hbcore.pas

Midas.dll全部源码

  try
    Clear;
    if Assigned(pszName) then
      FName := StrPas(pszName);

    I := 0;
    while I < iFields do
      DoAddField(Self, 0, I, True);

    Result := DBERR_NONE;
  except
    Clear;
    Result := HandleExceptions;
  end;
end;

procedure TDSBase.GetFieldDescList(var AFields: DSFLDDescList; Recurse, Response: Boolean);

  procedure DoAddFieldDesc(var FieldNo: Integer; AddFldDesc: Boolean);
  var
    I: Integer;
    Child: TDSBase;
  begin
    if AddFldDesc then
    begin
      AddFieldDesc(AFields, FFields[FieldNo]);
      if Response then
        with AFields[High(AFields)] do
          iFldAttr := iFldAttr and not (fldAttrREQUIRED or fldAttrREADONLY);
    end;

    Inc(FieldNo);
    with FFields[FieldNo - 1] do
      case iFldType of
        fldADT:
          begin
            for I := 1 to iUnits1 do
              DoAddFieldDesc(FieldNo, AddFldDesc);
          end;
        fldARRAY:
          begin
            for I := 1 to iUnits1 do
              DoAddFieldDesc(FieldNo, (I = 1) and AddFldDesc);
          end;
        fldTABLE:
          begin
            if Recurse and AddFldDesc then
            begin
              Child := GetEmbeddedDSBase(FieldNo);
              Inc(AFields[High(AFields)].iUnits1, ord(Response) * 6);
              Child.GetFieldDescList(AFields, Recurse, Response);
            end;
          end;
      end;
  end;

  procedure AddField(Index: Integer; pName: PChar; FieldType: Integer; Len: DWord);
  begin
    StrCopy(AFields[Index].szName, pName);
    AFields[Index].iFldType := FieldType;
    AFields[Index].iUnits1 := Len;
  end;

var
  FieldNo, Start: Integer;
begin
  if Response then
  begin
    Start := Length(AFields);
    SetLength(AFields, Start + 6);
    AddField(Start + 0, 'ERROR_RECORDNO', fldINT32,   0);
    AddField(Start + 1, 'ERROR_RESPONSE', fldINT32,   0);
    AddField(Start + 2, 'ERROR_MESSAGE',  fldZSTRING, MAXMSGLEN + 1);
    AddField(Start + 3, 'ERROR_CONTEXT',  fldZSTRING, MAXMSGLEN + 1);
    AddField(Start + 4, 'ERROR_CATEGORY', fldINT32,   0);
    AddField(Start + 5, 'ERROR_CODE',     fldINT32,   0);
  end;

  FieldNo := 0;
  while FieldNo <= High(FFields) do
    DoAddFieldDesc(FieldNo, True);
end;

procedure TDSBase.AddFieldInternal(ParentID: Word; pFldDes: pDSFLDDesc;
  CreateEmbedded: Boolean);
var
  I, J: Integer;
begin
  if Assigned(pFldDes) then
  begin
    AddFieldDesc(FFields, pFldDes^);

    FFields[High(FFields)].iFieldIDParent := ParentID;

    case pFldDes^.iFldType of
      fldUNKNOWN:
        HBError(DBERR_NOTSUPPORTED);
      fldZSTRING:
        FFields[High(FFields)].iFldLen := FFields[High(FFields)].iUnits1 + 1;
      fldUNICODE:
        FFields[High(FFields)].iFldLen := FFields[High(FFields)].iUnits1 * 2 + 2;
      fldINT16, fldUINT16:
        begin
          FFields[High(FFields)].iFldLen := SizeOf(SmallInt);
          FFields[High(FFields)].iUnits1 := SizeOf(SmallInt);
        end;
      fldINT32, fldUINT32:
        begin
          FFields[High(FFields)].iFldLen := SizeOf(Integer);
          FFields[High(FFields)].iUnits1 := SizeOf(Integer);
        end;
      fldBOOL:
        begin
          FFields[High(FFields)].iFldLen := SizeOf(WordBool);
          FFields[High(FFields)].iUnits1 := SizeOf(WordBool);
        end;
      fldFLOAT:
        begin
          FFields[High(FFields)].iFldLen := SizeOf(Double);
          FFields[High(FFields)].iUnits1 := SizeOf(Double);
        end;
      fldBCD:
         FFields[High(FFields)].iFldLen := SizeOf(FMTBCD);
      fldDATE, fldTIME:
        begin
          FFields[High(FFields)].iFldLen := SizeOf(Integer);
          FFields[High(FFields)].iUnits1 := SizeOf(Integer);
        end;
      fldTIMESTAMP:
        begin
          FFields[High(FFields)].iFldLen := SizeOf(Double);
          FFields[High(FFields)].iUnits1 := SizeOf(Double);
        end;
      fldBYTES, fldVARBYTES:
        FFields[High(FFields)].iFldLen := FFields[High(FFields)].iUnits1;
      fldBLOB:
        begin
          FFields[High(FFields)].iFldLen := SizeOf(TBlobData);
        end;
      fldCURSOR:
        HBError(DBERR_NOTSUPPORTED);
      fldINT64, fldUINT64:
        begin
          FFields[High(FFields)].iFldLen := SizeOf(Int64);
          FFields[High(FFields)].iUnits1 := SizeOf(Int64);
        end;
      fldADT, fldArray:
        begin
          FFields[High(FFields)].iFldLen := 0;
        end;
      fldTABLE:
        begin
          FFields[High(FFields)].iFldLen := SizeOf(DWord);
          if CreateEmbedded then
            CreateEmbeddedDS(High(FFields));
        end;
    else
      HBError(DBERR_NOTSUPPORTED);
    end;

    if (pFldDes.iFldAttr and fldAttrLink) <> 0 then
      FLinkFieldNo := Length(FFields);

    if High(FFields) = 0 then
    begin
      FFields[0].iNullOffsInRec := Reserved;
      FFields[0].iFldOffsInRec  := Reserved + SizeOf(Char);
    end else begin
      I := High(FFields) - 1;
      J := FFields[I].iFldOffsInRec + FFields[I].iFldLen;
      FFields[High(FFields)].iNullOffsInRec := J;
      FFields[High(FFields)].iFldOffsInRec  := J + SizeOf(Char);
    end;
    Inc(FRecBufSize, SizeOf(Char) + FFields[High(FFields)].iFldLen);
  end else
    Clear;
