hbcore.pas

Midas.dll全部源码

  Result := TDSBase.Create as IDSBase;
end;

function CreateDSBaseCursor(DSBase: IDSBase; var Cursor: IDSCursor): DBResult;
begin
  Cursor := TDSCursor.Create as IDSCursor;
  Result := Cursor.InitCursor(DSBase);
end;

function CreateDSCloneCursor(SourceCursor: IDSCursor; var Cursor: IDSCursor): DBResult;
begin
  Cursor := TDSCursor.Create as IDSCursor;
  Result := Cursor.CloneCursor(SourceCursor);
end;

function CreateDSWriter: IDSWriter;
begin
  Result := TDSWriter.Create as IDSWriter;
end;

function CompareInt64(const Value1, Value2: Int64): Integer;
asm
      MOV       ECX,DWORD PTR [Value1]
      MOV       EDX,DWORD PTR [Value1 + 4]
      XOR       EAX,EAX
@C1:  CMP       EDX,DWORD PTR [Value2]
      JG        @@G
      JL        @@L
@C2:  CMP       ECX,DWORD PTR [Value2 + 4]
      JB        @@L
      JE        @@Q
@@G:  INC       EAX
      JMP       @@Q
@@L:  DEC       EAX
@@Q:
end;

function CompareUInt64(const Value1, Value2: Int64): Integer;
asm
      MOV       ECX,DWORD PTR [Value1]
      MOV       EDX,DWORD PTR [Value1 + 4]
      XOR       EAX,EAX
@C1:  CMP       EDX,DWORD PTR [Value2]
      JA        @@G
      JB        @@L
@C2:  CMP       ECX,DWORD PTR [Value2 + 4]
      JB        @@L
      JE        @@Q
@@G:  INC       EAX
      JMP       @@Q
@@L:  DEC       EAX
@@Q:
end;

type
  TDSExprEvaluator = class(Tvg2ExprEvaluator)
  private
    FDSBase: TDSBase;
    FRecBuf: PChar;
    FiFldType: Integer;
    FiFldLen : Integer;
  protected
    function DoGetFieldValue(FieldNo: Word; const FieldName: string;
      var FldType, FldLen: Integer): Variant; override;
    procedure SetRecBuf(pRecBuf: PChar);
  public
    function EvaluteRec(pRecBuf: PChar): Boolean;
    property DSBase: TDSBase read FDSBase write FDSBase;
    property iFldType: Integer read FiFldType;
    property iFldLen: Integer read FiFldLen;
  end;

{ TDSExprEvaluator }
procedure TDSExprEvaluator.SetRecBuf(pRecBuf: PChar);
begin
  FRecBuf := pRecBuf;
end;

function TDSExprEvaluator.EvaluteRec(pRecBuf: PChar): Boolean;
begin
  SetRecBuf(pRecBuf);
  try
    Result := Evaluate(FiFldType, FiFldLen)
  except
    on ENotSupported do
      Result := False
    else
      Result := False;
  end;
end;

function TDSExprEvaluator.DoGetFieldValue(FieldNo: Word; const FieldName: string;
  var FldType, FldLen: Integer): Variant;
var
  S: string;
  W: WideString;
  TS: TTimeStamp;
