dbclient.pas

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

{ *************************************************************************** }
{                                                                             }
{ Kylix and Delphi Cross-Platform Visual Component Library                    }
{                                                                             }
{ Copyright (c) 1997, 2001 Borland Software Corporation                       }
{                                                                             }
{ *************************************************************************** }


unit DBClient;

{$R-,T-,H+,X+}

interface
{$IFDEF MSWINDOWS}
uses Windows, SysUtils, VarUtils, Variants, Classes, DB, DSIntf, DBCommon, Midas, SqlTimSt, ActiveX;
{$ENDIF}
{$IFDEF LINUX}
uses Libc, SysUtils, VarUtils, Variants, Classes, DB, DSIntf, DBCommon, Midas, SqlTimSt;
{$ENDIF}

type

{ Exceptions }

  EDBClient = class(EDatabaseError)
  private
    FErrorCode: DBResult;
  public
    constructor Create(Message: string; ErrorCode: DBResult);
    property ErrorCode: DBResult read FErrorCode;
  end;

  EReconcileError = class(EDBClient)
  private
    FContext: string;
    FPreviousError: DBResult;
  public
    constructor Create(NativeError, Context: string;
      ErrorCode, PreviousError: DBResult);
    property Context: string read FContext;
    property PreviousError: DBResult read FPreviousError;
  end;

{ TCustomRemoteServer }

  TCustomClientDataSet = class;
  TClientDataSet = class;

  TGetUsernameEvent = procedure(Sender: TObject; var Username: string) of object;

  TCustomRemoteServer = class(TCustomConnection)
  private
    FAppServer: Variant;
    FOnGetUsername: TGetUsernameEvent;
  protected
    function GetAppServer: Variant; virtual;
    procedure SetAppServer(Value: Variant); virtual;
    function GetServerList: OleVariant; virtual;
    procedure GetProviderNames(Proc: TGetStrProc); virtual;
    property OnGetUsername: TGetUsernameEvent read FOnGetUsername write FOnGetUsername;
  public
    constructor Create(AOwner: TComponent); override;
    function GetServer: IAppServer; virtual;
    property AppServer: Variant read GetAppServer;
  end;

{ TConnectionBroker }

  TConnectionBroker = class(TCustomRemoteServer)
  private
    FConnection: TCustomRemoteServer;
{$IFDEF MSWINDOWS}
    FStreamedConnected: Boolean;
{$ENDIF}
    procedure SetConnection(const Value: TCustomRemoteServer);
  protected
{$IFDEF MSWINDOWS}
    function GetAppServer: Variant; override;
    function GetConnected: Boolean; override;
    procedure Loaded; override;
{$ENDIF}
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure SetConnected(Value: Boolean); override;
  public
    constructor Create(AOwner: TComponent); override;
    function GetServer: IAppServer; override;
  published
    property Connected;
    property Connection: TCustomRemoteServer read FConnection write SetConnection;
    property LoginPrompt default False;
    property AfterConnect;
    property AfterDisconnect;
    property BeforeConnect;
    property BeforeDisconnect;
    property OnGetUsername;
    property OnLogin;
  end;

