provider.pas

这是不可多得的源代码

      write FAfterUpdateRecord;
  end;

{ TDataSetProvider }

  TGetTableNameEvent = procedure(Sender: TObject; DataSet: TDataSet; var TableName: string) of object;
  TGetDSProps = procedure(Sender: TObject; DataSet: TDataSet;
    out Properties: OleVariant) of object;

  TDataSetProvider = class(TBaseProvider)
  private
    FDataSet: TDataSet;
    FDataSetOpened: Boolean;
    FDSWriter: TDataPacketWriter;
    FGetDSProps: TGetDSProps;
    FParams: TParams;
    FResolveToDataSet: Boolean;
    FRecordsSent: Integer;
    FConstraints: Boolean;
    FTransactionStarted: Boolean;
    FGetTableName: TGetTableNameEvent;
    function FindRecord(Source, Delta: TDataSet; UpdateMode: TUpdateMode): Boolean;
    procedure Reset;
    procedure SetCommandText(const CommandText: string);
    procedure SetDataSet(ADataSet: TDataSet);
    procedure SetResolveToDataSet(Value: Boolean);
  protected
    { SQL Resolver support methods }
    procedure DoGetTableName(DataSet: TDataSet; var TableName: string); virtual;
  protected
    { Event overrides }
    procedure DoBeforeGetRecords(Count: Integer; Options: Integer;
      const CommandText: WideString; var Params, OwnerData: OleVariant); override;
    procedure DoBeforeExecute(const CommandText: WideString; var Params,
      OwnerData: OleVariant); override;
  protected
    procedure CheckDataSet;
    procedure SetParams(Values: OleVariant);
    procedure DoGetProviderAttributes(DataSet: TDataSet; List: TList); virtual;
    function CreateResolver: TCustomResolver; override;
    procedure CreateDataPacket(PacketOpts: TGetRecordOptions;
      ProvOpts: TProviderOptions; var RecsOut: Integer; var Data: OleVariant); override;
    function GetDataSetFromDelta(ATree: TUpdateTree; Source, Delta: TDataSet; Mode: TUpdateMode): TDataSet;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure LocateRecord(Source, Delta: TDataSet); override;
    procedure UpdateRecord(Source, Delta: TDataSet; BlobsOnly, KeyOnly: Boolean); override;
    procedure FetchDetails(Source, Delta: TDataSet); override;
    function InternalRowRequest(const Row: OleVariant; Options: TFetchOptions): OleVariant; override;
    function InternalGetParams(Types: TParamTypes = AllParamTypes): OleVariant; override;
    procedure InternalExecute(const CommandText: WideString; var Params: OleVariant); override;
    function InternalGetRecords(Count: Integer; out RecsOut: Integer;
      Options: TGetRecordOptions; const CommandText: WideString;
      var Params: OleVariant): OleVariant; override;
    function InternalApplyUpdates(const Delta: OleVariant; MaxErrors: Integer;
      out ErrorCount: Integer): OleVariant; override;
    property Params: TParams read FParams;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property DataSet: TDataSet read FDataSet write SetDataSet;
    property Constraints: Boolean read FConstraints write FConstraints default True;
    property ResolveToDataSet: Boolean read FResolveToDataSet write SetResolveToDataSet default False;
    property Exported;
    property Options;
    property UpdateMode;
    property OnDataRequest;
    property OnGetData;
    property OnUpdateData;
    property OnUpdateError;
    property AfterUpdateRecord;
    property BeforeUpdateRecord;
    property BeforeApplyUpdates;
    property AfterApplyUpdates;
    property BeforeGetRecords;
    property AfterGetRecords;
    property BeforeRowRequest;
    property AfterRowRequest;
    property BeforeExecute;
    property AfterExecute;
    property BeforeGetParams;
    property AfterGetParams;
    property OnGetTableName: TGetTableNameEvent read FGetTableName write FGetTableName;
    property OnGetDataSetProperties: TGetDSProps read FGetDSProps write FGetDSProps;
  end;

