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