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