{ TProvider - deprecated }

  TProvider = class(TDataSetProvider)
  end;

{ TUpdateTree }

  TUpdateTree = class(TObject)
  private
    FDeltaDS: TPacketDataSet;
    FErrorDS: TPacketDataSet;
    FOpened: Boolean;
    FSourceDS: TDataSet;
    FParent: TUpdateTree;
    FDetails: TList;
    FData: Pointer;
    FResolver: TCustomResolver;
    FName: string;
    function GetDetailCount: Integer;
    function GetDetail(Index: Integer): TUpdateTree;
    function GetErrorDS: TPacketDataSet;
    function GetHasErrors: Boolean;
    function GetIsNested: Boolean;
    function GetTree(const AName: string): TUpdateTree;
  protected
    procedure Clear;
    function DoUpdates: Boolean;
    procedure RefreshData(Options: TFetchOptions);
    procedure InitErrorPacket(E: EUpdateError; Response: TResolverResponse);
    procedure InitData(ASource: TDataSet);
    procedure InitDelta(const ADelta: OleVariant); overload;
    procedure InitDelta(ADelta: TPacketDataSet); overload;
    property Data: Pointer read FData write FData;
    property Delta: TPacketDataSet read FDeltaDS;
    property DetailCount: Integer read GetDetailCount;
    property Details[Index: Integer]: TUpdateTree read GetDetail;
    property ErrorDS: TPacketDataSet read GetErrorDS;
    property HasErrors: Boolean read GetHasErrors;
    property Name: string read FName write FName;
    property Parent: TUpdateTree read FParent;
    property Source: TDataSet read FSourceDS;
    property IsNested: Boolean read GetIsNested;
  public
    constructor Create(AParent: TUpdateTree; AResolver: TCustomResolver);
    destructor Destroy; override;
  end;

{ TCustomResolver }

  TCustomResolver = class(TComponent)
  private
    FProvider: TBaseProvider;
    FPrevResponse: TResolverResponse;
    FErrorCount: Integer;
    FMaxErrors: Integer;
    FUpdateTree: TUpdateTree;
  protected
    property Provider: TBaseProvider read FProvider;
    function HandleUpdateError(Tree: TUpdateTree; E: EUpdateError;
      var MaxErrors, ErrorCount: Integer): Boolean;
    procedure LogUpdateRecord(Tree: TUpdateTree);
    procedure LogUpdateError(Tree: TUpdateTree; E: EUpdateError;
      Response: TResolverResponse);
    procedure InitKeyFields(Tree: TUpdateTree; ADelta: TPacketDataSet);
    procedure InternalBeforeResolve(Tree: TUpdateTree); virtual;
    function InternalUpdateRecord(Tree: TUpdateTree): Boolean;
    procedure BeginUpdate; virtual;
    procedure EndUpdate; virtual;
    procedure InitTreeData(Tree: TUpdateTree); virtual;
    procedure FreeTreeData(Tree: TUpdateTree); virtual;
    procedure InitializeConflictBuffer(Tree: TUpdateTree); virtual; abstract;
    procedure DoUpdate(Tree: TUpdateTree); virtual; abstract;
    procedure DoDelete(Tree: TUpdateTree); virtual; abstract;
    procedure DoInsert(Tree: TUpdateTree); virtual; abstract;
    function RowRequest(Row: OleVariant; Options: TFetchOptions): OleVariant; virtual;
    function ApplyUpdates(const Delta: OleVariant; MaxErrors: Integer;
      out ErrorCount: Integer): OleVariant; virtual;
  public
    constructor Create(AProvider: TBaseProvider); reintroduce;
    destructor Destroy; override;
  end;