{ TAggregate }

  TAggregate = class;
  TAggregates = class;
  TAggUpdateEvent = procedure(Agg: TAggregate) of object;

  TAggregate = class(TCollectionItem)
  private
    FExpression: string;
    FFldDesc: DSFLDDesc;
    FHAggregate: hDSAggregate;
    FAggregateName: String;
    FGroupingLevel: Integer;
    FDataSet: TCustomClientDataSet;
    FIndexName: string;
    FDataBuffer: Array of Byte;
    FDataType: TFieldType;
    FDataSize: Integer;
    FDependentFields: TBits;
    FRecBufOfs: Integer;
    FInUse: Boolean;
    FActive: Boolean;
    FVisible: Boolean;
    FOutOfDate: Boolean;
    FOnUpdate: TAggUpdateEvent;
    procedure SetActive(Value: Boolean);
    procedure SetExpression(const Text: string);
    procedure SetGroupingLevel(GroupingLevel: Integer);
    procedure SetIndexName(Value: String);
  protected
    procedure Activate;
    property DependentFields: TBits read FDependentFields;
    property RecBufOfs: Integer read FRecBufOfs write FRecBufOfs;
  public
    constructor Create(Aggregates: TAggregates; ADataSet: TCustomClientDataSet); reintroduce; overload;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function GetDisplayName: string; override;
    function Value: Variant;
    property AggHandle: hDSAggregate read FHAggregate write FHAggregate;
    property InUse: Boolean read FInUse write FInUse default false;
    property DataSet: TCustomClientDataSet read FDataSet;
    property DataSize: Integer read FDataSize;
    property DataType: TFieldType read FDataType;
  published
    property Active: Boolean read FActive write SetActive default False;
    property AggregateName: String read FAggregateName write FAggregateName;
    property Expression: string read FExpression write SetExpression;
    property GroupingLevel: Integer read FGroupingLevel write SetGroupingLevel default 0;
    property IndexName: string read FIndexName write SetIndexName;
    property Visible: Boolean read FVisible write FVisible default True;
    property OnUpdate: TAggUpdateEvent read FOnUpdate write FOnUpdate;
  end;

{ TAggregates }

  TAggregates = class(TCollection)
  private
    FOwner: TPersistent;
    function GetItem(Index: Integer): TAggregate;
    procedure SetItem(Index: Integer; Value: TAggregate);
  protected
    function GetOwner: TPersistent; override;
  public
    constructor Create(Owner: TPersistent);
    function Add: TAggregate;
    procedure Clear;
    function Find(const DisplayName: string): TAggregate;
    function IndexOf(const DisplayName: string): Integer;
    property Items[Index: Integer]: TAggregate read GetItem write SetItem; default;
  end;

