dbclient.pas

多数代码可以直接在Delphi6和Delphi7环境下运行。部分涉及.NET技术内容的代码

      with Params[I] do
        if ParamType in Types then
        begin
          Result[Idx] := VarArrayOf([Name, Value, Ord(DataType), Ord(ParamType)]);
          Inc(Idx);
        end;
  end;
end;

procedure UnpackParams(const Source: OleVariant; Dest: TParams);
var
  TempParams: TParams;
  i: Integer;
begin
  if not VarIsNull(Source) and VarIsArray(Source) and VarIsArray(Source[0]) then
  begin
    TempParams := TParams.Create;
    try
      for i := 0 to VarArrayHighBound(Source, 1) do
      begin
        with TParam(TempParams.Add) do
        begin
          if VarArrayHighBound(Source[i], 1) > 1 then
            DataType := TFieldType(Source[i][2]);
          if VarArrayHighBound(Source[i], 1) > 2 then
            ParamType := TParamType(Source[i][3]);
          Name := Source[i][0];
          Value := Source[i][1];
        end;
      end;
      Dest.Assign(TempParams);
    finally
      TempParams.Free;
    end;
  end;
end;

{ TCustomRemoteServer }

constructor TCustomRemoteServer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
end;

function TCustomRemoteServer.GetServerList: OleVariant;
begin
  Result := NULL;
end;

function TCustomRemoteServer.GetServer: IAppServer;
begin
  Result := nil;
end;

procedure TCustomRemoteServer.GetProviderNames(Proc: TGetStrProc);
var
  List: Variant;
  I: Integer;
begin
  Connected := True;
  VarClear(List);
  try
    List := AppServer.AS_GetProviderNames;
  except
    { Assume any errors means the list is not available. }
  end;
  if VarIsArray(List) and (VarArrayDimCount(List) = 1) then
    for I := VarArrayLowBound(List, 1) to VarArrayHighBound(List, 1) do
      Proc(List[I]);
end;

function TCustomRemoteServer.GetAppServer: Variant;
begin
  Result := FAppServer;
end;

procedure TCustomRemoteServer.SetAppServer(Value: Variant);
begin
  FAppServer := Value;
end;

{ TCustomClientDataSet }

constructor TCustomClientDataSet.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FMasterLink := TMasterDataLink.Create(Self);
  FMasterLink.OnMasterChange := MasterChanged;
  FMasterLink.OnMasterDisable := MasterDisabled;
  FPacketRecords := AllRecords;
  FFetchOnDemand := True;
  FParams := TParams.Create(Self);
  FAggregates := TAggregates.Create(Self);
  FActiveAggLists := TList.Create;
  FOpeningFile := False;
  FDisableStringTrim := False;
  ObjectView := True;
end;

destructor TCustomClientDataSet.Destroy;
begin
  FSavePacketOnClose := False;
  inherited Destroy;
  ClearSavedPacket;
  FreeDataPacket(FDeltaPacket);
  SetRemoteServer(nil);
  SetConnectionBroker(nil);
  AppServer := nil;
  FMasterLink.Free;
  FIndexDefs.Free;
  FParams.Free;
  FAggregates.Free;
  ClearActiveAggs;
  FActiveAggLists.Free;
  FAggFieldsUpdated.Free;
end;

function TCustomClientDataSet.CreateDSBase: IDSBase;
begin
  CreateDbClientObject(CLSID_DSBase, IDSBase, Result);
end;

function TCustomClientDataSet.CreateDSCursor(SourceCursor: IDSCursor): IDSCursor;
begin
  CreateDbClientObject(CLSID_DSCursor, IDSCursor, Result);
  if Assigned(SourceCursor) then
    Check(Result.CloneCursor(SourceCursor)) else
    Check(Result.InitCursor(FDSBase));
end;

procedure TCustomClientDataSet.SetCommandText(Value: String);
var
  SQL: String;
  List: TParams;
begin
  if FCommandText <> Value then
  begin
    FCommandText := Value;
    if Value <> '' then
    begin
      List := TParams.Create(Self);
      try
        SQL := copy(Value, 1, Length(Value));
        List.ParseSQL(SQL, True);
        List.AssignValues(FParams);
        FParams.Clear;
        FParams.Assign(List);
      finally
        List.Free;
      end;
    end else
      FParams.Clear;
  end;
end;

procedure TCustomClientDataSet.SetDisableStringTrim(Value: Boolean);
begin
  CheckInactive;
  FDisableStringTrim := Value;
end;

procedure TCustomClientDataSet.SetParams(Value: TParams);
begin
  FParams.Assign(Value);