end;

function TDSBase.AddField(pFldDes: pDSFLDDesc): DBResult;
begin
  try
    AddFieldInternal(0, pFldDes, True);
    Result := DBERR_NONE;
  except
    Result := HandleExceptions;
  end;
end;

procedure TDSBase.CheckInactiveIndex(szName: PChar);
var
  I: Integer;
begin
  if DefaultIndex(szName) then
    HBError(DBERR_ACTIVEINDEX)
  else begin
    for I := 0 to FCursors.Count - 1 do
      if (StrIComp(TDSCursor(FCursors[I]).FIndexDS.szName, szName) = 0) then
        HBError(DBERR_ACTIVEINDEX);
  end;
end;

procedure TDSBase.GetIndexDesc(IndexNo: DWord; p1: PDSIDXDesc);
begin
  Move(FIndexes[IndexNo], p1^, SizeOf(DSIDXDesc));
end;

function TDSBase.FindIndex(pszName: PChar): Integer;
var
  Tmp: string;
begin
  Tmp := StrPas(pszName);
  for Result := 0 to Length(FIndexes) - 1 do
    if CompareText(Tmp, FIndexes[Result].szName) = 0 then Exit;
  Result := -1;
end;

procedure TDSBase.UpdateLinkedIndex(var IdxDesc: DSIDXDesc);
begin
  with FIndexes[High(FIndexes)] do
    if (iFields > 0) and (iKeyFields[0] <> Integer(FLinkFieldNo)) then
    begin
      Move(iKeyFields[0], iKeyFields[1], iFields * SizeOf(iKeyFields[0]));
      iKeyFields[0] := FLinkFieldNo;
      Inc(iFields);
    end;
end;

function TDSBase.CreateIndex(const IdxDesc: DSIDXDesc): DBResult;
var
  I: Integer;
begin
  try
    if IdxDesc.szName <> nil then
    begin
      I := FindIndex(IdxDesc.szName);
      if I < 0 then
      begin
        SetLength(FIndexes, Length(FIndexes) + 1);
        Move(IdxDesc, FIndexes[High(FIndexes)], SizeOf(DSIDXDesc));
        if Assigned(FParentDS) then
          UpdateLinkedIndex(FIndexes[High(FIndexes)]);
        CalcKeySize(FIndexes[High(FIndexes)]);
        Result := DBERR_NONE;
      end else
        Result := DBERR_NAMENOTUNIQUE;
    end else
      Result := DBERR_INDEXNAMEREQUIRED;
  except
    Result := HandleExceptions;
  end;
end;

function TDSBase.FldCmpEx(iFldType: DWord; pFld1, pFld2: Pointer; iUnits1,
  iUnits2: DWord; CaseIns: Bool): Integer;

const
  Cases: array[Boolean] of Integer = (SORT_STRINGSORT, SORT_STRINGSORT or NORM_IGNORECASE);

var
  I1, I2: Integer;
  W1, W2: DWord;
  I641, I642: Int64;
  B1, B2: WordBool;
  D1, D2: Double;
  F1, F2: Double;