{ TDataSetResolver }

  TDataSetResolver = class(TCustomResolver)
  private
    FBookmark: TBookmarkStr;
    FOpened: Boolean;
    function GetProvider: TDataSetProvider;
    procedure PutRecord(Tree: TUpdateTree);
  protected
    property Provider: TDataSetProvider read GetProvider;
    procedure BeginUpdate; override;
    procedure DoUpdate(Tree: TUpdateTree); override;
    procedure DoDelete(Tree: TUpdateTree); override;
    procedure DoInsert(Tree: TUpdateTree); override;
    procedure EndUpdate; override;
    procedure InternalBeforeResolve(Tree: TUpdateTree); override;
    procedure InitializeConflictBuffer(Tree: TUpdateTree); override;
  public
    constructor Create(AProvider: TDataSetProvider); reintroduce;
  end;

{ TSQLResolver }

  TSQLResolver = class(TCustomResolver)
  private
    FSQL: TStringList;
    FParams: TParams;
    function GetProvider: TDataSetProvider;
    procedure GenWhereSQL(Tree: TUpdateTree; SQL: TStrings; Params: TParams;
      GenUpdateMode: TUpdateMode; Alias: string);
    procedure GenInsertSQL(Tree: TUpdateTree; SQL: TStrings; Params: TParams);
    procedure GenDeleteSQL(Tree: TUpdateTree; SQL: TStrings; Params: TParams;
      Alias: string);
    procedure GenUpdateSQL(Tree: TUpdateTree; SQL: TStrings; Params: TParams;
      Alias: string);
    procedure GenSelectSQL(Tree: TUpdateTree; SQL: TStrings; Params: TParams;
      Alias: string; Mode: TUpdateMode = upWhereKeyOnly);
    function UseFieldInUpdate(Field: TField): Boolean;
    function UseFieldInWhere(Field: TField; Mode: TUpdateMode): Boolean;
    procedure InternalDoUpdate(Tree: TUpdateTree; UpdateKind: TUpdateKind);
  protected
    property Provider: TDataSetProvider read GetProvider;
    procedure InitializeConflictBuffer(Tree: TUpdateTree); override;
    procedure DoExecSQL(SQL: TStringList; Params: TParams); virtual;
    procedure DoGetValues(SQL: TStringList; Params: TParams;
      DataSet: TDataSet); virtual;
    procedure InitTreeData(Tree: TUpdateTree); override;
    procedure FreeTreeData(Tree: TUpdateTree); override;
    procedure DoUpdate(Tree: TUpdateTree); override;
    procedure DoDelete(Tree: TUpdateTree); override;
    procedure DoInsert(Tree: TUpdateTree); override;
  public
    constructor Create(AProvider: TDataSetProvider); reintroduce;
    destructor Destroy; override;
  end;

{ TLocalAppServer }

  TLocalAppServer = class(TInterfacedObject, IAppServer{$IFDEF MSWINDOWS}, ISupportErrorInfo{$ENDIF})
  private
    FProvider: TCustomProvider;
    FProviderCreated: Boolean;
  protected
    { IDispatch }
    function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
    { IAppServer }
    function AS_ApplyUpdates(const ProviderName: WideString; Delta: OleVariant; MaxErrors: Integer;
                             out ErrorCount: Integer; var OwnerData: OleVariant): OleVariant; safecall;
    function AS_GetRecords(const ProviderName: WideString; Count: Integer; out RecsOut: Integer;
                           Options: Integer; const CommandText: WideString;
                           var Params: OleVariant; var OwnerData: OleVariant): OleVariant; safecall;
    function AS_DataRequest(const ProviderName: WideString; Data: OleVariant): OleVariant; safecall;
    function AS_GetProviderNames: OleVariant; safecall;
    function AS_GetParams(const ProviderName: WideString; var OwnerData: OleVariant): OleVariant; safecall;
    function AS_RowRequest(const ProviderName: WideString; Row: OleVariant; RequestType: Integer;
                           var OwnerData: OleVariant): OleVariant; safecall;
    procedure AS_Execute(const ProviderName: WideString;  const CommandText: WideString;
                         var Params, OwnerData: OleVariant); safecall;
    { ISupportErrorInfo }
    function InterfaceSupportsErrorInfo(const iid: TGUID): HResult; stdcall;
  public
    constructor Create(AProvider: TCustomProvider); overload;
    constructor Create(ADataset: TDataset); overload;
    destructor Destroy; override;
    function SafeCallException(ExceptObject: TObject;
      ExceptAddr: Pointer): HResult; override;
  end;

  IProviderContainer = interface
  ['{EEE9FFD4-752F-11D4-80DD-00C04F6BB88C}']
    procedure RegisterProvider(Prov: TCustomProvider);
    procedure UnRegisterProvider(Prov: TCustomProvider);
  end;