{ TClientDataSet }

  TFieldDescList = array of DSFLDDesc;

  TKeyIndex = (kiLookup, kiRangeStart, kiRangeEnd, kiCurRangeStart,
    kiCurRangeEnd, kiSave);

  PRecInfo = ^TRecInfo;
  TRecInfo = packed record
    RecordNumber: Longint;
    BookmarkFlag: TBookmarkFlag;
    Attribute: DSAttr;
  end;

  PKeyBuffer = ^TKeyBuffer;
  TKeyBuffer = record
    Modified: Boolean;
    Exclusive: Boolean;
    FieldCount: Integer;
    Data: record end;
  end;

  TDataPacketFormat = (dfBinary, dfXML, dfXMLUTF8);

  TReconcileAction = (raSkip, raAbort, raMerge, raCorrect, raCancel, raRefresh);
  TReconcileErrorEvent = procedure(DataSet: TCustomClientDataSet; E: EReconcileError;
    UpdateKind: TUpdateKind; var Action: TReconcileAction) of object;
  TRemoteEvent = procedure(Sender: TObject; var OwnerData: OleVariant) of object;

  TReconcileInfo = record
    DataSet: TDataSet;
    UpdateKind: TUpdateKind;
    ReconcileError: EReconcileError;
    ActionRef: ^TReconcileAction;
  end;

  TDataSetOption = (doDisableInserts, doDisableDeletes, doDisableEdits, doNoResetCall);
  TDataSetOptions = set of TDataSetOption;

  TFetchOption = (foRecord, foBlobs, foDetails);
  TFetchOptions = set of TFetchOption;

  TCustomClientDataSet = class(TDataSet)
  private
    FActiveAggLists: TList;
    FAggFieldsUpdated: TBits;
    FAggFieldsInit: Boolean;
    FAggFieldsSize: Integer;
    FAggGrpIndOfs: Integer;
    FAggFieldsOfs: Integer;
    FAggGrpIndSize: Integer;
    FAggregates: TAggregates;
    FAggregatesActive: Boolean;
    FCommandText: string;
    FDisableStringTrim: Boolean;
    FDSBase: IDSBase;
    FDSCursor: IDSCursor;
    FDSOptions: TDataSetOptions;
    FFindCursor: IDSCursor;
    FCloneSource: TCustomClientDataSet;
    FReconcileDataSet: TCustomClientDataSet;
    FSavedPacket: TDataPacket;
    FDeltaPacket: TDataPacket;
    FParams: TParams;
    FIndexDefs: TIndexDefs;
    FIndexName: string;
    FExprFilter: HDSFilter;
    FFuncFilter: HDSFilter;
    FFileName: string;
    FFilterBuffer: PChar;
    FGroupingLevel: Integer;
    FLastParentBM: array of byte;
    FMasterLink: TMasterDataLink;
    FIndexFieldMap: DSKEY;
    FKeyBuffers: array[TKeyIndex] of PKeyBuffer;
    FKeyBuffer: PKeyBuffer;
    FNewValueBuffer: PChar;
    FOldValueBuffer: PChar;
    FCurValueBuffer: PChar;
    FIndexFieldCount: Integer;
    FIndexGroupingLevel: Integer;
    FAppServer: IAppServer;
    FProviderName: string;
    FRemoteServer: TCustomRemoteServer;
    FPacketRecords: Integer;
    FConstDisableCount: Integer;
    FMaxAggGroupingLevel: Integer;
    FParentDataSet: TCustomClientDataSet;
    { Word & Byte size data members }
    FKeySize: Word;
    FRecordSize: Integer;
    FBookmarkOfs: Integer;
    FRecInfoOfs: Integer;
    FRecBufSize: Integer;
    FReadOnly: Boolean;
    FFieldsIndex: Boolean;
    FCanModify: Boolean;
    FInReconcileCallback: Boolean;
    FNotifyCallback: Boolean;
    FOpeningFile: Boolean;
    FProviderEOF: Boolean;
    FFetchOnDemand: Boolean;
    FStoreDefs: Boolean;
    FSavePacketOnClose: Boolean;
    FOnReconcileError: TReconcileErrorEvent;
    FStatusFilter: TUpdateStatusSet;
    FBeforeApplyUpdates: TRemoteEvent;
    FAfterApplyUpdates: TRemoteEvent;
    FBeforeGetRecords: TRemoteEvent;
    FAfterGetRecords: TRemoteEvent;
    FBeforeRowRequest: TRemoteEvent;
    FAfterRowRequest: TRemoteEvent;
    FBeforeExecute: TRemoteEvent;
    FAfterExecute: TRemoteEvent;
    FBeforeGetParams: TRemoteEvent;
    FAfterGetParams: TRemoteEvent;
    FConnectionBroker: TConnectionBroker;
    procedure AddExprFilter(const Expr: string; Options: TFilterOptions);
    procedure AddFuncFilter;
    function CalcFieldsCallBack(RecBuf: PChar): DBResult; stdcall;
    procedure CheckFieldProps;
    procedure CheckMasterRange;
    procedure CheckProviderEOF;
    procedure ClearActiveAggs;
    procedure ClearSavedPacket;
    procedure CloseAggs;
    function CreateDSBase: IDSBase;
    function CreateDSCursor(SourceCursor: IDSCursor): IDSCursor;
    procedure DecodeIndexDesc(const IndexDesc: DSIDXDesc;
      var Name, Fields, DescFields, CaseInsFields: string; var Options: TIndexOptions);
    procedure EncodeFieldDesc(var FieldDesc: DSFLDDesc; const Name: string;
      DataType: TFieldType; Size, Precision: Integer; Calculated: Boolean;
      Attributes: TFieldAttributes);
    procedure EncodeIndexDesc(var IndexDesc: DSIDXDesc;
      const Name, Fields, DescFields, CaseInsFields: string; Options: TIndexOptions);
    procedure FetchMoreData(All: Boolean);
    function FilterCallback(RecBuf: PChar): LongBool; stdcall;
    procedure DoAggUpdates(IsUpdate: Boolean);
    function  GetActiveAggs(Index: Integer) : TList;
    function GetActiveRecBuf(var RecBuf: PChar): Boolean;
    procedure GetAggFieldData(Buffer: PChar);
    function GetChangeCount: Integer;
    function GetData: OleVariant;
    function GetDataSize: Integer;
    function GetDelta: OleVariant;
    function GetIndexDefs: TIndexDefs;
    function GetIndexFieldNames: string;
    function GetIndexName: string;
    function GetLogChanges: Boolean;
    function GetMasterFields: string;
    function GetProviderEOF: Boolean;
    function GetSavePoint: Integer;
    function GetHasAppServer: Boolean;
    procedure InitBufferPointers(GetProps: Boolean);
    function InternalGetGroupState(Level: Integer): TGroupPosInds;
    procedure InternalFetch(Options: TFetchOptions);
    procedure MasterChanged(Sender: TObject);
    procedure MasterDisabled(Sender: TObject);
    procedure NotifyCallback; stdcall;
    procedure ReadData(Stream: TStream);
    function ReconcileCallback(iRslt: Integer; iUpdateKind: DSAttr;
      iResAction: dsCBRType; iErrCode: Integer; pErrMessage, pErrContext: PChar;
      pRecUpd, pRecOrg, pRecConflict: Pointer; iLevels: Integer;
      piFieldIDs: PInteger): dsCBRType; stdcall;
    procedure ResetAgg(Agg: TAggregate; DeleteFirst: Boolean);
    procedure ResetAllAggs(Value: Boolean);
    procedure ResetGrouping;
    procedure SetAggsActive(Value: Boolean);
    procedure SetConnectionBroker(const Value: TConnectionBroker);
    procedure SaveDataPacket(Format: TDataPacketFormat = dfBinary);
    procedure SetData(const Value: OleVariant);
    procedure SetDataSource(Value: TDataSource);
    procedure SetDisableStringTrim(Value: Boolean);
    procedure SetIndex(const Value: string; FieldsIndex: Boolean);
    procedure SetIndexDefs(Value: TIndexDefs);
    procedure SetFileName(const Value: string);
    procedure SetIndexFieldNames(const Value: string);
    procedure SetIndexName(const Value: string);
    procedure SetLogChanges(Value: Boolean);
    procedure SetMasterFields(const Value: string);
    procedure SetNotifyCallback;
    procedure SetParams(Value: TParams);
    procedure SetProviderEOF(Value: Boolean); 
    procedure SetProviderName(const Value: string);
    procedure SetReadOnly(Value: Boolean);
    procedure SetSavePoint(Value: Integer);
    procedure SortOnFields(Cursor: IDSCursor; const Fields: string;
      CaseInsensitive, Descending: Boolean);
    procedure SetupConstraints;
    procedure SetupInternalCalcFields(Add: Boolean);
    procedure WriteData(Stream: TStream);
    procedure SetStatusFilter(const Value: TUpdateStatusSet);
    function GetXMLData: string;
    procedure SetXMLData(const Value: string);
  protected
    { IProviderSupport }
    function PSGetIndexDefs(IndexTypes: TIndexOptions): TIndexDefs; override;
  protected
    { DataIntf Helper functions }
    procedure DoAfterApplyUpdates(var OwnerData: OleVariant); virtual;
    procedure DoBeforeApplyUpdates(var OwnerData: OleVariant); virtual;
    function DoApplyUpdates(Delta: OleVariant; MaxErrors: Integer; out ErrorCount: Integer): OleVariant; virtual;
    procedure DoAfterGetParams(var OwnerData: OleVariant); virtual;
    procedure DoBeforeGetParams(var OwnerData: OleVariant); virtual;
    procedure DoAfterGetRecords(var OwnerData: OleVariant); virtual;
    procedure DoBeforeGetRecords(var OwnerData: OleVariant); virtual;
    function DoGetRecords(Count: Integer; out RecsOut: Integer; Options: Integer;
       const CommandText: WideString; Params: OleVariant): OleVariant; virtual;
    procedure DoAfterRowRequest(var OwnerData: OleVariant); virtual;
    procedure DoBeforeRowRequest(var OwnerData: OleVariant); virtual;
    function DoRowRequest(Row: OleVariant; RequestType: Integer): OleVariant; virtual;
    procedure DoAfterExecute(var OwnerData: OleVariant); virtual;