end;

procedure TCustomClientDataSet.SetOptionalParam(const ParamName: string;
  const Value: OleVariant; IncludeInDelta: Boolean);
const
  ParamTypeMap: array[varSmallInt..varInt64] of Integer =
    ( dsfldINT, dsfldINT, dsfldFLOATIEEE, dsfldFLOATIEEE, dsfldBCD,
      dsfldFLOATIEEE, dsfldZSTRING, 0, 0, dsfldBOOL, 0, 0, 0, 0, 0, dsfldINT,
      dsfldINT, dsfldINT, dsfldFLOATIEEE);
  ParamTypeSize: array[varSmallInt..varInt64] of Integer =
    ( SizeOf(SmallInt), SizeOf(Integer), SizeOf(Single), SizeOf(Double),
      SizeOf(Currency), SizeOf(TDateTime), 0, 0, 0, SizeOf(WordBool), 0, 0, 0,
      0, 0, SizeOf(Byte), SizeOf(SmallInt), SizeOf(Integer), SizeOf(Int64));
var
  ParamType, ParamLen, t, l: DWord;
  S: string;
  P: Pointer;
  Unlock: Boolean;
  V, Name: Pointer;
  TimeStampRec: TSQLTimeStamp;
  FByteBuffer: array of Byte;
begin
  CheckActive;
  if ((VarType(Value) and varTypeMask) in [varSmallInt, varInteger, varSingle,
      varDouble, varCurrency, varDate, varOleStr, varBoolean, varByte, varWord,
      varLongWord, varInt64]) and
     ((not VarIsArray(Value)) or (VarType(Value) and varTypeMask = varByte)) then
  begin
    Unlock := False;
    try
      ParamType := ParamTypeMap[VarType(Value) and varTypeMask];
      ParamLen := ParamTypeSize[VarType(Value) and varTypeMask];
      if varType(Value) = varOleStr then
      begin
        if TryStrToSqlTimeStamp(String(Variant(Value)), TimeStampRec) then
        begin
          ParamType := dsfldTIMESTAMP;
          ParamLen := sizeof(TSQLTimeStamp);
        end;
      end;
      if ParamType = dsfldZSTRING then
      begin
        S := Value;
        P := PChar(S);
        ParamLen := Length(S) + 1;
      end else
      if VarIsArray(Value) then
      begin
        ParamType := dsfldBYTES;
        ParamLen := 1 + (VarArrayHighBound(Value, 1) - VarArrayLowBound(Value, 1));
        SetLength(FByteBuffer,ParamLen+sizeof(Integer));
        PInteger(FByteBuffer)^ := ParamLen;
        P := VarArrayLock(Value);
        try
          Move(P^, FByteBuffer[SizeOf(Integer)], ParamLen);
          Inc(ParamLen, SizeOf(Integer));
        finally
          VarArrayUnlock(Value);
        end;
        P := FByteBuffer;
      end else
      if (VarType(Value) and varByRef) = varByRef then
        P := TVarData(Value).VPointer else
        P := @TVarData(Value).VPointer;
      ParamType := ParamType shl dsSizeBitsLen or ParamLen;
      if IncludeInDelta then
        ParamType := ParamType or dsIncInDelta;
      Name := PChar(ParamName);
      if FDSBase.GetOptParameter(0, 0, Name, t, l, v) = 0 then
        Check(FDSBase.DropOptParameter(0, PChar(ParamName)));
      Check(FDSBase.AddOptParameter(0, PChar(ParamName), ParamType, ParamLen, P));
    finally
      if Unlock then
        VarArrayUnlock(Value);
    end;
  end else
    DatabaseError(SInvalidOptParamType, Self);
end;

function TCustomClientDataSet.GetOptionalParam(const ParamName: string): OleVariant;
begin
  Result := InternalGetOptionalParam(ParamName);
end;

function TCustomClientDataSet.InternalGetOptionalParam(const ParamName: string;
  FieldNo: Integer = 0): OleVariant;
var
  ParamType, ParamLen: DWord;
  Name: PChar;
  Value, P: Pointer;
  S: string;
