开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > Internet/IE编程 > 查看源码
Provider.pas
资源名称：__DCOM.rar　[点击查看]
上传用户：etonglee
上传日期：2014-03-01
资源大小：698k
文件大小：136k
源码类别：

Internet/IE编程

开发平台：

Delphi

Provider.pas：源码内容
  1. { ********************************************************************** }
  2. {                                                                        }
  3. { Kylix and Delphi Cross-Platform Visual Component Library               }
  4. {                                                                        }
  5. { Copyright (C) 1997, 2001 Borland Software Corporation                  }
  6. {                                                                        }
  7. { ********************************************************************** }
  10. unit Provider;
  12. {$T-,H+,X+}
  14. interface
  15. {$IFDEF MSWINDOWS}
  16. uses Windows, SysUtils, VarUtils, Variants, Classes, DBClient, DB, DSIntf, ActiveX, Midas, SqlTimSt;
  17. {$ENDIF}
  18. {$IFDEF LINUX}
  19. uses Libc, SysUtils, VarUtils, Variants, Classes, DBClient, DB, DSIntf, Midas, SqlTimSt;
  20. {$ENDIF}
  22. var
  23.   InformixLob: Boolean;
  25. type
  27. { EDSWriter }
  29.   EDSWriter = class(Exception)
  30.   private
  31.     FErrorCode: Integer;
  32.   public
  33.     constructor Create(ErrMsg: string; Status: Integer);
  34.     property ErrorCode: Integer read FErrorCode;
  35.   end;
  36. {$EXTERNALSYM EDSWriter}
  38. (*$HPPEMIT 'namespace Provider' *)
  39. (*$HPPEMIT '{' *)
  40. (*$HPPEMIT 'class DELPHICLASS EDSWriter;' *)
  41. (*$HPPEMIT '#pragma pack(push, 4)' *)
  42. (*$HPPEMIT 'class PASCALIMPLEMENTATION EDSWriter : public Sysutils::Exception' *)
  43. (*$HPPEMIT '{' *)
  44. (*$HPPEMIT '  typedef Sysutils::Exception inherited;' *)
  45. (*$HPPEMIT '' *)
  46. (*$HPPEMIT 'private:' *)
  47. (*$HPPEMIT '  int FErrorCode;' *)
  48. (*$HPPEMIT '' *)
  49. (*$HPPEMIT 'public:' *)
  50. (*$HPPEMIT '  __fastcall EDSWriter(AnsiString ErrMsg, long Status);' *)
  51. (*$HPPEMIT '  __property int ErrorCode = {read=FErrorCode, nodefault};' *)
  52. (*$HPPEMIT 'public:' *)
  53. (*$HPPEMIT '  /* Exception.CreateFmt */ inline __fastcall EDSWriter(const AnsiString Msg, const System::TVarRec * Args, const int Args_Size) : Sysutils::Exception(Msg, Args, Args_Size) { }' *)
  54. (*$HPPEMIT '  /* Exception.CreateRes */ inline __fastcall EDSWriter(int Ident, Extended Dummy) : Sysutils::Exception(Ident, Dummy) { }' *)
  55. (*$HPPEMIT '  /* Exception.CreateResFmt */ inline __fastcall EDSWriter(int Ident, const System::TVarRec * Args, const int Args_Size) : Sysutils::Exception(Ident, Args, Args_Size) { }' *)
  56. (*$HPPEMIT '  /* Exception.CreateHelp */ inline __fastcall EDSWriter(const AnsiString Msg, int AHelpContext) : Sysutils::Exception(Msg, AHelpContext) { }' *)
  57. (*$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) { }' *)
  58. (*$HPPEMIT '  /* Exception.CreateResHelp */ inline __fastcall EDSWriter(int Ident, int AHelpContext) : Sysutils::Exception(Ident, AHelpContext) { }' *)
  59. (*$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) { }' *)
  60. (*$HPPEMIT '' *)
  61. (*$HPPEMIT 'public:' *)
  62. (*$HPPEMIT '  /* TObject.Destroy */ inline __fastcall virtual ~EDSWriter(void) { }' *)
  63. (*$HPPEMIT '' *)
  64. (*$HPPEMIT '};' *)
  65. (*$HPPEMIT '' *)
  66. (*$HPPEMIT '#pragma pack(pop)' *)
  67. (*$HPPEMIT '}' *)
  69. { TCustomPacketWriter }
  71.   TCustomPacketWriter = class(TObject)
  72.   private
  73.     FIDSWriter: IDSWriter;
  74.     FBuffer: array of Byte;
  75.   protected
  76.     procedure AddAttribute(Area: TPcktAttrArea; const ParamName: string;
  77.       const Value: OleVariant; IncludeInDelta: Boolean);
  78.     procedure Check(Status: Integer);
  79.     property DSWriter: IDSWriter read FIDSWriter;
  80.   public
  81.     constructor Create; virtual;
  82.     destructor Destroy; override;
  83.   end;
  85. { TDataPacketWriter }
  87. type
  89. { Forward declarations }
  92.   TGetRecordOption = (grMetaData, grReset, grXML, grXMLUTF8);
  93.   TGetRecordOptions = set of TGetRecordOption;
  95.   TDataRequestEvent = function(Sender: TObject; Input: OleVariant): OleVariant of object;
  97.   TProviderOption = (poFetchBlobsOnDemand, poFetchDetailsOnDemand,
  98.     poIncFieldProps, poCascadeDeletes, poCascadeUpdates, poReadOnly,
  99.     poAllowMultiRecordUpdates, poDisableInserts, poDisableEdits,
  100.     poDisableDeletes, poNoReset, poAutoRefresh, poPropogateChanges,
  101.     poAllowCommandText, poRetainServerOrder );
  102.   TProviderOptions = set of TProviderOption;
  104.   PPutFieldInfo = ^TPutFieldInfo;
  105.   TPutFieldProc = procedure(Info: PPutFieldInfo) of object;
  106.   TPutFieldInfo = record
  107.     FieldNo: Integer;
  108.     Field: TField;
  109.     DataSet: TDataSet;
  110.     Size: Integer;
  111.     IsDetail: Boolean;
  112.     Opened: Boolean;
  113.     PutProc: TPutFieldProc;
  114.     LocalFieldIndex: Integer;
  115.     FieldInfos: Pointer;
  116.   end;
  118.   TInfoArray = array of TPutFieldInfo;
  120.   TGetParamsEvent = procedure(DataSet: TDataSet; Params: TList) of object;
  122.   TDataPacketWriter = class(TCustomPacketWriter)
  123.   private
  124.     FConstraints: Boolean;
  125.     FPutFieldInfo: TInfoArray;
  126.     FOptions: TProviderOptions;
  127.     FPacketOptions: TGetRecordOptions;
  128.     FOnGetParams: TGetParamsEvent;
  129.     procedure FreeInfoRecords(var Info: TInfoArray);
  130.     function GetFieldIdx(const FieldName: string; const Info: TInfoArray): Integer;
  131.     procedure AddExtraFieldProps(Field: TField);
  132.     function InitPutProcs(ADataSet: TDataSet; var GlobalIdx: Integer): TInfoArray;
  133.     procedure RefreshPutProcs(ADataSet: TDataSet; var Info: TInfoArray);
  134.   protected
  135.     procedure AddColumn(const Info: TPutFieldInfo);
  136.     procedure AddConstraints(DataSet: TDataSet);
  137.     procedure AddDataSetAttributes(DataSet: TDataSet);
  138.     procedure AddFieldLinks(const Info: TInfoArray);
  139.     procedure AddIndexDefs(DataSet: TDataSet; const Info: TInfoArray);
  140.     procedure PutADTField(Info: PPutFieldInfo);
  141.     procedure PutArrayField(Info: PPutFieldInfo);
  142.     procedure PutBlobField(Info: PPutFieldInfo);
  143.     procedure PutCalcField(Info: PPutFieldInfo);
  144.     procedure PutDataSetField(Info: PPutFieldInfo);
  145.     procedure PutField(Info: PPutFieldInfo);
  146.     procedure PutStringField(Info: PPutFieldInfo);
  147.     procedure PutWideStringField(Info: PPutFieldInfo);
  148.     procedure PutVarBytesField(Info: PPutFieldInfo);
  149.     procedure Reset;
  150.     procedure WriteMetaData(DataSet: TDataSet; const Info: TInfoArray;
  151.       IsReference: Boolean = False);
  152.     function WriteDataSet(DataSet: TDataSet; var Info: TInfoArray;
  153.       RecsOut: Integer): Integer;
  154.     property OnGetParams: TGetParamsEvent read FOnGetParams write FOnGetParams;
  155.   public
  156.     destructor Destroy; override;
  157.     procedure GetDataPacket(DataSet: TDataSet; var RecsOut: Integer;
  158.       out Data: OleVariant);
  159.     property Constraints: Boolean read FConstraints write FConstraints;
  160.     property PacketOptions: TGetRecordOptions read FPacketOptions write FPacketOptions;
  161.     property Options: TProviderOptions read FOptions write FOptions;
  162.   end;
  164. { TPacketDataSet }
  166.   TPacketDataSet = class(TCustomClientDataSet)
  167.   private
  168.     FOldRecBuf: PChar;
  169.     FCurRecBuf: PChar;
  170.     FCurValues: PChar;
  171.     FUseCurValues: Boolean;
  172.     FWritingCurValues: Boolean;
  173.     FNewValuesModified: Boolean;
  174.     function GetStreamMetaData: Boolean;
  175.     procedure SetStreamMetaData(Value: Boolean);
  176.     procedure SetWritingCurValues(const Value: Boolean);
  177.   protected
  178.     procedure DataEvent(Event: TDataEvent; Info: Longint); override;
  179.     function GetStateFieldValue(State: TDataSetState; Field: TField): Variant; override;
  180.     procedure InternalClose; override;
  181.     procedure InternalOpen; override;
  182.     procedure InternalInitRecord(Buffer: PChar); override;
  183.     procedure SetFieldData(Field: TField; Buffer: Pointer); override;
  184.     property WritingCurValues: Boolean read FWritingCurValues write SetWritingCurValues;
  185.   public
  186.     constructor Create(AOwner: TComponent); override;
  187.     procedure AssignCurValues(Source: TDataSet); overload;
  188.     procedure AssignCurValues(const CurValues: Variant); overload;
  189.     procedure CreateFromDelta(Source: TPacketDataSet);
  190.     function HasCurValues: Boolean;
  191.     function HasMergeConflicts: Boolean;
  192.     procedure InitAltRecBuffers(CheckModified: Boolean = True);
  193.     function UpdateKind: TUpdateKind;
  194.     property NewValuesModified: Boolean read FNewValuesModified;
  195.     property StreamMetaData: Boolean read GetStreamMetaData write SetStreamMetaData;
  196.     property UseCurValues: Boolean read FUseCurValues write FUseCurValues;
  197.   end;
  199. { TCustomProvider }
  201.   TCustomProvider = class(TComponent)
  202.   private
  203.     FExported: Boolean;
  204.     FOnDataRequest: TDataRequestEvent;
  205.     FBeforeApplyUpdates: TRemoteEvent;
  206.     FAfterApplyUpdates: TRemoteEvent;
  207.     FBeforeGetRecords: TRemoteEvent;
  208.     FAfterGetRecords: TRemoteEvent;
  209.     FBeforeRowRequest: TRemoteEvent;
  210.     FAfterRowRequest: TRemoteEvent;
  211.     FBeforeExecute: TRemoteEvent;
  212.     FAfterExecute: TRemoteEvent;
  213.     FBeforeGetParams: TRemoteEvent;
  214.     FAfterGetParams: TRemoteEvent;
  215.     function GetData: OleVariant;
  216.   protected
  218.     function InternalApplyUpdates(const Delta: OleVariant; MaxErrors: Integer;
  219.       out ErrorCount: Integer): OleVariant; virtual; abstract;
  220.     function InternalGetRecords(Count: Integer; out RecsOut: Integer;
  221.       Options: TGetRecordOptions; const CommandText: WideString;
  222.       var Params: OleVariant): OleVariant; virtual;
  223.     function InternalRowRequest(const Row: OleVariant; RequestType: TFetchOptions): OleVariant; virtual;
  224.     procedure InternalExecute(const CommandText: WideString; var Params: OleVariant); virtual;
  225.     function InternalGetParams(Types: TParamTypes = AllParamTypes): OleVariant; virtual;
  227.   { Event overrides }
  228.     procedure DoAfterApplyUpdates(var OwnerData: OleVariant); virtual;
  229.     procedure DoBeforeApplyUpdates(var OwnerData: OleVariant); virtual;
  230.     procedure DoAfterExecute(var OwnerData: OleVariant); virtual;
  231.     procedure DoBeforeExecute(const CommandText: WideString; var Params,
  232.       OwnerData: OleVariant); virtual;
  233.     procedure DoAfterGetParams(var OwnerData: OleVariant); virtual;
  234.     procedure DoBeforeGetParams(var OwnerData: OleVariant); virtual;
  235.     procedure DoAfterGetRecords(var OwnerData: OleVariant); virtual;
  236.     procedure DoBeforeGetRecords(Count: Integer; Options: Integer;
  237.       const CommandText: WideString; var Params, OwnerData: OleVariant); virtual;
  238.     procedure DoAfterRowRequest(var OwnerData: OleVariant); virtual;
  239.     procedure DoBeforeRowRequest(var OwnerData: OleVariant); virtual;
  241.   { Events }
  242.     property OnDataRequest: TDataRequestEvent read FOnDataRequest write FOnDataRequest;
  243.     property BeforeApplyUpdates: TRemoteEvent read FBeforeApplyUpdates write FBeforeApplyUpdates;
  244.     property AfterApplyUpdates: TRemoteEvent read FAfterApplyUpdates write FAfterApplyUpdates;
  245.     property BeforeGetRecords: TRemoteEvent read FBeforeGetRecords write FBeforeGetRecords;
  246.     property AfterGetRecords: TRemoteEvent read FAfterGetRecords write FAfterGetRecords;
  247.     property BeforeRowRequest: TRemoteEvent read FBeforeRowRequest write FBeforeRowRequest;
  248.     property AfterRowRequest: TRemoteEvent read FAfterRowRequest write FAfterRowRequest;
  249.     property BeforeExecute: TRemoteEvent read FBeforeExecute write FBeforeExecute;
  250.     property AfterExecute: TRemoteEvent read FAfterExecute write FAfterExecute;
  251.     property BeforeGetParams: TRemoteEvent read FBeforeGetParams write FBeforeGetParams;
  252.     property AfterGetParams: TRemoteEvent read FAfterGetParams write FAfterGetParams;
  253.   public
  254.     constructor Create(AOwner: TComponent); override;
  255.     destructor Destroy; override;
  257.     function ApplyUpdates(const Delta: OleVariant; MaxErrors: Integer;
  258.       out ErrorCount: Integer): OleVariant; overload;
  259.     function ApplyUpdates(const Delta: OleVariant; MaxErrors: Integer;
  260.       out ErrorCount: Integer; var OwnerData: OleVariant): OleVariant; overload;
  261.     function GetRecords(Count: Integer; out RecsOut: Integer;
  262.       Options: Integer): OleVariant; overload;
  263.     function GetRecords(Count: Integer; out RecsOut: Integer; Options: Integer;
  264.       const CommandText: WideString; var Params,
  265.       OwnerData: OleVariant): OleVariant; overload;
  266.     function RowRequest(const Row: OleVariant; RequestType: Integer;
  267.       var OwnerData: OleVariant): OleVariant;
  268.     procedure Execute(const CommandText: WideString; var Params,
  269.       OwnerData: OleVariant);
  270.     function GetParams(var OwnerData: OleVariant): OleVariant;
  271.     function DataRequest(Input: OleVariant): OleVariant; virtual;
  273.     property Data: OleVariant read GetData;
  274.     property Exported: Boolean read FExported write FExported default True;
  275.   end;
  277. const
  278.   ResetOption: Integer = 1 shl ord(grReset);
  279.   MetaDataOption: Integer = 1 shl ord(grMetaData);
  280.   XMLOption: Integer = 1 shl ord(grXML);
  281.   XMLUTF8Option: Integer = 1 shl ord(grXMLUTF8);
  283. { TBaseProvider }
  285. type
  287.   TUpdateTree = class;
  289.   TCustomResolver = class;
  290.   TResolverResponse = (rrSkip, rrAbort, rrMerge, rrApply, rrIgnore);
  291.   TProviderDataEvent = procedure(Sender: TObject; DataSet: TCustomClientDataSet) of object;
  292.   TBeforeUpdateRecordEvent = procedure(Sender: TObject; SourceDS: TDataSet;
  293.     DeltaDS: TCustomClientDataSet; UpdateKind: TUpdateKind; var Applied: Boolean) of object;
  294.   TAfterUpdateRecordEvent = procedure(Sender: TObject; SourceDS: TDataSet;
  295.     DeltaDS: TCustomClientDataSet; UpdateKind: TUpdateKind) of object;
  296.   TResolverErrorEvent = procedure(Sender: TObject; DataSet: TCustomClientDataSet;
  297.     E: EUpdateError; UpdateKind: TUpdateKind; var Response: TResolverResponse) of object;
  299.   TBaseProvider = class(TCustomProvider)
  300.   private
  301.     FDataDS: TPacketDataSet;
  302.     FUpdateMode: TUpdateMode;
  303.     FResolver: TCustomResolver;
  304.     FOnGetData: TProviderDataEvent;
  305.     FOnUpdateData: TProviderDataEvent;
  306.     FOnUpdateError: TResolverErrorEvent;
  307.     FBeforeUpdateRecord: TBeforeUpdateRecordEvent;
  308.     FAfterUpdateRecord: TAfterUpdateRecordEvent;
  309.     FProviderOptions: TProviderOptions;
  310.   protected
  311.     procedure CheckResolver;
  312.     function CreateResolver: TCustomResolver; virtual;
  313.     procedure FreeResolver;
  314.     procedure CreateDataPacket(PacketOpts: TGetRecordOptions;
  315.       ProvOpts: TProviderOptions; var RecsOut: Integer; var Data: OleVariant); virtual;
  316.     procedure DoOnGetData(var Data: OleVariant);
  317.     procedure DoOnUpdateData(Delta: TPacketDataSet);
  318.     procedure LocateRecord(Source, Delta: TDataSet); virtual;
  319.     procedure UpdateRecord(Source, Delta: TDataSet; BlobsOnly, KeyOnly: Boolean); virtual;
  320.     procedure FetchDetails(Source, Delta: TDataSet); virtual;
  321.     function InternalRowRequest(const Row: OleVariant;
  322.       RequestType: TFetchOptions): OleVariant; override;
  323.     function InternalApplyUpdates(const Delta: OleVariant; MaxErrors: Integer;
  324.       out ErrorCount: Integer): OleVariant; override;
  325.     function InternalGetRecords(Count: Integer; out RecsOut: Integer;
  326.       Options: TGetRecordOptions; const CommandText: WideString;
  327.       var Params: OleVariant): OleVariant; override;
  328.   public
  329.     constructor Create(AOwner: TComponent); override;
  330.     destructor Destroy; override;
  331.     property Resolver: TCustomResolver read FResolver;
  332.     property Options: TProviderOptions read FProviderOptions
  333.       write FProviderOptions default [];
  334.     property UpdateMode: TUpdateMode read FUpdateMode write FUpdateMode default upWhereAll;
  335.     property OnDataRequest;
  336.     property OnGetData: TProviderDataEvent read FOnGetData write FOnGetData;
  337.     property OnUpdateData: TProviderDataEvent read FOnUpdateData write FOnUpdateData;
  338.     property OnUpdateError: TResolverErrorEvent read FOnUpdateError write FOnUpdateError;
  339.     property BeforeUpdateRecord: TBeforeUpdateRecordEvent read FBeforeUpdateRecord
  340.       write FBeforeUpdateRecord;
  341.     property AfterUpdateRecord: TAfterUpdateRecordEvent read FAfterUpdateRecord
  342.       write FAfterUpdateRecord;
  343.   end;
  345. { TDataSetProvider }
  347.   TGetTableNameEvent = procedure(Sender: TObject; DataSet: TDataSet; var TableName: string) of object;
  348.   TGetDSProps = procedure(Sender: TObject; DataSet: TDataSet;
  349.     out Properties: OleVariant) of object;
  351.   TDataSetProvider = class(TBaseProvider)
  352.   private
  353.     FDataSet: TDataSet;
  354.     FDataSetOpened: Boolean;
  355.     FDSWriter: TDataPacketWriter;
  356.     FGetDSProps: TGetDSProps;
  357.     FParams: TParams;
  358.     FResolveToDataSet: Boolean;
  359.     FRecordsSent: Integer;
  360.     FConstraints: Boolean;
  361.     FTransactionStarted: Boolean;
  362.     FGetTableName: TGetTableNameEvent;
  363.     function FindRecord(Source, Delta: TDataSet; UpdateMode: TUpdateMode): Boolean;
  364.     procedure Reset;
  365.     procedure SetCommandText(const CommandText: string);
  366.     procedure SetDataSet(ADataSet: TDataSet);
  367.     procedure SetResolveToDataSet(Value: Boolean);
  368.   protected
  369.     { SQL Resolver support methods }
  370.     procedure DoGetTableName(DataSet: TDataSet; var TableName: string); virtual;
  371.   protected
  372.     { Event overrides }
  373.     procedure DoBeforeGetRecords(Count: Integer; Options: Integer;
  374.       const CommandText: WideString; var Params, OwnerData: OleVariant); override;
  375.     procedure DoBeforeExecute(const CommandText: WideString; var Params,
  376.       OwnerData: OleVariant); override;
  377.   protected
  378.     procedure CheckDataSet;
  379.     procedure SetParams(Values: OleVariant);
  380.     procedure DoGetProviderAttributes(DataSet: TDataSet; List: TList); virtual;
  381.     function CreateResolver: TCustomResolver; override;
  382.     procedure CreateDataPacket(PacketOpts: TGetRecordOptions;
  383.       ProvOpts: TProviderOptions; var RecsOut: Integer; var Data: OleVariant); override;
  384.     function GetDataSetFromDelta(ATree: TUpdateTree; Source, Delta: TDataSet; Mode: TUpdateMode): TDataSet;
  385.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  386.     procedure LocateRecord(Source, Delta: TDataSet); override;
  387.     procedure UpdateRecord(Source, Delta: TDataSet; BlobsOnly, KeyOnly: Boolean); override;
  388.     procedure FetchDetails(Source, Delta: TDataSet); override;
  389.     function InternalRowRequest(const Row: OleVariant; Options: TFetchOptions): OleVariant; override;
  390.     function InternalGetParams(Types: TParamTypes = AllParamTypes): OleVariant; override;
  391.     procedure InternalExecute(const CommandText: WideString; var Params: OleVariant); override;
  392.     function InternalGetRecords(Count: Integer; out RecsOut: Integer;
  393.       Options: TGetRecordOptions; const CommandText: WideString;
  394.       var Params: OleVariant): OleVariant; override;
  395.     function InternalApplyUpdates(const Delta: OleVariant; MaxErrors: Integer;
  396.       out ErrorCount: Integer): OleVariant; override;
  397.     property Params: TParams read FParams;
  398.   public
  399.     constructor Create(AOwner: TComponent); override;
  400.     destructor Destroy; override;
  401.   published
  402.     property DataSet: TDataSet read FDataSet write SetDataSet;
  403.     property Constraints: Boolean read FConstraints write FConstraints default True;
  404.     property ResolveToDataSet: Boolean read FResolveToDataSet write SetResolveToDataSet default False;
  405.     property Exported;
  406.     property Options;
  407.     property UpdateMode;
  408.     property OnDataRequest;
  409.     property OnGetData;
  410.     property OnUpdateData;
  411.     property OnUpdateError;
  412.     property AfterUpdateRecord;
  413.     property BeforeUpdateRecord;
  414.     property BeforeApplyUpdates;
  415.     property AfterApplyUpdates;
  416.     property BeforeGetRecords;
  417.     property AfterGetRecords;
  418.     property BeforeRowRequest;
  419.     property AfterRowRequest;
  420.     property BeforeExecute;
  421.     property AfterExecute;
  422.     property BeforeGetParams;
  423.     property AfterGetParams;
  424.     property OnGetTableName: TGetTableNameEvent read FGetTableName write FGetTableName;
  425.     property OnGetDataSetProperties: TGetDSProps read FGetDSProps write FGetDSProps;
  426.   end;
  428. { TProvider - deprecated }
  430.   TProvider = class(TDataSetProvider)
  431.   end;
  433. { TUpdateTree }
  435.   TUpdateTree = class(TObject)
  436.   private
  437.     FDeltaDS: TPacketDataSet;
  438.     FErrorDS: TPacketDataSet;
  439.     FOpened: Boolean;
  440.     FSourceDS: TDataSet;
  441.     FParent: TUpdateTree;
  442.     FDetails: TList;
  443.     FData: Pointer;
  444.     FResolver: TCustomResolver;
  445.     FName: string;
  446.     function GetDetailCount: Integer;
  447.     function GetDetail(Index: Integer): TUpdateTree;
  448.     function GetErrorDS: TPacketDataSet;
  449.     function GetHasErrors: Boolean;
  450.     function GetIsNested: Boolean;
  451.     function GetTree(const AName: string): TUpdateTree;
  452.   protected
  453.     procedure Clear;
  454.     function DoUpdates: Boolean;
  455.     procedure RefreshData(Options: TFetchOptions);
  456.     procedure InitErrorPacket(E: EUpdateError; Response: TResolverResponse);
  457.     procedure InitData(ASource: TDataSet);
  458.     procedure InitDelta(const ADelta: OleVariant); overload;
  459.     procedure InitDelta(ADelta: TPacketDataSet); overload;
  460.     property Data: Pointer read FData write FData;
  461.     property Delta: TPacketDataSet read FDeltaDS;
  462.     property DetailCount: Integer read GetDetailCount;
  463.     property Details[Index: Integer]: TUpdateTree read GetDetail;
  464.     property ErrorDS: TPacketDataSet read GetErrorDS;
  465.     property HasErrors: Boolean read GetHasErrors;
  466.     property Name: string read FName write FName;
  467.     property Parent: TUpdateTree read FParent;
  468.     property Source: TDataSet read FSourceDS;
  469.     property IsNested: Boolean read GetIsNested;
  470.   public
  471.     constructor Create(AParent: TUpdateTree; AResolver: TCustomResolver);
  472.     destructor Destroy; override;
  473.   end;
  475. { TCustomResolver }
  477.   TCustomResolver = class(TComponent)
  478.   private
  479.     FProvider: TBaseProvider;
  480.     FPrevResponse: TResolverResponse;
  481.     FErrorCount: Integer;
  482.     FMaxErrors: Integer;
  483.     FUpdateTree: TUpdateTree;
  484.   protected
  485.     property Provider: TBaseProvider read FProvider;
  486.     function HandleUpdateError(Tree: TUpdateTree; E: EUpdateError;
  487.       var MaxErrors, ErrorCount: Integer): Boolean;
  488.     procedure LogUpdateRecord(Tree: TUpdateTree);
  489.     procedure LogUpdateError(Tree: TUpdateTree; E: EUpdateError;
  490.       Response: TResolverResponse);
  491.     procedure InitKeyFields(Tree: TUpdateTree; ADelta: TPacketDataSet);
  492.     procedure InternalBeforeResolve(Tree: TUpdateTree); virtual;
  493.     function InternalUpdateRecord(Tree: TUpdateTree): Boolean;
  494.     procedure BeginUpdate; virtual;
  495.     procedure EndUpdate; virtual;
  496.     procedure InitTreeData(Tree: TUpdateTree); virtual;
  497.     procedure FreeTreeData(Tree: TUpdateTree); virtual;
  498.     procedure InitializeConflictBuffer(Tree: TUpdateTree); virtual; abstract;
  499.     procedure DoUpdate(Tree: TUpdateTree); virtual; abstract;
  500.     procedure DoDelete(Tree: TUpdateTree); virtual; abstract;
  501.     procedure DoInsert(Tree: TUpdateTree); virtual; abstract;
  502.     function RowRequest(Row: OleVariant; Options: TFetchOptions): OleVariant; virtual;
  503.     function ApplyUpdates(const Delta: OleVariant; MaxErrors: Integer;
  504.       out ErrorCount: Integer): OleVariant; virtual;
  505.   public
  506.     constructor Create(AProvider: TBaseProvider); reintroduce;
  507.     destructor Destroy; override;
  508.   end;
  510. { TDataSetResolver }
  512.   TDataSetResolver = class(TCustomResolver)
  513.   private
  514.     FBookmark: TBookmarkStr;
  515.     FOpened: Boolean;
  516.     function GetProvider: TDataSetProvider;
  517.     procedure PutRecord(Tree: TUpdateTree);
  518.   protected
  519.     property Provider: TDataSetProvider read GetProvider;
  520.     procedure BeginUpdate; override;
  521.     procedure DoUpdate(Tree: TUpdateTree); override;
  522.     procedure DoDelete(Tree: TUpdateTree); override;
  523.     procedure DoInsert(Tree: TUpdateTree); override;
  524.     procedure EndUpdate; override;
  525.     procedure InternalBeforeResolve(Tree: TUpdateTree); override;
  526.     procedure InitializeConflictBuffer(Tree: TUpdateTree); override;
  527.   public
  528.     constructor Create(AProvider: TDataSetProvider); reintroduce;
  529.   end;
  531. { TSQLResolver }
  533.   TSQLResolver = class(TCustomResolver)
  534.   private
  535.     FSQL: TStringList;
  536.     FParams: TParams;
  537.     function GetProvider: TDataSetProvider;
  538.     procedure GenWhereSQL(Tree: TUpdateTree; SQL: TStrings; Params: TParams;
  539.       GenUpdateMode: TUpdateMode; Alias: string);
  540.     procedure GenInsertSQL(Tree: TUpdateTree; SQL: TStrings; Params: TParams);
  541.     procedure GenDeleteSQL(Tree: TUpdateTree; SQL: TStrings; Params: TParams;
  542.       Alias: string);
  543.     procedure GenUpdateSQL(Tree: TUpdateTree; SQL: TStrings; Params: TParams;
  544.       Alias: string);
  545.     procedure GenSelectSQL(Tree: TUpdateTree; SQL: TStrings; Params: TParams;
  546.       Alias: string; Mode: TUpdateMode = upWhereKeyOnly);
  547.     function UseFieldInUpdate(Field: TField): Boolean;
  548.     function UseFieldInWhere(Field: TField; Mode: TUpdateMode): Boolean;
  549.     procedure InternalDoUpdate(Tree: TUpdateTree; UpdateKind: TUpdateKind);
  550.   protected
  551.     property Provider: TDataSetProvider read GetProvider;
  552.     procedure InitializeConflictBuffer(Tree: TUpdateTree); override;
  553.     procedure DoExecSQL(SQL: TStringList; Params: TParams); virtual;
  554.     procedure DoGetValues(SQL: TStringList; Params: TParams;
  555.       DataSet: TDataSet); virtual;
  556.     procedure InitTreeData(Tree: TUpdateTree); override;
  557.     procedure FreeTreeData(Tree: TUpdateTree); override;
  558.     procedure DoUpdate(Tree: TUpdateTree); override;
  559.     procedure DoDelete(Tree: TUpdateTree); override;
  560.     procedure DoInsert(Tree: TUpdateTree); override;
  561.   public
  562.     constructor Create(AProvider: TDataSetProvider); reintroduce;
  563.     destructor Destroy; override;
  564.   end;
  566. { TLocalAppServer }
  568.   TLocalAppServer = class(TInterfacedObject, IAppServer{$IFDEF MSWINDOWS}, ISupportErrorInfo{$ENDIF})
  569.   private
  570.     FProvider: TCustomProvider;
  571.     FProviderCreated: Boolean;
  572.   protected
  573.     { IDispatch }
  574.     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
  575.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
  576.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  577.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  578.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  579.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  580.     { IAppServer }
  581.     function AS_ApplyUpdates(const ProviderName: WideString; Delta: OleVariant; MaxErrors: Integer;
  582.                              out ErrorCount: Integer; var OwnerData: OleVariant): OleVariant; safecall;
  583.     function AS_GetRecords(const ProviderName: WideString; Count: Integer; out RecsOut: Integer;
  584.                            Options: Integer; const CommandText: WideString;
  585.                            var Params: OleVariant; var OwnerData: OleVariant): OleVariant; safecall;
  586.     function AS_DataRequest(const ProviderName: WideString; Data: OleVariant): OleVariant; safecall;
  587.     function AS_GetProviderNames: OleVariant; safecall;
  588.     function AS_GetParams(const ProviderName: WideString; var OwnerData: OleVariant): OleVariant; safecall;
  589.     function AS_RowRequest(const ProviderName: WideString; Row: OleVariant; RequestType: Integer;
  590.                            var OwnerData: OleVariant): OleVariant; safecall;
  591.     procedure AS_Execute(const ProviderName: WideString;  const CommandText: WideString;
  592.                          var Params, OwnerData: OleVariant); safecall;
  593.     { ISupportErrorInfo }
  594.     function InterfaceSupportsErrorInfo(const iid: TGUID): HResult; stdcall;
  595.   public
  596.     constructor Create(AProvider: TCustomProvider); overload;
  597.     constructor Create(ADataset: TDataset); overload;
  598.     destructor Destroy; override;
  599.     function SafeCallException(ExceptObject: TObject;
  600.       ExceptAddr: Pointer): HResult; override;
  601.   end;
  603.   IProviderContainer = interface
  604.   ['{EEE9FFD4-752F-11D4-80DD-00C04F6BB88C}']
  605.     procedure RegisterProvider(Prov: TCustomProvider);
  606.     procedure UnRegisterProvider(Prov: TCustomProvider);
  607.   end;
  609. { Utility functions }
  611. function GetObjectProperty(Instance: TPersistent; const PropName: string): TObject;
  612. function GetStringProperty(Instance: TPersistent; const PropName: string): string;
  613. function VarArrayFromStrings(Strings: TStrings): Variant;
  615. implementation
  616. {$IFDEF MSWINDOWS}
  617. uses MidConst, DBConsts, DBCommon, TypInfo, DataBkr, ComObj, FMTBcd,mtx,StrUtils;
  618. {$ENDIF}
  619. {$IFDEF LINUX}
  620. uses MidConst, DBConsts, DBCommon, TypInfo, FMTBcd, Types;
  621. {$ENDIF}
  623. const
  624.   DEFBUFSIZE = 8192;  { Default size for field data buffer }
  625.   DefAlias   = 'A';
  626.   NestAlias  = 'B';
  627.   tagSERVERCALC = 1;
  629.   ADOID_MSSQLSERVER ='SQLOLEDB.1';                 //ADO MS SQLSERVER 标志
  630.   ADOID_MSACCESSS   ='Microsoft.Jet.OLEDB.4.0';    //ADO MS ACCESS    标志
  631.   ADOID_ORACLE      ='MSDAORA.1';                  //ADO ORCALE       标志
  633.   PacketTypeMap: array [TFieldType] of Integer =
  634.     (dsfldUNKNOWN, dsfldZSTRING, dsfldINT, dsfldINT, dsfldINT, dsfldBOOL,
  635.      dsfldFLOATIEEE, dsfldFLOATIEEE, dsfldBCD, dsfldDATE, dsfldTIME,
  636.      dsfldTIMESTAMP, dsfldBYTES, dsfldBYTES, dsfldINT, dsfldBYTES, dsfldBYTES,
  637.      dsfldBYTES, dsfldBYTES, dsfldBYTES, dsfldBYTES, dsfldBYTES, dsfldUNKNOWN,
  638.      dsfldZSTRING, dsfldUNICODE, dsfldINT, dsfldADT, dsfldARRAY, dsfldEMBEDDEDTBL,
  639.      dsfldEMBEDDEDTBL, dsfldBYTES, dsfldBYTES, dsfldUNKNOWN, dsfldUNKNOWN,
  640.      dsfldUNKNOWN, dsfldZSTRING, dsfldDATETIME, dsFLDFMTBCD);
  642.   ExtraFieldProps: array [0..10] of string = ('Alignment', 'DisplayLabel',
  643.     'DisplayWidth', 'Visible', 'EditMask', 'DisplayFormat', 'EditFormat',
  644.     'MinValue', 'MaxValue', 'currency', 'DisplayValues');
  646. { Utility functions }
  648. function GetObjectProperty(Instance: TPersistent; const PropName: string): TObject;
  649. var
  650.   PropInfo: PPropInfo;
  651. begin
  652.   Result := nil;
  653.   PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, PropName);
  654.   if (PropInfo <> nil) and (PropInfo^.PropType^.Kind = tkClass) then
  655.     Result := TObject(GetOrdProp(Instance, PropInfo));
  656. end;
  658. function GetStringProperty(Instance: TPersistent; const PropName: string): string;
  659. var
  660.   PropInfo: PPropInfo;
  661. begin
  662.   Result := '';
  663.   PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, PropName);
  664.   if (PropInfo <> nil) and (PropInfo^.PropType^.Kind in [tkString, tkLString, tkWString]) then
  665.     Result := GetStrProp(Instance, PropInfo);
  666. end;
  668. function VarArrayFromStrings(Strings: TStrings): Variant;
  669. var
  670.   I: Integer;
  671. begin
  672.   Result := Null;
  673.   if Strings.Count > 0 then
  674.   begin
  675.     Result := VarArrayCreate([0, Strings.Count - 1], varOleStr);
  676.     for I := 0 to Strings.Count - 1 do Result[I] := WideString(Strings[I]);
  677.   end;
  678. end;
  680. { EDSWriter }
  682. constructor EDSWriter.Create(ErrMsg: string; Status: Integer);
  683. begin
  684.   FErrorCode := Status;
  685.   inherited Create(ErrMsg);
  686. end;
  688. { TCustomPacketWriter }
  690. constructor TCustomPacketWriter.Create;
  691. begin
  692.   SetLength(FBuffer, DEFBUFSIZE);
  693. end;
  695. destructor TCustomPacketWriter.Destroy;
  696. begin
  697.   FIDSWriter := nil;
  698.   FBuffer := nil;
  699.   inherited Destroy;
  700. end;
  702. procedure TCustomPacketWriter.Check(Status: Integer);
  703. var
  704.   ErrMsg: array[0..2048] of Char;
  705. begin
  706.   if Status <> 0 then
  707.   begin
  708.     FIDSWriter.GetErrorString(Status, ErrMsg);
  709.     raise EDSWriter.Create(ErrMsg, Status);
  710.   end;
  711. end;
  713. procedure TCustomPacketWriter.AddAttribute(Area: TPcktAttrArea; const ParamName: string;
  714.   const Value: OleVariant; IncludeInDelta: Boolean);
  715. const
  716.   ParamTypeMap: array[varSmallInt..varByte] of Integer =
  717.     ( dsfldINT, dsfldINT, dsfldFLOATIEEE, dsfldFLOATIEEE, dsfldBCD,
  718.       dsfldFLOATIEEE, dsfldZSTRING, 0, 0, dsfldBOOL, 0, 0, 0, 0, 0, dsfldINT);
  719.   ParamTypeSize: array[varSmallInt..varByte] of Integer =
  720.     ( SizeOf(SmallInt), SizeOf(Integer), SizeOf(Single), SizeOf(Double),
  721.       SizeOf(Currency), SizeOf(TDateTime), 0, 0, 0, SizeOf(WordBool), 0, 0, 0,
  722.       0, 0, SizeOf(Byte));
  723. var
  724.   ParamType, ParamLen, ElemSize, ElemCount: DWord;
  725.   P: Pointer;
  726.   DateRec: TDateTimeRec;
  727.   TimeStamp: TTimeStamp;
  728. begin
  729.   if ((VarType(Value) and varTypeMask) in [varSmallInt, varInteger, varSingle,
  730.       varDouble, varCurrency, varDate, varOleStr, varBoolean, varByte, varNull]) then
  731.   begin
  732.     ParamType := ParamTypeMap[VarType(Value) and varTypeMask];
  733.     ParamLen := ParamTypeSize[VarType(Value) and varTypeMask];
  734.     if ParamType = dsfldZSTRING then
  735.     begin
  736.       ParamType := (dsfldZSTRING shl dsSizeBitsLen) or dsVaryingFldType or SizeOf(Word);
  737.       ParamLen := Length(Value) + 1;
  738.       PWord(FBuffer)^ := ParamLen;
  739.       Inc(ParamLen, SizeOf(Word));
  740.       StrPLCopy(@FBuffer[SizeOf(Word)], Value, Length(FBuffer) - SizeOf(Word) - 1);
  741.     end else
  742.     if ParamType = dsfldTIMESTAMP then
  743.     begin
  744.       TimeStamp := DateTimeToTimeStamp(Value);
  745.       DateRec.DateTime := TimeStampToMSecs(TimeStamp);
  746.       Move(DateRec, PChar(FBuffer)^, ParamLen);
  747.       ParamType := ParamType shl dsSizeBitsLen or SizeOf(TDateTimeRec);
  748.     end else
  749.     if ParamType = dsfldDATETIME then
  750.     begin
  751.       P := @TVarData(Value).VPointer;
  752.       Move(P^, PByte(FBuffer)^, ParamLen);
  753.       ParamType := (ParamType shl dsSizeBitsLen) or SizeOf(TSQLTimeStamp);
  754.     end else
  755.     if VarIsArray(Value) then
  756.     begin
  757.       if ParamLen = 0 then
  758.         raise EDSWriter.Create(SInvalidOptParamType, 0);
  759.       ElemCount := VarArrayHighBound(Value, 1) + 1;
  760.       ElemSize := ParamLen;
  761.       if ParamType in [dsfldINT, dsfldUINT] then
  762.         ParamType := (dsfldUINT shl dsSizeBitsLen) or dsArrayFldType or ElemSize
  763.       else
  764.         ParamType := (dsfldBYTES shl dsSizeBitsLen) or dsArrayFldType or ElemSize;
  765.       PInteger(FBuffer)^ := ElemCount;
  766.       ParamLen := ElemCount * ElemSize;
  767.       P := VarArrayLock(Value);
  768.       try
  769.         Move(P^, FBuffer[SizeOf(Integer)], ParamLen);
  770.         Inc(ParamLen, SizeOf(Integer));
  771.       finally
  772.         VarArrayUnlock(Value);
  773.       end;
  774.     end else
  775.     begin
  776.       if (VarType(Value) and varByRef) = varByRef then
  777.         P := TVarData(Value).VPointer else
  778.         P := @TVarData(Value).VPointer;
  779.       Move(P^, PByte(FBuffer)^, ParamLen);
  780.       ParamType := ParamType shl dsSizeBitsLen or ParamLen;
  781.     end;
  782.     if IncludeInDelta then
  783.       ParamType := ParamType or dsIncInDelta;
  784.     Check(FIDSWriter.AddAttribute(Area, PChar(ParamName), ParamType, ParamLen, PByte(FBuffer)));
  785.   end else
  786.     raise EDSWriter.Create(SInvalidOptParamType, 0);
  787. end;
  789. { TDataPacketWriter }
  791. destructor TDataPacketWriter.Destroy;
  792. begin
  793.   FreeInfoRecords(FPutFieldInfo);
  794.   FPutFieldInfo := nil;
  795.   inherited Destroy;
  796. end;
  798. procedure TDataPacketWriter.FreeInfoRecords(var Info: TInfoArray);
  799. var
  800.   i: Integer;
  801. begin
  802.   for i := 0 to High(Info) do
  803.     if Info[i].FieldInfos <> nil then
  804.     begin
  805.       FreeInfoRecords(TInfoArray(Info[i].FieldInfos));
  806.       TInfoArray(Info[i].FieldInfos) := nil;
  807.     end;
  808. end;
  810. { Writing data }
  812. procedure TDataPacketWriter.PutBlobField(Info: PPutFieldInfo);
  813. begin
  814.   if not (poFetchBlobsOnDemand in Options) then
  815.   begin
  816.     Info.Size := Info.DataSet.GetBlobFieldData(Info.FieldNo, TBlobByteData(FBuffer));
  817.     if Info.Size <> 0 then
  818.     begin
  819.       if Length(FBuffer) <= Info.Size then
  820.         SetLength(FBuffer, Info.Size + 1);
  821.       FBuffer[Info.Size] := 0;
  822.       if TBlobField(Info.Field).Transliterate then
  823.         Info.Size := Info.DataSet.Translate(PChar(FBuffer), PChar(FBuffer), False);
  824.       FIDSWriter.PutField(fldIsChanged, Info.Size, PByte(FBuffer))
  825.     end else
  826.       FIDSWriter.PutField(fldIsNull, 0, nil);
  827.   end else
  828.     FIDSWriter.PutField(fldIsChanged, dsDELAYEDBIT or 1, @Info.Size);
  829. end;
  831. procedure TDataPacketWriter.PutCalcField(Info: PPutFieldInfo);
  832. begin
  833.   if Info.DataSet.GetFieldData(Info.Field, FBuffer) then
  834.   begin
  835.     if (Info.Field is TStringField) then
  836.       if TStringField(Info.Field).Transliterate then
  837.         Info.Size := Info.DataSet.Translate(PChar(FBuffer), PChar(FBuffer), False) else
  838.         Info.Size := StrLen(PChar(FBuffer));
  839.     FIDSWriter.PutField(fldIsChanged, Info.Size, PByte(FBuffer));
  840.   end else
  841.     FIDSWriter.PutField(fldIsNull, 0, nil);
  842. end;
  844. procedure TDataPacketWriter.PutField(Info: PPutFieldInfo);
  845. begin
  846.   if Info.DataSet.GetFieldData(Info.FieldNo, FBuffer) then
  847.     FIDSWriter.PutField(fldIsChanged, Info.Size, PByte(FBuffer)) else
  848.     FIDSWriter.PutField(fldIsNull, 0, nil);
  849. end;
  851. procedure TDataPacketWriter.PutStringField(Info: PPutFieldInfo);
  852. begin
  853.   if Length(FBuffer) <= Info.Size then
  854.     SetLength(FBuffer, Info.Size + 1);
  855.   if Info.DataSet.GetFieldData(Info.FieldNo, FBuffer) then
  856.   begin
  857.     if TStringField(Info.Field).Transliterate then
  858.       Info.Size := Info.DataSet.Translate(PChar(FBuffer), PChar(FBuffer), False) else
  859.       Info.Size := StrLen(PChar(FBuffer));
  860.     FIDSWriter.PutField(fldIsChanged, Info.Size, PByte(FBuffer));
  861.   end else
  862.     FIDSWriter.PutField(fldIsNull, 0, nil);
  863. end;
  865. procedure TDataPacketWriter.PutWideStringField(Info: PPutFieldInfo);
  866. var
  867.   W: WideString;
  868. begin
  869.   if Info.DataSet.GetFieldData(Info.field, @W, False) then
  870.   begin
  871.     Info.Size := Length(W);
  872.     FIDSWriter.PutField(fldIsChanged, Info.Size * 2, PByte(W));
  873.   end else
  874.     FIDSWriter.PutField(fldIsNull, 0, nil);
  875. end;
  877. procedure TDataPacketWriter.PutVarBytesField(Info: PPutFieldInfo);
  878. begin
  879.   if Info.DataSet.GetFieldData(Info.FieldNo, FBuffer) then
  880.     FIDSWriter.PutField(fldIsChanged, PWord(FBuffer)^, @FBuffer[SizeOf(Word)]) else
  881.     FIDSWriter.PutField(fldIsNull, 0, nil);
  882. end;
  884. procedure TDataPacketWriter.PutADTField(Info: PPutFieldInfo);
  885. var
  886.   i: Integer;
  887. begin
  888.   if Info.Field.IsNull then
  889.     FIDSWriter.PutField(fldIsNull, 0, nil) else
  890.     FIDSWriter.PutField(fldIsChanged, 0, nil);
  891.   for i := 0 to High(TInfoArray(Info.FieldInfos)) do
  892.     with TInfoArray(Info^.FieldInfos)[i] do
  893.       PutProc(@TInfoArray(Info.FieldInfos)[i]);
  894. end;
  896. procedure TDataPacketWriter.PutArrayField(Info: PPutFieldInfo);
  898.   procedure RefreshInfos(Src: TField; Dest: PPutFieldInfo);
  899.   var
  900.     i: Integer;
  901.   begin
  902.     with Dest^ do
  903.     begin
  904.       Field := Src;
  905.       FieldNo := Src.FieldNo;
  906.       if (FieldInfos <> nil) then { Must be an ADT }
  907.       begin
  908.         if not (Src is TADTField) then
  909.           raise EDSWriter.CreateFmt(SArrayElementError,[Src.ClassName]);
  910.         with (Src as TADTField) do
  911.           for i := 0 to FieldCount - 1 do
  912.             RefreshInfos(Fields[i], @TInfoArray(FieldInfos)[i]);
  913.       end;
  914.     end;
  915.   end;
  917. var
  918.   i: Integer;
  919. begin
  920.   if Info.Field.IsNull then
  921.     FIDSWriter.PutField(fldIsNull, 0, nil) else
  922.     FIDSWriter.PutField(fldIsChanged, 0, nil);
  923.   for i := 0 to TArrayField(Info.Field).FieldCount - 1 do
  924.     with TInfoArray(Info^.FieldInfos)[0] do
  925.     begin
  926.       RefreshInfos(TArrayField(Info.Field).Fields[i], @TInfoArray(Info.FieldInfos)[0]);
  927.       PutProc(@TInfoArray(Info.FieldInfos)[0]);
  928.     end;
  929. end;
  931. procedure TDataPacketWriter.PutDataSetField(Info: PPutFieldInfo);
  932. var
  933.   Count: DWord;
  934.   DataSet: TDataSet;
  935. begin
  936.   if Info.Field <> nil then
  937.   begin
  938.     if Info.Field.IsNull then
  939.     begin
  940.       FIDSWriter.PutField(fldIsNull, 0, nil);
  941.       Exit;
  942.     end;
  943.     DataSet := TDataSetField(Info.Field).NestedDataSet;
  944.   end else
  945.     DataSet := Info.DataSet;
  946.   if (poFetchDetailsOnDemand in Options) then
  947.     Count := dsDELAYEDBIT else
  948.     Count := DWord(-1);
  949.   FIDSWriter.PutField(fldIsChanged, SizeOf(Count), @Count);
  950.   if (not (poFetchDetailsOnDemand in Options)) and (Count = DWord(-1)) then
  951.   begin
  952.     DataSet.UpdateCursorPos;
  953.     DataSet.First;
  954.     DataSet.BlockReadSize := MaxInt;
  955.     try
  956.       WriteDataSet(DataSet, TInfoArray(Info.FieldInfos), -1);
  957.       FIDSWriter.EndOfNestedRows;
  958.     finally
  959.       DataSet.BlockReadSize := 0;
  960.     end;
  961.   end;
  962. end;
  964. function TDataPacketWriter.WriteDataSet(DataSet: TDataSet; var Info: TInfoArray;
  965.   RecsOut: Integer): Integer;
  966. const
  967.   B: Byte = 0;
  968. var
  969.   i: Integer;
  970.   ChildOpened: Boolean;
  972.   function OpenCloseDetails(Info: TInfoArray; ActiveState: Boolean): Boolean;
  973.   var
  974.     I: Integer;
  975.   begin
  976.     Result := False;
  977.     for I := 0 to High(Info) do
  978.     begin
  979.       if Info[I].IsDetail and (Info[I].DataSet.Active <> ActiveState) then
  980.       begin
  981.         Info[I].DataSet.Active := ActiveState;
  982.         Info[I].Opened := ActiveState;
  983.         Result := True;
  984.       end;
  985.     end;
  986.   end;
  988. begin
  989.   Result := 0;
  990.   if RecsOut = AllRecords then
  991.     RecsOut := High(Integer);
  992.   if DataSet.DefaultFields then
  993.     RefreshPutProcs(DataSet, Info);
  994.   ChildOpened := OpenCloseDetails(Info, True);
  995.   while (not DataSet.EOF) and (Result < RecsOut) do
  996.   begin
  997.     FIDSWriter.PutField(fldIsChanged, 1, @B);
  998.     for i := 0 to High(Info) do
  999.       Info[i].PutProc(@Info[i]);
  1000.     Inc(Result);
  1001.     if Result < RecsOut then
  1002.       DataSet.Next;
  1003.   end;
  1004.   if ChildOpened then
  1005.     OpenCloseDetails(Info, False);
  1006. end;
  1008. { Writing meta data }
  1010. procedure TDataPacketWriter.AddDataSetAttributes(DataSet: TDataSet);
  1011. var
  1012.   i: Integer;
  1013.   List: TList;
  1014. begin
  1015.   if Assigned(FOnGetParams) then
  1016.   begin
  1017.     List := TList.Create;
  1018.     try
  1019.       FOnGetParams(DataSet, List);
  1020.       for i := 0 to List.Count - 1 do
  1021.         with PPacketAttribute(List[i])^ do
  1022.         begin
  1023.           AddAttribute(pcktAttrArea, Name, Value, IncludeInDelta);
  1024.           Dispose(PPacketAttribute(List[i]));
  1025.         end;
  1026.     finally
  1027.       List.Free;
  1028.     end;
  1029.   end;
  1030. end;
  1032. function TDataPacketWriter.GetFieldIdx(const FieldName: string; const Info: TInfoArray): Integer;
  1033. var
  1034.   i: Integer;
  1035. begin
  1036.   Result := -1;
  1037.   for i := 0 to High(Info) do
  1038.     if (Info[i].Field <> nil) and (Info[i].Field.FieldName = FieldName) then
  1039.     begin
  1040.       Result := Info[i].LocalFieldIndex;
  1041.       break;
  1042.     end;
  1043. end;
  1045. type
  1046.   TPropWriter = class(TWriter);
  1048. procedure TDataPacketWriter.AddExtraFieldProps(Field: TField);
  1050.   procedure WriteProp(Instance: TPersistent; const PropName: string;
  1051.     Writer: TPropWriter);
  1052.   var
  1053.     PropInfo: PPropInfo;
  1054.   begin
  1055.     PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, PropName);
  1056.     if (PropInfo <> nil) and IsStoredProp(Instance, PropInfo) then
  1057.       Writer.WriteProperty(Instance, PropInfo);
  1058.   end;
  1060. var
  1061.   Writer: TPropWriter;
  1062.   Stream: TMemoryStream;
  1063.   i: Integer;
  1064.   Attr: Cardinal;
  1065. begin
  1066.   Stream := TMemoryStream.Create;
  1067.   try
  1068.     Writer := TPropWriter.Create(Stream, 1024);
  1069.     try
  1070.       Writer.WriteListBegin;
  1071.       for i := 0 to High(ExtraFieldProps) do
  1072.         WriteProp(Field, ExtraFieldProps[i], Writer);
  1073.       Writer.WriteListEnd;
  1074.       Writer.FlushBuffer;
  1075.       if Stream.Size > 2 then
  1076.       begin
  1077.         Attr := (dsfldBYTES shl dsSizeBitsLen) or dsArrayFldType or SizeOf(Byte) or dsIncInDelta;
  1078.         PInteger(FBuffer)^ := Stream.Size;
  1079.         Move(Stream.Memory^, FBuffer[SizeOf(Integer)], Stream.Size);
  1080.         Check(FIDSWriter.AddAttribute(fldAttrArea, szFIELDPROPS, Attr,
  1081.           Stream.Size + SizeOf(Integer), FBuffer));
  1082.       end;
  1083.     finally
  1084.       Writer.Free;
  1085.     end;
  1086.   finally
  1087.     Stream.Free;
  1088.   end;
  1089. end;
  1091. procedure TDataPacketWriter.AddColumn(const Info: TPutFieldInfo);
  1093.   procedure AddFieldDesc(const FldName: string; FldType, Attributes: Integer);
  1094.   var
  1095.     FldDesc: TDSDataPacketFldDesc;
  1096.   begin
  1097.     if Length(FldName) >= SizeOf(FldDesc.szFieldName) then
  1098.       raise EDSWriter.CreateFmt(SFieldNameTooLong,[SizeOf(FldDesc.szFieldName) - 1]);
  1099.     FillChar(FldDesc, SizeOf(FldDesc), 0);
  1100.     StrLCopy(FldDesc.szFieldName, PChar(FldName), SizeOf(FldDesc.szFieldName) - 1);
  1101.     FldDesc.iFieldType := FldType;
  1102.     FldDesc.iAttributes := Attributes;
  1103.     Check(FIDSWriter.AddColumnDesc(FldDesc));
  1104.   end;
  1106.   function ComputeInfoCount(Info: TInfoArray): Integer;
  1107.   var
  1108.     i: Integer;
  1109.   begin
  1110.     Result := Length(Info);
  1111.     for i := 0 to High(Info) do
  1112.       if Info[i].FieldInfos <> nil then
  1113.         Inc(Result, ComputeInfoCount(Info[i].FieldInfos));
  1114.   end;
  1116.   procedure AddMinMax(AField: TField);
  1117.   begin
  1118.     case AField.DataType of
  1119.       ftInteger, ftSmallInt:    
  1120.         if (TIntegerField(AField).MinValue <> 0) or 
  1121.            (TIntegerField(AField).MaxValue <> 0)  then
  1122.            begin
  1123.              AddAttribute(fldAttrArea, szMINVALUE, 
  1124.                            TIntegerField(AField).MinValue, False);
  1125.              AddAttribute(fldAttrArea, szMAXVALUE, 
  1126.                           TIntegerField(AField).MaxValue, False);
  1127.            end;
  1128.       ftCurrency, ftFloat:
  1129.         if (TFloatField(AField).MinValue <> 0 ) or 
  1130.            (TFloatField(AField).MaxValue <> 0 ) then
  1131.            begin
  1132.              AddAttribute(fldAttrArea, szMINVALUE, 
  1133.                            TFloatField(AField).MinValue, False);
  1134.              AddAttribute(fldAttrArea, szMAXVALUE, 
  1135.                           TFloatField(AField).MaxValue, False);
  1136.            end;
  1137.       ftBCD:
  1138.         if (TBCDField(AField).MinValue <> 0 ) or 
  1139.            (TIntegerField(AField).MaxValue <> 0 ) then
  1140.            begin
  1141.              AddAttribute(fldAttrArea, szMINVALUE, 
  1142.                            TBCDField(AField).MinValue, False);
  1143.              AddAttribute(fldAttrArea, szMAXVALUE, 
  1144.                           TBCDField(AField).MaxValue, False);
  1145.            end;
  1146.       ftFMTBcd:
  1147.         if (TFMTBcdField(AField).MaxValue <> '') or
  1148.            (TFMTBcdField(AField).MinValue <> '') then
  1149.            begin
  1150.              AddAttribute(fldAttrArea, szMINVALUE, 
  1151.                     VarFMTBcdCreate(TFMTBCDField(AField).MinValue, TFMTBCDField(AField).Precision, TFMTBCDField(AField).Size), False);
  1152.              AddAttribute(fldAttrArea, szMAXVALUE, 
  1153.                     VarFMTBcdCreate(TFMTBCDField(AField).MaxValue, TFMTBCDField(AField).Precision, TFMTBCDField(AField).Size), False);
  1154.            end;
  1155.     end;
  1156.   end;
  1158. var
  1159.   FldType, Prec, Attr, i, Width: Integer;
  1160.   TempStr: string;
  1161. begin
  1162.   if Info.IsDetail and (Info.Field = nil) then
  1163.   begin
  1164.     FldType := (dsfldEMBEDDEDTBL shl dsSizeBitsLen) or
  1165.       ComputeInfoCount(Info.FieldInfos) or dsPseudoFldType;
  1166.     AddFieldDesc(Info.DataSet.Name, FldType, 0);
  1167.     WriteMetaData(Info.DataSet, TInfoArray(Info.FieldInfos));
  1168.   end else
  1169.   begin
  1170.     Width := 0;
  1171.     Attr := 0;
  1172.     if Info.Field.ReadOnly or (Info.Field.FieldKind <> fkData) then Attr := Attr or fldAttrREADONLY;
  1173.     if Info.Field.Required and (Info.Field.DataType <> ftAutoInc) then Attr := Attr or fldAttrREQUIRED;
  1174.     if (pfHidden in Info.Field.ProviderFlags) then Attr := Attr or fldAttrHIDDEN or fldAttrREADONLY;
  1175.     FldType := PacketTypeMap[Info.Field.DataType];
  1176.     case Info.Field.DataType of
  1177.       ftTimeStamp:
  1178.         FldType := (FldType shl dsSizeBitsLen) or sizeof(TSQLTimeStamp);
  1179.       ftString, ftFixedChar, ftVarBytes, ftGUID, ftWideString:
  1180.       begin
  1181.         FldType := FldType shl dsSizeBitsLen or dsVaryingFldType;
  1182.         if Info.Size < 255 then
  1183.           FldType := FldType or SizeOf(Byte) else
  1184.           FldType := FldType or SizeOf(Word);
  1185.         Width := Info.Size;
  1186.       end;
  1187.       ftBCD:
  1188.       begin
  1189.         if TBCDField(Info.Field).Precision = 0 then
  1190.           Width := 32 else
  1191.           Width := TBCDField(Info.Field).Precision;
  1192.         Prec := Width shr 1;
  1193.         Inc(Prec, Prec and 1);  { Make an even number }
  1194.         FldType := (FldType shl dsSizeBitsLen) or (Prec + 2);
  1195.       end;
  1196.       ftFMTBcd:
  1197.       begin
  1198.         if TFMTBCDField(Info.Field).Precision = 0 then
  1199.           Width := 32 else
  1200.           Width := TFMTBCDField(Info.Field).Precision;
  1201.         Prec := Width shr 1;
  1202.         Inc(Prec, Prec and 1);  { Make an even number }
  1203.         FldType := (FldType shl dsSizeBitsLen) or (Prec + 2);
  1204.       end;
  1205.       ftArray:
  1206.         FldType := (FldType shl dsSizeBitsLen) or dsPseudoFldType or
  1207.           dsCompArrayFldType or TObjectField(Info.Field).Size;
  1208.       ftADT:
  1209.         FldType := (FldType shl dsSizeBitsLen) or dsPseudoFldType or
  1210.           TObjectField(Info.Field).FieldCount;
  1211.       ftDataSet, ftReference:
  1212.         FldType := (FldType shl dsSizeBitsLen) or dsPseudoFldType or
  1213.           dsEmbeddedFldType or ComputeInfoCount(TInfoArray(Info.FieldInfos));
  1214.     else
  1215.       if Info.Field.IsBlob then
  1216.       begin
  1217.         FldType := (FldType shl dsSizeBitsLen) or dsVaryingFldType or SizeOf(Integer);
  1218.         Width := Info.Field.Size;
  1219.       end else
  1220.         FldType := (FldType shl dsSizeBitsLen) or Info.Size;
  1221.     end;
  1222.     AddFieldDesc(Info.Field.FieldName, FldType, Attr);
  1223.     if (Info.Field.FieldKind <> fkData) then
  1224.       AddAttribute(fldAttrArea, szSERVERCALC, True, True);
  1225.     if Info.Field.ProviderFlags <> [pfInWhere, pfInUpdate] then
  1226.       AddAttribute(fldAttrArea, szPROVFLAGS, Byte(Info.Field.ProviderFlags), True);
  1227.     if Info.Field.Origin <> '' then
  1228.       AddAttribute(fldAttrArea, szORIGIN, Info.Field.Origin, True);
  1229.     if Width > 0 then
  1230.       AddAttribute(fldAttrArea, szWIDTH, Width, False);
  1231.     if Info.Field is TBCDField then 
  1232.     begin
  1233.       if TBCDField(Info.Field).Size <> 0 then
  1234.         AddAttribute(fldAttrArea, szDECIMALS, TBCDField(Info.Field).Size, False);
  1235.     end
  1236.     else if Info.Field is TFMTBCDField then 
  1237.     begin
  1238.       if TFMTBCDField(Info.Field).Size <> 0 then
  1239.         AddAttribute(fldAttrArea, szDECIMALS, TFMTBCDField(Info.Field).Size, False);
  1240.     end;
  1241.     AddMinMax(Info.Field);
  1242.     case Info.Field.DataType of
  1243.       ftCurrency: TempStr := szstMONEY;
  1244.       ftAutoInc: TempStr := szstAUTOINC;
  1245.       ftVarBytes, ftBlob: TempStr := szstBINARY;
  1246.       ftMemo: TempStr := szstMEMO;
  1247.       ftFmtMemo: TempStr := szstFMTMEMO;
  1248.       ftParadoxOle: TempStr := szstOLEOBJ;
  1249.       ftGraphic: TempStr := szstGRAPHIC;
  1250.       ftDBaseOle: TempStr := szstDBSOLEOBJ;
  1251.       ftTypedBinary: TempStr := szstTYPEDBINARY;
  1252.       ftADT:
  1253.         if (Info.Field.ParentField <> nil) and
  1254.            (Info.Field.ParentField.DataType in [ftDataSet, ftReference]) then
  1255.           TempStr := szstADTNESTEDTABLE;
  1256.       ftReference: TempStr := szstREFNESTEDTABLE;
  1257.       ftString:
  1258.         if TStringField(Info.Field).FixedChar then
  1259.           TempStr := szstFIXEDCHAR else
  1260.           TempStr := '';
  1261.       ftGUID: TempStr := szstGUID;
  1262.       ftOraClob: TempStr := szstHMEMO;
  1263.       ftOraBlob: TempStr := szstHBINARY;
  1264.     else
  1265.         TempStr := '';
  1266.     end;
  1267.     if TempStr <> '' then
  1268.       AddAttribute(fldAttrArea, szSUBTYPE, TempStr, False);
  1269.     if Info.Field is TObjectField then
  1270.       AddAttribute(fldAttrArea, szTYPENAME, TObjectField(Info.Field).ObjectType, False);
  1271.     if poIncFieldProps in Options then
  1272.       AddExtraFieldProps(Info.Field);
  1273.     case Info.Field.DataType of
  1274.       ftADT, ftArray: { Array will only have 1 child field }
  1275.         for i := 0 to High(TInfoArray(Info.FieldInfos)) do
  1276.           AddColumn(TInfoArray(Info.FieldInfos)[i]);
  1277.       ftDataSet, ftReference:
  1278.         with TDataSetField(Info.Field) do
  1279.           WriteMetaData(NestedDataSet, TInfoArray(Info.FieldInfos),
  1280.             Info.Field.DataType = ftReference);
  1281.     end;
  1282.   end;
  1283. end;
  1285. procedure TDataPacketWriter.AddConstraints(DataSet: TDataSet);
  1286. type
  1287.   TConstraintType = (ctField, ctRecord, ctDefault);
  1289.   procedure AddSQLExprAttr(ExprParser: TExprParser; const ExprText, ExprErrMsg,
  1290.     FieldName: string; FieldIndex: Integer; ConstraintType: TConstraintType;
  1291.     Required: Boolean);
  1292.   type
  1293.     PSQLExprInfo = ^TSQLExprInfo;
  1294.     TSQLExprInfo = packed record
  1295.       iErrStrLen: Integer;
  1296.       iFldNum: Integer;
  1297.       bReqExpr: BYTE;
  1298.     end;
  1299.   const
  1300.     TypeStr: array[TConstraintType] of PChar = (szBDEDOMX, szBDERECX, szBDEDEFX);
  1301.     Attr: Integer = dsVaryingFldType or SizeOf(Integer) or (dsfldBYTES shl dsSizeBitsLen);
  1302.   var
  1303.     ErrorStr: string;
  1304.     AttrType: PChar;
  1305.     Len, AttrSize: Integer;
  1306.     SQLExprInfo: PSQLExprInfo;
  1307.     Options: TParserOptions;
  1308.   begin
  1309.     if ExprText = '' then Exit;
  1310.     if (ConstraintType <> ctDefault) and (ExprErrMsg = '') then
  1311.     begin
  1312.       if (ConstraintType = ctField) and (FieldName <> '') then
  1313.         ErrorStr := Format('%s %s: %s %s',[SConstraintFailed, SField, FieldName, ExprText]) else
  1314.         ErrorStr := Format('%s %s',[SConstraintFailed, ExprText]);
  1315.     end else
  1316.       ErrorStr := ExprErrMsg;
  1317.     Len := Length(ErrorStr);
  1318.     if (Len > 0) then Inc(Len);
  1319.     SQLExprInfo := @FBuffer[SizeOf(Integer)];
  1320.     SQLExprInfo.iErrStrLen := Len;
  1321.     SQLExprInfo.iFldNum := FieldIndex;
  1322.     SQLExprInfo.bReqExpr := Ord(Required);
  1323.     Options := [poExtSyntax];
  1324.     if ConstraintType = ctDefault then Include(Options, poDefaultExpr);
  1325.     if ConstraintType = ctRecord then Include(Options, poUseOrigNames);
  1326.     if FieldName <> '' then Include(Options, poFieldNameGiven);
  1327.     with ExprParser do
  1328.     begin
  1329.       SetExprParams(ExprText, [], Options, FieldName);
  1330.       Move(FilterData[0], FBuffer[SizeOf(TSQLExprInfo) + Len + SizeOf(Integer)], DataSize);
  1331.       AttrSize := DataSize + SizeOf(TSQLExprInfo) + Len;
  1332.     end;
  1333.     PInteger(FBuffer)^ := AttrSize;
  1334.     if Len > 0 then
  1335.       StrLCopy(@FBuffer[SizeOf(TSQLExprInfo) + SizeOf(Integer)], PChar(ErrorStr), Length(FBuffer) - SizeOf(TSQLExprInfo) - SizeOf(Integer) - 1);
  1336.     AttrType := TypeStr[ConstraintType];
  1337.     Check(FIDSWriter.AddAttribute(pcktAttrArea, AttrType, Attr, AttrSize + SizeOf(Integer), PByte(FBuffer)));
  1338.   end;
  1340. var
  1341.   i: Integer;
  1342.   ExprParser: TExprParser;
  1343.   Constraints: TCheckConstraints;
  1344.   Obj: TObject;
  1345.   ErrMsg: string;
  1346. begin
  1347.   ExprParser := TExprParser.Create(DataSet, '', [], [], '', nil, FieldTypeMap);
  1348.   try
  1349.     Obj := GetObjectProperty(DataSet, 'Constraints'); { Do not localize }
  1350.     if (Obj <> nil) and (Obj is TCheckConstraints) then
  1351.     begin
  1352.       Constraints := Obj as TCheckConstraints;
  1353.       try
  1354.         for i := 0 to Constraints.Count - 1 do
  1355.           with Constraints[i] do
  1356.           begin
  1357.             AddSQLExprAttr(ExprParser, ImportedConstraint, ErrorMessage, '', 0,
  1358.               ctRecord, False);
  1359.             AddSQLExprAttr(ExprParser, CustomConstraint, ErrorMessage, '', 0,
  1360.               ctRecord, False);
  1361.           end;
  1362.       except
  1363.         if DataSet.Name <> '' then
  1364.           ErrMsg := Format('%s: %s',[DataSet.Name, SRecConstFail]) 
  1365.         else
  1366.           ErrMsg := SRecConstFail;
  1367.         if ExceptObject is Exception then
  1368.           raise EDSWriter.CreateFmt(ErrMsg, [Exception(ExceptObject).Message])
  1369.         else
  1370.           raise EDSWriter.CreateFmt(ErrMsg, ['']);
  1371.       end;
  1372.     end;
  1373.     for i := 0 to DataSet.FieldList.Count - 1 do
  1374.       with DataSet.FieldList[i] do
  1375.       begin
  1376.         try
  1377.           AddSQLExprAttr(ExprParser, DefaultExpression, '', FullName, i + 1,
  1378.             ctDefault, False);
  1379.         except
  1380.           if Name <> '' then
  1381.             ErrMsg := Format('%s: %s',[Name, SDefExprFail]) else
  1382.           if DataSet.Name <> '' then
  1383.             ErrMsg := Format('%s.%s: %s',[DataSet.Name, FullName, SDefExprFail]) else
  1384.             ErrMsg := Format('%s: %s', [FullName, SDefExprFail]);
  1385.           if ExceptObject is Exception then
  1386.             raise EDSWriter.CreateFmt(ErrMsg, [Exception(ExceptObject).Message])
  1387.           else
  1388.             raise EDSWriter.CreateFmt(ErrMsg, ['']);
  1389.         end;
  1390.         try
  1391.           AddSQLExprAttr(ExprParser, ImportedConstraint, ConstraintErrorMessage,
  1392.             FullName, i + 1, ctField, False);
  1393.           AddSQLExprAttr(ExprParser, CustomConstraint, ConstraintErrorMessage,
  1394.             FullName, i + 1, ctField, False);
  1395.         except
  1396.           if Name <> '' then
  1397.             ErrMsg := Format('%s: %s',[Name, SFieldConstFail]) else
  1398.           if DataSet.Name <> '' then
  1399.             ErrMsg := Format('%s.%s: %s',[DataSet.Name, FullName, SFieldConstFail]) else
  1400.             ErrMsg := Format('%s: %s', [FullName, SFieldConstFail]);
  1401.           if ExceptObject is Exception then
  1402.             raise EDSWriter.CreateFmt(ErrMsg, [Exception(ExceptObject).Message])
  1403.           else
  1404.             raise EDSWriter.CreateFmt(ErrMsg, ['']);
  1405.         end;
  1406.       end;
  1407.   finally
  1408.     ExprParser.Free;
  1409.   end;
  1410. end;
  1412. procedure TDataPacketWriter.AddIndexDefs(DataSet: TDataSet; const Info: TInfoArray);
  1413. var
  1414.   FieldList, CaseList, DescList: TList;
  1416.   function GetKeyData(Index: TIndexDef): OleVariant;
  1417.   var
  1418.     i: Integer;
  1419.     x: Integer;
  1420.   begin
  1421.     with Index do
  1422.     begin
  1423.       FieldList.Clear;
  1424.       CaseList.Clear;
  1425.       DescList.Clear;
  1426.       DataSet.GetFieldList(FieldList, Fields);
  1427.       DataSet.GetFieldList(CaseList, CaseInsFields);
  1428.       DataSet.GetFieldList(DescList, DescFields);
  1429.       Result := VarArrayCreate([0, FieldList.Count - 1], varInteger);
  1430.       for i := 0 to FieldList.Count - 1 do
  1431.       begin
  1432.         x := GetFieldIdx(TField(FieldList[i]).FieldName, Info);
  1433.         if (CaseList.IndexOf(FieldList[i]) <> -1) or
  1434.            ((i = 0) and (FieldList.Count = 1) and (ixCaseInSensitive in Options)) then
  1435.           x := x or dskeyCASEINSENSITIVE;
  1436.         if (DescList.IndexOf(FieldList[i]) <> -1) or
  1437.            ((i = 0) and (FieldList.Count = 1) and (ixDescending in Options)) then
  1438.           x := x or dskeyDESCENDING;
  1439.         Result[i] := x;
  1440.       end;
  1441.     end;
  1442.   end;
  1444. var
  1445.   i: Integer;
  1446.   DefIdx, KeyIndex: TIndexDef;
  1447.   IndexDefs: TIndexDefs;
  1448.   KeyList: OleVariant;
  1449.   KeyFields: string;
  1450. begin
  1451.   FieldList := TList.Create;
  1452.   try
  1453.     CaseList := TList.Create;
  1454.     try
  1455.       DescList := TList.Create;
  1456.       try
  1457.         { Get the DEFAULT_ORDER }
  1458.         if not (poRetainServerOrder in Options) then
  1459.           DefIdx := IProviderSupport(DataSet).PSGetDefaultOrder
  1460.         else
  1461.           DefIdx := nil;
  1462.         if Assigned(DefIdx) then
  1463.         try
  1464.           KeyList := GetKeyData(DefIdx);
  1465.           AddAttribute(pcktAttrArea, szDEFAULT_ORDER, KeyList, False);
  1466.         finally
  1467.           DefIdx.Free;
  1468.         end;
  1469.         KeyFields := IProviderSupport(DataSet).PSGetKeyFields;
  1470.         IndexDefs := IProviderSupport(DataSet).PSGetIndexDefs([ixUnique]);
  1471.         try
  1472.           if KeyFields <> '' then
  1473.           begin
  1474.             { PRIMARY_KEY is used to define the keyfields }
  1475.             KeyList := NULL;
  1476.             if Assigned(IndexDefs) then
  1477.             begin
  1478.               KeyIndex := IndexDefs.GetIndexForFields(KeyFields, False);
  1479.               if Assigned(KeyIndex) then
  1480.               begin
  1481.                 KeyList := GetKeyData(KeyIndex);
  1482.                 KeyIndex.Free;{ KeyIndex is already used, remove it from the list }
  1483.               end;
  1484.             end;
  1485.             if VarIsNull(KeyList) then
  1486.             begin
  1487.               DataSet.GetFieldList(FieldList, KeyFields);
  1488.               KeyList := VarArrayCreate([0, FieldList.Count - 1], varSmallInt);
  1489.               for i := 0 to FieldList.Count - 1 do
  1490.                 KeyList[i] := GetFieldIdx(TField(FieldList[i]).FieldName, Info);
  1491.             end;
  1492.             if not VarIsNull(KeyList) then
  1493.               AddAttribute(pcktAttrArea, szPRIMARY_KEY, KeyList, False);
  1494.           end;
  1495.           if Assigned(IndexDefs) then
  1496.             for i := 0 to IndexDefs.Count - 1 do
  1497.               with IndexDefs[i] do
  1498.               begin
  1499.                 KeyList := GetKeyData(IndexDefs[i]);
  1500.                 AddAttribute(pcktAttrArea, szUNIQUE_KEY, KeyList, False);
  1501.               end;
  1502.         finally
  1503.           IndexDefs.Free;
  1504.         end;
  1505.       finally
  1506.         DescList.Free;
  1507.       end;
  1508.     finally
  1509.       CaseList.Free;
  1510.     end;
  1511.   finally
  1512.     FieldList.Free;
  1513.   end;
  1514. end;
  1516. procedure TDataPacketWriter.AddFieldLinks(const Info: TInfoArray);
  1517. var
  1518.   MasterFields, DetailFields: TList;
  1519.   i, j: Integer;
  1520.   LinkFields: Variant;
  1521. begin
  1522.   MasterFields := TList.Create;
  1523.   try
  1524.     DetailFields := TList.Create;
  1525.     try
  1526.       for i := 0 to High(Info) do
  1527.         if Info[i].IsDetail and (Info[i].Field = nil) then
  1528.         begin
  1529.           Info[i].DataSet.GetDetailLinkFields(MasterFields, DetailFields);
  1530.           if (MasterFields.Count > 0) and (MasterFields.Count <= DetailFields.Count) then
  1531.           begin
  1532.             LinkFields := VarArrayCreate([0, MasterFields.Count * 2], varSmallInt);
  1533.             LinkFields[0] := Info[i].LocalFieldIndex;
  1534.             for j := 0 to MasterFields.Count - 1 do
  1535.               LinkFields[j + 1] := GetFieldIdx(TField(MasterFields[j]).FieldName,
  1536.                 Info);
  1537.             for j := 0 to MasterFields.Count - 1 do
  1538.               LinkFields[j + MasterFields.Count + 1] :=
  1539.                 GetFieldIdx(TField(DetailFields[j]).FieldName, TInfoArray(Info[i].FieldInfos));
  1540.             AddAttribute(pcktAttrArea, szMD_FIELDLINKS, LinkFields, False);
  1541.           end;
  1542.         end;
  1543.     finally
  1544.       DetailFields.Free;
  1545.     end;
  1546.   finally
  1547.     MasterFields.Free;
  1548.   end;
  1549. end;
  1551. procedure TDataPacketWriter.WriteMetaData(DataSet: TDataSet; const Info: TInfoArray;
  1552.   IsReference: Boolean);
  1553. var
  1554.   i, MDOptions: Integer;
  1555. begin
  1556.   for i := 0 to High(Info) do
  1557.     AddColumn(Info[i]);
  1558.   if (poReadOnly in Options) or IsReference then
  1559.     AddAttribute(pcktAttrArea, szREADONLY, True, False);
  1560.   if (poDisableEdits in Options) then
  1561.     AddAttribute(pcktAttrArea, szDISABLE_EDITS, True, False);
  1562.   if (poDisableInserts in Options) then
  1563.     AddAttribute(pcktAttrArea, szDISABLE_INSERTS, True, False);
  1564.   if (poDisableDeletes in Options) then
  1565.     AddAttribute(pcktAttrArea, szDISABLE_DELETES, True, False);
  1566.   if (poNoReset in Options) then
  1567.     AddAttribute(pcktAttrArea, szNO_RESET_CALL, True, False);
  1568.   if Constraints then
  1569.     AddConstraints(DataSet);
  1570.   AddIndexDefs(DataSet, Info);
  1571.   AddFieldLinks(Info);
  1572.   MDOptions := 0;
  1573.   if poCascadeDeletes in Options then MDOptions := dsCASCADEDELETES;
  1574.   if poCascadeUpdates in Options then MDOptions := MDOptions or dsCASCADEUPDATES;
  1575.   if MDOptions <> 0 then
  1576.     AddAttribute(pcktAttrArea, szMD_SEMANTICS, MDOptions, True);
  1577.   AddDataSetAttributes(DataSet);
  1578.   if Info <> FPutFieldInfo then
  1579.     Check(FIDSWriter.AddAttribute(pcktAttrArea, nil, 0, 0, nil));
  1580. end;
  1582. procedure TDataPacketWriter.RefreshPutProcs(ADataSet: TDataSet; var Info: TInfoArray);
  1584.   procedure RefreshInfo(ADataSet: TDataSet; AField: TField; var Info: TPutFieldInfo);
  1585.   var
  1586.     j: Integer;
  1587.   begin
  1588.     Info.Field := AField;
  1589.     if AField = nil then
  1590.       Info.DataSet := ADataSet
  1591.     else
  1592.     begin
  1593.       Info.DataSet := AField.DataSet;
  1594.       if AField.DataType = ftADT then
  1595.       begin
  1596.         with TADTField(AField) do
  1597.         for j := 0 to FieldCount - 1 do
  1598.           RefreshInfo(ADataSet, Fields[j], TInfoArray(Info.FieldInfos)[j]);
  1599.       end;
  1600.     end;
  1601.   end;
  1603. var
  1604.   i: Integer;
  1605.   List: TList;
  1606. begin
  1607.   List := TList.Create;
  1608.   try
  1609.     ADataSet.GetDetailDataSets(List);
  1610.     for i := 0 to ADataSet.FieldCount - 1 do
  1611.       RefreshInfo(ADataSet, ADataSet.Fields[i], Info[i]);
  1612.     for i := 0 to List.Count - 1 do
  1613.       RefreshInfo(TDataSet(List[i]), nil, Info[ADataSet.FieldCount + i]);
  1614.   finally
  1615.     List.Free;
  1616.   end;
  1617. end;
  1619. function TDataPacketWriter.InitPutProcs(ADataSet: TDataSet;
  1620.   var GlobalIdx: Integer): TInfoArray;
  1622.   procedure InitInfoStruct(var Info: TPutFieldInfo; AField: TField;
  1623.     var GlobalIdx, LocalIdx: Integer);
  1624.   begin
  1625.     FillChar(Info, SizeOf(Info), 0);
  1626.     with Info do
  1627.     begin
  1628.       IsDetail := AField = nil;
  1629.       Field := AField;
  1630.       Inc(GlobalIdx);
  1631.       LocalFieldIndex := LocalIdx;
  1632.       Inc(LocalIdx);
  1633.       if Field <> nil then
  1634.       begin
  1635.         FieldNo := Field.FieldNo;
  1636.         Size := Field.DataSize;
  1637.         DataSet := Field.DataSet;
  1638.       end;
  1639.     end;
  1640.   end;
  1642.   procedure InitFieldProc(ADataSet: TDataSet; AField: TField;
  1643.     var Info: TPutFieldInfo; var GlobalIdx, LocalIdx: Integer);
  1644.   var
  1645.     i: Integer;
  1646.     NestedIdx: Integer;
  1647.   begin
  1648.     with Info do
  1649.     begin
  1650.       InitInfoStruct(Info, AField, GlobalIdx, LocalIdx);
  1651.       if AField = nil then { Linked dataset }
  1652.       begin
  1653.         Opened := not ADataSet.Active;
  1654.         if Opened then ADataSet.Open;
  1655.         DataSet := ADataSet;
  1656.         PutProc := PutDataSetField;
  1657.         TInfoArray(FieldInfos) := InitPutProcs(DataSet, GlobalIdx);
  1658.       end else
  1659.       begin
  1660.         case Field.DataType of
  1661.           ftString, ftFixedChar, ftGUID:
  1662.           begin
  1663.             PutProc := PutStringField;
  1664.             Dec(Size);  { Don't count the null terminator }
  1665.           end;
  1666.           ftWideString:
  1667.           begin
  1668.             PutProc := PutWideStringField;
  1669.             Size := AField.Size * 2;
  1670.           end;
  1671.           ftVarBytes:
  1672.           begin
  1673.             PutProc := PutVarBytesField;
  1674.             Dec(Size, 2); { Don't write size bytes }
  1675.           end;
  1676.           ftADT:
  1677.           with TADTField(Field) do
  1678.           begin
  1679.             PutProc := PutADTField;
  1680.             SetLength(TInfoArray(FieldInfos), FieldCount);
  1681.             for i := 0 to FieldCount - 1 do
  1682.               InitFieldProc(ADataSet, Fields[i], TInfoArray(FieldInfos)[i],
  1683.                 GlobalIdx, LocalIdx);
  1684.           end;
  1685.           ftArray:
  1686.           with TArrayField(Field) do
  1687.           begin
  1688.             PutProc := PutArrayField;
  1689.             SetLength(TInfoArray(FieldInfos), 1);
  1690.             NestedIdx := LocalIdx;
  1691.             InitFieldProc(ADataSet, Fields[0], TInfoArray(FieldInfos)[0],
  1692.                 GlobalIdx, LocalIdx);
  1693.             LocalIdx := (LocalIdx - NestedIdx) * (FieldCount - 1) + LocalIdx;
  1694.           end;
  1695.           ftDataSet, ftReference:
  1696.           with TDataSetField(Field).NestedDataSet do
  1697.           begin
  1698.             PutProc := PutDataSetField;
  1699.             NestedIdx := 1;
  1700.             SetLength(TInfoArray(FieldInfos), FieldCount);
  1701.             for i := 0 to FieldCount - 1 do
  1702.               InitFieldProc(TDataSetField(Field).NestedDataSet, Fields[i],
  1703.                 TInfoArray(FieldInfos)[i], GlobalIdx, NestedIdx);
  1704.           end;
  1705.           ftSmallint, ftInteger, ftWord, ftBoolean, ftFloat, ftCurrency, ftBCD,
  1706.           ftDate, ftTime, ftDateTime, ftAutoInc, ftLargeint, ftBytes, ftTimeStamp, ftFMTBcd:
  1707.             PutProc := PutField;
  1708.           ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftParadoxOle, ftDBaseOle, ftTypedBinary, ftOraBlob, ftOraClob:
  1709.             PutProc := PutBlobField;
  1710.         else
  1711.           DatabaseErrorFmt(SUnknownFieldType, [Field.FieldName]);
  1712.         end;
  1713.         if Field.FieldKind <> fkData then
  1714.           PutProc := PutCalcField;
  1715.       end;
  1716.     end;
  1717.   end;
  1719. var
  1720.   i, LocalIdx: Integer;
  1721.   List: TList;
  1722. begin
  1723.   LocalIdx := 1;
  1724.   List := TList.Create;
  1725.   try
  1726.     ADataSet.GetDetailDataSets(List);
  1727.     SetLength(Result, ADataSet.FieldCount + List.Count);
  1728.     for i := 0 to ADataSet.FieldCount - 1 do
  1729.       InitFieldProc(ADataSet, ADataSet.Fields[i], Result[i], GlobalIdx, LocalIdx);
  1730.     for i := 0 to List.Count - 1 do
  1731.       InitFieldProc(TDataSet(List[i]), nil, Result[ADataSet.FieldCount + i],
  1732.         GlobalIdx, LocalIdx);
  1733.   finally
  1734.     List.Free;
  1735.   end;
  1736. end;
  1738. procedure TDataPacketWriter.GetDataPacket(DataSet: TDataSet;
  1739.   var RecsOut: Integer; out Data: OleVariant);
  1741.   procedure CheckMetaData(DataSet: TDataSet);
  1742.   var
  1743.     Idx: Integer;
  1744.     TempPacket: TDataPacket;
  1745.     Version: Integer;
  1746.   begin
  1747.     Idx := 1;
  1748.     if (FPutFieldInfo = nil) or (grMetaData in PacketOptions) then
  1749.     begin
  1750.       CreateDBClientObject(CLSID_DSWriter, IDSWriter, FIDSWriter);
  1751.       if FPutFieldInfo <> nil then
  1752.       begin
  1753.         FreeInfoRecords(FPutFieldInfo);
  1754.         FPutFieldInfo := nil;
  1755.       end;
  1756.       FPutFieldInfo := InitPutProcs(DataSet, Idx);
  1757.       if poFetchBlobsOnDemand in Options then
  1758.         Version := PACKETVERSION_3 else
  1759.         Version := PACKETVERSION_1;
  1760.       if grXMLUTF8 in PacketOptions then
  1761.         FIDSWriter.SetXMLMode(xmlUTF8)
  1762.       else if grXML in PacketOptions then
  1763.         FIDSWriter.SetXMLMode(xmlON)
  1764.       else
  1765.         FIDSWriter.SetXMLMode(0);
  1766.       Check(FIDSWriter.Init_Sequential(Version, Idx - 1));
  1767.       WriteMetaData(DataSet, FPutFieldInfo);
  1768.       if not (grMetaData in PacketOptions) then
  1769.       begin
  1770.         FIDSWriter.GetDataPacket(TempPacket);
  1771.         SafeArrayCheck(SafeArrayDestroy(TempPacket));
  1772.         TempPacket := nil;
  1773.       end;
  1774.     end;
  1775.     if not (grMetaData in PacketOptions) then
  1776.       Check(FIDSWriter.Reset);
  1777.   end;
  1779. var
  1780.   DataPacket: TDataPacket;
  1781. begin
  1782.     CheckMetaData(DataSet);
  1783.     RecsOut := WriteDataSet(DataSet, FPutFieldInfo, RecsOut);
  1784.     FIDSWriter.GetDataPacket(DataPacket);
  1785.     DataPacketToVariant(DataPacket, Data);
  1786. end;
  1788. procedure TDataPacketWriter.Reset;
  1790.   procedure CloseDetailDatasets(const Info: TInfoArray);
  1791.   var
  1792.     i: integer;
  1793.   begin
  1794.     for i := 0 to High(Info) do
  1795.       if Info[i].IsDetail and (Info[i].Opened or Info[i].Dataset.Active) then
  1796.       begin
  1797.         Info[i].DataSet.Close;
  1798.         Info[i].Opened := False;
  1799.         CloseDetailDatasets(TInfoArray(Info[i].FieldInfos));
  1800.       end;
  1801.   end;
  1803. begin
  1804.   CloseDetailDatasets(FPutFieldInfo);
  1805. end;
  1807. { TPacketDataSet }
  1809. constructor TPacketDataSet.Create(AOwner: TComponent);
  1810. begin
  1811.   inherited;
  1812.   FetchOnDemand := False;
  1813. end;
  1815. procedure TPacketDataSet.CreateFromDelta(Source: TPacketDataSet);
  1816. var
  1817.   TempBase: IDSBase;
  1818. begin
  1819.   Source.Check(Source.DSBase.Clone(2, True, False, TempBase));
  1820.   DSBase := TempBase;
  1821.   Open;
  1822. end;
  1824. procedure TPacketDataSet.InternalInitRecord(Buffer: PChar);
  1825. var
  1826.   I: Integer;
  1827. begin
  1828.   inherited InternalInitRecord(Buffer);
  1829.   { Initialize new records in the error result dataset to unchanged values }
  1830.   for I := 1 to FieldCount do
  1831.     DSBase.PutBlank(PByte(Buffer), 0, I, BLANK_NOTCHANGED);
  1832. end;
  1834. procedure TPacketDataSet.InternalOpen;
  1835. var
  1836.   MDSem: DWord;
  1837. begin
  1838.   inherited InternalOpen;
  1839.   FOldRecBuf := AllocRecordBuffer;
  1840.   FCurRecBuf := AllocRecordBuffer;
  1841.   DSBase.GetProp(dspropMD_SEMANTICS, @MDSem);
  1842.   MDSem := MDSem and mdCASCADEMOD;
  1843.   DSBase.SetProp(dspropMD_SEMANTICS, MDSem);
  1844. end;
  1846. procedure TPacketDataSet.InternalClose;
  1847. begin
  1848.   inherited InternalClose;
  1849.   FreeRecordBuffer(FOldRecBuf);
  1850.   FreeRecordBuffer(FCurRecBuf);
  1851. end;
  1853. function TPacketDataSet.GetStateFieldValue(State: TDataSetState; Field: TField): Variant;
  1854. begin
  1855.   { When reading an OldValue, return the CurValue instead if we have one }
  1856.   if FUseCurValues and (State = dsOldValue) and HasCurValues then
  1857.   begin
  1858.     Result := inherited GetStateFieldValue(dsCurValue, Field);
  1859.     if not VarIsClear(Result) then Exit;
  1860.   end;
  1861.   Result := inherited GetStateFieldValue(State, Field);
  1862. end;
  1864. function TPacketDataSet.GetStreamMetaData: Boolean;
  1865. var
  1866.   Value: Integer;
  1867. begin
  1868.   DSBase.GetProp(DSProp(dspropDONTINCLMETADATA), @Value);
  1869.   Result := Value <> 0;
  1870. end;
  1872. procedure TPacketDataSet.SetStreamMetaData(Value: Boolean);
  1873. begin
  1874.   DSBase.SetProp(DSProp(dspropDONTINCLMETADATA), Integer(not Value));
  1875. end;
  1877. function TPacketDataSet.UpdateKind: TUpdateKind;
  1878. begin
  1879.   case UpdateStatus of
  1880.     usInserted: Result := ukInsert;
  1881.     usDeleted: Result := ukDelete;
  1882.   else
  1883.     Result := ukModify;
  1884.   end;
  1885. end;
  1887. procedure TPacketDataSet.DataEvent(Event: TDataEvent; Info: Integer);
  1888. begin
  1889.   if Event in [deDataSetScroll, deDataSetChange] then
  1890.   begin
  1891.     FNewValuesModified := False;
  1892.     FCurValues := nil;
  1893.   end;
  1894.   inherited DataEvent(Event, Info);
  1895. end;
  1897. function TPacketDataSet.HasCurValues: Boolean;
  1898. begin
  1899.   Result := FCurValues <> nil;
  1900. end;
  1902. procedure TPacketDataSet.InitAltRecBuffers(CheckModified: Boolean);
  1903. var
  1904.   No: Integer;
  1905. begin
  1906.   if UpdateStatus in [usUnmodified, usDeleted] then
  1907.     GetCurrentRecord(FOldRecBuf);
  1908.   if CheckModified and (UpdateStatus = usUnmodified) then
  1909.   begin
  1910.     No := RecNo;
  1911.     Next;
  1912.     if UpdateStatus <> usModified then
  1913.       RecNo := No;
  1914.   end;
  1915.   if UpdateStatus = usInserted then
  1916.     SetAltRecBuffers(ActiveBuffer, ActiveBuffer, FCurRecBuf) else
  1917.     SetAltRecBuffers(FOldRecBuf, ActiveBuffer, FCurRecBuf);
  1918. end;
  1920. procedure TPacketDataSet.SetFieldData(Field: TField; Buffer: Pointer);
  1921. begin
  1922.   { Set a flag when any of the field's NewValue properties are modified }
  1923.   if State = dsNewValue then
  1924.     FNewValuesModified := True;
  1925.   if FWritingCurValues then
  1926.     Check(DSCursor.PutField(FCurRecBuf, Field.FieldNo, Buffer)) else
  1927.     inherited SetFieldData(Field, Buffer);
  1928. end;
  1930. procedure TPacketDataSet.SetWritingCurValues(const Value: Boolean);
  1931. begin
  1932.   if Value then
  1933.   begin
  1934.     FCurValues := FCurRecBuf;
  1935.     InitRecord(FCurValues);
  1936.   end else
  1937.     InitAltRecBuffers;
  1938.   FWritingCurValues := Value;
  1939. end;
  1941. procedure TPacketDataSet.AssignCurValues(Source: TDataSet);
  1942. var
  1943.   I: Integer;
  1944.   NewValue: Variant;
  1945.   Field, SourceField: TField;
  1946. begin
  1947.   WritingCurValues := True;
  1948.   try
  1949.     for i := 0 to FieldCount - 1 do
  1950.     begin
  1951.       Field := Fields[i];
  1952.       SourceField := Source.FindField(Field.FieldName);
  1953.       if (SourceField <> nil) and not Field.IsBlob and
  1954.          not (Field.DataType in [ftBytes, ftVarBytes]) and
  1955.          (Field.OldValue <> SourceField.Value) then
  1956.       begin
  1957.         NewValue := Field.NewValue;
  1958.         if VarIsClear(Field.NewValue) or
  1959.            (NewValue <> SourceField.Value) then
  1960.           Field.Assign(SourceField);
  1961.       end;
  1962.     end;
  1963.   finally
  1964.     WritingCurValues := False;
  1965.   end;
  1966. end;
  1968. procedure TPacketDataSet.AssignCurValues(const CurValues: Variant);
  1969. var
  1970.   I: Integer;
  1971.   Field: TField;
  1972.   CurValue: Variant;
  1973. begin
  1974.   WritingCurValues := True;
  1975.   try
  1976.     if VarIsNull(CurValues) then
  1977.       FCurValues := nil
  1978.     else
  1979.       for I := VarArrayLowBound(CurValues, 1) to VarArrayHighBound(CurValues, 1) do
  1980.       begin
  1981.         if VarIsArray(CurValues[I]) then
  1982.         begin
  1983.           CurValue := CurValues[I][1];
  1984.           Field := FieldByName(CurValues[I][0])
  1985.         end else
  1986.         begin
  1987.           CurValue := CurValues[I];
  1988.           Field := Fields[I];
  1989.         end;
  1990.         if not VarIsClear(CurValue) then
  1991.           if (Field.OldValue <> CurValue) then
  1992.             Fields[I].Value := CurValue;
  1993.       end;
  1994.   finally
  1995.     WritingCurValues := False;
  1996.   end;
  1997. end;
  1999. function TPacketDataSet.HasMergeConflicts: Boolean;
  2000. var
  2001.   I: Integer;
  2002.   CurVal, NewVal: Variant;
  2003. begin
  2004.   Result := False;
  2005.   for I := 0 to FieldCount - 1 do
  2006.     with Fields[I] do
  2007.     begin
  2008.       CurVal := CurValue;
  2009.       if VarIsClear(CurVal) then Continue;
  2010.       NewVal := NewValue;
  2011.       if VarIsClear(NewVal) then Continue;
  2012.       if CurVal = NewVal then Continue;
  2013.       Result := True;
  2014.       Break;
  2015.     end;
  2016. end;
  2018. { TCustomProvider }
  2020. constructor TCustomProvider.Create(AOwner: TComponent);
  2021. var
  2022.   ProvContainer: IProviderContainer;
  2023. begin
  2024.   inherited Create(AOwner);
  2025.   FExported := True;
  2026. {$IFDEF MSWINDOWS}
  2027.   if AOwner is TRemoteDataModule then
  2028.     TRemoteDataModule(AOwner).RegisterProvider(Self)
  2029.   else if AOwner is TCRemoteDataModule then
  2030.     TCRemoteDataModule(AOwner).RegisterProvider(Self)
  2031.   else if Assigned(AOwner) then
  2032.     if AOwner.GetInterface(IProviderContainer, ProvContainer) then
  2033.       ProvContainer.RegisterProvider(Self);
  2034. {$ENDIF}
  2035. {$IFDEF LINUX}
  2036.   if Assigned(AOwner) then
  2037.     if AOwner.GetInterface(IProviderContainer, ProvContainer) then
  2038.       ProvContainer.RegisterProvider(Self);
  2039. {$ENDIF}
  2040. end;
  2042. destructor TCustomProvider.Destroy;
  2043. var
  2044.   ProvContainer: IProviderContainer;
  2045. begin
  2046. {$IFDEF MSWINDOWS}
  2047.   if Owner is TRemoteDataModule then
  2048.     TRemoteDataModule(Owner).UnRegisterProvider(Self)
  2049.   else if Owner is TCRemoteDataModule then
  2050.     TCRemoteDataModule(Owner).UnRegisterProvider(Self)
  2051.   else if Assigned(Owner) then
  2052.     if Owner.GetInterface(IProviderContainer, ProvContainer) then
  2053.       ProvContainer.UnRegisterProvider(Self);
  2054. {$ENDIF}
  2055. {$IFDEF LINUX}
  2056.   if Assigned(Owner) then
  2057.     if Owner.GetInterface(IProviderContainer, ProvContainer) then
  2058.       ProvContainer.UnRegisterProvider(Self);
  2059. {$ENDIF}
  2060.   inherited Destroy;
  2061. end;
  2063. function TCustomProvider.GetData: OleVariant;
  2064. var
  2065.   Recs: Integer;
  2066.   Options: TGetRecordOptions;
  2067. begin
  2068.   Options := [grMetaData];
  2069.   Result := GetRecords(-1, Recs, Byte(Options));
  2070. end;
  2072. procedure TCustomProvider.DoAfterApplyUpdates(var OwnerData: OleVariant);
  2073. begin
  2074.   if Assigned(FAfterApplyUpdates) then FAfterApplyUpdates(Self, OwnerData);
  2075. end;
  2077. procedure TCustomProvider.DoBeforeApplyUpdates(var OwnerData: OleVariant);
  2078. begin
  2079.   if Assigned(FBeforeApplyUpdates) then FBeforeApplyUpdates(Self, OwnerData);
  2080. end;
  2082. function TCustomProvider.ApplyUpdates(Const Delta: OleVariant; MaxErrors: Integer;