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