begin
  with FDSBase.FFields[FieldNo - 1] do
  begin
    FldType := iFldType;
    FldLen  := iFldLen - ord((iFldType = fldZSTRING));

    if not Assigned(FRecBuf) or ((FRecBuf + iNullOffsInRec)^ <> Char(NOT_BLANK)) then
    begin
      Result := Null;
      Exit;
    end;

    case iFldType of
      fldZSTRING, fldBYTES, fldVARBYTES:
        Result := StrPas(FRecBuf + iFldOffsInRec);
      fldUNICODE:
        begin
          W := SysAllocStringLen(PWideChar(FRecBuf + iFldOffsInRec + 2), PWord(FRecBuf + iFldOffsInRec)^);
          Result := W;
          SysFreeString(PWideChar(W));
        end;
      fldINT16:
        Result := PSmallInt(FRecBuf + iFldOffsInRec)^ ;
      fldUINT16:
        Result := PWord(FRecBuf + iFldOffsInRec)^ ;
      fldINT32:
        Result := PInteger(FRecBuf + iFldOffsInRec)^ ;
      fldUINT32:
        Result := Integer(PDWord(FRecBuf + iFldOffsInRec)^);
      fldBOOL:
        Result := PWordBool(FRecBuf + iFldOffsInRec)^ ;
      fldFLOAT:
        Result := PDouble(FRecBuf + iFldOffsInRec)^ ;
      fldBCD:
        begin
          SetString(S, PChar(FRecBuf + iFldOffsInRec), SizeOf(FMTBCD));
          Result := S;
        end;
      fldDATE:
        begin
          TS.Date := PDateTimeRec(FRecBuf + iFldOffsInRec).Date;
          TS.Time := 0;
          Result := TimeStampToDateTime(TS);
          FldType := fldTIMESTAMP;
          FldLen := SizeOf(TDateTime);
        end;
      fldTIME:
        begin
          TS.Date := DateDelta;
          TS.Time := PDateTimeRec(FRecBuf + iFldOffsInRec).Time;
          Result := TimeStampToDateTime(TS);
          FldType := fldTIMESTAMP;
          FldLen := SizeOf(TDateTime);
        end;
      fldTIMESTAMP:
        begin
          Result := PDateTimeRec(FRecBuf + iFldOffsInRec).DateTime;
        end;
      fldINT64, fldUINT64:
        Result := Integer(PInt64(FRecBuf + iFldOffsInRec)^);
      fldBLOB, fldCURSOR, fldADT, fldArray, fldTABLE, fldREF:
        Result := Null;
    else
      HBError(DBERR_NOTSUPPORTED);
    end;
  end;
end;

{ TDSBase }
procedure TDSBase.Initialize;
var
  Index: DSIDXDesc;
begin
  inherited;
  FRecords := TList.Create;
  FCursors := TList.Create;
  FBlobs   := TList.Create;
  FChanges := TList.Create;
  FChangesDS := TList.Create;
  FChangesVL := TList.Create;

  ZeroMem(@Index, SizeOf(Index));
  StrCopy(Index.szName, szDEFAULT_ORDER);
  Index.bUnique := True;
  Check(CreateIndex(Index));

  StrCopy(Index.szName, szCHANGEINDEX);
  Index.bUnique := False;
  Check(CreateIndex(Index));
  Clear;
end;

destructor TDSBase.Destroy;
begin
  FCursor := nil;
  FMDCursor := nil;
  FAICursor := nil;
  Clear;
  FIndexes := nil;
  FRecords.Free;
  FCursors.Free;
  FBlobs.Free;
  FChanges.Free;
  FChangesDS.Free;
  FChangesVL.Free;
  inherited;
end;

procedure TDSBase.Clear;
var
  I: Integer;
begin
  FCursor := nil;
  FMDCursor := nil;
  FAICursor := nil;

  for I := FCursors.Count - 1 downto 0 do
    RemoveCursor(FCursors[I]);

  FreeAttrInfos(FAttrInfos);

  Reset;

  FName       := '';

  FRecBufSize := Reserved;

  FLogChanges := True;
  FReadOnly   := False;
  FStreamedReadOnly := False;

  FLCID       := LOCALE_USER_DEFAULT;

  FFields     := nil;
  FWFldDescs  := nil;

  FLinkFieldNo:= 0;
  FLinkFieldCreated := False;

  for I := 0 to High(FChilds) do
    FChilds[I] := nil;

  FChilds := nil;
  SetLength(FIndexes, 2);
end;

procedure TDSBase.CursorNeeded(var ACursor: IDSCursor);
begin
  if not Assigned(ACursor) then
    Check(CreateDSBaseCursor(Self as IDSBase, ACursor));
end;

function TDSBase.AcceptChanges: DBResult;
var
  I: Integer;
  P: PDeltaRec;
  Attr: DSAttr;
  DeltaRecs: TList;
begin
  try
    DeltaRecs := TList.Create;
    try

      GetDeltaRecords(nil, DeltaRecs);

      for I := 0 to High(FChilds) do
         FChilds[I].AcceptChanges;

      I := 0;
      DisableNotify;
      try
        while I < DeltaRecs.Count do
        begin
          P := DeltaRecs[I];
          Attr := P.RecAttr;
          {
          if P.RecAttr = dsRecUnmodified then
            Attr := dsRecModified else
            Attr := P.RecAttr;
          }
          if Attr = dsRecModified then
          begin
            MergeRecord(Attr, PDeltaRec(DeltaRecs[I - 1]).RecNo, P.pRecBuf, DeltaRecs);
          end else if (Attr = dsRecNew) or (Attr = dsRecDeleted) then
          begin
            MergeRecord(P.RecAttr, P.RecNo, nil, DeltaRecs);
          end;
          Inc(I);
        end;
      finally
        EnableNotify;
      end;
      NotifyCursors(ceNotify, 0, 0, 0);
    finally
      ListFreeMem(DeltaRecs, True);
    end;
    Result := DBERR_NONE;
  except
    Result := HandleExceptions;
  end;