{ Utility functions }

function GetObjectProperty(Instance: TPersistent; const PropName: string): TObject;
function GetStringProperty(Instance: TPersistent; const PropName: string): string;
function VarArrayFromStrings(Strings: TStrings): Variant;

implementation
{$IFDEF MSWINDOWS}
uses MidConst, DBConsts, DBCommon, TypInfo, DataBkr, ComObj, FMTBcd;
{$ENDIF}
{$IFDEF LINUX}
uses MidConst, DBConsts, DBCommon, TypInfo, FMTBcd, Types;
{$ENDIF}

const
  DEFBUFSIZE = 8192;  { Default size for field data buffer }
  DefAlias   = 'A';
  NestAlias  = 'B';
  tagSERVERCALC = 1;

  PacketTypeMap: array [TFieldType] of Integer =
    (dsfldUNKNOWN, dsfldZSTRING, dsfldINT, dsfldINT, dsfldINT, dsfldBOOL,
     dsfldFLOATIEEE, dsfldFLOATIEEE, dsfldBCD, dsfldDATE, dsfldTIME,
     dsfldTIMESTAMP, dsfldBYTES, dsfldBYTES, dsfldINT, dsfldBYTES, dsfldBYTES,
     dsfldBYTES, dsfldBYTES, dsfldBYTES, dsfldBYTES, dsfldBYTES, dsfldUNKNOWN,
     dsfldZSTRING, dsfldUNICODE, dsfldINT, dsfldADT, dsfldARRAY, dsfldEMBEDDEDTBL,
     dsfldEMBEDDEDTBL, dsfldBYTES, dsfldBYTES, dsfldUNKNOWN, dsfldUNKNOWN,
     dsfldUNKNOWN, dsfldZSTRING, dsfldDATETIME, dsFLDFMTBCD);

  ExtraFieldProps: array [0..10] of string = ('Alignment', 'DisplayLabel',
    'DisplayWidth', 'Visible', 'EditMask', 'DisplayFormat', 'EditFormat',
    'MinValue', 'MaxValue', 'currency', 'DisplayValues');

{ Utility functions }

function GetObjectProperty(Instance: TPersistent; const PropName: string): TObject;
var
  PropInfo: PPropInfo;
begin
  Result := nil;
  PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, PropName);
  if (PropInfo <> nil) and (PropInfo^.PropType^.Kind = tkClass) then
    Result := TObject(GetOrdProp(Instance, PropInfo));
end;

function GetStringProperty(Instance: TPersistent; const PropName: string): string;
var
  PropInfo: PPropInfo;
begin
  Result := '';
  PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, PropName);
  if (PropInfo <> nil) and (PropInfo^.PropType^.Kind in [tkString, tkLString, tkWString]) then
    Result := GetStrProp(Instance, PropInfo);
end;

function VarArrayFromStrings(Strings: TStrings): Variant;
var
  I: Integer;
begin
  Result := Null;
  if Strings.Count > 0 then
  begin
    Result := VarArrayCreate([0, Strings.Count - 1], varOleStr);
    for I := 0 to Strings.Count - 1 do Result[I] := WideString(Strings[I]);
  end;
end;

{ EDSWriter }

constructor EDSWriter.Create(ErrMsg: string; Status: Integer);
begin
  FErrorCode := Status;
  inherited Create(ErrMsg);
end;