home *** CD-ROM | disk | FTP | other *** search
/ Delphi Anthology / aDELPHI.iso / Runimage / Delphi50 / Source / Vcl / provider.pas < prev    next >
Pascal/Delphi Source File  |  1999-08-11  |  126KB  |  3,828 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Borland Delphi Visual Component Library         }
  5. {       Provider - Resolver framework                   }
  6. {                                                       }
  7. {       Copyright (c) 1997,99 Inprise Corporation       }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11. unit Provider;
  12.  
  13. {$T-,H+,X+}
  14.  
  15. interface
  16.  
  17. uses Windows, SysUtils, Classes, DbClient, DB, DsIntf, ActiveX, Midas;
  18.  
  19. type
  20.  
  21. { EDSWriter }
  22.  
  23.   EDSWriter = class(Exception)
  24.   private
  25.     FErrorCode: Integer;
  26.   public
  27.     constructor Create(ErrMsg: string; Status: Integer);
  28.     property ErrorCode: Integer read FErrorCode;
  29.   end;
  30. {$EXTERNALSYM EDSWriter}
  31.  
  32. (*$HPPEMIT 'namespace Provider' *)
  33. (*$HPPEMIT '{' *)
  34. (*$HPPEMIT 'class DELPHICLASS EDSWriter;' *)
  35. (*$HPPEMIT '#pragma pack(push, 4)' *)
  36. (*$HPPEMIT 'class PASCALIMPLEMENTATION EDSWriter : public Sysutils::Exception' *)
  37. (*$HPPEMIT '{' *)
  38. (*$HPPEMIT '  typedef Sysutils::Exception inherited;' *)
  39. (*$HPPEMIT '' *)
  40. (*$HPPEMIT 'private:' *)
  41. (*$HPPEMIT '  int FErrorCode;' *)
  42. (*$HPPEMIT '' *)
  43. (*$HPPEMIT 'public:' *)
  44. (*$HPPEMIT '  __fastcall EDSWriter(AnsiString ErrMsg, long Status);' *)
  45. (*$HPPEMIT '  __property int ErrorCode = {read=FErrorCode, nodefault};' *)
  46. (*$HPPEMIT 'public:' *)
  47. (*$HPPEMIT '  /* Exception.CreateFmt */ inline __fastcall EDSWriter(const AnsiString Msg, const System::TVarRec * Args, const int Args_Size) : Sysutils::Exception(Msg, Args, Args_Size) { }' *)
  48. (*$HPPEMIT '  /* Exception.CreateRes */ inline __fastcall EDSWriter(int Ident, Extended Dummy) : Sysutils::Exception(Ident, Dummy) { }' *)
  49. (*$HPPEMIT '  /* Exception.CreateResFmt */ inline __fastcall EDSWriter(int Ident, const System::TVarRec * Args, const int Args_Size) : Sysutils::Exception(Ident, Args, Args_Size) { }' *)
  50. (*$HPPEMIT '  /* Exception.CreateHelp */ inline __fastcall EDSWriter(const AnsiString Msg, int AHelpContext) : Sysutils::Exception(Msg, AHelpContext) { }' *)
  51. (*$HPPEMIT '  /* Exception.CreateFmtHelp */ inline __fastcall EDSWriter(const AnsiString Msg, const System::TVarRec * Args, const int Args_Size, int AHelpContext) : Sysutils::Exception(Msg, Args, Args_Size, AHelpContext) { }' *)
  52. (*$HPPEMIT '  /* Exception.CreateResHelp */ inline __fastcall EDSWriter(int Ident, int AHelpContext) : Sysutils::Exception(Ident, AHelpContext) { }' *)
  53. (*$HPPEMIT '  /* Exception.CreateResFmtHelp */ inline __fastcall EDSWriter(int Ident, const System::TVarRec * Args, const int Args_Size, int AHelpContext) : Sysutils::Exception(Ident, Args, Args_Size, AHelpContext) { }' *)
  54. (*$HPPEMIT '' *)
  55. (*$HPPEMIT 'public:' *)
  56. (*$HPPEMIT '  /* TObject.Destroy */ inline __fastcall virtual ~EDSWriter(void) { }' *)
  57. (*$HPPEMIT '' *)
  58. (*$HPPEMIT '};' *)
  59. (*$HPPEMIT '' *)
  60. (*$HPPEMIT '#pragma pack(pop)' *)
  61. (*$HPPEMIT '}' *)
  62.  
  63. { TCustomPacketWriter }
  64.  
  65.   TCustomPacketWriter = class(TObject)
  66.   private
  67.     FIDSWriter: IDSWriter;
  68.     FBuffer: array of Byte;
  69.   protected
  70.     procedure AddAttribute(Area: TPcktAttrArea; const ParamName: string;
  71.       const Value: OleVariant; IncludeInDelta: Boolean);
  72.     procedure Check(Status: Integer);
  73.     property DSWriter: IDSWriter read FIDSWriter;
  74.   public
  75.     constructor Create; virtual;
  76.     destructor Destroy; override;
  77.   end;
  78.  
  79. { TDataPacketWriter }
  80.  
  81. type
  82.  
  83.   TGetRecordOption = (grMetaData, grReset, grXML);
  84.   TGetRecordOptions = set of TGetRecordOption;
  85.  
  86.   TDataRequestEvent = function(Sender: TObject; Input: OleVariant): OleVariant of object;
  87.  
  88.   TProviderOption = (poFetchBlobsOnDemand, poFetchDetailsOnDemand,
  89.     poIncFieldProps, poCascadeDeletes, poCascadeUpdates, poReadOnly,
  90.     poAllowMultiRecordUpdates, poDisableInserts, poDisableEdits,
  91.     poDisableDeletes, poNoReset, poAutoRefresh, poPropogateChanges,
  92.     poAllowCommandText);
  93.   TProviderOptions = set of TProviderOption;
  94.  
  95.   PPutFieldInfo = ^TPutFieldInfo;
  96.   TPutFieldProc = procedure(Info: PPutFieldInfo) of object;
  97.   TPutFieldInfo = record
  98.     FieldNo: Integer;
  99.     Field: TField;
  100.     DataSet: TDataSet;
  101.     Size: Integer;
  102.     IsDetail: Boolean;
  103.     Opened: Boolean;
  104.     PutProc: TPutFieldProc;
  105.     LocalFieldIndex: Integer;
  106.     FieldInfos: Pointer;
  107.   end;
  108.  
  109.   TInfoArray = array of TPutFieldInfo;
  110.  
  111.   TGetParamsEvent = procedure(DataSet: TDataSet; Params: TList) of object;
  112.  
  113.   TDataPacketWriter = class(TCustomPacketWriter)
  114.   private
  115.     FConstraints: Boolean;
  116.     FPutFieldInfo: TInfoArray;
  117.     FOptions: TProviderOptions;
  118.     FPacketOptions: TGetRecordOptions;
  119.     FOnGetParams: TGetParamsEvent;
  120.     procedure FreeInfoRecords(var Info: TInfoArray);
  121.     function GetFieldIdx(const FieldName: string; const Info: TInfoArray): Integer;
  122.     procedure AddExtraFieldProps(Field: TField);
  123.     function InitPutProcs(ADataSet: TDataSet; var GlobalIdx: Integer): TInfoArray;
  124.     procedure RefreshPutProcs(ADataSet: TDataSet; var Info: TInfoArray);
  125.   protected
  126.     procedure AddColumn(const Info: TPutFieldInfo);
  127.     procedure AddConstraints(DataSet: TDataSet);
  128.     procedure AddDataSetAttributes(DataSet: TDataSet);
  129.     procedure AddFieldLinks(const Info: TInfoArray);
  130.     procedure AddIndexDefs(DataSet: TDataSet; const Info: TInfoArray);
  131.     procedure PutADTField(Info: PPutFieldInfo);
  132.     procedure PutArrayField(Info: PPutFieldInfo);
  133.     procedure PutBlobField(Info: PPutFieldInfo);
  134.     procedure PutCalcField(Info: PPutFieldInfo);
  135.     procedure PutDataSetField(Info: PPutFieldInfo);
  136.     procedure PutField(Info: PPutFieldInfo);
  137.     procedure PutStringField(Info: PPutFieldInfo);
  138.     procedure PutWideStringField(Info: PPutFieldInfo);
  139.     procedure PutVarBytesField(Info: PPutFieldInfo);
  140.     procedure WriteMetaData(DataSet: TDataSet; const Info: TInfoArray;
  141.       IsReference: Boolean = False);
  142.     function WriteDataSet(DataSet: TDataSet; var Info: TInfoArray;
  143.       RecsOut: Integer): Integer;
  144.     property OnGetParams: TGetParamsEvent read FOnGetParams write FOnGetParams;
  145.   public
  146.     destructor Destroy; override;
  147.     procedure GetDataPacket(DataSet: TDataSet; var RecsOut: Integer;
  148.       out Data: OleVariant);
  149.     property Constraints: Boolean read FConstraints write FConstraints;
  150.     property PacketOptions: TGetRecordOptions read FPacketOptions write FPacketOptions;
  151.     property Options: TProviderOptions read FOptions write FOptions;
  152.   end;
  153.  
  154. { TPacketDataSet }
  155.  
  156.   TPacketDataSet = class(TClientDataSet)
  157.   private
  158.     FOldRecBuf: PChar;
  159.     FCurRecBuf: PChar;
  160.     FCurValues: PChar;
  161.     FUseCurValues: Boolean;
  162.     FWritingCurValues: Boolean;
  163.     FNewValuesModified: Boolean;
  164.     function GetStreamMetaData: Boolean;
  165.     procedure SetStreamMetaData(Value: Boolean);
  166.     procedure SetWritingCurValues(const Value: Boolean);
  167.   protected
  168.     procedure DataEvent(Event: TDataEvent; Info: Longint); override;
  169.     function GetStateFieldValue(State: TDataSetState; Field: TField): Variant; override;
  170.     procedure InternalClose; override;
  171.     procedure InternalOpen; override;
  172.     procedure InternalInitRecord(Buffer: PChar); override;
  173.     procedure SetFieldData(Field: TField; Buffer: Pointer); override;
  174.     property WritingCurValues: Boolean read FWritingCurValues write SetWritingCurValues;
  175.   public
  176.     constructor Create(AOwner: TComponent); override;
  177.     procedure AssignCurValues(Source: TDataSet); overload;
  178.     procedure AssignCurValues(const CurValues: Variant); overload;
  179.     procedure CreateFromDelta(Source: TPacketDataSet);
  180.     function HasCurValues: Boolean;
  181.     function HasMergeConflicts: Boolean;
  182.     procedure InitAltRecBuffers(CheckModified: Boolean = True);
  183.     function UpdateKind: TUpdateKind;
  184.     property NewValuesModified: Boolean read FNewValuesModified;
  185.     property StreamMetaData: Boolean read GetStreamMetaData write SetStreamMetaData;
  186.     property UseCurValues: Boolean read FUseCurValues write FUseCurValues;
  187.   end;
  188.  
  189. { TCustomProvider }
  190.  
  191.   TCustomProvider = class(TComponent)
  192.   private
  193.     FExported: Boolean;
  194.     FOnDataRequest: TDataRequestEvent;
  195.     FBeforeApplyUpdates: TRemoteEvent;
  196.     FAfterApplyUpdates: TRemoteEvent;
  197.     FBeforeGetRecords: TRemoteEvent;
  198.     FAfterGetRecords: TRemoteEvent;
  199.     FBeforeRowRequest: TRemoteEvent;
  200.     FAfterRowRequest: TRemoteEvent;
  201.     FBeforeExecute: TRemoteEvent;
  202.     FAfterExecute: TRemoteEvent;
  203.     FBeforeGetParams: TRemoteEvent;
  204.     FAfterGetParams: TRemoteEvent;
  205.     function GetData: OleVariant;
  206.   protected
  207.  
  208.     function InternalApplyUpdates(const Delta: OleVariant; MaxErrors: Integer;
  209.       out ErrorCount: Integer): OleVariant; virtual; abstract;
  210.     function InternalGetRecords(Count: Integer; out RecsOut: Integer;
  211.       Options: TGetRecordOptions; const CommandText: WideString;
  212.       var Params: OleVariant): OleVariant; virtual;
  213.     function InternalRowRequest(const Row: OleVariant; RequestType: TFetchOptions): OleVariant; virtual;
  214.     procedure InternalExecute(const CommandText: WideString; var Params: OleVariant); virtual;
  215.     function InternalGetParams(Types: TParamTypes = AllParamTypes): OleVariant; virtual;
  216.  
  217.   { Event overrides }
  218.     procedure DoBeforeGetRecords(Count: Integer; Options: Integer;
  219.       const CommandText: WideString; var Params, OwnerData: OleVariant); virtual;
  220.     procedure DoBeforeExecute(const CommandText: WideString; var Params,
  221.       OwnerData: OleVariant); virtual;
  222.  
  223.   { Events }
  224.     property OnDataRequest: TDataRequestEvent read FOnDataRequest write FOnDataRequest;
  225.     property BeforeApplyUpdates: TRemoteEvent read FBeforeApplyUpdates write FBeforeApplyUpdates;
  226.     property AfterApplyUpdates: TRemoteEvent read FAfterApplyUpdates write FAfterApplyUpdates;
  227.     property BeforeGetRecords: TRemoteEvent read FBeforeGetRecords write FBeforeGetRecords;
  228.     property AfterGetRecords: TRemoteEvent read FAfterGetRecords write FAfterGetRecords;
  229.     property BeforeRowRequest: TRemoteEvent read FBeforeRowRequest write FBeforeRowRequest;
  230.     property AfterRowRequest: TRemoteEvent read FAfterRowRequest write FAfterRowRequest;
  231.     property BeforeExecute: TRemoteEvent read FBeforeExecute write FBeforeExecute;
  232.     property AfterExecute: TRemoteEvent read FAfterExecute write FAfterExecute;
  233.     property BeforeGetParams: TRemoteEvent read FBeforeGetParams write FBeforeGetParams;
  234.     property AfterGetParams: TRemoteEvent read FAfterGetParams write FAfterGetParams;
  235.   public
  236.     constructor Create(AOwner: TComponent); override;
  237.     destructor Destroy; override;
  238.  
  239.     function ApplyUpdates(const Delta: OleVariant; MaxErrors: Integer;
  240.       out ErrorCount: Integer): OleVariant; overload;
  241.     function ApplyUpdates(const Delta: OleVariant; MaxErrors: Integer;
  242.       out ErrorCount: Integer; var OwnerData: OleVariant): OleVariant; overload;
  243.     function GetRecords(Count: Integer; out RecsOut: Integer;
  244.       Options: Integer): OleVariant; overload;
  245.     function GetRecords(Count: Integer; out RecsOut: Integer; Options: Integer;
  246.       const CommandText: WideString; var Params,
  247.       OwnerData: OleVariant): OleVariant; overload;
  248.     function RowRequest(const Row: OleVariant; RequestType: Integer;
  249.       var OwnerData: OleVariant): OleVariant;
  250.     procedure Execute(const CommandText: WideString; var Params,
  251.       OwnerData: OleVariant);
  252.     function GetParams(var OwnerData: OleVariant): OleVariant;
  253.     function DataRequest(Input: OleVariant): OleVariant; virtual;
  254.  
  255.     property Data: OleVariant read GetData;
  256.     property Exported: Boolean read FExported write FExported default True;
  257.   end;
  258.  
  259. { TBaseProvider }
  260.  
  261. type
  262.  
  263.   TCustomResolver = class;
  264.   TResolverResponse = (rrSkip, rrAbort, rrMerge, rrApply, rrIgnore);
  265.   TProviderDataEvent = procedure(Sender: TObject; DataSet: TClientDataSet) of object;
  266.   TBeforeUpdateRecordEvent = procedure(Sender: TObject; SourceDS: TDataSet;
  267.     DeltaDS: TClientDataSet; UpdateKind: TUpdateKind; var Applied: Boolean) of object;
  268.   TAfterUpdateRecordEvent = procedure(Sender: TObject; SourceDS: TDataSet;
  269.     DeltaDS: TClientDataSet; UpdateKind: TUpdateKind) of object;
  270.   TResolverErrorEvent = procedure(Sender: TObject; DataSet: TClientDataSet;
  271.     E: EUpdateError; UpdateKind: TUpdateKind; var Response: TResolverResponse) of object;
  272.  
  273.   TBaseProvider = class(TCustomProvider)
  274.   private
  275.     FDataDS: TPacketDataSet;
  276.     FUpdateMode: TUpdateMode;
  277.     FResolver: TCustomResolver;
  278.     FOnGetData: TProviderDataEvent;
  279.     FOnUpdateData: TProviderDataEvent;
  280.     FOnUpdateError: TResolverErrorEvent;
  281.     FBeforeUpdateRecord: TBeforeUpdateRecordEvent;
  282.     FAfterUpdateRecord: TAfterUpdateRecordEvent;
  283.     FProviderOptions: TProviderOptions;
  284.   protected
  285.     procedure CheckResolver;
  286.     function CreateResolver: TCustomResolver; virtual;
  287.     procedure FreeResolver;
  288.     procedure CreateDataPacket(PacketOpts: TGetRecordOptions;
  289.       ProvOpts: TProviderOptions; var RecsOut: Integer; var Data: OleVariant); virtual;
  290.     procedure DoOnGetData(var Data: OleVariant);
  291.     procedure DoOnUpdateData(Delta: TPacketDataSet);
  292.     procedure LocateRecord(Source, Delta: TDataSet); virtual;
  293.     procedure UpdateRecord(Source, Delta: TDataSet; BlobsOnly, KeyOnly: Boolean); virtual;
  294.     procedure FetchDetails(Source, Delta: TDataSet); virtual;
  295.  
  296.     function InternalRowRequest(const Row: OleVariant;
  297.       RequestType: TFetchOptions): OleVariant; override;
  298.     function InternalApplyUpdates(const Delta: OleVariant; MaxErrors: Integer;
  299.       out ErrorCount: Integer): OleVariant; override;
  300.     function InternalGetRecords(Count: Integer; out RecsOut: Integer;
  301.       Options: TGetRecordOptions; const CommandText: WideString;
  302.       var Params: OleVariant): OleVariant; override;
  303.   public
  304.     constructor Create(AOwner: TComponent); override;
  305.     destructor Destroy; override;
  306.     property Resolver: TCustomResolver read FResolver;
  307.     property Options: TProviderOptions read FProviderOptions
  308.       write FProviderOptions default [];
  309.     property UpdateMode: TUpdateMode read FUpdateMode write FUpdateMode default upWhereAll;
  310.     property OnDataRequest;
  311.     property OnGetData: TProviderDataEvent read FOnGetData write FOnGetData;
  312.     property OnUpdateData: TProviderDataEvent read FOnUpdateData write FOnUpdateData;
  313.     property OnUpdateError: TResolverErrorEvent read FOnUpdateError write FOnUpdateError;
  314.     property BeforeUpdateRecord: TBeforeUpdateRecordEvent read FBeforeUpdateRecord
  315.       write FBeforeUpdateRecord;
  316.     property AfterUpdateRecord: TAfterUpdateRecordEvent read FAfterUpdateRecord
  317.       write FAfterUpdateRecord;
  318.   end;
  319.  
  320. { TDataSetProvider }
  321.  
  322.   TGetTableNameEvent = procedure(Sender: TObject; DataSet: TDataSet; var TableName: string) of object;
  323.   TGetDSProps = procedure(Sender: TObject; DataSet: TDataSet;
  324.     out Properties: OleVariant) of object;
  325.  
  326.   TDataSetProvider = class(TBaseProvider)
  327.   private
  328.     FDataSet: TDataSet;
  329.     FDataSetOpened: Boolean;
  330.     FDSWriter: TDataPacketWriter;
  331.     FGetDSProps: TGetDSProps;
  332.     FParams: TParams;
  333.     FResolveToDataSet: Boolean;
  334.     FRecordsSent: Integer;
  335.     FConstraints: Boolean;
  336.     FGetTableName: TGetTableNameEvent;
  337.     procedure CheckDataSet;
  338.     function FindRecord(Source, Delta: TDataSet; UpdateMode: TUpdateMode): Boolean;
  339.     procedure Reset;
  340.     procedure SetCommandText(const CommandText: string);
  341.     procedure SetDataSet(ADataSet: TDataSet);
  342.     procedure SetParams(Values: OleVariant);
  343.     procedure SetResolveToDataSet(Value: Boolean);
  344.   protected
  345.     { SQL Resolver support methods }
  346.     procedure DoGetTableName(DataSet: TDataSet; var TableName: string); virtual;
  347.   protected
  348.     { Event overrides }
  349.     procedure DoBeforeGetRecords(Count: Integer; Options: Integer;
  350.       const CommandText: WideString; var Params, OwnerData: OleVariant); override;
  351.     procedure DoBeforeExecute(const CommandText: WideString; var Params,
  352.       OwnerData: OleVariant); override;
  353.   protected
  354.     procedure DoGetProviderAttributes(DataSet: TDataSet; List: TList); virtual;
  355.     function CreateResolver: TCustomResolver; override;
  356.     procedure CreateDataPacket(PacketOpts: TGetRecordOptions;
  357.       ProvOpts: TProviderOptions; var RecsOut: Integer; var Data: OleVariant); override;
  358.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  359.     procedure LocateRecord(Source, Delta: TDataSet); override;
  360.     procedure UpdateRecord(Source, Delta: TDataSet; BlobsOnly, KeyOnly: Boolean); override;
  361.     procedure FetchDetails(Source, Delta: TDataSet); override;
  362.  
  363.     function InternalRowRequest(const Row: OleVariant; Options: TFetchOptions): OleVariant; override;
  364.     function InternalGetParams(Types: TParamTypes = AllParamTypes): OleVariant; override;
  365.     procedure InternalExecute(const CommandText: WideString; var Params: OleVariant); override;
  366.     function InternalGetRecords(Count: Integer; out RecsOut: Integer;
  367.       Options: TGetRecordOptions; const CommandText: WideString;
  368.       var Params: OleVariant): OleVariant; override;
  369.     function InternalApplyUpdates(const Delta: OleVariant; MaxErrors: Integer;
  370.       out ErrorCount: Integer): OleVariant; override;
  371.   public
  372.     constructor Create(AOwner: TComponent); override;
  373.     destructor Destroy; override;
  374.   published
  375.     property DataSet: TDataSet read FDataSet write SetDataSet;
  376.     property Constraints: Boolean read FConstraints write FConstraints;
  377.     property ResolveToDataSet: Boolean read FResolveToDataSet write SetResolveToDataSet default False;
  378.     property Exported;
  379.     property Options;
  380.     property UpdateMode;
  381.     property OnDataRequest;
  382.     property OnGetData;
  383.     property OnUpdateData;
  384.     property OnUpdateError;
  385.     property AfterUpdateRecord;
  386.     property BeforeUpdateRecord;
  387.     property BeforeApplyUpdates;
  388.     property AfterApplyUpdates;
  389.     property BeforeGetRecords;
  390.     property AfterGetRecords;
  391.     property BeforeRowRequest;
  392.     property AfterRowRequest;
  393.     property BeforeExecute;
  394.     property AfterExecute;
  395.     property BeforeGetParams;
  396.     property AfterGetParams;
  397.     property OnGetTableName: TGetTableNameEvent read FGetTableName write FGetTableName;
  398.     property OnGetDataSetProperties: TGetDSProps read FGetDSProps write FGetDSProps;
  399.   end;
  400.  
  401. { TProvider - deprecated }
  402.  
  403.   TProvider = class(TDataSetProvider)
  404.   end;
  405.  
  406. { TUpdateTree }
  407.  
  408.   TUpdateTree = class(TObject)
  409.   private
  410.     FDeltaDS: TPacketDataSet;
  411.     FErrorDS: TPacketDataSet;
  412.     FOpened: Boolean;
  413.     FSourceDS: TDataSet;
  414.     FParent: TUpdateTree;
  415.     FDetails: TList;
  416.     FData: Pointer;
  417.     FResolver: TCustomResolver;
  418.     FName: string;
  419.     function GetDetailCount: Integer;
  420.     function GetDetail(Index: Integer): TUpdateTree;
  421.     function GetErrorDS: TPacketDataSet;
  422.     function GetHasErrors: Boolean;
  423.     function GetIsNested: Boolean;
  424.     function GetTree(const AName: string): TUpdateTree;
  425.   protected
  426.     procedure Clear;
  427.     function DoUpdates: Boolean;
  428.  
  429.     procedure RefreshData(Options: TFetchOptions);
  430.     procedure InitErrorPacket(E: EUpdateError; Response: TResolverResponse);
  431.     procedure InitData(ASource: TDataSet);
  432.     procedure InitDelta(const ADelta: OleVariant); overload;
  433.     procedure InitDelta(ADelta: TPacketDataSet); overload;
  434.     property Data: Pointer read FData write FData;
  435.     property Delta: TPacketDataSet read FDeltaDS;
  436.     property DetailCount: Integer read GetDetailCount;
  437.     property Details[Index: Integer]: TUpdateTree read GetDetail;
  438.     property ErrorDS: TPacketDataSet read GetErrorDS;
  439.     property HasErrors: Boolean read GetHasErrors;
  440.     property Name: string read FName write FName;
  441.     property Parent: TUpdateTree read FParent;
  442.     property Source: TDataSet read FSourceDS;
  443.     property IsNested: Boolean read GetIsNested;
  444.   public
  445.     constructor Create(AParent: TUpdateTree; AResolver: TCustomResolver);
  446.     destructor Destroy; override;
  447.   end;
  448.  
  449. { TCustomResolver }
  450.  
  451.   TCustomResolver = class(TComponent)
  452.   private
  453.     FProvider: TBaseProvider;
  454.     FPrevResponse: TResolverResponse;
  455.     FErrorCount: Integer;
  456.     FMaxErrors: Integer;
  457.     FUpdateTree: TUpdateTree;
  458.   protected
  459.     property Provider: TBaseProvider read FProvider;
  460.     function HandleUpdateError(Tree: TUpdateTree; E: EUpdateError;
  461.       var MaxErrors, ErrorCount: Integer): Boolean;
  462.     procedure LogUpdateRecord(Tree: TUpdateTree);
  463.     procedure LogUpdateError(Tree: TUpdateTree; E: EUpdateError;
  464.       Response: TResolverResponse);
  465.     procedure InitKeyFields(Tree: TUpdateTree; ADelta: TPacketDataSet);
  466.     procedure InternalBeforeResolve(Tree: TUpdateTree); virtual;
  467.     function InternalUpdateRecord(Tree: TUpdateTree): Boolean;
  468.     procedure BeginUpdate; virtual;
  469.     procedure EndUpdate; virtual;
  470.     procedure InitTreeData(Tree: TUpdateTree); virtual;
  471.     procedure FreeTreeData(Tree: TUpdateTree); virtual;
  472.     procedure InitializeConflictBuffer(Tree: TUpdateTree); virtual; abstract;
  473.     procedure DoUpdate(Tree: TUpdateTree); virtual; abstract;
  474.     procedure DoDelete(Tree: TUpdateTree); virtual; abstract;
  475.     procedure DoInsert(Tree: TUpdateTree); virtual; abstract;
  476.     function RowRequest(Row: OleVariant; Options: TFetchOptions): OleVariant; virtual;
  477.     function ApplyUpdates(const Delta: OleVariant; MaxErrors: Integer;
  478.       out ErrorCount: Integer): OleVariant; virtual;
  479.   public
  480.     constructor Create(AProvider: TBaseProvider); reintroduce;
  481.     destructor Destroy; override;
  482.   end;
  483.  
  484. { TDataSetResolver }
  485.  
  486.   TDataSetResolver = class(TCustomResolver)
  487.   private
  488.     FBookmark: TBookmarkStr;
  489.     FOpened: Boolean;
  490.     function GetProvider: TDataSetProvider;
  491.     procedure PutRecord(Tree: TUpdateTree);
  492.   protected
  493.     property Provider: TDataSetProvider read GetProvider;
  494.     procedure BeginUpdate; override;
  495.     procedure DoUpdate(Tree: TUpdateTree); override;
  496.     procedure DoDelete(Tree: TUpdateTree); override;
  497.     procedure DoInsert(Tree: TUpdateTree); override;
  498.     procedure EndUpdate; override;
  499.     procedure InternalBeforeResolve(Tree: TUpdateTree); override;
  500.     procedure InitializeConflictBuffer(Tree: TUpdateTree); override;
  501.   public
  502.     constructor Create(AProvider: TDataSetProvider); reintroduce;
  503.   end;
  504.  
  505. { TSQLResolver }
  506.  
  507.   TSQLResolver = class(TCustomResolver)
  508.   private
  509.     FSQL: TStringList;
  510.     FParams: TParams;
  511.     function GetProvider: TDataSetProvider;
  512.     procedure GenWhereSQL(Tree: TUpdateTree; SQL: TStrings; Params: TParams;
  513.       GenUpdateMode: TUpdateMode; Alias: string);
  514.     procedure GenInsertSQL(Tree: TUpdateTree; SQL: TStrings; Params: TParams);
  515.     procedure GenDeleteSQL(Tree: TUpdateTree; SQL: TStrings; Params: TParams;
  516.       Alias: string);
  517.     procedure GenUpdateSQL(Tree: TUpdateTree; SQL: TStrings; Params: TParams;
  518.       Alias: string);
  519.     procedure GenSelectSQL(Tree: TUpdateTree; SQL: TStrings; Params: TParams;
  520.       Alias: string);
  521.     function UseFieldInUpdate(Field: TField): Boolean;
  522.     function UseFieldInWhere(Field: TField; Mode: TUpdateMode): Boolean;
  523.     procedure InternalDoUpdate(Tree: TUpdateTree; UpdateKind: TUpdateKind);
  524.   protected
  525.     property Provider: TDataSetProvider read GetProvider;
  526.     procedure InitializeConflictBuffer(Tree: TUpdateTree); override;
  527.     procedure DoExecSQL(SQL: TStringList; Params: TParams); virtual;
  528.     procedure DoGetValues(SQL: TStringList; Params: TParams;
  529.       DataSet: TDataSet); virtual;
  530.     procedure InitTreeData(Tree: TUpdateTree); override;
  531.     procedure FreeTreeData(Tree: TUpdateTree); override;
  532.     procedure DoUpdate(Tree: TUpdateTree); override;
  533.     procedure DoDelete(Tree: TUpdateTree); override;
  534.     procedure DoInsert(Tree: TUpdateTree); override;
  535.   public
  536.     constructor Create(AProvider: TDataSetProvider); reintroduce;
  537.     destructor Destroy; override;
  538.   end;
  539.  
  540. { TLocalAppServer }
  541.  
  542.   TLocalAppServer = class(TInterfacedObject, IAppServer, ISupportErrorInfo)
  543.   private
  544.     FProvider: TCustomProvider;
  545.     FProviderCreated: Boolean;
  546.   protected
  547.     { IDispatch }
  548.     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
  549.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
  550.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  551.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  552.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  553.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  554.     { IAppServer }
  555.     function AS_ApplyUpdates(const ProviderName: WideString; Delta: OleVariant; MaxErrors: Integer;
  556.                              out ErrorCount: Integer; var OwnerData: OleVariant): OleVariant; safecall;
  557.     function AS_GetRecords(const ProviderName: WideString; Count: Integer; out RecsOut: Integer;
  558.                            Options: Integer; const CommandText: WideString;
  559.                            var Params: OleVariant; var OwnerData: OleVariant): OleVariant; safecall;
  560.     function AS_DataRequest(const ProviderName: WideString; Data: OleVariant): OleVariant; safecall;
  561.     function AS_GetProviderNames: OleVariant; safecall;
  562.     function AS_GetParams(const ProviderName: WideString; var OwnerData: OleVariant): OleVariant; safecall;
  563.     function AS_RowRequest(const ProviderName: WideString; Row: OleVariant; RequestType: Integer;
  564.                            var OwnerData: OleVariant): OleVariant; safecall;
  565.     procedure AS_Execute(const ProviderName: WideString;  const CommandText: WideString;
  566.                          var Params, OwnerData: OleVariant); safecall;
  567.     { ISupportErrorInfo }
  568.     function InterfaceSupportsErrorInfo(const iid: TIID): HResult; stdcall;
  569.   public
  570.     constructor Create(AProvider: TCustomProvider); overload;
  571.     constructor Create(ADataset: TDataset); overload;
  572.     destructor Destroy; override;
  573.     function SafeCallException(ExceptObject: TObject;
  574.       ExceptAddr: Pointer): HResult; override;
  575.   end;
  576.  
  577. { Utility functions }
  578.  
  579. function GetObjectProperty(Instance: TPersistent; const PropName: string): TObject;
  580. function GetStringProperty(Instance: TPersistent; const PropName: string): string;
  581.  
  582. implementation
  583.  
  584. uses MidConst, DBConsts, DBCommon, TypInfo, DataBkr, ComObj;
  585.  
  586. const
  587.   DEFBUFSIZE = 8192;  { Default size for field data buffer }
  588.   DefAlias   = 'A';
  589.   NestAlias  = 'B';
  590.   tagSERVERCALC = 1;
  591.  
  592.   PacketTypeMap: array [TFieldType] of Integer =
  593.     (dsfldUNKNOWN, dsfldZSTRING, dsfldINT, dsfldINT, dsfldINT, dsfldBOOL,
  594.      dsfldFLOATIEEE, dsfldFLOATIEEE, dsfldBCD, dsfldDATE, dsfldTIME,
  595.      dsfldTIMESTAMP, dsfldBYTES, dsfldBYTES, dsfldINT, dsfldBYTES, dsfldBYTES,
  596.      dsfldBYTES, dsfldBYTES, dsfldBYTES, dsfldBYTES, dsfldBYTES, dsfldUNKNOWN,
  597.      dsfldZSTRING, dsfldUNICODE, dsfldINT, dsfldADT, dsfldARRAY, dsfldEMBEDDEDTBL,
  598.      dsfldEMBEDDEDTBL, dsfldBYTES, dsfldBYTES, dsfldUNKNOWN, dsfldUNKNOWN,
  599.      dsfldUNKNOWN, dsfldZSTRING);
  600.  
  601.   ExtraFieldProps: array [0..10] of string = ('Alignment', 'DisplayLabel',
  602.     'DisplayWidth', 'Visible', 'EditMask', 'DisplayFormat', 'EditFormat',
  603.     'MinValue', 'MaxValue', 'currency', 'DisplayValues');
  604.  
  605. { Utility functions }
  606.  
  607. function GetObjectProperty(Instance: TPersistent; const PropName: string): TObject;
  608. var
  609.   PropInfo: PPropInfo;
  610. begin
  611.   Result := nil;
  612.   PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, PropName);
  613.   if (PropInfo <> nil) and (PropInfo^.PropType^.Kind = tkClass) then
  614.     Result := TObject(GetOrdProp(Instance, PropInfo));
  615. end;
  616.  
  617. function GetStringProperty(Instance: TPersistent; const PropName: string): string;
  618. var
  619.   PropInfo: PPropInfo;
  620. begin
  621.   Result := '';
  622.   PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, PropName);
  623.   if (PropInfo <> nil) and (PropInfo^.PropType^.Kind in [tkString, tkLString, tkWString]) then
  624.     Result := GetStrProp(Instance, PropInfo);
  625. end;
  626.  
  627. { EDSWriter }
  628.  
  629. constructor EDSWriter.Create(ErrMsg: string; Status: Integer);
  630. begin
  631.   FErrorCode := Status;
  632.   inherited Create(ErrMsg);
  633. end;
  634.  
  635. { TCustomPacketWriter }
  636.  
  637. constructor TCustomPacketWriter.Create;
  638. begin
  639.   SetLength(FBuffer, DEFBUFSIZE);
  640. end;
  641.  
  642. destructor TCustomPacketWriter.Destroy;
  643. begin
  644.   FIDSWriter := nil;
  645.   FBuffer := nil;
  646.   inherited Destroy;
  647. end;
  648.  
  649. procedure TCustomPacketWriter.Check(Status: Integer);
  650. var
  651.   ErrMsg: array[0..2048] of Char;
  652. begin
  653.   if Status <> 0 then
  654.   begin
  655.     FIDSWriter.GetErrorString(Status, ErrMsg);
  656.     raise EDSWriter.Create(ErrMsg, Status);
  657.   end;
  658. end;
  659.  
  660. procedure TCustomPacketWriter.AddAttribute(Area: TPcktAttrArea; const ParamName: string;
  661.   const Value: OleVariant; IncludeInDelta: Boolean);
  662. const
  663.   ParamTypeMap: array[varSmallInt..varByte] of Integer =
  664.     ( dsfldINT, dsfldINT, dsfldFLOATIEEE, dsfldFLOATIEEE, dsfldBCD,
  665.       dsfldFLOATIEEE, dsfldZSTRING, 0, 0, dsfldBOOL, 0, 0, 0, 0, 0, dsfldINT);
  666.   ParamTypeSize: array[varSmallInt..varByte] of Integer =
  667.     ( SizeOf(SmallInt), SizeOf(Integer), SizeOf(Single), SizeOf(Double),
  668.       SizeOf(Currency), SizeOf(TDateTime), 0, 0, 0, SizeOf(WordBool), 0, 0, 0,
  669.       0, 0, SizeOf(Byte));
  670. var
  671.   ParamType, ParamLen, ElemSize, ElemCount: DWord;
  672.   P: Pointer;
  673.   DateRec: TDateTimeRec;
  674.   TimeStamp: TTimeStamp;
  675. begin
  676.   if ((VarType(Value) and varTypeMask) in [varSmallInt, varInteger, varSingle,
  677.       varDouble, varCurrency, varDate, varOleStr, varBoolean, varByte]) then
  678.   begin
  679.     ParamType := ParamTypeMap[VarType(Value) and varTypeMask];
  680.     ParamLen := ParamTypeSize[VarType(Value) and varTypeMask];
  681.     if ParamType = dsfldZSTRING then
  682.     begin
  683.       ParamType := (dsfldZSTRING shl dsSizeBitsLen) or dsVaryingFldType or SizeOf(Word);
  684.       ParamLen := Length(Value) + 1;
  685.       PWord(FBuffer)^ := ParamLen;
  686.       Inc(ParamLen, SizeOf(Word));
  687.       StrPCopy(@FBuffer[SizeOf(Word)], Value);
  688.     end else
  689.     if ParamType = dsfldTIMESTAMP then
  690.     begin
  691.       TimeStamp := DateTimeToTimeStamp(Value);
  692.       DateRec.DateTime := TimeStampToMSecs(TimeStamp);
  693.       Move(DateRec, PChar(FBuffer)^, ParamLen);
  694.       ParamType := ParamType shl dsSizeBitsLen or SizeOf(TDateTimeRec);
  695.     end else
  696.     if VarIsArray(Value) then
  697.     begin
  698.       if ParamLen = 0 then
  699.         raise EDSWriter.Create(SInvalidOptParamType, 0);
  700.       ElemCount := VarArrayHighBound(Value, 1) + 1;
  701.       ElemSize := ParamLen;
  702.       ParamType := (dsfldUINT shl dsSizeBitsLen) or dsArrayFldType or ElemSize;
  703.       PInteger(FBuffer)^ := ElemCount;
  704.       ParamLen := ElemCount * ElemSize;
  705.       P := VarArrayLock(Value);
  706.       try
  707.         Move(P^, FBuffer[SizeOf(Integer)], ParamLen);
  708.         Inc(ParamLen, SizeOf(Integer));
  709.       finally
  710.         VarArrayUnlock(Value);
  711.       end;
  712.     end else
  713.     begin
  714.       if (VarType(Value) and varByRef) = varByRef then
  715.         P := TVarData(Value).VPointer else
  716.         P := @TVarData(Value).VPointer;
  717.       Move(P^, PByte(FBuffer)^, ParamLen);
  718.       ParamType := ParamType shl dsSizeBitsLen or ParamLen;
  719.     end;
  720.     if IncludeInDelta then
  721.       ParamType := ParamType or dsIncInDelta;
  722.     Check(FIDSWriter.AddAttribute(Area, PChar(ParamName), ParamType, ParamLen, PByte(FBuffer)));
  723.   end else
  724.     raise EDSWriter.Create(SInvalidOptParamType, 0);
  725. end;
  726.  
  727. { TDataPacketWriter }
  728.  
  729. destructor TDataPacketWriter.Destroy;
  730. begin
  731.   FreeInfoRecords(FPutFieldInfo);
  732.   FPutFieldInfo := nil;
  733.   inherited Destroy;
  734. end;
  735.  
  736. procedure TDataPacketWriter.FreeInfoRecords(var Info: TInfoArray);
  737. var
  738.   i: Integer;
  739. begin
  740.   for i := 0 to High(Info) do
  741.     if Info[i].FieldInfos <> nil then
  742.     begin
  743.       FreeInfoRecords(TInfoArray(Info[i].FieldInfos));
  744.       TInfoArray(Info[i].FieldInfos) := nil;
  745.     end;
  746. end;
  747.  
  748. { Writing data }
  749.  
  750. procedure TDataPacketWriter.PutBlobField(Info: PPutFieldInfo);
  751. begin
  752.   if not (poFetchBlobsOnDemand in Options) then
  753.   begin
  754.     Info.Size := Info.DataSet.GetBlobFieldData(Info.FieldNo, TBlobByteData(FBuffer));
  755.     if Info.Size <> 0 then
  756.     begin
  757.       if Length(FBuffer) > Info.Size then
  758.         FBuffer[Info.Size] := 0;
  759.       if TBlobField(Info.Field).Transliterate then
  760.         Info.Size := Info.DataSet.Translate(PChar(FBuffer), PChar(FBuffer), False);
  761.       FIDSWriter.PutField(fldIsChanged, Info.Size, PByte(FBuffer))
  762.     end else
  763.       FIDSWriter.PutField(fldIsNull, 0, nil);
  764.   end else
  765.     FIDSWriter.PutField(fldIsChanged, dsDELAYEDBIT or 1, @Info.Size);
  766. end;
  767.  
  768. procedure TDataPacketWriter.PutCalcField(Info: PPutFieldInfo);
  769. begin
  770.   if Info.DataSet.GetFieldData(Info.Field, FBuffer) then
  771.   begin
  772.     if (Info.Field is TStringField) then
  773.       if TStringField(Info.Field).Transliterate then
  774.         Info.Size := Info.DataSet.Translate(PChar(FBuffer), PChar(FBuffer), False) else
  775.         Info.Size := StrLen(PChar(FBuffer));
  776.     FIDSWriter.PutField(fldIsChanged, Info.Size, PByte(FBuffer));
  777.   end else
  778.     FIDSWriter.PutField(fldIsNull, 0, nil);
  779. end;
  780.  
  781. procedure TDataPacketWriter.PutField(Info: PPutFieldInfo);
  782. begin
  783.   if Info.DataSet.GetFieldData(Info.FieldNo, FBuffer) then
  784.     FIDSWriter.PutField(fldIsChanged, Info.Size, PByte(FBuffer)) else
  785.     FIDSWriter.PutField(fldIsNull, 0, nil);
  786. end;
  787.  
  788. procedure TDataPacketWriter.PutStringField(Info: PPutFieldInfo);
  789. begin
  790.   if Info.DataSet.GetFieldData(Info.FieldNo, FBuffer) then
  791.   begin
  792.     if TStringField(Info.Field).Transliterate then
  793.       Info.Size := Info.DataSet.Translate(PChar(FBuffer), PChar(FBuffer), False) else
  794.       Info.Size := StrLen(PChar(FBuffer));
  795.     FIDSWriter.PutField(fldIsChanged, Info.Size, PByte(FBuffer));
  796.   end else
  797.     FIDSWriter.PutField(fldIsNull, 0, nil);
  798. end;
  799.  
  800. procedure TDataPacketWriter.PutWideStringField(Info: PPutFieldInfo);
  801. var
  802.   W: WideString;
  803. begin
  804.   if Info.DataSet.GetFieldData(Info.FieldNo, @W) then
  805.   begin
  806.     Info.Size := Length(W);
  807.     FIDSWriter.PutField(fldIsChanged, Info.Size * 2, PByte(W));
  808.   end else
  809.     FIDSWriter.PutField(fldIsNull, 0, nil);
  810. end;
  811.  
  812. procedure TDataPacketWriter.PutVarBytesField(Info: PPutFieldInfo);
  813. begin
  814.   if Info.DataSet.GetFieldData(Info.FieldNo, FBuffer) then
  815.     FIDSWriter.PutField(fldIsChanged, PWord(FBuffer)^, @FBuffer[SizeOf(Word)]) else
  816.     FIDSWriter.PutField(fldIsNull, 0, nil);
  817. end;
  818.  
  819. procedure TDataPacketWriter.PutADTField(Info: PPutFieldInfo);
  820. var
  821.   i: Integer;
  822. begin
  823.   if Info.Field.IsNull then
  824.     FIDSWriter.PutField(fldIsNull, 0, nil) else
  825.     FIDSWriter.PutField(fldIsChanged, 0, nil);
  826.   for i := 0 to High(TInfoArray(Info.FieldInfos)) do
  827.     with TInfoArray(Info^.FieldInfos)[i] do
  828.       PutProc(@TInfoArray(Info.FieldInfos)[i]);
  829. end;
  830.  
  831. procedure TDataPacketWriter.PutArrayField(Info: PPutFieldInfo);
  832.  
  833.   procedure RefreshInfos(Src: TField; Dest: PPutFieldInfo);
  834.   var
  835.     i: Integer;
  836.   begin
  837.     with Dest^ do
  838.     begin
  839.       Field := Src;
  840.       FieldNo := Src.FieldNo;
  841.       if (FieldInfos <> nil) then { Must be an ADT }
  842.       begin
  843.         if not (Src is TADTField) then
  844.           raise EDSWriter.CreateFmt(SArrayElementError,[Src.ClassName]);
  845.         with (Src as TADTField) do
  846.           for i := 0 to FieldCount - 1 do
  847.             RefreshInfos(Fields[i], @TInfoArray(FieldInfos)[i]);
  848.       end;
  849.     end;
  850.   end;
  851.  
  852. var
  853.   i: Integer;
  854. begin
  855.   if Info.Field.IsNull then
  856.     FIDSWriter.PutField(fldIsNull, 0, nil) else
  857.     FIDSWriter.PutField(fldIsChanged, 0, nil);
  858.   for i := 0 to TArrayField(Info.Field).FieldCount - 1 do
  859.     with TInfoArray(Info^.FieldInfos)[0] do
  860.     begin
  861.       RefreshInfos(TArrayField(Info.Field).Fields[i], @TInfoArray(Info.FieldInfos)[0]);
  862.       PutProc(@TInfoArray(Info.FieldInfos)[0]);
  863.     end;
  864. end;
  865.  
  866. procedure TDataPacketWriter.PutDataSetField(Info: PPutFieldInfo);
  867. var
  868.   Count: DWord;
  869.   DataSet: TDataSet;
  870. begin
  871.   if Info.Field <> nil then
  872.   begin
  873.     if Info.Field.IsNull then
  874.     begin
  875.       FIDSWriter.PutField(fldIsNull, 0, nil);
  876.       Exit;
  877.     end;
  878.     DataSet := TDataSetField(Info.Field).NestedDataSet;
  879.   end else
  880.     DataSet := Info.DataSet;
  881.   if (poFetchDetailsOnDemand in Options) then
  882.     Count := dsDELAYEDBIT else
  883.     Count := DWord(-1);
  884.   FIDSWriter.PutField(fldIsChanged, SizeOf(Count), @Count);
  885.   if (not (poFetchDetailsOnDemand in Options)) and (Count = DWord(-1)) then
  886.   begin
  887.     DataSet.UpdateCursorPos;
  888.     DataSet.First;
  889.     DataSet.BlockReadSize := MaxInt;
  890.     try
  891.       WriteDataSet(DataSet, TInfoArray(Info.FieldInfos), -1);
  892.       FIDSWriter.EndOfNestedRows;
  893.     finally
  894.       DataSet.BlockReadSize := 0;
  895.     end;
  896.   end;
  897. end;
  898.  
  899. function TDataPacketWriter.WriteDataSet(DataSet: TDataSet; var Info: TInfoArray;
  900.   RecsOut: Integer): Integer;
  901. const
  902.   B: Byte = 0;
  903. var
  904.   i: Integer;
  905. begin
  906.   Result := 0;
  907.   if RecsOut = AllRecords then
  908.     RecsOut := High(Integer);
  909.   if DataSet.DefaultFields then
  910.     RefreshPutProcs(DataSet, Info);
  911.   while (not DataSet.EOF) and (Result < RecsOut) do
  912.   begin
  913.     FIDSWriter.PutField(fldIsChanged, 1, @B);
  914.     for i := 0 to High(Info) do
  915.       Info[i].PutProc(@Info[i]);
  916.     Inc(Result);
  917.     if Result < RecsOut then
  918.       DataSet.Next;
  919.   end;
  920. end;
  921.  
  922. { Writing meta data }
  923.  
  924. procedure TDataPacketWriter.AddDataSetAttributes(DataSet: TDataSet);
  925. var
  926.   i: Integer;
  927.   List: TList;
  928. begin
  929.   if Assigned(FOnGetParams) then
  930.   begin
  931.     List := TList.Create;
  932.     try
  933.       FOnGetParams(DataSet, List);
  934.       for i := 0 to List.Count - 1 do
  935.         with PPacketAttribute(List[i])^ do
  936.         begin
  937.           AddAttribute(pcktAttrArea, Name, Value, IncludeInDelta);
  938.           Dispose(PPacketAttribute(List[i]));
  939.         end;
  940.     finally
  941.       List.Free;
  942.     end;
  943.   end;
  944. end;
  945.  
  946. function TDataPacketWriter.GetFieldIdx(const FieldName: string; const Info: TInfoArray): Integer;
  947. var
  948.   i: Integer;
  949. begin
  950.   Result := -1;
  951.   for i := 0 to High(Info) do
  952.     if (Info[i].Field <> nil) and (Info[i].Field.FieldName = FieldName) then
  953.     begin
  954.       Result := Info[i].LocalFieldIndex;
  955.       break;
  956.     end;
  957. end;
  958.  
  959. type
  960.   TPropWriter = class(TWriter);
  961.  
  962. procedure TDataPacketWriter.AddExtraFieldProps(Field: TField);
  963.  
  964.   procedure WriteProp(Instance: TPersistent; const PropName: string;
  965.     Writer: TPropWriter);
  966.   var
  967.     PropInfo: PPropInfo;
  968.   begin
  969.     PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, PropName);
  970.     if (PropInfo <> nil) and IsStoredProp(Instance, PropInfo) then
  971.       Writer.WriteProperty(Instance, PropInfo);
  972.   end;
  973.  
  974. var
  975.   Writer: TPropWriter;
  976.   Stream: TMemoryStream;
  977.   i, Attr: Integer;
  978. begin
  979.   Stream := TMemoryStream.Create;
  980.   try
  981.     Writer := TPropWriter.Create(Stream, 1024);
  982.     try
  983.       Writer.WriteListBegin;
  984.       for i := 0 to High(ExtraFieldProps) do
  985.         WriteProp(Field, ExtraFieldProps[i], Writer);
  986.       Writer.WriteListEnd;
  987.       Writer.FlushBuffer;
  988.       if Stream.Size > 2 then
  989.       begin
  990.         Attr := (dsfldBYTES shl dsSizeBitsLen) or dsArrayFldType or SizeOf(Byte);
  991.         PInteger(FBuffer)^ := Stream.Size;
  992.         Move(Stream.Memory^, FBuffer[SizeOf(Integer)], Stream.Size);
  993.         Check(FIDSWriter.AddAttribute(fldAttrArea, szFIELDPROPS, Attr,
  994.           Stream.Size + SizeOf(Integer), FBuffer));
  995.       end;
  996.     finally
  997.       Writer.Free;
  998.     end;
  999.   finally
  1000.     Stream.Free;
  1001.   end;
  1002. end;
  1003.  
  1004. procedure TDataPacketWriter.AddColumn(const Info: TPutFieldInfo);
  1005.  
  1006.   procedure AddFieldDesc(const FldName: string; FldType, Attributes: Integer);
  1007.   var
  1008.     FldDesc: TDSDataPacketFldDesc;
  1009.   begin
  1010.     if Length(FldName) > SizeOf(FldDesc.szFieldName) then
  1011.       raise EDSWriter.CreateFmt(SFieldNameTooLong,[SizeOf(FldDesc.szFieldName) - 1]);
  1012.     FillChar(FldDesc, SizeOf(FldDesc), 0);
  1013.     StrCopy(FldDesc.szFieldName, PChar(FldName));
  1014.     FldDesc.iFieldType := FldType;
  1015.     FldDesc.iAttributes := Attributes;
  1016.     Check(FIDSWriter.AddColumnDesc(FldDesc));
  1017.   end;
  1018.  
  1019.   function ComputeInfoCount(Info: TInfoArray): Integer;
  1020.   var
  1021.     i: Integer;
  1022.   begin
  1023.     Result := Length(Info);
  1024.     for i := 0 to High(Info) do
  1025.       if Info[i].FieldInfos <> nil then
  1026.         Inc(Result, ComputeInfoCount(Info[i].FieldInfos));
  1027.   end;
  1028.  
  1029.   procedure AddMinMax(AField: TField);
  1030.   begin
  1031.     case AField.DataType of
  1032.       ftInteger, ftSmallInt:    
  1033.         if (TIntegerField(AField).MinValue <> 0) or 
  1034.            (TIntegerField(AField).MaxValue <> 0)  then
  1035.            begin
  1036.              AddAttribute(fldAttrArea, szMINVALUE, 
  1037.                            TIntegerField(AField).MinValue, False);
  1038.              AddAttribute(fldAttrArea, szMAXVALUE, 
  1039.                           TIntegerField(AField).MaxValue, False);
  1040.            end;
  1041.       ftCurrency, ftFloat:
  1042.         if (TFloatField(AField).MinValue <> 0 ) or 
  1043.            (TFloatField(AField).MaxValue <> 0 ) then
  1044.            begin
  1045.              AddAttribute(fldAttrArea, szMINVALUE, 
  1046.                            TFloatField(AField).MinValue, False);
  1047.              AddAttribute(fldAttrArea, szMAXVALUE, 
  1048.                           TFloatField(AField).MaxValue, False);
  1049.            end;
  1050.       ftBCD:
  1051.         if (TBCDField(AField).MinValue <> 0 ) or 
  1052.            (TIntegerField(AField).MaxValue <> 0 ) then
  1053.            begin
  1054.              AddAttribute(fldAttrArea, szMINVALUE, 
  1055.                            TBCDField(AField).MinValue, False);
  1056.              AddAttribute(fldAttrArea, szMAXVALUE, 
  1057.                           TBCDField(AField).MaxValue, False);
  1058.            end;
  1059.     end;
  1060.   end;
  1061.  
  1062. var
  1063.   FldType, Prec, Attr, i, Width: Integer;
  1064.   TempStr: string;
  1065. begin
  1066.   if Info.IsDetail and (Info.Field = nil) then
  1067.   begin
  1068.     FldType := (dsfldEMBEDDEDTBL shl dsSizeBitsLen) or
  1069.       ComputeInfoCount(Info.FieldInfos) or dsPseudoFldType;
  1070.     AddFieldDesc(Info.DataSet.Name, FldType, 0);
  1071.     WriteMetaData(Info.DataSet, TInfoArray(Info.FieldInfos));
  1072.   end else
  1073.   begin
  1074.     Width := 0;
  1075.     Attr := 0;
  1076.     if Info.Field.ReadOnly or (Info.Field.FieldKind <> fkData) then Attr := Attr or fldAttrREADONLY;
  1077.     if Info.Field.Required and (Info.Field.DataType <> ftAutoInc) then Attr := Attr or fldAttrREQUIRED;
  1078.     if (pfHidden in Info.Field.ProviderFlags) then Attr := Attr or fldAttrHIDDEN or fldAttrREADONLY;
  1079.     FldType := PacketTypeMap[Info.Field.DataType];
  1080.     case Info.Field.DataType of
  1081.       ftString, ftFixedChar, ftVarBytes, ftGUID, ftWideString:
  1082.       begin
  1083.         FldType := FldType shl dsSizeBitsLen or dsVaryingFldType;
  1084.         if Info.Size < 255 then
  1085.           FldType := FldType or SizeOf(Byte) else
  1086.           FldType := FldType or SizeOf(Word);
  1087.         Width := Info.Size;
  1088.       end;
  1089.       ftBCD:
  1090.       begin
  1091.         if TBCDField(Info.Field).Precision = 0 then
  1092.           Width := 32 else
  1093.           Width := TBCDField(Info.Field).Precision;
  1094.         Prec := Width shr 1;
  1095.         Inc(Prec, Prec and 1);  { Make an even number }
  1096.         FldType := (FldType shl dsSizeBitsLen) or (Prec + 2);
  1097.       end;
  1098.       ftArray:
  1099.         FldType := (FldType shl dsSizeBitsLen) or dsPseudoFldType or
  1100.           dsCompArrayFldType or TObjectField(Info.Field).Size;
  1101.       ftADT:
  1102.         FldType := (FldType shl dsSizeBitsLen) or dsPseudoFldType or
  1103.           TObjectField(Info.Field).FieldCount;
  1104.       ftDataSet, ftReference:
  1105.         FldType := (FldType shl dsSizeBitsLen) or dsPseudoFldType or
  1106.           dsEmbeddedFldType or ComputeInfoCount(TInfoArray(Info.FieldInfos));
  1107.     else
  1108.       if Info.Field.IsBlob then
  1109.       begin
  1110.         FldType := (FldType shl dsSizeBitsLen) or dsVaryingFldType or SizeOf(Integer);
  1111.         Width := Info.Field.Size;
  1112.       end else
  1113.         FldType := (FldType shl dsSizeBitsLen) or Info.Size;
  1114.     end;
  1115.     AddFieldDesc(Info.Field.FieldName, FldType, Attr);
  1116.     if (Info.Field.FieldKind <> fkData) then
  1117.       AddAttribute(fldAttrArea, szSERVERCALC, True, True);
  1118.     if Info.Field.ProviderFlags <> [pfInWhere, pfInUpdate] then
  1119.       AddAttribute(fldAttrArea, szPROVFLAGS, Byte(Info.Field.ProviderFlags), True);
  1120.     if Info.Field.Origin <> '' then
  1121.       AddAttribute(fldAttrArea, szORIGIN, Info.Field.Origin, True);
  1122.     if Width > 0 then
  1123.       AddAttribute(fldAttrArea, szWIDTH, Width, False);
  1124.     if (Info.Field is TBCDField) and (TBCDField(Info.Field).Size <> 0) then
  1125.       AddAttribute(fldAttrArea, szDECIMALS, TBCDField(Info.Field).Size, False);
  1126.     AddMinMax(Info.Field);
  1127.     case Info.Field.DataType of
  1128.       ftCurrency: TempStr := szstMONEY;
  1129.       ftAutoInc: TempStr := szstAUTOINC;
  1130.       ftVarBytes, ftBlob: TempStr := szstBINARY;
  1131.       ftMemo: TempStr := szstMEMO;
  1132.       ftFmtMemo: TempStr := szstFMTMEMO;
  1133.       ftParadoxOle: TempStr := szstOLEOBJ;
  1134.       ftGraphic: TempStr := szstGRAPHIC;
  1135.       ftDBaseOle: TempStr := szstDBSOLEOBJ;
  1136.       ftTypedBinary: TempStr := szstTYPEDBINARY;
  1137.       ftADT:
  1138.         if (Info.Field.ParentField <> nil) and
  1139.            (Info.Field.ParentField.DataType in [ftDataSet, ftReference]) then
  1140.           TempStr := szstADTNESTEDTABLE;
  1141.       ftReference: TempStr := szstREFNESTEDTABLE;
  1142.       ftString:
  1143.         if TStringField(Info.Field).FixedChar then
  1144.           TempStr := szstFIXEDCHAR else
  1145.           TempStr := '';
  1146.       ftGUID: TempStr := szstGUID;
  1147.       ftOraClob: TempStr := szstHMEMO;
  1148.       ftOraBlob: TempStr := szstHBINARY;
  1149.     else
  1150.         TempStr := '';
  1151.     end;
  1152.     if TempStr <> '' then
  1153.       AddAttribute(fldAttrArea, szSUBTYPE, TempStr, False);
  1154.     if Info.Field is TObjectField then
  1155.       AddAttribute(fldAttrArea, szTYPENAME, TObjectField(Info.Field).ObjectType, False);
  1156.     if poIncFieldProps in Options then
  1157.       AddExtraFieldProps(Info.Field);
  1158.     case Info.Field.DataType of
  1159.       ftADT, ftArray: { Array will only have 1 child field }
  1160.         for i := 0 to High(TInfoArray(Info.FieldInfos)) do
  1161.           AddColumn(TInfoArray(Info.FieldInfos)[i]);
  1162.       ftDataSet, ftReference:
  1163.         with TDataSetField(Info.Field) do
  1164.           WriteMetaData(NestedDataSet, TInfoArray(Info.FieldInfos),
  1165.             Info.Field.DataType = ftReference);
  1166.     end;
  1167.   end;
  1168. end;
  1169.  
  1170. procedure TDataPacketWriter.AddConstraints(DataSet: TDataSet);
  1171. type
  1172.   TConstraintType = (ctField, ctRecord, ctDefault);
  1173.  
  1174.   procedure AddSQLExprAttr(ExprParser: TExprParser; const ExprText, ExprErrMsg,
  1175.     FieldName: string; FieldIndex: Integer; ConstraintType: TConstraintType;
  1176.     Required: Boolean);
  1177.   type
  1178.     PSQLExprInfo = ^TSQLExprInfo;
  1179.     TSQLExprInfo = packed record
  1180.       iErrStrLen: Integer;
  1181.       iFldNum: Integer;
  1182.       bReqExpr: BYTE;
  1183.     end;
  1184.   const
  1185.     TypeStr: array[TConstraintType] of PChar = (szBDEDOMX, szBDERECX, szBDEDEFX);
  1186.     Attr: Integer = dsVaryingFldType or SizeOf(Integer) or (dsfldBYTES shl dsSizeBitsLen);
  1187.   var
  1188.     ErrorStr: string;
  1189.     AttrType: PChar;
  1190.     Len, AttrSize: Integer;
  1191.     SQLExprInfo: PSQLExprInfo;
  1192.     Options: TParserOptions;
  1193.   begin
  1194.     if ExprText = '' then Exit;
  1195.     if (ConstraintType <> ctDefault) and (ExprErrMsg = '') then
  1196.     begin
  1197.       if (ConstraintType = ctField) and (FieldName <> '') then
  1198.         ErrorStr := Format('%s %s: %s %s',[SConstraintFailed, SField, FieldName, ExprText]) else
  1199.         ErrorStr := Format('%s %s',[SConstraintFailed, ExprText]);
  1200.     end else
  1201.       ErrorStr := ExprErrMsg;
  1202.     Len := Length(ErrorStr);
  1203.     if (Len > 0) then Inc(Len);
  1204.     SQLExprInfo := @FBuffer[SizeOf(Integer)];
  1205.     SQLExprInfo.iErrStrLen := Len;
  1206.     SQLExprInfo.iFldNum := FieldIndex;
  1207.     SQLExprInfo.bReqExpr := Ord(Required);
  1208.     Options := [poExtSyntax];
  1209.     if ConstraintType = ctDefault then Include(Options, poDefaultExpr);
  1210.     if ConstraintType = ctRecord then Include(Options, poUseOrigNames);
  1211.     if FieldName <> '' then Include(Options, poFieldNameGiven);
  1212.     with ExprParser do
  1213.     begin
  1214.       SetExprParams(ExprText, [], Options, FieldName);
  1215.       Move(FilterData[0], FBuffer[SizeOf(TSQLExprInfo) + Len + SizeOf(Integer)], DataSize);
  1216.       AttrSize := DataSize + SizeOf(TSQLExprInfo) + Len;
  1217.     end;
  1218.     PInteger(FBuffer)^ := AttrSize;
  1219.     if Len > 0 then
  1220.       StrCopy(@FBuffer[SizeOf(TSQLExprInfo) + SizeOf(Integer)], PChar(ErrorStr));
  1221.     AttrType := TypeStr[ConstraintType];
  1222.     Check(FIDSWriter.AddAttribute(pcktAttrArea, AttrType, Attr, AttrSize + SizeOf(Integer), PByte(FBuffer)));
  1223.   end;
  1224.  
  1225. var
  1226.   i: Integer;
  1227.   ExprParser: TExprParser;
  1228.   Constraints: TCheckConstraints;
  1229.   Obj: TObject;
  1230.   ErrMsg: string;
  1231. begin
  1232.   ExprParser := TExprParser.Create(DataSet, '', [], [], '', nil, FieldTypeMap);
  1233.   try
  1234.     Obj := GetObjectProperty(DataSet, 'Constraints'); { Do not localize }
  1235.     if (Obj <> nil) and (Obj is TCheckConstraints) then
  1236.     begin
  1237.       Constraints := Obj as TCheckConstraints;
  1238.       try
  1239.         for i := 0 to Constraints.Count - 1 do
  1240.           with Constraints[i] do
  1241.           begin
  1242.             AddSQLExprAttr(ExprParser, ImportedConstraint, ErrorMessage, '', 0,
  1243.               ctRecord, False);
  1244.             AddSQLExprAttr(ExprParser, CustomConstraint, ErrorMessage, '', 0,
  1245.               ctRecord, False);
  1246.           end;
  1247.       except
  1248.         on E: Exception do
  1249.         begin
  1250.           if DataSet.Name <> '' then
  1251.             ErrMsg := Format('%s: %s',[DataSet.Name, SRecConstFail]) else
  1252.             ErrMsg := SRecConstFail;
  1253.           raise EDSWriter.CreateFmt(ErrMsg, [E.Message]);
  1254.         end;
  1255.       end;
  1256.     end;
  1257.     for i := 0 to DataSet.FieldList.Count - 1 do
  1258.       with DataSet.FieldList[i] do
  1259.       begin
  1260.         try
  1261.           AddSQLExprAttr(ExprParser, DefaultExpression, '', FullName, i + 1,
  1262.             ctDefault, False);
  1263.         except
  1264.           on E: Exception do
  1265.           begin
  1266.             if Name <> '' then
  1267.               ErrMsg := Format('%s: %s',[Name, SDefExprFail]) else
  1268.             if DataSet.Name <> '' then
  1269.               ErrMsg := Format('%s.%s: %s',[DataSet.Name, FullName, SDefExprFail]) else
  1270.               ErrMsg := Format('%s: %s',[FullName, SDefExprFail]);
  1271.             raise EDSWriter.CreateFmt(ErrMsg, [E.Message]);
  1272.           end;
  1273.         end;
  1274.         try
  1275.           AddSQLExprAttr(ExprParser, ImportedConstraint, ConstraintErrorMessage,
  1276.             FullName, i + 1, ctField, False);
  1277.           AddSQLExprAttr(ExprParser, CustomConstraint, ConstraintErrorMessage,
  1278.             FullName, i + 1, ctField, False);
  1279.         except
  1280.           on E: Exception do
  1281.           begin
  1282.             if Name <> '' then
  1283.               ErrMsg := Format('%s: %s',[Name, SFieldConstFail]) else
  1284.             if DataSet.Name <> '' then
  1285.               ErrMsg := Format('%s.%s: %s',[DataSet.Name, FullName, SFieldConstFail]) else
  1286.               ErrMsg := Format('%s: %s',[FullName, SFieldConstFail]);
  1287.             raise EDSWriter.CreateFmt(ErrMsg, [E.Message]);
  1288.           end;
  1289.         end;
  1290.       end;
  1291.   finally
  1292.     ExprParser.Free;
  1293.   end;
  1294. end;
  1295.  
  1296. procedure TDataPacketWriter.AddIndexDefs(DataSet: TDataSet; const Info: TInfoArray);
  1297. var
  1298.   FieldList, CaseList, DescList: TList;
  1299.  
  1300.   function GetKeyData(Index: TIndexDef): OleVariant;
  1301.   var
  1302.     i: Integer;
  1303.     x: SmallInt;
  1304.   begin
  1305.     with Index do
  1306.     begin
  1307.       FieldList.Clear;
  1308.       CaseList.Clear;
  1309.       DescList.Clear;
  1310.       DataSet.GetFieldList(FieldList, Fields);
  1311.       DataSet.GetFieldList(CaseList, CaseInsFields);
  1312.       DataSet.GetFieldList(DescList, DescFields);
  1313.       Result := VarArrayCreate([0, FieldList.Count - 1], varSmallInt);
  1314.       for i := 0 to FieldList.Count - 1 do
  1315.       begin
  1316.         x := GetFieldIdx(TField(FieldList[i]).FieldName, Info);
  1317.         if (CaseList.IndexOf(FieldList[i]) <> -1) or
  1318.            ((i = 0) and (FieldList.Count = 1) and (ixCaseInSensitive in Options)) then
  1319.           x := x or dskeyCASEINSENSITIVE;
  1320.         if (DescList.IndexOf(FieldList[i]) <> -1) or
  1321.            ((i = 0) and (FieldList.Count = 1) and (ixDescending in Options)) then
  1322.           x := x or SmallInt(dskeyDESCENDING);
  1323.         Result[i] := x;
  1324.       end;
  1325.     end;
  1326.   end;
  1327.  
  1328. var
  1329.   i: Integer;
  1330.   DefIdx, KeyIndex: TIndexDef;
  1331.   IndexDefs: TIndexDefs;
  1332.   KeyList: OleVariant;
  1333.   KeyFields: string;
  1334. begin
  1335.   FieldList := TList.Create;
  1336.   try
  1337.     CaseList := TList.Create;
  1338.     try
  1339.       DescList := TList.Create;
  1340.       try
  1341.         { Get the DEFAULT_ORDER }
  1342.         DefIdx := IProviderSupport(DataSet).PSGetDefaultOrder;
  1343.         if Assigned(DefIdx) then
  1344.         try
  1345.           KeyList := GetKeyData(DefIdx);
  1346.           AddAttribute(pcktAttrArea, szDEFAULT_ORDER, KeyList, False);
  1347.         finally
  1348.           DefIdx.Free;
  1349.         end;
  1350.         KeyFields := IProviderSupport(DataSet).PSGetKeyFields;
  1351.         IndexDefs := IProviderSupport(DataSet).PSGetIndexDefs([ixUnique]);
  1352.         try
  1353.           if KeyFields <> '' then
  1354.           begin
  1355.             { PRIMARY_KEY is used to define the keyfields }
  1356.             KeyList := NULL;
  1357.             if Assigned(IndexDefs) then
  1358.             begin
  1359.               KeyIndex := IndexDefs.GetIndexForFields(KeyFields, False);
  1360.               if Assigned(KeyIndex) then
  1361.               begin
  1362.                 KeyList := GetKeyData(KeyIndex);
  1363.                 KeyIndex.Free;{ KeyIndex is already used, remove it from the list }
  1364.               end;
  1365.             end;
  1366.             if VarIsNull(KeyList) then
  1367.             begin
  1368.               DataSet.GetFieldList(FieldList, KeyFields);
  1369.               KeyList := VarArrayCreate([0, FieldList.Count - 1], varSmallInt);
  1370.               for i := 0 to FieldList.Count - 1 do
  1371.                 KeyList[i] := GetFieldIdx(TField(FieldList[i]).FieldName, Info);
  1372.             end;
  1373.             if not VarIsNull(KeyList) then
  1374.               AddAttribute(pcktAttrArea, szPRIMARY_KEY, KeyList, False);
  1375.           end;
  1376.           if Assigned(IndexDefs) then
  1377.             for i := 0 to IndexDefs.Count - 1 do
  1378.               with IndexDefs[i] do
  1379.               begin
  1380.                 KeyList := GetKeyData(IndexDefs[i]);
  1381.                 AddAttribute(pcktAttrArea, szUNIQUE_KEY, KeyList, False);
  1382.               end;
  1383.         finally
  1384.           IndexDefs.Free;
  1385.         end;
  1386.       finally
  1387.         DescList.Free;
  1388.       end;
  1389.     finally
  1390.       CaseList.Free;
  1391.     end;
  1392.   finally
  1393.     FieldList.Free;
  1394.   end;
  1395. end;
  1396.  
  1397. procedure TDataPacketWriter.AddFieldLinks(const Info: TInfoArray);
  1398. var
  1399.   MasterFields, DetailFields: TList;
  1400.   i, j: Integer;
  1401.   LinkFields: Variant;
  1402. begin
  1403.   MasterFields := TList.Create;
  1404.   try
  1405.     DetailFields := TList.Create;
  1406.     try
  1407.       for i := 0 to High(Info) do
  1408.         if Info[i].IsDetail and (Info[i].Field = nil) then
  1409.         begin
  1410.           Info[i].DataSet.GetDetailLinkFields(MasterFields, DetailFields);
  1411.           if (MasterFields.Count > 0) and (MasterFields.Count <= DetailFields.Count) then
  1412.           begin
  1413.             LinkFields := VarArrayCreate([0, MasterFields.Count * 2], varSmallInt);
  1414.             LinkFields[0] := Info[i].LocalFieldIndex;
  1415.             for j := 0 to MasterFields.Count - 1 do
  1416.               LinkFields[j + 1] := GetFieldIdx(TField(MasterFields[j]).FieldName,
  1417.                 Info);
  1418.             for j := 0 to MasterFields.Count - 1 do
  1419.               LinkFields[j + MasterFields.Count + 1] :=
  1420.                 GetFieldIdx(TField(DetailFields[j]).FieldName, TInfoArray(Info[i].FieldInfos));
  1421.             AddAttribute(pcktAttrArea, szMD_FIELDLINKS, LinkFields, False);
  1422.           end;
  1423.         end;
  1424.     finally
  1425.       DetailFields.Free;
  1426.     end;
  1427.   finally
  1428.     MasterFields.Free;
  1429.   end;
  1430. end;
  1431.  
  1432. procedure TDataPacketWriter.WriteMetaData(DataSet: TDataSet; const Info: TInfoArray;
  1433.   IsReference: Boolean);
  1434. var
  1435.   i, MDOptions: Integer;
  1436. begin
  1437.   for i := 0 to High(Info) do
  1438.     AddColumn(Info[i]);
  1439.   if (poReadOnly in Options) or IsReference then
  1440.     AddAttribute(pcktAttrArea, szREADONLY, True, False);
  1441.   if (poDisableEdits in Options) then
  1442.     AddAttribute(pcktAttrArea, szDISABLE_EDITS, True, False);
  1443.   if (poDisableInserts in Options) then
  1444.     AddAttribute(pcktAttrArea, szDISABLE_INSERTS, True, False);
  1445.   if (poDisableDeletes in Options) then
  1446.     AddAttribute(pcktAttrArea, szDISABLE_DELETES, True, False);
  1447.   if (poNoReset in Options) then
  1448.     AddAttribute(pcktAttrArea, szNO_RESET_CALL, True, False);
  1449.   if Constraints then
  1450.     AddConstraints(DataSet);
  1451.   AddIndexDefs(DataSet, Info);
  1452.   AddFieldLinks(Info);
  1453.   MDOptions := 0;
  1454.   if poCascadeDeletes in Options then MDOptions := dsCASCADEDELETES;
  1455.   if poCascadeUpdates in Options then MDOptions := MDOptions or dsCASCADEUPDATES;
  1456.   if MDOptions <> 0 then
  1457.     AddAttribute(pcktAttrArea, szMD_SEMANTICS, MDOptions, True);
  1458.   AddDataSetAttributes(DataSet);
  1459.   if Info <> FPutFieldInfo then
  1460.     Check(FIDSWriter.AddAttribute(pcktAttrArea, nil, 0, 0, nil));
  1461. end;
  1462.  
  1463. procedure TDataPacketWriter.RefreshPutProcs(ADataSet: TDataSet; var Info: TInfoArray);
  1464.  
  1465.   procedure RefreshInfo(ADataSet: TDataSet; AField: TField; var Info: TPutFieldInfo);
  1466.   var
  1467.     j: Integer;
  1468.   begin
  1469.     Info.Field := AField;
  1470.     if AField = nil then
  1471.       Info.DataSet := ADataSet
  1472.     else
  1473.     begin
  1474.       Info.DataSet := AField.DataSet;
  1475.       if AField.DataType = ftADT then
  1476.       begin
  1477.         with TADTField(AField) do
  1478.         for j := 0 to FieldCount - 1 do
  1479.           RefreshInfo(ADataSet, Fields[j], TInfoArray(Info.FieldInfos)[j]);
  1480.       end;
  1481.     end;
  1482.   end;
  1483.  
  1484. var
  1485.   i: Integer;
  1486.   List: TList;
  1487. begin
  1488.   List := TList.Create;
  1489.   try
  1490.     ADataSet.GetDetailDataSets(List);
  1491.     for i := 0 to ADataSet.FieldCount - 1 do
  1492.       RefreshInfo(ADataSet, ADataSet.Fields[i], Info[i]);
  1493.     for i := 0 to List.Count - 1 do
  1494.       RefreshInfo(TDataSet(List[i]), nil, Info[ADataSet.FieldCount + i]);
  1495.   finally
  1496.     List.Free;
  1497.   end;
  1498. end;
  1499.  
  1500. function TDataPacketWriter.InitPutProcs(ADataSet: TDataSet;
  1501.   var GlobalIdx: Integer): TInfoArray;
  1502.  
  1503.   procedure InitInfoStruct(var Info: TPutFieldInfo; AField: TField;
  1504.     var GlobalIdx, LocalIdx: Integer);
  1505.   begin
  1506.     FillChar(Info, SizeOf(Info), 0);
  1507.     with Info do
  1508.     begin
  1509.       IsDetail := AField = nil;
  1510.       Field := AField;
  1511.       Inc(GlobalIdx);
  1512.       LocalFieldIndex := LocalIdx;
  1513.       Inc(LocalIdx);
  1514.       if Field <> nil then
  1515.       begin
  1516.         FieldNo := Field.FieldNo;
  1517.         Size := Field.DataSize;
  1518.         DataSet := Field.DataSet;
  1519.       end;
  1520.     end;
  1521.   end;
  1522.  
  1523.   procedure InitFieldProc(ADataSet: TDataSet; AField: TField;
  1524.     var Info: TPutFieldInfo; var GlobalIdx, LocalIdx: Integer);
  1525.   var
  1526.     i: Integer;
  1527.     NestedIdx: Integer;
  1528.   begin
  1529.     with Info do
  1530.     begin
  1531.       InitInfoStruct(Info, AField, GlobalIdx, LocalIdx);
  1532.       if AField = nil then { Linked dataset }
  1533.       begin
  1534.         Opened := not ADataSet.Active;
  1535.         if Opened then ADataSet.Open;
  1536.         DataSet := ADataSet;
  1537.         PutProc := PutDataSetField;
  1538.         TInfoArray(FieldInfos) := InitPutProcs(DataSet, GlobalIdx);
  1539.       end else
  1540.       begin
  1541.         case Field.DataType of
  1542.           ftString, ftFixedChar, ftGUID:
  1543.           begin
  1544.             PutProc := PutStringField;
  1545.             Dec(Size);  { Don't count the null terminator }
  1546.           end;
  1547.           ftWideString:
  1548.           begin
  1549.             PutProc := PutWideStringField;
  1550.             Size := AField.Size * 2;
  1551.           end;
  1552.           ftVarBytes:
  1553.           begin
  1554.             PutProc := PutVarBytesField;
  1555.             Dec(Size, 2); { Don't write size bytes }
  1556.           end;
  1557.           ftADT:
  1558.           with TADTField(Field) do
  1559.           begin
  1560.             PutProc := PutADTField;
  1561.             SetLength(TInfoArray(FieldInfos), FieldCount);
  1562.             for i := 0 to FieldCount - 1 do
  1563.               InitFieldProc(ADataSet, Fields[i], TInfoArray(FieldInfos)[i],
  1564.                 GlobalIdx, LocalIdx);
  1565.           end;
  1566.           ftArray:
  1567.           with TArrayField(Field) do
  1568.           begin
  1569.             PutProc := PutArrayField;
  1570.             SetLength(TInfoArray(FieldInfos), 1);
  1571.             NestedIdx := LocalIdx;
  1572.             InitFieldProc(ADataSet, Fields[0], TInfoArray(FieldInfos)[0],
  1573.                 GlobalIdx, LocalIdx);
  1574.             LocalIdx := (LocalIdx - NestedIdx) * (FieldCount - 1) + LocalIdx;
  1575.           end;
  1576.           ftDataSet, ftReference:
  1577.           with TDataSetField(Field).NestedDataSet do
  1578.           begin
  1579.             PutProc := PutDataSetField;
  1580.             NestedIdx := 1;
  1581.             SetLength(TInfoArray(FieldInfos), FieldCount);
  1582.             for i := 0 to FieldCount - 1 do
  1583.               InitFieldProc(TDataSetField(Field).NestedDataSet, Fields[i],
  1584.                 TInfoArray(FieldInfos)[i], GlobalIdx, NestedIdx);
  1585.           end;
  1586.           ftSmallint, ftInteger, ftWord, ftBoolean, ftFloat, ftCurrency, ftBCD,
  1587.           ftDate, ftTime, ftDateTime, ftAutoInc, ftLargeint, ftBytes:
  1588.             PutProc := PutField;
  1589.           ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftParadoxOle, ftDBaseOle, ftTypedBinary, ftOraBlob, ftOraClob:
  1590.             PutProc := PutBlobField;
  1591.         else
  1592.           DatabaseErrorFmt(SUnknownFieldType, [Field.FieldName]);
  1593.         end;
  1594.         if Field.FieldKind <> fkData then
  1595.           PutProc := PutCalcField;
  1596.       end;
  1597.     end;
  1598.   end;
  1599.  
  1600. var
  1601.   i, LocalIdx: Integer;
  1602.   List: TList;
  1603. begin
  1604.   LocalIdx := 1;
  1605.   List := TList.Create;
  1606.   try
  1607.     ADataSet.GetDetailDataSets(List);
  1608.     SetLength(Result, ADataSet.FieldCount + List.Count);
  1609.     for i := 0 to ADataSet.FieldCount - 1 do
  1610.       InitFieldProc(ADataSet, ADataSet.Fields[i], Result[i], GlobalIdx, LocalIdx);
  1611.     for i := 0 to List.Count - 1 do
  1612.       InitFieldProc(TDataSet(List[i]), nil, Result[ADataSet.FieldCount + i],
  1613.         GlobalIdx, LocalIdx);
  1614.   finally
  1615.     List.Free;
  1616.   end;
  1617. end;
  1618.  
  1619. procedure TDataPacketWriter.GetDataPacket(DataSet: TDataSet;
  1620.   var RecsOut: Integer; out Data: OleVariant);
  1621.  
  1622.   procedure CheckMetaData(DataSet: TDataSet);
  1623.   var
  1624.     Idx: Integer;
  1625.     TempPacket: TDataPacket;
  1626.     Version: Integer;
  1627.   begin
  1628.     Idx := 1;
  1629.     if (FPutFieldInfo = nil) or (grMetaData in PacketOptions) then
  1630.     begin
  1631.       CreateDBClientObject(CLSID_DSWriter, IDSWriter, FIDSWriter);
  1632.       if FPutFieldInfo <> nil then
  1633.       begin
  1634.         FreeInfoRecords(FPutFieldInfo);
  1635.         FPutFieldInfo := nil;
  1636.       end;
  1637.       FPutFieldInfo := InitPutProcs(DataSet, Idx);
  1638.       if poFetchBlobsOnDemand in Options then
  1639.         Version := PACKETVERSION_2 else
  1640.         Version := PACKETVERSION_1;
  1641.       if grXML in PacketOptions then
  1642.         FIDSWriter.SetXMLMode(xmlON) else
  1643.         FIDSWriter.SetXMLMode(0);
  1644.       Check(FIDSWriter.Init_Sequential(Version, Idx - 1));
  1645.       WriteMetaData(DataSet, FPutFieldInfo);
  1646.       if not (grMetaData in PacketOptions) then
  1647.       begin
  1648.         FIDSWriter.GetDataPacket(TempPacket);
  1649.         SafeArrayDestroy(TempPacket);
  1650.         TempPacket := nil;
  1651.       end;
  1652.     end;
  1653.     if not (grMetaData in PacketOptions) then
  1654.       Check(FIDSWriter.Reset);
  1655.   end;
  1656.  
  1657. var
  1658.   DataPacket: TDataPacket;
  1659. begin
  1660.     CheckMetaData(DataSet);
  1661.     RecsOut := WriteDataSet(DataSet, FPutFieldInfo, RecsOut);
  1662.     FIDSWriter.GetDataPacket(DataPacket);
  1663.     DataPacketToVariant(DataPacket, Data);
  1664. end;
  1665.  
  1666. { TPacketDataSet }
  1667.  
  1668. constructor TPacketDataSet.Create(AOwner: TComponent);
  1669. begin
  1670.   inherited;
  1671.   FetchOnDemand := False;
  1672. end;
  1673.  
  1674. procedure TPacketDataSet.CreateFromDelta(Source: TPacketDataSet);
  1675. var
  1676.   TempBase: IDSBase;
  1677. begin
  1678.   Source.Check(Source.DSBase.Clone(2, True, False, TempBase));
  1679.   DSBase := TempBase;
  1680.   Open;
  1681. end;
  1682.  
  1683. procedure TPacketDataSet.InternalInitRecord(Buffer: PChar);
  1684. var
  1685.   I: Integer;
  1686. begin
  1687.   inherited InternalInitRecord(Buffer);
  1688.   { Initialize new records in the error result dataset to unchanged values }
  1689.   for I := 1 to FieldCount do
  1690.     DSBase.PutBlank(PByte(Buffer), 0, I, BLANK_NOTCHANGED);
  1691. end;
  1692.  
  1693. procedure TPacketDataSet.InternalOpen;
  1694. var
  1695.   MDSem: DWord;
  1696. begin
  1697.   inherited InternalOpen;
  1698.   FOldRecBuf := AllocRecordBuffer;
  1699.   FCurRecBuf := AllocRecordBuffer;
  1700.   DSBase.GetProp(dspropMD_SEMANTICS, @MDSem);
  1701.   MDSem := MDSem and mdCASCADEMOD;
  1702.   DSBase.SetProp(dspropMD_SEMANTICS, MDSem);
  1703. end;
  1704.  
  1705. procedure TPacketDataSet.InternalClose;
  1706. begin
  1707.   inherited InternalClose;
  1708.   FreeRecordBuffer(FOldRecBuf);
  1709.   FreeRecordBuffer(FCurRecBuf);
  1710. end;
  1711.  
  1712. function TPacketDataSet.GetStateFieldValue(State: TDataSetState; Field: TField): Variant;
  1713. begin
  1714.   { When reading an OldValue, return the CurValue instead if we have one }
  1715.   if FUseCurValues and (State = dsOldValue) and HasCurValues then
  1716.   begin
  1717.     Result := inherited GetStateFieldValue(dsCurValue, Field);
  1718.     if not VarIsEmpty(Result) then Exit;
  1719.   end;
  1720.   Result := inherited GetStateFieldValue(State, Field);
  1721. end;
  1722.  
  1723. function TPacketDataSet.GetStreamMetaData: Boolean;
  1724. var
  1725.   Value: Integer;
  1726. begin
  1727.   DSBase.GetProp(DSProp(dspropDONTINCLMETADATA), @Value);
  1728.   Result := Value <> 0;
  1729. end;
  1730.  
  1731. procedure TPacketDataSet.SetStreamMetaData(Value: Boolean);
  1732. begin
  1733.   DSBase.SetProp(DSProp(dspropDONTINCLMETADATA), Integer(not Value));
  1734. end;
  1735.  
  1736. function TPacketDataSet.UpdateKind: TUpdateKind;
  1737. begin
  1738.   case UpdateStatus of
  1739.     usInserted: Result := ukInsert;
  1740.     usDeleted: Result := ukDelete;
  1741.   else
  1742.     Result := ukModify;
  1743.   end;
  1744. end;
  1745.  
  1746. procedure TPacketDataSet.DataEvent(Event: TDataEvent; Info: Integer);
  1747. begin
  1748.   if Event in [deDataSetScroll, deDataSetChange] then
  1749.   begin
  1750.     FNewValuesModified := False;
  1751.     FCurValues := nil;
  1752.   end;
  1753.   inherited DataEvent(Event, Info);
  1754. end;
  1755.  
  1756. function TPacketDataSet.HasCurValues: Boolean;
  1757. begin
  1758.   Result := FCurValues <> nil;
  1759. end;
  1760.  
  1761. procedure TPacketDataSet.InitAltRecBuffers(CheckModified: Boolean);
  1762. var
  1763.   No: Integer;
  1764. begin
  1765.   if UpdateStatus in [usUnmodified, usDeleted] then
  1766.     GetCurrentRecord(FOldRecBuf);
  1767.   if CheckModified and (UpdateStatus = usUnmodified) then
  1768.   begin
  1769.     No := RecNo;
  1770.     Next;
  1771.     if UpdateStatus <> usModified then
  1772.       RecNo := No;
  1773.   end;
  1774.   if UpdateStatus = usInserted then
  1775.     SetAltRecBuffers(ActiveBuffer, ActiveBuffer, FCurRecBuf) else
  1776.     SetAltRecBuffers(FOldRecBuf, ActiveBuffer, FCurRecBuf);
  1777. end;
  1778.  
  1779. procedure TPacketDataSet.SetFieldData(Field: TField; Buffer: Pointer);
  1780. begin
  1781.   { Set a flag when any of the field's NewValue properties are modified }
  1782.   if State = dsNewValue then
  1783.     FNewValuesModified := True;
  1784.   if FWritingCurValues then
  1785.     Check(DSCursor.PutField(FCurRecBuf, Field.FieldNo, Buffer)) else
  1786.     inherited SetFieldData(Field, Buffer);
  1787. end;
  1788.  
  1789. procedure TPacketDataSet.SetWritingCurValues(const Value: Boolean);
  1790. begin
  1791.   if Value then
  1792.   begin
  1793.     FCurValues := FCurRecBuf;
  1794.     InitRecord(FCurValues);
  1795.   end else
  1796.     InitAltRecBuffers;
  1797.   FWritingCurValues := Value;
  1798. end;
  1799.  
  1800. procedure TPacketDataSet.AssignCurValues(Source: TDataSet);
  1801. var
  1802.   I: Integer;
  1803.   NewValue: Variant;
  1804.   Field, SourceField: TField;
  1805. begin
  1806.   WritingCurValues := True;
  1807.   try
  1808.     for i := 0 to FieldCount - 1 do
  1809.     begin
  1810.       Field := Fields[i];
  1811.       SourceField := Source.FindField(Field.FieldName);
  1812.       if (SourceField <> nil) and not Field.IsBlob and
  1813.          not (Field.DataType in [ftBytes, ftVarBytes]) and
  1814.          (Field.OldValue <> SourceField.Value) then
  1815.       begin
  1816.         NewValue := Field.NewValue;
  1817.         if VarIsEmpty(Field.NewValue) or
  1818.            (NewValue <> SourceField.Value) then
  1819.           Field.Assign(SourceField);
  1820.       end;
  1821.     end;
  1822.   finally
  1823.     WritingCurValues := False;
  1824.   end;
  1825. end;
  1826.  
  1827. procedure TPacketDataSet.AssignCurValues(const CurValues: Variant);
  1828. var
  1829.   I: Integer;
  1830.   Field: TField;
  1831.   CurValue: Variant;
  1832. begin
  1833.   WritingCurValues := True;
  1834.   try
  1835.     if VarIsNull(CurValues) then
  1836.       FCurValues := nil
  1837.     else
  1838.       for I := VarArrayLowBound(CurValues, 1) to VarArrayHighBound(CurValues, 1) do
  1839.       begin
  1840.         if VarIsArray(CurValues[I]) then
  1841.         begin
  1842.           CurValue := CurValues[I][1];
  1843.           Field := FieldByName(CurValues[I][0])
  1844.         end else
  1845.         begin
  1846.           CurValue := CurValues[I];
  1847.           Field := Fields[I];
  1848.         end;
  1849.         if not VarIsEmpty(CurValue) then
  1850.           if (Field.OldValue <> CurValue) then
  1851.             Fields[I].Value := CurValue;
  1852.       end;
  1853.   finally
  1854.     WritingCurValues := False;
  1855.   end;
  1856. end;
  1857.  
  1858. function TPacketDataSet.HasMergeConflicts: Boolean;
  1859. var
  1860.   I: Integer;
  1861.   CurVal, NewVal: Variant;
  1862. begin
  1863.   Result := False;
  1864.   for I := 0 to FieldCount - 1 do
  1865.     with Fields[I] do
  1866.     begin
  1867.       CurVal := CurValue;
  1868.       if VarIsEmpty(CurVal) then Continue;
  1869.       NewVal := NewValue;
  1870.       if VarIsEmpty(NewVal) then Continue;
  1871.       if CurVal = NewVal then Continue;
  1872.       Result := True;
  1873.       Break;
  1874.     end;
  1875. end;
  1876.  
  1877. { TCustomProvider }
  1878.  
  1879. constructor TCustomProvider.Create(AOwner: TComponent);
  1880. begin
  1881.   inherited Create(AOwner);
  1882.   FExported := True;
  1883.   if AOwner is TRemoteDataModule then
  1884.     TRemoteDataModule(AOwner).RegisterProvider(Self);
  1885. end;
  1886.  
  1887. destructor TCustomProvider.Destroy;
  1888. begin
  1889.   if Owner is TRemoteDataModule then
  1890.     TRemoteDataModule(Owner).UnRegisterProvider(Self);
  1891.   inherited Destroy;
  1892. end;
  1893.  
  1894. function TCustomProvider.GetData: OleVariant;
  1895. var
  1896.   Recs: Integer;
  1897.   Options: TGetRecordOptions;
  1898. begin
  1899.   Options := [grMetaData];
  1900.   Result := GetRecords(-1, Recs, Byte(Options));
  1901. end;
  1902.  
  1903. function TCustomProvider.ApplyUpdates(Const Delta: OleVariant; MaxErrors: Integer;
  1904.   out ErrorCount: Integer): OleVariant;
  1905. var
  1906.   OwnerData: OleVariant;
  1907. begin
  1908.   ApplyUpdates(Delta, MaxErrors, ErrorCount, OwnerData);
  1909. end;
  1910.  
  1911. function TCustomProvider.ApplyUpdates(const Delta: OleVariant; MaxErrors: Integer;
  1912.   out ErrorCount: Integer; var OwnerData: OleVariant): OleVariant;
  1913. begin
  1914.   if Assigned(FBeforeApplyUpdates) then FBeforeApplyUpdates(Self, OwnerData);
  1915.   Result := InternalApplyUpdates(Delta, MaxErrors, ErrorCount);
  1916.   if Assigned(FAfterApplyUpdates) then FAfterApplyUpdates(Self, OwnerData);
  1917. end;
  1918.  
  1919. procedure TCustomProvider.DoBeforeGetRecords(Count: Integer; Options: Integer;
  1920.   const CommandText: WideString; var Params, OwnerData: OleVariant);
  1921. begin
  1922.   if Assigned(FBeforeGetRecords) then FBeforeGetRecords(Self, OwnerData);
  1923. end;
  1924.  
  1925. function TCustomProvider.GetRecords(Count: Integer; out RecsOut: Integer; Options: Integer): OleVariant;
  1926. var
  1927.   Params, OwnerData: OleVariant;
  1928. begin
  1929.   Result := GetRecords(Count, RecsOut, Options, '', Params, OwnerData);
  1930. end;
  1931.  
  1932. function TCustomProvider.GetRecords(Count: Integer; out RecsOut: Integer; Options: Integer;
  1933.   const CommandText: WideString; var Params, OwnerData: OleVariant): OleVariant;
  1934. begin
  1935.   DoBeforeGetRecords(Count, Options, CommandText, Params, OwnerData);
  1936.   Result := InternalGetRecords(Count, RecsOut, TGetRecordOptions(Byte(Options)),
  1937.     CommandText, Params);
  1938.   if Assigned(FAfterGetRecords) then FAfterGetRecords(Self, OwnerData);
  1939.   Params := InternalGetParams([ptOutput, ptInputOutput]);
  1940. end;
  1941.  
  1942. function TCustomProvider.RowRequest(const Row: OleVariant; RequestType: Integer;
  1943.   var OwnerData: OleVariant): OleVariant;
  1944. begin
  1945.   if Assigned(FBeforeRowRequest) then FBeforeRowRequest(Self, OwnerData);
  1946.   Result := InternalRowRequest(Row, TFetchOptions(Byte(RequestType)));
  1947.   if Assigned(FAfterRowRequest) then FAfterRowRequest(Self, OwnerData);
  1948. end;
  1949.  
  1950. procedure TCustomProvider.DoBeforeExecute(const CommandText: WideString;
  1951.   var Params, OwnerData: OleVariant);
  1952. begin
  1953.   if Assigned(FBeforeExecute) then FBeforeExecute(Self, OwnerData);
  1954. end;
  1955.  
  1956. procedure TCustomProvider.Execute(const CommandText: WideString;
  1957.   var Params, OwnerData: OleVariant);
  1958. begin
  1959.   DoBeforeExecute(CommandText, Params, OwnerData);
  1960.   InternalExecute(CommandText, Params);
  1961.   if Assigned(FAfterExecute) then FAfterExecute(Self, OwnerData);
  1962.   Params := InternalGetParams([ptOutput, ptInputOutput]);
  1963. end;
  1964.  
  1965. function TCustomProvider.GetParams(var OwnerData: OleVariant): OleVariant;
  1966. begin
  1967.   if Assigned(FBeforeGetParams) then FBeforeGetParams(Self, OwnerData);
  1968.   Result := InternalGetParams;
  1969.   if Assigned(FAfterGetParams) then FAfterGetParams(Self, OwnerData);
  1970. end;
  1971.  
  1972. function TCustomProvider.InternalGetParams(Types: TParamTypes = AllParamTypes): OleVariant;
  1973. begin
  1974.   Result := NULL;
  1975. end;
  1976.  
  1977. procedure TCustomProvider.InternalExecute(const CommandText: WideString; var Params: OleVariant);
  1978. begin
  1979. end;
  1980.  
  1981. function TCustomProvider.InternalGetRecords(Count: Integer; out RecsOut: Integer;
  1982.   Options: TGetRecordOptions; const CommandText: WideString;
  1983.   var Params: OleVariant): OleVariant;
  1984. begin
  1985.   Result := NULL;
  1986. end;
  1987.  
  1988. function TCustomProvider.InternalRowRequest(const Row: OleVariant; RequestType: TFetchOptions): OleVariant;
  1989. begin
  1990.   Result := NULL;
  1991. end;
  1992.  
  1993. function TCustomProvider.DataRequest(Input: OleVariant): OleVariant;
  1994. begin
  1995.   if Assigned(FOnDataRequest) then
  1996.     Result := FOnDataRequest(Self, Input) else
  1997.     Result := NULL;
  1998. end;
  1999.  
  2000. { TBaseProvider }
  2001.  
  2002. constructor TBaseProvider.Create(AOwner: TComponent);
  2003. begin
  2004.   inherited Create(AOwner);
  2005.   FProviderOptions := [];
  2006. end;
  2007.  
  2008. destructor TBaseProvider.Destroy;
  2009. begin
  2010.   FResolver.Free;
  2011.   inherited Destroy;
  2012. end;
  2013.  
  2014. procedure TBaseProvider.LocateRecord(Source, Delta: TDataSet);
  2015. begin
  2016. end;
  2017.  
  2018. procedure TBaseProvider.UpdateRecord(Source, Delta: TDataSet; BlobsOnly, KeyOnly: Boolean);
  2019. begin
  2020. end;
  2021.  
  2022. procedure TBaseProvider.FetchDetails(Source, Delta: TDataSet);
  2023. begin
  2024. end;
  2025.  
  2026. procedure TBaseProvider.CheckResolver;
  2027. begin
  2028.   if not Assigned(FResolver) then
  2029.     FResolver := CreateResolver;
  2030. end;
  2031.  
  2032. procedure TBaseProvider.FreeResolver;
  2033. begin
  2034.   FResolver.Free;
  2035.   FResolver := nil;
  2036. end;
  2037.  
  2038. function TBaseProvider.InternalApplyUpdates(const Delta: OleVariant; MaxErrors: Integer;
  2039.   out ErrorCount: Integer): OleVariant;
  2040. begin
  2041.   if poReadOnly in Options then DatabaseError(SReadOnlyProvider);
  2042.   CheckResolver;
  2043.   Result := Resolver.ApplyUpdates(Delta, MaxErrors, ErrorCount);
  2044. end;
  2045.  
  2046. function TBaseProvider.InternalRowRequest(const Row: OleVariant; RequestType: TFetchOptions): OleVariant;
  2047. begin
  2048.   CheckResolver;
  2049.   Result := Resolver.RowRequest(Row, RequestType);
  2050. end;
  2051.  
  2052. function TBaseProvider.InternalGetRecords(Count: Integer; out RecsOut: Integer;
  2053.   Options: TGetRecordOptions; const CommandText: WideString;
  2054.   var Params: OleVariant): OleVariant;
  2055. begin
  2056.   if (Count = 0) then
  2057.     Include(Options, grMetaData);
  2058.   RecsOut := Count;
  2059.   CreateDataPacket(Options, Self.Options, RecsOut, Result);
  2060.   DoOnGetData(Result);
  2061. end;
  2062.  
  2063. procedure TBaseProvider.DoOnGetData(var Data: OleVariant);
  2064. begin
  2065.   if Assigned(OnGetData) then
  2066.   begin
  2067.     if not Assigned(FDataDS) then
  2068.       FDataDS := TPacketDataSet.Create(Self) else
  2069.       FDataDS.StreamMetaData := False;
  2070.     FDataDS.AppendData(Data, False);
  2071.     OnGetData(Self, FDataDS);
  2072.     if FDataDS.ChangeCount > 0 then
  2073.     begin
  2074.       FDataDS.MergeChangeLog;
  2075.       Data := FDataDS.Data;
  2076.     end;
  2077.     FDataDS.EmptyDataSet;
  2078.   end;
  2079. end;
  2080.  
  2081. procedure TBaseProvider.DoOnUpdateData(Delta: TPacketDataSet);
  2082. begin
  2083.   if Assigned(FOnUpdateData) then
  2084.   begin
  2085.     Delta.LogChanges := False;
  2086.     FOnUpdateData(Self, Delta);
  2087.   end;
  2088. end;
  2089.  
  2090. function TBaseProvider.CreateResolver: TCustomResolver;
  2091. begin
  2092.   Result := nil;
  2093. end;
  2094.  
  2095. procedure TBaseProvider.CreateDataPacket(PacketOpts: TGetRecordOptions;
  2096.   ProvOpts: TProviderOptions; var RecsOut: Integer; var Data: OleVariant);
  2097. begin
  2098.   RecsOut := 0;
  2099.   Data := NULL;
  2100. end;
  2101.  
  2102. { TDataSetProvider }
  2103.  
  2104. constructor TDataSetProvider.Create(AOwner: TComponent);
  2105. begin
  2106.   inherited Create(AOwner);
  2107.   FResolveToDataSet := False;
  2108.   FUpdateMode := upWhereAll;
  2109.   FDSWriter := nil;
  2110.   FConstraints := True;
  2111.   FRecordsSent := 0;
  2112. end;
  2113.  
  2114. destructor TDataSetProvider.Destroy;
  2115. begin
  2116.   FDSWriter.Free;
  2117.   if Assigned(FParams) then
  2118.     FParams.Free;
  2119.   inherited Destroy;
  2120. end;
  2121.  
  2122. procedure TDataSetProvider.LocateRecord(Source, Delta: TDataSet);
  2123. begin
  2124.   if not FindRecord(Source, Delta, UpdateMode) then
  2125.     DatabaseError(SRecordChanged);
  2126. end;
  2127.  
  2128. function TDataSetProvider.FindRecord(Source, Delta: TDataSet;
  2129.   UpdateMode: TUpdateMode): Boolean;
  2130.  
  2131.   procedure GetFieldList(DataSet: TDataSet; UpdateMode: TUpdateMode; List: TList);
  2132.   var
  2133.     i: Integer;
  2134.   begin
  2135.     for i := 0 to DataSet.FieldCount - 1 do
  2136.       with DataSet.Fields[i] do
  2137.       begin
  2138.         if (DataType in [ftBytes, ftVarBytes]) or IsBlob or
  2139.            (DataSet.Fields[i] is TObjectField) then continue;
  2140.         case UpdateMode of
  2141.           upWhereKeyOnly:
  2142.             if pfInKey in ProviderFlags then List.Add(DataSet.Fields[i]);
  2143.           upWhereAll:
  2144.             if pfInWhere in ProviderFlags then List.Add(DataSet.Fields[i]);
  2145.           upWhereChanged:
  2146.             if (pfInKey in ProviderFlags) or (not VarIsEmpty(NewValue)) then
  2147.               List.Add(DataSet.Fields[i]);
  2148.         end;
  2149.       end;
  2150.   end;
  2151.  
  2152. var
  2153.   i: Integer;
  2154.   KeyValues: Variant;
  2155.   Fields: string;
  2156.   FieldList: TList;
  2157.   IsDelta: BOOL;
  2158. begin
  2159.   Result := False;
  2160.   TPacketDataSet(Delta).DSBase.GetProp(dspropISDELTA, @IsDelta);
  2161.   FieldList := TList.Create;
  2162.   try
  2163.     GetFieldList(Delta, UpdateMode, FieldList);
  2164.     if FieldList.Count > 1 then
  2165.     begin
  2166.       KeyValues := VarArrayCreate([0, FieldList.Count - 1], varVariant);
  2167.       Fields := '';
  2168.       for i := 0 to FieldList.Count - 1 do
  2169.         with TField(FieldList[i]) do
  2170.         begin
  2171.           if IsDelta then
  2172.             KeyValues[i] := OldValue else
  2173.             KeyValues[i] := Value;
  2174.           if Fields <> '' then Fields := Fields + ';';
  2175.           Fields := Fields + FieldName;
  2176.         end;
  2177.       Result := Source.Locate(Fields, KeyValues, []);
  2178.     end
  2179.     else if FieldList.Count = 1 then
  2180.     begin
  2181.       with TField(FieldList[0]) do
  2182.         if IsDelta then
  2183.           Result := Source.Locate(FieldName, OldValue, []) else
  2184.           Result := Source.Locate(FieldName, Value, []);
  2185.     end else
  2186.       DatabaseError(SNoKeySpecified);
  2187.   finally
  2188.     FieldList.Free;
  2189.   end;
  2190. end;
  2191.  
  2192. procedure TDataSetProvider.FetchDetails(Source, Delta: TDataSet);
  2193. var
  2194.   i: Integer;
  2195.   Field: TField;
  2196. begin
  2197.   Source.First;
  2198.   while not Source.EOF do
  2199.   begin
  2200.     Delta.Insert;
  2201.     for i := 0 to Delta.FieldCount - 1 do
  2202.     begin
  2203.       Field := Source.FindField(Delta.Fields[i].FieldName);
  2204.       if Field <> nil then
  2205.         Delta.Fields[i].Assign(Field);
  2206.     end;
  2207.     Delta.Post;
  2208.     Source.Next;
  2209.   end;
  2210. end;
  2211.  
  2212. procedure TDataSetProvider.UpdateRecord(Source, Delta: TDataSet; BlobsOnly, KeyOnly: Boolean);
  2213. var
  2214.   Field: TField;
  2215.   i: Integer;
  2216.   UseUpMode: TUpdateMode;
  2217. begin
  2218.   if KeyOnly then
  2219.     UseUpMode := upWhereKeyOnly
  2220.   else
  2221.     UseUpMode := UpdateMode;
  2222.   if not FindRecord(Source, Delta, UseUpMode) then
  2223.     DatabaseError(SRecordChanged);
  2224.   begin
  2225.     if not FindRecord(Source, Delta, upWhereKeyOnly) then
  2226.       DatabaseError(SRecordChanged);
  2227.     with Delta do
  2228.     begin
  2229.       Edit;
  2230.       for i := 0 to FieldCount - 1 do
  2231.       begin
  2232.         Field := Source.FindField(Fields[i].FieldName);
  2233.         if (Field <> nil) and (not BlobsOnly or (Field.IsBlob and VarIsNull(Fields[i].NewValue))) then
  2234.           Fields[i].Assign(Field);
  2235.       end;
  2236.       Post;
  2237.     end;
  2238.   end;
  2239. end;
  2240.  
  2241. procedure TDataSetProvider.DoBeforeExecute(const CommandText: WideString;
  2242.   var Params, OwnerData: OleVariant);
  2243. begin
  2244.   SetCommandText(CommandText);
  2245.   SetParams(Params);
  2246.   inherited DoBeforeExecute(CommandText, Params, OwnerData);
  2247. end;
  2248.  
  2249. procedure TDataSetProvider.InternalExecute(const CommandText: WideString;
  2250.   var Params: OleVariant);
  2251. begin
  2252.   CheckDataSet;
  2253.   IProviderSupport(DataSet).PSExecute;
  2254. end;
  2255.  
  2256. procedure TDataSetProvider.DoGetTableName(DataSet: TDataSet; var TableName: string);
  2257. begin
  2258.   if Assigned(OnGetTableName) then
  2259.     OnGetTableName(Self, DataSet, TableName);
  2260. end;
  2261.  
  2262. procedure TDataSetProvider.Reset;
  2263. begin
  2264.   CheckDataSet;
  2265.   if FDataSetOpened then
  2266.   begin
  2267.     DataSet.Close;
  2268.     FDataSetOpened := False;
  2269.   end;
  2270.   IProviderSupport(DataSet).PSReset;
  2271.   if DataSet.Active then
  2272.     DataSet.First;
  2273.   FRecordsSent := 0;
  2274. end;
  2275.  
  2276. procedure TDataSetProvider.SetCommandText(const CommandText: string);
  2277. begin
  2278.   if CommandText = '' then Exit;
  2279.   if not (poAllowCommandText in Options) then
  2280.     DatabaseError(SCannotChangeCommandText);
  2281.   CheckDataSet;
  2282.   IProviderSupport(DataSet).PSSetCommandText(CommandText);
  2283. end;
  2284.  
  2285. procedure TDataSetProvider.SetParams(Values: OleVariant);
  2286. begin
  2287.   if VarIsEmpty(Values) then Exit;
  2288.   CheckDataSet;
  2289.   if not Assigned(FParams) then
  2290.     FParams := TParams.Create;
  2291.   FParams.Clear;
  2292.   UnpackParams(Values, FParams);
  2293.   IProviderSupport(DataSet).PSSetParams(FParams);
  2294. end;
  2295.  
  2296. function TDataSetProvider.InternalGetParams(Types: TParamTypes = AllParamTypes): OleVariant;
  2297. var
  2298.   Params: TParams;
  2299. begin
  2300.   CheckDataSet;
  2301.   Params := IProviderSupport(DataSet).PSGetParams;
  2302.   if (Params = nil) or (Params.Count = 0) then
  2303.     Result := NULL else
  2304.     Result := PackageParams(Params, Types);
  2305. end;
  2306.  
  2307. function TDataSetProvider.InternalRowRequest(const Row: OleVariant; Options: TFetchOptions): OleVariant;
  2308. begin
  2309.   CheckResolver;
  2310.   CheckDataSet;
  2311.   Resolver.FUpdateTree.InitData(DataSet);
  2312.   try
  2313.     if not DataSet.Active then
  2314.     begin
  2315.       DataSet.Open;
  2316.       FDataSetOpened := True;
  2317.     end;     
  2318.     Result := inherited InternalRowRequest(Row, Options);
  2319.   finally
  2320.     Resolver.FUpdateTree.InitData(nil);
  2321.     if FDataSetOpened then
  2322.     begin
  2323.       DataSet.Close;
  2324.       FDataSetOpened := False;
  2325.     end;    
  2326.   end;
  2327. end;
  2328.  
  2329. function TDataSetProvider.InternalApplyUpdates(const Delta: OleVariant; MaxErrors: Integer;
  2330.   out ErrorCount: Integer): OleVariant;
  2331. var
  2332.   TransactionStarted: Boolean;
  2333. begin
  2334.   CheckDataSet;
  2335.   TransactionStarted := not IProviderSupport(DataSet).PSInTransaction;
  2336.   if TransactionStarted then
  2337.     IProviderSupport(DataSet).PSStartTransaction;
  2338.   try
  2339.     CheckResolver;
  2340.     Resolver.FUpdateTree.InitData(DataSet);
  2341.     try
  2342.       Result := inherited InternalApplyUpdates(Delta, MaxErrors, ErrorCount);
  2343.     finally
  2344.       Resolver.FUpdateTree.InitData(nil);
  2345.     end;
  2346.   finally
  2347.     if TransactionStarted then
  2348.       IProviderSupport(DataSet).PSEndTransaction((ErrorCount <= MaxErrors) or (MaxErrors = -1));
  2349.   end;
  2350. end;
  2351.  
  2352. procedure TDataSetProvider.SetDataSet(ADataSet: TDataSet);
  2353. begin
  2354.   FDataSet := ADataSet;
  2355. end;
  2356.  
  2357. procedure TDataSetProvider.SetResolveToDataSet(Value: Boolean);
  2358. begin
  2359.   if (Value <> FResolveToDataSet) and Assigned(Resolver) then
  2360.     FreeResolver;
  2361.   FResolveToDataSet := Value;
  2362. end;
  2363.  
  2364. function TDataSetProvider.CreateResolver: TCustomResolver;
  2365. begin
  2366.   if ResolveToDataSet then
  2367.     Result := TDataSetResolver.Create(Self) else
  2368.     Result := TSQLResolver.Create(Self);
  2369. end;
  2370.  
  2371. procedure TDataSetProvider.CheckDataSet;
  2372. begin
  2373.   if not Assigned(DataSet) then DatabaseError(SMissingDataSet);
  2374. end;
  2375.  
  2376. procedure TDataSetProvider.DoBeforeGetRecords(Count: Integer; Options: Integer;
  2377.   const CommandText: WideString; var Params, OwnerData: OleVariant);
  2378. begin
  2379.   SetCommandText(CommandText);
  2380.   SetParams(Params);
  2381.   inherited;
  2382. end;
  2383.  
  2384. function TDataSetProvider.InternalGetRecords(Count: Integer; out RecsOut: Integer;
  2385.   Options: TGetRecordOptions; const CommandText: WideString;
  2386.   var Params: OleVariant): OleVariant;
  2387. begin
  2388.   try
  2389.     if grReset in Options then
  2390.     begin
  2391.       Reset;
  2392.       { When doing only a reset and not getting more data then exit }
  2393.       if Count = 0 then Exit;
  2394.     end;
  2395.     if not DataSet.Active then
  2396.     begin
  2397.       DataSet.Open;
  2398.       FDataSetOpened := True;
  2399.     end;
  2400.     if (Count = 0) or (grMetaData in Options) then
  2401.     begin
  2402.       FDataDS.Free;
  2403.       FDataDS := nil;
  2404.       FRecordsSent := 0;
  2405.     end;
  2406.     DataSet.CheckBrowseMode;
  2407.     DataSet.BlockReadSize := Count;
  2408.     try
  2409.       Result := inherited InternalGetRecords(Count, RecsOut, Options,
  2410.         CommandText, Params);
  2411.       Inc(FRecordsSent, RecsOut);
  2412.       if (RecsOut <> Count) then Reset;
  2413.     finally
  2414.       if DataSet.Active then
  2415.       begin
  2416.         DataSet.BlockReadSize := 0;
  2417.         if (Count <> 0) and (RecsOut = Count) then
  2418.           DataSet.Next;
  2419.       end;
  2420.     end;
  2421.   except
  2422.     Reset;
  2423.     raise;
  2424.   end;
  2425. end;
  2426.  
  2427. procedure TDataSetProvider.DoGetProviderAttributes(DataSet: TDataSet; List: TList);
  2428. var
  2429.   CustParams: OleVariant;
  2430.   Attr: PPacketAttribute;
  2431.   i, j: Integer;
  2432. begin
  2433.   IProviderSupport(DataSet).PSGetAttributes(List);
  2434.   if Assigned(FGetDSProps) then
  2435.   begin
  2436.     FGetDSProps(Self, DataSet, CustParams);
  2437.     if VarIsArray(CustParams) then
  2438.     begin
  2439.       for i := VarArrayLowBound(CustParams, 1) to VarArrayHighBound(CustParams, 1) do
  2440.       begin
  2441.         if VarIsArray(CustParams[i]) and
  2442.           (VarArrayHighBound(CustParams[i], 1) - VarArrayLowBound(CustParams[i], 1) = 2) then
  2443.         begin
  2444.           j := VarArrayLowBound(CustParams[i], 1);
  2445.           New(Attr);
  2446.           List.Add(Attr);
  2447.           with Attr^ do
  2448.           begin
  2449.             Name := CustParams[i][j];
  2450.             Value := CustParams[i][j + 1];
  2451.             IncludeInDelta := CustParams[i][j + 2];
  2452.           end;
  2453.         end;
  2454.       end;
  2455.     end;
  2456.   end;
  2457. end;
  2458.  
  2459. procedure TDataSetProvider.CreateDataPacket(PacketOpts: TGetRecordOptions;
  2460.   ProvOpts: TProviderOptions; var RecsOut: Integer; var Data: OleVariant);
  2461. begin
  2462.   if not Assigned(FDSWriter) then
  2463.     FDSWriter := TDataPacketWriter.Create;
  2464.   FDSWriter.Constraints := Constraints;
  2465.   FDSWriter.OnGetParams := DoGetProviderAttributes;
  2466.   FDSWriter.PacketOptions := PacketOpts;
  2467.   FDSWriter.Options := ProvOpts;
  2468.   FDSWriter.GetDataPacket(DataSet, RecsOut, Data);
  2469. end;
  2470.  
  2471. procedure TDataSetProvider.Notification(AComponent: TComponent; Operation: TOperation);
  2472. begin
  2473.   inherited Notification(AComponent, Operation);
  2474.   if (Operation = opRemove) and (FDataSet <> nil) and
  2475.     (AComponent = FDataSet) then FDataSet := nil;
  2476. end;
  2477.  
  2478. { TUpdateTree }
  2479.  
  2480. constructor TUpdateTree.Create(AParent: TUpdateTree; AResolver: TCustomResolver);
  2481. begin
  2482.   FResolver := AResolver;
  2483.   FParent := AParent;
  2484.   FDeltaDS := TPacketDataSet.Create(nil);
  2485.   FDeltaDS.ObjectView := True;
  2486.   FDeltaDS.FieldDefs.HiddenFields := True;
  2487.   FDetails := TList.Create;
  2488.   FName := '';
  2489. end;
  2490.  
  2491. destructor TUpdateTree.Destroy;
  2492. begin
  2493.   if Assigned(FResolver) then
  2494.     FResolver.FreeTreeData(Self);
  2495.   Clear;
  2496.   FDetails.Free;
  2497.   if not Assigned(Parent) then
  2498.     FDeltaDS.Free;
  2499.   inherited Destroy;
  2500. end;
  2501.  
  2502. function TUpdateTree.GetIsNested: Boolean;
  2503. begin
  2504.   Result := Assigned(Source) and Assigned(Source.DataSetField);
  2505. end;
  2506.  
  2507. procedure TUpdateTree.Clear;
  2508. var
  2509.   i: Integer;
  2510. begin
  2511.   for i := 0 to DetailCount - 1 do
  2512.     Details[i].Free;
  2513.   FDetails.Clear;
  2514.   FDeltaDS.Data := NULL;
  2515.   if not Assigned(Parent) then
  2516.   begin
  2517.     FErrorDS.Free;
  2518.     FErrorDS := nil;
  2519.   end;
  2520. end;
  2521.  
  2522. function TUpdateTree.GetTree(const AName: string): TUpdateTree;
  2523. var
  2524.   i: Integer;
  2525. begin
  2526.   for i := 0 to DetailCount - 1 do
  2527.     if AnsiCompareText(Details[i].Name, AName) = 0 then
  2528.     begin
  2529.       Result := Details[i];
  2530.       Exit;
  2531.     end;
  2532.   Result := TUpdateTree.Create(Self, FResolver);
  2533.   Result.Name := AName;
  2534.   FDetails.Add(Result);
  2535. end;
  2536.  
  2537. procedure TUpdateTree.InitData(ASource: TDataSet);
  2538. var
  2539.   i: Integer;
  2540.   Tree: TUpdateTree;
  2541.   List: TList;
  2542. begin
  2543.   if ASource = nil then
  2544.   begin
  2545.     for i := 0 to FDetails.Count - 1 do
  2546.       TUpdateTree(FDetails[i]).InitData(nil);
  2547.     if FOpened then FSourceDS.Close;
  2548.     FOpened := False;
  2549.   end else
  2550.   begin
  2551.     FSourceDS := ASource;
  2552.     FOpened := (FSourceDS.FieldCount = 0) and FSourceDS.ObjectView;
  2553.     if FOpened then FSourceDS.Open;
  2554.     if FSourceDS.ObjectView then
  2555.       for i := 0 to FSourceDS.FieldCount - 1 do
  2556.         if FSourceDS.Fields[i].DataType in [ftDataSet] then
  2557.           with TDataSetField(FSourceDS.Fields[i]) do
  2558.           begin
  2559.             Tree := GetTree(FSourceDS.Fields[i].FieldName);
  2560.             Tree.InitData(NestedDataSet);
  2561.           end;
  2562.     List := TList.Create;
  2563.     try
  2564.       FSourceDS.GetDetailDataSets(List);
  2565.       for i := 0 to List.Count - 1 do
  2566.       begin
  2567.         Tree := GetTree(TDataSet(List[i]).Name);
  2568.         Tree.InitData(TDataSet(List[i]));
  2569.       end;
  2570.     finally
  2571.       List.Free;
  2572.     end;
  2573.   end;
  2574. end;
  2575.  
  2576. procedure TUpdateTree.InitDelta(ADelta: TPacketDataSet);
  2577. var
  2578.   i: Integer;
  2579.   Attr: Variant;
  2580.   KeySet: Boolean;
  2581.   Tree: TUpdateTree;
  2582.   FieldInfo: TFieldInfo;
  2583. begin
  2584.   if (FDeltaDS <> nil) and (FDeltaDS <> ADelta) then
  2585.     FDeltaDS.Free;
  2586.   FDeltaDS := ADelta;
  2587.   FDeltaDS.LogChanges := False;
  2588.   KeySet := False;
  2589.   for i := 0 to FDeltaDS.FieldCount - 1 do
  2590.   begin
  2591.     Attr := FDeltaDS.InternalGetOptionalParam(szPROVFLAGS, FDeltaDS.Fields[i].FieldNo);
  2592.     if not (VarIsNull(Attr) or VarIsEmpty(Attr)) then
  2593.       FDeltaDS.Fields[i].ProviderFlags := TProviderFlags(Byte(Attr));
  2594.     Attr := FDeltaDS.InternalGetOptionalParam(szORIGIN, FDeltaDS.Fields[i].FieldNo);
  2595.     if not (VarIsNull(Attr) or VarIsEmpty(Attr)) then
  2596.       FDeltaDS.Fields[i].Origin := Attr;
  2597.     Attr := FDeltaDS.InternalGetOptionalParam(szSERVERCALC, FDeltaDS.Fields[i].FieldNo);
  2598.     if not (VarIsEmpty(Attr) or VarIsNull(Attr)) and
  2599.       (VarType(Attr) = varBoolean) and Boolean(Attr) then
  2600.       FDeltaDS.Fields[i].Tag := tagSERVERCALC;
  2601.     if GetFieldInfo(FDeltaDS.Fields[i].Origin, FieldInfo) then
  2602.       FDeltaDS.Fields[i].Origin := FieldInfo.OriginalFieldName else
  2603.       FDeltaDS.Fields[i].Origin := FDeltaDS.Fields[i].FieldName;
  2604.     if pfInKey in FDeltaDS.Fields[i].ProviderFlags then
  2605.       KeySet := True;
  2606.     if Delta.Fields[i].DataType = ftDataSet then
  2607.       with TDataSetField(Delta.Fields[i]) do
  2608.       begin
  2609.         Tree := GetTree(Delta.Fields[i].FieldName);
  2610.         Tree.InitDelta(TPacketDataSet(NestedDataSet));
  2611.       end;
  2612.   end;
  2613.   FResolver.InitTreeData(Self);
  2614.   if not KeySet then
  2615.     FResolver.InitKeyFields(Self, FDeltaDS);
  2616. end;
  2617.  
  2618. procedure TUpdateTree.InitDelta(const ADelta: OleVariant);
  2619. begin
  2620.   if FDeltaDS.Active then Clear;
  2621.   FDeltaDS.Data := ADelta;
  2622.   InitDelta(FDeltaDS);
  2623. end;
  2624.  
  2625. function TUpdateTree.GetDetailCount: Integer;
  2626. begin
  2627.   Result := FDetails.Count;
  2628. end;
  2629.  
  2630. function TUpdateTree.GetDetail(Index: Integer): TUpdateTree;
  2631. begin
  2632.   Result := TUpdateTree(FDetails[Index]);
  2633. end;
  2634.  
  2635. procedure TUpdateTree.RefreshData(Options: TFetchOptions);
  2636.  
  2637.   function NeedsUpdate(DataSet: TDataSet): Boolean;
  2638.   var
  2639.     i: Integer;
  2640.     Field: TField;
  2641.   begin
  2642.     Result := False;
  2643.     if DataSet.RecordCount = 0 then Exit;
  2644.     for i := 0 to DataSet.FieldCount - 1 do
  2645.     begin
  2646.       Field := DataSet.Fields[i];
  2647.       Result := (Field is TDataSetField) and
  2648.                 (VarIsNull(Field.NewValue) or
  2649.                  NeedsUpdate(TDataSetField(Field).NestedDataSet));
  2650.       if Result then Exit;
  2651.     end;
  2652.   end;
  2653.  
  2654. var
  2655.   i: Integer;
  2656.   Tree: TUpdateTree;
  2657.   Field: TField;
  2658.   Updated: Boolean;
  2659. begin
  2660.   Updated := False;
  2661.   if (foRecord in Options) and (Delta.RecordCount > 0) then
  2662.   begin
  2663.     Updated := True;
  2664.     FResolver.Provider.UpdateRecord(Source, Delta, False, True);
  2665.   end;
  2666.   for i := 0 to Delta.FieldCount - 1 do
  2667.   begin
  2668.     Field := Delta.Fields[i];
  2669.     if (not Updated) and (foBlobs in Options) and Field.IsBlob and
  2670.        VarIsNull(Field.NewValue) then
  2671.     begin
  2672.       Updated := True;
  2673.       FResolver.Provider.UpdateRecord(Source, Delta, True, False);
  2674.     end;
  2675.     if (Field is TDataSetField) then
  2676.     begin
  2677.       if not Updated then
  2678.         FResolver.Provider.LocateRecord(Source, Delta);
  2679.       Tree := GetTree(Field.FieldName);
  2680.       if Assigned(Tree) then
  2681.       begin
  2682.         if not VarIsNull(Field.NewValue) then
  2683.         begin
  2684.           if Tree.Delta.RecordCount > 0 then
  2685.             Tree.RefreshData(Options);
  2686.         end else
  2687.           FResolver.Provider.FetchDetails(Tree.Source, Tree.Delta);
  2688.       end;
  2689.     end;
  2690.   end;
  2691. end;
  2692.  
  2693. function TUpdateTree.DoUpdates: Boolean;
  2694. var
  2695.   i: Integer;
  2696. begin
  2697.   Result := True;
  2698.   Delta.First;
  2699.   while not Delta.EOF do
  2700.   begin
  2701.     Delta.InitAltRecBuffers(False);
  2702.     FResolver.InternalBeforeResolve(Self);
  2703.     if (Delta.UpdateStatus = usInserted) then
  2704.     begin
  2705.       Result := FResolver.InternalUpdateRecord(Self);
  2706.       if not Result then Exit;
  2707.     end;
  2708.     for i := 0 to DetailCount - 1 do
  2709.     begin
  2710.       Result := Details[i].DoUpdates;
  2711.       if not Result then Exit;
  2712.     end;
  2713.     if Delta.UpdateStatus = usUnmodified then
  2714.       Delta.InitAltRecBuffers(True);
  2715.     if (Delta.UpdateStatus = usModified) then
  2716.       Result := FResolver.InternalUpdateRecord(Self);
  2717.     if (Delta.UpdateStatus = usDeleted) then
  2718.       Result := FResolver.InternalUpdateRecord(Self);
  2719.     if not Result then Exit;
  2720.     Delta.Next;
  2721.   end;
  2722. end;
  2723.  
  2724. function TUpdateTree.GetErrorDS: TPacketDataSet;
  2725. var
  2726.   Field: TField;
  2727. begin
  2728.   if not Assigned(FErrorDS) then
  2729.   begin
  2730.     if not Assigned(Parent) then
  2731.     begin
  2732.       FErrorDS := TPacketDataSet.Create(nil);
  2733.       FErrorDS.ObjectView := True;
  2734.       FErrorDS.CreateFromDelta(Delta);
  2735.     end else
  2736.     begin
  2737.       Field := Parent.ErrorDS.FieldByName(Delta.DataSetField.FieldName);
  2738.       FErrorDS := (Field as TDataSetField).NestedDataSet as TPacketDataSet;
  2739.     end;
  2740.     FErrorDS.LogChanges := False;
  2741.     FErrorDS.DSBase.SetProp(DSProp(dspropAUTOINC_DISABLED), Integer(True));
  2742.   end;
  2743.   Result := FErrorDS;
  2744. end;
  2745.  
  2746. function TUpdateTree.GetHasErrors: Boolean;
  2747. begin
  2748.   Result := Assigned(FErrorDS);
  2749. end;
  2750.  
  2751. procedure TUpdateTree.InitErrorPacket(E: EUpdateError; Response: TResolverResponse);
  2752. var
  2753.   TrueRecNo: DWord;
  2754. begin
  2755.   with ErrorDS do
  2756.   begin
  2757.     if Assigned(Parent) then Parent.InitErrorPacket(nil, rrSkip);
  2758.     Self.Delta.UpdateCursorPos;
  2759.     Self.Delta.DSCursor.GetRecordNumber(TrueRecNo);
  2760.     if not Locate('ERROR_RECORDNO', Integer(TrueRecNo), []) then
  2761.       Append else
  2762.       Edit;
  2763.     if not Assigned(E) then
  2764.     begin
  2765.       if Response = rrSkip then
  2766.       begin
  2767.         SetFields([TrueRecNo]);
  2768.         Post;
  2769.       end else
  2770.         SetFields([TrueRecNo, 0, '', '', 0, 0]);
  2771.     end else
  2772.       SetFields([TrueRecNo, Ord(Response)+1, E.Message, '', 1, E.ErrorCode]);
  2773.   end;
  2774. end;
  2775.  
  2776. { TCustomResolver }
  2777.  
  2778. constructor TCustomResolver.Create(AProvider: TBaseProvider);
  2779. begin
  2780.   FProvider := AProvider;
  2781.   FUpdateTree := TUpdateTree.Create(nil, Self);
  2782. end;
  2783.  
  2784. destructor TCustomResolver.Destroy;
  2785. begin
  2786.   FUpdateTree.Free;
  2787.   inherited Destroy;
  2788. end;
  2789.  
  2790. { Updates }
  2791.  
  2792. procedure TCustomResolver.BeginUpdate;
  2793. begin
  2794. end;
  2795.  
  2796. procedure TCustomResolver.EndUpdate;
  2797. begin
  2798. end;
  2799.  
  2800. procedure TCustomResolver.InitKeyFields(Tree: TUpdateTree; ADelta: TPacketDataSet);
  2801. var
  2802.   Pos, i: Integer;
  2803.   KeyFields, FieldName: string;
  2804. begin
  2805.   KeyFields := IProviderSupport(Tree.Source).PSGetKeyFields;
  2806.   Pos := 1;
  2807.   while Pos <= Length(KeyFields) do
  2808.   begin
  2809.     FieldName := ExtractFieldName(KeyFields, Pos);
  2810.     for i := 0 to ADelta.FieldCount - 1 do
  2811.       if AnsiCompareText(FieldName, ADelta.Fields[i].Origin) = 0 then
  2812.       begin
  2813.         ADelta.Fields[i].ProviderFlags := ADelta.Fields[i].ProviderFlags + [pfInKey];
  2814.         break;
  2815.       end;
  2816.   end;
  2817. end;
  2818.  
  2819. procedure TCustomResolver.InitTreeData(Tree: TUpdateTree);
  2820. begin
  2821. end;
  2822.  
  2823. procedure TCustomResolver.FreeTreeData(Tree: TUpdateTree);
  2824. begin
  2825. end;
  2826.  
  2827. procedure TCustomResolver.InternalBeforeResolve(Tree: TUpdateTree);
  2828. begin
  2829. end;
  2830.  
  2831. function TCustomResolver.InternalUpdateRecord(Tree: TUpdateTree): Boolean;
  2832. type
  2833.   PRaiseFrame = ^TRaiseFrame;
  2834.   TRaiseFrame = record
  2835.     NextRaise: PRaiseFrame;
  2836.     ExceptAddr: Pointer;
  2837.     ExceptObject: TObject;
  2838.     ExceptionRecord: PExceptionRecord;
  2839.   end;
  2840. var
  2841.   RecNoSave: Integer;
  2842.   Applied: Boolean;
  2843.   UpdateKind: TUpdateKind;
  2844.   E: Exception;
  2845.   PrevErr, Err: EUpdateError;
  2846. begin
  2847.   PrevErr := nil;
  2848.   Err := nil;
  2849.   Tree.Delta.UseCurValues := False;
  2850.   while True do
  2851.   try
  2852.     UpdateKind := Tree.Delta.UpdateKind;
  2853.     if ((UpdateKind = ukInsert) and (FPrevResponse in [rrMerge, rrApply])) or
  2854.        ((FPrevResponse = rrMerge) and Tree.Delta.HasMergeConflicts) then
  2855.       DatabaseError(SInvalidResponse);
  2856.     Applied := False;
  2857.     RecNoSave := Tree.Delta.RecNo;
  2858.     try
  2859.       if Assigned(Provider.BeforeUpdateRecord) then
  2860.         Provider.BeforeUpdateRecord(Provider, Tree.Source, Tree.Delta, UpdateKind, Applied);
  2861.     finally
  2862.       if Tree.Delta.RecNo <> RecNoSave then
  2863.         Tree.Delta.RecNo := RecNoSave;
  2864.     end;
  2865.     if not Applied then
  2866.       case UpdateKind of
  2867.         ukModify:
  2868.         begin
  2869.           if poDisableEdits in Provider.Options then
  2870.             raise Exception.CreateRes(@SNoEditsAllowed);
  2871.           DoUpdate(Tree);
  2872.         end;
  2873.         ukDelete:
  2874.         begin
  2875.           if poDisableDeletes in Provider.Options then
  2876.             raise Exception.CreateRes(@SNoDeletesAllowed);
  2877.           DoDelete(Tree);
  2878.         end;
  2879.         ukInsert:
  2880.         begin
  2881.           if poDisableInserts in Provider.Options then
  2882.             raise Exception.CreateRes(@SNoInsertsAllowed);
  2883.           DoInsert(Tree);
  2884.         end;
  2885.       end;
  2886.     if Assigned(Provider.AfterUpdateRecord) then
  2887.       Provider.AfterUpdateRecord(Provider, Tree.Source, Tree.Delta, UpdateKind);
  2888.     if (poPropogateChanges in Provider.Options) and Tree.Delta.NewValuesModified then
  2889.       LogUpdateRecord(Tree);
  2890.     Break;
  2891.   except
  2892.     if RaiseList <> nil then
  2893.     begin
  2894.       { Remove the exception }
  2895.       E := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
  2896.       PRaiseFrame(RaiseList)^.ExceptObject := nil;
  2897.       PrevErr.Free;
  2898.       PrevErr := Err;
  2899.       Err := IProviderSupport(Tree.Source).PSGetUpdateException(E, PrevErr);
  2900.       if HandleUpdateError(Tree, Err, FMaxErrors, FErrorCount) then
  2901.       begin
  2902.         Tree.Delta.UseCurValues := True;
  2903.         Continue;
  2904.       end else
  2905.         break;
  2906.     end;
  2907.   end;
  2908.   PrevErr.Free;
  2909.   Err.Free;
  2910.   FPrevResponse := rrSkip;
  2911.   Result := FErrorCount <= FMaxErrors;
  2912. end;
  2913.  
  2914. function TCustomResolver.RowRequest(Row: OleVariant; Options: TFetchOptions): OleVariant;
  2915. begin
  2916.   BeginUpdate;
  2917.   try
  2918.     FUpdateTree.InitDelta(Row);
  2919.     try
  2920.       FUpdateTree.RefreshData(Options);
  2921.       Result := FUpdateTree.Delta.Data;
  2922.     finally
  2923.       FUpdateTree.Clear;
  2924.     end;
  2925.   finally
  2926.     EndUpdate;
  2927.   end;
  2928. end;
  2929.  
  2930. function TCustomResolver.ApplyUpdates(const Delta: OleVariant; MaxErrors: Integer;
  2931.   out ErrorCount: Integer): OleVariant;
  2932. begin
  2933.   BeginUpdate;
  2934.   try
  2935.     FUpdateTree.InitDelta(Delta);
  2936.     try
  2937.       Provider.DoOnUpdateData(FUpdateTree.Delta);
  2938.       FPrevResponse := rrSkip;
  2939.       if MaxErrors = -1 then MaxErrors := MaxInt;
  2940.       FMaxErrors := MaxErrors;
  2941.       FErrorCount := 0;
  2942.       FUpdateTree.DoUpdates;
  2943.       ErrorCount := FErrorCount;
  2944.       if FUpdateTree.HasErrors then
  2945.         Result := FUpdateTree.ErrorDS.Data else
  2946.         Result := Null;
  2947.     finally
  2948.       FUpdateTree.Clear;
  2949.     end;
  2950.   finally
  2951.     EndUpdate;
  2952.   end;
  2953. end;
  2954.  
  2955. { Update error handling }
  2956.  
  2957. function TCustomResolver.HandleUpdateError(Tree: TUpdateTree;
  2958.   E: EUpdateError; var MaxErrors, ErrorCount: Integer): Boolean;
  2959. var
  2960.   Response: TResolverResponse;
  2961.   UpdateKind: TUpdateKind;
  2962. begin
  2963.   UpdateKind := Tree.Delta.UpdateKind;
  2964.   if ErrorCount < MaxErrors then
  2965.     Response := rrSkip else
  2966.     Response := rrAbort;
  2967.   try
  2968.     InitializeConflictBuffer(Tree);
  2969.   except
  2970.     { Ignore errors that occur when initializing the conflict buffer }
  2971.   end;
  2972.   if Assigned(Provider.OnUpdateError) then
  2973.     Provider.OnUpdateError(Provider, Tree.Delta, E, UpdateKind, Response);
  2974.   if Response in [rrSkip, rrAbort] then
  2975.   begin
  2976.     Inc(ErrorCount);
  2977.     if ErrorCount > MaxErrors then
  2978.       Response := rrAbort;
  2979.     if (Response = rrAbort) then
  2980.       MaxErrors := ErrorCount - 1;
  2981.     if Response in [rrSkip, rrAbort] then
  2982.       LogUpdateError(Tree, E, Response);
  2983.   end;
  2984.   FPrevResponse := Response;
  2985.   Result := Response in [rrMerge, rrApply];
  2986. end;
  2987.  
  2988. procedure TCustomResolver.LogUpdateRecord(Tree: TUpdateTree);
  2989. var
  2990.   I: Integer;
  2991.   CurVal: Variant;
  2992. begin
  2993.   Tree.InitErrorPacket(nil, rrApply);
  2994.   for I := 0 to Tree.Delta.FieldCount - 1 do
  2995.   begin
  2996.     { Blobs, Bytes and VarBytes are not included in result packet }
  2997.     if (Tree.Delta.Fields[I].IsBlob) or
  2998.        (Tree.Delta.Fields[I].DataType in [ftBytes, ftVarBytes]) then
  2999.       continue;
  3000.     CurVal := Tree.Delta.Fields[I].NewValue;
  3001.     if not VarIsEmpty(CurVal) then
  3002.       Tree.ErrorDS.FieldByName(Tree.Delta.Fields[I].FieldName).Value := CurVal;
  3003.   end;
  3004.   Tree.ErrorDS.Post;
  3005. end;
  3006.  
  3007. procedure TCustomResolver.LogUpdateError(Tree: TUpdateTree;
  3008.   E: EUpdateError; Response: TResolverResponse);
  3009. var
  3010.   I: Integer;
  3011.   CurVal: Variant;
  3012. begin
  3013.   Tree.InitErrorPacket(E, Response);
  3014.   if Tree.Delta.HasCurValues then
  3015.     for I := 0 to Tree.Delta.FieldCount - 1 do
  3016.     begin
  3017.       { Blobs, Bytes and VarBytes are not included in result packet }
  3018.       if (Tree.Delta.Fields[I].IsBlob) or
  3019.          (Tree.Delta.Fields[I].DataType in [ftBytes, ftVarBytes]) then
  3020.         continue;
  3021.       CurVal := Tree.Delta.Fields[I].CurValue;
  3022.       if not VarIsEmpty(CurVal) then
  3023.         Tree.ErrorDS.FieldByName(Tree.Delta.Fields[I].FieldName).Value := CurVal;
  3024.     end;
  3025.   Tree.ErrorDS.Post;
  3026. end;
  3027.  
  3028. { TDataSetResolver }
  3029.  
  3030. constructor TDataSetResolver.Create(AProvider: TDataSetProvider);
  3031. begin
  3032.   inherited Create(AProvider);
  3033.   FOpened := False;
  3034. end;
  3035.  
  3036. function TDataSetResolver.GetProvider: TDataSetProvider;
  3037. begin
  3038.   Result := TDataSetProvider(inherited Provider);
  3039. end;
  3040.  
  3041. procedure TDataSetResolver.BeginUpdate;
  3042. begin
  3043.   FOpened := not Provider.DataSet.Active;
  3044.   if FOpened then
  3045.   begin
  3046.     Provider.DataSet.Open;
  3047.     FBookmark := '';
  3048.   end else
  3049.     FBookmark := Provider.DataSet.Bookmark;
  3050. end;
  3051.  
  3052. procedure TDataSetResolver.EndUpdate;
  3053. begin
  3054.   if FOpened then
  3055.   begin
  3056.     Provider.DataSet.Close;
  3057.     FOpened := False;
  3058.   end else
  3059.   begin
  3060.     if (Length(FBookmark) > 0) and
  3061.        Provider.DataSet.BookmarkValid(@FBookmark[1]) then
  3062.     Provider.DataSet.Bookmark := FBookmark;
  3063.   end;
  3064. end;
  3065.  
  3066. procedure TDataSetResolver.InitializeConflictBuffer(Tree: TUpdateTree);
  3067. begin
  3068.   { Set the conflict buffer to the current values of the data }
  3069.   if Provider.FindRecord(Tree.Source, Tree.Delta, upWhereKeyOnly) then
  3070.     Tree.Delta.AssignCurValues(Tree.Source);
  3071. end;
  3072.  
  3073. procedure TDataSetResolver.InternalBeforeResolve(Tree: TUpdateTree);
  3074. begin
  3075.   Provider.FindRecord(Tree.Source, Tree.Delta, Provider.UpdateMode);
  3076. end;
  3077.  
  3078. procedure TDataSetResolver.PutRecord(Tree: TUpdateTree);
  3079.  
  3080.   procedure PutField(Src, Dest: TField); forward;
  3081.  
  3082.   procedure PutObjectField(Src, Dest: TObjectField);
  3083.   var
  3084.     i: Integer;
  3085.   begin
  3086.     if VarIsNull(Src.NewValue) then
  3087.       Dest.Clear else
  3088.       for i := 0 to Src.FieldCount - 1 do
  3089.         if (not VarIsEmpty(Src.Fields[i].NewValue)) and
  3090.            (pfInUpdate in Src.Fields[i].ProviderFlags) then
  3091.           PutField(Src.Fields[i], Dest.Fields[i]);
  3092.   end;
  3093.  
  3094.   procedure PutField(Src, Dest: TField);
  3095.   begin
  3096.     if (Src.DataType in [ftArray, ftADT]) then
  3097.       PutObjectField(TObjectField(Src), TObjectField(Dest)) else
  3098.     if (Src.DataType in [ftDataSet, ftReference]) then
  3099.       raise Exception.CreateRes(@SNoDataSets) else
  3100.     if (not VarIsEmpty(Src.NewValue)) and
  3101.        (pfInUpdate in Src.ProviderFlags) then
  3102.       Dest.Assign(Src);
  3103.   end;
  3104.  
  3105. var
  3106.   i: Integer;
  3107.   Field: TField;
  3108. begin
  3109.   with Tree do
  3110.   try
  3111.     for i := 0 to Delta.FieldCount - 1 do
  3112.     begin
  3113.       Field := Source.FindField(Delta.Fields[i].FieldName);
  3114.       if (Field <> nil) then
  3115.         PutField(Delta.Fields[i], Field);
  3116.     end;
  3117.     Source.Post;
  3118.   except
  3119.     Source.Cancel;
  3120.     raise;
  3121.   end;
  3122. end;
  3123.  
  3124. procedure TDataSetResolver.DoUpdate(Tree: TUpdateTree);
  3125. begin
  3126.   with Tree do
  3127.   begin
  3128.     if not Provider.FindRecord(Source, Delta, Provider.UpdateMode) then
  3129.       DatabaseError(SRecordChanged);
  3130.     Source.Edit;
  3131.     PutRecord(Tree);
  3132.   end;
  3133. end;
  3134.  
  3135. procedure TDataSetResolver.DoDelete(Tree: TUpdateTree);
  3136. begin
  3137.   with Tree do
  3138.   begin
  3139.     if Provider.FindRecord(Tree.Source, Tree.Delta, Provider.UpdateMode) then
  3140.       Source.Delete else
  3141.       DatabaseError(SRecordChanged);
  3142.   end;
  3143. end;
  3144.  
  3145. procedure TDataSetResolver.DoInsert(Tree: TUpdateTree);
  3146. begin
  3147.   Tree.Source.Append;
  3148.   PutRecord(Tree);
  3149. end;
  3150.  
  3151. { TSQLResolver }
  3152.  
  3153. type
  3154.   PSQLInfo = ^TSQLInfo;
  3155.   TSQLInfo = record
  3156.     IsSQLBased: Boolean;
  3157.     QuoteChar: string;
  3158.     QuotedTable: string;
  3159.     QuotedTableDot: string;
  3160.     Opened: Boolean;
  3161.     HasObjects: Boolean;
  3162.   end;
  3163.  
  3164. constructor TSQLResolver.Create(AProvider: TDataSetProvider);
  3165. begin
  3166.   inherited Create(AProvider);
  3167.   FSQL := TStringList.Create;
  3168.   FParams := TParams.Create(nil);
  3169. end;
  3170.  
  3171. destructor TSQLResolver.Destroy;
  3172. begin
  3173.   FSQL.Free;
  3174.   FParams.Free;
  3175.   inherited Destroy;
  3176. end;
  3177.  
  3178. function TSQLResolver.GetProvider: TDataSetProvider;
  3179. begin
  3180.   Result := TDataSetProvider(inherited Provider);
  3181. end;
  3182.  
  3183. procedure TSQLResolver.InitTreeData(Tree: TUpdateTree);
  3184.  
  3185.   function GetQuotedTableName(SQLBased: Boolean;
  3186.     const QuoteChar, TableName: string): string;
  3187.   var
  3188.     DotPos: Integer;
  3189.   begin
  3190.     Result := '';
  3191.     if Length(TableName) > 0 then
  3192.     begin
  3193.       if TableName[1] in ['''','"','`'] then
  3194.         Result := TableName else
  3195.       begin
  3196.         if SQLBased then
  3197.         begin
  3198.           Result := TableName;
  3199.           DotPos := Pos('.', Result);
  3200.           if DotPos <> 0 then
  3201.           begin
  3202.             System.Insert(QuoteChar, Result, DotPos + 1);
  3203.             System.Insert(QuoteChar, Result, DotPos);
  3204.           end;
  3205.           Result := QuoteChar + Result + QuoteChar;
  3206.         end else
  3207.           Result := QuoteChar + TableName + QuoteChar;
  3208.       end;
  3209.     end;
  3210.   end;
  3211.  
  3212. var
  3213.   Info: PSQLInfo;
  3214.   i: Integer;
  3215.   TableName: string;
  3216. begin
  3217.   if Tree.Data <> nil then
  3218.     Dispose(PSQLInfo(Tree.Data));
  3219.   New(Info);
  3220.   Tree.Data := Info;
  3221.   Info.IsSQLBased := IProviderSupport(Tree.Source).PSIsSQLBased;
  3222.   Info.QuoteChar := IProviderSupport(Tree.Source).PSGetQuoteChar;
  3223.   TableName := VarToStr(Tree.Delta.GetOptionalParam(szTABLE_NAME));
  3224.   if TableName = '' then
  3225.     TableName := IProviderSupport(Tree.Source).PSGetTableName;
  3226.   Provider.DoGetTableName(Tree.Source, TableName);
  3227.   if TableName <> '' then
  3228.     Info.QuotedTable := GetQuotedTableName(Info.IsSQLBased, Info.QuoteChar, TableName);
  3229.   if Info.IsSQLBased then
  3230.     Info.QuotedTableDot := '' else
  3231.     Info.QuotedTableDot := Info.QuotedTable + '.';
  3232.   Info.HasObjects := False;
  3233.   for i := 0 to Tree.Delta.FieldCount - 1 do
  3234.     if (Tree.Delta.Fields[i] is TObjectField) and
  3235.        (TObjectField(Tree.Delta.Fields[i]).ObjectType <> '') then
  3236.     begin
  3237.       Info.HasObjects := True;
  3238.       break;
  3239.     end;
  3240. end;
  3241.  
  3242. procedure TSQLResolver.FreeTreeData(Tree: TUpdateTree);
  3243. begin
  3244.   Dispose(PSQLInfo(Tree.Data));
  3245.   Tree.Data := nil;
  3246. end;
  3247.  
  3248. procedure TSQLResolver.DoExecSQL(SQL: TStringList; Params: TParams);
  3249. var
  3250.   RowsAffected: Integer;
  3251. begin
  3252.   RowsAffected := IProviderSupport(Provider.DataSet).PSExecuteStatement(SQL.Text, Params);
  3253.   if not (poAllowMultiRecordUpdates in Provider.Options) and (RowsAffected > 1) then
  3254.     DatabaseError(STooManyRecordsModified);
  3255.   if RowsAffected < 1 then
  3256.     DatabaseError(SRecordChanged);
  3257. end;
  3258.  
  3259. procedure TSQLResolver.DoGetValues(SQL: TStringList; Params: TParams;
  3260.   DataSet: TDataSet);
  3261. var
  3262.   DS: TDataSet;
  3263. begin
  3264.   DS := nil;
  3265.   IProviderSupport(Provider.DataSet).PSExecuteStatement(SQL.Text, Params, @DS);
  3266.   if Assigned(DS) then
  3267.   try
  3268.     TPacketDataSet(DataSet).AssignCurValues(DS)
  3269.   finally
  3270.     DS.Free;
  3271.   end;
  3272. end;
  3273.  
  3274. procedure TSQLResolver.InitializeConflictBuffer(Tree: TUpdateTree);
  3275. var
  3276.   Alias: string;
  3277. begin
  3278.   if PSQLInfo(Tree.Data)^.HasObjects then Alias := DefAlias else Alias := '';
  3279.   FSQL.Clear;
  3280.   FParams.Clear;
  3281.   GenSelectSQL(Tree, FSQL, FParams, Alias);
  3282.   DoGetValues(FSQL, FParams, Tree.Delta);
  3283. end;
  3284.  
  3285. procedure TSQLResolver.InternalDoUpdate(Tree: TUpdateTree; UpdateKind: TUpdateKind);
  3286. var
  3287.   Alias: string;
  3288. begin
  3289.   if not IProviderSupport(Tree.Source).PSUpdateRecord(UpdateKind, Tree.Delta) then
  3290.   begin
  3291.     if (PSQLInfo(Tree.Data)^.QuotedTable = '') and not Tree.IsNested then
  3292.       DatabaseError(SNoTableName);
  3293.     if PSQLInfo(Tree.Data)^.HasObjects then Alias := DefAlias else Alias := '';
  3294.     FSQL.Clear;
  3295.     FParams.Clear;
  3296.     case UpdateKind of
  3297.       ukModify: GenUpdateSQL(Tree, FSQL, FParams, Alias);
  3298.       ukInsert: GenInsertSQL(Tree, FSQL, FParams);
  3299.       ukDelete: GenDeleteSQL(Tree, FSQL, FParams, Alias);
  3300.     end;
  3301.     DoExecSQL(FSQL, FParams);
  3302.   end;
  3303. end;
  3304.  
  3305. procedure TSQLResolver.DoUpdate(Tree: TUpdateTree);
  3306. begin
  3307.   InternalDoUpdate(Tree, ukModify);
  3308. end;
  3309.  
  3310. procedure TSQLResolver.DoDelete(Tree: TUpdateTree);
  3311. begin
  3312.   InternalDoUpdate(Tree, ukDelete);
  3313. end;
  3314.  
  3315. procedure TSQLResolver.DoInsert(Tree: TUpdateTree);
  3316. begin
  3317.   InternalDoUpdate(Tree, ukInsert);
  3318. end;
  3319.  
  3320. { SQL generation }
  3321.  
  3322. function QuoteFullName(const FullName, QuoteChar: string): string;
  3323. var
  3324.   i: Integer;
  3325.   p: PChar;
  3326. begin
  3327.   if (Length(FullName) > 1) and (FullName[1] in [#0, #1]) then
  3328.     p := @FullName[2] else
  3329.     p := PChar(FullName);
  3330.   Result := Format('%s%s%0:s',[QuoteChar, p]);
  3331.   for i := Length(Result) downto 1 do
  3332.     if Result[i] = '.' then
  3333.     begin
  3334.       System.Insert(QuoteChar, Result, i + 1);
  3335.       System.Insert(QuoteChar, Result, i);
  3336.     end;
  3337. end;
  3338.  
  3339. function TSQLResolver.UseFieldInUpdate(Field: TField): Boolean;
  3340. const
  3341.   ExcludedTypes = [ftAutoInc, ftDataSet, ftADT, ftArray, ftReference, ftCursor, ftUnknown];
  3342. begin
  3343.   with Field do
  3344.   begin
  3345.     Result := (pfInUpdate in ProviderFlags) and not (DataType in ExcludedTypes) and
  3346.       not ReadOnly and (FieldKind = fkData) and not (pfHidden in ProviderFlags) and
  3347.       not VarIsEmpty(NewValue) and (Tag <> tagSERVERCALC);
  3348.   end;
  3349. end;
  3350.  
  3351. function TSQLResolver.UseFieldInWhere(Field: TField; Mode: TUpdateMode): Boolean;
  3352. const
  3353.   ExcludedTypes = [ftDataSet, ftADT, ftArray, ftReference, ftCursor, ftUnknown];
  3354. begin
  3355.   with Field do
  3356.   begin
  3357.     Result := not (DataType in ExcludedTypes) and not IsBlob and
  3358.       (FieldKind = fkData) and (Tag <> tagSERVERCALC);
  3359.     if Result then
  3360.       case Mode of
  3361.         upWhereAll:
  3362.           Result := pfInWhere in ProviderFlags;
  3363.         upWhereChanged:
  3364.           Result := ((pfInWhere in ProviderFlags) and not VarIsEmpty(NewValue)) or
  3365.             (pfInKey in ProviderFlags);
  3366.         upWhereKeyOnly:
  3367.           Result := pfInKey in ProviderFlags;
  3368.       end;
  3369.   end;
  3370. end;
  3371.  
  3372. procedure TSQLResolver.GenWhereSQL(Tree: TUpdateTree; SQL: TStrings; Params: TParams;
  3373.   GenUpdateMode: TUpdateMode; Alias: string);
  3374.  
  3375.   function AddField(Field: TField; InObject: Boolean): Boolean;
  3376.   var
  3377.     i: Integer;
  3378.     BindText: string;
  3379.   begin
  3380.     Result := False;
  3381.     with PSQLInfo(Tree.Data)^ do
  3382.     begin
  3383.       if Field.DataType = ftADT then
  3384.       begin
  3385.         for i := 0 to TObjectField(Field).FieldCount - 1 do
  3386.           if AddField(TObjectField(Field).Fields[i], True) then
  3387.             Result := True;
  3388.       end else
  3389.       if UseFieldInWhere(Field, GenUpdateMode) then
  3390.       begin
  3391.         Result := True;
  3392.         if InObject then
  3393.         begin
  3394.           if VarIsNull(Field.OldValue) then
  3395.             BindText := Format(' %s.%s is null and', [Alias,
  3396.               QuoteFullName(Field.FullName, QuoteChar)])
  3397.           else
  3398.           begin
  3399.             BindText := Format(' %s.%s = ? and',[Alias,
  3400.               QuoteFullName(Field.FullName, QuoteChar)]);
  3401.             TParam(Params.Add).AssignFieldValue(Field, Field.OldValue);
  3402.           end;
  3403.         end else
  3404.         begin
  3405.           if VarIsNull(Field.OldValue) or (not IsSQLBased and
  3406.              (Field.DataType = ftString) and (Length(Field.OldValue) = 0)) then
  3407.             BindText := Format(' %s%s%s%1:s is null and', [PSQLInfo(Tree.Data)^.QuotedTableDot,
  3408.               QuoteChar, Field.Origin])
  3409.           else
  3410.           begin
  3411.             BindText := Format(' %s%s%s%1:s = ? and',
  3412.               [PSQLInfo(Tree.Data)^.QuotedTableDot, QuoteChar, Field.Origin]);
  3413.             TParam(Params.Add).AssignFieldValue(Field, Field.OldValue);
  3414.           end;
  3415.         end;
  3416.         SQL.Add(BindText);
  3417.       end;
  3418.     end;
  3419.   end;
  3420.  
  3421. var
  3422.   I: Integer;
  3423.   TempStr: string;
  3424.   Added: Boolean;
  3425. begin
  3426.   with PSQLInfo(Tree.Data)^ do
  3427.   begin
  3428.     SQL.Add('where');
  3429.     Added := False;
  3430.     for I := 0 to Tree.Delta.FieldCount - 1 do
  3431.       if AddField(Tree.Delta.Fields[I], Alias = NestAlias) then
  3432.         Added := True;
  3433.     if not Added then
  3434.       DatabaseError(SNoKeySpecified);
  3435.     { Remove last ' and'}
  3436.     TempStr := SQL[SQL.Count-1];
  3437.     SQL[SQL.Count-1] := Copy(TempStr, 1, Length(TempStr) - 4);
  3438.   end;
  3439. end;
  3440.  
  3441. procedure TSQLResolver.GenInsertSQL(Tree: TUpdateTree; SQL: TStrings;
  3442.   Params: TParams);
  3443.  
  3444.   procedure AddField(Field: TField; var FieldLine, ParamLine: string);
  3445.   var
  3446.     i: Integer;
  3447.     TempStr: string;
  3448.     Value: Variant;
  3449.   begin
  3450.     with PSQLInfo(Tree.Data)^ do
  3451.     begin
  3452.       if Field.DataType in [ftADT, ftArray] then
  3453.       begin
  3454.         FieldLine := Format('%s%s%s%s%2:s, ', [FieldLine, PSQLInfo(Tree.Data)^.QuotedTableDot,
  3455.           QuoteChar, Field.Origin]);
  3456.         ParamLine := Format('%s%s(', [ParamLine, TObjectField(Field).ObjectType]);
  3457.         for i := 0 to TObjectField(Field).FieldCount - 1 do
  3458.           AddField(TObjectField(Field).Fields[i], TempStr, ParamLine);
  3459.         ParamLine := Copy(ParamLine, 1, Length(ParamLine) - 2) + '), ';
  3460.       end else
  3461.       if (Field.DataType = ftDataSet) and (TObjectField(Field).ObjectType <> '') then
  3462.       begin
  3463.         FieldLine := Format('%s%s%s%s%2:s, ', [FieldLine, PSQLInfo(Tree.Data)^.QuotedTableDot,
  3464.           QuoteChar, Field.Origin]);
  3465.         ParamLine := Format('%s%s(), ', [ParamLine, TDataSetField(Field).ObjectType]);
  3466.       end else
  3467.       if UseFieldInUpdate(Field) then
  3468.       begin
  3469.         if Field.DataType = ftOraBlob then
  3470.         begin
  3471.           FieldLine := Format('%s%s%s%s%2:s, ', [FieldLine, PSQLInfo(Tree.Data)^.QuotedTableDot,
  3472.                     QuoteChar, Field.Origin]);
  3473.           ParamLine := ParamLine + 'EMPTY_BLOB(), '
  3474.         end 
  3475.         else if Field.DataType = ftOraClob then
  3476.         begin
  3477.           FieldLine := Format('%s%s%s%s%2:s, ', [FieldLine, PSQLInfo(Tree.Data)^.QuotedTableDot,
  3478.                     QuoteChar, Field.Origin]);
  3479.           ParamLine := ParamLine + 'EMPTY_CLOB(), '
  3480.         end else
  3481.         begin
  3482.           FieldLine := Format('%s%s%s%s%2:s, ', [FieldLine, PSQLInfo(Tree.Data)^.QuotedTableDot,
  3483.           QuoteChar, Field.Origin]);
  3484.           ParamLine := ParamLine + '?, ';
  3485.           Value := Field.NewValue;
  3486.           if VarIsEmpty(Value) then Value := Field.OldValue;
  3487.           TParam(Params.Add).AssignFieldValue(Field, Value);
  3488.         end;
  3489.       end;
  3490.     end;
  3491.   end;
  3492.  
  3493. var
  3494.   I, J: Integer;
  3495.   FieldLine, ParamLine: string;
  3496.   OraLobs: Integer;
  3497.   Value: Variant;
  3498. begin
  3499.   OraLobs := 0;
  3500.   with PSQLInfo(Tree.Data)^ do
  3501.   begin
  3502.     SQL.Clear;
  3503.     if Tree.IsNested then
  3504.     begin
  3505.       SQL.Add(Format('insert into the (select %s FROM %s %s',[QuoteFullName(Tree.Name, QuoteChar),
  3506.         PSQLInfo(Tree.Parent.Data).QuotedTable, DefAlias]));
  3507.       GenWhereSQL(Tree.Parent, SQL, Params, upWhereKeyOnly, DefAlias);
  3508.       SQL.Add(')');
  3509.     end else
  3510.       SQL.Add(Format('insert into %s', [QuotedTable]));
  3511.     FieldLine := '  (';
  3512.     ParamLine := FieldLine;
  3513.     for I := 0 to Tree.Delta.FieldCount - 1 do
  3514.     begin
  3515.       AddField(Tree.Delta.Fields[I], FieldLine, ParamLine);
  3516.       if Tree.Delta.Fields[I].DataType in [ftOraClob, ftOraBlob] then
  3517.         Inc(OraLobs);
  3518.     end;
  3519.     if not Tree.IsNested then
  3520.       SQL.Add(Copy(FieldLine, 1, Length(FieldLine)-2)+')');
  3521.     SQL.Add('values');
  3522.     SQL.Add(Copy(ParamLine, 1, Length(ParamLine)-2)+')');
  3523.  
  3524.     if OraLobs > 0 then
  3525.     begin
  3526.       SQL.Add(' RETURNING ');
  3527.       J := OraLobs;
  3528.       for I := 0 to Tree.Delta.FieldCount - 1 do
  3529.         if (Tree.Delta.Fields[I].DataType in [ftOraClob, ftOraBlob] )
  3530.            and UseFieldInUpdate(Tree.Delta.Fields[I])  then
  3531.            begin
  3532.              Dec(J);
  3533.              SQL.Add(Format('%s ', [Tree.Delta.Fields[I].FullName]));
  3534.              if J > 0 then SQL.Add(', ');
  3535.              Value := Tree.Delta.Fields[I].NewValue;
  3536.              if VarIsEmpty(Value) then Value := Tree.Delta.Fields[I].OldValue;
  3537.              TParam(Params.Add).AssignFieldValue(Tree.Delta.Fields[I], Value)
  3538.            end;
  3539.       SQL.Add('INTO ');
  3540.       while OraLobs > 0 do
  3541.       begin
  3542.         SQL.Add('? ');
  3543.         Dec(OraLobs);
  3544.         if OraLobs > 0 then SQL.Add(', ');
  3545.       end;
  3546.     end;
  3547.   end;
  3548. end;
  3549.  
  3550. procedure TSQLResolver.GenDeleteSQL(Tree: TUpdateTree; SQL: TStrings;
  3551.   Params: TParams; Alias: string);
  3552. begin
  3553.   with PSQLInfo(Tree.Data)^ do
  3554.   begin
  3555.     SQL.Clear;
  3556.     if Tree.IsNested then
  3557.     begin
  3558.       Alias := NestAlias;
  3559.       SQL.Add(Format('delete the (select %s FROM %s %s',[QuoteFullName(Tree.Name, QuoteChar),
  3560.         PSQLInfo(Tree.Parent.Data).QuotedTable, DefAlias]));
  3561.       GenWhereSQL(Tree.Parent, SQL, Params, upWhereKeyOnly, DefAlias);
  3562.       SQL.Add(Format(') %s',[Alias]));
  3563.     end else
  3564.       SQL.Add(Format('delete from %s %s', [QuotedTable, Alias]));
  3565.     GenWhereSQL(Tree, SQL, Params, Provider.UpdateMode, Alias);
  3566.   end;
  3567. end;
  3568.  
  3569. procedure TSQLResolver.GenUpdateSQL(Tree: TUpdateTree; SQL: TStrings;
  3570.   Params: TParams; Alias: string);
  3571.  
  3572.   procedure AddField(Field: TField; InObject, InArray: Boolean);
  3573.   var
  3574.     i: Integer;
  3575.     TempStr: string;
  3576.     Value: Variant;
  3577.     NoParam: Boolean;
  3578.   begin
  3579.     NoParam := False;
  3580.     with PSQLInfo(Tree.Data)^ do
  3581.     begin
  3582.       if Field.DataType = ftADT then
  3583.       begin
  3584.         if InArray then
  3585.           SQL.Add(Format(' %s(',[TObjectField(Field).ObjectType]));
  3586.         for i := 0 to TObjectField(Field).FieldCount - 1 do
  3587.           AddField(TObjectField(Field).Fields[i], True, InArray);
  3588.         if InArray then
  3589.         begin
  3590.           TempStr := SQL[SQL.Count-1];
  3591.           SQL[SQL.Count-1] := Copy(TempStr, 1, Length(TempStr) - 1);
  3592.           SQL.Add('),');
  3593.         end;
  3594.       end
  3595.       else if Field.DataType = ftArray then
  3596.       begin
  3597.         SQL.Add(Format('%s = %s(',[Field.FullName, TObjectField(Field).ObjectType]));
  3598.         for i := 0 to TObjectField(Field).FieldCount - 1 do
  3599.           AddField(TObjectField(Field).Fields[i], InObject, True);
  3600.         TempStr := SQL[SQL.Count-1];
  3601.         SQL[SQL.Count-1] := Copy(TempStr, 1, Length(TempStr) - 1);
  3602.         SQL.Add('),');
  3603.       end
  3604.       else if InArray then
  3605.       begin
  3606.         SQL.Add(' ?,');
  3607.         Value := Field.NewValue;
  3608.         if VarIsEmpty(Value) then Value := Field.OldValue;
  3609.         TParam(Params.Add).AssignFieldValue(Field, Value);
  3610.       end
  3611.       else if UseFieldInUpdate(Field) then
  3612.       begin
  3613.         if Field.DataType = ftOraClob then
  3614.         begin
  3615.           NoParam := True;
  3616.           if InObject then
  3617.             SQL.Add(Format(' %s.%s = EMPTY_CLOB(),', [Alias, QuoteFullName(Field.FullName, QuoteChar),
  3618.               Field.FullName])) else
  3619.             SQL.Add(Format(' %s%s%s%1:s = EMPTY_CLOB(),', [PSQLInfo(Tree.Data)^.QuotedTableDot,
  3620.                QuoteChar, Field.Origin]));
  3621.         end
  3622.         else if Field.DataType = ftOraBlob then
  3623.         begin
  3624.           NoParam := True;
  3625.           if InObject then
  3626.             SQL.Add(Format(' %s.%s = EMPTY_BLOB(),', [Alias, QuoteFullName(Field.FullName, QuoteChar),
  3627.                Field.FullName])) else
  3628.             SQL.Add(Format(' %s%s%s%1:s = EMPTY_BLOB(),', [PSQLInfo(Tree.Data)^.QuotedTableDot,
  3629.                QuoteChar, Field.Origin]));
  3630.         end
  3631.         else if InObject then
  3632.           SQL.Add(Format(' %s.%s = ?,', [Alias, QuoteFullName(Field.FullName, QuoteChar),
  3633.             Field.FullName])) else
  3634.           SQL.Add(Format(' %s%s%s%1:s = ?,', [PSQLInfo(Tree.Data)^.QuotedTableDot,
  3635.             QuoteChar, Field.Origin]));
  3636.         if not NoParam then
  3637.         begin
  3638.           Value := Field.NewValue;
  3639.           if VarIsEmpty(Value) then Value := Field.OldValue;
  3640.           TParam(Params.Add).AssignFieldValue(Field, Value);
  3641.         end;
  3642.       end;
  3643.     end;
  3644.   end;
  3645.  
  3646. var
  3647.   I, J: integer;
  3648.   TempStr: string;
  3649.   OraLobs: Integer;
  3650.   Value: Variant;
  3651. begin
  3652.   OraLobs := 0;
  3653.   with PSQLInfo(Tree.Data)^ do
  3654.   begin
  3655.     if Tree.IsNested then
  3656.     begin
  3657.       Alias := NestAlias;
  3658.       SQL.Add(Format('update the (select %s FROM %s %s',[QuoteFullName(Tree.Name, QuoteChar),
  3659.         PSQLInfo(Tree.Parent.Data).QuotedTable, DefAlias]));
  3660.       GenWhereSQL(Tree.Parent, SQL, Params, upWhereKeyOnly, DefAlias);
  3661.       SQL.Add(Format(') %s set',[Alias]));
  3662.     end else
  3663.       SQL.Add(Format('update %s %s set', [QuotedTable, Alias]));
  3664.  
  3665.     for I := 0 to Tree.Delta.FieldCount - 1 do
  3666.     begin
  3667.       if (Tree.Delta.Fields[i].DataType in [ftOraClob, ftOraBlob]) and
  3668.           UseFieldInUpdate(Tree.Delta.Fields[I]) then
  3669.           Inc(OraLobs);
  3670.       AddField(Tree.Delta.Fields[i], Alias = NestAlias, False);
  3671.     end;
  3672.     { Remove last ',' }
  3673.     TempStr := SQL[SQL.Count-1];
  3674.     SQL[SQL.Count-1] := Copy(TempStr, 1, Length(TempStr) - 1);
  3675.  
  3676.     GenWhereSQL(Tree, SQL, Params, Provider.UpdateMode, Alias);
  3677.  
  3678.     if OraLobs > 0 then
  3679.     begin
  3680.       SQL.Add(' RETURNING ');
  3681.       J := OraLobs;
  3682.       for I := 0 to Tree.Delta.FieldCount - 1 do
  3683.         if (Tree.Delta.Fields[I].DataType in [ftOraClob, ftOraBlob]) 
  3684.            and UseFieldInUpdate(Tree.Delta.Fields[I])  then
  3685.            begin
  3686.              Dec(J);
  3687.              SQL.Add(Format('%s ', [Tree.Delta.Fields[I].FullName]));
  3688.              if J > 0 then SQL.Add(', ');
  3689.              Value := Tree.Delta.Fields[I].NewValue;
  3690.              if VarIsEmpty(Value) then Value := Tree.Delta.Fields[I].OldValue;
  3691.              TParam(Params.Add).AssignFieldValue(Tree.Delta.Fields[I], Value)
  3692.            end;
  3693.       SQL.Add('INTO ');
  3694.       while OraLobs > 0 do
  3695.       begin
  3696.         SQL.Add('? ');
  3697.         Dec(OraLobs);
  3698.         if OraLobs > 0 then SQL.Add(', ');
  3699.       end;
  3700.     end;
  3701.   end;
  3702. end;
  3703.  
  3704. procedure TSQLResolver.GenSelectSQL(Tree: TUpdateTree; SQL: TStrings;
  3705.   Params: TParams; Alias: string);
  3706. var
  3707.   i: Integer;
  3708.   Temp: string;
  3709. begin
  3710.   with PSQLInfo(Tree.Data)^ do
  3711.   begin
  3712.     SQL.Add('select');
  3713.     for i := 0 to Tree.Delta.FieldCount - 1 do
  3714.       with Tree.Delta.Fields[i] do
  3715.         if not (DataType in [ftDataSet, ftReference]) and (FieldKind = fkData) then
  3716.           SQL.Add(Format(' %s%s%s%1:s,',[QuotedTableDot, QuoteChar, Origin]));
  3717.     { Remove last ',' }
  3718.     Temp := SQL[SQL.Count-1];
  3719.     SQL[SQL.Count-1] := Copy(Temp, 1, Length(Temp) - 1);
  3720.     SQL.Add(Format(' from %s %s',[QuotedTable, Alias]));
  3721.     GenWhereSQL(Tree, SQL, Params, upWhereKeyOnly, Alias);
  3722.   end;
  3723. end;
  3724.  
  3725. { TLocalAppServer }
  3726.  
  3727. constructor TLocalAppServer.Create(AProvider: TCustomProvider);
  3728. begin
  3729.   inherited Create;
  3730.   FProvider := AProvider;
  3731. end;
  3732.  
  3733. destructor TLocalAppServer.Destroy; 
  3734. begin
  3735.   if FProviderCreated then FProvider.Free;
  3736.   inherited Destroy;
  3737. end;
  3738.  
  3739. constructor TLocalAppServer.Create(ADataset: TDataset);
  3740. begin
  3741.   inherited Create;
  3742.   FProvider := TDatasetProvider.Create(nil);
  3743.   TDatasetProvider(FProvider).Dataset := ADataset;
  3744.   FProviderCreated := True;
  3745. end;
  3746.  
  3747. function TLocalAppServer.GetTypeInfoCount(out Count: Integer): HResult;
  3748. begin
  3749.   Result := E_NOTIMPL;
  3750. end;
  3751.  
  3752. function TLocalAppServer.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
  3753. begin
  3754.   Result := E_NOTIMPL;
  3755. end;
  3756.  
  3757. function TLocalAppServer.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  3758.   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
  3759. begin
  3760.   Result := E_NOTIMPL;
  3761. end;
  3762.  
  3763. function TLocalAppServer.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  3764.   Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
  3765. begin
  3766.   Result := E_NOTIMPL;
  3767. end;
  3768.  
  3769. function TLocalAppServer.AS_ApplyUpdates(const ProviderName: WideString;
  3770.   Delta: OleVariant; MaxErrors: Integer; out ErrorCount: Integer;
  3771.   var OwnerData: OleVariant): OleVariant;
  3772. begin
  3773.   Result := FProvider.ApplyUpdates(Delta, MaxErrors, ErrorCount, OwnerData);
  3774. end;
  3775.  
  3776. function TLocalAppServer.AS_GetRecords(const ProviderName: WideString; Count: Integer;
  3777.   out RecsOut: Integer; Options: Integer; const CommandText: WideString;
  3778.   var Params, OwnerData: OleVariant): OleVariant;
  3779. begin
  3780.   Result := FProvider.GetRecords(Count, RecsOut, Options, CommandText, Params,
  3781.     OwnerData);
  3782. end;
  3783.  
  3784. function TLocalAppServer.AS_GetProviderNames: OleVariant;
  3785. begin
  3786.   Result := NULL;
  3787. end;
  3788.  
  3789. function TLocalAppServer.AS_DataRequest(const ProviderName: WideString;
  3790.   Data: OleVariant): OleVariant;
  3791. begin
  3792.   Result := FProvider.DataRequest(Data);
  3793. end;
  3794.  
  3795. function TLocalAppServer.AS_GetParams(const ProviderName: WideString;
  3796.   var OwnerData: OleVariant): OleVariant;
  3797. begin
  3798.   Result := FProvider.GetParams(OwnerData);
  3799. end;
  3800.  
  3801. function TLocalAppServer.AS_RowRequest(const ProviderName: WideString;
  3802.   Row: OleVariant; RequestType: Integer; var OwnerData: OleVariant): OleVariant;
  3803. begin
  3804.   Result := FProvider.RowRequest(Row, RequestType, OwnerData);
  3805. end;
  3806.  
  3807. procedure TLocalAppServer.AS_Execute(const ProviderName: WideString;
  3808.    const CommandText: WideString; var Params, OwnerData: OleVariant);
  3809. begin
  3810.   FProvider.Execute(CommandText, Params, OwnerData);
  3811. end;
  3812.  
  3813. function TLocalAppServer.InterfaceSupportsErrorInfo(const iid: TIID): HResult;
  3814. begin
  3815.   if IsEqualGUID(IAppServer, iid) then
  3816.     Result := S_OK else
  3817.     Result := S_FALSE;
  3818. end;
  3819.  
  3820. function TLocalAppServer.SafeCallException(ExceptObject: TObject;
  3821.   ExceptAddr: Pointer): HResult;
  3822. begin
  3823.   Result := HandleSafeCallException(ExceptObject, ExceptAddr, IAppServer, '', '');
  3824. end;
  3825.  
  3826.  
  3827. end.
  3828.