end;

function TDSBase.Clone(iPType: DWord; bRecurse, bCloneOptParams: Bool; var DataSet: IDSBase): DBResult;

  procedure CloneOptParams(Source, Dest: TDSBase; Response: Boolean);
  var
    I: Integer;
  begin
    with Dest do
    begin
      for I := 0 to High(Source.FAttrInfos) do
        with Source.FAttrInfos[I] do
          AddOptAttribute(FAttrInfos, iFieldNo + DWord(ord(Response)) * 6, Attr, AttrType, Len, Value);

      for I := 0 to High(FChilds) do
        CloneOptParams(BaseFromIDS(Source.FChilds[I]), BaseFromIDS(FChilds[I]), Response);
    end;
  end;

var
  DSBase: TDSBase;
  TmpFields: DSFLDDescList;

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

var
  Response: Boolean;
begin
  try
    DSBase := TDSBase.Create;
    DataSet := DSBase as IDSBase;
    Response := FIsDelta and (iPType = 2);

    GetFieldDescList(TmpFields, bRecurse, Response);
    Check(DataSet.Create(Length(TmpFields), Pointer(TmpFields), nil));

    if bCloneOptParams then
      CloneOptParams(Self, DSBase, Response);

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

procedure TDSBase.CalcKeySize(var IndexDS: DSIDXDesc);
var
  I: Integer;
begin
  if not DefaultIndex(IndexDS.szName) then
    with IndexDS do
    begin
      iKeyLen := 0;
      for I := 0 to iFields - 1 do
        Inc(iKeyLen, FFields[iKeyFields[I] - 1].iFldLen);
    end;
end;

function TDSBase.ExtractKey(pRecBuf, pKeyBuf: PChar; const IndexDS: DSIDXDesc): DBResult;
var
  I: Integer;
  bBlank: Bool;
begin
  InitRecord(pKeyBuf);
  CopyRecord(pRecBuf, pKeyBuf);
  with IndexDS do
  begin
    for I := 0 to iFields - 1 do
      with FFields[iKeyFields[I]] do
      begin
        GetField(pRecBuf, I + 1, (pKeyBuf + iFldOffsInRec), bBlank);
        PutBlankInternal(pKeyBuf, I + 1, DWord(bBlank));
      end;
  end;
  Result := DBERR_NONE;
end;

function TDSBase.Create(iFields: DWord; pFldDes: pDSFLDDesc; pszName: PChar): DBResult;

  procedure DoAddField(BaseDS: TDSBase; ParentID: DWord; var DescNo: DWord;
    AddFldDesc: Boolean);
  var
    I, StartDescNo, Parent: DWord;
    FldDes: pDSFLDDesc;
    FldDesc: DSFLDDesc;
    Child: TDSBase;
  begin
    FldDes := @DSFLDDescList(pFldDes)[DescNo];
    BaseDS.AddFieldInternal(ParentID, FldDes, True);
    Inc(DescNo);
    with FldDes^ do
      if iFldType = fldADT then
      begin
        Parent := High(BaseDS.FFields) + 1;
        for I := 1 to iUnits1 do
          DoAddField(BaseDS, Parent, DescNo, AddFldDesc)
      end else if iFldType = fldARRAY then
      begin
        Parent := High(BaseDS.FFields) + 1;
        StartDescNo := DescNo;
        for I := 1 to iUnits1 do
        begin
          DescNo := StartDescNo;
          DoAddField(BaseDS, Parent, DescNo, (I = 1) and AddFldDesc);
        end;
      end else if iFldType = fldTABLE then
      begin
        with BaseDS do
          Child := BaseFromIDS(FChilds[High(FChilds)]);
        for I := 1 to iUnits1 do
          DoAddField(Child, 0, DescNo, True);
        if Child.FLinkFieldNo = 0 then
        begin
          InitLinkField(FldDesc);
          Child.AddFieldInternal(0, @FldDesc, False);
        end;
      end;
  end;

var
  I: DWord;
begin