begin
  if (pFld1 <> nil) and (pFld2 = nil) then
  begin
    Result := 1;
    Exit;
  end else if (pFld1 = nil) and (pFld2 <> nil) then
  begin
    Result := -1;
    Exit;
  end else if (pFld1 = nil) and (pFld2 = nil) then
  begin
    Result := 0;
    Exit;
  end;

  case iFldType of
    fldZSTRING, fldBYTES, fldVARBYTES:
      begin
        Result := CompareString(FLCID, Cases[CaseIns], pFld1, -1, pFld2, -1) - 2;
      end;
    fldUNICODE:
      begin
        Result := CompareStringW(FLCID, Cases[CaseIns],
          PWideChar(PChar(pFld1) + 2), PWord(pFld1)^,
          PWideChar(PChar(pFld2) + 2), PWord(pFld2)^) - 2;
      end;
    fldINT16:
      begin
        I1 := PSmallint(pFld1)^;
        I2 := PSmallint(pFld2)^;
        if I1 > I2 then Result :=  1 else
        if I1 < I2 then Result := -1 else Result := 0;
      end;
    fldUINT16:
      begin
        W1 := PWord(pFld1)^;
        W2 := PWord(pFld2)^;
        if W1 > W2 then Result :=  1 else
        if W1 < W2 then Result := -1 else Result := 0;
      end;
    fldINT32:
      begin
        I1 := PInteger(pFld1)^;
        I2 := PInteger(pFld2)^;
        if I1 > I2 then Result :=  1 else
        if I1 < I2 then Result := -1 else Result := 0;
      end;
    fldUINT32:
      begin
        W1 := PDWord(pFld1)^;
        W2 := PDWord(pFld2)^;
        if W1 > W2 then Result :=  1 else
        if W1 < W2 then Result := -1 else Result := 0;
      end;
    fldBOOL:
      begin
        B1 := PWordBool(pFld1)^;
        B2 := PWordBool(pFld2)^;
        if B1 > B2 then Result :=  1 else
        if B1 < B2 then Result := -1 else Result := 0;
      end;
    fldFLOAT:
      begin
        F1 := PDouble(pFld1)^;
        F2 := PDouble(pFld2)^;
        if F1 > F2 then Result :=  1 else
        if F1 < F2 then Result := -1 else Result := 0;
      end;
    fldBCD:
      begin
        Result := CompareFMTBCD(pFMTBcd(pFld1)^, pFMTBcd(pFld2)^);
      end;
    fldDATE:
      begin
        W1 := PDateTimeRec(pFld1)^.Date;
        W2 := PDateTimeRec(pFld2)^.Date;
        if W1 > W2 then Result :=  1 else
        if W1 < W2 then Result := -1 else Result := 0;
      end;
    fldTIME:
      begin
        W1 := PDateTimeRec(pFld1)^.Time;
        W2 := PDateTimeRec(pFld2)^.Time;
        if W1 > W2 then Result :=  1 else
        if W1 < W2 then Result := -1 else Result := 0;
      end;
    fldTIMESTAMP:
      begin
        D1 := PDateTimeRec(pFld1)^.DateTime;
        D2 := PDateTimeRec(pFld2)^.DateTime;
        if D1 > D2 then Result :=  1 else
        if D1 < D2 then Result := -1 else Result := 0;
      end;
    fldINT64:
      begin
        I641 := PInt64(pFld1)^;
        I642 := PInt64(pFld2)^;
        Result := CompareInt64(I641, I642);
      end;
    fldUINT64:
      begin
        I641 := PInt64(pFld1)^;
        I642 := PInt64(pFld2)^;
        Result := CompareUInt64(I641, I642);
      end;
    else
      Result := 0;
  end;
end;

function TDSBase.FldCmp(iFldType: DWord; pFld1, pFld2: Pointer; iUnits1,
  iUnits2: DWord): Integer;
begin
  Result := FldCmpEx(iFldType, pFld1, pFld2, iUnits1, iUnits2, False)
end;

function TDSBase.CmpRecsEx(IndexDS: pDSIDXDesc; iFields, iPartLen: Integer; pRec1, pRec2: PChar): Integer;
var
  I, I1, I2: Integer;
  pFld1, pFld2: PChar;
begin
  Result := 0;
  if pRec1 = pRec2 then Exit;

  if not Assigned(IndexDS) then
  begin
    I1 := GetRecordRecNo(pRec1);
    I2 := GetRecordRecNo(pRec2);
    if I1 > I2 then Result :=  1 else
    if I1 < I2 then Result := -1 else Result := 0;
    Exit;
  end;

  if (iFields = 0) or (iFields > IndexDS.iFields) then
    iFields := IndexDS.iFields;

  for I := 0 to iFields - 1 do
  begin
    with FFields[IndexDS.iKeyFields[I] - 1] do
    begin
      if (pRec1 + iNullOffsInRec)^ = Char(NOT_BLANK) then
        pFld1 := pRec1 + iFldOffsInRec else
        pFld1 := nil;

      if (pRec2 + iNullOffsInRec)^ = Char(NOT_BLANK) then
        pFld2 := pRec2 + iFldOffsInRec else
        pFld2 := nil;

      if iPartLen = 0 then
        Result := FldCmpEx(iFldType, pFld1, pFld2, iFldLen, iFldLen, IndexDS.bCaseInsensitive[I]) else
        Result := FldCmpEx(iFldType, pFld1, pFld2, iPartLen, iPartLen, IndexDS.bCaseInsensitive[I]);
    end;

    if Result <> 0 then
    begin
      if IndexDS.bDescending[I] then
        Result := - Result;
      Break;
    end;