home *** CD-ROM | disk | FTP | other *** search
/ PC Pro 1999 February / DPPCPRO0299.ISO / February / Delphi / Install / DATA.Z / DB.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-06-09  |  210.6 KB  |  7,911 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1995,96 Borland International     }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit DB;
  11.  
  12. {$N+,P+,S-,R-}
  13.  
  14. interface
  15.  
  16. uses SysUtils, Windows, Bde, Classes;
  17.  
  18. const
  19.  
  20. { TDataSet maximum number of record buffers }
  21.  
  22.   dsMaxBufferCount = 1024;
  23.  
  24. { Maximum string field size }
  25.  
  26.   dsMaxStringSize = 8192;
  27.  
  28.  { SQL Trace buffer size }
  29.  
  30.   smTraceBufSize = 8192 + SizeOf(TraceDesc);
  31.  
  32. { TDBDataSet flags }
  33.  
  34.   dbfOpened     = 0;
  35.   dbfPrepared   = 1;
  36.   dbfExecSQL    = 2;
  37.   dbfTable      = 3;
  38.   dbfFieldList  = 4;
  39.   dbfIndexList  = 5;
  40.   dbfStoredProc = 6;
  41.   dbfExecProc   = 7;
  42.   dbfProcDesc   = 8;
  43.  
  44. type
  45.  
  46. { Forward declarations }
  47.  
  48.   TDBError = class;
  49.   TSession = class;
  50.   TDatabase = class;
  51.   TFieldDefs = class;
  52.   TDataSet = class;
  53.   TDBDataSet = class;
  54.   TField = class;
  55.   TDataSource = class;
  56.   TDataLink = class;
  57.  
  58. { Generic types }
  59.  
  60.   PFieldDescList = ^TFieldDescList;
  61.   TFieldDescList = array[0..1023] of FLDDesc;
  62.  
  63.   PIndexDescList = ^TIndexDescList;
  64.   TIndexDescList = array[0..63] of IDXDesc;
  65.  
  66. { Exception classes }
  67.  
  68.   EDatabaseError = class(Exception);
  69.  
  70.   EDBEngineError = class(EDatabaseError)
  71.   private
  72.     FErrors: TList;
  73.     function GetError(Index: Integer): TDBError;
  74.     function GetErrorCount: Integer;
  75.   public
  76.     constructor Create(ErrorCode: DBIResult);
  77.     destructor Destroy; override;
  78.     property ErrorCount: Integer read GetErrorCount;
  79.     property Errors[Index: Integer]: TDBError read GetError;
  80.   end;
  81.  
  82. { BDE error information type }
  83.  
  84.   TDBError = class
  85.   private
  86.     FErrorCode: DBIResult;
  87.     FNativeError: Longint;
  88.     FMessage: string;
  89.     function GetCategory: Byte;
  90.     function GetSubCode: Byte;
  91.   public
  92.     constructor Create(Owner: EDBEngineError; ErrorCode: DBIResult;
  93.       NativeError: Longint; Message: PChar);
  94.     property Category: Byte read GetCategory;
  95.     property ErrorCode: DBIResult read FErrorCode;
  96.     property SubCode: Byte read GetSubCode;
  97.     property Message: string read FMessage;
  98.     property NativeError: Longint read FNativeError;
  99.   end;
  100.  
  101. { TLocale }
  102.  
  103.   TLocale = Pointer;
  104.  
  105. { TBDECallback }
  106.  
  107.   TBDECallbackEvent = function(CBInfo: Pointer): CBRType of Object;
  108.  
  109.   TBDECallback = class
  110.   private
  111.     FHandle: hDBICur;
  112.     FOwner: TObject;
  113.     FCBType: CBType;
  114.     FOldCBData: Longint;
  115.     FOldCBBuf: Pointer;
  116.     FOldCBBufLen: Word;
  117.     FOldCBFunc: pfDBICallBack;
  118.     FInstalled: Boolean;
  119.     FCallbackEvent: TBDECallbackEvent;
  120.   protected
  121.     function Invoke(CallType: CBType; CBInfo: Pointer): CBRType;
  122.   public
  123.     constructor Create(AOwner: TObject; Handle: hDBICur; CBType: CBType;
  124.       CBBuf: Pointer; CBBufSize: Integer; CallbackEvent: TBDECallbackEvent;
  125.       Chain: Boolean);
  126.     destructor Destroy; override;
  127.   end;
  128.  
  129. { TSessionList }
  130.  
  131.   TSessionList = class(TObject)
  132.   private
  133.     FSessions: TList;
  134.     procedure AddSession(ASession: TSession);
  135.     procedure CloseAll;
  136.     function GetCount: Integer;
  137.     function GetSession(Index: Integer): TSession;
  138.     function GetCurrentSession: TSession;
  139.     function GetSessionByName(const SessionName: string): TSession;
  140.     procedure SetCurrentSession(Value: TSession);
  141.   public
  142.     constructor Create;
  143.     destructor Destroy; override;
  144.     property CurrentSession: TSession read GetCurrentSession write SetCurrentSession;
  145.     function FindSession(const SessionName: string): TSession;
  146.     procedure GetSessionNames(List: TStrings);
  147.     function OpenSession(const SessionName: string): TSession;
  148.     property Count: Integer read GetCount;
  149.     property Sessions[Index: Integer]: TSession read GetSession; default;
  150.     property List[const SessionName: string]: TSession read GetSessionByName;
  151.   end;
  152.  
  153. { TSession }
  154.  
  155.   TConfigMode = (cmPersistent, cmSession, cmAll);
  156.  
  157.   TPasswordEvent = procedure(Sender: TObject; var Continue: Boolean) of Object;
  158.  
  159.   TDatabaseEvent = (dbOpen, dbClose, dbAdd, dbRemove, dbAddAlias, dbDeleteAlias);
  160.  
  161.   TDatabaseNotifyEvent = procedure(DBEvent: TDatabaseEvent; const Param) of object;
  162.  
  163.   TBDEInitProc = procedure(Session: TSession);
  164.  
  165.   TTraceFlag = (tfQPrepare, tfQExecute, tfError, tfStmt, tfConnect,
  166.     tfTransact, tfBlob, tfMisc, tfVendor);
  167.  
  168.   TTraceFlags = set of TTraceFlag;
  169.  
  170.   TWriteProc = function (Client: TObject; Data: PChar; Len: Integer): LongBool; StdCall;
  171.   TSMRegProc = function (Handle: Integer; ClientName: PChar;
  172.     var WriteProc: TWriteProc; Instance: TObject;
  173.     const SignalProc: Pointer): TObject; StdCall;
  174.  
  175.   TSession = class(TComponent)
  176.   private
  177.     FHandle: HDBISes;
  178.     FDefault: Boolean;
  179.     FDatabases: TList;
  180.     FCallbacks: TList;
  181.     FLocale: TLocale;
  182.     FClientLib: THandle;
  183.     FSMRegProc: TSMRegProc;
  184.     FSMWriteProc: TWriteProc;
  185.     FSMBuffer: PTraceDesc;
  186.     FSMClient: TObject;
  187.     FTraceFlags: TTraceFlags;
  188.     FStreamedActive: Boolean;
  189.     FKeepConnections: Boolean;
  190.     FSessionName: string;
  191.     FNetFileDir: string;
  192.     FPrivateDir: string;
  193.     FCBSCType: CBSCType;
  194.     FDLLDetach: Boolean;
  195.     FBDEOwnsLoginCbDb: Boolean;
  196.     FLockCount: Integer;
  197.     FCBDBLogin: TCBDBLogin;
  198.     FOnPassword: TPasswordEvent;
  199.     FOnStartup: TNotifyEvent;
  200.     FOnDBNotify: TDatabaseNotifyEvent;
  201.     procedure AddDatabase(Value: TDatabase);
  202.     procedure AddConfigRecord(const Path, Node: string; List: TStrings);
  203.     procedure CallBDEInitProcs;
  204.     procedure CheckInactive;
  205.     procedure CheckConfigMode(CfgMode: TConfigMode);
  206.     function DBLoginCallback(CBInfo: Pointer): CBRType;
  207.     procedure DBNotification(DBEvent: TDatabaseEvent; const Param);
  208.     procedure DeleteConfigPath(const Path, Node: string);
  209.     function GetActive: Boolean;
  210.     function GetConfigMode: TConfigMode;
  211.     function GetDatabase(Index: Integer): TDatabase;
  212.     function GetDatabaseCount: Integer;
  213.     function GetHandle: HDBISes;
  214.     function GetNetFileDir: string;
  215.     function GetPrivateDir: string;
  216.     procedure InitializeBDE;
  217.     procedure InternalAddAlias(const Name, Driver: string; List: TStrings;
  218.       CfgMode: TConfigMode; RestoreMode: Boolean);
  219.     procedure InternalDeleteAlias(const Name: string; CfgMode: TConfigMode;
  220.       RestoreMode: Boolean);
  221.     procedure LockSession;
  222.     procedure MakeCurrent;
  223.     procedure ModifyConfigParams(const Path, Node: string; List: TStrings);
  224.     procedure RegisterCallbacks(Value: Boolean);
  225.     procedure RemoveDatabase(Value: TDatabase);
  226.     function ServerCallback(CBInfo: Pointer): CBRType;
  227.     procedure SetActive(Value: Boolean);
  228.     procedure SetConfigMode(Value: TConfigMode);
  229.     procedure SetConfigParams(const Path, Node: string; List: TStrings);
  230.     procedure SetNetFileDir(const Value: string);
  231.     procedure SetPrivateDir(const Value: string);
  232.     procedure SetSessionName(const Value: string);
  233.     procedure SetTraceFlags(Value: TTraceFlags);
  234.     procedure SMClientSignal(Sender: TObject; Data: Integer);
  235.     function SqlTraceCallback(CBInfo: Pointer): CBRType;
  236.     procedure StartSession(Value: Boolean);
  237.     procedure UnlockSession;
  238.   protected
  239.     procedure Loaded; override;
  240.     property OnDBNotify: TDatabaseNotifyEvent read FOnDBNotify write FOnDBNotify;
  241.     property BDEOwnsLoginCbDb: Boolean read FBDEOwnsLoginCbDb write FBDEOwnsLoginCbDb;
  242.   public
  243.     constructor Create(AOwner: TComponent); override;
  244.     destructor Destroy; override;
  245.     procedure AddAlias(const Name, Driver: string; List: TStrings);
  246.     procedure AddStandardAlias(const Name, Path, DefaultDriver: string);
  247.     property ConfigMode: TConfigMode read GetConfigMode write SetConfigMode;
  248.     procedure AddPassword(const Password: string);
  249.     procedure Close;
  250.     procedure CloseDatabase(Database: TDatabase);
  251.     procedure DeleteAlias(const Name: string);
  252.     procedure DropConnections;
  253.     function FindDatabase(const DatabaseName: string): TDatabase;
  254.     procedure GetAliasNames(List: TStrings);
  255.     procedure GetAliasParams(const AliasName: string; List: TStrings);
  256.     function GetAliasDriverName(const AliasName: string): string;
  257.     procedure GetConfigParams(const Path, Section: string; List: TStrings);
  258.     procedure GetDatabaseNames(List: TStrings);
  259.     procedure GetDriverNames(List: TStrings);
  260.     procedure GetDriverParams(const DriverName: string; List: TStrings);
  261.     function GetPassword: Boolean;
  262.     procedure GetTableNames(const DatabaseName, Pattern: string;
  263.       Extensions, SystemTables: Boolean; List: TStrings);
  264.     procedure GetStoredProcNames(const DatabaseName: string; List: TStrings);
  265.     function IsAlias(const Name: string): Boolean;
  266.     procedure ModifyAlias(Name: string; List: TStrings);
  267.     procedure Open;
  268.     function OpenDatabase(const DatabaseName: string): TDatabase;
  269.     procedure RemoveAllPasswords;
  270.     procedure RemovePassword(const Password: string);
  271.     procedure SaveConfigFile;
  272.     property DatabaseCount: Integer read GetDatabaseCount;
  273.     property Databases[Index: Integer]: TDatabase read GetDatabase;
  274.     property Handle: HDBISES read GetHandle;
  275.     property Locale: TLocale read FLocale;
  276.     property TraceFlags: TTraceFlags read FTraceFlags write SetTraceFlags;
  277.   published
  278.     property Active: Boolean read GetActive write SetActive default False;
  279.     property KeepConnections: Boolean read FKeepConnections write FKeepConnections default True;
  280.     property NetFileDir: string read GetNetFileDir write SetNetFileDir;
  281.     property PrivateDir: string read GetPrivateDir write SetPrivateDir;
  282.     property SessionName: string read FSessionName write SetSessionName;
  283.     property OnPassword: TPasswordEvent read FOnPassword write FOnPassword;
  284.     property OnStartup: TNotifyEvent read FOnStartup write FOnStartup;
  285.   end;
  286.  
  287. { TParamList }
  288.  
  289.   TParamList = class(TObject)
  290.   private
  291.     FFieldCount: Integer;
  292.     FBufSize: Word;
  293.     FFieldDescs: PFieldDescList;
  294.     FBuffer: PChar;
  295.   public
  296.     constructor Create(Params: TStrings);
  297.     destructor Destroy; override;
  298.     property Buffer: PChar read FBuffer;
  299.     property FieldCount: Integer read FFieldCount;
  300.     property FieldDescs: PFieldDescList read FFieldDescs;
  301.   end;
  302.  
  303. { TDatabase }
  304.  
  305.   TTransIsolation = (tiDirtyRead, tiReadCommitted, tiRepeatableRead);
  306.  
  307.   TLoginEvent = procedure(Database: TDatabase;
  308.     LoginParams: TStrings) of object;
  309.  
  310.   TDatabase = class(TComponent)
  311.   private
  312.     FDataSets: TList;
  313.     FTransIsolation: TTransIsolation;
  314.     FLoginPrompt: Boolean;
  315.     FKeepConnection: Boolean;
  316.     FTemporary: Boolean;
  317.     FSessionAlias: Boolean;
  318.     FStreamedConnected: Boolean;
  319.     FLocaleLoaded: Boolean;
  320.     FAliased: Boolean;
  321.     FReserved: Byte;
  322.     FRefCount: Integer;
  323.     FHandle: HDBIDB;
  324.     FSQLBased: Boolean;
  325.     FTransHandle: HDBIXAct;
  326.     FLocale: TLocale;
  327.     FSession: TSession;
  328.     FSessionName: string;
  329.     FParams: TStrings;
  330.     FDatabaseName: string;
  331.     FDatabaseType: string;
  332.     FAcquiredHandle: Boolean;
  333.     FOnLogin: TLoginEvent;
  334.     procedure CheckActive;
  335.     procedure CheckInactive;
  336.     procedure CheckDatabaseName;
  337.     procedure CheckDatabaseAlias(var Password: string);
  338.     procedure CheckSessionName(Required: Boolean);
  339.     procedure EndTransaction(TransEnd: EXEnd);
  340.     function GetAliasName: string;
  341.     function GetConnected: Boolean;
  342.     function GetDataSet(Index: Integer): TDBDataSet;
  343.     function GetDataSetCount: Integer;
  344.     function GetDirectory: string;
  345.     function GetDriverName: string;
  346.     function GetIsSQLBased: Boolean;
  347.     function GetInTransaction: Boolean;
  348.     function GetTraceFlags: TTraceFlags;
  349.     procedure LoadLocale;
  350.     procedure Login(LoginParams: TStrings);
  351.     procedure ParamsChanging(Sender: TObject);
  352.     procedure SetAliasName(const Value: string);
  353.     procedure SetConnected(Value: Boolean);
  354.     procedure SetDatabaseName(const Value: string);
  355.     procedure SetDatabaseType(const Value: string; Aliased: Boolean);
  356.     procedure SetDirectory(const Value: string);
  357.     procedure SetDriverName(const Value: string);
  358.     procedure SetHandle(Value: HDBIDB);
  359.     procedure SetKeepConnection(Value: Boolean);
  360.     procedure SetParams(Value: TStrings);
  361.     procedure SetTraceFlags(Value: TTraceFlags);
  362.     procedure SetSessionName(const Value: string);
  363.   protected
  364.     procedure Loaded; override;
  365.   public
  366.     constructor Create(AOwner: TComponent); override;
  367.     destructor Destroy; override;
  368.     procedure ApplyUpdates(const DataSets: array of TDBDataSet);
  369.     procedure Close;
  370.     procedure CloseDataSets;
  371.     procedure Commit;
  372.     procedure FlushSchemaCache(const TableName: string);
  373.     procedure Open;
  374.     procedure Rollback;
  375.     procedure StartTransaction;
  376.     procedure ValidateName(const Name: string);
  377.     property DataSetCount: Integer read GetDataSetCount;
  378.     property DataSets[Index: Integer]: TDBDataSet read GetDataSet;
  379.     property Directory: string read GetDirectory write SetDirectory;
  380.     property Handle: HDBIDB read FHandle write SetHandle;
  381.     property IsSQLBased: Boolean read FSQLBased;
  382.     property InTransaction: Boolean read GetInTransaction;
  383.     property Locale: TLocale read FLocale;
  384.     property Session: TSession read FSession;
  385.     property Temporary: Boolean read FTemporary write FTemporary;
  386.     property SessionAlias: Boolean read FSessionAlias;
  387.     property TraceFlags: TTraceFlags read GetTraceFlags write SetTraceFlags;
  388.   published
  389.     property AliasName: string read GetAliasName write SetAliasName;
  390.     property Connected: Boolean read GetConnected write SetConnected default False;
  391.     property DatabaseName: string read FDatabaseName write SetDatabaseName;
  392.     property DriverName: string read GetDriverName write SetDriverName;
  393.     property KeepConnection: Boolean read FKeepConnection write SetKeepConnection default True;
  394.     property LoginPrompt: Boolean read FLoginPrompt write FLoginPrompt default True;
  395.     property Params: TStrings read FParams write SetParams;
  396.     property SessionName: string read FSessionName write SetSessionName;
  397.     property TransIsolation: TTransIsolation read FTransIsolation write FTransIsolation default tiReadCommitted;
  398.     property OnLogin: TLoginEvent read FOnLogin write FOnLogin;
  399.   end;
  400.  
  401. { TDataSetDesigner }
  402.  
  403.   TDataEvent = (deFieldChange, deRecordChange, deDataSetChange,
  404.     deDataSetScroll, deLayoutChange, deUpdateRecord, deUpdateState,
  405.     deCheckBrowseMode, dePropertyChange, deFieldListChange,
  406.     deFocusControl);
  407.  
  408.   TDataSetDesigner = class(TObject)
  409.   private
  410.     FDataSet: TDataSet;
  411.     FSaveActive: Boolean;
  412.     FReserved: Byte;
  413.   public
  414.     constructor Create(DataSet: TDataSet);
  415.     destructor Destroy; override;
  416.     procedure BeginDesign;
  417.     procedure DataEvent(Event: TDataEvent; Info: Longint); virtual;
  418.     procedure EndDesign;
  419.     property DataSet: TDataSet read FDataSet;
  420.   end;
  421.  
  422. { TFieldDef }
  423.  
  424.   TFieldClass = class of TField;
  425.  
  426.   TFieldType = (ftUnknown, ftString, ftSmallint, ftInteger, ftWord,
  427.     ftBoolean, ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime,
  428.     ftBytes, ftVarBytes, ftAutoInc, ftBlob, ftMemo, ftGraphic,
  429.     ftFmtMemo, ftParadoxOle, ftDBaseOle, ftTypedBinary);
  430.  
  431.   TFieldDef = class
  432.   private
  433.     FOwner: TFieldDefs;
  434.     FName: string;
  435.     FDataType: TFieldType;
  436.     FRequired: Boolean;
  437.     FBDECalcField: Boolean;
  438.     FSize: Word;
  439.     FFieldNo: Integer;
  440.     function GetFieldClass: TFieldClass;
  441.   public
  442.     constructor Create(Owner: TFieldDefs; const Name: string;
  443.       DataType: TFieldType; Size: Word; Required: Boolean; FieldNo: Integer);
  444.     destructor Destroy; override;
  445.     function CreateField(Owner: TComponent): TField;
  446.     property BDECalcField: Boolean read FBDECalcField;
  447.     property DataType: TFieldType read FDataType;
  448.     property FieldClass: TFieldClass read GetFieldClass;
  449.     property FieldNo: Integer read FFieldNo;
  450.     property Name: string read FName;
  451.     property Required: Boolean read FRequired;
  452.     property Size: Word read FSize;
  453.   end;
  454.  
  455. { TFieldDefs }
  456.  
  457.   TFieldDefs = class
  458.   private
  459.     FDataSet: TDataSet;
  460.     FItems: TList;
  461.     FUpdated: Boolean;
  462.     FReserved: Byte;
  463.     function GetCount: Integer;
  464.     function GetItem(Index: Integer): TFieldDef;
  465.   public
  466.     constructor Create(DataSet: TDataSet);
  467.     destructor Destroy; override;
  468.     procedure Add(const Name: string; DataType: TFieldType; Size: Word;
  469.       Required: Boolean);
  470.     procedure AddFieldDesc(FieldDesc: FLDDesc; Required: Boolean;
  471.       FieldNo: Word);
  472.     procedure Assign(FieldDefs: TFieldDefs);
  473.     procedure Clear;
  474.     function Find(const Name: string): TFieldDef;
  475.     function IndexOf(const Name: string): Integer;
  476.     procedure Update;
  477.     property Count: Integer read GetCount;
  478.     property Items[Index: Integer]: TFieldDef read GetItem; default;
  479.   end;
  480.  
  481. { TDataSet }
  482.  
  483.   TBookmark = Pointer;
  484.   TBookmarkStr = String;
  485.  
  486.   PBufferList = ^TBufferList;
  487.   TBufferList = array[0..dsMaxBufferCount - 1] of PChar;
  488.  
  489.   TDataSetState = (dsInactive, dsBrowse, dsEdit, dsInsert,
  490.     dsSetKey, dsCalcFields, dsUpdateNew, dsUpdateOld, dsFilter);
  491.  
  492.   TGetMode = (gmCurrent, gmNext, gmPrior);
  493.  
  494.   TFilterOption = (foCaseInsensitive, foNoPartialCompare);
  495.   TFilterOptions = set of TFilterOption;
  496.  
  497.   TLocateOption = (loCaseInsensitive, loPartialKey);
  498.   TLocateOptions = set of TLocateOption;
  499.  
  500.   TResyncMode = set of (rmExact, rmCenter);
  501.  
  502.   TKeyIndex = (kiLookup, kiRangeStart, kiRangeEnd, kiCurRangeStart,
  503.     kiCurRangeEnd, kiSave);
  504.  
  505.   PKeyBuffer = ^TKeyBuffer;
  506.   TKeyBuffer = record
  507.     Modified: Boolean;
  508.     Exclusive: Boolean;
  509.     FieldCount: Integer;
  510.     Data: record end;
  511.   end;
  512.  
  513.   TDataAction = (daFail, daAbort, daRetry);
  514.  
  515.   TDataSetNotifyEvent = procedure(DataSet: TDataSet) of object;
  516.   TDataSetErrorEvent = procedure(DataSet: TDataSet; E: EDatabaseError;
  517.     var Action: TDataAction) of object;
  518.  
  519.  
  520.   TUpdateStatus = (usUnmodified, usModified, usInserted, usDeleted);
  521.   TUpdateKind = (ukModify, ukInsert, ukDelete);
  522.   TUpdateAction = (uaFail, uaAbort, uaSkip, uaRetry, uaApplied);
  523.   TUpdateRecordTypes = set of (rtModified, rtInserted, rtDeleted, rtUnmodified);
  524.   TUpdateErrorEvent = procedure(DataSet: TDataSet; E: EDatabaseError;
  525.     UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction) of object;
  526.   TUpdateRecordEvent = procedure(DataSet: TDataSet; UpdateKind: TUpdateKind;
  527.     var UpdateAction: TUpdateAction) of object;
  528.   TOnServerYieldEvent = procedure(DataSet: TDataSet; var AbortQuery: Boolean) of object;
  529.   TDataSetUpdateObject = class(TComponent)
  530.   protected
  531.     function GetDataSet: TDataSet; virtual; abstract;
  532.     procedure SetDataSet(ADataSet: TDataSet); virtual; abstract;
  533.     procedure Apply(UpdateKind: TUpdateKind); virtual; abstract;
  534.     property DataSet: TDataSet read GetDataSet write SetDataSet;
  535.   end;
  536.  
  537.   TFilterRecordEvent = procedure(DataSet: TDataSet;
  538.     var Accept: Boolean) of object;
  539.  
  540.   TRecNoStatus = (rnDbase, rnParadox, rnNotSupported);
  541.  
  542.   PRecInfo = ^TRecInfo;
  543.   TRecInfo = record
  544.     UpdateStatus: TUpdateStatus;
  545.     RecordNumber: Longint;
  546.   end;
  547.  
  548.   TDataOperation = function: DBIResult of object;
  549.  
  550.   TDataSet = class(TComponent)
  551.   private
  552.     FFields: TList;
  553.     FDataSources: TList;
  554.     FFieldDefs: TFieldDefs;
  555.     FBuffers: PBufferList;
  556.     FBufListSize: Integer;
  557.     FBufferCount: Integer;
  558.     FRecordCount: Integer;
  559.     FActiveRecord: Integer;
  560.     FCurrentRecord: Integer;
  561.     FHandle: HDBICur;
  562.     FBOF: Boolean;
  563.     FEOF: Boolean;
  564.     FState: TDataSetState;
  565.     FAutoCalcFields: Boolean;
  566.     FDefaultFields: Boolean;
  567.     FCanModify: Boolean;
  568.     FModified: Boolean;
  569.     FStreamedActive: Boolean;
  570.     FInfoQueryMode: Boolean;
  571.     FDisableState: TDataSetState;
  572.     FEnableEvent: TDataEvent;
  573.     FFiltered: Boolean;
  574.     FFound: Boolean;
  575.     FRecProps: RecProps;
  576.     FRawFieldCount: Integer;
  577.     FRecordSize: Word;
  578.     FBookmarkSize: Word;
  579.     FRecInfoOfs: Word;
  580.     FBookmarkOfs: Word;
  581.     FRecNoStatus: TRecNoStatus;
  582.     FKeySize: Word;
  583.     FExpIndex: Boolean;
  584.     FCaseInsIndex: Boolean;
  585.     FCalcFieldsSize: Word;
  586.     FRecBufSize: Word;
  587.     FDisableCount: Integer;
  588.     FFirstDataLink: TDataLink;
  589.     FLocale: TLocale;
  590.     FDesigner: TDataSetDesigner;
  591.     FKeyBuffers: array[TKeyIndex] of PKeyBuffer;
  592.     FKeyBuffer: PKeyBuffer;
  593.     FCalcBuffer: PChar;
  594.     FFilterText: string;
  595.     FFilterOptions: TFilterOptions;
  596.     FExprFilter: HDBIFilter;
  597.     FFuncFilter: HDBIFilter;
  598.     FFilterBuffer: PChar;
  599.     FIndexFieldCount: Integer;
  600.     FIndexFieldMap: DBIKey;
  601.     FBDECalcFields: Boolean;
  602.     FCachedUpdates: Boolean;
  603.     FUpdateCBBuf: PDELAYUPDCbDesc;
  604.     FUpdateCallback: TBDECallback;
  605.     FInUpdateCallback: Boolean;
  606.     FUpdateErrCode: DBIResult;
  607.     FAsyncCallback: TBDECallback;
  608.     FCBYieldStep: CBYieldStep;
  609.     FOnServerYield: TOnServerYieldEvent;
  610.     FUpdateObject: TDataSetUpdateObject;
  611.     FBeforeOpen: TDataSetNotifyEvent;
  612.     FAfterOpen: TDataSetNotifyEvent;
  613.     FBeforeClose: TDataSetNotifyEvent;
  614.     FAfterClose: TDataSetNotifyEvent;
  615.     FBeforeInsert: TDataSetNotifyEvent;
  616.     FAfterInsert: TDataSetNotifyEvent;
  617.     FBeforeEdit: TDataSetNotifyEvent;
  618.     FAfterEdit: TDataSetNotifyEvent;
  619.     FBeforePost: TDataSetNotifyEvent;
  620.     FAfterPost: TDataSetNotifyEvent;
  621.     FBeforeCancel: TDataSetNotifyEvent;
  622.     FAfterCancel: TDataSetNotifyEvent;
  623.     FBeforeDelete: TDataSetNotifyEvent;
  624.     FAfterDelete: TDataSetNotifyEvent;
  625.     FOnNewRecord: TDataSetNotifyEvent;
  626.     FOnCalcFields: TDataSetNotifyEvent;
  627.     FOnUpdateError: TUpdateErrorEvent;
  628.     FOnUpdateRecord: TUpdateRecordEvent;
  629.     FOnFilterRecord: TFilterRecordEvent;
  630.     FOnEditError: TDataSetErrorEvent;
  631.     FOnPostError: TDataSetErrorEvent;
  632.     FOnDeleteError: TDataSetErrorEvent;
  633.     procedure ActivateBuffers;
  634.     procedure ActivateFilters;
  635.     procedure AddDataSource(DataSource: TDataSource);
  636.     procedure AddField(Field: TField);
  637.     procedure AddRecord(const Values: array of const; Append: Boolean);
  638.     procedure AllocKeyBuffers;
  639.     procedure AllocDelUpdCBBuf(Allocate: Boolean);
  640.     procedure BeginInsertAppend;
  641.     procedure BindFields(Binding: Boolean);
  642.     function CachedUpdateCallBack(CBInfo: Pointer): CBRType;
  643.     procedure CalculateBDEFields;
  644.     procedure CalculateFields;
  645.     procedure CheckCanModify;
  646.     procedure CheckCachedUpdateMode;
  647.     procedure CheckFieldName(const FieldName: string);
  648.     procedure CheckFieldNames(const FieldNames: string);
  649.     procedure CheckOperation(Operation: TDataOperation;
  650.       ErrorEvent: TDataSetErrorEvent);
  651.     procedure CheckRequiredFields;
  652.     procedure CheckSetKeyMode;
  653.     procedure CopyBuffer(SourceIndex, DestIndex: Integer);
  654.     function CreateExprFilter(const Expr: string;
  655.       Options: TFilterOptions; Priority: Integer): HDBIFilter;
  656.     procedure CreateFields;
  657.     function CreateFuncFilter(FilterFunc: Pointer;
  658.       Priority: Integer): HDBIFilter;
  659.     function CreateLookupFilter(Fields: TList; const Values: Variant;
  660.       Options: TLocateOptions; Priority: Integer): HDBIFilter;
  661.     procedure DeactivateFilters;
  662.     function DeleteRecord: DBIResult;
  663.     procedure DestroyFields;
  664.     function EditRecord: DBIResult;
  665.     procedure EndInsertAppend;
  666.     function FieldByNumber(FieldNo: Integer): TField;
  667.     function FindRecord(Restart, GoForward: Boolean): Boolean;
  668.     procedure FreeFieldBuffers;
  669.     procedure FreeKeyBuffers;
  670.     function GetActive: Boolean;
  671.     function GetBookmarkStr: TBookmarkStr;
  672.     procedure GetCalcFields(Index: Integer);
  673.     function GetField(Index: Integer): TField;
  674.     function GetFieldCount: Integer;
  675.     function GetFieldValue(const FieldName: string): Variant;
  676.     procedure GetIndexInfo;
  677.     function GetNextRecord: Boolean;
  678.     function GetNextRecords: Integer;
  679.     function GetPriorRecord: Boolean;
  680.     function GetPriorRecords: Integer;
  681.     function GetRecord(Index: Integer; GetMode: TGetMode): DBIResult;
  682.     function GetRecordCount: Longint;
  683.     function GetUpdatesPending: Boolean;
  684.     function InitKeyBuffer(Buffer: PKeyBuffer): PKeyBuffer;
  685.     procedure InitRecord(Buffer: PChar);
  686.     procedure InternalClose;
  687.     procedure InternalOpen;
  688.     function LocateRecord(const KeyFields: string; const KeyValues: Variant;
  689.       Options: TLocateOptions; SyncCursor: Boolean): Boolean;
  690.     function MapsToIndex(Fields: TList; CaseInsensitive: Boolean): Boolean;
  691.     procedure MoveBuffer(CurIndex, NewIndex: Integer);
  692.     procedure PostKeyBuffer(Commit: Boolean);
  693.     function PostRecord: DBIResult;
  694.     function RecordFilter(RecBuf: Pointer; RecNo: Integer): Smallint; stdcall;
  695.     procedure RemoveDataSource(DataSource: TDataSource);
  696.     procedure RemoveField(Field: TField);
  697.     procedure SetActive(Value: Boolean);
  698.     procedure SetBookmarkStr(const Value: TBookmarkStr);
  699.     procedure SetBufferCount(Value: Integer);
  700.     procedure SetBufListSize(Value: Integer);
  701.     procedure SetCurrentRecord(Index: Integer);
  702.     procedure SetField(Index: Integer; Value: TField);
  703.     procedure SetFieldDefs(Value: TFieldDefs);
  704.     procedure SetFieldValue(const FieldName: string; const Value: Variant);
  705.     procedure SetFilterData(const Text: string; Options: TFilterOptions);
  706.     procedure SetFiltered(Value: Boolean);
  707.     procedure SetFilterHandle(var Filter: HDBIFilter; Value: HDBIFilter);
  708.     procedure SetFilterOptions(Value: TFilterOptions);
  709.     procedure SetFilterText(const Value: string);
  710.     procedure SetOnFilterRecord(const Value: TFilterRecordEvent);
  711.     procedure SetOnUpdateError(UpdateEvent: TUpdateErrorEvent);
  712.     procedure SetState(Value: TDataSetState);
  713.     procedure UpdateBufferCount;
  714.     function UpdateCallbackRequired: Boolean;
  715.     procedure UpdateFieldDefs;
  716.     function YieldCallBack(CBInfo: Pointer): CBRType;
  717.   protected
  718.     procedure CheckInactive;
  719.     procedure ClearBuffers;
  720.     procedure CloseCursor; virtual;
  721.     function CreateHandle: HDBICur; virtual;
  722.     procedure DataEvent(Event: TDataEvent; Info: Longint); virtual;
  723.     procedure DestroyHandle; virtual;
  724.     procedure DestroyLookupCursor; virtual;
  725.     procedure DoAfterCancel; virtual;
  726.     procedure DoAfterClose; virtual;
  727.     procedure DoAfterDelete; virtual;
  728.     procedure DoAfterEdit; virtual;
  729.     procedure DoAfterInsert; virtual;
  730.     procedure DoAfterOpen; virtual;
  731.     procedure DoAfterPost; virtual;
  732.     procedure DoBeforeCancel; virtual;
  733.     procedure DoBeforeClose; virtual;
  734.     procedure DoBeforeDelete; virtual;
  735.     procedure DoBeforeEdit; virtual;
  736.     procedure DoBeforeInsert; virtual;
  737.     procedure DoBeforeOpen; virtual;
  738.     procedure DoBeforePost; virtual;
  739.     procedure DoOnCalcFields; virtual;
  740.     procedure DoOnNewRecord; virtual;
  741.     function GetCanModify: Boolean; virtual;
  742.     function GetDataSource: TDataSource; virtual;
  743.     function GetIndexField(Index: Integer): TField;
  744.     function GetIndexFieldCount: Integer;
  745.     function GetKeyBuffer(KeyIndex: TKeyIndex): PKeyBuffer;
  746.     function GetKeyExclusive: Boolean;
  747.     function GetKeyFieldCount: Integer;
  748.     function GetLookupCursor(const KeyFields: string;
  749.       CaseInsensitive: Boolean): HDBICur; virtual;
  750.     function GetRecordNumber: Longint; virtual;
  751.     procedure InitFieldDefs; virtual;
  752.     procedure Loaded; override;
  753.     procedure OpenCursor; virtual;
  754.     procedure PrepareCursor; virtual;
  755.     function ResetCursorRange: Boolean;
  756.     function SetCursorRange: Boolean;
  757.     procedure SetIndexField(Index: Integer; Value: TField);
  758.     procedure SetKeyBuffer(KeyIndex: TKeyIndex; Clear: Boolean);
  759.     procedure SetKeyExclusive(Value: Boolean);
  760.     procedure SetKeyFieldCount(Value: Integer);
  761.     procedure SetKeyFields(KeyIndex: TKeyIndex; const Values: array of const);
  762.     procedure SetLinkRanges(MasterFields: TList);
  763.     procedure SetLocale(Value: TLocale);
  764.     procedure SetName(const Value: TComponentName); override;
  765.     procedure SwitchToIndex(const IndexName, TagName: string);
  766.     procedure GetChildren(Proc: TGetChildProc); override;
  767.     procedure SetChildOrder(Component: TComponent; Order: Integer); override;
  768.     property InfoQueryMode: Boolean read FInfoQueryMode;
  769.     procedure SetCachedUpdates(Value: Boolean);
  770.     procedure SetupCallBack(Value: Boolean);
  771.     function ProcessUpdates(UpdCmd: DBIDelayedUpdCmd): DBIResult;
  772.     function GetUpdateRecordSet: TUpdateRecordTypes;
  773.     procedure SetUpdateRecordSet(RecordTypes: TUpdateRecordTypes);
  774.     procedure SetUpdateObject(Value: TDataSetUpdateObject);
  775.     function ForceUpdateCallback: Boolean;
  776.   public
  777.     constructor Create(AOwner: TComponent); override;
  778.     destructor Destroy; override;
  779.     function ActiveBuffer: PChar;
  780.     procedure Append;
  781.     procedure AppendRecord(const Values: array of const);
  782.     procedure Cancel;
  783.     procedure CheckBrowseMode;
  784.     procedure ClearFields;
  785.     procedure Close;
  786.     function  ControlsDisabled: Boolean;
  787.     procedure CursorPosChanged;
  788.     procedure Delete;
  789.     procedure DisableControls;
  790.     procedure Edit;
  791.     procedure EnableControls;
  792.     procedure FetchAll;
  793.     function FieldByName(const FieldName: string): TField;
  794.     function FindField(const FieldName: string): TField;
  795.     function FindFirst: Boolean;
  796.     function FindLast: Boolean;
  797.     function FindNext: Boolean;
  798.     function FindPrior: Boolean;
  799.     procedure First;
  800.     procedure FreeBookmark(Bookmark: TBookmark);
  801.     function GetBookmark: TBookmark;
  802.     function GetCurrentRecord(Buffer: PChar): Boolean;
  803.     procedure GetFieldList(List: TList; const FieldNames: string);
  804.     procedure GetFieldNames(List: TStrings);
  805.     procedure GotoBookmark(Bookmark: TBookmark);
  806.     procedure Insert;
  807.     procedure InsertRecord(const Values: array of const);
  808.     function IsLinkedTo(DataSource: TDataSource): Boolean;
  809.     procedure Last;
  810.     function Locate(const KeyFields: string; const KeyValues: Variant;
  811.       Options: TLocateOptions): Boolean;
  812.     function Lookup(const KeyFields: string; const KeyValues: Variant;
  813.       const ResultFields: string): Variant;
  814.     function MoveBy(Distance: Integer): Integer;
  815.     procedure Next;
  816.     procedure Open;
  817.     procedure Post;
  818.     procedure Prior;
  819.     procedure Refresh;
  820.     procedure Resync(Mode: TResyncMode);
  821.     procedure SetFields(const Values: array of const);
  822.     procedure SetDetailFields(MasterFields: TList);
  823.     procedure UpdateCursorPos;
  824.     procedure UpdateRecord;
  825.     procedure ApplyUpdates;
  826.     procedure CommitUpdates;
  827.     procedure CancelUpdates;
  828.     procedure RevertRecord;
  829.     function UpdateStatus: TUpdateStatus;
  830.     property BOF: Boolean read FBOF;
  831.     property Bookmark: TBookmarkStr read GetBookmarkStr write SetBookmarkStr;
  832.     property CanModify: Boolean read GetCanModify;
  833.     property DataSource: TDataSource read GetDataSource;
  834.     property DefaultFields: Boolean read FDefaultFields;
  835.     property Designer: TDataSetDesigner read FDesigner;
  836.     property EOF: Boolean read FEOF;
  837.     property ExpIndex: Boolean read FExpIndex;
  838.     property FieldCount: Integer read GetFieldCount;
  839.     property FieldDefs: TFieldDefs read FFieldDefs write SetFieldDefs;
  840.     property Fields[Index: Integer]: TField read GetField write SetField;
  841.     property FieldValues[const FieldName: string]: Variant read GetFieldValue write SetFieldValue; default;
  842.     property Found: Boolean read FFound;
  843.     property Handle: HDBICur read FHandle;
  844.     property KeySize: Word read FKeySize;
  845.     property Locale: TLocale read FLocale;
  846.     property Modified: Boolean read FModified;
  847.     property RecordCount: Longint read GetRecordCount;
  848.     property RecNo: Longint read GetRecordNumber;
  849.     property RecordSize: Word read FRecordSize;
  850.     property State: TDataSetState read FState;
  851.     property UpdateObject: TDataSetUpdateObject read FUpdateObject write SetUpdateObject;
  852.     property UpdateRecordTypes: TUpdateRecordTypes read GetUpdateRecordSet write SetUpdateRecordSet;
  853.     property UpdatesPending: Boolean read GetUpdatesPending;
  854.   published
  855.     property Active: Boolean read GetActive write SetActive default False;
  856.     property AutoCalcFields: Boolean read FAutoCalcFields write FAutoCalcFields default True;
  857.     property CachedUpdates: Boolean read FCachedUpdates write SetCachedUpdates default False;
  858.     property Filter: string read FFilterText write SetFilterText;
  859.     property Filtered: Boolean read FFiltered write SetFiltered default False;
  860.     property FilterOptions: TFilterOptions read FFilterOptions write SetFilterOptions default [];
  861.     property BeforeOpen: TDataSetNotifyEvent read FBeforeOpen write FBeforeOpen;
  862.     property AfterOpen: TDataSetNotifyEvent read FAfterOpen write FAfterOpen;
  863.     property BeforeClose: TDataSetNotifyEvent read FBeforeClose write FBeforeClose;
  864.     property AfterClose: TDataSetNotifyEvent read FAfterClose write FAfterClose;
  865.     property BeforeInsert: TDataSetNotifyEvent read FBeforeInsert write FBeforeInsert;
  866.     property AfterInsert: TDataSetNotifyEvent read FAfterInsert write FAfterInsert;
  867.     property BeforeEdit: TDataSetNotifyEvent read FBeforeEdit write FBeforeEdit;
  868.     property AfterEdit: TDataSetNotifyEvent read FAfterEdit write FAfterEdit;
  869.     property BeforePost: TDataSetNotifyEvent read FBeforePost write FBeforePost;
  870.     property AfterPost: TDataSetNotifyEvent read FAfterPost write FAfterPost;
  871.     property BeforeCancel: TDataSetNotifyEvent read FBeforeCancel write FBeforeCancel;
  872.     property AfterCancel: TDataSetNotifyEvent read FAfterCancel write FAfterCancel;
  873.     property BeforeDelete: TDataSetNotifyEvent read FBeforeDelete write FBeforeDelete;
  874.     property AfterDelete: TDataSetNotifyEvent read FAfterDelete write FAfterDelete;
  875.     property OnNewRecord: TDataSetNotifyEvent read FOnNewRecord write FOnNewRecord;
  876.     property OnCalcFields: TDataSetNotifyEvent read FOnCalcFields write FOnCalcFields;
  877.     property OnFilterRecord: TFilterRecordEvent read FOnFilterRecord write SetOnFilterRecord;
  878.     property OnServerYield: TOnServerYieldEvent read FOnServerYield write FOnServerYield;
  879.     property OnUpdateError: TUpdateErrorEvent read FOnUpdateError write SetOnUpdateError;
  880.     property OnUpdateRecord: TUpdateRecordEvent read FOnUpdateRecord write FOnUpdateRecord;
  881.     property OnEditError: TDataSetErrorEvent read FOnEditError write FOnEditError;
  882.     property OnPostError: TDataSetErrorEvent read FOnPostError write FOnPostError;
  883.     property OnDeleteError: TDataSetErrorEvent read FOnDeleteError write FOnDeleteError;
  884.   end;
  885.  
  886. { TDBDataSet }
  887.  
  888.   TUpdateMode = (upWhereAll, upWhereChanged, upWhereKeyOnly);
  889.   TDBFlags = set of 0..15;
  890.  
  891.   TDBDataSet = class(TDataSet)
  892.   private
  893.     FDBFlags: TDBFlags;
  894.     FUpdateMode: TUpdateMode;
  895.     FReserved: Byte;
  896.     FDatabase: TDatabase;
  897.     FDatabaseName: string;
  898.     FSessionName: string;
  899.     procedure CheckDBSessionName;
  900.     function GetDBFlag(Flag: Integer): Boolean;
  901.     function GetDBHandle: HDBIDB;
  902.     function GetDBLocale: TLocale;
  903.     function GetDBSession: TSession;
  904.     procedure SetDatabaseName(const Value: string);
  905.     procedure SetSessionName(const Value: string);
  906.     procedure SetUpdateMode(const Value: TUpdateMode);
  907.   protected
  908.     procedure CloseCursor; override;
  909.     procedure Disconnect; virtual;
  910.     procedure OpenCursor; override;
  911.     procedure SetDBFlag(Flag: Integer; Value: Boolean); virtual;
  912.     property DBFlags: TDBFlags read FDBFlags;
  913.     property UpdateMode: TUpdateMode read FUpdateMode write SetUpdateMode default upWhereAll;
  914.   public
  915.     function CheckOpen(Status: DBIResult): Boolean;
  916.     property Database: TDatabase read FDatabase;
  917.     property DBHandle: HDBIDB read GetDBHandle;
  918.     property DBLocale: TLocale read GetDBLocale;
  919.     property DBSession: TSession read GetDBSession;
  920.   published
  921.     property DatabaseName: string read FDatabaseName write SetDatabaseName;
  922.     property SessionName: string read FSessionName write SetSessionName;
  923.   end;
  924.  
  925. { TDataSource }
  926.  
  927.   TDataChangeEvent = procedure(Sender: TObject; Field: TField) of object;
  928.  
  929.   TDataSource = class(TComponent)
  930.   private
  931.     FDataSet: TDataSet;
  932.     FDataLinks: TList;
  933.     FEnabled: Boolean;
  934.     FAutoEdit: Boolean;
  935.     FState: TDataSetState;
  936.     FReserved: Byte;
  937.     FOnStateChange: TNotifyEvent;
  938.     FOnDataChange: TDataChangeEvent;
  939.     FOnUpdateData: TNotifyEvent;
  940.     procedure AddDataLink(DataLink: TDataLink);
  941.     procedure DataEvent(Event: TDataEvent; Info: Longint);
  942.     procedure NotifyDataLinks(Event: TDataEvent; Info: Longint);
  943.     procedure RemoveDataLink(DataLink: TDataLink);
  944.     procedure SetDataSet(ADataSet: TDataSet);
  945.     procedure SetEnabled(Value: Boolean);
  946.     procedure SetState(Value: TDataSetState);
  947.     procedure UpdateState;
  948.   public
  949.     constructor Create(AOwner: TComponent); override;
  950.     destructor Destroy; override;
  951.     procedure Edit;
  952.     function IsLinkedTo(DataSet: TDataSet): Boolean;
  953.     property State: TDataSetState read FState;
  954.   published
  955.     property AutoEdit: Boolean read FAutoEdit write FAutoEdit default True;
  956.     property DataSet: TDataSet read FDataSet write SetDataSet;
  957.     property Enabled: Boolean read FEnabled write SetEnabled default True;
  958.     property OnStateChange: TNotifyEvent read FOnStateChange write FOnStateChange;
  959.     property OnDataChange: TDataChangeEvent read FOnDataChange write FOnDataChange;
  960.     property OnUpdateData: TNotifyEvent read FOnUpdateData write FOnUpdateData;
  961.   end;
  962.  
  963. { TField }
  964.  
  965.   TFieldKind = (fkData, fkCalculated, fkLookup);
  966.  
  967.   TFieldNotifyEvent = procedure(Sender: TField) of object;
  968.   TFieldGetTextEvent = procedure(Sender: TField; var Text: string;
  969.     DisplayText: Boolean) of object;
  970.   TFieldSetTextEvent = procedure(Sender: TField; const Text: string) of object;
  971.   TFieldRef = ^TField;
  972.  
  973.   TField = class(TComponent)
  974.   private
  975.     FDataSet: TDataSet;
  976.     FFieldName: string;
  977.     FDataType: TFieldType;
  978.     FReadOnly: Boolean;
  979.     FFieldKind: TFieldKind;
  980.     FAlignment: TAlignment;
  981.     FVisible: Boolean;
  982.     FRequired: Boolean;
  983.     FValidating: Boolean;
  984.     FSize: Word;
  985.     FDataSize: Word;
  986.     FFieldNo: Integer;
  987.     FOffset: Word;
  988.     FDisplayWidth: Integer;
  989.     FDisplayLabel: string;
  990.     FEditMask: string;
  991.     FValueBuffer: Pointer;
  992.     FLookupDataSet: TDataSet;
  993.     FKeyFields: string;
  994.     FLookupKeyFields: string;
  995.     FLookupResultField: string;
  996.     FAttributeSet: string;
  997.     FOnChange: TFieldNotifyEvent;
  998.     FOnValidate: TFieldNotifyEvent;
  999.     FOnGetText: TFieldGetTextEvent;
  1000.     FOnSetText: TFieldSetTextEvent;
  1001.     procedure Bind(Binding: Boolean);
  1002.     procedure CalcLookupValue;
  1003.     function GetBDECalcField: Boolean;
  1004.     function GetCalculated: Boolean;
  1005.     function GetDisplayLabel: string;
  1006.     function GetDisplayName: string;
  1007.     function GetDisplayText: string;
  1008.     function GetDisplayWidth: Integer;
  1009.     function GetEditText: string;
  1010.     function GetIndex: Integer;
  1011.     function GetIsIndexField: Boolean;
  1012.     function GetIsNull: Boolean;
  1013.     function GetLookup: Boolean;
  1014.     function GetNewValue: Variant;
  1015.     function GetOldValue: Variant;
  1016.     function GetUpdateValue(ValueState: TDataSetState): Variant;
  1017.     function IsDisplayLabelStored: Boolean;
  1018.     function IsDisplayWidthStored: Boolean;
  1019.     procedure ReadAttributeSet(Reader: TReader);
  1020.     procedure SetAlignment(Value: TAlignment);
  1021.     procedure SetCalculated(Value: Boolean);
  1022.     procedure SetDataSet(ADataSet: TDataSet);
  1023.     procedure SetDisplayLabel(Value: string);
  1024.     procedure SetDisplayWidth(Value: Integer);
  1025.     procedure SetEditMask(const Value: string);
  1026.     procedure SetEditText(const Value: string);
  1027.     procedure SetFieldKind(Value: TFieldKind);
  1028.     procedure SetFieldName(const Value: string);
  1029.     procedure SetIndex(Value: Integer);
  1030.     procedure SetLookup(Value: Boolean);
  1031.     procedure SetLookupDataSet(Value: TDataSet);
  1032.     procedure SetLookupKeyFields(const Value: string);
  1033.     procedure SetLookupResultField(const Value: string);
  1034.     procedure SetKeyFields(const Value: string);
  1035.     procedure SetNewValue(const Value: Variant);
  1036.     procedure SetVisible(Value: Boolean);
  1037.     procedure UpdateDataSize;
  1038.     procedure WriteAttributeSet(Writer: TWriter);
  1039.   protected
  1040.     procedure AccessError(const TypeName: string);
  1041.     procedure CheckInactive;
  1042.     procedure Change; virtual;
  1043.     procedure DataChanged;
  1044.     procedure DefineProperties(Filer: TFiler); override;
  1045.     procedure FreeBuffers; virtual;
  1046.     function GetAsBoolean: Boolean; virtual;
  1047.     function GetAsCurrency: Currency; virtual;
  1048.     function GetAsDateTime: TDateTime; virtual;
  1049.     function GetAsFloat: Double; virtual;
  1050.     function GetAsInteger: Longint; virtual;
  1051.     function GetAsString: string; virtual;
  1052.     function GetAsVariant: Variant; virtual;
  1053.     function GetCanModify: Boolean;
  1054.     function GetDefaultWidth: Integer; virtual;
  1055.     function GetParentComponent: TComponent; override;
  1056.     procedure GetText(var Text: string; DisplayText: Boolean); virtual;
  1057.     function HasParent: Boolean; override;
  1058.     procedure Notification(AComponent: TComponent;
  1059.       Operation: TOperation); override;
  1060.     procedure PropertyChanged(LayoutAffected: Boolean);
  1061.     procedure ReadState(Reader: TReader); override;
  1062.     procedure SetAsBoolean(Value: Boolean); virtual;
  1063.     procedure SetAsCurrency(Value: Currency); virtual;
  1064.     procedure SetAsDateTime(Value: TDateTime); virtual;
  1065.     procedure SetAsFloat(Value: Double); virtual;
  1066.     procedure SetAsInteger(Value: Longint); virtual;
  1067.     procedure SetAsString(const Value: string); virtual;
  1068.     procedure SetAsVariant(const Value: Variant); virtual;
  1069.     procedure SetDataType(Value: TFieldType);
  1070.     procedure SetSize(Value: Word);
  1071.     procedure SetParentComponent(AParent: TComponent); override;
  1072.     procedure SetText(const Value: string); virtual;
  1073.     procedure SetVarValue(const Value: Variant); virtual;
  1074.   public
  1075.     constructor Create(AOwner: TComponent); override;
  1076.     destructor Destroy; override;
  1077.     procedure Assign(Source: TPersistent); override;
  1078.     procedure AssignValue(const Value: TVarRec);
  1079.     procedure Clear; virtual;
  1080.     procedure FocusControl;
  1081.     function GetData(Buffer: Pointer): Boolean;
  1082.     function IsValidChar(InputChar: Char): Boolean; virtual;
  1083.     procedure SetData(Buffer: Pointer);
  1084.     procedure SetFieldType(Value: TFieldType); virtual;
  1085.     property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean;
  1086.     property AsCurrency: Currency read GetAsCurrency write SetAsCurrency;
  1087.     property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
  1088.     property AsFloat: Double read GetAsFloat write SetAsFloat;
  1089.     property AsInteger: Longint read GetAsInteger write SetAsInteger;
  1090.     property AsString: string read GetAsString write SetAsString;
  1091.     property AsVariant: Variant read GetAsVariant write SetAsVariant;
  1092.     property AttributeSet: string read FAttributeSet write FAttributeSet;
  1093.     property BDECalcField: Boolean read GetBDECalcField;
  1094.     property CanModify: Boolean read GetCanModify;
  1095.     property DataSet: TDataSet read FDataSet write SetDataSet stored False;
  1096.     property DataSize: Word read FDataSize;
  1097.     property DataType: TFieldType read FDataType;
  1098.     property DisplayName: string read GetDisplayName;
  1099.     property DisplayText: string read GetDisplayText;
  1100.     property EditMask: string read FEditMask write SetEditMask;
  1101.     property EditMaskPtr: string read FEditMask;
  1102.     property FieldKind: TFieldKind read FFieldKind write SetFieldKind;
  1103.     property FieldNo: Integer read FFieldNo;
  1104.     property IsIndexField: Boolean read GetIsIndexField;
  1105.     property IsNull: Boolean read GetIsNull;
  1106.     property Size: Word read FSize write SetSize;
  1107.     property Text: string read GetEditText write SetEditText;
  1108.     property Value: Variant read GetAsVariant write SetAsVariant;
  1109.     property NewValue: Variant read GetNewValue write SetNewValue;
  1110.     property OldValue: Variant read GetOldValue;
  1111.   published
  1112.     property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
  1113.     property Calculated: Boolean read GetCalculated write SetCalculated default False;
  1114.     property DisplayLabel: string read GetDisplayLabel write SetDisplayLabel
  1115.       stored IsDisplayLabelStored;
  1116.     property DisplayWidth: Integer read GetDisplayWidth write SetDisplayWidth
  1117.       stored IsDisplayWidthStored;
  1118.     property FieldName: string read FFieldName write SetFieldName;
  1119.     property Index: Integer read GetIndex write SetIndex stored False;
  1120.     property Lookup: Boolean read GetLookup write SetLookup default False;
  1121.     property LookupDataSet: TDataSet read FLookupDataSet write SetLookupDataSet;
  1122.     property LookupKeyFields: string read FLookupKeyFields write SetLookupKeyFields;
  1123.     property LookupResultField: string read FLookupResultField write SetLookupResultField;
  1124.     property KeyFields: string read FKeyFields write SetKeyFields;
  1125.     property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
  1126.     property Required: Boolean read FRequired write FRequired default False;
  1127.     property Visible: Boolean read FVisible write SetVisible default True;
  1128.     property OnChange: TFieldNotifyEvent read FOnChange write FOnChange;
  1129.     property OnGetText: TFieldGetTextEvent read FOnGetText write FOnGetText;
  1130.     property OnSetText: TFieldSetTextEvent read FOnSetText write FOnSetText;
  1131.     property OnValidate: TFieldNotifyEvent read FOnValidate write FOnValidate;
  1132.   end;
  1133.  
  1134. { TDataLink }
  1135.  
  1136.   TDataLink = class(TPersistent)
  1137.   private
  1138.     FDataSource: TDataSource;
  1139.     FNext: TDataLink;
  1140.     FBufferCount: Integer;
  1141.     FFirstRecord: Integer;
  1142.     FReadOnly: Boolean;
  1143.     FActive: Boolean;
  1144.     FEditing: Boolean;
  1145.     FUpdating: Boolean;
  1146.     FDataSourceFixed: Boolean;
  1147.     procedure DataEvent(Event: TDataEvent; Info: Longint);
  1148.     function GetActiveRecord: Integer;
  1149.     function GetDataSet: TDataSet;
  1150.     function GetRecordCount: Integer;
  1151.     procedure SetActive(Value: Boolean);
  1152.     procedure SetActiveRecord(Value: Integer);
  1153.     procedure SetBufferCount(Value: Integer);
  1154.     procedure SetDataSource(ADataSource: TDataSource);
  1155.     procedure SetEditing(Value: Boolean);
  1156.     procedure SetReadOnly(Value: Boolean);
  1157.     procedure UpdateRange;
  1158.     procedure UpdateState;
  1159.   protected
  1160.     procedure ActiveChanged; virtual;
  1161.     procedure CheckBrowseMode; virtual;
  1162.     procedure DataSetChanged; virtual;
  1163.     procedure DataSetScrolled(Distance: Integer); virtual;
  1164.     procedure FocusControl(Field: TFieldRef); virtual;
  1165.     procedure EditingChanged; virtual;
  1166.     procedure LayoutChanged; virtual;
  1167.     procedure RecordChanged(Field: TField); virtual;
  1168.     procedure UpdateData; virtual;
  1169.   public
  1170.     constructor Create;
  1171.     destructor Destroy; override;
  1172.     function Edit: Boolean;
  1173.     procedure UpdateRecord;
  1174.     property Active: Boolean read FActive;
  1175.     property ActiveRecord: Integer read GetActiveRecord write SetActiveRecord;
  1176.     property BufferCount: Integer read FBufferCount write SetBufferCount;
  1177.     property DataSet: TDataSet read GetDataSet;
  1178.     property DataSource: TDataSource read FDataSource write SetDataSource;
  1179.     property DataSourceFixed: Boolean read FDataSourceFixed write FDataSourceFixed;
  1180.     property Editing: Boolean read FEditing;
  1181.     property ReadOnly: Boolean read FReadOnly write SetReadOnly;
  1182.     property RecordCount: Integer read GetRecordCount;
  1183.   end;
  1184.  
  1185. const
  1186.   dsEditModes = [dsEdit, dsInsert, dsSetKey];
  1187.  
  1188. function AnsiToNative(Locale: TLocale; const AnsiStr: string;
  1189.   NativeStr: PChar; MaxLen: Integer): PChar;
  1190. procedure NativeToAnsi(Locale: TLocale; NativeStr: PChar;
  1191.   var AnsiStr: string);
  1192. procedure AnsiToNativeBuf(Locale: TLocale; Source, Dest: PChar; Len: Integer);
  1193. procedure NativeToAnsiBuf(Locale: TLocale; Source, Dest: PChar; Len: Integer);
  1194.  
  1195. function NativeCompareStr(Locale: TLocale; const S1, S2: string; Len: Integer): Integer;
  1196. function NativeCompareStrBuf(Locale: TLocale; const S1, S2: PChar; Len: Integer): Integer;
  1197. function NativeCompareText(Locale: TLocale; const S1, S2: string; Len: Integer): Integer;
  1198. function NativeCompareTextBuf(Locale: TLocale; const S1, S2: PChar; Len: Integer): Integer;
  1199.  
  1200. function ExtractFieldName(const Fields: string; var Pos: Integer): string;
  1201.  
  1202. procedure RegisterFields(const FieldClasses: array of TFieldClass);
  1203.  
  1204. procedure DatabaseError(const Message: string);
  1205. procedure DBError(Ident: Word);
  1206. procedure DBErrorFmt(Ident: Word; const Args: array of const);
  1207. procedure DbiError(ErrorCode: DBIResult);
  1208. procedure Check(Status: DBIResult);
  1209. procedure RegisterBDEInitProc(const InitProc: TBDEInitProc);
  1210.  
  1211. var
  1212.   Session: TSession;
  1213.   Sessions: TSessionList;
  1214.  
  1215. const
  1216.   RegisterFieldsProc: procedure(const FieldClassess: array of TFieldClass) = nil;
  1217.  
  1218. implementation
  1219.  
  1220. uses Controls, Forms, DBConsts, DBPWDlg, DBLogDlg, DBTables;
  1221.  
  1222. var
  1223.   FCSect: TRTLCriticalSection;
  1224.   StartTime: LongInt = 0;
  1225.   TimerID: Word;
  1226.   AcquiredTimer: Boolean = False;
  1227.   BDEInitProcs: TList;
  1228.  
  1229. procedure RegisterBDEInitProc(const InitProc: TBDEInitProc);
  1230. begin
  1231.   if not Assigned(BDEInitProcs) then
  1232.     BDEInitProcs := TList.Create;
  1233.   BDEInitProcs.Add(@InitProc);
  1234. end;
  1235.  
  1236. procedure FreeTimer;
  1237. begin
  1238.   if AcquiredTimer then
  1239.   begin
  1240.     KillTimer(0, TimerID);
  1241.     AcquiredTimer := False;
  1242.     StartTime := 0;
  1243.     Screen.Cursor := crDefault;
  1244.   end;
  1245. end;
  1246.  
  1247. { Timer callback function }
  1248.  
  1249. procedure TimerCallBack(hWnd: HWND; Message: Word; TimerID: Word;
  1250.   SysTime: LongInt); stdcall;
  1251. begin
  1252.   FreeTimer;
  1253. end;
  1254.  
  1255. { BdeCallbacks }
  1256.  
  1257. function BdeCallBack(CallType: CBType; Data: Longint;
  1258.   CBInfo: Pointer): CBRType; stdcall;
  1259. begin
  1260.   if (Data <> 0) then
  1261.     Result := TBDECallback(Data).Invoke(CallType, CBInfo) else
  1262.     Result := cbrUSEDEF;
  1263. end;
  1264.  
  1265. function DLLDetachCallBack(CallType: CBType; Data: Longint;
  1266.   CBInfo: Pointer): CBRType; stdcall;
  1267. begin
  1268.   DB.Session.FDLLDetach := True;
  1269.   Sessions.CloseAll;
  1270. end;
  1271.  
  1272. constructor TBDECallback.Create(AOwner: TObject; Handle: hDBICur; CBType: CBType;
  1273.   CBBuf: Pointer; CBBufSize: Integer; CallbackEvent: TBDECallbackEvent;
  1274.   Chain: Boolean);
  1275. begin
  1276.   FOwner := AOwner;
  1277.   FHandle := Handle;
  1278.   FCBType := CBType;
  1279.   FCallbackEvent := CallbackEvent;
  1280.   DbiGetCallBack(Handle, FCBType, @FOldCBData, @FOldCBBufLen, @FOldCBBuf, FOldCBFunc);
  1281.   if not Assigned(FOldCBFunc) or Chain then
  1282.   begin
  1283.     Check(DbiRegisterCallback(FHandle, FCBType, Longint(Self), CBBufSize,
  1284.       CBBuf, BdeCallBack));
  1285.     FInstalled := True;
  1286.   end;
  1287. end;
  1288.  
  1289. destructor TBDECallback.Destroy;
  1290. begin
  1291.   if FInstalled then
  1292.   begin
  1293.     if Assigned(FOldCBFunc) then
  1294.     try
  1295.       DbiRegisterCallback(FHandle, FCBType, FOldCBData, FOldCBBufLen,
  1296.         FOldCBBuf, FOldCBFunc);
  1297.     except
  1298.     end
  1299.     else
  1300.       DbiRegisterCallback(FHandle, FCBType, 0, 0, nil, nil);
  1301.   end;
  1302. end;
  1303.  
  1304. function TBDECallback.Invoke(CallType: CBType; CBInfo: Pointer): CBRType;
  1305. begin
  1306.   if CallType = FCBType then
  1307.     Result := FCallbackEvent(CBInfo) else
  1308.     Result := cbrUSEDEF;
  1309.   if Assigned(FOldCBFunc)
  1310.     then Result := FOldCBFunc(CallType, FOldCBData, CBInfo);
  1311. end;
  1312.  
  1313. { Utility routines }
  1314.  
  1315. procedure DisposeMem(var Buffer; Size: Word);
  1316. begin
  1317.   if Pointer(Buffer) <> nil then
  1318.   begin
  1319.     FreeMem(Pointer(Buffer), Size);
  1320.     Pointer(Buffer) := nil;
  1321.   end;
  1322. end;
  1323.  
  1324. function BuffersEqual(Buf1, Buf2: Pointer; Size: Cardinal): Boolean; assembler;
  1325. asm
  1326.         PUSH    EDI
  1327.         PUSH    ESI
  1328.         MOV     ESI,Buf1
  1329.         MOV     EDI,Buf2
  1330.         XOR     EAX,EAX
  1331.         JECXZ   @@1
  1332.         CLD
  1333.         REPE    CMPSB
  1334.         JNE     @@1
  1335.         INC     EAX
  1336. @@1:    POP     ESI
  1337.         POP     EDI
  1338. end;
  1339.  
  1340. function StrToOem(const AnsiStr: string): string;
  1341. begin
  1342.   SetLength(Result, Length(AnsiStr));
  1343.   if Length(Result) > 0 then
  1344.     CharToOem(PChar(AnsiStr), PChar(Result));
  1345. end;
  1346.  
  1347. function AnsiToNative(Locale: TLocale; const AnsiStr: string;
  1348.   NativeStr: PChar; MaxLen: Integer): PChar;
  1349. var
  1350.   Len: Integer;
  1351. begin
  1352.   Len := Length(AnsiStr);
  1353.   if Len > MaxLen then Len := MaxLen;
  1354.   if Len > 0 then AnsiToNativeBuf(Locale, Pointer(AnsiStr), NativeStr, Len);
  1355.   NativeStr[Len] := #0;
  1356.   Result := NativeStr;
  1357. end;
  1358.  
  1359. procedure NativeToAnsi(Locale: TLocale; NativeStr: PChar;
  1360.   var AnsiStr: string);
  1361. var
  1362.   Len: Integer;
  1363. begin
  1364.   Len := StrLen(NativeStr);
  1365.   SetString(AnsiStr, nil, Len);
  1366.   if Len > 0 then NativeToAnsiBuf(Locale, NativeStr, Pointer(AnsiStr), Len);
  1367. end;
  1368.  
  1369. procedure AnsiToNativeBuf(Locale: TLocale; Source, Dest: PChar; Len: Integer);
  1370. var
  1371.   DataLoss: LongBool;
  1372. begin
  1373.   if Len > 0 then
  1374.     if Locale <> nil then
  1375.       DbiAnsiToNative(Locale, Dest, Source, Len, DataLoss) else
  1376.       CharToOemBuff(Source, Dest, Len);
  1377. end;
  1378.  
  1379. procedure NativeToAnsiBuf(Locale: TLocale; Source, Dest: PChar; Len: Integer);
  1380. var
  1381.   DataLoss: LongBool;
  1382. begin
  1383.   if Len > 0 then
  1384.     if Locale <> nil then
  1385.       DbiNativeToAnsi(Locale, Dest, Source, Len, DataLoss) else
  1386.       OemToCharBuff(Source, Dest, Len)
  1387. end;
  1388.  
  1389. function NativeCompareStr(Locale: TLocale; const S1, S2: string; Len: Integer): Integer;
  1390. begin
  1391.   Result := NativeCompareStrBuf(Locale, PChar(S1), PChar(S2), Len);
  1392. end;
  1393.  
  1394. function NativeCompareStrBuf(Locale: TLocale; const S1, S2: PChar; Len: Integer): Integer;
  1395. begin
  1396.   if Len > 0 then
  1397.     Result := OsLdStrnCmp(Locale, S1, S2, Len) else
  1398.     Result := OsLdStrCmp(Locale, S1, S2);
  1399. end;
  1400.  
  1401. function NativeCompareText(Locale: TLocale; const S1, S2: string; Len: Integer): Integer;
  1402. begin
  1403.   Result := NativeCompareTextBuf(Locale, PChar(S1), PChar(S2), Len);
  1404. end;
  1405.  
  1406. function NativeCompareTextBuf(Locale: TLocale; const S1, S2: PChar; Len: Integer): Integer;
  1407. begin
  1408.   if Len > 0 then
  1409.     Result := OsLdStrnCmpi(Locale, S1, S2, Len) else
  1410.     Result := OsLdStrCmpi(Locale, S1, S2);
  1411. end;
  1412.  
  1413. function ExtractFieldName(const Fields: string; var Pos: Integer): string;
  1414. var
  1415.   I: Integer;
  1416. begin
  1417.   I := Pos;
  1418.   while (I <= Length(Fields)) and (Fields[I] <> ';') do Inc(I);
  1419.   Result := Copy(Fields, Pos, I - Pos);
  1420.   if (I <= Length(Fields)) and (Fields[I] = ';') then Inc(I);
  1421.   Pos := I;
  1422. end;
  1423.  
  1424. function IsDirectory(const DatabaseName: string): Boolean;
  1425. begin
  1426.   Result := (DatabaseName = '') or (Pos(':', DatabaseName) <> 0) or
  1427.     (Pos('\', DatabaseName) <> 0);
  1428. end;
  1429.  
  1430. procedure MergeStrings(Dest, Source: TStrings);
  1431. var
  1432.   DI, I, P: Integer;
  1433.   S: string;
  1434. begin
  1435.   for I := 0 to Source.Count - 1 do
  1436.   begin
  1437.     S := Source[I];
  1438.     P := Pos('=', S);
  1439.     if P > 1 then
  1440.     begin
  1441.       DI := Dest.IndexOfName(Copy(S, 1, P - 1));
  1442.       if DI > -1 then Dest[DI] := S;
  1443.     end;
  1444.   end;
  1445. end;
  1446.  
  1447. procedure CheckTypeSize(DataType: TFieldType; Size: Word);
  1448. begin
  1449.   case DataType of
  1450.     ftString: if (Size >= 1) and (Size <= dsMaxStringSize) then Exit;
  1451.     ftBCD: if Size <= 32 then Exit;
  1452.     ftBytes, ftVarBytes: if Size > 0 then Exit;
  1453.     ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftParadoxOle, ftDBaseOle,
  1454.     ftTypedBinary: Exit;
  1455.   else
  1456.     if Size = 0 then Exit;
  1457.   end;
  1458.   DBError(SInvalidFieldSize);
  1459. end;
  1460.  
  1461. function FieldTypeToVarType(DataType: TFieldType): Integer;
  1462. const
  1463.   TypeMap: array[TFieldType] of Word = (
  1464.     varEmpty, varString, varInteger, varInteger, varInteger, varBoolean,
  1465.     varDouble, varCurrency, varCurrency, varDate, varDate, varDate,
  1466.     varEmpty, varEmpty, varInteger, varEmpty, varEmpty, varEmpty,
  1467.     varEmpty, varEmpty, varEmpty, varEmpty);
  1468. begin
  1469.   Result := TypeMap[DataType];
  1470. end;
  1471.  
  1472. procedure RegisterFields(const FieldClasses: array of TFieldClass);
  1473. begin
  1474.   if Assigned(RegisterFieldsProc) then
  1475.     RegisterFieldsProc(FieldClasses) else
  1476.     DBError(SInvalidFieldRegistration);
  1477. end;
  1478.  
  1479. function GetIntProp(const Handle: Pointer; PropName: Integer): Integer;
  1480. var
  1481.   Length: Word;
  1482.   Value: Integer;
  1483. begin
  1484.   Value := 0;
  1485.   Check(DbiGetProp(HDBIObj(Handle), propName, @Value, SizeOf(Value), Length));
  1486.   Result := Value;
  1487. end;
  1488.  
  1489. { Error and exception handling routines }
  1490.  
  1491. procedure DatabaseError(const Message: string);
  1492. begin
  1493.   raise EDatabaseError.Create(Message);
  1494. end;
  1495.  
  1496. procedure DBError(Ident: Word);
  1497. begin
  1498.   DatabaseError(LoadStr(Ident));
  1499. end;
  1500.  
  1501. procedure DBErrorFmt(Ident: Word; const Args: array of const);
  1502. begin
  1503.   DatabaseError(FmtLoadStr(Ident, Args));
  1504. end;
  1505.  
  1506. procedure DbiError(ErrorCode: DBIResult);
  1507. begin
  1508.   if AcquiredTimer then FreeTimer;
  1509.   raise EDBEngineError.Create(ErrorCode);
  1510. end;
  1511.  
  1512. procedure Check(Status: DBIResult);
  1513. begin
  1514.   if Status <> 0 then DbiError(Status);
  1515. end;
  1516.  
  1517. { TDBError }
  1518.  
  1519. constructor TDBError.Create(Owner: EDBEngineError; ErrorCode: DBIResult;
  1520.   NativeError: Longint; Message: PChar);
  1521. begin
  1522.   Owner.FErrors.Add(Self);
  1523.   FErrorCode := ErrorCode;
  1524.   FNativeError := NativeError;
  1525.   FMessage := Message;
  1526. end;
  1527.  
  1528. function TDBError.GetCategory: Byte;
  1529. begin
  1530.   Result := Hi(FErrorCode);
  1531. end;
  1532.  
  1533. function TDBError.GetSubCode: Byte;
  1534. begin
  1535.   Result := Lo(FErrorCode);
  1536. end;
  1537.  
  1538. { EDBEngineError }
  1539.  
  1540. function TrimMessage(Msg: PChar): PChar;
  1541. var
  1542.   Blank: Boolean;
  1543.   Source, Dest: PChar;
  1544. begin
  1545.   Source := Msg;
  1546.   Dest := Msg;
  1547.   Blank := False;
  1548.   while Source^ <> #0 do
  1549.   begin
  1550.     if Source^ <= ' ' then Blank := True else
  1551.     begin
  1552.       if Blank then
  1553.       begin
  1554.         Dest^ := ' ';
  1555.         Inc(Dest);
  1556.         Blank := False;
  1557.       end;
  1558.       Dest^ := Source^;
  1559.       Inc(Dest);
  1560.     end;
  1561.     Inc(Source);
  1562.   end;
  1563.   if (Dest > Msg) and ((Dest - 1)^ = '.') then Dec(Dest);
  1564.   Dest^ := #0;
  1565.   Result := Msg;
  1566. end;
  1567.  
  1568. constructor EDBEngineError.Create(ErrorCode: DBIResult);
  1569. var
  1570.   ErrorIndex: Integer;
  1571.   NativeError: Longint;
  1572.   Msg, LastMsg: DBIMSG;
  1573. begin
  1574.   inherited Create('');
  1575.   FErrors := TList.Create;
  1576.   ErrorIndex := 1;
  1577.   if not Session.Active then
  1578.   begin
  1579.     Message := FmtLoadStr(SInitError, [ErrorCode]);
  1580.     TDBError.Create(Self, ErrorCode, 0, PChar(Message));
  1581.   end
  1582.   else begin
  1583.     DbiGetErrorString(ErrorCode, Msg);
  1584.     TDBError.Create(Self, ErrorCode, 0, Msg);
  1585.     TrimMessage(Msg);
  1586.     if Msg[0] = #0 then Message := FmtLoadStr(SBDEError, [ErrorCode])
  1587.     else Message := Msg;
  1588.     while True do
  1589.     begin
  1590.       StrCopy(LastMsg, Msg);
  1591.       ErrorCode := DbiGetErrorEntry(ErrorIndex, NativeError, Msg);
  1592.       if (ErrorCode = DBIERR_NONE) or
  1593.         (ErrorCode = DBIERR_NOTINITIALIZED) then Break;
  1594.       TDBError.Create(Self, ErrorCode, NativeError, Msg);
  1595.       TrimMessage(Msg);
  1596.       if (Msg[0] <> #0) and (StrComp(Msg, LastMsg) <> 0) then
  1597.         Message := Format('%s. %s', [Message, Msg]);
  1598.       Inc(ErrorIndex);
  1599.     end;
  1600.  end;
  1601. end;
  1602.  
  1603. destructor EDBEngineError.Destroy;
  1604. var
  1605.   I: Integer;
  1606. begin
  1607.   if FErrors <> nil then
  1608.   begin
  1609.     for I := FErrors.Count - 1 downto 0 do TDBError(FErrors[I]).Free;
  1610.     FErrors.Free;
  1611.   end;
  1612.   inherited Destroy;
  1613. end;
  1614.  
  1615. function EDBEngineError.GetError(Index: Integer): TDBError;
  1616. begin
  1617.   Result := FErrors[Index];
  1618. end;
  1619.  
  1620. function EDBEngineError.GetErrorCount: Integer;
  1621. begin
  1622.   Result := FErrors.Count;
  1623. end;
  1624.  
  1625. { TSessionList }
  1626.  
  1627. constructor TSessionList.Create;
  1628. begin
  1629.   inherited Create;
  1630.   FSessions := TList.Create;
  1631.   InitializeCriticalSection(FCSect);
  1632. end;
  1633.  
  1634. destructor TSessionList.Destroy;
  1635. begin
  1636.   CloseAll;
  1637.   DeleteCriticalSection(FCSect);
  1638.   inherited Destroy;
  1639. end;
  1640.  
  1641. procedure TSessionList.AddSession(ASession: TSession);
  1642. begin
  1643.   if FSessions.Count = 0 then ASession.FDefault := True;
  1644.   FSessions.Add(ASession);
  1645. end;
  1646.  
  1647. procedure TSessionList.CloseAll;
  1648. var
  1649.   I: Integer;
  1650. begin
  1651.   for I := FSessions.Count-1 downto 0 do
  1652.     TSession(FSessions[I]).Free;
  1653. end;
  1654.  
  1655. function TSessionList.GetCount: Integer;
  1656. begin
  1657.   Result := FSessions.Count;
  1658. end;
  1659.  
  1660. function TSessionList.GetCurrentSession: TSession;
  1661. var
  1662.   Handle: HDBISes;
  1663.   I: Integer;
  1664. begin
  1665.   Check(DbiGetCurrSession(Handle));
  1666.   for I := 0 to FSessions.Count - 1 do
  1667.     if TSession(FSessions[I]).Handle = Handle then
  1668.     begin
  1669.       Result := TSession(FSessions[I]);
  1670.       Exit;
  1671.     end;
  1672.   Result := nil;
  1673. end;
  1674.  
  1675. function TSessionList.GetSession(Index: Integer): TSession;
  1676. begin
  1677.   Result := TSession(FSessions[Index]);
  1678. end;
  1679.  
  1680. function TSessionList.GetSessionByName(const SessionName: string): TSession;
  1681. begin
  1682.   if SessionName = '' then
  1683.     Result := DB.Session
  1684.   else
  1685.     Result := FindSession(SessionName);
  1686.   if Result = nil then
  1687.     DBErrorFmt(SInvalidSessionName, [SessionName]);
  1688. end;
  1689.  
  1690. function TSessionList.FindSession(const SessionName: string): TSession;
  1691. var
  1692.   I: Integer;
  1693. begin
  1694.   if SessionName = '' then
  1695.     Result := DB.Session
  1696.   else
  1697.   begin
  1698.     for I := 0 to FSessions.Count - 1 do
  1699.     begin
  1700.       Result := FSessions[I];
  1701.       if AnsiCompareText(Result.SessionName, SessionName) = 0 then Exit;
  1702.     end;
  1703.     Result := nil;
  1704.   end;
  1705. end;
  1706.  
  1707. procedure TSessionList.GetSessionNames(List: TStrings);
  1708. var
  1709.   I: Integer;
  1710. begin
  1711.   List.BeginUpdate;
  1712.   try
  1713.     List.Clear;
  1714.     for I := 0 to FSessions.Count - 1 do
  1715.       with TSession(FSessions[I]) do
  1716.         List.Add(SessionName);
  1717.   finally
  1718.     List.EndUpdate;
  1719.   end;
  1720. end;
  1721.  
  1722. function TSessionList.OpenSession(const SessionName: string): TSession;
  1723. begin
  1724.   Result := FindSession(SessionName);
  1725.   if Result = nil then
  1726.   begin
  1727.     Result := TSession.Create(nil);
  1728.     Result.SessionName := SessionName;
  1729.   end;
  1730.   Result.SetActive(True);
  1731. end;
  1732.  
  1733. procedure TSessionList.SetCurrentSession(Value: TSession);
  1734. begin
  1735.   Check(DbiSetCurrSession(Value.FHandle))
  1736. end;
  1737.  
  1738. { TSession }
  1739.  
  1740. constructor TSession.Create(AOwner: TComponent);
  1741. begin
  1742.   inherited Create(AOwner);
  1743.   Exclude(FComponentStyle, csInheritable);
  1744.   FDatabases := TList.Create;
  1745.   FCallbacks := TList.Create;
  1746.   FKeepConnections := True;
  1747.   Sessions.AddSession(Self);
  1748.   FHandle := nil;
  1749. end;
  1750.  
  1751. destructor TSession.Destroy;
  1752.  
  1753.   procedure ResetDBSessionRefs;
  1754.   var
  1755.     I: Integer;
  1756.   begin
  1757.     for I := 0 to FDatabases.Count - 1 do
  1758.       with TDatabase(FDatabases[I]) do
  1759.       if FSession = Self then
  1760.       begin
  1761.         FSession := DB.Session;
  1762.         FSession.AddDatabase(FDatabases[I]);
  1763.       end;
  1764.   end;
  1765.  
  1766. begin
  1767.   SetActive(False);
  1768.   Sessions.FSessions.Remove(Self);
  1769.   if not FDefault and Assigned(FDatabases) then ResetDBSessionRefs;
  1770.   FDatabases.Free;
  1771.   FCallbacks.Free;
  1772.   inherited Destroy;
  1773. end;
  1774.  
  1775. procedure TSession.AddAlias(const Name, Driver: string; List: TStrings);
  1776. begin
  1777.   InternalAddAlias(Name, Driver, List, ConfigMode, True);
  1778. end;
  1779.  
  1780. procedure TSession.AddDatabase(Value: TDatabase);
  1781. begin
  1782.   FDatabases.Add(Value);
  1783.   DBNotification(dbAdd, Value);
  1784. end;
  1785.  
  1786. procedure TSession.AddConfigRecord(const Path, Node: string; List: TStrings);
  1787. var
  1788.   ParamList: TParamList;
  1789. begin
  1790.   ParamList := TParamList.Create(List);
  1791.   try
  1792.     with ParamList do
  1793.       Check(DbiCfgAddRecord(nil, PChar(Format(Path, [Node])), FieldCount,
  1794.         PFLDDesc(FieldDescs), Buffer));
  1795.   finally
  1796.     ParamList.Free;
  1797.   end;
  1798. end;
  1799.  
  1800. procedure TSession.AddStandardAlias(const Name, Path, DefaultDriver: string);
  1801. var
  1802.   AliasParams: TStringList;
  1803. begin
  1804.   AliasParams := TStringList.Create;
  1805.   try
  1806.     AliasParams.Add(Format('%s=%s', [szCFGDBPATH, Path]));
  1807.     AliasParams.Add(Format('%s=%s', [szCFGDBDEFAULTDRIVER, DefaultDriver]));
  1808.     AddAlias(Name, szCFGDBSTANDARD, AliasParams);
  1809.   finally
  1810.     AliasParams.Free;
  1811.   end;
  1812. end;
  1813.  
  1814. procedure TSession.AddPassword(const Password: string);
  1815. var
  1816.   Buffer: array[0..255] of Char;
  1817. begin
  1818.   LockSession;
  1819.   try
  1820.     if Password <> '' then
  1821.       Check(DbiAddPassword(AnsiToNative(Locale, Password, Buffer,
  1822.         SizeOf(Buffer) - 1)));
  1823.   finally
  1824.     UnlockSession;
  1825.   end;
  1826. end;
  1827.  
  1828. procedure TSession.CallBDEInitProcs;
  1829. var
  1830.   I: Integer;
  1831. begin
  1832.   if Assigned(BDEInitProcs) then
  1833.     for I := 0 to BDEInitProcs.Count - 1 do
  1834.       TBDEInitProc(BDEInitProcs[I])(Self);
  1835. end;
  1836.  
  1837. procedure TSession.CheckInactive;
  1838. begin
  1839.   if Active then
  1840.     DBError(SSessionActive);
  1841. end;
  1842.  
  1843. procedure TSession.CheckConfigMode(CfgMode: TConfigMode);
  1844. begin
  1845.   if CfgMode = cmAll then CfgMode := cmPersistent;
  1846.   ConfigMode := CfgMode;
  1847. end;
  1848.  
  1849. procedure TSession.Close;
  1850. begin
  1851.   SetActive(False);
  1852. end;
  1853.  
  1854. procedure TSession.CloseDatabase(Database: TDatabase);
  1855. begin
  1856.   if Database.FRefCount <> 0 then Dec(Database.FRefCount);
  1857.   if (Database.FRefCount = 0) and not Database.KeepConnection then
  1858.     if Database.Temporary then Database.Free else Database.Close;
  1859. end;
  1860.  
  1861. function TSession.DBLoginCallback(CBInfo: Pointer): CBRType;
  1862. var
  1863.   Database: TDatabase;
  1864.   UserName, Password: string;
  1865.   AliasParams: TStringList;
  1866. begin
  1867.   Result := cbrYES;
  1868.   with PCBDBLogin(CBInfo)^ do
  1869.   try
  1870.     if hDB = nil then
  1871.     begin
  1872.       if not FBDEOwnsLoginCbDb then
  1873.       begin
  1874.         hDb := OpenDatabase(szDbName).Handle;
  1875.         if not Assigned(hDb) then
  1876.           Result := cbrAbort
  1877.         else
  1878.           bCallbackToClose := True;
  1879.       end else
  1880.       begin
  1881.         AliasParams := TStringList.Create;
  1882.         try
  1883.           GetAliasParams(szDbName, AliasParams);
  1884.           UserName := AliasParams.Values[szUSERNAME];
  1885.         finally
  1886.           AliasParams.Free;
  1887.         end;
  1888.         Password := '';
  1889.         if LoginDialogEx(szDbName, UserName, Password, True) then
  1890.         begin
  1891.           AnsiToNative(Locale, Password, szPassword, SizeOf(szPassword) - 1);
  1892.           bCallbackToClose := False;
  1893.         end
  1894.         else
  1895.           Result :=cbrAbort;
  1896.       end
  1897.     end else
  1898.     begin
  1899.       Database := FindDatabase(szDbName);
  1900.       if Assigned(Database) and (hDB = Database.Handle) then
  1901.         CloseDatabase(Database);
  1902.     end;
  1903.   except
  1904.     Result := cbrAbort;
  1905.   end;
  1906. end;
  1907.  
  1908. procedure TSession.DBNotification(DBEvent: TDatabaseEvent; const Param);
  1909. begin
  1910.   if Assigned(FOnDBNotify) then FOnDBNotify(DBEvent, Param);
  1911. end;
  1912.  
  1913. procedure TSession.DeleteAlias(const Name: string);
  1914. begin
  1915.   InternalDeleteAlias(Name, ConfigMode, True);
  1916. end;
  1917.  
  1918. procedure TSession.DeleteConfigPath(const Path, Node: string);
  1919. var
  1920.   CfgPath: string;
  1921. begin
  1922.   CfgPath := Format(Path, [Node]);
  1923.   if DbiCfgPosition(nil, PChar(CfgPath)) = 0 then
  1924.     Check(DbiCfgDropRecord(nil, PChar(CfgPath)));
  1925. end;
  1926.  
  1927. procedure TSession.DropConnections;
  1928. var
  1929.   I: Integer;
  1930. begin
  1931.   for I := FDatabases.Count - 1 downto 0 do
  1932.     with TDatabase(FDatabases[I]) do
  1933.       if Temporary and (FRefCount = 0) then Free;
  1934. end;
  1935.  
  1936. function TSession.FindDatabase(const DatabaseName: string): TDatabase;
  1937. var
  1938.   I: Integer;
  1939. begin
  1940.   for I := 0 to FDatabases.Count - 1 do
  1941.   begin
  1942.     Result := FDatabases[I];
  1943.     if ((Result.DatabaseName <> '') or Result.Temporary) and
  1944.       (AnsiCompareText(Result.DatabaseName, DatabaseName) = 0) then Exit;
  1945.   end;
  1946.   Result := nil;
  1947. end;
  1948.  
  1949. function TSession.GetActive: Boolean;
  1950. begin
  1951.   Result := FHandle <> nil;
  1952. end;
  1953.  
  1954. function TSession.GetAliasDriverName(const AliasName: string): string;
  1955. var
  1956.   Desc: DBDesc;
  1957. begin
  1958.   LockSession;
  1959.   try
  1960.     if DbiGetDatabaseDesc(PChar(StrToOem(AliasName)), @Desc) <> 0 then
  1961.       DBErrorFmt(SInvalidAliasName, [AliasName]);
  1962.   finally
  1963.     UnlockSession;
  1964.   end;
  1965.   if Desc.szDBType[sizeOf(Desc.szDBType) - 1] <> #0 then
  1966.     Desc.szDBType[sizeOf(Desc.szDBType) - 1] := #0;
  1967.   OemToChar(Desc.szDBType, Desc.szDBType);
  1968.   Result := Desc.szDBType;
  1969. end;
  1970.  
  1971. procedure TSession.GetAliasNames(List: TStrings);
  1972. var
  1973.   Cursor: HDBICur;
  1974.   Desc: DBDesc;
  1975. begin
  1976.   List.BeginUpdate;
  1977.   try
  1978.     List.Clear;
  1979.     LockSession;
  1980.     try
  1981.       Check(DbiOpenDatabaseList(Cursor));
  1982.     finally
  1983.       UnlockSession;
  1984.     end;
  1985.     try
  1986.       while DbiGetNextRecord(Cursor, dbiNOLOCK, @Desc, nil) = 0 do
  1987.       begin
  1988.         OemToChar(Desc.szName, Desc.szName);
  1989.         List.Add(Desc.szName);
  1990.       end;
  1991.     finally
  1992.       DbiCloseCursor(Cursor);
  1993.     end;
  1994.   finally
  1995.     List.EndUpdate;
  1996.   end;
  1997. end;
  1998.  
  1999. procedure TSession.GetAliasParams(const AliasName: string; List: TStrings);
  2000. var
  2001.   SAlias: DBIName;
  2002.   Desc: DBDesc;
  2003. begin
  2004.   List.BeginUpdate;
  2005.   try
  2006.     List.Clear;
  2007.     StrPLCopy(SAlias, AliasName, SizeOf(SAlias) - 1);
  2008.     CharToOEM(SAlias, SAlias);
  2009.     LockSession;
  2010.     try
  2011.       Check(DbiGetDatabaseDesc(SAlias, @Desc));
  2012.     finally
  2013.       UnlockSession;
  2014.     end;
  2015.     if Desc.szDBType[sizeOf(Desc.szDBType) - 1] <> #0 then
  2016.       Desc.szDBType[sizeOf(Desc.szDBType) - 1] := #0;
  2017.     if StrIComp(Desc.szDbType, szCFGDBSTANDARD) = 0 then
  2018.     begin
  2019.       GetConfigParams('\DATABASES\%s\DB INFO', SAlias, List);
  2020.       List.Values[szCFGDBTYPE] := '';
  2021.     end
  2022.     else
  2023.       GetConfigParams('\DATABASES\%s\DB OPEN', SAlias, List);
  2024.   finally
  2025.     List.EndUpdate;
  2026.   end;
  2027. end;
  2028.  
  2029. procedure TSession.GetConfigParams(const Path, Section: string; List: TStrings);
  2030. var
  2031.   Cursor: HDBICur;
  2032.   ConfigDesc: CFGDesc;
  2033. begin
  2034.   LockSession;
  2035.   try
  2036.     Check(DbiOpenCfgInfoList(nil, dbiREADONLY, cfgPERSISTENT, PChar(Format(Path,
  2037.       [Section])), Cursor));
  2038.   finally
  2039.     UnlockSession;
  2040.   end;
  2041.   try
  2042.     while DbiGetNextRecord(Cursor, dbiNOLOCK, @ConfigDesc, nil) = 0 do
  2043.       with ConfigDesc do
  2044.       begin
  2045.         OemToChar(szValue, szValue);
  2046.         List.Add(Format('%s=%s', [szNodeName, szValue]));
  2047.       end;
  2048.   finally
  2049.     DbiCloseCursor(Cursor);
  2050.   end;
  2051. end;
  2052.  
  2053. function TSession.GetDatabase(Index: Integer): TDatabase;
  2054. begin
  2055.   Result := FDatabases[Index];
  2056. end;
  2057.  
  2058. function TSession.GetDatabaseCount: Integer;
  2059. begin
  2060.   Result := FDatabases.Count;
  2061. end;
  2062.  
  2063. procedure TSession.GetDatabaseNames(List: TStrings);
  2064. var
  2065.   I: Integer;
  2066.   Names: TStringList;
  2067. begin
  2068.   Names := TStringList.Create;
  2069.   try
  2070.     Names.Sorted := True;
  2071.     GetAliasNames(Names);
  2072.     for I := 0 to FDatabases.Count - 1 do
  2073.       with TDatabase(FDatabases[I]) do
  2074.         if not IsDirectory(DatabaseName) then Names.Add(DatabaseName);
  2075.     List.Assign(Names);
  2076.   finally
  2077.     Names.Free;
  2078.   end;
  2079. end;
  2080.  
  2081. procedure TSession.GetDriverNames(List: TStrings);
  2082. var
  2083.   Cursor: HDBICur;
  2084.   Name: array[0..255] of Char;
  2085. begin
  2086.   List.BeginUpdate;
  2087.   try
  2088.     List.Clear;
  2089.     List.Add(szCFGDBSTANDARD);
  2090.     LockSession;
  2091.     try
  2092.       Check(DbiOpenDriverList(Cursor));
  2093.     finally
  2094.       UnlockSession;
  2095.     end;
  2096.     try
  2097.       while DbiGetNextRecord(Cursor, dbiNOLOCK, @Name, nil) = 0 do
  2098.         if (StrIComp(Name, szPARADOX) <> 0) and
  2099.           (StrIComp(Name, szDBASE) <> 0) then
  2100.         begin
  2101.           OemToChar(Name, Name);
  2102.           List.Add(Name);
  2103.         end;
  2104.     finally
  2105.       DbiCloseCursor(Cursor);
  2106.     end;
  2107.   finally
  2108.     List.EndUpdate;
  2109.   end;
  2110. end;
  2111.  
  2112. procedure TSession.GetDriverParams(const DriverName: string;
  2113.   List: TStrings);
  2114. begin
  2115.   List.BeginUpdate;
  2116.   try
  2117.     List.Clear;
  2118.     if CompareText(DriverName, szCFGDBSTANDARD) = 0 then
  2119.     begin
  2120.       List.Add(Format('%s=', [szCFGDBPATH]));
  2121.       List.Add(Format('%s=%s', [szCFGDBDEFAULTDRIVER, szPARADOX]));
  2122.       List.Add(Format('%s=%s', [szCFGDBENABLEBCD, szCFGFALSE]));
  2123.     end
  2124.     else
  2125.       GetConfigParams('\DRIVERS\%s\DB OPEN', StrToOem(DriverName), List);
  2126.   finally
  2127.     List.EndUpdate;
  2128.   end;
  2129. end;
  2130.  
  2131. function TSession.GetHandle: HDBISes;
  2132. begin
  2133.   if FHandle <> nil then
  2134.     Check(DbiSetCurrSession(FHandle))
  2135.   else
  2136.     SetActive(True);
  2137.   Result := FHandle;
  2138. end;
  2139.  
  2140. function TSession.GetNetFileDir: string;
  2141. var
  2142.   Length: Word;
  2143.   Buffer: array[0..255] of Char;
  2144. begin
  2145.   if Active and not (csWriting in ComponentState) then
  2146.   begin
  2147.     LockSession;
  2148.     try
  2149.       Check(DbiGetProp(HDBIOBJ(FHandle), sesNETFILE, @Buffer, SizeOf(Buffer),
  2150.         Length));
  2151.     finally
  2152.       UnLockSession;
  2153.     end;
  2154.     NativeToAnsi(nil, Buffer, Result);
  2155.   end else
  2156.     Result := FNetFileDir;
  2157.   Result := AnsiUpperCase(Result);
  2158. end;
  2159.  
  2160. function TSession.GetPrivateDir: string;
  2161. var
  2162.   SessionInfo: SESInfo;
  2163. begin
  2164.   if Active and not (csWriting in ComponentState) then
  2165.   begin
  2166.     LockSession;
  2167.     try
  2168.       Check(DbiGetSesInfo(SessionInfo));
  2169.     finally
  2170.       UnlockSession;
  2171.     end;
  2172.     NativeToAnsi(nil, SessionInfo.szPrivDir, Result);
  2173.   end else
  2174.     Result := FPrivateDir;
  2175.   Result := AnsiUpperCase(Result);
  2176. end;
  2177.  
  2178. function TSession.GetPassword: Boolean;
  2179. begin
  2180.   if Assigned(FOnPassword) then
  2181.   begin
  2182.     Result := False;
  2183.     FOnPassword(Self, Result)
  2184.   end else
  2185.     Result := PasswordDialog(Self);
  2186. end;
  2187.  
  2188. procedure TSession.GetTableNames(const DatabaseName, Pattern: string;
  2189.   Extensions, SystemTables: Boolean; List: TStrings);
  2190. var
  2191.   Database: TDatabase;
  2192.   Cursor: HDBICur;
  2193.   WildCard: PChar;
  2194.   Name: string;
  2195.   SPattern: array[0..127] of Char;
  2196.   Desc: TBLBaseDesc;
  2197. begin
  2198.   List.BeginUpdate;
  2199.   try
  2200.     List.Clear;
  2201.     Database := OpenDatabase(DatabaseName);
  2202.     try
  2203.       WildCard := nil;
  2204.       if Pattern <> '' then
  2205.         WildCard := AnsiToNative(Database.Locale, Pattern, SPattern,
  2206.           SizeOf(SPattern) - 1);
  2207.       Check(DbiOpenTableList(Database.Handle, False, SystemTables,
  2208.         WildCard, Cursor));
  2209.       try
  2210.         while DbiGetNextRecord(Cursor, dbiNOLOCK, @Desc, nil) = 0 do
  2211.           with Desc do
  2212.           begin
  2213.             if Extensions and (szExt[0] <> #0) then
  2214.               StrCat(StrCat(szName, '.'), szExt);
  2215.             NativeToAnsi(Database.Locale, szName, Name);
  2216.             List.Add(Name);
  2217.           end;
  2218.       finally
  2219.         DbiCloseCursor(Cursor);
  2220.       end;
  2221.     finally
  2222.       CloseDatabase(Database);
  2223.     end;
  2224.   finally
  2225.     List.EndUpdate;
  2226.   end;
  2227. end;
  2228.  
  2229. procedure TSession.GetStoredProcNames(const DatabaseName: string; List: TStrings);
  2230. var
  2231.   Database: TDatabase;
  2232.   Cursor: HDBICur;
  2233.   Name: string;
  2234.   Desc: SPDesc;
  2235. begin
  2236.   List.BeginUpdate;
  2237.   try
  2238.     List.Clear;
  2239.     Database := OpenDatabase(DatabaseName);
  2240.     try
  2241.       Check(DbiOpenSPList(Database.Handle, False, True, nil, Cursor));
  2242.       try
  2243.         while DbiGetNextRecord(Cursor, dbiNOLOCK, @Desc, nil) = 0 do
  2244.           with Desc do
  2245.           begin
  2246.             NativeToAnsi(Database.Locale, szName, Name);
  2247.             List.Add(Name);
  2248.           end;
  2249.       finally
  2250.         DbiCloseCursor(Cursor);
  2251.       end;
  2252.     finally
  2253.       CloseDatabase(Database);
  2254.     end;
  2255.   finally
  2256.     List.EndUpdate;
  2257.   end;
  2258. end;
  2259.  
  2260. procedure TSession.InitializeBDE;
  2261. const
  2262.   StartFlags: LongInt = $FFFFEBF0;
  2263. var
  2264.   Status: DBIResult;
  2265.   Env: DbiEnv;
  2266.   ClientHandle: hDBIObj;
  2267.   SetCursor: Boolean;
  2268. begin
  2269.   SetCursor := GetCurrentThreadID = MainThreadID;
  2270.   if SetCursor then
  2271.     Screen.Cursor := crHourGlass;
  2272.   try
  2273.     FillChar(Env, SizeOf(Env), 0);
  2274.     StrPLCopy(Env.szLang, LoadStr(SIDAPILangID), SizeOf(Env.szLang) - 1);
  2275.     Status := DbiInit(@Env);
  2276.     if (Status <> DBIERR_NONE) and (Status <> DBIERR_MULTIPLEINIT) then
  2277.       DBErrorFmt(SInitError, [Status]);
  2278.     Check(DbiGetCurrSession(FHandle));
  2279.     if DbiGetObjFromName(objCLIENT, nil, ClientHandle) = 0 then
  2280.       DbiSetProp(ClientHandle, clSQLRESTRICT, StartFlags);
  2281.     if IsLibrary then
  2282.       DbiRegisterCallback(nil, cbDETACHNOTIFY, 0, 0, nil, DLLDetachCallBack);
  2283.   finally
  2284.     if SetCursor then
  2285.       Screen.Cursor := crDefault;
  2286.   end;
  2287. end;
  2288.  
  2289. procedure TSession.InternalAddAlias(const Name, Driver: string; List: TStrings;
  2290.   CfgMode: TConfigMode; RestoreMode: Boolean);
  2291. var
  2292.   Standard: Boolean;
  2293.   DefaultDriver: string;
  2294.   OemName: string;
  2295.   CfgModeSave: TConfigMode;
  2296.  
  2297.   procedure ValidateAliasName;
  2298.   const
  2299.     ValidChars = ['0'..'9','A'..'Z','a'..'z','_',#127..#255];
  2300.   var
  2301.     I, Len: Integer;
  2302.     ValidName: Boolean;
  2303.   begin
  2304.     Len := Length(Name);
  2305.     ValidName := Len > 0;
  2306.     if ValidName then
  2307.     begin
  2308.       OemName := StrToOem(Name);
  2309.       for I := 1 to  Len do
  2310.       begin
  2311.         ValidName := OemName[I] in ValidChars;
  2312.         if not ValidName then break;
  2313.       end;
  2314.     end;
  2315.     if not ValidName then
  2316.       DBErrorFmt(SInvalidAliasName, [Name]);
  2317.   end;
  2318.  
  2319.   procedure AddDBInfo;
  2320.   var
  2321.     DBInfo: TStringList;
  2322.     EnableBCD: string;
  2323.   begin
  2324.     DBInfo := TStringList.Create;
  2325.     try
  2326.       if Standard then
  2327.         DBInfo.Add(Format('%s=%s', [szCFGDBTYPE, szCFGDBSTANDARD])) else
  2328.         DBInfo.Add(Format('%s=%s', [szCFGDBTYPE, Driver]));
  2329.       DBInfo.Add(Format('%s=%s', [szCFGDBPATH, List.Values[szCFGDBPATH]]));
  2330.       if Standard then
  2331.       begin
  2332.         if DefaultDriver = '' then
  2333.           DefaultDriver := List.Values[szCFGDBDEFAULTDRIVER];
  2334.         DBInfo.Add(Format('%s=%s', [szCFGDBDEFAULTDRIVER, DefaultDriver]));
  2335.         EnableBCD := List.Values[szCFGDBENABLEBCD];
  2336.         if EnableBCD = '' then EnableBCD := szCFGFALSE;
  2337.         DBInfo.Add(Format('%s=%s', [szCFGDBENABLEBCD, EnableBCD]));
  2338.       end;
  2339.       AddConfigRecord('\DATABASES\%s\DB INFO', OemName, DBInfo);
  2340.     finally
  2341.       DBInfo.Free;
  2342.     end;
  2343.   end;
  2344.  
  2345.   procedure AddDBOpen;
  2346.   var
  2347.     DBOpen: TStringList;
  2348.   begin
  2349.     try
  2350.       DBOpen := TStringList.Create;
  2351.       try
  2352.         GetDriverParams(Driver, DBOpen);
  2353.         MergeStrings(DBOpen, List);
  2354.         AddConfigRecord('\DATABASES\%s\DB OPEN', OemName, DBOpen);
  2355.       finally
  2356.         DBOpen.Free;
  2357.       end;
  2358.     except
  2359.       DbiCfgDropRecord(nil, PChar(Format('\DATABASES\%s\DB INFO', [Name])));
  2360.       raise;
  2361.     end;
  2362.   end;
  2363.  
  2364. begin
  2365.   LockSession;
  2366.   try
  2367.     DefaultDriver := '';
  2368.     Standard := (Driver = '') or (CompareText(Driver, szCFGDBSTANDARD) = 0);
  2369.     if not Standard and ((CompareText(Driver, szPARADOX) = 0) or
  2370.       (CompareText(Driver, szDBASE) = 0) or
  2371.       (CompareText(Driver, szASCII) = 0)) then
  2372.     begin
  2373.       Standard := True;
  2374.       DefaultDriver := Driver;
  2375.     end;
  2376.     ValidateAliasName;
  2377.     CfgModeSave := ConfigMode;
  2378.     try
  2379.       CheckConfigMode(CfgMode);
  2380.       AddDBInfo;
  2381.       if not Standard then AddDBOpen;
  2382.     finally
  2383.       if RestoreMode then ConfigMode := CfgModeSave;
  2384.     end;
  2385.   finally
  2386.     UnlockSession;
  2387.   end;
  2388.   DBNotification(dbAddAlias, Pointer(Name));
  2389. end;
  2390.  
  2391. procedure TSession.InternalDeleteAlias(const Name: string;
  2392.   CfgMode: TConfigMode; RestoreMode: Boolean);
  2393. var
  2394.   CfgModeSave: TConfigMode;
  2395. begin
  2396.   DBNotification(dbDeleteAlias, Pointer(Name));
  2397.   LockSession;
  2398.   try
  2399.     CfgModeSave := ConfigMode;
  2400.     try
  2401.       CheckConfigMode(CfgMode);
  2402.       DeleteConfigPath('\DATABASES\%s', StrToOem(Name));
  2403.     finally
  2404.       if RestoreMode then ConfigMode := cfgModeSave;
  2405.     end;
  2406.   finally
  2407.     UnlockSession;
  2408.   end;
  2409. end;
  2410.  
  2411. function TSession.IsAlias(const Name: string): Boolean;
  2412. begin
  2413.   MakeCurrent;
  2414.   Result := DbiCfgPosition(nil, PChar(Format('\DATABASES\%s', [Name]))) = 0;
  2415. end;
  2416.  
  2417. procedure TSession.Loaded;
  2418. begin
  2419.   inherited Loaded;
  2420.   try
  2421.     if FStreamedActive then SetActive(True);
  2422.   except
  2423.     if csDesigning in ComponentState then
  2424.       Application.HandleException(Self)
  2425.     else
  2426.       raise;
  2427.   end;
  2428. end;
  2429.  
  2430. procedure TSession.LockSession;
  2431. begin
  2432.   if FLockCount = 0 then
  2433.   begin
  2434.     EnterCriticalSection(FCSect);
  2435.     Inc(FLockCount);
  2436.     MakeCurrent;
  2437.   end
  2438.   else
  2439.     Inc(FLockCount);
  2440. end;
  2441.  
  2442. procedure TSession.UnLockSession;
  2443. begin
  2444.   Dec(FLockCount);
  2445.   if FLockCount = 0 then
  2446.     LeaveCriticalSection(FCSect);
  2447. end;
  2448.  
  2449. procedure TSession.MakeCurrent;
  2450. begin
  2451.   if FHandle <> nil then
  2452.     Check(DbiSetCurrSession(FHandle))
  2453.   else
  2454.     SetActive(True);
  2455. end;
  2456.  
  2457. procedure TSession.ModifyAlias(Name: string; List: TStrings);
  2458. var
  2459.   DriverName: string;
  2460.   OemName: string;
  2461.   CfgModeSave: TConfigMode;
  2462. begin
  2463.   LockSession;
  2464.   try
  2465.     CfgModeSave := ConfigMode;
  2466.     try
  2467.       CheckConfigMode(ConfigMode);
  2468.       DriverName := GetAliasDriverName(Name);
  2469.       OemName := StrToOem(Name);
  2470.       ModifyConfigParams('\DATABASES\%s\DB INFO', OemName, List);
  2471.       if DriverName <> szCFGDBSTANDARD then
  2472.         ModifyConfigParams('\DATABASES\%s\DB OPEN', OemName, List);
  2473.     finally
  2474.       ConfigMode := CfgModeSave;
  2475.     end;
  2476.   finally
  2477.     UnLockSession;
  2478.   end;
  2479. end;
  2480.  
  2481. procedure TSession.ModifyConfigParams(const Path, Node: string; List: TStrings);
  2482. var
  2483.   I, J, C: Integer;
  2484.   Params: TStrings;
  2485. begin
  2486.   Params := TStringList.Create;
  2487.   try
  2488.     GetConfigParams(Path, Node, Params);
  2489.     C := 0;
  2490.     for I := 0 to Params.Count - 1 do
  2491.     begin
  2492.       J := List.IndexOfName(Params.Names[I]);
  2493.       if J >= 0 then
  2494.       begin
  2495.         Params[I] := List[J];
  2496.         Inc(C);
  2497.       end;
  2498.     end;
  2499.     if C > 0 then SetConfigParams(Path, Node, Params);
  2500.   finally
  2501.     Params.Free;
  2502.   end;
  2503. end;
  2504.  
  2505. procedure TSession.Open;
  2506. begin
  2507.   SetActive(True);
  2508. end;
  2509.  
  2510. function TSession.OpenDatabase(const DatabaseName: string): TDatabase;
  2511. var
  2512.   TempDatabase: TDatabase;
  2513. begin
  2514.   MakeCurrent;
  2515.   TempDatabase := nil;
  2516.   try
  2517.     Result := FindDatabase(DatabaseName);
  2518.     if Result = nil then
  2519.     begin
  2520.       TempDatabase := TDatabase.Create(Self);
  2521.       TempDatabase.DatabaseName := DatabaseName;
  2522.       TempDatabase.KeepConnection := FKeepConnections;
  2523.       TempDatabase.Temporary := True;
  2524.       Result := TempDatabase;
  2525.     end;
  2526.     Result.Open;
  2527.     Inc(Result.FRefCount);
  2528.   except
  2529.     TempDatabase.Free;
  2530.     raise;
  2531.   end;
  2532. end;
  2533.  
  2534. procedure TSession.RegisterCallbacks(Value: Boolean);
  2535.  
  2536.   procedure UnloadSMClient;
  2537.   begin
  2538.     try
  2539.       FreeMem(FSMBuffer, smTraceBufSize);
  2540.       FSMClient.Free;
  2541.       FreeLibrary(FClientLib);
  2542.     except
  2543.     end;
  2544.   end;
  2545.  
  2546.   function LoadSMClient: Boolean;
  2547.   var
  2548.     FM: THandle;
  2549.     ClientLibPath: PChar;
  2550.     ClientName: string;
  2551.     FOldCBFunc: pfDBICallBack;
  2552.   begin
  2553.     Result := False;
  2554.     try
  2555.       if DbiGetCallBack(nil, cbTrace, nil, nil, nil,
  2556.         FOldCBFunc) = DBIERR_NONE then Exit;
  2557.       FM := OpenFileMapping(FILE_MAP_READ, False, 'SMClientLib');
  2558.       if FM <> 0 then
  2559.       try
  2560.         ClientLibPath := MapViewOfFile(FM, FILE_MAP_READ, 0, 0, MAX_PATH);
  2561.         FClientLib := LoadLibrary(ClientLibPath);
  2562.         if FClientLib > 32 then
  2563.         try
  2564.           FSMRegProc := GetProcAddress(FClientLib, 'RegisterClient');
  2565.           if not Assigned(FSMRegProc) then SysUtils.Abort;
  2566.           ClientName := Application.Title;
  2567.           if ClientName = '' then  ClientName := LoadStr(SUntitled);
  2568.           if not FDefault then
  2569.             ClientName := Format('%s.%s', [ClientName, SessionName]);
  2570.           FSMClient := FSMRegProc(Integer(FHandle), PChar(ClientName),
  2571.             FSMWriteProc, Self, @TSession.SMClientSignal);
  2572.           if not Assigned(FSMClient) then SysUtils.Abort;
  2573.           GetMem(FSMBuffer, smTraceBufSize);
  2574.           Result := True;
  2575.         except
  2576.           UnloadSMClient;
  2577.           FClientLib := 0;
  2578.         end;
  2579.       finally
  2580.         CloseHandle(FM);
  2581.       end;
  2582.     except
  2583.     end;
  2584.   end;
  2585.  
  2586. var
  2587.   I: Integer;
  2588. begin
  2589.   if Value then
  2590.   begin
  2591.     FCallbacks.Add(TBDECallback.Create(Self, nil, cbSERVERCALL,
  2592.       @FCBSCType, SizeOf(CBSCType), ServerCallBack, False));
  2593.  
  2594.     FCallbacks.Add(TBDECallback.Create(Self, nil, cbDBLOGIN,
  2595.       @FCBDBLogin, SizeOf(TCBDBLogin), DBLoginCallBack, False));
  2596.  
  2597.     if LoadSMClient then
  2598.       FCallbacks.Add(TBDECallback.Create(Self, nil, cbTRACE,
  2599.         FSMBuffer, smTraceBufSize, SqlTraceCallBack, False));
  2600.   end else
  2601.   begin
  2602.     for I := FCallbacks.Count - 1 downto 0 do
  2603.       TBDECallback(FCallbacks[I]).Free;
  2604.     FCallbacks.Clear;
  2605.     if (FClientLib <> 0) then UnloadSMClient;
  2606.   end;
  2607. end;
  2608.  
  2609. procedure TSession.RemoveDatabase(Value: TDatabase);
  2610. begin
  2611.   FDatabases.Remove(Value);
  2612.   DBNotification(dbRemove, Value);
  2613. end;
  2614.  
  2615. procedure TSession.RemoveAllPasswords;
  2616. begin
  2617.   LockSession;
  2618.   try
  2619.     DbiDropPassword(nil);
  2620.   finally
  2621.     UnlockSession;
  2622.   end;
  2623. end;
  2624.  
  2625. procedure TSession.RemovePassword(const Password: string);
  2626. var
  2627.   Buffer: array[0..255] of Char;
  2628. begin
  2629.   LockSession;
  2630.   try
  2631.     if Password <> '' then
  2632.       DbiDropPassword(AnsiToNative(Locale, Password, Buffer,
  2633.         SizeOf(Buffer) - 1));
  2634.   finally
  2635.     UnlockSession;
  2636.   end;
  2637. end;
  2638.  
  2639. procedure TSession.SaveConfigFile;
  2640. var
  2641.   CfgModeSave: TConfigMode;
  2642. begin
  2643.   CfgModeSave := ConfigMode;
  2644.   try
  2645.     ConfigMode := cmPersistent;
  2646.     Check(DbiCfgSave(nil, nil, False));
  2647.   finally
  2648.     ConfigMode := CfgModeSave;
  2649.   end;
  2650. end;
  2651.  
  2652. function TSession.ServerCallBack(CBInfo: Pointer): CBRType;
  2653. const
  2654.   MinWait = 500;
  2655. begin
  2656.   Result := cbrUSEDEF;
  2657.   if (FCBSCType = cbscSQL) and (GetCurrentThreadID = MainThreadID) then
  2658.   begin
  2659.     if StartTime = 0 then
  2660.     begin
  2661.       TimerID := SetTimer(0, 0, 1000, @TimerCallBack);
  2662.       AcquiredTimer := TimerID <> 0;
  2663.       StartTime := GetTickCount;
  2664.     end
  2665.     else if AcquiredTimer and (GetTickCount - StartTime > MinWait) then
  2666.       Screen.Cursor := crSQLWait;
  2667.   end;
  2668. end;
  2669.  
  2670. procedure TSession.SetActive(Value: Boolean);
  2671. begin
  2672.   if csReading in ComponentState then
  2673.     FStreamedActive := Value
  2674.   else
  2675.     if Active <> Value then
  2676.       StartSession(Value);
  2677. end;
  2678.  
  2679. function TSession.GetConfigMode: TConfigMode;
  2680. begin
  2681.   LockSession;
  2682.   try
  2683.     Result := TConfigMode(GetIntProp(FHandle, sesCfgMode));
  2684.   finally
  2685.     UnlockSession;
  2686.   end;
  2687. end;
  2688.  
  2689. procedure TSession.SetConfigMode(Value: TConfigMode);
  2690. begin
  2691.   LockSession;
  2692.   try
  2693.     Check(DbiSetProp(hDBIObj(FHandle), sesCFGMODE, Longint(Value)));
  2694.   finally
  2695.     UnlockSession;
  2696.   end;
  2697. end;
  2698.  
  2699. procedure TSession.SetConfigParams(const Path, Node: string; List: TStrings);
  2700. var
  2701.   ParamList: TParamList;
  2702. begin
  2703.   ParamList := TParamList.Create(List);
  2704.   try
  2705.     with ParamList do
  2706.       Check(DbiCfgModifyRecord(nil, PChar(Format(Path, [Node])), FieldCount,
  2707.         PFLDDesc(FieldDescs), Buffer));
  2708.   finally
  2709.     ParamList.Free;
  2710.   end;
  2711. end;
  2712.  
  2713. procedure TSession.SetNetFileDir(const Value: string);
  2714. var
  2715.   Buffer: array[0..255] of Char;
  2716. begin
  2717.   if Active then
  2718.   begin
  2719.     LockSession;
  2720.     try
  2721.       Check(DbiSetProp(HDBIOBJ(Handle), sesNETFILE, Longint(AnsiToNative(nil,
  2722.         Value, Buffer, SizeOf(Buffer) - 1))));
  2723.     finally
  2724.       UnLockSession;
  2725.     end;
  2726.   end;
  2727.   FNetFileDir := Value;
  2728. end;
  2729.  
  2730. procedure TSession.SetPrivateDir(const Value: string);
  2731. var
  2732.   Buffer: array[0..255] of Char;
  2733. begin
  2734.   if Active then
  2735.   begin
  2736.     LockSession;
  2737.     try
  2738.       Check(DbiSetPrivateDir(AnsiToNative(nil, Value, Buffer,
  2739.         SizeOf(Buffer) - 1)));
  2740.     finally
  2741.       UnlockSession;
  2742.     end;
  2743.   end;
  2744.   FPrivateDir := Value;
  2745. end;
  2746.  
  2747. procedure TSession.SetSessionName(const Value: string);
  2748. var
  2749.   Ses: TSession;
  2750. begin
  2751.   CheckInActive;
  2752.   if Value <> '' then
  2753.   begin
  2754.     Ses := Sessions.FindSession(Value);
  2755.     if not ((Ses = nil) or (Ses = Self)) then
  2756.       DBErrorFmt(SDuplicateSessionName, [Value]);
  2757.   end;
  2758.   FSessionName := Value
  2759. end;
  2760.  
  2761. procedure TSession.SetTraceFlags(Value: TTraceFlags);
  2762. var
  2763.   I: Integer;
  2764. begin
  2765.   FTraceFlags := Value;
  2766.   for I := FDatabases.Count - 1 downto 0 do
  2767.     with TDatabase(FDatabases[I]) do
  2768.       TraceFlags := FTraceFlags;
  2769. end;
  2770.  
  2771. procedure TSession.SMClientSignal(Sender: TObject; Data: Integer);
  2772. begin
  2773.   SetTraceFlags(TTraceFlags(Word(Data)));
  2774. end;
  2775.  
  2776. function TSession.SqlTraceCallBack(CBInfo: Pointer): CBRType;
  2777. var
  2778.   Len: Integer;
  2779.   Data: PChar;
  2780. begin
  2781.   Result := cbrUSEDEF;
  2782.   try
  2783.     Data := @PTraceDesc(CBInfo).pszTrace;
  2784.     Len := StrLen(Data);
  2785.     if not FSMWriteProc(FSMClient, Data, Len) then SysUtils.abort;
  2786.   except
  2787.     SetTraceFlags([]);
  2788.   end;
  2789. end;
  2790.  
  2791. procedure TSession.StartSession(Value: Boolean);
  2792. var
  2793.   I: Integer;
  2794. begin
  2795.   EnterCriticalSection(FCSect);
  2796.   try
  2797.     if Value then
  2798.     begin
  2799.       if Assigned(FOnStartup) then FOnStartup(Self);
  2800.       if FSessionName = '' then DBError(SSessionNameMissing);
  2801.       if (DB.Session <> Self) then DB.Session.Active := True;
  2802.       if FDefault then
  2803.         InitializeBDE
  2804.       else
  2805.         Check(DbiStartSession(nil, FHandle, nil));
  2806.       try
  2807.         RegisterCallbacks(True);
  2808.         if FNetFileDir <> '' then SetNetFileDir(FNetFileDir);
  2809.         if FPrivateDir <> '' then SetPrivateDir(FPrivateDir);
  2810.         ConfigMode := cmAll;
  2811.         CallBDEInitProcs;
  2812.       except
  2813.         StartSession(False);
  2814.         raise;
  2815.       end;
  2816.     end else
  2817.     begin
  2818.       DbiSetCurrSession(FHandle);
  2819.       for I := FDatabases.Count - 1 downto 0 do
  2820.         with TDatabase(FDatabases[I]) do
  2821.           if Temporary then Free else Close;
  2822.       RegisterCallbacks(False);
  2823.       if FDefault then
  2824.       begin
  2825.         if not FDLLDetach then
  2826.         begin
  2827.           if IsLibrary then
  2828.           begin
  2829.             DbiRegisterCallback(nil, cbDETACHNOTIFY, 0, 0, @DLLDetachCallBack, nil);
  2830.             DbiDLLExit;
  2831.           end;
  2832.           DbiExit;
  2833.         end;
  2834.       end
  2835.       else
  2836.       begin
  2837.         Check(DbiCloseSession(FHandle));
  2838.         DbiSetCurrSession(Session.FHandle);
  2839.       end;
  2840.       FHandle := nil;
  2841.     end;
  2842.   finally
  2843.     LeaveCriticalSection(FCSect);
  2844.   end;
  2845. end;
  2846.  
  2847. { TParamList }
  2848.  
  2849. constructor TParamList.Create(Params: TStrings);
  2850. var
  2851.   I, P, FieldNo: Integer;
  2852.   BufPtr: PChar;
  2853.   S: string;
  2854. begin
  2855.   for I := 0 to Params.Count - 1 do
  2856.   begin
  2857.     S := Params[I];
  2858.     P := Pos('=', S);
  2859.     if P <> 0 then
  2860.     begin
  2861.       Inc(FFieldCount);
  2862.       Inc(FBufSize, Length(S) - P + 1);
  2863.     end;
  2864.   end;
  2865.   if FFieldCount > 0 then
  2866.   begin
  2867.     FFieldDescs := AllocMem(FFieldCount * SizeOf(FLDDesc));
  2868.     FBuffer := AllocMem(FBufSize);
  2869.     FieldNo := 0;
  2870.     BufPtr := FBuffer;
  2871.     for I := 0 to Params.Count - 1 do
  2872.     begin
  2873.       S := Params[I];
  2874.       P := Pos('=', S);
  2875.       if P <> 0 then
  2876.         with FFieldDescs^[FieldNo] do
  2877.         begin
  2878.           Inc(FieldNo);
  2879.           iFldNum := FieldNo;
  2880.           StrPLCopy(szName, Copy(S, 1, P - 1), SizeOf(szName) - 1);
  2881.           iFldType := fldZSTRING;
  2882.           iOffset := BufPtr - FBuffer;
  2883.           iLen := Length(S) - P + 1;
  2884.           StrCopy(BufPtr, PChar(Copy(S, P + 1, 255)));
  2885.           CharToOem(BufPtr, BufPtr);
  2886.           Inc(BufPtr, iLen);
  2887.         end;
  2888.     end;
  2889.   end;
  2890. end;
  2891.  
  2892. destructor TParamList.Destroy;
  2893. begin
  2894.   DisposeMem(FFieldDescs, FFieldCount * SizeOf(FLDDesc));
  2895.   DisposeMem(FBuffer, FBufSize);
  2896. end;
  2897.  
  2898. { TDatabase }
  2899.  
  2900. constructor TDatabase.Create(AOwner: TComponent);
  2901. begin
  2902.   inherited Create(AOwner);
  2903.   Exclude(FComponentStyle, csInheritable);
  2904.   if AOwner is TSession then
  2905.     FSession := TSession(AOwner) else
  2906.     FSession := DB.Session;
  2907.   SessionName := FSession.SessionName;
  2908.   FSession.AddDatabase(Self);
  2909.   FDataSets := TList.Create;
  2910.   FParams := TStringList.Create;
  2911.   TStringList(FParams).OnChanging := ParamsChanging;
  2912.   FLoginPrompt := True;
  2913.   FKeepConnection := True;
  2914.   FLocale := FSession.Locale;
  2915.   FTransIsolation := tiReadCommitted;
  2916. end;
  2917.  
  2918. destructor TDatabase.Destroy;
  2919. begin
  2920.   Close;
  2921.   FParams.Free;
  2922.   FDataSets.Free;
  2923.   if FSession <> nil then
  2924.     FSession.RemoveDatabase(Self);
  2925.   inherited Destroy;
  2926. end;
  2927.  
  2928. procedure TDatabase.ApplyUpdates(const DataSets: array of TDBDataSet);
  2929. var
  2930.   I: Integer;
  2931.   DS: TDBDataSet;
  2932. begin
  2933.   StartTransaction;
  2934.   try
  2935.     for I := 0 to High(DataSets) do
  2936.     begin
  2937.       DS := DataSets[I];
  2938.       if DS.Database <> Self then
  2939.         DatabaseError(FmtLoadStr(SUpdateWrongDB, [DS.Name, Name]));
  2940.       DataSets[I].ApplyUpdates;
  2941.     end;
  2942.     Commit;
  2943.   except
  2944.     Rollback;
  2945.     raise;
  2946.   end;
  2947.   for I := 0 to High(DataSets) do
  2948.     DataSets[I].CommitUpdates;
  2949. end;
  2950.  
  2951. procedure TDatabase.CheckActive;
  2952. begin
  2953.   if FHandle = nil then DBError(SDatabaseClosed);
  2954. end;
  2955.  
  2956. procedure TDatabase.CheckInactive;
  2957. begin
  2958.   if FHandle <> nil then DBError(SDatabaseOpen);
  2959. end;
  2960.  
  2961. procedure TDatabase.CheckDatabaseName;
  2962. begin
  2963.   if (FDatabaseName = '') and not Temporary then
  2964.     DBError(SDatabaseNameMissing);
  2965. end;
  2966.  
  2967. procedure TDatabase.CheckSessionName(Required: Boolean);
  2968. var
  2969.   NewSession: TSession;
  2970. begin
  2971.   if Required then
  2972.     NewSession := Sessions.List[FSessionName]
  2973.   else
  2974.     NewSession := Sessions.FindSession(FSessionName);
  2975.   if (NewSession <> nil) and (NewSession <> FSession) then
  2976.   begin
  2977.     FSession.RemoveDatabase(Self);
  2978.     FSession := NewSession;
  2979.     FSession.AddDatabase(Self);
  2980.   end;
  2981.   if Required then FSession.Active := True;
  2982. end;
  2983.  
  2984. procedure TDatabase.Close;
  2985. begin
  2986.   if FHandle <> nil then
  2987.   begin
  2988.     Session.DBNotification(dbClose, Self);
  2989.     CloseDataSets;
  2990.     if FLocaleLoaded then OsLdUnloadObj(FLocale);
  2991.     FLocaleLoaded := False;
  2992.     FLocale := DB.Session.Locale;
  2993.     if not FAcquiredHandle then
  2994.       DbiCloseDatabase(FHandle)
  2995.     else
  2996.       FAcquiredHandle := False;
  2997.     FSQLBased := False;
  2998.     FHandle := nil;
  2999.     FRefCount := 0;
  3000.     if FSessionAlias then
  3001.     begin
  3002.       FSession.InternalDeleteAlias(FDatabaseName, cmSession, True);
  3003.       FSessionAlias := False;
  3004.     end;
  3005.   end;
  3006. end;
  3007.  
  3008. procedure TDatabase.CloseDataSets;
  3009. begin
  3010.   while FDataSets.Count <> 0 do TDBDataSet(FDataSets.Last).Disconnect;
  3011. end;
  3012.  
  3013. procedure TDatabase.Commit;
  3014. begin
  3015.   CheckActive;
  3016.   EndTransaction(xendCOMMIT);
  3017. end;
  3018.  
  3019. procedure TDatabase.EndTransaction(TransEnd: EXEnd);
  3020. begin
  3021.   if FTransHandle = nil then DBErrorFmt(SEndTransError, [FDatabaseName]);
  3022.   Check(DbiEndTran(FHandle, FTransHandle, TransEnd));
  3023.   FTransHandle := nil;
  3024. end;
  3025.  
  3026. function TDatabase.GetAliasName: string;
  3027. begin
  3028.   if FAliased then Result := FDatabaseType else Result := '';
  3029. end;
  3030.  
  3031. function TDatabase.GetConnected: Boolean;
  3032. begin
  3033.   Result := FHandle <> nil;
  3034. end;
  3035.  
  3036. function TDatabase.GetDataSet(Index: Integer): TDBDataSet;
  3037. begin
  3038.   Result := FDataSets[Index];
  3039. end;
  3040.  
  3041. function TDatabase.GetDataSetCount: Integer;
  3042. begin
  3043.   Result := FDataSets.Count;
  3044. end;
  3045.  
  3046. function TDatabase.GetDirectory: string;
  3047. var
  3048.   SDirectory: DBIPATH;
  3049. begin
  3050.   Check(DbiGetDirectory(Handle, False, SDirectory));
  3051.   SetLength(Result, StrLen(SDirectory));
  3052.   OemToChar(SDirectory, PChar(Result));
  3053. end;
  3054.  
  3055. function TDatabase.GetDriverName: string;
  3056. begin
  3057.   if FAliased then Result := '' else Result := FDatabaseType;
  3058. end;
  3059.  
  3060. function TDatabase.GetIsSQLBased: Boolean;
  3061. var
  3062.   Length: Word;
  3063.   Buffer: array[0..63] of Char;
  3064. begin
  3065.   Result := False;
  3066.   if FHandle <> nil then
  3067.   begin
  3068.     Check(DbiGetProp(HDBIOBJ(FHandle), dbDATABASETYPE, @Buffer,
  3069.       SizeOf(Buffer), Length));
  3070.     Result := StrIComp(Buffer, szCFGDBSTANDARD) <> 0;
  3071.   end;
  3072. end;
  3073.  
  3074. function TDatabase.GetTraceFlags: TTraceFlags;
  3075. begin
  3076.   if Connected and IsSQLBased then
  3077.     Result := TTraceFlags(Word(GetIntProp(FHandle, dbTraceMode)))
  3078.   else
  3079.     Result := [];
  3080. end;
  3081.  
  3082. function TDatabase.GetInTransaction: Boolean;
  3083. var
  3084.   X: XInfo;
  3085. begin
  3086.   Result := (Handle <> nil) and (DbiGetTranInfo(Handle, nil, @X) = DBIERR_NONE)
  3087.     and (X.exState = xsActive);
  3088. end;
  3089.  
  3090. procedure TDatabase.Loaded;
  3091. begin
  3092.   inherited Loaded;
  3093.   try
  3094.     if FStreamedConnected then Open
  3095.     else CheckSessionName(False);
  3096.   except
  3097.     if csDesigning in ComponentState then
  3098.       Application.HandleException(Self)
  3099.     else
  3100.       raise;
  3101.   end;
  3102. end;
  3103.  
  3104. procedure TDatabase.LoadLocale;
  3105. var
  3106.   LName: DBIName;
  3107.   DBLocale: TLocale;
  3108. begin
  3109.   if IsSQLBased and (DbiGetLdNameFromDB(FHandle, nil, LName) = 0) and
  3110.     (OsLdLoadBySymbName(LName, DBLocale) = 0) then
  3111.   begin
  3112.     FLocale := DBLocale;
  3113.     FLocaleLoaded := True;
  3114.   end;
  3115. end;
  3116.  
  3117. procedure TDatabase.Login(LoginParams: TStrings);
  3118. var
  3119.   UserName, Password: string;
  3120. begin
  3121.   if Assigned(FOnLogin) then FOnLogin(Self, LoginParams) else
  3122.   begin
  3123.     UserName := LoginParams.Values[szUSERNAME];
  3124.     if not LoginDialogEx(DatabaseName, UserName, Password, False) then
  3125.       DBErrorFmt(SLoginError, [DatabaseName]);
  3126.     LoginParams.Values[szUSERNAME] := UserName;
  3127.     LoginParams.Values[szPASSWORD] := Password;
  3128.   end;
  3129. end;
  3130.  
  3131. procedure TDatabase.CheckDatabaseAlias(var Password: string);
  3132. var
  3133.   Desc: DBDesc;
  3134.   Aliased: Boolean;
  3135.   DBName: string;
  3136.   DriverType: string;
  3137.   AliasParams: TStringList;
  3138.   LoginParams: TStringList;
  3139.  
  3140.   function NeedsDBAlias: Boolean;
  3141.   var
  3142.     I: Integer;
  3143.     PName: String;
  3144.   begin
  3145.     Result := not Aliased or ((FDatabaseType <> '') and
  3146.       (FDatabaseName <> FDatabaseType));
  3147.     for I := 0 to FParams.Count - 1 do
  3148.     begin
  3149.       if AliasParams.IndexOf(FParams[I]) > -1 then continue;
  3150.       PName := FParams.Names[I];
  3151.       if (CompareText(PName, szPASSWORD) = 0) then continue;
  3152.       if AliasParams.IndexOfName(PName) > -1 then
  3153.       begin
  3154.         Result := True;
  3155.         AliasParams.Values[PName] := FParams.Values[PName];
  3156.       end;
  3157.     end;
  3158.   end;
  3159.  
  3160. begin
  3161.   Password := '';
  3162.   FSessionAlias := False;
  3163.   AliasParams := TStringList.Create;
  3164.   try
  3165.     begin
  3166.       if FDatabaseType <> '' then
  3167.       begin
  3168.         DBName := FDatabaseType;
  3169.         Aliased := FAliased;
  3170.       end else
  3171.       begin
  3172.         DBName := FDatabaseName;
  3173.         Aliased := True;
  3174.       end;
  3175.       if Aliased then
  3176.       begin
  3177.         if DbiGetDatabaseDesc(PChar(StrToOem(DBName)), @Desc) <> 0 then Exit;
  3178.         if Desc.szDBType[sizeOf(Desc.szDBType) - 1] <> #0 then
  3179.           Desc.szDBType[sizeOf(Desc.szDBType) - 1] := #0;
  3180.         OemToChar(Desc.szDbType, Desc.szDbType);
  3181.         DriverType := Desc.szDbType;
  3182.         FSession.GetAliasParams(DBName, AliasParams);
  3183.       end else
  3184.       begin
  3185.         FSession.GetDriverParams(DBName, AliasParams);
  3186.         DriverType := FDatabaseType;
  3187.       end;
  3188.       if (DriverType <> szCFGDBSTANDARD) then
  3189.       begin
  3190.         if LoginPrompt then
  3191.         begin
  3192.           LoginParams := TStringList.Create;
  3193.           try
  3194.             if FParams.Values[szUSERNAME] = '' then
  3195.               FParams.Values[szUSERNAME] := AliasParams.Values[szUSERNAME];
  3196.             LoginParams.Values[szUSERNAME] := FParams.Values[szUSERNAME];
  3197.             Login(LoginParams);
  3198.             Password := LoginParams.Values[szPASSWORD];
  3199.             FParams.Values[szUSERNAME] := LoginParams.Values[szUSERNAME];
  3200.           finally
  3201.             LoginParams.Free;
  3202.           end;
  3203.         end else
  3204.           Password := FParams.Values[szPASSWORD];
  3205.       end;
  3206.     end;
  3207.     if NeedsDBAlias then
  3208.     begin
  3209.       FSession.InternalAddAlias(FDatabaseName, DriverType, AliasParams,
  3210.         cmSession, False);
  3211.       FSessionAlias := True;
  3212.     end;
  3213.   finally
  3214.     AliasParams.Free;
  3215.   end;
  3216. end;
  3217.  
  3218. procedure TDatabase.Open;
  3219. var
  3220.   DBName: string;
  3221.   DBPassword: string;
  3222.   CfgModeSave: TConfigMode;
  3223. begin
  3224.   if FHandle = nil then
  3225.   begin
  3226.     CheckDatabaseName;
  3227.     CheckSessionName(True);
  3228.     FSession.LockSession;
  3229.     try
  3230.       CfgModeSave := FSession.ConfigMode;
  3231.       try
  3232.         CheckDatabaseAlias(DBPassword);
  3233.         try
  3234.           if (FDatabaseType = '') and IsDirectory(FDatabaseName) then
  3235.             DBName := '' else
  3236.             DBName := StrToOem(FDatabaseName);
  3237.           Check(DbiOpenDatabase(Pointer(DBName), nil, dbiREADWRITE, dbiOPENSHARED,
  3238.             Pointer(StrToOem(DBPassword)), 0, nil, nil, FHandle));
  3239.           if DBName = '' then SetDirectory(FDatabaseName);
  3240.           DbiSetProp(HDBIOBJ(FHandle), dbUSESCHEMAFILE, Longint(True));
  3241.           DbiSetProp(HDBIOBJ(FHandle), dbPARAMFMTQMARK, Longint(True));
  3242.           FSQLBased := GetIsSQLBased;
  3243.           LoadLocale;
  3244.           TraceFlags := FSession.FTraceFlags;
  3245.           Session.DBNotification(dbOpen, Self);
  3246.         except
  3247.           if FSessionAlias then
  3248.             FSession.InternalDeleteAlias(FDatabaseName, cmSession, False);
  3249.           raise;
  3250.         end;
  3251.       finally
  3252.         FSession.ConfigMode := CfgModeSave;
  3253.       end;
  3254.     finally
  3255.       FSession.UnlockSession;
  3256.     end;
  3257.   end;
  3258. end;
  3259.  
  3260. procedure TDatabase.ParamsChanging(Sender: TObject);
  3261. begin
  3262.   CheckInactive;
  3263. end;
  3264.  
  3265. procedure TDatabase.Rollback;
  3266. begin
  3267.   CheckActive;
  3268.   EndTransaction(xendABORT);
  3269. end;
  3270.  
  3271. procedure TDatabase.SetAliasName(const Value: string);
  3272. begin
  3273.   SetDatabaseType(Value, True);
  3274. end;
  3275.  
  3276. procedure TDatabase.SetConnected(Value: Boolean);
  3277. begin
  3278.   if csReading in ComponentState then
  3279.     FStreamedConnected := Value
  3280.   else
  3281.     if Value then Open else Close;
  3282. end;
  3283.  
  3284. procedure TDatabase.SetDatabaseName(const Value: string);
  3285. begin
  3286.   if FDatabaseName <> Value then
  3287.   begin
  3288.     CheckInactive;
  3289.     ValidateName(Value);
  3290.     FDatabaseName := Value;
  3291.   end;
  3292. end;
  3293.  
  3294. procedure TDatabase.SetDatabaseType(const Value: string;
  3295.   Aliased: Boolean);
  3296. begin
  3297.   CheckInactive;
  3298.   FDatabaseType := Value;
  3299.   FAliased := Aliased;
  3300. end;
  3301.  
  3302. procedure TDatabase.SetDirectory(const Value: string);
  3303. begin
  3304.   Check(DbiSetDirectory(Handle, Pointer(StrToOem(Value))));
  3305. end;
  3306.  
  3307. procedure TDatabase.SetDriverName(const Value: string);
  3308. begin
  3309.   SetDatabaseType(Value, False);
  3310. end;
  3311.  
  3312. procedure TDatabase.SetHandle(Value: HDBIDB);
  3313. var
  3314.   DBSession: HDBISes;
  3315. begin
  3316.   if Connected then Close;
  3317.   if Value <> nil then
  3318.   begin
  3319.     Check(DbiGetObjFromObj(HDBIObj(Value), objSESSION, HDBIObj(DBSession)));
  3320.     CheckDatabaseName;
  3321.     CheckSessionName(True);
  3322.     if FSession.Handle <> DBSession then DBError(SDatabaseHandleSet);
  3323.     FHandle := Value;
  3324.     FSQLBased := GetIsSQLBased;
  3325.     LoadLocale;
  3326.     Session.DBNotification(dbOpen, Self);
  3327.     FAcquiredHandle := True;
  3328.   end;
  3329. end;
  3330.  
  3331. procedure TDatabase.SetKeepConnection(Value: Boolean);
  3332. begin
  3333.   if FKeepConnection <> Value then
  3334.   begin
  3335.     FKeepConnection := Value;
  3336.     if not Value and (FRefCount = 0) then Close;
  3337.   end;
  3338. end;
  3339.  
  3340. procedure TDatabase.SetParams(Value: TStrings);
  3341. begin
  3342.   CheckInactive;
  3343.   FParams.Assign(Value);
  3344. end;
  3345.  
  3346. procedure TDatabase.SetSessionName(const Value: string);
  3347. begin
  3348.   CheckInactive;
  3349.   if FSessionName <> Value then
  3350.   begin
  3351.     FSessionName := Value;
  3352.     CheckSessionName(False);
  3353.   end;
  3354. end;
  3355.  
  3356. procedure TDatabase.SetTraceFlags(Value: TTraceFlags);
  3357. begin
  3358.   if Connected and IsSQLBased then
  3359.     DbiSetProp(hDBIObj(FHandle), dbTraceMode, Integer(Word(Value)));
  3360. end;
  3361.  
  3362. procedure TDatabase.StartTransaction;
  3363. begin
  3364.   CheckActive;
  3365.   if FTransHandle <> nil then DBErrorFmt(SBeginTransError, [FDatabaseName]);
  3366.   if not IsSQLBased and (TransIsolation <> tiDirtyRead) then
  3367.     DBError(SLocalTransDirty);
  3368.   Check(DbiBeginTran(FHandle, EXILType(FTransIsolation), FTransHandle));
  3369. end;
  3370.  
  3371. procedure TDatabase.ValidateName(const Name: string);
  3372. var
  3373.   Database: TDatabase;
  3374. begin
  3375.   if Name <> '' then
  3376.   begin
  3377.     Database := FSession.FindDatabase(Name);
  3378.     if (Database <> nil) and (Database <> Self) then
  3379.     begin
  3380.       if not Database.Temporary or (Database.FRefCount <> 0) then
  3381.         DBErrorFmt(SDuplicateDatabaseName, [Name]);
  3382.       Database.Free;
  3383.     end;
  3384.   end;
  3385. end;
  3386.  
  3387. procedure TDatabase.FlushSchemaCache(const TableName: string);
  3388. begin
  3389.   if Connected and IsSQLBased then
  3390.     Check(DbiSchemaCacheFlush(FHandle, PChar(TableName)));
  3391. end;
  3392.  
  3393. { TDataSetDesigner }
  3394.  
  3395. constructor TDataSetDesigner.Create(DataSet: TDataSet);
  3396. begin
  3397.   FDataSet := DataSet;
  3398.   FDataSet.FDesigner := Self;
  3399. end;
  3400.  
  3401. destructor TDataSetDesigner.Destroy;
  3402. begin
  3403.   FDataSet.FDesigner := nil;
  3404. end;
  3405.  
  3406. procedure TDataSetDesigner.BeginDesign;
  3407. begin
  3408.   FSaveActive := FDataSet.Active;
  3409.   if FSaveActive then
  3410.   begin
  3411.     FDataSet.InternalClose;
  3412.     FDataSet.SetState(dsInactive);
  3413.   end;
  3414.   FDataSet.DisableControls;
  3415. end;
  3416.  
  3417. procedure TDataSetDesigner.DataEvent(Event: TDataEvent; Info: Longint);
  3418. begin
  3419. end;
  3420.  
  3421. procedure TDataSetDesigner.EndDesign;
  3422. begin
  3423.   FDataSet.EnableControls;
  3424.   if FSaveActive then
  3425.   begin
  3426.     try
  3427.       FDataSet.InternalOpen;
  3428.       FDataSet.SetState(dsBrowse);
  3429.     except
  3430.       FDataSet.SetState(dsInactive);
  3431.       FDataSet.CloseCursor;
  3432.       raise;
  3433.     end;
  3434.   end;
  3435. end;
  3436.  
  3437. { TFieldDef }
  3438.  
  3439. constructor TFieldDef.Create(Owner: TFieldDefs; const Name: string;
  3440.   DataType: TFieldType; Size: Word; Required: Boolean; FieldNo: Integer);
  3441. begin
  3442.   CheckTypeSize(DataType, Size);
  3443.   if Owner <> nil then
  3444.   begin
  3445.     Owner.FItems.Add(Self);
  3446.     Owner.FUpdated := False;
  3447.     FOwner := Owner;
  3448.   end;
  3449.   FName := Name;
  3450.   FDataType := DataType;
  3451.   FSize := Size;
  3452.   FRequired := Required;
  3453.   FFieldNo := FieldNo;
  3454. end;
  3455.  
  3456. destructor TFieldDef.Destroy;
  3457. begin
  3458.   if FOwner <> nil then
  3459.   begin
  3460.     FOwner.FItems.Remove(Self);
  3461.     FOwner.FUpdated := False;
  3462.   end;
  3463. end;
  3464.  
  3465. function TFieldDef.CreateField(Owner: TComponent): TField;
  3466. var
  3467.   FieldClass: TFieldClass;
  3468. begin
  3469.   FieldClass := GetFieldClass;
  3470.   if FieldClass = nil then DBErrorFmt(SUnknownFieldType, [Name]);
  3471.   Result := FieldClass.Create(Owner);
  3472.   try
  3473.     Result.FieldName := Name;
  3474.     Result.Size := FSize;
  3475.     Result.Required := FRequired;
  3476.     Result.SetFieldType(FDataType);
  3477.     if FOwner <> nil then Result.DataSet := FOwner.FDataSet;
  3478.   except
  3479.     Result.Free;
  3480.     raise;
  3481.   end;
  3482. end;
  3483.  
  3484. function TFieldDef.GetFieldClass: TFieldClass;
  3485. const
  3486.   FieldClasses: array[TFieldType] of TFieldClass = (
  3487.     nil,                { ftUnknown }
  3488.     TStringField,       { ftString }
  3489.     TSmallintField,     { ftSmallint }
  3490.     TIntegerField,      { ftInteger }
  3491.     TWordField,         { ftWord }
  3492.     TBooleanField,      { ftBoolean }
  3493.     TFloatField,        { ftFloat }
  3494.     TCurrencyField,     { ftCurrency }
  3495.     TBCDField,          { ftBCD }
  3496.     TDateField,         { ftDate }
  3497.     TTimeField,         { ftTime }
  3498.     TDateTimeField,     { ftDateTime }
  3499.     TBytesField,        { ftBytes }
  3500.     TVarBytesField,     { ftVarBytes }
  3501.     TAutoIncField,      { ftAutoInc }
  3502.     TBlobField,         { ftBlob }
  3503.     TMemoField,         { ftMemo }
  3504.     TGraphicField,      { ftGraphic }
  3505.     TBlobField,         { ftFmtMemo }
  3506.     TBlobField,         { ftParadoxOle }
  3507.     TBlobField,         { ftDBaseOle }
  3508.     TBlobField);        { ftTypedBinary }
  3509. begin
  3510.   Result := FieldClasses[FDataType];
  3511. end;
  3512.  
  3513. { TFieldDefs }
  3514.  
  3515. constructor TFieldDefs.Create(DataSet: TDataSet);
  3516. begin
  3517.   FDataSet := DataSet;
  3518.   FItems := TList.Create;
  3519. end;
  3520.  
  3521. destructor TFieldDefs.Destroy;
  3522. begin
  3523.   if FItems <> nil then Clear;
  3524.   FItems.Free;
  3525. end;
  3526.  
  3527. procedure TFieldDefs.Add(const Name: string; DataType: TFieldType;
  3528.   Size: Word; Required: Boolean);
  3529. begin
  3530.   if Name = '' then DBError(SFieldNameMissing);
  3531.   if IndexOf(Name) >= 0 then DBErrorFmt(SDuplicateFieldName, [Name]);
  3532.   TFieldDef.Create(Self, Name, DataType, Size, Required, FItems.Count + 1);
  3533. end;
  3534.  
  3535. procedure TFieldDefs.AddFieldDesc(FieldDesc: FLDDesc; Required: Boolean;
  3536.   FieldNo: Word);
  3537. const
  3538.   TypeMap: array[0..MAXLOGFLDTYPES - 1] of TFieldType = (
  3539.     ftUnknown, ftString, ftDate, ftBlob, ftBoolean, ftSmallint,
  3540.     ftInteger, ftFloat, ftBCD, ftBytes, ftTime, ftDateTime,
  3541.     ftWord, ftInteger, ftUnknown, ftVarBytes, ftUnknown);
  3542.   BlobTypeMap: array[fldstMEMO..fldstTYPEDBINARY] of TFieldType = (
  3543.     ftMemo, ftBlob, ftFmtMemo, ftParadoxOle, ftGraphic,
  3544.     ftDBaseOle, ftTypedBinary);
  3545. var
  3546.   DataType: TFieldType;
  3547.   Size: Word;
  3548.   I: Integer;
  3549.   FieldName, Name: string;
  3550. begin
  3551.   with FieldDesc do
  3552.   begin
  3553.     NativeToAnsi(FDataSet.Locale, szName, FieldName);
  3554.     I := 0;
  3555.     Name := FieldName;
  3556.     while IndexOf(Name) >= 0 do
  3557.     begin
  3558.       Inc(I);
  3559.       Name := Format('%s_%d', [FieldName, I]);
  3560.     end;
  3561.     if iFldType < MAXLOGFLDTYPES then
  3562.       DataType := TypeMap[iFldType] else
  3563.       DataType := ftUnknown;
  3564.     Size := 0;
  3565.     case iFldType of
  3566.       fldZSTRING:
  3567.         Size := iUnits1;
  3568.       fldINT16, fldUINT16:
  3569.         if iLen <> 2 then DataType := ftUnknown;
  3570.       fldINT32:
  3571.         if iSubType = fldstAUTOINC then DataType := ftAutoInc;
  3572.       fldFLOAT:
  3573.         if iSubType = fldstMONEY then DataType := ftCurrency;
  3574.       fldBCD:
  3575.         Size := Abs(iUnits2);
  3576.       fldBYTES, fldVARBYTES:
  3577.         Size := iUnits1;
  3578.       fldBLOB:
  3579.         begin
  3580.           Size := iUnits1;
  3581.           if (iSubType >= fldstMEMO) and (iSubType <= fldstTYPEDBINARY) then
  3582.             DataType := BlobTypeMap[iSubType];
  3583.         end;
  3584.     end;
  3585.     if DataType <> ftUnknown then
  3586.       with TFieldDef.Create(Self, Name, DataType, Size, Required, FieldNo) do
  3587.         FBDECalcField := bCalcField;
  3588.   end;
  3589. end;
  3590.  
  3591. procedure TFieldDefs.Assign(FieldDefs: TFieldDefs);
  3592. var
  3593.   I: Integer;
  3594. begin
  3595.   Clear;
  3596.   for I := 0 to FieldDefs.Count - 1 do
  3597.     with FieldDefs[I] do Add(Name, DataType, Size, Required);
  3598. end;
  3599.  
  3600. procedure TFieldDefs.Clear;
  3601. begin
  3602.   while FItems.Count > 0 do TFieldDef(FItems.Last).Free;
  3603. end;
  3604.  
  3605. function TFieldDefs.Find(const Name: string): TFieldDef;
  3606. var
  3607.   I: Integer;
  3608. begin
  3609.   I := IndexOf(Name);
  3610.   if I < 0 then DBErrorFmt(SFieldNotFound, [Name]);
  3611.   Result := FItems[I];
  3612. end;
  3613.  
  3614. function TFieldDefs.GetCount: Integer;
  3615. begin
  3616.   Result := FItems.Count;
  3617. end;
  3618.  
  3619. function TFieldDefs.GetItem(Index: Integer): TFieldDef;
  3620. begin
  3621.   Result := FItems[Index];
  3622. end;
  3623.  
  3624. function TFieldDefs.IndexOf(const Name: string): Integer;
  3625. begin
  3626.   for Result := 0 to FItems.Count - 1 do
  3627.     if AnsiCompareText(TFieldDef(FItems[Result]).Name, Name) = 0 then Exit;
  3628.   Result := -1;
  3629. end;
  3630.  
  3631. procedure TFieldDefs.Update;
  3632. begin
  3633.   FDataSet.UpdateFieldDefs;
  3634. end;
  3635.  
  3636. { TFilterExpr }
  3637.  
  3638. type
  3639.  
  3640.   TExprNodeKind = (enField, enConst, enOperator);
  3641.  
  3642.   PExprNode = ^TExprNode;
  3643.   TExprNode = record
  3644.     FNext: PExprNode;
  3645.     FKind: TExprNodeKind;
  3646.     FPartial: Boolean;
  3647.     FOperator: CanOp;
  3648.     FData: Variant;
  3649.     FLeft: PExprNode;
  3650.     FRight: PExprNode;
  3651.   end;
  3652.  
  3653.   TFilterExpr = class
  3654.   private
  3655.     FDataSet: TDataSet;
  3656.     FOptions: TFilterOptions;
  3657.     FNodes: PExprNode;
  3658.     FExprBuffer: PCANExpr;
  3659.     FExprBufSize: Integer;
  3660.     FExprNodeSize: Integer;
  3661.     FExprDataSize: Integer;
  3662.     function FieldFromNode(Node: PExprNode): TField;
  3663.     function GetExprData(Pos, Size: Integer): PChar;
  3664.     function PutCompareNode(Node: PExprNode): Integer;
  3665.     function PutConstBCD(const Value: Variant; Decimals: Integer): Integer;
  3666.     function PutConstDate(const Value: Variant): Integer;
  3667.     function PutConstDateTime(const Value: Variant): Integer;
  3668.     function PutConstFloat(const Value: Variant): Integer;
  3669.     function PutConstInt(DataType: Integer; const Value: Variant): Integer;
  3670.     function PutConstNode(DataType: Integer; Data: PChar;
  3671.       Size: Integer): Integer;
  3672.     function PutConstStr(const Value: string): Integer;
  3673.     function PutConstTime(const Value: Variant): Integer;
  3674.     function PutData(Data: PChar; Size: Integer): Integer;
  3675.     function PutExprNode(Node: PExprNode): Integer;
  3676.     function PutFieldNode(Field: TField): Integer;
  3677.     function PutNode(NodeType: NodeClass; OpType: CanOp;
  3678.       OpCount: Integer): Integer;
  3679.     procedure SetNodeOp(Node, Index, Data: Integer);
  3680.   public
  3681.     constructor Create(DataSet: TDataSet; Options: TFilterOptions);
  3682.     destructor Destroy; override;
  3683.     function NewCompareNode(Field: TField; Operator: CanOp;
  3684.       const Value: Variant): PExprNode;
  3685.     function NewNode(Kind: TExprNodeKind; Operator: CanOp;
  3686.       const Data: Variant; Left, Right: PExprNode): PExprNode;
  3687.     function GetFilterData(Root: PExprNode): PCANExpr;
  3688.   end;
  3689.  
  3690. constructor TFilterExpr.Create(DataSet: TDataSet; Options: TFilterOptions);
  3691. begin
  3692.   FDataSet := DataSet;
  3693.   FOptions := Options;
  3694. end;
  3695.  
  3696. destructor TFilterExpr.Destroy;
  3697. var
  3698.   Node: PExprNode;
  3699. begin
  3700.   FreeMem(FExprBuffer, FExprBufSize);
  3701.   while FNodes <> nil do
  3702.   begin
  3703.     Node := FNodes;
  3704.     FNodes := Node^.FNext;
  3705.     Dispose(Node);
  3706.   end;
  3707. end;
  3708.  
  3709. function TFilterExpr.FieldFromNode(Node: PExprNode): TField;
  3710. begin
  3711.   Result := FDataSet.FieldByName(Node^.FData);
  3712.   if Result.FieldKind <> fkData then
  3713.     DBErrorFmt(SExprBadField, [Result.FieldName]);
  3714. end;
  3715.  
  3716. function TFilterExpr.GetExprData(Pos, Size: Integer): PChar;
  3717. begin
  3718.   ReallocMem(FExprBuffer, FExprBufSize + Size);
  3719.   Move(PChar(FExprBuffer)[Pos], PChar(FExprBuffer)[Pos + Size],
  3720.     FExprBufSize - Pos);
  3721.   Inc(FExprBufSize, Size);
  3722.   Result := PChar(FExprBuffer) + Pos;
  3723. end;
  3724.  
  3725. function TFilterExpr.GetFilterData(Root: PExprNode): PCANExpr;
  3726. begin
  3727.   FExprBufSize := SizeOf(CANExpr);
  3728.   GetMem(FExprBuffer, FExprBufSize);
  3729.   PutExprNode(Root);
  3730.   with FExprBuffer^ do
  3731.   begin
  3732.     iVer := CANEXPRVERSION;
  3733.     iTotalSize := FExprBufSize;
  3734.     iNodes := $FFFF;
  3735.     iNodeStart := SizeOf(CANExpr);
  3736.     iLiteralStart := FExprNodeSize + SizeOf(CANExpr);
  3737.   end;
  3738.   Result := FExprBuffer;
  3739. end;
  3740.  
  3741. function TFilterExpr.NewCompareNode(Field: TField; Operator: CanOp;
  3742.   const Value: Variant): PExprNode;
  3743. begin
  3744.   Result := NewNode(enOperator, Operator, Unassigned,
  3745.     NewNode(enField, canNOTDEFINED, Field.FieldName, nil, nil),
  3746.     NewNode(enConst, canNOTDEFINED, Value, nil, nil));
  3747. end;
  3748.  
  3749. function TFilterExpr.NewNode(Kind: TExprNodeKind; Operator: CanOp;
  3750.   const Data: Variant; Left, Right: PExprNode): PExprNode;
  3751. begin
  3752.   New(Result);
  3753.   with Result^ do
  3754.   begin
  3755.     FNext := FNodes;
  3756.     FKind := Kind;
  3757.     FPartial := False;
  3758.     FOperator := Operator;
  3759.     FData := Data;
  3760.     FLeft := Left;
  3761.     FRight := Right;
  3762.   end;
  3763.   FNodes := Result;
  3764. end;
  3765.  
  3766. function TFilterExpr.PutCompareNode(Node: PExprNode): Integer;
  3767. const
  3768.   ReverseOperator: array[canEQ..canLE] of CanOp = (
  3769.     canEQ, canNE, canLT, canGT, canLE, canGE);
  3770. var
  3771.   Operator: CanOp;
  3772.   Left, Right, Temp: PExprNode;
  3773.   Field: TField;
  3774.   FieldPos, ConstPos, CaseInsensitive, PartialLength, L: Integer;
  3775.   S: string;
  3776. begin
  3777.   Operator := Node^.FOperator;
  3778.   Left := Node^.FLeft;
  3779.   Right := Node^.FRight;
  3780.   if Right^.FKind = enField then
  3781.   begin
  3782.     Temp := Left;
  3783.     Left := Right;
  3784.     Right := Temp;
  3785.     Operator := ReverseOperator[Operator];
  3786.   end;
  3787.   if (Left^.FKind <> enField) or (Right^.FKind <> enConst) then
  3788.     DBError(SExprBadCompare);
  3789.   Field := FieldFromNode(Left);
  3790.   if VarIsNull(Right^.FData) then
  3791.   begin
  3792.     case Operator of
  3793.       canEQ: Operator := canISBLANK;
  3794.       canNE: Operator := canNOTBLANK;
  3795.     else
  3796.       DBError(SExprBadNullTest);
  3797.     end;
  3798.     Result := PutNode(nodeUNARY, Operator, 1);
  3799.     SetNodeOp(Result, 0, PutFieldNode(Field));
  3800.   end else
  3801.   begin
  3802.     if ((Operator = canEQ) or (Operator = canNE)) and
  3803.       (Field.DataType = ftString) then
  3804.     begin
  3805.       S := Right^.FData;
  3806.       L := Length(S);
  3807.       if L <> 0 then
  3808.       begin
  3809.         CaseInsensitive := 0;
  3810.         PartialLength := 0;
  3811.         if foCaseInsensitive in FOptions then CaseInsensitive := 1;
  3812.         if Node^.FPartial then PartialLength := L else
  3813.           if not (foNoPartialCompare in FOptions) and (L > 1) and
  3814.             (S[L] = '*') then
  3815.           begin
  3816.             Delete(S, L, 1);
  3817.             PartialLength := L - 1;
  3818.           end;
  3819.         if (CaseInsensitive <> 0) or (PartialLength <> 0) then
  3820.         begin
  3821.           Result := PutNode(nodeCOMPARE, Operator, 4);
  3822.           SetNodeOp(Result, 0, CaseInsensitive);
  3823.           SetNodeOp(Result, 1, PartialLength);
  3824.           SetNodeOp(Result, 2, PutFieldNode(Field));
  3825.           SetNodeOp(Result, 3, PutConstStr(S));
  3826.           Exit;
  3827.         end;
  3828.       end;
  3829.     end;
  3830.     Result := PutNode(nodeBINARY, Operator, 2);
  3831.     FieldPos := PutFieldNode(Field);
  3832.     case Field.DataType of
  3833.       ftString:
  3834.         ConstPos := PutConstStr(Right^.FData);
  3835.       ftSmallint:
  3836.         ConstPos := PutConstInt(fldINT16, Right^.FData);
  3837.       ftInteger, ftAutoInc:
  3838.         ConstPos := PutConstInt(fldINT32, Right^.FData);
  3839.       ftWord:
  3840.         ConstPos := PutConstInt(fldUINT16, Right^.FData);
  3841.       ftFloat, ftCurrency:
  3842.         ConstPos := PutConstFloat(Right^.FData);
  3843.       ftBCD:
  3844.         ConstPos := PutConstBCD(Right^.FData, Field.Size);
  3845.       ftDate:
  3846.         ConstPos := PutConstDate(Right^.FData);
  3847.       ftTime:
  3848.         ConstPos := PutConstTime(Right^.FData);
  3849.       ftDateTime:
  3850.         ConstPos := PutConstDateTime(Right^.FData);
  3851.     else
  3852.       DBErrorFmt(SExprBadField, [Field.FieldName]);
  3853.     end;
  3854.     SetNodeOp(Result, 0, FieldPos);
  3855.     SetNodeOp(Result, 1, ConstPos);
  3856.   end;
  3857. end;
  3858.  
  3859. function TFilterExpr.PutConstBCD(const Value: Variant;
  3860.   Decimals: Integer): Integer;
  3861. var
  3862.   C: Currency;
  3863.   BCD: FMTBcd;
  3864. begin
  3865.   if VarType(Value) = varString then
  3866.     C := StrToCurr(string(TVarData(Value).VString)) else
  3867.     C := Value;
  3868.   CurrToBCD(C, BCD, 32, Decimals);
  3869.   Result := PutConstNode(fldBCD, @BCD, 18);
  3870. end;
  3871.  
  3872. function TFilterExpr.PutConstDate(const Value: Variant): Integer;
  3873. var
  3874.   DateTime: TDateTime;
  3875.   TimeStamp: TTimeStamp;
  3876. begin
  3877.   if VarType(Value) = varString then
  3878.     DateTime := StrToDate(string(TVarData(Value).VString)) else
  3879.     DateTime := VarToDateTime(Value);
  3880.   TimeStamp := DateTimeToTimeStamp(DateTime);
  3881.   Result := PutConstNode(fldDATE, @TimeStamp.Date, 4);
  3882. end;
  3883.  
  3884. function TFilterExpr.PutConstDateTime(const Value: Variant): Integer;
  3885. var
  3886.   DateTime: TDateTime;
  3887.   DateData: Double;
  3888. begin
  3889.   if VarType(Value) = varString then
  3890.     DateTime := StrToDateTime(string(TVarData(Value).VString)) else
  3891.     DateTime := VarToDateTime(Value);
  3892.   DateData := TimeStampToMSecs(DateTimeToTimeStamp(DateTime));
  3893.   Result := PutConstNode(fldTIMESTAMP, @DateData, 8);
  3894. end;
  3895.  
  3896. function TFilterExpr.PutConstFloat(const Value: Variant): Integer;
  3897. var
  3898.   F: Double;
  3899. begin
  3900.   if VarType(Value) = varString then
  3901.     F := StrToFloat(string(TVarData(Value).VString)) else
  3902.     F := Value;
  3903.   Result := PutConstNode(fldFLOAT, @F, SizeOf(Double));
  3904. end;
  3905.  
  3906. function TFilterExpr.PutConstInt(DataType: Integer;
  3907.   const Value: Variant): Integer;
  3908. var
  3909.   I, Size: Integer;
  3910. begin
  3911.   if VarType(Value) = varString then
  3912.     I := StrToInt(string(TVarData(Value).VString)) else
  3913.     I := Value;
  3914.   Size := 2;
  3915.   case DataType of
  3916.     fldINT16:
  3917.       if (I < -32768) or (I > 32767) then DBError(SExprRangeError);
  3918.     fldUINT16:
  3919.       if (I < 0) or (I > 65535) then DBError(SExprRangeError);
  3920.   else
  3921.     Size := 4;
  3922.   end;
  3923.   Result := PutConstNode(DataType, @I, Size);
  3924. end;
  3925.  
  3926. function TFilterExpr.PutConstNode(DataType: Integer; Data: PChar;
  3927.   Size: Integer): Integer;
  3928. begin
  3929.   Result := PutNode(nodeCONST, canCONST2, 3);
  3930.   SetNodeOp(Result, 0, DataType);
  3931.   SetNodeOp(Result, 1, Size);
  3932.   SetNodeOp(Result, 2, PutData(Data, Size));
  3933. end;
  3934.  
  3935. function TFilterExpr.PutConstStr(const Value: string): Integer;
  3936. var
  3937.   Buffer: array[0..255] of Char;
  3938. begin
  3939.   AnsiToNative(FDataSet.Locale, Value, Buffer, SizeOf(Buffer) - 1);
  3940.   Result := PutConstNode(fldZSTRING, Buffer, StrLen(Buffer) + 1);
  3941. end;
  3942.  
  3943. function TFilterExpr.PutConstTime(const Value: Variant): Integer;
  3944. var
  3945.   DateTime: TDateTime;
  3946.   TimeStamp: TTimeStamp;
  3947. begin
  3948.   if VarType(Value) = varString then
  3949.     DateTime := StrToTime(string(TVarData(Value).VString)) else
  3950.     DateTime := VarToDateTime(Value);
  3951.   TimeStamp := DateTimeToTimeStamp(DateTime);
  3952.   Result := PutConstNode(fldTIME, @TimeStamp.Time, 4);
  3953. end;
  3954.  
  3955. function TFilterExpr.PutData(Data: PChar; Size: Integer): Integer;
  3956. begin
  3957.   Move(Data^, GetExprData(FExprBufSize, Size)^, Size);
  3958.   Result := FExprDataSize;
  3959.   Inc(FExprDataSize, Size);
  3960. end;
  3961.  
  3962. function TFilterExpr.PutExprNode(Node: PExprNode): Integer;
  3963. const
  3964.   BoolFalse: WordBool = False;
  3965. var
  3966.   Field: TField;
  3967. begin
  3968.   case Node^.FKind of
  3969.     enField:
  3970.       begin
  3971.         Field := FieldFromNode(Node);
  3972.         if Field.DataType <> ftBoolean then
  3973.           DBErrorFmt(SExprNotBoolean, [Field.FieldName]);
  3974.         Result := PutNode(nodeBINARY, canNE, 2);
  3975.         SetNodeOp(Result, 0, PutFieldNode(Field));
  3976.         SetNodeOp(Result, 1, PutConstNode(fldBOOL, @BoolFalse,
  3977.           SizeOf(WordBool)));
  3978.       end;
  3979.     enOperator:
  3980.       case Node^.FOperator of
  3981.         canEQ..canLE:
  3982.           Result := PutCompareNode(Node);
  3983.         canAND, canOR:
  3984.           begin
  3985.             Result := PutNode(nodeBINARY, Node^.FOperator, 2);
  3986.             SetNodeOp(Result, 0, PutExprNode(Node^.FLeft));
  3987.             SetNodeOp(Result, 1, PutExprNode(Node^.FRight));
  3988.           end;
  3989.       else
  3990.         Result := PutNode(nodeUNARY, canNOT, 1);
  3991.         SetNodeOp(Result, 0, PutExprNode(Node^.FLeft));
  3992.       end;
  3993.   else
  3994.     DBError(SExprIncorrect);
  3995.   end;
  3996. end;
  3997.  
  3998. function TFilterExpr.PutFieldNode(Field: TField): Integer;
  3999. var
  4000.   Buffer: array[0..255] of Char;
  4001. begin
  4002.   AnsiToNative(FDataSet.Locale, Field.FieldName, Buffer, SizeOf(Buffer) - 1);
  4003.   Result := PutNode(nodeFIELD, canFIELD2, 2);
  4004.   SetNodeOp(Result, 0, Field.FieldNo);
  4005.   SetNodeOp(Result, 1, PutData(Buffer, StrLen(Buffer) + 1));
  4006. end;
  4007.  
  4008. function TFilterExpr.PutNode(NodeType: NodeClass; OpType: CanOp;
  4009.   OpCount: Integer): Integer;
  4010. var
  4011.   Size: Integer;
  4012. begin
  4013.   Size := SizeOf(CANHdr) + OpCount * SizeOf(Word);
  4014.   with PCANHdr(GetExprData(SizeOf(CANExpr) + FExprNodeSize, Size))^ do
  4015.   begin
  4016.     nodeClass := NodeType;
  4017.     canOp := OpType;
  4018.   end;
  4019.   Result := FExprNodeSize;
  4020.   Inc(FExprNodeSize, Size);
  4021. end;
  4022.  
  4023. procedure TFilterExpr.SetNodeOp(Node, Index, Data: Integer);
  4024. begin
  4025.   PWordArray(PChar(FExprBuffer) + (SizeOf(CANExpr) + Node +
  4026.     SizeOf(CANHdr)))^[Index] := Data;
  4027. end;
  4028.  
  4029. { TExprParser }
  4030.  
  4031. type
  4032.  
  4033.   TExprToken = (etEnd, etSymbol, etName, etLiteral, etLParen, etRParen,
  4034.     etEQ, etNE, etGE, etLE, etGT, etLT);
  4035.  
  4036.   TExprParser = class
  4037.   private
  4038.     FFilter: TFilterExpr;
  4039.     FText: string;
  4040.     FSourcePtr: PChar;
  4041.     FTokenPtr: PChar;
  4042.     FTokenString: string;
  4043.     FToken: TExprToken;
  4044.     FFilterData: PCANExpr;
  4045.     procedure NextToken;
  4046.     function ParseExpr: PExprNode;
  4047.     function ParseExpr2: PExprNode;
  4048.     function ParseExpr3: PExprNode;
  4049.     function ParseExpr4: PExprNode;
  4050.     function ParseExpr5: PExprNode;
  4051.     function TokenName: string;
  4052.     function TokenSymbolIs(const S: string): Boolean;
  4053.   public
  4054.     constructor Create(DataSet: TDataSet; const Text: string;
  4055.       Options: TFilterOptions);
  4056.     destructor Destroy; override;
  4057.     property FilterData: PCANExpr read FFilterData;
  4058.   end;
  4059.  
  4060. constructor TExprParser.Create(DataSet: TDataSet; const Text: string;
  4061.   Options: TFilterOptions);
  4062. var
  4063.   Root: PExprNode;
  4064. begin
  4065.   FFilter := TFilterExpr.Create(DataSet, Options);
  4066.   FText := Text;
  4067.   FSourcePtr := PChar(Text);
  4068.   NextToken;
  4069.   Root := ParseExpr;
  4070.   if FToken <> etEnd then DBError(SExprTermination);
  4071.   FFilterData := FFilter.GetFilterData(Root);
  4072. end;
  4073.  
  4074. destructor TExprParser.Destroy;
  4075. begin
  4076.   FFilter.Free;
  4077. end;
  4078.  
  4079. procedure TExprParser.NextToken;
  4080. var
  4081.   P, TokenStart: PChar;
  4082.   L: Integer;
  4083.   StrBuf: array[0..255] of Char;
  4084. begin
  4085.   FTokenString := '';
  4086.   P := FSourcePtr;
  4087.   while (P^ <> #0) and (P^ <= ' ') do Inc(P);
  4088.   FTokenPtr := P;
  4089.   case P^ of
  4090.     'A'..'Z', 'a'..'z', '_':
  4091.       begin
  4092.         TokenStart := P;
  4093.         Inc(P);
  4094.         while P^ in ['A'..'Z', 'a'..'z', '0'..'9', '_'] do Inc(P);
  4095.         SetString(FTokenString, TokenStart, P - TokenStart);
  4096.         FToken := etSymbol;
  4097.       end;
  4098.     '[':
  4099.       begin
  4100.         Inc(P);
  4101.         TokenStart := P;
  4102.         while (P^ <> ']') and (P^ <> #0) do Inc(P);
  4103.         if P^ = #0 then DBError(SExprNameError);
  4104.         SetString(FTokenString, TokenStart, P - TokenStart);
  4105.         FToken := etName;
  4106.         Inc(P);
  4107.       end;
  4108.     '''':
  4109.       begin
  4110.         Inc(P);
  4111.         L := 0;
  4112.         while True do
  4113.         begin
  4114.           if P^ = #0 then DBError(SExprStringError);
  4115.           if P^ = '''' then
  4116.           begin
  4117.             Inc(P);
  4118.             if P^ <> '''' then Break;
  4119.           end;
  4120.           if L < SizeOf(StrBuf) then
  4121.           begin
  4122.             StrBuf[L] := P^;
  4123.             Inc(L);
  4124.           end;
  4125.           Inc(P);
  4126.         end;
  4127.         SetString(FTokenString, StrBuf, L);
  4128.         FToken := etLiteral;
  4129.       end;
  4130.     '-', '0'..'9':
  4131.       begin
  4132.         TokenStart := P;
  4133.         Inc(P);
  4134.         while P^ in ['0'..'9', '.', 'e', 'E', '+', '-'] do Inc(P);
  4135.         SetString(FTokenString, TokenStart, P - TokenStart);
  4136.         FToken := etLiteral;
  4137.       end;
  4138.     '(':
  4139.       begin
  4140.         Inc(P);
  4141.         FToken := etLParen;
  4142.       end;
  4143.     ')':
  4144.       begin
  4145.         Inc(P);
  4146.         FToken := etRParen;
  4147.       end;
  4148.     '<':
  4149.       begin
  4150.         Inc(P);
  4151.         case P^ of
  4152.           '=':
  4153.             begin
  4154.               Inc(P);
  4155.               FToken := etLE;
  4156.             end;
  4157.           '>':
  4158.             begin
  4159.               Inc(P);
  4160.               FToken := etNE;
  4161.             end;
  4162.         else
  4163.           FToken := etLT;
  4164.         end;
  4165.       end;
  4166.     '=':
  4167.       begin
  4168.         Inc(P);
  4169.         FToken := etEQ;
  4170.       end;
  4171.     '>':
  4172.       begin
  4173.         Inc(P);
  4174.         if P^ = '=' then
  4175.         begin
  4176.           Inc(P);
  4177.           FToken := etGE;
  4178.         end else
  4179.           FToken := etGT;
  4180.       end;
  4181.     #0:
  4182.       FToken := etEnd;
  4183.   else
  4184.     DBErrorFmt(SExprInvalidChar, [P^]);
  4185.   end;
  4186.   FSourcePtr := P;
  4187. end;
  4188.  
  4189. function TExprParser.ParseExpr: PExprNode;
  4190. begin
  4191.   Result := ParseExpr2;
  4192.   while TokenSymbolIs('OR') do
  4193.   begin
  4194.     NextToken;
  4195.     Result := FFilter.NewNode(enOperator, canOR, Unassigned,
  4196.       Result, ParseExpr2);
  4197.   end;
  4198. end;
  4199.  
  4200. function TExprParser.ParseExpr2: PExprNode;
  4201. begin
  4202.   Result := ParseExpr3;
  4203.   while TokenSymbolIs('AND') do
  4204.   begin
  4205.     NextToken;
  4206.     Result := FFilter.NewNode(enOperator, canAND, Unassigned,
  4207.       Result, ParseExpr3);
  4208.   end;
  4209. end;
  4210.  
  4211. function TExprParser.ParseExpr3: PExprNode;
  4212. begin
  4213.   if TokenSymbolIs('NOT') then
  4214.   begin
  4215.     NextToken;
  4216.     Result := FFilter.NewNode(enOperator, canNOT, Unassigned,
  4217.       ParseExpr4, nil);
  4218.   end else
  4219.     Result := ParseExpr4;
  4220. end;
  4221.  
  4222. function TExprParser.ParseExpr4: PExprNode;
  4223. const
  4224.   Operators: array[etEQ..etLT] of CanOp = (
  4225.     canEQ, canNE, canGE, canLE, canGT, canLT);
  4226. var
  4227.   Operator: CanOp;
  4228. begin
  4229.   Result := ParseExpr5;
  4230.   if FToken in [etEQ..etLT] then
  4231.   begin
  4232.     Operator := Operators[FToken];
  4233.     NextToken;
  4234.     Result := FFilter.NewNode(enOperator, Operator, Unassigned,
  4235.       Result, ParseExpr5);
  4236.   end;
  4237. end;
  4238.  
  4239. function TExprParser.ParseExpr5: PExprNode;
  4240. begin
  4241.   case FToken of
  4242.     etSymbol:
  4243.       if TokenSymbolIs('NULL') then
  4244.         Result := FFilter.NewNode(enConst, canNOTDEFINED, System.Null, nil, nil) else
  4245.         Result := FFilter.NewNode(enField, canNOTDEFINED, FTokenString, nil, nil);
  4246.     etName:
  4247.       Result := FFilter.NewNode(enField, canNOTDEFINED, FTokenString, nil, nil);
  4248.     etLiteral:
  4249.       Result := FFilter.NewNode(enConst, canNOTDEFINED, FTokenString, nil, nil);
  4250.     etLParen:
  4251.       begin
  4252.         NextToken;
  4253.         Result := ParseExpr;
  4254.         if FToken <> etRParen then DBErrorFmt(SExprNoRParen, [TokenName]);
  4255.       end;
  4256.   else
  4257.     DBErrorFmt(SExprExpected, [TokenName]);
  4258.   end;
  4259.   NextToken;
  4260. end;
  4261.  
  4262. function TExprParser.TokenName: string;
  4263. begin
  4264.   if FSourcePtr = FTokenPtr then Result := LoadStr(SExprNothing) else
  4265.   begin
  4266.     SetString(Result, FTokenPtr, FSourcePtr - FTokenPtr);
  4267.     Result := '''' + Result + '''';
  4268.   end;
  4269. end;
  4270.  
  4271. function TExprParser.TokenSymbolIs(const S: string): Boolean;
  4272. begin
  4273.   Result := (FToken = etSymbol) and (CompareText(FTokenString, S) = 0);
  4274. end;
  4275.  
  4276. { TDataSet }
  4277.  
  4278. constructor TDataSet.Create(AOwner: TComponent);
  4279. begin
  4280.   inherited Create(AOwner);
  4281.   FFieldDefs := TFieldDefs.Create(Self);
  4282.   FFields := TList.Create;
  4283.   FDataSources := TList.Create;
  4284.   FAutoCalcFields := True;
  4285.   ClearBuffers;
  4286.   SetLocale(DB.Session.Locale);
  4287. end;
  4288.  
  4289. destructor TDataSet.Destroy;
  4290. begin
  4291.   Destroying;
  4292.   Close;
  4293.   SetUpdateObject(nil);
  4294.   FDesigner.Free;
  4295.   while FDataSources.Count > 0 do RemoveDataSource(FDataSources.Last);
  4296.   FDataSources.Free;
  4297.   DestroyFields;
  4298.   FFields.Free;
  4299.   FFieldDefs.Free;
  4300.   FAsyncCallback.Free;
  4301.   inherited Destroy;
  4302. end;
  4303.  
  4304. procedure TDataSet.SetName(const Value: TComponentName);
  4305. var
  4306.   I: Integer;
  4307.   OldName, FieldName, NamePrefix: TComponentName;
  4308.   Field: TField;
  4309. begin
  4310.   OldName := Name;
  4311.   inherited SetName(Value);
  4312.   if (csDesigning in ComponentState) and (Name <> OldName) then
  4313.     { In design mode the name of the fields should track the data set name }
  4314.     for I := 0 to FFields.Count - 1 do
  4315.     begin
  4316.       Field := FFields[I];
  4317.       if Field.Owner = Owner then
  4318.       begin
  4319.         FieldName := Field.Name;
  4320.         NamePrefix := FieldName;
  4321.         if Length(NamePrefix) > Length(OldName) then
  4322.         begin
  4323.           SetLength(NamePrefix, Length(OldName));
  4324.           if CompareText(OldName, NamePrefix) = 0 then
  4325.           begin
  4326.             System.Delete(FieldName, 1, Length(OldName));
  4327.             System.Insert(Value, FieldName, 1);
  4328.             try
  4329.               Field.Name := FieldName;
  4330.             except
  4331.               on EComponentError do {Ignore rename errors };
  4332.             end;
  4333.           end;
  4334.         end;
  4335.       end;
  4336.     end;
  4337. end;
  4338.  
  4339. procedure TDataSet.GetChildren(Proc: TGetChildProc);
  4340. var
  4341.   I: Integer;
  4342.   Field: TField;
  4343. begin
  4344.   for I := 0 to FFields.Count - 1 do
  4345.   begin
  4346.     Field := FFields[I];
  4347.     if Field.Owner <> Self then Proc(Field);
  4348.   end;
  4349. end;
  4350.  
  4351. procedure TDataSet.SetChildOrder(Component: TComponent; Order: Integer);
  4352. begin
  4353.   if FFields.IndexOf(Component) >= 0 then
  4354.     (Component as TField).Index := Order;
  4355. end;
  4356.  
  4357. procedure TDataSet.Loaded;
  4358. begin
  4359.   inherited Loaded;
  4360.   try
  4361.     if FStreamedActive then Active := True;
  4362.   except
  4363.     if csDesigning in ComponentState then
  4364.       Application.HandleException(Self)
  4365.     else
  4366.       raise;
  4367.   end;
  4368. end;
  4369.  
  4370. procedure TDataSet.SetState(Value: TDataSetState);
  4371. begin
  4372.   if FState <> Value then
  4373.   begin
  4374.     FState := Value;
  4375.     FModified := False;
  4376.     DataEvent(deUpdateState, 0);
  4377.   end;
  4378. end;
  4379.  
  4380. procedure TDataSet.Open;
  4381. begin
  4382.   Active := True;
  4383. end;
  4384.  
  4385. procedure TDataSet.Close;
  4386. begin
  4387.   Active := False;
  4388. end;
  4389.  
  4390. procedure TDataSet.CheckInactive;
  4391. begin
  4392.   if Active then
  4393.     if csUpdating in ComponentState then
  4394.       Close else
  4395.       DBError(SDataSetOpen);
  4396. end;
  4397.  
  4398. function TDataSet.GetActive: Boolean;
  4399. begin
  4400.   Result := State <> dsInactive;
  4401. end;
  4402.  
  4403. procedure TDataSet.SetActive(Value: Boolean);
  4404. begin
  4405.   if (csReading in ComponentState) then
  4406.   begin
  4407.     if Value then FStreamedActive := Value;
  4408.   end
  4409.   else
  4410.     if Active <> Value then
  4411.     begin
  4412.       if Value then
  4413.       begin
  4414.         DoBeforeOpen;
  4415.         try
  4416.           OpenCursor;
  4417.           SetState(dsBrowse);
  4418.         except
  4419.           SetState(dsInactive);
  4420.           CloseCursor;
  4421.           raise;
  4422.         end;
  4423.         DoAfterOpen;
  4424.       end else
  4425.       begin
  4426.         if not (csDestroying in ComponentState) then DoBeforeClose;
  4427.         SetState(dsInactive);
  4428.         CloseCursor;
  4429.         if not (csDestroying in ComponentState) then DoAfterClose;
  4430.       end;
  4431.     end;
  4432. end;
  4433.  
  4434. procedure TDataSet.SetLocale(Value: TLocale);
  4435. begin
  4436.   FLocale := Value;
  4437. end;
  4438.  
  4439. procedure TDataSet.OpenCursor;
  4440. var
  4441.   CursorLocale: TLocale;
  4442. begin
  4443.   if FAsyncCallback = nil then
  4444.     FAsyncCallback := TBDECallback.Create(Self, nil, cbYIELDCLIENT,
  4445.       @FCBYieldStep, SizeOf(CBYieldStep), YieldCallBack, False);
  4446.   FHandle := CreateHandle;
  4447.   if FHandle = nil then DBError(SHandleError);
  4448.   if DbiGetLdObj(FHandle, CursorLocale) = 0 then SetLocale(CursorLocale);
  4449.   InternalOpen;
  4450. end;
  4451.  
  4452. procedure TDataSet.CloseCursor;
  4453. begin
  4454.   InternalClose;
  4455.   SetLocale(DB.Session.Locale);
  4456.   if FHandle <> nil then
  4457.   begin
  4458.     DestroyHandle;
  4459.     FHandle := nil;
  4460.   end;
  4461. end;
  4462.  
  4463. function TDataSet.CreateHandle: HDBICur;
  4464. begin
  4465.   Result := nil;
  4466. end;
  4467.  
  4468. procedure TDataSet.DestroyHandle;
  4469. begin
  4470.   DbiRelRecordLock(FHandle, False);
  4471.   DbiCloseCursor(FHandle);
  4472. end;
  4473.  
  4474. procedure TDataSet.InternalOpen;
  4475. var
  4476.   I: Integer;
  4477.   FieldDescs: PFieldDescList;
  4478.   RequiredFields: set of 0..255;
  4479.   CursorProps: CurProps;
  4480.   ValCheckDesc: VCHKDesc;
  4481. begin
  4482.   if not InfoQueryMode and CachedUpdates then
  4483.   begin
  4484.     DbiGetCursorProps(FHandle, CursorProps);
  4485.     Check(DbiBeginDelayedUpdates(FHandle));
  4486.   end;
  4487.   DbiGetCursorProps(FHandle, CursorProps);
  4488.   FRecordSize := CursorProps.iRecBufSize;
  4489.   FBookmarkSize := CursorProps.iBookmarkSize;
  4490.   FCanModify := (CursorProps.eOpenMode = dbiReadWrite) and
  4491.     not CursorProps.bTempTable;
  4492.   FRecNoStatus := TRecNoStatus(CursorProps.ISeqNums);
  4493.   RequiredFields := [];
  4494.   for I := 1 to CursorProps.iValChecks do
  4495.   begin
  4496.     DbiGetVChkDesc(FHandle, I, @ValCheckDesc);
  4497.     if ValCheckDesc.bRequired and not ValCheckDesc.bHasDefVal then
  4498.       Include(RequiredFields, ValCheckDesc.iFldNum - 1);
  4499.   end;
  4500.   FieldDescs := AllocMem(CursorProps.iFields * SizeOf(FLDDesc));
  4501.   try
  4502.     DbiGetFieldDescs(FHandle, PFLDDesc(FieldDescs));
  4503.     FieldDefs.Clear;
  4504.     for I := 0 to CursorProps.iFields - 1 do
  4505.       FieldDefs.AddFieldDesc(FieldDescs^[I], I in RequiredFields, I + 1);
  4506.   finally
  4507.     FreeMem(FieldDescs, CursorProps.iFields * SizeOf(FLDDesc));
  4508.   end;
  4509.   if not InfoQueryMode then
  4510.   begin
  4511.     GetIndexInfo;
  4512.     FDefaultFields := FFields.Count = 0;
  4513.     if FDefaultFields then CreateFields;
  4514.     BindFields(True);
  4515.     FRecInfoOfs := FRecordSize + FCalcFieldsSize;
  4516.     FBookmarkOfs := FRecInfoOfs + SizeOf(TRecInfo);
  4517.     FRecBufSize := FBookmarkOfs + 1 + FBookmarkSize;
  4518.     if CachedUpdates then
  4519.     begin
  4520.       AllocDelUpdCBBuf(True);
  4521.       SetupCallBack(UpdateCallBackRequired);
  4522.     end;
  4523.     AllocKeyBuffers;
  4524.     DbiSetToBegin(FHandle);
  4525.     PrepareCursor;
  4526.     if FFilterText <> '' then
  4527.       FExprFilter := CreateExprFilter(FFilterText, FFilterOptions, 0);
  4528.     if Assigned(FOnFilterRecord) then
  4529.       FFuncFilter := CreateFuncFilter(@TDataSet.RecordFilter, 1);
  4530.     if FFiltered then ActivateFilters;
  4531.     UpdateBufferCount;
  4532.     FBOF := True;
  4533.   end;
  4534. end;
  4535.  
  4536. procedure TDataSet.InternalClose;
  4537. begin
  4538.   if not InfoQueryMode then
  4539.   begin
  4540.     FreeFieldBuffers;
  4541.     SetBufListSize(0);
  4542.     FBufferCount := 0;
  4543.     ClearBuffers;
  4544.     FFuncFilter := nil;
  4545.     FExprFilter := nil;
  4546.     FreeKeyBuffers;
  4547.     if CachedUpdates then
  4548.     begin
  4549.       SetupCallBack(False);
  4550.       AllocDelUpdCBBuf(False);
  4551.       DbiEndDelayedUpdates(FHandle);
  4552.     end;
  4553.     BindFields(False);
  4554.     if FDefaultFields then DestroyFields;
  4555.     FDefaultFields := False;
  4556.     FIndexFieldCount := 0;
  4557.     FKeySize := 0;
  4558.     FExpIndex := False;
  4559.     FCaseInsIndex := False;
  4560.   end;
  4561.   FCanModify := False;
  4562. end;
  4563.  
  4564. procedure TDataSet.GetIndexInfo;
  4565. var
  4566.   IndexDesc: IDXDesc;
  4567. begin
  4568.   if DbiGetIndexDesc(FHandle, 0, IndexDesc) = 0 then
  4569.   begin
  4570.     FExpIndex := IndexDesc.bExpIdx;
  4571.     FCaseInsIndex := IndexDesc.bCaseInsensitive;
  4572.     if not ExpIndex then
  4573.     begin
  4574.       FIndexFieldCount := IndexDesc.iFldsInKey;
  4575.       FIndexFieldMap := IndexDesc.aiKeyFld;
  4576.     end;
  4577.     FKeySize := IndexDesc.iKeyLen;
  4578.   end;
  4579. end;
  4580.  
  4581. procedure TDataSet.PrepareCursor;
  4582. begin
  4583. end;
  4584.  
  4585. procedure TDataSet.ActivateFilters;
  4586. begin
  4587.   if FExprFilter <> nil then DbiActivateFilter(FHandle, FExprFilter);
  4588.   if FFuncFilter <> nil then DbiActivateFilter(FHandle, FFuncFilter);
  4589. end;
  4590.  
  4591. procedure TDataSet.DeactivateFilters;
  4592. begin
  4593.   if FFuncFilter <> nil then DbiDeactivateFilter(FHandle, FFuncFilter);
  4594.   if FExprFilter <> nil then DbiDeactivateFilter(FHandle, FExprFilter);
  4595. end;
  4596.  
  4597. procedure TDataSet.CreateFields;
  4598. var
  4599.   I: Integer;
  4600. begin
  4601.   for I := 0 to FFieldDefs.Count - 1 do
  4602.     with FFieldDefs[I] do
  4603.       if DataType <> ftUnknown then CreateField(Self);
  4604. end;
  4605.  
  4606. procedure TDataSet.DestroyFields;
  4607. var
  4608.   Field: TField;
  4609. begin
  4610.   while FFields.Count > 0 do
  4611.   begin
  4612.     Field := FFields.Last;
  4613.     RemoveField(Field);
  4614.     Field.Free;
  4615.   end;
  4616. end;
  4617.  
  4618. procedure TDataSet.BindFields(Binding: Boolean);
  4619. const
  4620.   CalcFieldTypes = [ftString, ftSmallint, ftInteger, ftWord, ftBoolean,
  4621.     ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime];
  4622.   BaseTypes: array[TFieldType] of TFieldType = (
  4623.     ftUnknown, ftString, ftSmallint, ftInteger, ftWord,
  4624.     ftBoolean, ftFloat, ftFloat, ftBCD, ftDate, ftTime, ftDateTime,
  4625.     ftBytes, ftVarBytes, ftInteger, ftBlob, ftBlob, ftBlob,
  4626.     ftBlob, ftBlob, ftBlob, ftBlob);
  4627. var
  4628.   I: Integer;
  4629.   FieldDef: TFieldDef;
  4630. begin
  4631.   FCalcFieldsSize := 0;
  4632.   FBDECalcFields := False;
  4633.   for I := 0 to FFields.Count - 1 do
  4634.     with TField(FFields[I]) do
  4635.       if Binding then
  4636.       begin
  4637.         if FieldKind <> fkData then
  4638.         begin
  4639.           if not (DataType in CalcFieldTypes) then
  4640.             DBErrorFmt(SInvalidCalcType, [DisplayName]);
  4641.           FFieldNo := -1;
  4642.           FOffset := FCalcFieldsSize;
  4643.           Inc(FCalcFieldsSize, DataSize + 1);
  4644.         end else
  4645.         begin
  4646.           FieldDef := FieldDefs.Find(FFieldName);
  4647.           if (BaseTypes[DataType] <> BaseTypes[FieldDef.DataType]) or
  4648.             (Size <> FieldDef.Size) then
  4649.             DBErrorFmt(SFieldTypeMismatch, [DisplayName]);
  4650.           FFieldNo := FieldDef.FieldNo;
  4651.           if FieldDef.BDECalcField and not FBDECalcFields then
  4652.             FBDECalcFields := True;
  4653.         end;
  4654.         Bind(True);
  4655.       end else
  4656.       begin
  4657.         Bind(False);
  4658.         FFieldNo := 0;
  4659.       end;
  4660. end;
  4661.  
  4662. procedure TDataSet.SwitchToIndex(const IndexName, TagName: string);
  4663. var
  4664.   Status: DBIResult;
  4665.   CursorProps: CurProps;
  4666. begin
  4667.   UpdateCursorPos;
  4668.   Status := DbiSwitchToIndex(FHandle, PChar(IndexName),
  4669.     PChar(TagName), 0, True);
  4670.   if Status = DBIERR_NOCURRREC then
  4671.     Status := DbiSwitchToIndex(FHandle, PChar(IndexName),
  4672.     PChar(TagName), 0, False);
  4673.   Check(Status);
  4674.   SetBufListSize(0);
  4675.   FIndexFieldCount := 0;
  4676.   FKeySize := 0;
  4677.   FExpIndex := False;
  4678.   FCaseInsIndex := False;
  4679.   DbiGetCursorProps(FHandle, CursorProps);
  4680.   FBookmarkSize := CursorProps.iBookmarkSize;
  4681.   FRecBufSize := FBookmarkOfs + FBookmarkSize + 1;
  4682.   try
  4683.     SetBufListSize(FBufferCount + 1);
  4684.   except
  4685.     SetState(dsInactive);
  4686.     CloseCursor;
  4687.     raise;
  4688.   end;
  4689.   GetIndexInfo;
  4690. end;
  4691.  
  4692. procedure TDataSet.FetchAll;
  4693. begin
  4694.   if not EOF then
  4695.   begin
  4696.     CheckBrowseMode;
  4697.     Check(DbiSetToEnd(Handle));
  4698.     Check(DbiGetPriorRecord(FHandle, dbiNoLock, nil, nil));
  4699.     UpdateCursorPos;
  4700.   end;
  4701. end;
  4702.  
  4703. procedure TDataSet.FreeFieldBuffers;
  4704. var
  4705.   I: Integer;
  4706. begin
  4707.   for I := 0 to FFields.Count - 1 do TField(FFields[I]).FreeBuffers;
  4708. end;
  4709.  
  4710. procedure TDataSet.SetFieldDefs(Value: TFieldDefs);
  4711. begin
  4712.   FFieldDefs.Assign(Value);
  4713. end;
  4714.  
  4715. procedure TDataSet.UpdateFieldDefs;
  4716. begin
  4717.   if not FFieldDefs.FUpdated then
  4718.   begin
  4719.     InitFieldDefs;
  4720.     FFieldDefs.FUpdated := True;
  4721.   end;
  4722. end;
  4723.  
  4724. procedure TDataSet.InitFieldDefs;
  4725. begin
  4726.   if not Active then
  4727.     try
  4728.       FInfoQueryMode := True;
  4729.       OpenCursor;
  4730.     finally
  4731.       CloseCursor;
  4732.       FInfoQueryMode := False;
  4733.     end;
  4734. end;
  4735.  
  4736. procedure TDataSet.AddField(Field: TField);
  4737. begin
  4738.   FFields.Add(Field);
  4739.   Field.FDataSet := Self;
  4740.   DataEvent(deFieldListChange, 0)
  4741. end;
  4742.  
  4743. procedure TDataSet.RemoveField(Field: TField);
  4744. begin
  4745.   Field.FDataSet := nil;
  4746.   FFields.Remove(Field);
  4747.   if not (csDestroying in ComponentState) then
  4748.     DataEvent(deFieldListChange, 0)
  4749. end;
  4750.  
  4751. function TDataSet.GetFieldCount: Integer;
  4752. begin
  4753.   Result := FFields.Count;
  4754. end;
  4755.  
  4756. function TDataSet.GetField(Index: Integer): TField;
  4757. begin
  4758.   Result := FFields[Index];
  4759. end;
  4760.  
  4761. procedure TDataSet.SetField(Index: Integer; Value: TField);
  4762. begin
  4763.   TField(FFields[Index]).Assign(Value);
  4764. end;
  4765.  
  4766. function TDataSet.GetFieldValue(const FieldName: string): Variant;
  4767. var
  4768.   I: Integer;
  4769.   Fields: TList;
  4770. begin
  4771.   if Pos(';', FieldName) <> 0 then
  4772.   begin
  4773.     Fields := TList.Create;
  4774.     try
  4775.       GetFieldList(Fields, FieldName);
  4776.       Result := VarArrayCreate([0, Fields.Count - 1], varVariant);
  4777.       for I := 0 to Fields.Count - 1 do
  4778.         Result[I] := TField(Fields[I]).Value;
  4779.     finally
  4780.       Fields.Free;
  4781.     end;
  4782.   end else
  4783.     Result := FieldByName(FieldName).Value
  4784. end;
  4785.  
  4786. procedure TDataSet.SetFieldValue(const FieldName: string;
  4787.   const Value: Variant);
  4788. var
  4789.   I: Integer;
  4790.   Fields: TList;
  4791. begin
  4792.   if Pos(';', FieldName) <> 0 then
  4793.   begin
  4794.     Fields := TList.Create;
  4795.     try
  4796.       GetFieldList(Fields, FieldName);
  4797.       for I := 0 to Fields.Count - 1 do
  4798.         TField(Fields[I]).Value := Value[I];
  4799.     finally
  4800.       Fields.Free;
  4801.     end;
  4802.   end else
  4803.     FieldByName(FieldName).Value := Value;
  4804. end;
  4805.  
  4806. function TDataSet.FieldByName(const FieldName: string): TField;
  4807. begin
  4808.   Result := FindField(FieldName);
  4809.   if Result = nil then DBErrorFmt(SFieldNotFound, [FieldName]);
  4810. end;
  4811.  
  4812. function TDataSet.FieldByNumber(FieldNo: Integer): TField;
  4813. var
  4814.   I: Integer;
  4815. begin
  4816.   for I := 0 to FFields.Count - 1 do
  4817.   begin
  4818.     Result := Fields[I];
  4819.     if Result.FieldNo = FieldNo then Exit;
  4820.   end;
  4821.   Result := nil;
  4822. end;
  4823.  
  4824. function TDataSet.FindField(const FieldName: string): TField;
  4825. var
  4826.   I: Integer;
  4827. begin
  4828.   for I := 0 to FFields.Count - 1 do
  4829.   begin
  4830.     Result := FFields[I];
  4831.     if AnsiCompareText(Result.FFieldName, FieldName) = 0 then Exit;
  4832.   end;
  4833.   Result := nil;
  4834. end;
  4835.  
  4836. procedure TDataSet.CheckFieldName(const FieldName: string);
  4837. begin
  4838.   if FieldName = '' then DBError(SFieldNameMissing);
  4839.   if FindField(FieldName) <> nil then
  4840.     DBErrorFmt(SDuplicateFieldName, [FieldName]);
  4841. end;
  4842.  
  4843. procedure TDataSet.CheckFieldNames(const FieldNames: string);
  4844. var
  4845.   Pos: Integer;
  4846. begin
  4847.   Pos := 1;
  4848.   while Pos <= Length(FieldNames) do
  4849.     FieldByName(ExtractFieldName(FieldNames, Pos));
  4850. end;
  4851.  
  4852. function TDataSet.GetIndexField(Index: Integer): TField;
  4853. var
  4854.   FieldNo: Integer;
  4855. begin
  4856.   if (Index < 0) or (Index >= FIndexFieldCount) then
  4857.     DBError(SFieldIndexError);
  4858.   FieldNo := FIndexFieldMap[Index];
  4859.   Result := FieldByNumber(FieldNo);
  4860.   if Result = nil then
  4861.     DBErrorFmt(SIndexFieldMissing, [FFieldDefs[FieldNo - 1].Name]);
  4862. end;
  4863.  
  4864. procedure TDataSet.SetIndexField(Index: Integer; Value: TField);
  4865. begin
  4866.   GetIndexField(Index).Assign(Value);
  4867. end;
  4868.  
  4869. function TDataSet.GetIndexFieldCount: Integer;
  4870. begin
  4871.   Result := FIndexFieldCount;
  4872. end;
  4873.  
  4874. procedure TDataSet.GetFieldNames(List: TStrings);
  4875. var
  4876.   I: Integer;
  4877. begin
  4878.   List.BeginUpdate;
  4879.   try
  4880.     List.Clear;
  4881.     if FFields.Count > 0 then
  4882.       for I := 0 to FFields.Count - 1 do
  4883.         List.Add(TField(FFields[I]).FFieldName)
  4884.     else
  4885.     begin
  4886.       UpdateFieldDefs;
  4887.       for I := 0 to FFieldDefs.Count - 1 do
  4888.         List.Add(FFieldDefs[I].Name);
  4889.     end;
  4890.   finally
  4891.     List.EndUpdate;
  4892.   end;
  4893. end;
  4894.  
  4895. function TDataSet.GetDataSource: TDataSource;
  4896. begin
  4897.   Result := nil;
  4898. end;
  4899.  
  4900. function TDataSet.IsLinkedTo(DataSource: TDataSource): Boolean;
  4901. var
  4902.   DataSet: TDataSet;
  4903. begin
  4904.   Result := True;
  4905.   while DataSource <> nil do
  4906.   begin
  4907.     DataSet := DataSource.DataSet;
  4908.     if DataSet = nil then Break;
  4909.     if DataSet = Self then Exit;
  4910.     DataSource := DataSet.DataSource;
  4911.   end;
  4912.   Result := False;
  4913. end;
  4914.  
  4915. procedure TDataSet.AddDataSource(DataSource: TDataSource);
  4916. begin
  4917.   FDataSources.Add(DataSource);
  4918.   DataSource.FDataSet := Self;
  4919.   UpdateBufferCount;
  4920.   DataSource.UpdateState;
  4921. end;
  4922.  
  4923. procedure TDataSet.RemoveDataSource(DataSource: TDataSource);
  4924. begin
  4925.   DataSource.FDataSet := nil;
  4926.   FDataSources.Remove(DataSource);
  4927.   DataSource.UpdateState;
  4928.   UpdateBufferCount;
  4929. end;
  4930.  
  4931. procedure TDataSet.SetBufListSize(Value: Integer);
  4932. var
  4933.   I: Integer;
  4934.   NewList: PBufferList;
  4935. begin
  4936.   if FBufListSize <> Value then
  4937.   begin
  4938.     GetMem(NewList, Value * SizeOf(Pointer));
  4939.     if FBufListSize > Value then
  4940.     begin
  4941.       if Value <> 0 then
  4942.         Move(FBuffers^, NewList^, Value * SizeOf(Pointer));
  4943.       for I := Value to FBufListSize - 1 do
  4944.         FreeMem(FBuffers^[I], FRecBufSize);
  4945.     end else
  4946.     begin
  4947.       if FBufListSize <> 0 then
  4948.         Move(FBuffers^, NewList^, FBufListSize * SizeOf(Pointer));
  4949.       I := FBufListSize;
  4950.       try
  4951.         while I < Value do
  4952.         begin
  4953.           GetMem(NewList^[I], FRecBufSize);
  4954.           Inc(I);
  4955.         end;
  4956.       except
  4957.         while I > FBufListSize do
  4958.         begin
  4959.           FreeMem(NewList^[I], FRecBufSize);
  4960.           Dec(I);
  4961.         end;
  4962.         FreeMem(NewList, Value * SizeOf(Pointer));
  4963.         raise;
  4964.       end;
  4965.     end;
  4966.     FreeMem(FBuffers, FBufListSize * SizeOf(Pointer));
  4967.     FBuffers := NewList;
  4968.     FBufListSize := Value;
  4969.   end;
  4970. end;
  4971.  
  4972. procedure TDataSet.SetBufferCount(Value: Integer);
  4973. var
  4974.   I, Delta: Integer;
  4975.   DataLink: TDataLink;
  4976.  
  4977.   procedure AdjustFirstRecord(Delta: Integer);
  4978.   var
  4979.     DataLink: TDataLink;
  4980.   begin
  4981.     if Delta <> 0 then
  4982.     begin
  4983.       DataLink := FFirstDataLink;
  4984.       while DataLink <> nil do
  4985.       begin
  4986.         if DataLink.Active then Inc(DataLink.FFirstRecord, Delta);
  4987.         DataLink := DataLink.FNext;
  4988.       end;
  4989.     end;
  4990.   end;
  4991.  
  4992. begin
  4993.   if FBufferCount <> Value then
  4994.   begin
  4995.     if (FBufferCount > Value) and (FRecordCount > 0) then
  4996.     begin
  4997.       Delta := FActiveRecord;
  4998.       DataLink := FFirstDataLink;
  4999.       while DataLink <> nil do
  5000.       begin
  5001.         if DataLink.Active and (DataLink.FFirstRecord < Delta) then
  5002.           Delta := DataLink.FFirstRecord;
  5003.         DataLink := DataLink.FNext;
  5004.       end;
  5005.       for I := 0 to Value - 1 do MoveBuffer(I + Delta, I);
  5006.       Dec(FActiveRecord, Delta);
  5007.       if FCurrentRecord <> -1 then Dec(FCurrentRecord, Delta);
  5008.       if FRecordCount > Value then FRecordCount := Value;
  5009.       AdjustFirstRecord(-Delta);
  5010.     end;
  5011.     SetBufListSize(Value + 1);
  5012.     FBufferCount := Value;
  5013.     GetNextRecords;
  5014.     AdjustFirstRecord(GetPriorRecords);
  5015.   end;
  5016. end;
  5017.  
  5018. procedure TDataSet.UpdateBufferCount;
  5019. var
  5020.   I, J, MaxBufferCount: Integer;
  5021.   DataLink: TDataLink;
  5022. begin
  5023.   if FHandle <> nil then
  5024.   begin
  5025.     MaxBufferCount := 1;
  5026.     FFirstDataLink := nil;
  5027.     for I := FDataSources.Count - 1 downto 0 do
  5028.       with TDataSource(FDataSources[I]) do
  5029.         for J := FDataLinks.Count - 1 downto 0 do
  5030.         begin
  5031.           DataLink := FDataLinks[J];
  5032.           DataLink.FNext := FFirstDataLink;
  5033.           FFirstDataLink := DataLink;
  5034.           if DataLink.FBufferCount > MaxBufferCount then
  5035.             MaxBufferCount := DataLink.FBufferCount;
  5036.         end;
  5037.     SetBufferCount(MaxBufferCount);
  5038.   end;
  5039. end;
  5040.  
  5041. procedure TDataSet.InitRecord(Buffer: PChar);
  5042. begin
  5043.   DbiInitRecord(FHandle, Buffer);
  5044.   FillChar(Buffer[FRecordSize], FCalcFieldsSize, 0);
  5045.   with PRecInfo(Buffer + FRecInfoOfs)^ do
  5046.   begin
  5047.     UpdateStatus := TUpdateStatus(usInserted);
  5048.     RecordNumber := -1;
  5049.   end;
  5050. end;
  5051.  
  5052. procedure TDataSet.AllocKeyBuffers;
  5053. var
  5054.   KeyIndex: TKeyIndex;
  5055. begin
  5056.   try
  5057.     for KeyIndex := Low(TKeyIndex) to High(TKeyIndex) do
  5058.       FKeyBuffers[KeyIndex] := InitKeyBuffer(
  5059.         AllocMem(SizeOf(TKeyBuffer) + FRecordSize));
  5060.   except
  5061.     FreeKeyBuffers;
  5062.     raise;
  5063.   end;
  5064. end;
  5065.  
  5066. procedure TDataSet.FreeKeyBuffers;
  5067. var
  5068.   KeyIndex: TKeyIndex;
  5069. begin
  5070.   for KeyIndex := Low(TKeyIndex) to High(TKeyIndex) do
  5071.     DisposeMem(FKeyBuffers[KeyIndex], SizeOf(TKeyBuffer) + FRecordSize);
  5072. end;
  5073.  
  5074. function TDataSet.InitKeyBuffer(Buffer: PKeyBuffer): PKeyBuffer;
  5075. begin
  5076.   FillChar(Buffer^, SizeOf(TKeyBuffer) + FRecordSize, 0);
  5077.   DbiInitRecord(FHandle, PChar(Buffer) + SizeOf(TKeyBuffer));
  5078.   Result := Buffer;
  5079. end;
  5080.  
  5081. procedure TDataSet.DataEvent(Event: TDataEvent; Info: Longint);
  5082. var
  5083.   I: Integer;
  5084. begin
  5085.   case Event of
  5086.     deFieldChange:
  5087.       begin
  5088.         if TField(Info).FieldKind = fkData then FModified := True;
  5089.         if State <> dsSetKey then
  5090.         begin
  5091.           if FBDECalcFields and (TField(Info).FieldKind = fkData) and
  5092.             not TField(Info).BDECalcField then
  5093.             CalculateBDEFields
  5094.           else if (FCalcFieldsSize <> 0) and FAutoCalcFields and
  5095.             (TField(Info).FieldKind = fkData) then
  5096.           begin
  5097.             FillChar(ActiveBuffer[FRecordSize], FCalcFieldsSize, 0);
  5098.             CalculateFields;
  5099.           end;
  5100.           TField(Info).Change;
  5101.         end;
  5102.       end;
  5103.     dePropertyChange:
  5104.       FFieldDefs.FUpdated := False;
  5105.   end;
  5106.   if FDisableCount = 0 then
  5107.   begin
  5108.     for I := 0 to FDataSources.Count - 1 do
  5109.       TDataSource(FDataSources[I]).DataEvent(Event, Info);
  5110.     if FDesigner <> nil then FDesigner.DataEvent(Event, Info);
  5111.   end else
  5112.     if (Event = deUpdateState) and (State = dsInactive) or
  5113.       (Event = deLayoutChange) then FEnableEvent := deLayoutChange;
  5114. end;
  5115.  
  5116. function TDataset.ControlsDisabled: Boolean;
  5117. begin
  5118.   Result := FDisableCount <> 0;
  5119. end;
  5120.  
  5121. procedure TDataSet.DisableControls;
  5122. begin
  5123.   if FDisableCount = 0 then
  5124.   begin
  5125.     FDisableState := FState;
  5126.     FEnableEvent := deDataSetChange;
  5127.   end;
  5128.   Inc(FDisableCount);
  5129. end;
  5130.  
  5131. procedure TDataSet.EnableControls;
  5132. begin
  5133.   if FDisableCount <> 0 then
  5134.   begin
  5135.     Dec(FDisableCount);
  5136.     if FDisableCount = 0 then
  5137.     begin
  5138.       if FDisableState <> FState then DataEvent(deUpdateState, 0);
  5139.       if (FDisableState <> dsInactive) and (FState <> dsInactive) then
  5140.         DataEvent(FEnableEvent, 0);
  5141.     end;
  5142.   end;
  5143. end;
  5144.  
  5145. procedure TDataSet.UpdateRecord;
  5146. begin
  5147.   if not (State in dsEditModes) then DBError(SNotEditing);
  5148.   DataEvent(deUpdateRecord, 0);
  5149. end;
  5150.  
  5151. procedure TDataSet.MoveBuffer(CurIndex, NewIndex: Integer);
  5152. var
  5153.   Buffer: PChar;
  5154. begin
  5155.   if CurIndex <> NewIndex then
  5156.   begin
  5157.     Buffer := FBuffers^[CurIndex];
  5158.     if CurIndex < NewIndex then
  5159.       Move(FBuffers^[CurIndex + 1], FBuffers^[CurIndex],
  5160.         (NewIndex - CurIndex) * SizeOf(Pointer))
  5161.     else
  5162.       Move(FBuffers^[NewIndex], FBuffers^[NewIndex + 1],
  5163.         (CurIndex - NewIndex) * SizeOf(Pointer));
  5164.     FBuffers^[NewIndex] := Buffer;
  5165.   end;
  5166. end;
  5167.  
  5168. procedure TDataSet.CopyBuffer(SourceIndex, DestIndex: Integer);
  5169. begin
  5170.   Move(FBuffers^[SourceIndex]^, FBuffers^[DestIndex]^, FRecBufSize);
  5171. end;
  5172.  
  5173. function TDataSet.ActiveBuffer: PChar;
  5174. begin
  5175.   Result := FBuffers^[FActiveRecord];
  5176. end;
  5177.  
  5178. procedure TDataSet.ClearBuffers;
  5179. begin
  5180.   FRecordCount := 0;
  5181.   FActiveRecord := 0;
  5182.   FCurrentRecord := -1;
  5183.   FBOF := True;
  5184.   FEOF := True;
  5185. end;
  5186.  
  5187. procedure TDataSet.ActivateBuffers;
  5188. begin
  5189.   FRecordCount := 1;
  5190.   FActiveRecord := 0;
  5191.   FCurrentRecord := 0;
  5192.   FBOF := False;
  5193.   FEOF := False;
  5194. end;
  5195.  
  5196. procedure TDataSet.GetCalcFields(Index: Integer);
  5197. var
  5198.   SaveState: TDataSetState;
  5199. begin
  5200.   if FCalcFieldsSize <> 0 then
  5201.   begin
  5202.     SaveState := FState;
  5203.     FState := dsCalcFields;
  5204.     try
  5205.       FCalcBuffer := FBuffers^[Index];
  5206.       FillChar(FCalcBuffer[FRecordSize], FCalcFieldsSize, 0);
  5207.       CalculateFields;
  5208.     finally
  5209.       FState := SaveState;
  5210.     end;
  5211.   end;
  5212. end;
  5213.  
  5214. procedure TDataSet.CalculateFields;
  5215. var
  5216.   I: Integer;
  5217. begin
  5218.   for I := 0 to FFields.Count - 1 do
  5219.     with TField(FFields[I]) do
  5220.       if FieldKind = fkLookup then CalcLookupValue;
  5221.   DoOnCalcFields;
  5222. end;
  5223.  
  5224. procedure TDataSet.CalculateBDEFields;
  5225. var
  5226.   I: Integer;
  5227. begin
  5228.   for I := 0 to FFields.Count - 1 do
  5229.     with TField(FFields[I]) do
  5230.       if BDECalcField then Value := Value;
  5231. end;
  5232.  
  5233. function TDataSet.GetCanModify: Boolean;
  5234. begin
  5235.   Result := FCanModify or ForceUpdateCallback;
  5236. end;
  5237.  
  5238. function TDataSet.GetRecord(Index: Integer; GetMode: TGetMode): DBIResult;
  5239. var
  5240.   Buffer: PChar;
  5241. begin
  5242.   Buffer := FBuffers^[Index];
  5243.   case GetMode of
  5244.     gmCurrent:
  5245.       Result := DbiGetRecord(FHandle, dbiNoLock, Buffer, @FRecProps);
  5246.     gmNext:
  5247.       Result := DbiGetNextRecord(FHandle, dbiNoLock, Buffer, @FRecProps);
  5248.     gmPrior:
  5249.       Result := DbiGetPriorRecord(FHandle, dbiNoLock, Buffer, @FRecProps);
  5250.   else
  5251.     Result := 0;
  5252.   end;
  5253.   if Result = 0 then
  5254.   begin
  5255.     with PRecInfo(Buffer + FRecInfoOfs)^ do
  5256.     begin
  5257.       UpdateStatus := TUpdateStatus(FRecProps.iRecStatus);
  5258.       case FRecNoStatus of
  5259.         rnParadox: RecordNumber := FRecProps.iSeqNum;
  5260.         rnDBase: RecordNumber := FRecProps.iPhyRecNum;
  5261.       else
  5262.         RecordNumber := -1;
  5263.       end;
  5264.     end;
  5265.     GetCalcFields(Index);
  5266.     Buffer[FBookmarkOfs] := #0;
  5267.     Check(DbiGetBookmark(FHandle, Buffer + FBookmarkOfs + 1));
  5268.   end;
  5269. end;
  5270.  
  5271. procedure TDataSet.SetCurrentRecord(Index: Integer);
  5272. var
  5273.   Buffer: PChar;
  5274. begin
  5275.   if FCurrentRecord <> Index then
  5276.   begin
  5277.     Buffer := FBuffers^[Index];
  5278.     case Buffer[FBookmarkOfs] of
  5279.       #0,#255: Check(DbiSetToBookmark(FHandle, Buffer + FBookmarkOfs + 1));
  5280.       #1: Check(DbiSetToBegin(FHandle));
  5281.       #2: Check(DbiSetToEnd(FHandle));
  5282.     end;
  5283.     FCurrentRecord := Index;
  5284.   end;
  5285. end;
  5286.  
  5287. procedure TDataSet.UpdateCursorPos;
  5288. begin
  5289.   if FRecordCount > 0 then SetCurrentRecord(FActiveRecord);
  5290. end;
  5291.  
  5292. procedure TDataSet.CursorPosChanged;
  5293. begin
  5294.   FCurrentRecord := -1;
  5295. end;
  5296.  
  5297. function TDataSet.GetCurrentRecord(Buffer: PChar): Boolean;
  5298. begin
  5299.   Result := False;
  5300.   if (FActiveRecord < FRecordCount) and
  5301.     (FBuffers^[FActiveRecord][FBookmarkOfs] = #0) then
  5302.   begin
  5303.     if FCurrentRecord <> FActiveRecord then
  5304.     begin
  5305.       if DbiSetToBookmark(FHandle, FBuffers^[FActiveRecord] +
  5306.         FBookmarkOfs + 1) <> 0 then Exit;
  5307.       FCurrentRecord := FActiveRecord;
  5308.     end;
  5309.     Result := DbiGetRecord(FHandle, dbiNoLock, Buffer, nil) = 0;
  5310.   end;
  5311. end;
  5312.  
  5313. function TDataSet.GetNextRecord: Boolean;
  5314. var
  5315.   GetMode: TGetMode;
  5316.   Status: DBIResult;
  5317. begin
  5318.   GetMode := gmNext;
  5319.   if FRecordCount > 0 then
  5320.   begin
  5321.     SetCurrentRecord(FRecordCount - 1);
  5322.     if (State = dsInsert) and (FCurrentRecord = FActiveRecord) and
  5323.       (ActiveBuffer[FBookmarkOfs] = #0) then GetMode := gmCurrent;
  5324.   end;
  5325.   Status := GetRecord(FRecordCount, GetMode);
  5326.   case Status of
  5327.     DBIERR_NONE:
  5328.       begin
  5329.         if FRecordCount = 0 then
  5330.           ActivateBuffers
  5331.         else
  5332.           if FRecordCount < FBufferCount then
  5333.             Inc(FRecordCount)
  5334.           else
  5335.             MoveBuffer(0, FRecordCount);
  5336.         FCurrentRecord := FRecordCount - 1;
  5337.         Result := True;
  5338.       end;
  5339.     DBIERR_EOF:
  5340.       begin
  5341.         FCurrentRecord := -1;
  5342.         Result := False;
  5343.       end;
  5344.   else
  5345.     DbiError(Status);
  5346.   end;
  5347. end;
  5348.  
  5349. function TDataSet.GetPriorRecord: Boolean;
  5350. var
  5351.   Status: DBIResult;
  5352. begin
  5353.   if FRecordCount > 0 then SetCurrentRecord(0);
  5354.   Status := GetRecord(FRecordCount, gmPrior);
  5355.   case Status of
  5356.     DBIERR_NONE:
  5357.       begin
  5358.         if FRecordCount = 0 then
  5359.           ActivateBuffers
  5360.         else
  5361.         begin
  5362.           MoveBuffer(FRecordCount, 0);
  5363.           if FRecordCount < FBufferCount then
  5364.           begin
  5365.             Inc(FRecordCount);
  5366.             Inc(FActiveRecord);
  5367.           end;
  5368.         end;
  5369.         FCurrentRecord := 0;
  5370.         Result := True;
  5371.       end;
  5372.     DBIERR_BOF:
  5373.       begin
  5374.         FCurrentRecord := -1;
  5375.         Result := False;
  5376.       end;
  5377.   else
  5378.     DbiError(Status);
  5379.   end;
  5380. end;
  5381.  
  5382. function TDataSet.GetNextRecords: Integer;
  5383. begin
  5384.   Result := 0;
  5385.   try
  5386.     while (FRecordCount < FBufferCount) and GetNextRecord do Inc(Result);
  5387.   except
  5388.   end;
  5389. end;
  5390.  
  5391. function TDataSet.GetPriorRecords: Integer;
  5392. begin
  5393.   Result := 0;
  5394.   try
  5395.     while (FRecordCount < FBufferCount) and GetPriorRecord do Inc(Result);
  5396.   except
  5397.   end;
  5398. end;
  5399.  
  5400. procedure TDataSet.Resync(Mode: TResyncMode);
  5401. var
  5402.   Count: Integer;
  5403. begin
  5404.   if rmExact in Mode then
  5405.   begin
  5406.     FCurrentRecord := -1;
  5407.     Check(GetRecord(FRecordCount, gmCurrent));
  5408.   end else
  5409.     if (GetRecord(FRecordCount, gmCurrent) <> 0) and
  5410.       (GetRecord(FRecordCount, gmNext) <> 0) and
  5411.       (GetRecord(FRecordCount, gmPrior) <> 0) then
  5412.     begin
  5413.       ClearBuffers;
  5414.       DataEvent(deDataSetChange, 0);
  5415.       Exit;
  5416.     end;
  5417.   if rmCenter in Mode then
  5418.     Count := (FBufferCount - 1) div 2 else
  5419.     Count := FActiveRecord;
  5420.   MoveBuffer(FRecordCount, 0);
  5421.   ActivateBuffers;
  5422.   try
  5423.     while (Count > 0) and GetPriorRecord do Dec(Count);
  5424.     GetNextRecords;
  5425.     GetPriorRecords;
  5426.   except
  5427.   end;
  5428.   DataEvent(deDataSetChange, 0);
  5429. end;
  5430.  
  5431. procedure TDataSet.CheckBrowseMode;
  5432. begin
  5433.   if State = dsInactive then DBError(SDataSetClosed);
  5434.   DataEvent(deCheckBrowseMode, 0);
  5435.   case State of
  5436.     dsEdit, dsInsert:
  5437.       begin
  5438.         UpdateRecord;
  5439.         if Modified then Post else Cancel;
  5440.       end;
  5441.     dsSetKey:
  5442.       Post;
  5443.   end;
  5444. end;
  5445.  
  5446. procedure TDataSet.CheckSetKeyMode;
  5447. begin
  5448.   if State <> dsSetKey then DBError(SNotEditing);
  5449. end;
  5450.  
  5451. procedure TDataSet.CheckCanModify;
  5452. begin
  5453.   if not CanModify then DBError(SDataSetReadOnly);
  5454. end;
  5455.  
  5456. procedure TDataSet.CheckCachedUpdateMode;
  5457. begin
  5458.   if not CachedUpdates then DBError(SNoCachedUpdates);
  5459. end;
  5460.  
  5461. procedure TDataSet.First;
  5462. begin
  5463.   CheckBrowseMode;
  5464.   ClearBuffers;
  5465.   try
  5466.     Check(DbiSetToBegin(FHandle));
  5467.     GetNextRecord;
  5468.     GetNextRecords;
  5469.   finally
  5470.     FBOF := True;
  5471.     DataEvent(deDataSetChange, 0);
  5472.   end;
  5473. end;
  5474.  
  5475. procedure TDataSet.Last;
  5476. begin
  5477.   CheckBrowseMode;
  5478.   ClearBuffers;
  5479.   try
  5480.     Check(DbiSetToEnd(FHandle));
  5481.     GetPriorRecord;
  5482.     GetPriorRecords;
  5483.   finally
  5484.     FEOF := True;
  5485.     DataEvent(deDataSetChange, 0);
  5486.   end;
  5487. end;
  5488.  
  5489. function TDataSet.MoveBy(Distance: Integer): Integer;
  5490. var
  5491.   I, ScrollCount: Integer;
  5492. begin
  5493.   CheckBrowseMode;
  5494.   Result := 0;
  5495.   if ((Distance > 0) and not FEOF) or ((Distance < 0) and not FBOF) then
  5496.   begin
  5497.     FBOF := False;
  5498.     FEOF := False;
  5499.     ScrollCount := 0;
  5500.     try
  5501.       while Distance > 0 do
  5502.       begin
  5503.         if FActiveRecord < FRecordCount - 1 then Inc(FActiveRecord) else
  5504.         begin
  5505.           if FRecordCount < FBufferCount then I := 0 else I := 1;
  5506.           if GetNextRecord then Dec(ScrollCount, I) else
  5507.           begin
  5508.             FEOF := True;
  5509.             Break;
  5510.           end;
  5511.         end;
  5512.         Dec(Distance);
  5513.         Inc(Result);
  5514.       end;
  5515.       while Distance < 0 do
  5516.       begin
  5517.         if FActiveRecord > 0 then Dec(FActiveRecord) else
  5518.         begin
  5519.           if FRecordCount < FBufferCount then I := 0 else I := 1;
  5520.           if GetPriorRecord then Inc(ScrollCount, I) else
  5521.           begin
  5522.             FBOF := True;
  5523.             Break;
  5524.           end;
  5525.         end;
  5526.         Inc(Distance);
  5527.         Dec(Result);
  5528.       end;
  5529.     finally
  5530.       DataEvent(deDataSetScroll, ScrollCount);
  5531.     end;
  5532.   end;
  5533. end;
  5534.  
  5535. procedure TDataSet.Next;
  5536. begin
  5537.   MoveBy(1);
  5538. end;
  5539.  
  5540. procedure TDataSet.Prior;
  5541. begin
  5542.   MoveBy(-1);
  5543. end;
  5544.  
  5545. procedure TDataSet.Refresh;
  5546. begin
  5547.   CheckBrowseMode;
  5548.   UpdateCursorPos;
  5549.   Check(DbiForceReread(FHandle));
  5550.   Resync([]);
  5551. end;
  5552.  
  5553. procedure TDataSet.SetFields(const Values: array of const);
  5554. var
  5555.   I: Integer;
  5556. begin
  5557.   for I := 0 to High(Values) do Fields[I].AssignValue(Values[I]);
  5558. end;
  5559.  
  5560. procedure TDataSet.Insert;
  5561. var
  5562.   Buffer: PChar;
  5563. begin
  5564.   BeginInsertAppend;
  5565.   MoveBuffer(FRecordCount, FActiveRecord);
  5566.   Buffer := ActiveBuffer;
  5567.   InitRecord(Buffer);
  5568.   if FRecordCount = 0 then
  5569.     Buffer[FBookmarkOfs] := #1
  5570.   else
  5571.   begin
  5572.     Move(FBuffers^[FActiveRecord + 1][FBookmarkOfs], Buffer[FBookmarkOfs],
  5573.       FBookmarkSize + 1);
  5574.     Buffer[FBookmarkOfs] := #255;
  5575.   end;
  5576.   if FRecordCount < FBufferCount then Inc(FRecordCount);
  5577.   EndInsertAppend;
  5578. end;
  5579.  
  5580. procedure TDataSet.Append;
  5581. var
  5582.   Buffer: PChar;
  5583. begin
  5584.   BeginInsertAppend;
  5585.   ClearBuffers;
  5586.   Buffer := FBuffers^[0];
  5587.   InitRecord(Buffer);
  5588.   Buffer[FBookmarkOfs] := #2;
  5589.   FRecordCount := 1;
  5590.   FBOF := False;
  5591.   GetPriorRecords;
  5592.   EndInsertAppend;
  5593. end;
  5594.  
  5595. procedure TDataSet.BeginInsertAppend;
  5596. begin
  5597.   CheckBrowseMode;
  5598.   CheckCanModify;
  5599.   DoBeforeInsert;
  5600. end;
  5601.  
  5602. procedure TDataSet.EndInsertAppend;
  5603. begin
  5604.   SetState(dsInsert);
  5605.   try
  5606.     DoOnNewRecord;
  5607.   except
  5608.     UpdateCursorPos;
  5609.     FreeFieldBuffers;
  5610.     SetState(dsBrowse);
  5611.     Resync([]);
  5612.     raise;
  5613.   end;
  5614.   FModified := False;
  5615.   DataEvent(deDataSetChange, 0);
  5616.   DoAfterInsert;
  5617. end;
  5618.  
  5619. procedure TDataSet.AddRecord(const Values: array of const; Append: Boolean);
  5620. var
  5621.   Buffer: PChar;
  5622. begin
  5623.   BeginInsertAppend;
  5624.   if not Append then UpdateCursorPos;
  5625.   DisableControls;
  5626.   try
  5627.     MoveBuffer(FRecordCount, FActiveRecord);
  5628.     try
  5629.       Buffer := ActiveBuffer;
  5630.       InitRecord(Buffer);
  5631.       FState := dsInsert;
  5632.       try
  5633.         DoOnNewRecord;
  5634.         DoAfterInsert;
  5635.         SetFields(Values);
  5636.         DoBeforePost;
  5637.         if Append then
  5638.           Check(DbiAppendRecord(FHandle, Buffer)) else
  5639.           Check(DbiInsertRecord(FHandle, dbiNoLock, Buffer));
  5640.       finally
  5641.         FreeFieldBuffers;
  5642.         FState := dsBrowse;
  5643.         FModified := False;
  5644.       end;
  5645.     except
  5646.       MoveBuffer(FActiveRecord, FRecordCount);
  5647.       raise;
  5648.     end;
  5649.     Resync([]);
  5650.     DoAfterPost;
  5651.   finally
  5652.     EnableControls;
  5653.   end;
  5654. end;
  5655.  
  5656. procedure TDataSet.InsertRecord(const Values: array of const);
  5657. begin
  5658.   AddRecord(Values, False);
  5659. end;
  5660.  
  5661. procedure TDataSet.AppendRecord(const Values: array of const);
  5662. begin
  5663.   AddRecord(Values, True);
  5664. end;
  5665.  
  5666. procedure TDataSet.CheckOperation(Operation: TDataOperation;
  5667.   ErrorEvent: TDataSetErrorEvent);
  5668. var
  5669.   Done: Boolean;
  5670.   Action: TDataAction;
  5671. begin
  5672.   Done := False;
  5673.   repeat
  5674.     try
  5675.       UpdateCursorPos;
  5676.       Check(Operation);
  5677.       Done := True;
  5678.     except
  5679.       on E: EDatabaseError do
  5680.       begin
  5681.         Action := daFail;
  5682.         if Assigned(ErrorEvent) then ErrorEvent(Self, E, Action);
  5683.         if Action = daFail then raise;
  5684.         if Action = daAbort then SysUtils.Abort;
  5685.       end;
  5686.     end;
  5687.   until Done;
  5688. end;
  5689.  
  5690. function TDataSet.EditRecord: DBIResult;
  5691. begin
  5692.   Result := DbiGetRecord(FHandle, dbiWriteLock, ActiveBuffer, nil);
  5693. end;
  5694.  
  5695. procedure TDataSet.Edit;
  5696. begin
  5697.   if not (State in [dsEdit, dsInsert]) then
  5698.     if FRecordCount = 0 then Insert else
  5699.     begin
  5700.       CheckBrowseMode;
  5701.       CheckCanModify;
  5702.       DoBeforeEdit;
  5703.       CheckOperation(EditRecord, FOnEditError);
  5704.       GetCalcFields(FActiveRecord);
  5705.       SetState(dsEdit);
  5706.       DataEvent(deRecordChange, 0);
  5707.       DoAfterEdit;
  5708.     end;
  5709. end;
  5710.  
  5711. procedure TDataSet.ClearFields;
  5712. begin
  5713.   if not (State in dsEditModes) then DBError(SNotEditing);
  5714.   DataEvent(deCheckBrowseMode, 0);
  5715.   DbiInitRecord(FHandle, ActiveBuffer);
  5716.   if State <> dsSetKey then GetCalcFields(FActiveRecord);
  5717.   DataEvent(deRecordChange, 0);
  5718. end;
  5719.  
  5720. procedure TDataSet.CheckRequiredFields;
  5721. const
  5722.   CheckTypes = [ftString, ftSmallint, ftInteger, ftWord, ftBoolean, ftFloat,
  5723.     ftCurrency, ftBCD, ftDate, ftTime, ftDateTime, ftBytes, ftVarBytes];
  5724. var
  5725.   I: Integer;
  5726. begin
  5727.   for I := 0 to FFields.Count - 1 do
  5728.     with TField(FFields[I]) do
  5729.       if Required and not ReadOnly and (FieldKind = fkData) and
  5730.         (DataType in CheckTypes) and IsNull then
  5731.       begin
  5732.         FocusControl;
  5733.         DBErrorFmt(SFieldRequired, [DisplayName]);
  5734.       end;
  5735. end;
  5736.  
  5737. function TDataSet.PostRecord: DBIResult;
  5738. begin
  5739.   if State = dsEdit then
  5740.     Result := DbiModifyRecord(FHandle, ActiveBuffer, True) else
  5741.     Result := DbiInsertRecord(FHandle, dbiNoLock, ActiveBuffer);
  5742. end;
  5743.  
  5744. procedure TDataSet.Post;
  5745. begin
  5746.   UpdateRecord;
  5747.   case State of
  5748.     dsEdit, dsInsert:
  5749.       begin
  5750.         DataEvent(deCheckBrowseMode, 0);
  5751.         CheckRequiredFields;
  5752.         DoBeforePost;
  5753.         CheckOperation(PostRecord, FOnPostError);
  5754.         FreeFieldBuffers;
  5755.         SetState(dsBrowse);
  5756.         Resync([]);
  5757.         DoAfterPost;
  5758.       end;
  5759.     dsSetKey:
  5760.       PostKeyBuffer(True);
  5761.   end;
  5762. end;
  5763.  
  5764. procedure TDataSet.Cancel;
  5765. begin
  5766.   case State of
  5767.     dsEdit, dsInsert:
  5768.       begin
  5769.         DataEvent(deCheckBrowseMode, 0);
  5770.         DoBeforeCancel;
  5771.         UpdateCursorPos;
  5772.         if State = dsEdit then DbiRelRecordLock(FHandle, False);
  5773.         FreeFieldBuffers;
  5774.         SetState(dsBrowse);
  5775.         Resync([]);
  5776.         DoAfterCancel;
  5777.       end;
  5778.     dsSetKey:
  5779.       PostKeyBuffer(False);
  5780.   end;
  5781. end;
  5782.  
  5783. function TDataSet.DeleteRecord: DBIResult;
  5784. begin
  5785.   Result := DbiDeleteRecord(FHandle, nil);
  5786.   if Hi(Result) = ERRCAT_NOTFOUND then Result := 0;
  5787. end;
  5788.  
  5789. procedure TDataSet.Delete;
  5790. begin
  5791.   if State = dsInactive then DBError(SDataSetClosed);
  5792.   if State in [dsInsert, dsSetKey] then Cancel else
  5793.   begin
  5794.     if FRecordCount = 0 then DBError(SDataSetEmpty);
  5795.     DataEvent(deCheckBrowseMode, 0);
  5796.     DoBeforeDelete;
  5797.     CheckOperation(DeleteRecord, FOnDeleteError);
  5798.     FreeFieldBuffers;
  5799.     SetState(dsBrowse);
  5800.     Resync([]);
  5801.     DoAfterDelete;
  5802.   end;
  5803. end;
  5804.  
  5805. function TDataSet.GetBookmark: TBookmark;
  5806. begin
  5807.   Result := nil;
  5808.   if (State in [dsBrowse, dsEdit, dsInsert]) and (FRecordCount > 0)
  5809.     and (ActiveBuffer[FBookmarkOfs] = #0) then
  5810.   begin
  5811.     Result := StrAlloc(FBookmarkSize);
  5812.     Move(ActiveBuffer[FBookmarkOfs + 1], Result^, FBookmarkSize);
  5813.   end;
  5814. end;
  5815.  
  5816. function TDataset.GetBookmarkStr: TBookmarkStr;
  5817. begin
  5818.   Result := '';
  5819.   if (State in [dsBrowse, dsEdit, dsInsert]) and (FRecordCount > 0)
  5820.     and (ActiveBuffer[FBookmarkOfs] = #0) then
  5821.   begin
  5822.     SetString(Result, PChar(@ActiveBuffer[FBookmarkOfs + 1]), FBookmarkSize);
  5823.   end;
  5824. end;
  5825.  
  5826. procedure TDataSet.GotoBookmark(Bookmark: TBookmark);
  5827. begin
  5828.   if Bookmark <> nil then
  5829.   begin
  5830.     CheckBrowseMode;
  5831.     Check(DbiSetToBookmark(FHandle, Bookmark));
  5832.     Resync([rmExact, rmCenter]);
  5833.   end;
  5834. end;
  5835.  
  5836. procedure TDataset.SetBookmarkStr(const Value: TBookmarkStr);
  5837. begin
  5838.   GotoBookmark(Pointer(Value));
  5839. end;
  5840.  
  5841. procedure TDataSet.FreeBookmark(Bookmark: TBookmark);
  5842. begin
  5843.   StrDispose(Bookmark);
  5844. end;
  5845.  
  5846. function TDataSet.GetKeyBuffer(KeyIndex: TKeyIndex): PKeyBuffer;
  5847. begin
  5848.   Result := FKeyBuffers[KeyIndex];
  5849. end;
  5850.  
  5851. procedure TDataSet.SetKeyBuffer(KeyIndex: TKeyIndex; Clear: Boolean);
  5852. begin
  5853.   CheckBrowseMode;
  5854.   FKeyBuffer := FKeyBuffers[KeyIndex];
  5855.   Move(FKeyBuffer^, FKeyBuffers[kiSave]^, SizeOf(TKeyBuffer) + FRecordSize);
  5856.   if Clear then InitKeyBuffer(FKeyBuffer);
  5857.   SetState(dsSetKey);
  5858.   DataEvent(deDataSetChange, 0);
  5859. end;
  5860.  
  5861. procedure TDataSet.PostKeyBuffer(Commit: Boolean);
  5862. begin
  5863.   DataEvent(deCheckBrowseMode, 0);
  5864.   if Commit then
  5865.     FKeyBuffer^.Modified := FModified
  5866.   else
  5867.     Move(FKeyBuffers[kiSave]^, FKeyBuffer^, SizeOf(TKeyBuffer) + FRecordSize);
  5868.   SetState(dsBrowse);
  5869.   DataEvent(deDataSetChange, 0);
  5870. end;
  5871.  
  5872. function TDataSet.GetKeyExclusive: Boolean;
  5873. begin
  5874.   CheckSetKeyMode;
  5875.   Result := FKeyBuffer^.Exclusive;
  5876. end;
  5877.  
  5878. procedure TDataSet.SetKeyExclusive(Value: Boolean);
  5879. begin
  5880.   CheckSetKeyMode;
  5881.   FKeyBuffer^.Exclusive := Value;
  5882. end;
  5883.  
  5884. function TDataSet.GetKeyFieldCount: Integer;
  5885. begin
  5886.   CheckSetKeyMode;
  5887.   Result := FKeyBuffer^.FieldCount;
  5888. end;
  5889.  
  5890. procedure TDataSet.SetKeyFieldCount(Value: Integer);
  5891. begin
  5892.   CheckSetKeyMode;
  5893.   FKeyBuffer^.FieldCount := Value;
  5894. end;
  5895.  
  5896. procedure TDataSet.SetKeyFields(KeyIndex: TKeyIndex;
  5897.   const Values: array of const);
  5898. var
  5899.   I: Integer;
  5900. begin
  5901.   if ExpIndex then DBError(SCompositeIndexError);
  5902.   if FIndexFieldCount = 0 then DBError(SNoFieldIndexes);
  5903.   Inc(FDisableCount);
  5904.   FState := dsSetKey;
  5905.   FModified := False;
  5906.   FKeyBuffer := InitKeyBuffer(FKeyBuffers[KeyIndex]);
  5907.   try
  5908.     for I := 0 to High(Values) do GetIndexField(I).AssignValue(Values[I]);
  5909.     FKeyBuffer^.FieldCount := High(Values) + 1;
  5910.     FKeyBuffer^.Modified := FModified;
  5911.   finally
  5912.     FState := dsBrowse;
  5913.     FModified := False;
  5914.     Dec(FDisableCount);
  5915.   end;
  5916. end;
  5917.  
  5918. procedure TDataSet.SetDetailFields(MasterFields: TList);
  5919. var
  5920.   SaveState: TDataSetState;
  5921.   I: Integer;
  5922. begin
  5923.   Inc(FDisableCount);
  5924.   SaveState := FState;
  5925.   FState := dsSetKey;
  5926.   try
  5927.     FKeyBuffer := InitKeyBuffer(FKeyBuffers[kiLookup]);
  5928.     FKeyBuffer^.Modified := True;
  5929.     for I := 0 to MasterFields.Count - 1 do
  5930.       GetIndexField(I).Assign(TField(MasterFields[I]));
  5931.     FKeyBuffer^.FieldCount := MasterFields.Count;
  5932.   finally
  5933.     FState := SaveState;
  5934.     FModified := False;
  5935.     Dec(FDisableCount);
  5936.   end;
  5937. end;
  5938.  
  5939. function TDataSet.SetCursorRange: Boolean;
  5940. var
  5941.   RangeStart, RangeEnd: PKeyBuffer;
  5942.   StartKey, EndKey: PChar;
  5943.   IndexBuffer: PChar;
  5944.   UseStartKey, UseEndKey, UseKey: Boolean;
  5945. begin
  5946.   Result := False;
  5947.   if not (
  5948.     BuffersEqual(FKeyBuffers[kiRangeStart], FKeyBuffers[kiCurRangeStart],
  5949.     SizeOf(TKeyBuffer) + FRecordSize) and
  5950.     BuffersEqual(FKeyBuffers[kiRangeEnd], FKeyBuffers[kiCurRangeEnd],
  5951.     SizeOf(TKeyBuffer) + FRecordSize)) then
  5952.   begin
  5953.     IndexBuffer := AllocMem(KeySize * 2);
  5954.     try
  5955.       UseStartKey := True;
  5956.       UseEndKey := True;
  5957.       RangeStart := FKeyBuffers[kiRangeStart];
  5958.       if RangeStart^.Modified then
  5959.       begin
  5960.         StartKey := PChar(RangeStart) + SizeOf(TKeyBuffer);
  5961.         UseStartKey := DbiExtractKey(Handle, StartKey, IndexBuffer) = 0;
  5962.       end
  5963.       else StartKey := nil;
  5964.       RangeEnd := FKeyBuffers[kiRangeEnd];
  5965.       if RangeEnd^.Modified then
  5966.       begin
  5967.         EndKey := PChar(RangeEnd) + SizeOf(TKeyBuffer);
  5968.         UseEndKey := DbiExtractKey(Handle, EndKey, IndexBuffer + KeySize) = 0;
  5969.       end
  5970.       else EndKey := nil;
  5971.       UseKey := UseStartKey and UseEndKey;
  5972.       if UseKey then
  5973.       begin
  5974.         if StartKey <> nil then StartKey := IndexBuffer;
  5975.         if EndKey <> nil then EndKey := IndexBuffer + KeySize;
  5976.       end;
  5977.       Check(DbiSetRange(FHandle, UseKey,
  5978.         RangeStart^.FieldCount, 0, StartKey, not RangeStart^.Exclusive,
  5979.         RangeEnd^.FieldCount, 0, EndKey, not RangeEnd^.Exclusive));
  5980.       Move(FKeyBuffers[kiRangeStart]^, FKeyBuffers[kiCurRangeStart]^,
  5981.         SizeOf(TKeyBuffer) + FRecordSize);
  5982.       Move(FKeyBuffers[kiRangeEnd]^, FKeyBuffers[kiCurRangeEnd]^,
  5983.         SizeOf(TKeyBuffer) + FRecordSize);
  5984.       DestroyLookupCursor;
  5985.       Result := True;
  5986.     finally
  5987.       FreeMem(IndexBuffer, KeySize * 2);
  5988.     end;
  5989.   end;
  5990. end;
  5991.  
  5992. function TDataSet.ResetCursorRange: Boolean;
  5993. begin
  5994.   Result := False;
  5995.   if FKeyBuffers[kiCurRangeStart]^.Modified or
  5996.     FKeyBuffers[kiCurRangeEnd]^.Modified then
  5997.   begin
  5998.     Check(DbiResetRange(FHandle));
  5999.     InitKeyBuffer(FKeyBuffers[kiCurRangeStart]);
  6000.     InitKeyBuffer(FKeyBuffers[kiCurRangeEnd]);
  6001.     DestroyLookupCursor;
  6002.     Result := True;
  6003.   end;
  6004. end;
  6005.  
  6006. procedure TDataSet.SetLinkRanges(MasterFields: TList);
  6007. var
  6008.   SaveState: TDataSetState;
  6009.   I: Integer;
  6010. begin
  6011.   Inc(FDisableCount);
  6012.   SaveState := FState;
  6013.   FState := dsSetKey;
  6014.   try
  6015.     FKeyBuffer := InitKeyBuffer(FKeyBuffers[kiRangeStart]);
  6016.     FKeyBuffer^.Modified := True;
  6017.     for I := 0 to MasterFields.Count - 1 do
  6018.       GetIndexField(I).Assign(TField(MasterFields[I]));
  6019.     FKeyBuffer^.FieldCount := MasterFields.Count;
  6020.   finally
  6021.     FState := SaveState;
  6022.     FModified := False;
  6023.     Dec(FDisableCount);
  6024.   end;
  6025.   Move(FKeyBuffers[kiRangeStart]^, FKeyBuffers[kiRangeEnd]^,
  6026.     SizeOf(TKeyBuffer) + FRecordSize);
  6027. end;
  6028.  
  6029. function TDataSet.GetRecordCount: Longint;
  6030. begin
  6031.   if State = dsInactive then DBError(SDataSetClosed);
  6032.   Check(DbiGetExactRecordCount(FHandle, Result));
  6033. end;
  6034.  
  6035. function TDataSet.GetRecordNumber: Longint;
  6036. var
  6037.   BufPtr: PChar;
  6038. begin
  6039.   case State of
  6040.     dsInactive: DBError(SDataSetClosed);
  6041.     dsCalcFields: BufPtr := FCalcBuffer
  6042.   else
  6043.     BufPtr := ActiveBuffer;
  6044.   end;
  6045.   Result := PRecInfo(BufPtr + FRecInfoOfs).RecordNumber;
  6046. end;
  6047.  
  6048. procedure TDataSet.AllocDelUpdCBBuf(Allocate: Boolean);
  6049. begin
  6050.   if Allocate then
  6051.   begin
  6052.     FUpdateCBBuf := AllocMem(SizeOf(DELAYUPDCbDesc));
  6053.     FUpdateCBBuf.pNewRecBuf := StrAlloc(FRecBufSize);
  6054.     FUpdateCBBuf.pOldRecBuf := StrAlloc(FRecBufSize);
  6055.     FUpdateCBBuf.iRecBufSize := FRecordSize;
  6056.   end else
  6057.   begin
  6058.     if Assigned(FUpdateCBBuf) then
  6059.     begin
  6060.       StrDispose(FUpdateCBBuf.pNewRecBuf);
  6061.       StrDispose(FUpdateCBBuf.pOldRecBuf);
  6062.       DisposeMem(FUpdateCBBuf, SizeOf(DELAYUPDCbDesc));
  6063.     end;
  6064.   end;
  6065. end;
  6066.  
  6067. function TDataSet.UpdateCallbackRequired: Boolean;
  6068. begin
  6069.   Result := FCachedUpdates and (Assigned(FOnUpdateError) or
  6070.     Assigned(FOnUpdateRecord) or Assigned(FUpdateObject));
  6071. end;
  6072.  
  6073. function TDataSet.ForceUpdateCallback: Boolean;
  6074. begin
  6075.   Result := FCachedUpdates and (Assigned(FOnUpdateRecord) or
  6076.     Assigned(FUpdateObject));
  6077. end;
  6078.  
  6079. procedure TDataSet.SetCachedUpdates(Value: Boolean);
  6080.  
  6081.   procedure ReAllocBuffers;
  6082.   var
  6083.     CursorProps: CurProps;
  6084.   begin
  6085.     FreeFieldBuffers;
  6086.     FreeKeyBuffers;
  6087.     SetBufListSize(0);
  6088.     DbiGetCursorProps(FHandle, CursorProps);
  6089.     FRecordSize := CursorProps.iRecBufSize;
  6090.     FBookmarkSize := CursorProps.iBookmarkSize;
  6091.     FRecInfoOfs := FRecordSize + FCalcFieldsSize;
  6092.     FBookmarkOfs :=  FRecordSize + FCalcFieldsSize + SizeOf(TRecInfo);
  6093.     FRecBufSize := FBookmarkOfs + FBookmarkSize + 1;
  6094.     try
  6095.       SetBufListSize(FBufferCount + 1);
  6096.       AllocKeyBuffers;
  6097.     except
  6098.       SetState(dsInactive);
  6099.       CloseCursor;
  6100.       raise;
  6101.     end;
  6102.   end;
  6103.  
  6104. begin
  6105.   if State = dsInActive then
  6106.     FCachedUpdates := Value
  6107.   else if FCachedUpdates <> Value then
  6108.   begin
  6109.     CheckBrowseMode;
  6110.     UpdateCursorPos;
  6111.     if FCachedUpdates then
  6112.       Check(DbiEndDelayedUpdates(FHandle))
  6113.     else
  6114.       Check(DbiBeginDelayedUpdates(FHandle));
  6115.     FCachedUpdates := Value;
  6116.     ReAllocBuffers;
  6117.     AllocDelUpdCBBuf(Value);
  6118.     SetupCallBack(UpdateCallBackRequired);
  6119.     Resync([]);
  6120.   end;
  6121. end;
  6122.  
  6123. procedure TDataSet.SetupCallBack(Value: Boolean);
  6124. begin
  6125.   if Value then
  6126.   begin
  6127.     if (csDesigning in ComponentState) then Exit;
  6128.     if not Assigned(FUpdateCallback) then
  6129.       FUpdateCallback := TBDECallback.Create(Self, Self.Handle, cbDELAYEDUPD,
  6130.         FUpdateCBBuf, SizeOf(DELAYUPDCbDesc), CachedUpdateCallBack, True);
  6131.   end
  6132.   else
  6133.   begin
  6134.     if Assigned(FUpdateCallback) then
  6135.     begin
  6136.       FUpdateCallback.Free;
  6137.       FUpdateCallback := nil;
  6138.     end;
  6139.   end;
  6140. end;
  6141.  
  6142. function TDataSet.ProcessUpdates(UpdCmd: DBIDelayedUpdCmd): DBIResult;
  6143. begin
  6144.   CheckCachedUpdateMode;
  6145.   UpdateCursorPos;
  6146.   Result := DbiApplyDelayedUpdates(Handle, UpdCmd);
  6147.   Resync([]);
  6148. end;
  6149.  
  6150. procedure TDataSet.ApplyUpdates;
  6151. var
  6152.   Status: DBIResult;
  6153. begin
  6154.   if State <> dsBrowse then Post;
  6155.   Status := ProcessUpdates(dbiDelayedUpdPrepare);
  6156.   if Status <> DBIERR_NONE then
  6157.     if Status = DBIERR_UPDATEABORT then SysUtils.Abort
  6158.     else DbiError(Status);
  6159. end;
  6160.  
  6161. procedure TDataSet.CommitUpdates;
  6162. begin
  6163.   Check(ProcessUpdates(dbiDelayedUpdCommit));
  6164. end;
  6165.  
  6166. procedure TDataSet.CancelUpdates;
  6167. begin
  6168.   Cancel;
  6169.   ProcessUpdates(dbiDelayedUpdCancel);
  6170. end;
  6171.  
  6172. procedure TDataSet.RevertRecord;
  6173. var
  6174.   Status: DBIResult;
  6175. begin
  6176.   if State in dsEditModes then Cancel;
  6177.   Status := ProcessUpdates(dbiDelayedUpdCancelCurrent);
  6178.   if not ((Status = DBIERR_NONE) or (Status = DBIERR_NOTSUPPORTED)) then
  6179.     Check(Status);
  6180. end;
  6181.  
  6182. function TDataSet.UpdateStatus: TUpdateStatus;
  6183. var
  6184.   BufPtr: PChar;
  6185. begin
  6186.   CheckCachedUpdateMode;
  6187.   if FState = dsCalcFields then
  6188.     BufPtr := FCalcBuffer
  6189.   else
  6190.     BufPtr := ActiveBuffer;
  6191.   Result := PRecInfo(BufPtr + FRecInfoOfs).UpdateStatus;
  6192. end;
  6193.  
  6194. function TDataSet.CachedUpdateCallBack(CBInfo: Pointer): CBRType;
  6195. const
  6196.   CBRetCode: array[TUpdateAction] of CBRType = (cbrAbort, cbrAbort,
  6197.     cbrSkip, cbrRetry, cbrPartialAssist);
  6198. var
  6199.   UpdateAction: TUpdateAction;
  6200.   UpdateKind: TUpdateKind;
  6201. begin
  6202.   try
  6203.     Result := cbrUSEDEF;
  6204.     FInUpdateCallBack := True;
  6205.     UpdateAction := uaFail;
  6206.     UpdateKind := TUpdateKind(ord(FUpdateCBBuf.eDelayUpdOpType)-1);
  6207.     try
  6208.       if Assigned(FOnUpdateRecord) then
  6209.         FOnUpdateRecord(Self, UpdateKind, UpdateAction)
  6210.       else
  6211.         if Assigned(FUpdateObject) then
  6212.         begin
  6213.           FUpdateObject.Apply(UpdateKind);
  6214.           UpdateAction := uaApplied;
  6215.         end
  6216.       else
  6217.         DbiError(FUpdateCBBuf.iErrCode);
  6218.     except
  6219.       on E: EDatabaseError do
  6220.       begin
  6221.         if Assigned(FOnUpdateError) then
  6222.           FOnUpdateError(Self, E, UpdateKind, UpdateAction)
  6223.         else
  6224.         begin
  6225.           Application.HandleException(Self);
  6226.           UpdateAction := uaAbort;
  6227.         end;
  6228.       end;
  6229.     end;
  6230.     Result := CBRetCode[UpdateAction];
  6231.     if UpdateAction = uaAbort then FUpdateCBBuf.iErrCode := DBIERR_UPDATEABORT;
  6232.   except
  6233.     Application.HandleException(Self);
  6234.   end;
  6235.   FInUpdateCallBack := False;
  6236. end;
  6237.  
  6238. function TDataSet.GetUpdateRecordSet: TUpdateRecordTypes;
  6239. begin
  6240.   if Active then
  6241.   begin
  6242.     CheckCachedUpdateMode;
  6243.     Result := TUpdateRecordTypes(Byte(GetIntProp(FHandle, curDELAYUPDDISPLAYOPT)));
  6244.   end
  6245.   else
  6246.     Result := [];
  6247. end;
  6248.  
  6249. procedure TDataSet.SetUpdateRecordSet(RecordTypes: TUpdateRecordTypes);
  6250. begin
  6251.   CheckCachedUpdateMode;
  6252.   CheckBrowseMode;
  6253.   UpdateCursorPos;
  6254.   Check(DbiSetProp(hDbiObj(Handle), curDELAYUPDDISPLAYOPT, Longint(Byte(RecordTypes))));
  6255.   Resync([]);
  6256. end;
  6257.  
  6258. procedure TDataSet.SetUpdateObject(Value: TDataSetUpdateObject);
  6259. begin
  6260.   if Value <> FUpdateObject then
  6261.   begin
  6262.     if Assigned(FUpdateObject) and (FUpdateObject.DataSet = Self) then
  6263.       FUpdateObject.DataSet := nil;
  6264.     FUpdateObject := Value;
  6265.     if Assigned(FUpdateObject) then
  6266.     begin
  6267.       { If another dataset already references this updateobject, then
  6268.         remove the reference }
  6269.       if Assigned(FUpdateObject.DataSet) and
  6270.         (FUpdateObject.DataSet <> Self) then
  6271.         FUpdateObject.DataSet.UpdateObject := nil;
  6272.       FUpdateObject.DataSet := Self;
  6273.     end;
  6274.   end;
  6275. end;
  6276.  
  6277. procedure TDataSet.SetOnUpdateError(UpdateEvent: TUpdateErrorEvent);
  6278. begin
  6279.   if Active then SetupCallback(UpdateCallBackRequired);
  6280.   FOnUpdateError := UpdateEvent;
  6281. end;
  6282.  
  6283. function TDataSet.GetUpdatesPending: Boolean;
  6284. begin
  6285.   Result := GetIntProp(FHandle, curDELAYUPDNUMUPDATES) > 0;
  6286. end;
  6287.  
  6288. function TDataSet.CreateExprFilter(const Expr: string;
  6289.   Options: TFilterOptions; Priority: Integer): HDBIFilter;
  6290. var
  6291.   Parser: TExprParser;
  6292. begin
  6293.   Parser := TExprParser.Create(Self, Expr, Options);
  6294.   try
  6295.     Check(DbiAddFilter(FHandle, 0, Priority, False, Parser.FilterData,
  6296.       nil, Result));
  6297.   finally
  6298.     Parser.Free;
  6299.   end;
  6300. end;
  6301.  
  6302. function TDataSet.CreateFuncFilter(FilterFunc: Pointer;
  6303.   Priority: Integer): HDBIFilter;
  6304. begin
  6305.   Check(DbiAddFilter(FHandle, Integer(Self), Priority, False, nil,
  6306.     PFGENFilter(FilterFunc), Result));
  6307. end;
  6308.  
  6309. function TDataSet.CreateLookupFilter(Fields: TList; const Values: Variant;
  6310.   Options: TLocateOptions; Priority: Integer): HDBIFilter;
  6311. var
  6312.   I: Integer;
  6313.   Filter: TFilterExpr;
  6314.   Expr, Node: PExprNode;
  6315.   FilterOptions: TFilterOptions;
  6316. begin
  6317.   if loCaseInsensitive in Options then
  6318.     FilterOptions := [foNoPartialCompare, foCaseInsensitive] else
  6319.     FilterOptions := [foNoPartialCompare];
  6320.   Filter := TFilterExpr.Create(Self, FilterOptions);
  6321.   try
  6322.     if Fields.Count = 1 then
  6323.     begin
  6324.       Node := Filter.NewCompareNode(TField(Fields[0]), canEQ, Values);
  6325.       Expr := Node;
  6326.     end else
  6327.       for I := 0 to Fields.Count - 1 do
  6328.       begin
  6329.         Node := Filter.NewCompareNode(TField(Fields[I]), canEQ, Values[I]);
  6330.         if I = 0 then
  6331.           Expr := Node else
  6332.           Expr := Filter.NewNode(enOperator, canAND, Unassigned, Expr, Node);
  6333.       end;
  6334.     if loPartialKey in Options then Node^.FPartial := True;
  6335.     Check(DbiAddFilter(FHandle, 0, Priority, False,
  6336.       Filter.GetFilterData(Expr), nil, Result));
  6337.   finally
  6338.     Filter.Free;
  6339.   end;
  6340. end;
  6341.  
  6342. procedure TDataSet.SetFilterHandle(var Filter: HDBIFilter;
  6343.   Value: HDBIFilter);
  6344. begin
  6345.   if FFiltered then
  6346.   begin
  6347.     CursorPosChanged;
  6348.     DestroyLookupCursor;
  6349.     DbiSetToBegin(FHandle);
  6350.     if Filter <> nil then DbiDropFilter(FHandle, Filter);
  6351.     Filter := Value;
  6352.     if Filter <> nil then DbiActivateFilter(FHandle, Filter);
  6353.   end else
  6354.     Filter := Value;
  6355. end;
  6356.  
  6357. procedure TDataSet.SetFilterData(const Text: string; Options: TFilterOptions);
  6358. var
  6359.   Filter: HDBIFilter;
  6360. begin
  6361.   if Active then
  6362.   begin
  6363.     CheckBrowseMode;
  6364.     if (FFilterText <> Text) or (FFilterOptions <> Options) then
  6365.     begin
  6366.       if Text <> '' then
  6367.         Filter := CreateExprFilter(Text, Options, 0) else
  6368.         Filter := nil;
  6369.       SetFilterHandle(FExprFilter, Filter);
  6370.     end;
  6371.   end;
  6372.   FFilterText := Text;
  6373.   FFilterOptions := Options;
  6374.   if Active and FFiltered then First;
  6375. end;
  6376.  
  6377. procedure TDataSet.SetFilterText(const Value: string);
  6378. begin
  6379.   SetFilterData(Value, FFilterOptions);
  6380. end;
  6381.  
  6382. procedure TDataSet.SetFilterOptions(Value: TFilterOptions);
  6383. begin
  6384.   SetFilterData(FFilterText, Value);
  6385. end;
  6386.  
  6387. procedure TDataSet.SetOnFilterRecord(const Value: TFilterRecordEvent);
  6388. var
  6389.   Filter: HDBIFilter;
  6390. begin
  6391.   if Active then
  6392.   begin
  6393.     CheckBrowseMode;
  6394.     if Assigned(FOnFilterRecord) <> Assigned(Value) then
  6395.     begin
  6396.       if Assigned(Value) then
  6397.         Filter := CreateFuncFilter(@TDataSet.RecordFilter, 1) else
  6398.         Filter := nil;
  6399.       SetFilterHandle(FFuncFilter, Filter);
  6400.     end;
  6401.     FOnFilterRecord := Value;
  6402.     if FFiltered then First;
  6403.   end else
  6404.     FOnFilterRecord := Value;
  6405. end;
  6406.  
  6407. procedure TDataSet.SetFiltered(Value: Boolean);
  6408. begin
  6409.   if Active then
  6410.   begin
  6411.     CheckBrowseMode;
  6412.     if FFiltered <> Value then
  6413.     begin
  6414.       DestroyLookupCursor;
  6415.       DbiSetToBegin(FHandle);
  6416.       if Value then ActivateFilters else DeactivateFilters;
  6417.       FFiltered := Value;
  6418.     end;
  6419.     First;
  6420.   end else
  6421.     FFiltered := Value;
  6422. end;
  6423.  
  6424. function TDataSet.FindRecord(Restart, GoForward: Boolean): Boolean;
  6425. var
  6426.   Status: DBIResult;
  6427. begin
  6428.   CheckBrowseMode;
  6429.   FFound := False;
  6430.   UpdateCursorPos;
  6431.   CursorPosChanged;
  6432.   if not FFiltered then ActivateFilters;
  6433.   try
  6434.     if GoForward then
  6435.     begin
  6436.       if Restart then Check(DbiSetToBegin(FHandle));
  6437.       Status := DbiGetNextRecord(FHandle, dbiNoLock, nil, nil);
  6438.     end else
  6439.     begin
  6440.       if Restart then Check(DbiSetToEnd(FHandle));
  6441.       Status := DbiGetPriorRecord(FHandle, dbiNoLock, nil, nil);
  6442.     end;
  6443.   finally
  6444.     if not FFiltered then DeactivateFilters;
  6445.   end;
  6446.   if Status = DBIERR_NONE then
  6447.   begin
  6448.     Resync([rmExact, rmCenter]);
  6449.     FFound := True;
  6450.   end;
  6451.   Result := FFound;
  6452. end;
  6453.  
  6454. function TDataSet.FindFirst: Boolean;
  6455. begin
  6456.   Result := FindRecord(True, True);
  6457. end;
  6458.  
  6459. function TDataSet.FindLast: Boolean;
  6460. begin
  6461.   Result := FindRecord(True, False);
  6462. end;
  6463.  
  6464. function TDataSet.FindNext: Boolean;
  6465. begin
  6466.   Result := FindRecord(False, True);
  6467. end;
  6468.  
  6469. function TDataSet.FindPrior: Boolean;
  6470. begin
  6471.   Result := FindRecord(False, False);
  6472. end;
  6473.  
  6474. function TDataSet.RecordFilter(RecBuf: Pointer; RecNo: Integer): Smallint;
  6475. var
  6476.   SaveState: TDataSetState;
  6477.   Accept: Boolean;
  6478. begin
  6479.   SaveState := FState;
  6480.   FState := dsFilter;
  6481.   FFilterBuffer := RecBuf;
  6482.   try
  6483.     Accept := True;
  6484.     FOnFilterRecord(Self, Accept);
  6485.   except
  6486.     Application.HandleException(Self);
  6487.   end;
  6488.   FState := SaveState;
  6489.   Result := Ord(Accept);
  6490. end;
  6491.  
  6492. procedure TDataSet.GetFieldList(List: TList; const FieldNames: string);
  6493. var
  6494.   Pos: Integer;
  6495. begin
  6496.   Pos := 1;
  6497.   while Pos <= Length(FieldNames) do
  6498.     List.Add(FieldByName(ExtractFieldName(FieldNames, Pos)));
  6499. end;
  6500.  
  6501. function TDataSet.MapsToIndex(Fields: TList;
  6502.   CaseInsensitive: Boolean): Boolean;
  6503. var
  6504.   I: Integer;
  6505. begin
  6506.   Result := False;
  6507.   if CaseInsensitive and not FCaseInsIndex then Exit;
  6508.   if Fields.Count > FIndexFieldCount then Exit;
  6509.   for I := 0 to Fields.Count - 1 do
  6510.     if TField(Fields[I]).FieldNo <> FIndexFieldMap[I] then Exit;
  6511.   Result := True;
  6512. end;
  6513.  
  6514. function TDataSet.LocateRecord(const KeyFields: string;
  6515.   const KeyValues: Variant; Options: TLocateOptions;
  6516.   SyncCursor: Boolean): Boolean;
  6517. var
  6518.   I, FieldCount, PartialLength: Integer;
  6519.   Buffer: PChar;
  6520.   Fields: TList;
  6521.   LookupCursor: HDBICur;
  6522.   Filter: HDBIFilter;
  6523.   Status: DBIResult;
  6524.   CaseInsensitive: Boolean;
  6525. begin
  6526.   CheckBrowseMode;
  6527.   CursorPosChanged;
  6528.   Buffer := FBuffers^[FRecordCount];
  6529.   Fields := TList.Create;
  6530.   try
  6531.     GetFieldList(Fields, KeyFields);
  6532.     CaseInsensitive := loCaseInsensitive in Options;
  6533.     if CachedUpdates then
  6534.       LookupCursor := nil
  6535.     else
  6536.       if MapsToIndex(Fields, CaseInsensitive) then
  6537.         LookupCursor := FHandle else
  6538.         LookupCursor := GetLookupCursor(KeyFields, CaseInsensitive);
  6539.     if (LookupCursor <> nil) then
  6540.     begin
  6541.       FState := dsFilter;
  6542.       FFilterBuffer := Buffer;
  6543.       try
  6544.         DbiInitRecord(FHandle, Buffer);
  6545.         FieldCount := Fields.Count;
  6546.         if FieldCount = 1 then
  6547.           TField(Fields.First).Value := KeyValues
  6548.         else
  6549.           for I := 0 to FieldCount - 1 do
  6550.             TField(Fields[I]).Value := KeyValues[I];
  6551.         PartialLength := 0;
  6552.         if (loPartialKey in Options) and
  6553.           (TField(Fields.Last).DataType = ftString) then
  6554.         begin
  6555.           Dec(FieldCount);
  6556.           PartialLength := Length(TField(Fields.Last).AsString);
  6557.         end;
  6558.         Status := DbiGetRecordForKey(LookupCursor, False, FieldCount,
  6559.           PartialLength, Buffer, Buffer);
  6560.       finally
  6561.         FState := dsBrowse;
  6562.       end;
  6563.       if (Status = DBIERR_NONE) and SyncCursor and
  6564.         (LookupCursor <> FHandle) then
  6565.         Check(DbiSetToCursor(FHandle, LookupCursor));
  6566.     end else
  6567.     begin
  6568.       Check(DbiSetToBegin(FHandle));
  6569.       Filter := CreateLookupFilter(Fields, KeyValues, Options, 2);
  6570.       DbiActivateFilter(FHandle, Filter);
  6571.       Status := DbiGetNextRecord(FHandle, dbiNoLock, Buffer, nil);
  6572.       DbiDropFilter(FHandle, Filter);
  6573.     end;
  6574.   finally
  6575.     Fields.Free;
  6576.   end;
  6577.   Result := Status = DBIERR_NONE;
  6578. end;
  6579.  
  6580. function TDataSet.Lookup(const KeyFields: string; const KeyValues: Variant;
  6581.   const ResultFields: string): Variant;
  6582. begin
  6583.   Result := Null;
  6584.   if LocateRecord(KeyFields, KeyValues, [], False) then
  6585.   begin
  6586.     FState := dsCalcFields;
  6587.     try
  6588.       FCalcBuffer := FBuffers^[FRecordCount];
  6589.       FillChar(FCalcBuffer[FRecordSize], FCalcFieldsSize, 0);
  6590.       CalculateFields;
  6591.       Result := FieldValues[ResultFields];
  6592.     finally
  6593.       FState := dsBrowse;
  6594.     end;
  6595.   end;
  6596. end;
  6597.  
  6598. function TDataSet.Locate(const KeyFields: string;
  6599.   const KeyValues: Variant; Options: TLocateOptions): Boolean;
  6600. begin
  6601.   Result := LocateRecord(KeyFields, KeyValues, Options, True);
  6602.   if Result then Resync([rmExact, rmCenter]);
  6603. end;
  6604.  
  6605. function TDataSet.GetLookupCursor(const KeyFields: string;
  6606.   CaseInsensitive: Boolean): HDBICur;
  6607. begin
  6608.   Result := nil;
  6609. end;
  6610.  
  6611. procedure TDataSet.DestroyLookupCursor;
  6612. begin
  6613. end;
  6614.  
  6615. procedure TDataSet.DoAfterCancel;
  6616. begin
  6617.   if Assigned(FAfterCancel) then FAfterCancel(Self);
  6618. end;
  6619.  
  6620. procedure TDataSet.DoAfterClose;
  6621. begin
  6622.   if Assigned(FAfterClose) then FAfterClose(Self);
  6623. end;
  6624.  
  6625. procedure TDataSet.DoAfterDelete;
  6626. begin
  6627.   if Assigned(FAfterDelete) then FAfterDelete(Self);
  6628. end;
  6629.  
  6630. procedure TDataSet.DoAfterEdit;
  6631. begin
  6632.   if Assigned(FAfterEdit) then FAfterEdit(Self);
  6633. end;
  6634.  
  6635. procedure TDataSet.DoAfterInsert;
  6636. begin
  6637.   if Assigned(FAfterInsert) then FAfterInsert(Self);
  6638. end;
  6639.  
  6640. procedure TDataSet.DoAfterOpen;
  6641. begin
  6642.   if Assigned(FAfterOpen) then FAfterOpen(Self);
  6643. end;
  6644.  
  6645. procedure TDataSet.DoAfterPost;
  6646. begin
  6647.   if Assigned(FAfterPost) then FAfterPost(Self);
  6648. end;
  6649.  
  6650. procedure TDataSet.DoBeforeCancel;
  6651. begin
  6652.   if Assigned(FBeforeCancel) then FBeforeCancel(Self);
  6653. end;
  6654.  
  6655. procedure TDataSet.DoBeforeClose;
  6656. begin
  6657.   if Assigned(FBeforeClose) then FBeforeClose(Self);
  6658. end;
  6659.  
  6660. procedure TDataSet.DoBeforeDelete;
  6661. begin
  6662.   if Assigned(FBeforeDelete) then FBeforeDelete(Self);
  6663. end;
  6664.  
  6665. procedure TDataSet.DoBeforeEdit;
  6666. begin
  6667.   if Assigned(FBeforeEdit) then FBeforeEdit(Self);
  6668. end;
  6669.  
  6670. procedure TDataSet.DoBeforeInsert;
  6671. begin
  6672.   if Assigned(FBeforeInsert) then FBeforeInsert(Self);
  6673. end;
  6674.  
  6675. procedure TDataSet.DoBeforeOpen;
  6676. begin
  6677.   if Assigned(FBeforeOpen) then FBeforeOpen(Self);
  6678. end;
  6679.  
  6680. procedure TDataSet.DoBeforePost;
  6681. begin
  6682.   if Assigned(FBeforePost) then FBeforePost(Self);
  6683. end;
  6684.  
  6685. procedure TDataSet.DoOnCalcFields;
  6686. begin
  6687.   if Assigned(FOnCalcFields) then FOnCalcFields(Self);
  6688. end;
  6689.  
  6690. procedure TDataSet.DoOnNewRecord;
  6691. begin
  6692.   if Assigned(FOnNewRecord) then FOnNewRecord(Self);
  6693. end;
  6694.  
  6695. function TDataSet.YieldCallBack(CBInfo: Pointer): CBRType;
  6696. var
  6697.   AbortQuery: Boolean;
  6698. begin
  6699.   AbortQuery := False;
  6700.   if Assigned(OnServerYield) and (FCBYieldStep <> cbYieldLast) then
  6701.     OnServerYield(Self, AbortQuery);
  6702.   if AbortQuery then
  6703.     Result := cbrABORT else
  6704.     Result := cbrUSEDEF;
  6705. end;
  6706.  
  6707. { TDBDataSet }
  6708.  
  6709. procedure TDBDataSet.OpenCursor;
  6710. begin
  6711.   SetDBFlag(dbfOpened, True);
  6712.   inherited OpenCursor;
  6713.   SetUpdateMode(FUpdateMode);
  6714. end;
  6715.  
  6716. procedure TDBDataSet.CloseCursor;
  6717. begin
  6718.   inherited CloseCursor;
  6719.   SetDBFlag(dbfOpened, False);
  6720. end;
  6721.  
  6722. procedure TDBDataSet.CheckDBSessionName;
  6723. var
  6724.   S: TSession;
  6725.   Database: TDatabase;
  6726. begin
  6727.   if (SessionName <> '') and (DatabaseName <> '') then
  6728.   begin
  6729.     S := Sessions.FindSession(SessionName);
  6730.     if Assigned(S) and not Assigned(S.FindDatabase(DatabaseName)) then
  6731.     begin
  6732.       Database := DB.Session.FindDatabase(DatabaseName);
  6733.       if Assigned(Database) then Database.CheckSessionName(True);
  6734.     end;
  6735.   end;
  6736. end;
  6737.  
  6738. function TDBDataSet.CheckOpen(Status: DBIResult): Boolean;
  6739. begin
  6740.   case Status of
  6741.     DBIERR_NONE:
  6742.       Result := True;
  6743.     DBIERR_NOTSUFFTABLERIGHTS:
  6744.       begin
  6745.         if not FDatabase.Session.GetPassword then DbiError(Status);
  6746.         Result := False;
  6747.       end;
  6748.   else
  6749.     DbiError(Status);
  6750.   end;
  6751. end;
  6752.  
  6753. procedure TDBDataSet.Disconnect;
  6754. begin
  6755.   Close;
  6756. end;
  6757.  
  6758. function TDBDataSet.GetDBFlag(Flag: Integer): Boolean;
  6759. begin
  6760.   Result := Flag in FDBFlags;
  6761. end;
  6762.  
  6763. procedure TDBDataSet.SetDBFlag(Flag: Integer; Value: Boolean);
  6764. begin
  6765.   if Value then
  6766.   begin
  6767.     if not (Flag in FDBFlags) then
  6768.     begin
  6769.       if FDBFlags = [] then
  6770.       begin
  6771.         CheckDBSessionName;
  6772.         FDatabase := Sessions.List[SessionName].OpenDatabase(FDatabaseName);
  6773.         FDatabase.FDataSets.Add(Self);
  6774.         SetLocale(FDatabase.Locale);
  6775.       end;
  6776.       Include(FDBFlags, Flag);
  6777.     end;
  6778.   end else
  6779.   begin
  6780.     if Flag in FDBFlags then
  6781.     begin
  6782.       Exclude(FDBFlags, Flag);
  6783.       if FDBFlags = [] then
  6784.       begin
  6785.         SetLocale(DBLocale);
  6786.         FDatabase.FDataSets.Remove(Self);
  6787.         FDatabase.Session.CloseDatabase(FDatabase);
  6788.         FDatabase := nil;
  6789.       end;
  6790.     end;
  6791.   end;
  6792. end;
  6793.  
  6794. function TDBDataSet.GetDBHandle: HDBIDB;
  6795. begin
  6796.   if FDatabase <> nil then
  6797.     Result := FDatabase.Handle else
  6798.     Result := nil;
  6799. end;
  6800.  
  6801. function TDBDataSet.GetDBLocale: TLocale;
  6802. begin
  6803.   if Database <> nil then
  6804.     Result := Database.Locale else
  6805.     Result := nil;
  6806. end;
  6807.  
  6808. function TDBDataSet.GetDBSession: TSession;
  6809. begin
  6810.   if (FDatabase <> nil) then
  6811.     Result := FDatabase.Session else
  6812.     Result := Sessions.FindSession(SessionName);
  6813.   if Result = nil then Result := DB.Session;
  6814. end;
  6815.  
  6816. procedure TDBDataSet.SetDatabaseName(const Value: string);
  6817. begin
  6818.   if FDatabaseName <> Value then
  6819.   begin
  6820.     CheckInactive;
  6821.     if FDatabase <> nil then DBError(SDatabaseOpen);
  6822.     FDatabaseName := Value;
  6823.     DataEvent(dePropertyChange, 0);
  6824.   end;
  6825. end;
  6826.  
  6827. procedure TDBDataSet.SetSessionName(const Value: string);
  6828. begin
  6829.   CheckInactive;
  6830.   FSessionName := Value;
  6831.   DataEvent(dePropertyChange, 0);
  6832. end;
  6833.  
  6834. procedure TDBDataSet.SetUpdateMode(const Value: TUpdateMode);
  6835. begin
  6836.   if (FHandle <> nil) and Database.IsSQLBased and CanModify then
  6837.     Check(DbiSetProp(hDbiObj(FHandle), curUPDLOCKMODE, Longint(Value)));
  6838.   FUpdateMode := Value;
  6839. end;
  6840.  
  6841. { TField }
  6842.  
  6843. constructor TField.Create(AOwner: TComponent);
  6844. begin
  6845.   inherited Create(AOwner);
  6846.   FVisible := True;
  6847. end;
  6848.  
  6849. destructor TField.Destroy;
  6850. begin
  6851.   if FDataSet <> nil then
  6852.   begin
  6853.     FDataSet.Close;
  6854.     FDataSet.RemoveField(Self);
  6855.   end;
  6856.   inherited Destroy;
  6857. end;
  6858.  
  6859. procedure TField.AccessError(const TypeName: string);
  6860. begin
  6861.   DBErrorFmt(SFieldAccessError, [DisplayName, TypeName]);
  6862. end;
  6863.  
  6864. procedure TField.Assign(Source: TPersistent);
  6865. begin
  6866.   if Source = nil then
  6867.   begin
  6868.     Clear;
  6869.     Exit;
  6870.   end;
  6871.   if Source is TField then
  6872.   begin
  6873.     Value := TField(Source).Value;
  6874.     Exit;
  6875.   end;
  6876.   inherited Assign(Source);
  6877. end;
  6878.  
  6879. procedure TField.AssignValue(const Value: TVarRec);
  6880.  
  6881.   procedure Error;
  6882.   begin
  6883.     DBErrorFmt(SFieldValueError, [DisplayName]);
  6884.   end;
  6885.  
  6886. begin
  6887.   with Value do
  6888.     case VType of
  6889.       vtInteger:
  6890.         AsInteger := VInteger;
  6891.       vtBoolean:
  6892.         AsBoolean := VBoolean;
  6893.       vtChar:
  6894.         AsString := VChar;
  6895.       vtExtended:
  6896.         AsFloat := VExtended^;
  6897.       vtString:
  6898.         AsString := VString^;
  6899.       vtPointer:
  6900.         if VPointer <> nil then Error;
  6901.       vtPChar:
  6902.         AsString := VPChar;
  6903.       vtObject:
  6904.         if (VObject = nil) or (VObject is TPersistent) then
  6905.           Assign(TPersistent(VObject))
  6906.         else
  6907.           Error;
  6908.       vtAnsiString:
  6909.         AsString := string(VAnsiString);
  6910.       vtCurrency:
  6911.         AsCurrency := VCurrency^;
  6912.       vtVariant:
  6913.         if not VarIsEmpty(VVariant^) then AsVariant := VVariant^;
  6914.     else
  6915.       Error;
  6916.     end;
  6917. end;
  6918.  
  6919. procedure TField.Bind(Binding: Boolean);
  6920. begin
  6921.   if FFieldKind = fkLookup then
  6922.     if Binding then
  6923.     begin
  6924.       if (FLookupDataSet = nil) or (FKeyFields = '') or
  6925.         (FLookupKeyFields = '') or (FLookupResultField = '') then
  6926.         DBErrorFmt(SLookupInfoError, [DisplayName]);
  6927.       FDataSet.CheckFieldNames(FKeyFields);
  6928.       FLookupDataSet.Open;
  6929.       FLookupDataSet.CheckFieldNames(FLookupKeyFields);
  6930.       FLookupDataSet.FieldByName(FLookupResultField);
  6931.     end;
  6932. end;
  6933.  
  6934. procedure TField.CalcLookupValue;
  6935. begin
  6936.   if (FLookupDataSet <> nil) and FLookupDataSet.Active then
  6937.     Value := FLookupDataSet.Lookup(FLookupKeyFields,
  6938.       FDataSet.FieldValues[FKeyFields], FLookupResultField);
  6939. end;
  6940.  
  6941. procedure TField.Change;
  6942. begin
  6943.   if Assigned(FOnChange) then FOnChange(Self);
  6944. end;
  6945.  
  6946. procedure TField.CheckInactive;
  6947. begin
  6948.   if FDataSet <> nil then FDataSet.CheckInactive;
  6949. end;
  6950.  
  6951. procedure TField.Clear;
  6952. begin
  6953.   SetData(nil);
  6954. end;
  6955.  
  6956. procedure TField.DataChanged;
  6957. begin
  6958.   FDataSet.DataEvent(deFieldChange, Longint(Self));
  6959. end;
  6960.  
  6961. procedure TField.DefineProperties(Filer: TFiler);
  6962.  
  6963.   function DoWrite: Boolean;
  6964.   begin
  6965.     if Assigned(Filer.Ancestor) then
  6966.       Result := CompareText(FAttributeSet, TField(Filer.Ancestor).FAttributeSet) <> 0
  6967.     else
  6968.       Result := FAttributeSet <> '';
  6969.   end;
  6970.  
  6971. begin
  6972.   Filer.DefineProperty('AttributeSet', ReadAttributeSet, WriteAttributeSet,
  6973.     DoWrite);
  6974. end;
  6975.  
  6976. procedure TField.FocusControl;
  6977. var
  6978.   Field: TField;
  6979. begin
  6980.   if (FDataSet <> nil) and FDataSet.Active then
  6981.   begin
  6982.     Field := Self;
  6983.     FDataSet.DataEvent(deFocusControl, Longint(@Field));
  6984.   end;
  6985. end;
  6986.  
  6987. procedure TField.FreeBuffers;
  6988. begin
  6989. end;
  6990.  
  6991. function TField.GetAsBoolean: Boolean;
  6992. begin
  6993.   AccessError('Boolean');
  6994. end;
  6995.  
  6996. function TField.GetAsCurrency: Currency;
  6997. begin
  6998.   Result := GetAsFloat;
  6999. end;
  7000.  
  7001. function TField.GetAsDateTime: TDateTime;
  7002. begin
  7003.   AccessError('DateTime');
  7004. end;
  7005.  
  7006. function TField.GetAsFloat: Double;
  7007. begin
  7008.   AccessError('Float');
  7009. end;
  7010.  
  7011. function TField.GetAsInteger: Longint;
  7012. begin
  7013.   AccessError('Integer');
  7014. end;
  7015.  
  7016. function TField.GetAsString: string;
  7017. var
  7018.   I, L: Integer;
  7019.   S: string[63];
  7020. begin
  7021.   S := ClassName;
  7022.   I := 1;
  7023.   L := Length(S);
  7024.   if S[1] = 'T' then I := 2;
  7025.   if (L >= 5) and (CompareText(Copy(S, L - 4, 5), 'FIELD') = 0) then Dec(L, 5);
  7026.   FmtStr(Result, '(%s)', [Copy(S, I, L + 1 - I)]);
  7027. end;
  7028.  
  7029. function TField.GetAsVariant: Variant;
  7030. begin
  7031.   AccessError('Variant');
  7032. end;
  7033.  
  7034. function TField.GetCalculated: Boolean;
  7035. begin
  7036.   Result := FFieldKind = fkCalculated;
  7037. end;
  7038.  
  7039. function TField.GetBDECalcField: Boolean;
  7040. begin
  7041.   if FieldNo >= 0 then
  7042.     Result := DataSet.FieldDefs.Find(FieldName).BDECalcField
  7043.   else Result := False;
  7044. end;
  7045.  
  7046. function TField.GetCanModify: Boolean;
  7047. begin
  7048.   if FieldNo > 0 then
  7049.     if DataSet.State <> dsSetKey then
  7050.       Result := not ReadOnly and DataSet.CanModify
  7051.     else
  7052.       Result := (DataSet.FIndexFieldCount = 0) or IsIndexField
  7053.   else
  7054.     Result := False;
  7055. end;
  7056.  
  7057. function TField.GetData(Buffer: Pointer): Boolean;
  7058. var
  7059.   IsBlank: LongBool;
  7060.   RecBuf: PChar;
  7061. begin
  7062.   if FDataSet = nil then DBErrorFmt(SDataSetMissing, [DisplayName]);
  7063.   Result := False;
  7064.   with FDataSet do
  7065.   begin
  7066.     case State of
  7067.       dsSetKey: RecBuf := PChar(FKeyBuffer) + SizeOf(TKeyBuffer);
  7068.       dsCalcFields: RecBuf := FCalcBuffer;
  7069.       dsUpdateNew: RecBuf := FUpdateCBBuf.pNewRecBuf;
  7070.       dsUpdateOld: RecBuf := FUpdateCBBuf.pOldRecBuf;
  7071.       dsFilter: RecBuf := FFilterBuffer;
  7072.     else
  7073.       if FActiveRecord >= FRecordCount then Exit;
  7074.       RecBuf := FBuffers^[FActiveRecord];
  7075.     end;
  7076.     if FieldNo > 0 then
  7077.       if FValidating then
  7078.       begin
  7079.         Result := LongBool(FValueBuffer);
  7080.         if Result and (Buffer <> nil) then
  7081.           Move(FValueBuffer^, Buffer^, DataSize);
  7082.       end else
  7083.       begin
  7084.         Check(DbiGetField(FHandle, FieldNo, RecBuf, Buffer, IsBlank));
  7085.         Result := not IsBlank;
  7086.       end
  7087.     else
  7088.       if (FieldNo < 0) and (State <> dsSetKey) then
  7089.       begin
  7090.         Inc(RecBuf, FRecordSize + FOffset);
  7091.         Result := Boolean(RecBuf[0]);
  7092.         if Result and (Buffer <> nil) then
  7093.           Move(RecBuf[1], Buffer^, DataSize);
  7094.       end;
  7095.   end;
  7096. end;
  7097.  
  7098. function TField.GetDefaultWidth: Integer;
  7099. begin
  7100.   Result := 10;
  7101. end;
  7102.  
  7103. function TField.GetDisplayLabel: string;
  7104. begin
  7105.   Result := GetDisplayName;
  7106. end;
  7107.  
  7108. function TField.GetDisplayName: string;
  7109. begin
  7110.   if FDisplayLabel <> '' then
  7111.     Result := FDisplayLabel else
  7112.     Result := FFieldName;
  7113. end;
  7114.  
  7115. function TField.GetDisplayText: string;
  7116. begin
  7117.   Result := '';
  7118.   if Assigned(FOnGetText) then
  7119.     FOnGetText(Self, Result, True) else
  7120.     GetText(Result, True);
  7121. end;
  7122.  
  7123. function TField.GetDisplayWidth: Integer;
  7124. begin
  7125.   if FDisplayWidth > 0 then
  7126.     Result := FDisplayWidth else
  7127.     Result := GetDefaultWidth;
  7128. end;
  7129.  
  7130. function TField.GetEditText: string;
  7131. begin
  7132.   Result := '';
  7133.   if Assigned(FOnGetText) then
  7134.     FOnGetText(Self, Result, False) else
  7135.     GetText(Result, False);
  7136. end;
  7137.  
  7138. function TField.GetIndex: Integer;
  7139. begin
  7140.   if FDataSet <> nil then
  7141.     Result := FDataSet.FFields.IndexOf(Self) else
  7142.     Result := -1;
  7143. end;
  7144.  
  7145. function TField.GetIsIndexField: Boolean;
  7146. var
  7147.   I: Integer;
  7148. begin
  7149.   Result := False;
  7150.   if FFieldNo > 0 then
  7151.     for I := 0 to FDataSet.FIndexFieldCount - 1 do
  7152.       if FDataSet.FIndexFieldMap[I] = FFieldNo then
  7153.       begin
  7154.         Result := True;
  7155.         Exit;
  7156.       end;
  7157. end;
  7158.  
  7159. function TField.GetIsNull: Boolean;
  7160. begin
  7161.   Result := not GetData(nil);
  7162. end;
  7163.  
  7164. function TField.GetLookup: Boolean;
  7165. begin
  7166.   Result := FFieldKind = fkLookup;
  7167. end;
  7168.  
  7169. procedure TField.GetText(var Text: string; DisplayText: Boolean);
  7170. begin
  7171.   Text := GetAsString;
  7172. end;
  7173.  
  7174. function TField.HasParent: Boolean;
  7175. begin
  7176.   HasParent := True;
  7177. end;
  7178.  
  7179. function TField.GetNewValue: Variant;
  7180. begin
  7181.   FDataSet.CheckCachedUpdateMode;
  7182.   if FDataSet.FInUpdateCallBack then
  7183.     Result := GetUpdateValue(dsUpdateNew)
  7184.   else
  7185.     Result := Value;
  7186. end;
  7187.  
  7188. function TField.GetOldValue: Variant;
  7189. begin
  7190.   with FDataSet do
  7191.   begin
  7192.     CheckCachedUpdateMode;
  7193.     if FInUpdateCallBack and not (Self is TBlobField) then
  7194.       Result := GetUpdateValue(dsUpdateOld)
  7195.     else
  7196.     begin
  7197.       UpdateCursorPos;
  7198.       Check(DbiSetProp(hDbiObj(Handle), curDELAYUPDGETOLDRECORD, Longint(True)));
  7199.       try
  7200.         Check(DbiGetRecord(FHandle, dbiNoLock, FUpdateCBBuf.pOldRecBuf, nil));
  7201.         Result := GetUpdateValue(dsUpdateOld);
  7202.       finally
  7203.         DbiSetProp(hDbiObj(Handle), curDELAYUPDGETOLDRECORD, Longint(False));
  7204.       end;
  7205.     end;
  7206.   end;
  7207. end;
  7208.  
  7209. function TField.GetUpdateValue(ValueState: TDataSetState): Variant;
  7210. var
  7211.   SaveState: TDataSetState;
  7212. begin
  7213.   if FieldKind <> fkData then
  7214.     DBErrorFmt(SOldNewNonData, [FieldName]);
  7215.   SaveState := FDataset.FState;
  7216.   FDataSet.FState := ValueState;
  7217.   try
  7218.     Result := GetAsVariant;
  7219.   finally
  7220.     FDataSet.FState := SaveState;
  7221.   end;
  7222. end;
  7223.  
  7224. function TField.GetParentComponent: TComponent;
  7225. begin
  7226.   Result := DataSet;
  7227. end;
  7228.  
  7229. procedure TField.SetParentComponent(AParent: TComponent);
  7230. begin
  7231.   if not (csLoading in ComponentState) then DataSet := AParent as TDataSet;
  7232. end;
  7233.  
  7234. function TField.IsValidChar(InputChar: Char): Boolean;
  7235. begin
  7236.   Result := True;
  7237. end;
  7238.  
  7239. function TField.IsDisplayLabelStored: Boolean;
  7240. begin
  7241.   Result := FDisplayLabel <> '';
  7242. end;
  7243.  
  7244. function TField.IsDisplayWidthStored: Boolean;
  7245. begin
  7246.   Result := FDisplayWidth > 0;
  7247. end;
  7248.  
  7249. procedure TField.Notification(AComponent: TComponent;
  7250.   Operation: TOperation);
  7251. begin
  7252.   inherited Notification(AComponent, Operation);
  7253.   if (Operation = opRemove) and (AComponent = FLookupDataSet) then
  7254.     FLookupDataSet := nil;
  7255. end;
  7256.  
  7257. procedure TField.PropertyChanged(LayoutAffected: Boolean);
  7258. const
  7259.   Events: array[Boolean] of TDataEvent = (deDataSetChange, deLayoutChange);
  7260. begin
  7261.   if (FDataSet <> nil) and FDataSet.Active then
  7262.     FDataSet.DataEvent(Events[LayoutAffected], 0);
  7263. end;
  7264.  
  7265. procedure TField.ReadAttributeSet(Reader: TReader);
  7266. begin
  7267.   FAttributeSet := Reader.ReadString;
  7268. end;
  7269.  
  7270. procedure TField.ReadState(Reader: TReader);
  7271. begin
  7272.   inherited ReadState(Reader);
  7273.   if Reader.Parent is TDataSet then DataSet := TDataSet(Reader.Parent);
  7274. end;
  7275.  
  7276. procedure TField.SetAsBoolean(Value: Boolean);
  7277. begin
  7278.   AccessError('Boolean');
  7279. end;
  7280.  
  7281. procedure TField.SetAsCurrency(Value: Currency);
  7282. begin
  7283.   SetAsFloat(Value);
  7284. end;
  7285.  
  7286. procedure TField.SetAsDateTime(Value: TDateTime);
  7287. begin
  7288.   AccessError('DateTime');
  7289. end;
  7290.  
  7291. procedure TField.SetAsFloat(Value: Double);
  7292. begin
  7293.   AccessError('Float');
  7294. end;
  7295.  
  7296. procedure TField.SetAsInteger(Value: Longint);
  7297. begin
  7298.   AccessError('Integer');
  7299. end;
  7300.  
  7301. procedure TField.SetAsString(const Value: string);
  7302. begin
  7303.   AccessError('String');
  7304. end;
  7305.  
  7306. procedure TField.SetAsVariant(const Value: Variant);
  7307. begin
  7308.   if TVarData(Value).VType = varNull then
  7309.     Clear
  7310.   else
  7311.     try
  7312.       SetVarValue(Value);
  7313.     except
  7314.       on EVariantError do DBErrorFmt(SFieldValueError, [DisplayName]);
  7315.     end;
  7316. end;
  7317.  
  7318. procedure TField.SetAlignment(Value: TAlignment);
  7319. begin
  7320.   if FAlignment <> Value then
  7321.   begin
  7322.     FAlignment := Value;
  7323.     PropertyChanged(False);
  7324.   end;
  7325. end;
  7326.  
  7327. procedure TField.SetCalculated(Value: Boolean);
  7328. begin
  7329.   if Value then
  7330.     FieldKind := fkCalculated
  7331.   else if not Lookup then FieldKind := fkData;
  7332. end;
  7333.  
  7334. procedure TField.SetData(Buffer: Pointer);
  7335. var
  7336.   RecBuf: PChar;
  7337. begin
  7338.   if FDataSet = nil then DBErrorFmt(SDataSetMissing, [DisplayName]);
  7339.   with FDataSet do
  7340.   begin
  7341.     case State of
  7342.       dsEdit, dsInsert: RecBuf := FBuffers^[FActiveRecord];
  7343.       dsSetKey:
  7344.         begin
  7345.           RecBuf := PChar(FKeyBuffer) + SizeOf(TKeyBuffer);
  7346.           if (FieldNo < 0) or (FIndexFieldCount > 0) and not IsIndexField then
  7347.             DBErrorFmt(SNotIndexField, [DisplayName]);
  7348.         end;
  7349.       dsCalcFields: RecBuf := FCalcBuffer;
  7350.       dsUpdateNew: RecBuf := FUpdateCBBuf.pNewRecBuf;
  7351.       dsUpdateOld: DBError(SNoOldValueUpdate);
  7352.       dsFilter: RecBuf := FFilterBuffer;
  7353.     else
  7354.       DBError(SNotEditing);
  7355.     end;
  7356.     if FieldNo > 0 then
  7357.     begin
  7358.       if (State <> dsSetKey) and (State <> dsFilter) and ReadOnly then
  7359.         DBErrorFmt(SFieldReadOnly, [DisplayName]);
  7360.       if State = dsCalcFields then DBError(SNotEditing);
  7361.       if Assigned(FOnValidate) then
  7362.       begin
  7363.         FValueBuffer := Buffer;
  7364.         FValidating := True;
  7365.         try
  7366.           FOnValidate(Self);
  7367.         finally
  7368.           FValidating := False;
  7369.         end;
  7370.       end;
  7371.       if not BDECalcField then
  7372.         Check(DbiPutField(FHandle, FieldNo, RecBuf, Buffer));
  7373.     end else
  7374.     begin
  7375.       Inc(RecBuf, FRecordSize + FOffset);
  7376.       Boolean(RecBuf[0]) := LongBool(Buffer);
  7377.       if Boolean(RecBuf[0]) then Move(Buffer^, RecBuf[1], DataSize);
  7378.     end;
  7379.     if (State <> dsCalcFields) and (State <> dsFilter) then
  7380.       DataEvent(deFieldChange, Longint(Self));
  7381.   end;
  7382. end;
  7383.  
  7384. procedure TField.SetDataSet(ADataSet: TDataSet);
  7385. begin
  7386.   if ADataset <> FDataset then
  7387.   begin
  7388.     if FDataSet <> nil then FDataSet.CheckInactive;
  7389.     if ADataSet <> nil then
  7390.     begin
  7391.       ADataSet.CheckInactive;
  7392.       ADataSet.CheckFieldName(FFieldName);
  7393.     end;
  7394.     if FDataSet <> nil then FDataSet.RemoveField(Self);
  7395.     if ADataSet <> nil then ADataSet.AddField(Self);
  7396.   end;
  7397. end;
  7398.  
  7399. procedure TField.SetDataType(Value: TFieldType);
  7400. begin
  7401.   FDataType := Value;
  7402.   UpdateDataSize;
  7403. end;
  7404.  
  7405. procedure TField.SetDisplayLabel(Value: string);
  7406. begin
  7407.   if Value = FFieldName then Value := '';
  7408.   if FDisplayLabel <> Value then
  7409.   begin
  7410.     FDisplaylabel := Value;
  7411.     PropertyChanged(True);
  7412.   end;
  7413. end;
  7414.  
  7415. procedure TField.SetDisplayWidth(Value: Integer);
  7416. begin
  7417.   if FDisplayWidth <> Value then
  7418.   begin
  7419.     FDisplayWidth := Value;
  7420.     PropertyChanged(True);
  7421.   end;
  7422. end;
  7423.  
  7424. procedure TField.SetEditMask(const Value: string);
  7425. begin
  7426.   FEditMask := Value;
  7427.   PropertyChanged(False);
  7428. end;
  7429.  
  7430. procedure TField.SetEditText(const Value: string);
  7431. begin
  7432.   if Assigned(FOnSetText) then FOnSetText(Self, Value) else SetText(Value);
  7433. end;
  7434.  
  7435. procedure TField.SetFieldKind(Value: TFieldKind);
  7436. begin
  7437.   if FFieldKind <> Value then
  7438.   begin
  7439.     CheckInactive;
  7440.     FFieldKind := Value;
  7441.   end;
  7442. end;
  7443.  
  7444. procedure TField.SetFieldName(const Value: string);
  7445. begin
  7446.   CheckInactive;
  7447.   if FDataSet <> nil then FDataSet.CheckFieldName(Value);
  7448.   FFieldName := Value;
  7449.   if FDisplayLabel = Value then FDisplayLabel := '';
  7450.   if FDataSet <> nil then FDataSet.DataEvent(deFieldListChange, 0);
  7451. end;
  7452.  
  7453. procedure TField.SetFieldType(Value: TFieldType);
  7454. begin
  7455. end;
  7456.  
  7457. procedure TField.SetIndex(Value: Integer);
  7458. var
  7459.   CurIndex, Count: Integer;
  7460. begin
  7461.   CurIndex := GetIndex;
  7462.   if CurIndex >= 0 then
  7463.   begin
  7464.     Count := FDataSet.FFields.Count;
  7465.     if Value < 0 then Value := 0;
  7466.     if Value >= Count then Value := Count - 1;
  7467.     if Value <> CurIndex then
  7468.     begin
  7469.       FDataSet.FFields.Delete(CurIndex);
  7470.       FDataSet.FFields.Insert(Value, Self);
  7471.       PropertyChanged(True);
  7472.       FDataSet.DataEvent(deFieldListChange, 0);
  7473.     end;
  7474.   end;
  7475. end;
  7476.  
  7477. procedure TField.SetLookup(Value: Boolean);
  7478. begin
  7479.   if Value then
  7480.     FieldKind := fkLookup
  7481.   else if not Calculated then FieldKind := fkData;
  7482. end;
  7483.  
  7484. procedure TField.SetLookupDataSet(Value: TDataSet);
  7485. begin
  7486.   CheckInactive;
  7487.   if (Value <> nil) and (Value = FDataSet) then DBError(SCircularDataLink);
  7488.   FLookupDataSet := Value;
  7489. end;
  7490.  
  7491. procedure TField.SetLookupKeyFields(const Value: string);
  7492. begin
  7493.   CheckInactive;
  7494.   FLookupKeyFields := Value;
  7495. end;
  7496.  
  7497. procedure TField.SetLookupResultField(const Value: string);
  7498. begin
  7499.   CheckInactive;
  7500.   FLookupResultField := Value;
  7501. end;
  7502.  
  7503. procedure TField.SetKeyFields(const Value: string);
  7504. begin
  7505.   CheckInactive;
  7506.   FKeyFields := Value;
  7507. end;
  7508.  
  7509. procedure TField.SetNewValue(const Value: Variant);
  7510. begin
  7511.   FDataSet.FState := dsUpdateNew;
  7512.   try
  7513.     SetAsVariant(Value);
  7514.   finally
  7515.     FDataSet.FState := dsBrowse;
  7516.   end;
  7517. end;
  7518.  
  7519. procedure TField.SetSize(Value: Word);
  7520. begin
  7521.   CheckInactive;
  7522.   CheckTypeSize(DataType, Value);
  7523.   FSize := Value;
  7524.   UpdateDataSize;
  7525. end;
  7526.  
  7527. procedure TField.SetText(const Value: string);
  7528. begin
  7529.   SetAsString(Value);
  7530. end;
  7531.  
  7532. procedure TField.SetVarValue(const Value: Variant);
  7533. begin
  7534.   AccessError('Variant');
  7535. end;
  7536.  
  7537. procedure TField.SetVisible(Value: Boolean);
  7538. begin
  7539.   if FVisible <> Value then
  7540.   begin
  7541.     FVisible := Value;
  7542.     PropertyChanged(True);
  7543.   end;
  7544. end;
  7545.  
  7546. procedure TField.UpdateDataSize;
  7547. begin
  7548.   case FDataType of
  7549.     ftSmallint, ftWord, ftBoolean:
  7550.       FDataSize := 2;
  7551.     ftInteger, ftDate, ftTime, ftAutoInc:
  7552.       FDataSize := 4;
  7553.     ftFloat, ftCurrency, ftDateTime:
  7554.       FDataSize := 8;
  7555.     ftBCD:
  7556.       FDataSize := 34;
  7557.     ftBytes:
  7558.       FDataSize := Size;
  7559.     ftVarBytes:
  7560.       FDataSize := Size + 2;
  7561.     ftString:
  7562.       FDataSize := Size + 1;
  7563.   else
  7564.     FDataSize := 0;
  7565.   end;
  7566. end;
  7567.  
  7568. procedure TField.WriteAttributeSet(Writer: TWriter);
  7569. begin
  7570.   Writer.WriteString(FAttributeSet);
  7571. end;
  7572.  
  7573. { TDataSource }
  7574.  
  7575. constructor TDataSource.Create(AOwner: TComponent);
  7576. begin
  7577.   inherited Create(AOwner);
  7578.   FDataLinks := TList.Create;
  7579.   FEnabled := True;
  7580.   FAutoEdit := True;
  7581. end;
  7582.  
  7583. destructor TDataSource.Destroy;
  7584. begin
  7585.   FOnStateChange := nil;
  7586.   SetDataSet(nil);
  7587.   while FDataLinks.Count > 0 do RemoveDataLink(FDataLinks.Last);
  7588.   FDataLinks.Free;
  7589.   inherited Destroy;
  7590. end;
  7591.  
  7592. procedure TDataSource.Edit;
  7593. begin
  7594.   if AutoEdit and (State = dsBrowse) then DataSet.Edit;
  7595. end;
  7596.  
  7597. procedure TDataSource.SetState(Value: TDataSetState);
  7598. var
  7599.   PriorState: TDataSetState;
  7600. begin
  7601.   if FState <> Value then
  7602.   begin
  7603.     PriorState := FState;
  7604.     FState := Value;
  7605.     NotifyDataLinks(deUpdateState, 0);
  7606.     if not (csDestroying in ComponentState) then
  7607.     begin
  7608.       if Assigned(FOnStateChange) then FOnStateChange(Self);
  7609.       if PriorState = dsInactive then
  7610.         if Assigned(FOnDataChange) then FOnDataChange(Self, nil);
  7611.     end;
  7612.   end;
  7613. end;
  7614.  
  7615. procedure TDataSource.UpdateState;
  7616. begin
  7617.   if Enabled and (DataSet <> nil) then
  7618.     SetState(DataSet.State) else
  7619.     SetState(dsInactive);
  7620. end;
  7621.  
  7622. function TDataSource.IsLinkedTo(DataSet: TDataSet): Boolean;
  7623. var
  7624.   DataSource: TDataSource;
  7625. begin
  7626.   Result := True;
  7627.   while DataSet <> nil do
  7628.   begin
  7629.     DataSource := DataSet.GetDataSource;
  7630.     if DataSource = nil then Break;
  7631.     if DataSource = Self then Exit;
  7632.     DataSet := DataSource.DataSet;
  7633.   end;
  7634.   Result := False;
  7635. end;
  7636.  
  7637. procedure TDataSource.SetDataSet(ADataSet: TDataSet);
  7638. begin
  7639.   if IsLinkedTo(ADataSet) then DBError(SCircularDataLink);
  7640.   if FDataSet <> nil then FDataSet.RemoveDataSource(Self);
  7641.   if ADataSet <> nil then ADataSet.AddDataSource(Self);
  7642. end;
  7643.  
  7644. procedure TDataSource.SetEnabled(Value: Boolean);
  7645. begin
  7646.   FEnabled := Value;
  7647.   UpdateState;
  7648. end;
  7649.  
  7650. procedure TDataSource.AddDataLink(DataLink: TDataLink);
  7651. begin
  7652.   FDataLinks.Add(DataLink);
  7653.   DataLink.FDataSource := Self;
  7654.   if DataSet <> nil then DataSet.UpdateBufferCount;
  7655.   DataLink.UpdateState;
  7656. end;
  7657.  
  7658. procedure TDataSource.RemoveDataLink(DataLink: TDataLink);
  7659. begin
  7660.   DataLink.FDataSource := nil;
  7661.   FDataLinks.Remove(DataLink);
  7662.   DataLink.UpdateState;
  7663.   if DataSet <> nil then DataSet.UpdateBufferCount;
  7664. end;
  7665.  
  7666. procedure TDataSource.NotifyDataLinks(Event: TDataEvent; Info: Longint);
  7667. var
  7668.   I: Integer;
  7669. begin
  7670.   for I := 0 to FDataLinks.Count - 1 do
  7671.     with TDataLink(FDataLinks[I]) do
  7672.       if FBufferCount = 1 then DataEvent(Event, Info);
  7673.   for I := 0 to FDataLinks.Count - 1 do
  7674.     with TDataLink(FDataLinks[I]) do
  7675.       if FBufferCount > 1 then DataEvent(Event, Info);
  7676. end;
  7677.  
  7678. procedure TDataSource.DataEvent(Event: TDataEvent; Info: Longint);
  7679. begin
  7680.   if Event = deUpdateState then UpdateState else
  7681.     if FState <> dsInactive then
  7682.     begin
  7683.       NotifyDataLinks(Event, Info);
  7684.       case Event of
  7685.         deFieldChange:
  7686.           if Assigned(FOnDataChange) then FOnDataChange(Self, TField(Info));
  7687.         deRecordChange, deDataSetChange, deDataSetScroll, deLayoutChange:
  7688.           if Assigned(FOnDataChange) then FOnDataChange(Self, nil);
  7689.         deUpdateRecord:
  7690.           if Assigned(FOnUpdateData) then FOnUpdateData(Self);
  7691.       end;
  7692.     end;
  7693. end;
  7694.  
  7695. { TDataLink }
  7696.  
  7697. constructor TDataLink.Create;
  7698. begin
  7699.   inherited Create;
  7700.   FBufferCount := 1;
  7701. end;
  7702.  
  7703. destructor TDataLink.Destroy;
  7704. begin
  7705.   FActive := False;
  7706.   FEditing := False;
  7707.   FDataSourceFixed := False;
  7708.   SetDataSource(nil);
  7709.   inherited Destroy;
  7710. end;
  7711.  
  7712. procedure TDataLink.UpdateRange;
  7713. var
  7714.   Min, Max: Integer;
  7715. begin
  7716.   Min := DataSet.FActiveRecord - FBufferCount + 1;
  7717.   if Min < 0 then Min := 0;
  7718.   Max := DataSet.FBufferCount - FBufferCount;
  7719.   if Max < 0 then Max := 0;
  7720.   if Max > DataSet.FActiveRecord then Max := DataSet.FActiveRecord;
  7721.   if FFirstRecord < Min then FFirstRecord := Min;
  7722.   if FFirstRecord > Max then FFirstRecord := Max;
  7723. end;
  7724.  
  7725. function TDataLink.GetDataSet: TDataSet;
  7726. begin
  7727.   if DataSource <> nil then Result := DataSource.DataSet else Result := nil;
  7728. end;
  7729.  
  7730. procedure TDataLink.SetDataSource(ADataSource: TDataSource);
  7731. begin
  7732.   if FDataSource <> ADataSource then
  7733.   begin
  7734.     if FDataSourceFixed then DBError(SDataSourceChange);
  7735.     if FDataSource <> nil then FDataSource.RemoveDataLink(Self);
  7736.     if ADataSource <> nil then ADataSource.AddDataLink(Self);
  7737.   end;
  7738. end;
  7739.  
  7740. procedure TDataLink.SetReadOnly(Value: Boolean);
  7741. begin
  7742.   if FReadOnly <> Value then
  7743.   begin
  7744.     FReadOnly := Value;
  7745.     UpdateState;
  7746.   end;
  7747. end;
  7748.  
  7749. procedure TDataLink.SetActive(Value: Boolean);
  7750. begin
  7751.   if FActive <> Value then
  7752.   begin
  7753.     FActive := Value;
  7754.     if Value then UpdateRange else FFirstRecord := 0;
  7755.     ActiveChanged;
  7756.   end;
  7757. end;
  7758.  
  7759. procedure TDataLink.SetEditing(Value: Boolean);
  7760. begin
  7761.   if FEditing <> Value then
  7762.   begin
  7763.     FEditing := Value;
  7764.     EditingChanged;
  7765.   end;
  7766. end;
  7767.  
  7768. procedure TDataLink.UpdateState;
  7769. begin
  7770.   SetActive((DataSource <> nil) and (DataSource.State <> dsInactive));
  7771.   SetEditing((DataSource <> nil) and (DataSource.State in dsEditModes) and
  7772.     not FReadOnly);
  7773. end;
  7774.  
  7775. procedure TDataLink.UpdateRecord;
  7776. begin
  7777.   FUpdating := True;
  7778.   try
  7779.     UpdateData;
  7780.   finally
  7781.     FUpdating := False;
  7782.   end;
  7783. end;
  7784.  
  7785. function TDataLink.Edit: Boolean;
  7786. begin
  7787.   if not FReadOnly and (DataSource <> nil) then DataSource.Edit;
  7788.   Result := FEditing;
  7789. end;
  7790.  
  7791. function TDataLink.GetActiveRecord: Integer;
  7792. begin
  7793.   if DataSource.State = dsSetKey then
  7794.     Result := 0 else
  7795.     Result := DataSource.DataSet.FActiveRecord - FFirstRecord;
  7796. end;
  7797.  
  7798. procedure TDataLink.SetActiveRecord(Value: Integer);
  7799. begin
  7800.   if DataSource.State <> dsSetKey then
  7801.     DataSource.DataSet.FActiveRecord := Value + FFirstRecord;
  7802. end;
  7803.  
  7804. procedure TDataLink.SetBufferCount(Value: Integer);
  7805. begin
  7806.   if FBufferCount <> Value then
  7807.   begin
  7808.     FBufferCount := Value;
  7809.     if Active then
  7810.     begin
  7811.       UpdateRange;
  7812.       DataSet.UpdateBufferCount;
  7813.       UpdateRange;
  7814.     end;
  7815.   end;
  7816. end;
  7817.  
  7818. function TDataLink.GetRecordCount: Integer;
  7819. begin
  7820.   if DataSource.State = dsSetKey then Result := 1 else
  7821.   begin
  7822.     Result := DataSource.DataSet.FRecordCount;
  7823.     if Result > FBufferCount then Result := FBufferCount;
  7824.   end;
  7825. end;
  7826.  
  7827. procedure TDataLink.DataEvent(Event: TDataEvent; Info: Longint);
  7828. var
  7829.   Active, First, Last, Count: Integer;
  7830. begin
  7831.   if Event = deUpdateState then UpdateState else
  7832.     if FActive then
  7833.       case Event of
  7834.         deFieldChange, deRecordChange:
  7835.           if not FUpdating then RecordChanged(TField(Info));
  7836.         deDataSetChange, deDataSetScroll, deLayoutChange:
  7837.           begin
  7838.             Count := 0;
  7839.             if DataSource.State <> dsSetKey then
  7840.             begin
  7841.               Active := DataSource.DataSet.FActiveRecord;
  7842.               First := FFirstRecord + Info;
  7843.               Last := First + FBufferCount - 1;
  7844.               if Active > Last then Count := Active - Last else
  7845.                 if Active < First then Count := Active - First;
  7846.               FFirstRecord := First + Count;
  7847.             end;
  7848.             case Event of
  7849.               deDataSetChange: DataSetChanged;
  7850.               deDataSetScroll: DataSetScrolled(Count);
  7851.               deLayoutChange: LayoutChanged;
  7852.             end;
  7853.           end;
  7854.         deUpdateRecord:
  7855.           UpdateRecord;
  7856.         deCheckBrowseMode:
  7857.           CheckBrowseMode;
  7858.         deFocusControl:
  7859.           FocusControl(TFieldRef(Info));
  7860.       end;
  7861. end;
  7862.  
  7863. procedure TDataLink.ActiveChanged;
  7864. begin
  7865. end;
  7866.  
  7867. procedure TDataLink.CheckBrowseMode;
  7868. begin
  7869. end;
  7870.  
  7871. procedure TDataLink.DataSetChanged;
  7872. begin
  7873.   RecordChanged(nil);
  7874. end;
  7875.  
  7876. procedure TDataLink.DataSetScrolled(Distance: Integer);
  7877. begin
  7878.   DataSetChanged;
  7879. end;
  7880.  
  7881. procedure TDataLink.EditingChanged;
  7882. begin
  7883. end;
  7884.  
  7885. procedure TDataLink.FocusControl(Field: TFieldRef);
  7886. begin
  7887. end;
  7888.  
  7889. procedure TDataLink.LayoutChanged;
  7890. begin
  7891.   DataSetChanged;
  7892. end;
  7893.  
  7894. procedure TDataLink.RecordChanged(Field: TField);
  7895. begin
  7896. end;
  7897.  
  7898. procedure TDataLink.UpdateData;
  7899. begin
  7900. end;
  7901.  
  7902. initialization
  7903.   Sessions := TSessionList.Create;
  7904.   Session := TSession.Create(nil);
  7905.   Session.SessionName := 'Default';
  7906. finalization
  7907.   Sessions.Free;
  7908.   BDEInitProcs.Free;
  7909.   FreeTimer;
  7910. end.
  7911.