begin
  if not Assigned(FDSBase) then CheckActive;
  VarClear(Result);
  Name := PChar(ParamName);
  if FDSBase.GetOptParameter(0, FieldNo, Pointer(Name), ParamType,
    ParamLen, Value) <> 0 then Exit;
  ParamType := (ParamType and dsTypeBitsMask) shr dsSizeBitsLen;
  if (ParamType = dsfldBYTES) or
     ((ParamType in [dsfldINT, dsfldUINT]) and (ParamLen > 4 )) then
    begin
      Result := VarArrayCreate([0, ParamLen-sizeof(Integer)], varByte);
      P := VarArrayLock(Result);
      try
        Move((PChar(Value) + SizeOf(Integer))^, P^, ParamLen-SizeOf(Integer));
      finally
        VarArrayUnlock(Result);
      end;
    end else
    begin
      case ParamType of
        dsfldINT,
        dsfldUINT:
        begin
          case ParamLen of
            1: Result := Byte(Value^);
            2: Result := SmallInt(Value^);
            4: Result := Integer(Value^);
          end;
        end;
        dsfldBOOL: Result := WordBool(Value^);
        dsfldFLOATIEEE: Result := Double(Value^);
        dsfldBCD: Result := Currency(Value^);
        dsfldDATE: Result := TDateTimeRec(Value^).Date - DateDelta;
        dsfldTIME: Result := TDateTimeRec(Value^).Time / MSecsPerDay;
        dsfldTIMESTAMP: Result := (TDateTimeRec(Value^).DateTime / MSecsPerDay) - DateDelta;
        dsfldDATETIME: Result := VarSQLTimeStampCreate(TSQLTimeStamp(Value^));
        dsfldZSTRING:
        begin
          SetString(S, PChar(Value), ParamLen-1);
          Result := S;
        end;
        else
          VarClear(Result);
      end;
    end;
end;

procedure TCustomClientDataSet.OpenCursor(InfoQuery: Boolean);

  procedure CheckCircularLinks;
  var
    ProvComp: TComponent;
  begin
    if Assigned(MasterSource) and Assigned(Owner) and (not Assigned(RemoteServer))
       and (ProviderName <> '') and (not Assigned(ConnectionBroker)) then
    begin
      ProvComp := Owner.FindComponent(ProviderName);
      if Assigned(ProvComp) and (ProvComp is TDataSetProvider) and
                 Assigned(MasterSource.DataSet) and
                 Assigned(TDataSetProvider(ProvComp).DataSet)  then
        if TDataSetProvider(ProvComp).DataSet = MasterSource.DataSet then
          DatabaseError(SCircularDataLink, MasterSource.DataSet);
    end;
  end;

var
  RecsOut: Integer;
  Options: TGetRecordOptions;
  DataPacket: TDataPacket;
  Stream: TFileStream;
begin
  FProviderEOF := True;
  FSavePacketOnClose := False;
  CheckCircularLinks;
  if not FOpeningFile and (FileName <> '') and FileExists(FileName) then
  begin
    Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
    try
      ReadDataPacket(Stream, False);
    finally
      Stream.Free;
    end;
  end;
  if DataSetField <> nil then
  begin
    FParentDataSet := DataSetField.DataSet as TCustomClientDataSet;
    OpenParentDataSet(FParentDataSet);
    Check(FParentDataSet.DSBase.GetEmbeddedDS(DataSetField.FieldNo, FDSBase));
    FieldDefs.HiddenFields := FParentDataSet.FieldDefs.HiddenFields;
  end
  else if not Assigned(FDSBase) then
  begin
    if Assigned(FSavedPacket) then DataPacket := FSavedPacket else
    begin
      Options := [grMetaData];
      DataPacket := VarToDataPacket(DoGetRecords(FPacketRecords, RecsOut,
        Byte(Options), CommandText, PackageParams(Params)));
      ProviderEOF := RecsOut <> FPacketRecords;
    end;
    if not Assigned(DataPacket) then DatabaseError(SNoDataProvider, Self);
    FDSBase := CreateDSBase;
    Check(FDSBase.AppendData(DataPacket, ProviderEOF));
  end;
  inherited OpenCursor(InfoQuery);
  if not InfoQuery and Assigned(FCloneSource) and not FCloneSource.BOF then
  begin
    SyncCursors(FDSCursor, FCloneSource.FDSCursor);
    CursorPosChanged;
    Resync([]);
  end;
  { DSBase now has the data packet so we don't need to hold on to it }
  ClearSavedPacket;
  FSavePacketOnClose := True;
end;

procedure TCustomClientDataSet.DoAfterGetParams(var OwnerData: OleVariant);
begin
  if Assigned(FAfterGetParams) then FAfterGetParams(Self, OwnerData);
end;

procedure TCustomClientDataSet.DoBeforeGetParams(var OwnerData: OleVariant);
begin
  if Assigned(FBeforeGetParams) then FBeforeGetParams(Self, OwnerData);
end;

procedure TCustomClientDataSet.FetchParams;
var
  OwnerData: OleVariant;