home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Runimage / Delphi50 / Source / Vcl / ibdatabase.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-08-11  |  54.0 KB  |  1,920 lines
  1. {********************************************************}
  2. {                                                        }
  3. {       Borland Delphi Visual Component Library          }
  4. {       InterBase Express core components                }
  5. {                                                        }
  6. {       Copyright (c) 1998-1999 Inprise Corporation      }
  7. {                                                        }
  8. {    InterBase Express is based in part on the product   }
  9. {    Free IB Components, written by Gregory H. Deatz for }
  10. {    Hoagland, Longo, Moran, Dunst & Doukas Company.     }
  11. {    Free IB Components is used under license.           }
  12. {                                                        }
  13. {********************************************************}
  14.  
  15. unit IBDatabase;
  16.  
  17. interface
  18.  
  19. uses
  20.   Windows, Dialogs, Controls, StdCtrls, SysUtils, Classes, Forms, ExtCtrls, IBHeader, IBExternals, DB,
  21.   IB, DBLogDlg;
  22.  
  23. const
  24.   DPBPrefix = 'isc_dpb_';
  25.   DPBConstantNames: array[1..isc_dpb_last_dpb_constant] of string = (
  26.     'cdd_pathname',
  27.     'allocation',
  28.     'journal',
  29.     'page_size',
  30.     'num_buffers',
  31.     'buffer_length',
  32.     'debug',
  33.     'garbage_collect',
  34.     'verify',
  35.     'sweep',
  36.     'enable_journal',
  37.     'disable_journal',
  38.     'dbkey_scope',
  39.     'number_of_users',
  40.     'trace',
  41.     'no_garbage_collect',
  42.     'damaged',
  43.     'license',
  44.     'sys_user_name',
  45.     'encrypt_key',
  46.     'activate_shadow',
  47.     'sweep_interval',
  48.     'delete_shadow',
  49.     'force_write',
  50.     'begin_log',
  51.     'quit_log',
  52.     'no_reserve',
  53.     'user_name',
  54.     'password',
  55.     'password_enc',
  56.     'sys_user_name_enc',
  57.     'interp',
  58.     'online_dump',
  59.     'old_file_size',
  60.     'old_num_files',
  61.     'old_file',
  62.     'old_start_page',
  63.     'old_start_seqno',
  64.     'old_start_file',
  65.     'drop_walfile',
  66.     'old_dump_id',
  67.     'wal_backup_dir',
  68.     'wal_chkptlen',
  69.     'wal_numbufs',
  70.     'wal_bufsize',
  71.     'wal_grp_cmt_wait',
  72.     'lc_messages',
  73.     'lc_ctype',
  74.     'cache_manager',
  75.     'shutdown',
  76.     'online',
  77.     'shutdown_delay',
  78.     'reserved',
  79.     'overwrite',
  80.     'sec_attach',
  81.     'disable_wal',
  82.     'connect_timeout',
  83.     'dummy_packet_interval',
  84.     'gbak_attach',
  85.     'sql_role_name',
  86.     'set_page_buffers',
  87.     'working_directory',
  88.     'SQL_dialect',
  89.     'set_db_readonly',
  90.     'set_db_SQL_dialect',
  91.     'gfix_attach',
  92.     'gstat_attach'
  93.   );
  94.  
  95.   TPBPrefix = 'isc_tpb_';
  96.   TPBConstantNames: array[1..isc_tpb_last_tpb_constant] of string = (
  97.     'consistency',
  98.     'concurrency',
  99.     'shared',
  100.     'protected',
  101.     'exclusive',
  102.     'wait',
  103.     'nowait',
  104.     'read',
  105.     'write',
  106.     'lock_read',
  107.     'lock_write',
  108.     'verb_time',
  109.     'commit_time',
  110.     'ignore_limbo',
  111.     'read_committed',
  112.     'autocommit',
  113.     'rec_version',
  114.     'no_rec_version',
  115.     'restart_requests',
  116.     'no_auto_undo'
  117.   );
  118.  
  119. type
  120.  
  121.   TIBDatabase = class;
  122.   TIBTransaction = class;
  123.   TIBBase = class;
  124.  
  125.   TTraceFlag = (tfQPrepare, tfQExecute, tfQFetch, tfError, tfStmt, tfConnect,
  126.      tfTransact, tfBlob, tfService, tfMisc);
  127.   TTraceFlags = set of TTraceFlag;
  128.  
  129.   TIBDatabaseLoginEvent = procedure(Database: TIBDatabase;
  130.     LoginParams: TStrings) of object;
  131.  
  132.   TIBFileName = type string;
  133.   { TIBDatabase }
  134.   TIBDataBase = class(TCustomConnection)
  135.   private
  136.     FHiddenPassword: string;
  137.     FIBLoaded: Boolean;
  138.     FOnLogin: TIBDatabaseLoginEvent;
  139.     FTraceFlags: TTraceFlags;
  140.     FDBSQLDialect: Integer;
  141.     FSQLDialect: Integer;
  142.     FOnDialectDowngradeWarning: TNotifyEvent;
  143.     FCanTimeout: Boolean;
  144.     FSQLObjects: TList;
  145.     FTransactions: TList;
  146.     FDBName: TIBFileName;
  147.     FDBParams: TStrings;
  148.     FDBParamsChanged: Boolean;
  149.     FDPB: PChar;
  150.     FDPBLength: Short;
  151.     FHandle: TISC_DB_HANDLE;
  152.     FHandleIsShared: Boolean;
  153.     FOnIdleTimer: TNotifyEvent;
  154.     FDefaultTransaction: TIBTransaction;
  155.     FInternalTransaction: TIBTransaction;
  156.     FStreamedConnected: Boolean;
  157.     FTimer: TTimer;
  158.     FUserNames: TStringList;
  159.     procedure EnsureInactive;
  160.     function GetDBSQLDialect: Integer;
  161.     function GetSQLDialect: Integer;
  162.     procedure SetSQLDialect(const Value: Integer);
  163.     procedure SetTraceFlags(const Value: TTraceFlags);
  164.     procedure ValidateClientSQLDialect;
  165.     procedure DBParamsChange(Sender: TObject);
  166.     procedure DBParamsChanging(Sender: TObject);
  167.     function GetSQLObject(Index: Integer): TIBBase;
  168.     function GetSQLObjectCount: Integer;
  169.     function GetDBParamByDPB(const Idx: Integer): String;
  170.     function GetIdleTimer: Integer;
  171.     function GetTransaction(Index: Integer): TIBTransaction;
  172.     function GetTransactionCount: Integer;
  173.     function Login: Boolean;
  174.     procedure SetDatabaseName(const Value: TIBFileName);
  175.     procedure SetDBParamByDPB(const Idx: Integer; Value: String);
  176.     procedure SetDBParams(Value: TStrings);
  177.     procedure SetDefaultTransaction(Value: TIBTransaction);
  178.     procedure SetIdleTimer(Value: Integer);
  179.     procedure TimeoutConnection(Sender: TObject);
  180.     function GetIsReadOnly: Boolean;
  181.     function AddSQLObject(ds: TIBBase): Integer;
  182.     procedure RemoveSQLObject(Idx: Integer);
  183.     procedure RemoveSQLObjects;
  184.     procedure InternalClose(Force: Boolean);
  185.  
  186.   protected
  187.     procedure DoConnect; override;
  188.     procedure DoDisconnect; override;
  189.     function GetConnected: Boolean; override;
  190.     procedure Loaded; override;
  191.     procedure Notification( AComponent: TComponent; Operation: TOperation); override;
  192.  
  193.   public
  194.     constructor Create(AOwner: TComponent); override;
  195.     destructor Destroy; override;
  196.     procedure ApplyUpdates(const DataSets: array of TDataSet);
  197.     procedure CloseDataSets;
  198.     procedure CheckActive;
  199.     procedure CheckInactive;
  200.     procedure CreateDatabase;
  201.     procedure DropDatabase;
  202.     procedure ForceClose;
  203.     procedure GetFieldNames(const TableName: string; List: TStrings);
  204.     procedure GetTableNames(List: TStrings; SystemTables: Boolean = False);
  205.     function IndexOfDBConst(st: String): Integer;
  206.     function TestConnected: Boolean;
  207.     procedure CheckDatabaseName;
  208.     function Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
  209.     function AddTransaction(TR: TIBTransaction): Integer;
  210.     function FindTransaction(TR: TIBTransaction): Integer;
  211.     function FindDefaultTransaction(): TIBTransaction;
  212.     procedure RemoveTransaction(Idx: Integer);
  213.     procedure RemoveTransactions;
  214.     procedure SetHandle(Value: TISC_DB_HANDLE);
  215.  
  216.     property Handle: TISC_DB_HANDLE read FHandle;
  217.     property IsReadOnly: Boolean read GetIsReadOnly;
  218.     property DBParamByDPB[const Idx: Integer]: String read GetDBParamByDPB
  219.                                                       write SetDBParamByDPB;
  220.     property SQLObjectCount: Integer read GetSQLObjectCount;
  221.     property SQLObjects[Index: Integer]: TIBBase read GetSQLObject;
  222.     property HandleIsShared: Boolean read FHandleIsShared;
  223.     property TransactionCount: Integer read GetTransactionCount;
  224.     property Transactions[Index: Integer]: TIBTransaction read GetTransaction;
  225.     property InternalTransaction: TIBTransaction read FInternalTransaction;
  226.  
  227.   published
  228.     property Connected;
  229.     property DatabaseName: TIBFileName read FDBName write SetDatabaseName;
  230.     property Params: TStrings read FDBParams write SetDBParams;
  231.     property LoginPrompt default True;
  232.     property DefaultTransaction: TIBTransaction read FDefaultTransaction
  233.                                                  write SetDefaultTransaction;
  234.     property IdleTimer: Integer read GetIdleTimer write SetIdleTimer;
  235.     property SQLDialect : Integer read GetSQLDialect write SetSQLDialect;
  236.     property DBSQLDialect : Integer read FDBSQLDialect;
  237.     property TraceFlags: TTraceFlags read FTraceFlags write SetTraceFlags;
  238.     property AfterConnect;
  239.     property AfterDisconnect;
  240.     property BeforeConnect;
  241.     property BeforeDisconnect;
  242.     property OnLogin: TIBDatabaseLoginEvent read FOnLogin write FOnLogin;
  243.     property OnIdleTimer: TNotifyEvent read FOnIdleTimer write FOnIdleTimer;
  244.     property OnDialectDowngradeWarning: TNotifyEvent read FOnDialectDowngradeWarning write FOnDialectDowngradeWarning;
  245.   end;
  246.  
  247.   { TIBTransaction }
  248.  
  249.   TTransactionAction         = (TARollback, TACommit, TARollbackRetaining, TACommitRetaining);
  250.  
  251.   TIBTransaction = class(TComponent)
  252.   private
  253.     FIBLoaded: Boolean;
  254.     FCanTimeout         : Boolean;
  255.     FDatabases          : TList;
  256.     FSQLObjects         : TList;
  257.     FDefaultDatabase    : TIBDatabase;
  258.     FHandle             : TISC_TR_HANDLE;
  259.     FHandleIsShared     : Boolean;
  260.     FOnIdleTimer          : TNotifyEvent;
  261.     FStreamedActive     : Boolean;
  262.     FTPB                : PChar;
  263.     FTPBLength          : Short;
  264.     FTimer              : TTimer;
  265.     FDefaultAction      : TTransactionAction;
  266.     FTRParams           : TStrings;
  267.     FTRParamsChanged    : Boolean;
  268.     procedure EnsureNotInTransaction;
  269.     procedure EndTransaction(Action: TTransactionAction; Force: Boolean);
  270.     function GetDatabase(Index: Integer): TIBDatabase;
  271.     function GetDatabaseCount: Integer;
  272.     function GetSQLObject(Index: Integer): TIBBase;
  273.     function GetSQLObjectCount: Integer;
  274.     function GetInTransaction: Boolean;
  275.     function GetIdleTimer: Integer;
  276.     procedure BeforeDatabaseDisconnect(DB: TIBDatabase);
  277.     procedure SetActive(Value: Boolean);
  278.     procedure SetDefaultAction(Value: TTransactionAction);
  279.     procedure SetDefaultDatabase(Value: TIBDatabase);
  280.     procedure SetIdleTimer(Value: Integer);
  281.     procedure SetTRParams(Value: TStrings);
  282.     procedure TimeoutTransaction(Sender: TObject);
  283.     procedure TRParamsChange(Sender: TObject);
  284.     procedure TRParamsChanging(Sender: TObject);
  285.     function AddSQLObject(ds: TIBBase): Integer;
  286.     procedure RemoveSQLObject(Idx: Integer);
  287.     procedure RemoveSQLObjects;
  288.  
  289.   protected
  290.     procedure Loaded; override;
  291.     procedure SetHandle(Value: TISC_TR_HANDLE);
  292.     procedure Notification( AComponent: TComponent; Operation: TOperation); override;
  293.  
  294.   public
  295.     constructor Create(AOwner: TComponent); override;
  296.     destructor Destroy; override;
  297.     function Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
  298.     procedure Commit;
  299.     procedure CommitRetaining;
  300.     procedure Rollback;
  301.     procedure RollbackRetaining;
  302.     procedure StartTransaction;
  303.     procedure CheckInTransaction;
  304.     procedure CheckNotInTransaction;
  305.  
  306.     function AddDatabase(db: TIBDatabase): Integer;
  307.     function FindDatabase(db: TIBDatabase): Integer;
  308.     function FindDefaultDatabase: TIBDatabase;
  309.     procedure RemoveDatabase(Idx: Integer);
  310.     procedure RemoveDatabases;
  311.     procedure CheckDatabasesInList;
  312.  
  313.     property DatabaseCount: Integer read GetDatabaseCount;
  314.     property Databases[Index: Integer]: TIBDatabase read GetDatabase;
  315.     property SQLObjectCount: Integer read GetSQLObjectCount;
  316.     property SQLObjects[Index: Integer]: TIBBase read GetSQLObject;
  317.     property Handle: TISC_TR_HANDLE read FHandle;
  318.     property HandleIsShared: Boolean read FHandleIsShared;
  319.     property InTransaction: Boolean read GetInTransaction;
  320.     property TPB: PChar read FTPB;
  321.     property TPBLength: Short read FTPBLength;
  322.   published
  323.     property Active: Boolean read GetInTransaction write SetActive;
  324.     property DefaultDatabase: TIBDatabase read FDefaultDatabase
  325.                                            write SetDefaultDatabase;
  326.     property IdleTimer: Integer read GetIdleTimer write SetIdleTimer default 0;
  327.     property DefaultAction: TTransactionAction read FDefaultAction write SetDefaultAction default taCommit;
  328.     property Params: TStrings read FTRParams write SetTRParams;
  329.     property OnIdleTimer: TNotifyEvent read FOnIdleTimer write FOnIdleTimer;
  330.   end;
  331.  
  332.   { TIBBase }
  333.  
  334.   { Virtually all components in IB are "descendents" of TIBBase.
  335.     It is to more easily manage the database and transaction
  336.     connections. }
  337.   TIBBase = class(TObject)
  338.   protected
  339.     FDatabase: TIBDatabase;
  340.     FIndexInDatabase: Integer;
  341.     FTransaction: TIBTransaction;
  342.     FIndexInTransaction: Integer;
  343.     FOwner: TObject;
  344.     FBeforeDatabaseDisconnect: TNotifyEvent;
  345.     FAfterDatabaseDisconnect: TNotifyEvent;
  346.     FOnDatabaseFree: TNotifyEvent;
  347.     FBeforeTransactionEnd: TNotifyEvent;
  348.     FAfterTransactionEnd: TNotifyEvent;
  349.     FOnTransactionFree: TNotifyEvent;
  350.  
  351.     procedure DoBeforeDatabaseDisconnect; virtual;
  352.     procedure DoAfterDatabaseDisconnect; virtual;
  353.     procedure DoDatabaseFree; virtual;
  354.     procedure DoBeforeTransactionEnd; virtual;
  355.     procedure DoAfterTransactionEnd; virtual;
  356.     procedure DoTransactionFree; virtual;
  357.     function GetDBHandle: PISC_DB_HANDLE; virtual;
  358.     function GetTRHandle: PISC_TR_HANDLE; virtual;
  359.     procedure SetDatabase(Value: TIBDatabase); virtual;
  360.     procedure SetTransaction(Value: TIBTransaction); virtual;
  361.   public
  362.     constructor Create(AOwner: TObject);
  363.     destructor Destroy; override;
  364.     procedure CheckDatabase; virtual;
  365.     procedure CheckTransaction; virtual;
  366.   public
  367.     property BeforeDatabaseDisconnect: TNotifyEvent read FBeforeDatabaseDisconnect
  368.                                                    write FBeforeDatabaseDisconnect;
  369.     property AfterDatabaseDisconnect: TNotifyEvent read FAfterDatabaseDisconnect
  370.                                                   write FAfterDatabaseDisconnect;
  371.     property OnDatabaseFree: TNotifyEvent read FOnDatabaseFree write FOnDatabaseFree;
  372.     property BeforeTransactionEnd: TNotifyEvent read FBeforeTransactionEnd write FBeforeTransactionEnd;
  373.     property AfterTransactionEnd: TNotifyEvent read FAfterTransactionEnd write FAfterTransactionEnd;
  374.     property OnTransactionFree: TNotifyEvent read FOnTransactionFree write FOnTransactionFree;
  375.     property Database: TIBDatabase read FDatabase
  376.                                     write SetDatabase;
  377.     property DBHandle: PISC_DB_HANDLE read GetDBHandle;
  378.     property Owner: TObject read FOwner;
  379.     property TRHandle: PISC_TR_HANDLE read GetTRHandle;
  380.     property Transaction: TIBTransaction read FTransaction
  381.                                           write SetTransaction;
  382.   end;
  383.  
  384. procedure GenerateDPB(sl: TStrings; var DPB: string; var DPBLength: Short);
  385. procedure GenerateTPB(sl: TStrings; var TPB: string; var TPBLength: Short);
  386.  
  387.  
  388. implementation
  389.  
  390. uses IBIntf, IBSQLMonitor, IBCustomDataSet, IBDatabaseInfo, IBSQL, IBUtils;
  391.  
  392. { TIBDatabase }
  393.  
  394. constructor TIBDatabase.Create(AOwner: TComponent);
  395. begin
  396.   inherited Create(AOwner);
  397.   FIBLoaded := False;
  398.   CheckIBLoaded;
  399.   FIBLoaded := True;
  400.   LoginPrompt := True;
  401.   FSQLObjects                          := TList.Create;
  402.   FTransactions                        := TList.Create;
  403.   FDBName                              := '';
  404.   FDBParams                            := TStringList.Create;
  405.   FDBParamsChanged                     := True;
  406.   TStringList(FDBParams).OnChange      := DBParamsChange;
  407.   TStringList(FDBParams).OnChanging    := DBParamsChanging;
  408.   FDPB                                 := nil;
  409.   FHandle                              := nil;
  410.   FUserNames                           := nil;
  411.   FInternalTransaction                 := TIBTransaction.Create(self);
  412.   FInternalTransaction.DefaultDatabase := Self;
  413.   FTimer                               := TTimer.Create(Self);
  414.   FTimer.Enabled                       := False;
  415.   FTimer.Interval                      := 0;
  416.   FTimer.OnTimer                       := TimeoutConnection;
  417.   FDBSQLDialect := 1;
  418.   FSQLDialect := 1;
  419.   FTraceFlags := [];
  420. end;
  421.  
  422. destructor TIBDatabase.Destroy;
  423. var
  424.   i: Integer;
  425. begin
  426.   if FIBLoaded then
  427.   begin
  428.     IdleTimer := 0;
  429.     if FHandle <> nil then ForceClose;
  430.     for i := 0 to FSQLObjects.Count - 1 do if FSQLObjects[i] <> nil then
  431.       SQLObjects[i].DoDatabaseFree;
  432.     RemoveSQLObjects;
  433.     RemoveTransactions;
  434.     FInternalTransaction.Free;
  435.     IBAlloc(FDPB, 0, 0);
  436.     FDBParams.Free;
  437.     FSQLObjects.Free;
  438.     FUserNames.Free;
  439.     FTransactions.Free;
  440.   end;
  441.   inherited Destroy;
  442. end;
  443.  
  444. function TIBDatabase.Call(ErrCode: ISC_STATUS;
  445.   RaiseError: Boolean): ISC_STATUS;
  446. begin
  447.   result := ErrCode;
  448.   FCanTimeout := False;
  449.   if RaiseError and (ErrCode > 0) then
  450.     IBDataBaseError;
  451. end;
  452.  
  453. procedure TIBDatabase.CheckActive;
  454. begin
  455.   if StreamedConnected and (not Connected) then
  456.     Loaded;
  457.   if FHandle = nil then
  458.     IBError(ibxeDatabaseClosed, [nil]);
  459. end;
  460.  
  461. procedure TIBDatabase.EnsureInactive;
  462. begin
  463.   if csDesigning in ComponentState then
  464.   begin
  465.     if FHandle <> nil then
  466.       Close;
  467.   end
  468. end;
  469.  
  470. procedure TIBDatabase.CheckInactive;
  471. begin
  472.   if FHandle <> nil then
  473.     IBError(ibxeDatabaseOpen, [nil]);
  474. end;
  475.  
  476. procedure TIBDatabase.CheckDatabaseName;
  477. begin
  478.   if (FDBName = '') then
  479.     IBError(ibxeDatabaseNameMissing, [nil]);
  480. end;
  481.  
  482. function TIBDatabase.AddSQLObject(ds: TIBBase): Integer;
  483. begin
  484.   result := 0;
  485.   if (ds.Owner is TIBCustomDataSet) then
  486.       RegisterClient(TDataSet(ds.Owner));
  487.   while (result < FSQLObjects.Count) and (FSQLObjects[result] <> nil) do
  488.     Inc(result);
  489.   if (result = FSQLObjects.Count) then
  490.     FSQLObjects.Add(ds)
  491.   else
  492.     FSQLObjects[result] := ds;
  493. end;
  494.  
  495. function TIBDatabase.AddTransaction(TR: TIBTransaction): Integer;
  496. begin
  497.   result := FindTransaction(TR);
  498.   if result <> -1 then begin
  499.     result := -1;
  500.     exit;
  501.   end;
  502.   result := 0;
  503.   while (result < FTransactions.Count) and (FTransactions[result] <> nil) do
  504.     Inc(result);
  505.   if (result = FTransactions.Count) then
  506.     FTransactions.Add(TR)
  507.   else
  508.     FTransactions[result] := TR;
  509. end;
  510.  
  511. procedure TIBDatabase.DoDisconnect;
  512. begin
  513.   if Connected then
  514.     InternalClose(False);
  515.   FDBSQLDialect := 1;
  516. end;
  517.  
  518. procedure TIBDatabase.CreateDatabase;
  519. var
  520.   tr_handle: TISC_TR_HANDLE;
  521. begin
  522.   CheckInactive;
  523.   tr_handle := nil;
  524.   Call(
  525.     isc_dsql_execute_immediate(StatusVector, @FHandle, @tr_handle, 0,
  526.                                PChar('CREATE DATABASE ''' + FDBName + ''' ' + {do not localize}
  527.                                Params.Text), SQLDialect, nil),
  528.     True);
  529. end;
  530.  
  531. procedure TIBDatabase.DropDatabase;
  532. begin
  533.   CheckActive;
  534.   Call(isc_drop_database(StatusVector, @FHandle), True);
  535. end;
  536.  
  537. procedure TIBDatabase.DBParamsChange(Sender: TObject);
  538. begin
  539.   FDBParamsChanged := True;
  540. end;
  541.  
  542. procedure TIBDatabase.DBParamsChanging(Sender: TObject);
  543. begin
  544.   EnsureInactive;
  545.   CheckInactive;
  546. end;
  547.  
  548. function TIBDatabase.FindTransaction(TR: TIBTransaction): Integer;
  549. var
  550.   i: Integer;
  551. begin
  552.   result := -1;
  553.   for i := 0 to FTransactions.Count - 1 do
  554.     if TR = Transactions[i] then begin
  555.       result := i;
  556.       break;
  557.     end;
  558. end;
  559.  
  560. function TIBDatabase.FindDefaultTransaction(): TIBTransaction;
  561. var
  562.   i: Integer;
  563. begin
  564.   result := FDefaultTransaction;
  565.   if result = nil then
  566.   begin
  567.     for i := 0 to FTransactions.Count - 1 do
  568.       if (Transactions[i] <> nil) and
  569.         (TIBTransaction(Transactions[i]).DefaultDatabase = self) and
  570.         (TIBTransaction(Transactions[i]) <> FInternalTransaction) then
  571.        begin
  572.        result := TIBTransaction(Transactions[i]);
  573.        break;
  574.        end;
  575.   end;
  576. end;
  577.  
  578. procedure TIBDatabase.ForceClose;
  579. begin
  580.   if Connected then
  581.     InternalClose(True);
  582. end;
  583.  
  584. function TIBDatabase.GetConnected: Boolean;
  585. begin
  586.   result := FHandle <> nil;
  587. end;
  588.  
  589. function TIBDatabase.GetSQLObject(Index: Integer): TIBBase;
  590. begin
  591.   result := FSQLObjects[Index];
  592. end;
  593.  
  594. function TIBDatabase.GetSQLObjectCount: Integer;
  595. var
  596.   i: Integer;
  597. begin
  598.   result := 0;
  599.   for i := 0 to FSQLObjects.Count - 1 do if FSQLObjects[i] <> nil then
  600.     Inc(result);
  601. end;
  602.  
  603. function TIBDatabase.GetDBParamByDPB(const Idx: Integer): String;
  604. var
  605.   ConstIdx, EqualsIdx: Integer;
  606. begin
  607.   if (Idx > 0) and (Idx <= isc_dpb_last_dpb_constant) then begin
  608.     ConstIdx := IndexOfDBConst(DPBConstantNames[Idx]);
  609.     if ConstIdx = -1 then
  610.       result := ''
  611.     else begin
  612.       result := Params[ConstIdx];
  613.       EqualsIdx := Pos('=', result); {mbcs ok}
  614.       if EqualsIdx = 0 then
  615.         result := ''
  616.       else
  617.         result := Copy(result, EqualsIdx + 1, Length(result));
  618.     end;
  619.   end else
  620.     result := '';
  621. end;
  622.  
  623. function TIBDatabase.GetIdleTimer: Integer;
  624. begin
  625.   result := FTimer.Interval;
  626. end;
  627.  
  628. function TIBDatabase.GetTransaction(Index: Integer): TIBTransaction;
  629. begin
  630.   result := FTransactions[Index];
  631. end;
  632.  
  633. function TIBDatabase.GetTransactionCount: Integer;
  634. var
  635.   i: Integer;
  636. begin
  637.   result := 0;
  638.   for i := 0 to FTransactions.Count - 1 do if FTransactions[i] <> nil then
  639.     Inc(result);
  640. end;
  641.  
  642. function TIBDatabase.IndexOfDBConst(st: String): Integer;
  643. var
  644.   i, pos_of_str: Integer;
  645. begin
  646.   result := -1;
  647.   for i := 0 to Params.Count - 1 do begin
  648.     pos_of_str := Pos(st, AnsiLowerCase(Params[i])); {mbcs ok}
  649.     if (pos_of_str = 1) or (pos_of_str = Length(DPBPrefix) + 1) then begin
  650.       result := i;
  651.       break;
  652.     end;
  653.   end;
  654. end;
  655.  
  656. procedure TIBDatabase.InternalClose(Force: Boolean);
  657. var
  658.   i: Integer;
  659. begin
  660.   CheckActive;
  661.   { Tell all connected transactions that we're disconnecting.
  662.     This is so transactions can commit/rollback, accordingly
  663.   }
  664.   for i := 0 to FTransactions.Count - 1 do begin
  665.     try
  666.       if FTransactions[i] <> nil then
  667.         Transactions[i].BeforeDatabaseDisconnect(Self);
  668.     except
  669.       if not Force then
  670.         raise;
  671.     end;
  672.   end;
  673.   for i := 0 to FSQLObjects.Count - 1 do begin
  674.     try
  675.       if FSQLObjects[i] <> nil then
  676.         SQLObjects[i].DoBeforeDatabaseDisconnect;
  677.     except
  678.       if not Force then
  679.         raise;
  680.     end;
  681.   end;
  682.  
  683.   if (not HandleIsShared) and
  684.      (Call(isc_detach_database(StatusVector, @FHandle), False) > 0) and
  685.      (not Force) then
  686.     IBDataBaseError
  687.   else begin
  688.     FHandle := nil;
  689.     FHandleIsShared := False;
  690.   end;
  691.  
  692.   MonitorHook.DBDisconnect(Self);
  693.  
  694.   for i := 0 to FSQLObjects.Count - 1 do
  695.     if FSQLObjects[i] <> nil then
  696.       SQLObjects[i].DoAfterDatabaseDisconnect;
  697. end;
  698.  
  699. procedure TIBDatabase.Loaded;
  700. var
  701.   i: integer;
  702. begin
  703.   try
  704.     if StreamedConnected and (not Connected) then begin
  705.       inherited Loaded;
  706.       for i := 0 to FTransactions.Count - 1 do
  707.         if  FTransactions[i] <> nil then
  708.         begin
  709.         with TIBTransaction(FTransactions[i]) do
  710.           if not Active then
  711.             if FStreamedActive and not InTransaction then
  712.             begin
  713.               StartTransaction;
  714.               FStreamedActive := False;
  715.             end;
  716.         end;
  717.       if (FDefaultTransaction <> nil) and
  718.          (FDefaultTransaction.FStreamedActive) and
  719.          (not FDefaultTransaction.InTransaction) then
  720.         FDefaultTransaction.StartTransaction;
  721.       FStreamedConnected := False;
  722.     end;
  723.   except
  724.     if csDesigning in ComponentState then
  725.       Application.HandleException(Self)
  726.     else
  727.       raise;
  728.   end;
  729. end;
  730.  
  731. procedure TIBDatabase.Notification( AComponent: TComponent;
  732.                                         Operation: TOperation);
  733. var
  734.   i: Integer;
  735. begin
  736.   inherited Notification( AComponent, Operation);
  737.   if (Operation = opRemove) and (AComponent = FDefaultTransaction) then
  738.   begin
  739.     i := FindTransaction(FDefaultTransaction);
  740.     if (i <> -1) then
  741.       RemoveTransaction(i);
  742.     FDefaultTransaction := nil;
  743.   end;
  744. end;
  745.  
  746. function TIBDatabase.Login: Boolean;
  747. var
  748.   IndexOfUser, IndexOfPassword: Integer;
  749.   Username, Password, old_password: String;
  750.   LoginParams: TStrings;
  751.  
  752.   procedure HidePassword;
  753.   var
  754.     I: Integer;
  755.     IndexAt: Integer;
  756.   begin
  757.     IndexAt := 0;
  758.     for I := 0 to Params.Count -1 do
  759.       if Pos('password', LowerCase(Params.Names[i])) = 0 then {mbcs ok}
  760.       begin
  761.         FHiddenPassword := Params.Values[Params.Names[i]];
  762.         IndexAt := I;
  763.         break;
  764.       end;
  765.     if IndexAt <> 0 then
  766.       Params.Delete(IndexAt);
  767.   end;
  768.  
  769. begin
  770.   if Assigned(FOnLogin) then begin
  771.     result := True;
  772.     LoginParams := TStringList.Create;
  773.     try
  774.       LoginParams.Assign(Params);
  775.       FOnLogin(Self, LoginParams);
  776.       Params.Assign (LoginParams);
  777.       HidePassword;
  778.     finally
  779.       LoginParams.Free;
  780.     end;
  781.   end
  782.   else begin
  783.     IndexOfUser := IndexOfDBConst(DPBConstantNames[isc_dpb_user_name]);
  784.     if IndexOfUser <> -1 then
  785.       Username := Copy(Params[IndexOfUser],
  786.                                          Pos('=', Params[IndexOfUser]) + 1, {mbcs ok}
  787.                                          Length(Params[IndexOfUser]));
  788.     IndexOfPassword := IndexOfDBConst(DPBConstantNames[isc_dpb_password]);
  789.     if IndexOfPassword <> -1 then begin
  790.       Password := Copy(Params[IndexOfPassword],
  791.                                          Pos('=', Params[IndexOfPassword]) + 1, {mbcs ok}
  792.                                          Length(Params[IndexOfPassword]));
  793.       old_password := password;
  794.     end;
  795.     result := LoginDialogEx(DatabaseName, Username, Password, False);
  796.     if result then begin
  797.       if IndexOfUser = -1 then
  798.         Params.Add(DPBConstantNames[isc_dpb_user_name] + '=' + Username)
  799.       else
  800.         Params[IndexOfUser] := DPBConstantNames[isc_dpb_user_name] +
  801.                                  '=' + Username;
  802.       if (Password = old_password) then
  803.         FHiddenPassword := ''
  804.       else begin
  805.         FHiddenPassword := Password;
  806.         if old_password <> '' then
  807.           HidePassword;
  808.       end;
  809.     end;
  810.   end;
  811. end;
  812.  
  813. procedure TIBDatabase.DoConnect;
  814. var
  815.   DPB: String;
  816.   TempDBParams: TStrings;
  817.  
  818. begin
  819.   CheckInactive;
  820.   CheckDatabaseName;
  821.   if (not LoginPrompt) and (FHiddenPassword <> '') then
  822.   begin
  823.     FHiddenPassword := '';
  824.     FDBParamsChanged := True;
  825.   end;
  826.   { Use builtin login prompt if requested }
  827.   if LoginPrompt and not Login then
  828.     IBError(ibxeOperationCancelled, [nil]);
  829.   { Generate a new DPB if necessary }
  830.   if (FDBParamsChanged) then
  831.   begin
  832.     FDBParamsChanged := False;
  833.     if (not LoginPrompt) or (FHiddenPassword = '') then
  834.       GenerateDPB(FDBParams, DPB, FDPBLength)
  835.     else begin
  836.       TempDBParams := TStringList.Create;
  837.       try
  838.        TempDBParams.Assign(FDBParams);
  839.        TempDBParams.Add('password=' + FHiddenPassword);
  840.        GenerateDPB(TempDBParams, DPB, FDPBLength);
  841.       finally
  842.        TempDBParams.Free;
  843.       end;
  844.     end;
  845.     IBAlloc(FDPB, 0, FDPBLength);
  846.     Move(DPB[1], FDPB[0], FDPBLength);
  847.   end;
  848.   if Call(isc_attach_database(StatusVector, Length(FDBName),
  849.                          PChar(FDBName), @FHandle,
  850.                          FDPBLength, FDPB), False) > 0 then begin
  851.     FHandle := nil;
  852.     IBDataBaseError;
  853.   end;
  854.   FDBSQLDialect := GetDBSQLDialect;
  855.   ValidateClientSQLDialect;
  856.   MonitorHook.DBConnect(Self);
  857. end;
  858.  
  859. procedure TIBDatabase.RemoveSQLObject(Idx: Integer);
  860. var
  861.   ds: TIBBase;
  862. begin
  863.   if (Idx >= 0) and (FSQLObjects[Idx] <> nil) then begin
  864.     ds := SQLObjects[Idx];
  865.     FSQLObjects[Idx] := nil;
  866.     ds.Database := nil;
  867.     if (ds.owner is TDataSet) then
  868.       UnregisterClient(TDataSet(ds.Owner));
  869.   end;
  870. end;
  871.  
  872. procedure TIBDatabase.RemoveSQLObjects;
  873. var
  874.   i: Integer;
  875. begin
  876.   for i := 0 to FSQLObjects.Count - 1 do if FSQLObjects[i] <> nil then
  877.   begin
  878.     RemoveSQLObject(i);
  879.     if (TIBBase(FSQLObjects[i]).owner is TDataSet) then
  880.       UnregisterClient(TDataSet(TIBBase(FSQLObjects[i]).owner));
  881.   end;
  882. end;
  883.  
  884. procedure TIBDatabase.RemoveTransaction(Idx: Integer);
  885. var
  886.   TR: TIBTransaction;
  887. begin
  888.   if ((Idx >= 0) and (FTransactions[Idx] <> nil)) then begin
  889.     TR := Transactions[Idx];
  890.     FTransactions[Idx] := nil;
  891.     TR.RemoveDatabase(TR.FindDatabase(Self));
  892.     if TR = FDefaultTransaction then
  893.       FDefaultTransaction := nil;
  894.   end;
  895. end;
  896.  
  897. procedure TIBDatabase.RemoveTransactions;
  898. var
  899.   i: Integer;
  900. begin
  901.   for i := 0 to FTransactions.Count - 1 do if FTransactions[i] <> nil then
  902.     RemoveTransaction(i);
  903. end;
  904.  
  905. procedure TIBDatabase.SetDatabaseName(const Value: TIBFileName);
  906. begin
  907.   if FDBName <> Value then begin
  908.     EnsureInactive;
  909.     CheckInactive;
  910.     FDBName := Value;
  911.   end;
  912. end;
  913.  
  914. procedure TIBDatabase.SetDBParamByDPB(const Idx: Integer; Value: String);
  915. var
  916.   ConstIdx: Integer;
  917. begin
  918.   ConstIdx := IndexOfDBConst(DPBConstantNames[Idx]);
  919.   if (Value = '') then begin
  920.     if ConstIdx <> -1 then
  921.       Params.Delete(ConstIdx);
  922.   end else begin
  923.     if (ConstIdx = -1) then
  924.       Params.Add(DPBConstantNames[Idx] + '=' + Value)
  925.     else
  926.       Params[ConstIdx] := DPBConstantNames[Idx] + '=' + Value;
  927.   end;
  928. end;
  929.  
  930. procedure TIBDatabase.SetDBParams(Value: TStrings);
  931. begin
  932.   FDBParams.Assign(Value);
  933. end;
  934.  
  935. procedure TIBDatabase.SetDefaultTransaction(Value: TIBTransaction);
  936. var
  937.   i: Integer;
  938. begin
  939.   if (FDefaultTransaction <> nil) and (FDefaultTransaction <> Value) then
  940.   begin
  941.     i := FindTransaction(FDefaultTransaction);
  942.     if (i <> -1) then
  943.       RemoveTransaction(i);
  944.   end;
  945.   if (Value <> nil) and (FDefaultTransaction <> Value) then begin
  946.     Value.AddDatabase(Self);
  947.     AddTransaction(Value);
  948.   end;
  949.   FDefaultTransaction := Value;
  950. end;
  951.  
  952. procedure TIBDatabase.SetHandle(Value: TISC_DB_HANDLE);
  953. begin
  954.   if HandleIsShared then
  955.     Close
  956.   else
  957.     CheckInactive;
  958.   FHandle := Value;
  959.   FHandleIsShared := (Value <> nil);
  960. end;
  961.  
  962. procedure TIBDatabase.SetIdleTimer(Value: Integer);
  963. begin
  964.   if Value < 0 then
  965.     IBError(ibxeTimeoutNegative, [nil])
  966.   else if (Value = 0) then begin
  967.     FTimer.Enabled := False;
  968.     FTimer.Interval := 0;
  969.   end else if (Value > 0) then begin
  970.     FTimer.Interval := Value;
  971.     if not (csDesigning in ComponentState) then
  972.       FTimer.Enabled := True;
  973.   end;
  974. end;
  975.  
  976. function TIBDatabase.TestConnected: Boolean;
  977. var
  978.   DatabaseInfo: TIBDatabaseInfo;
  979. begin
  980.   result := Connected;
  981.   if result then begin
  982.     DatabaseInfo := TIBDatabaseInfo.Create(self);
  983.     try begin
  984.         DatabaseInfo.Database := self;
  985.         { poke the server to see if connected }
  986.         if DatabaseInfo.BaseLevel = 0 then ;
  987.         DatabaseInfo.Free;
  988.       end
  989.     except begin
  990.         ForceClose;
  991.         result := False;
  992.         DatabaseInfo.Free;
  993.       end;
  994.     end;
  995.   end;
  996. end;
  997.  
  998. procedure TIBDatabase.TimeoutConnection(Sender: TObject);
  999. begin
  1000.   if Connected then begin
  1001.     if FCanTimeout then begin
  1002.       ForceClose;
  1003.       if Assigned(FOnIdleTimer) then
  1004.         FOnIdleTimer(Self);
  1005.     end else begin
  1006.       FCanTimeout := True;
  1007.     end;
  1008.   end;
  1009. end;
  1010.  
  1011. function TIBDatabase.GetIsReadOnly: Boolean;
  1012. var
  1013.   DatabaseInfo: TIBDatabaseInfo;
  1014. begin
  1015.   DatabaseInfo := TIBDatabaseInfo.Create(self);
  1016.   DatabaseInfo.Database := self;
  1017.   if (DatabaseInfo.ODSMajorVersion < 10) then
  1018.     result := false
  1019.   else begin
  1020.     if (DatabaseInfo.ReadOnly = 0) then
  1021.       result := false
  1022.     else
  1023.       result := true;
  1024.   end;
  1025.   DatabaseInfo.Free;
  1026. end;
  1027.  
  1028. function TIBDatabase.GetSQLDialect: Integer;
  1029. begin
  1030.   Result := FSQLDialect;
  1031. end;
  1032.  
  1033. procedure TIBDatabase.SetSQLDialect(const Value: Integer);
  1034. begin
  1035.   if (Value < 1) then IBError(ibxeSQLDialectInvalid, [nil]);
  1036.   if ((FHandle = nil) or (Value <= FDBSQLDialect))  then
  1037.     FSQLDialect := Value
  1038.   else
  1039.     IBError(ibxeSQLDialectInvalid, [nil]);
  1040. end;
  1041.  
  1042. function TIBDatabase.GetDBSQLDialect: Integer;
  1043. var
  1044.   DatabaseInfo: TIBDatabaseInfo;
  1045. begin
  1046.   DatabaseInfo := TIBDatabaseInfo.Create(self);
  1047.   DatabaseInfo.Database := self;
  1048.   result := DatabaseInfo.DBSQLDialect;
  1049.   DatabaseInfo.Free;
  1050. end;
  1051.  
  1052. procedure TIBDatabase.ValidateClientSQLDialect;
  1053. begin
  1054.   if (FDBSQLDialect < FSQLDialect) then
  1055.   begin
  1056.     FSQLDialect := FDBSQLDialect;
  1057.     if Assigned (FOnDialectDowngradeWarning) then
  1058.       FOnDialectDowngradeWarning(self);
  1059.   end;
  1060. end;
  1061.  
  1062. procedure TIBDatabase.SetTraceFlags(const Value: TTraceFlags);
  1063. begin
  1064.   if FTraceFlags <> Value then
  1065.     MonitorHook.TraceFlags := Value;
  1066.   FTraceFlags := Value;
  1067. end;
  1068.  
  1069. procedure TIBDatabase.ApplyUpdates(const DataSets: array of TDataSet);
  1070. var
  1071.   I: Integer;
  1072.   DS: TIBCustomDataSet;
  1073.   TR: TIBTransaction;
  1074. begin
  1075.   TR := nil;
  1076.   for I := 0 to High(DataSets) do
  1077.   begin
  1078.     DS := TIBCustomDataSet(DataSets[I]);
  1079.     if DS.Database <> Self then
  1080.       IBError(ibxeUpdateWrongDB, [nil]);
  1081.     if TR = nil then
  1082.       TR := DS.Transaction;
  1083.     if (DS.Transaction <> TR) or (TR = nil) then
  1084.       IBError(ibxeUpdateWrongTR, [nil]);
  1085.   end;
  1086.   TR.CheckInTransaction;
  1087.   for I := 0 to High(DataSets) do
  1088.   begin
  1089.     DS := TIBCustomDataSet(DataSets[I]);
  1090.     DS.ApplyUpdates;
  1091.   end;
  1092.   TR.CommitRetaining;
  1093. end;
  1094.  
  1095. procedure TIBDatabase.CloseDataSets;
  1096. var
  1097.   i: Integer;
  1098. begin
  1099.   for i := 0 to DataSetCount - 1 do
  1100.     if (DataSets[i] <> nil) then
  1101.       DataSets[i].close;
  1102. end;
  1103.  
  1104. procedure TIBDatabase.GetFieldNames(const TableName: string; List: TStrings);
  1105. var
  1106.   Query: TIBSQL;
  1107. begin
  1108.   if TableName = '' then IBError(ibxeNoTableName, [nil]);
  1109.   if not Connected then Open;
  1110.   if not FInternalTransaction.Active then FInternalTransaction.StartTransaction;
  1111.   Query := TIBSQL.Create(self);
  1112.   try
  1113.     Query.GoToFirstRecordOnExecute := False;
  1114.     Query.Database := Self;
  1115.     Query.Transaction := FInternalTransaction;
  1116.     Query.SQL.Text := 'Select R.RDB$FIELD_NAME ' + {do not localize}
  1117.       'from RDB$RELATION_FIELDS R, RDB$FIELDS F ' + {do not localize}
  1118.       'where R.RDB$RELATION_NAME = ' + {do not localize}
  1119.       '''' +
  1120.       FormatIdentifierValue(SQLDialect, TableName) +
  1121.       ''' ' +
  1122.       'and R.RDB$FIELD_SOURCE = F.RDB$FIELD_NAME '; {do not localize}
  1123.     Query.Prepare;
  1124.     Query.ExecQuery;
  1125.     with List do
  1126.     begin
  1127.       BeginUpdate;
  1128.       try
  1129.         Clear;
  1130.         while (not Query.EOF) and (Query.Next <> nil) do
  1131.           List.Add(TrimRight(Query.Current.ByName('RDB$FIELD_NAME').AsString)); {do not localize}
  1132.       finally
  1133.         EndUpdate;
  1134.       end;
  1135.     end;
  1136.   finally
  1137.     Query.free;
  1138.     FInternalTransaction.Commit;
  1139.   end;
  1140. end;
  1141.  
  1142. procedure TIBDatabase.GetTableNames(List: TStrings; SystemTables: Boolean);
  1143. var
  1144.   Query : TIBSQL;
  1145. begin
  1146.   if not (csReading in ComponentState) then begin
  1147.   if not Connected then Open;
  1148.   if not FInternalTransaction.Active then FInternalTransaction.StartTransaction;
  1149.     Query := TIBSQL.Create(self);
  1150.     try
  1151.       Query.GoToFirstRecordOnExecute := False;
  1152.       Query.Database := Self;
  1153.       Query.Transaction := FInternalTransaction;
  1154.       if SystemTables then
  1155.         Query.SQL.Text := 'Select RDB$RELATION_NAME from RDB$RELATIONS' + {do not localize}
  1156.                           ' where RDB$VIEW_BLR is NULL' {do not localize}
  1157.       else
  1158.         Query.SQL.Text := 'Select RDB$RELATION_NAME from RDB$RELATIONS' + {do not localize}
  1159.                           ' where RDB$VIEW_BLR is NULL and RDB$SYSTEM_FLAG = 0'; {do not localize}
  1160.       Query.Prepare;
  1161.       Query.ExecQuery;
  1162.       with List do
  1163.       begin
  1164.         BeginUpdate;
  1165.         try
  1166.           Clear;
  1167.           while (not Query.EOF) and (Query.Next <> nil) do
  1168.             List.Add(TrimRight(Query.Current[0].AsString));
  1169.         finally
  1170.           EndUpdate;
  1171.         end;
  1172.       end;
  1173.     finally
  1174.       Query.Free;
  1175.       FInternalTransaction.Commit;
  1176.     end;
  1177.   end;
  1178. end;
  1179.  
  1180. { TIBTransaction }
  1181.  
  1182. constructor TIBTransaction.Create(AOwner: TComponent);
  1183. begin
  1184.   inherited Create(AOwner);
  1185.   FIBLoaded := False;
  1186.   CheckIBLoaded;
  1187.   FIBLoaded := True;
  1188.   CheckIBLoaded;
  1189.   FDatabases                           := TList.Create;
  1190.   FSQLObjects                            := TList.Create;
  1191.   FHandle                              := nil;
  1192.   FTPB                                 := nil;
  1193.   FTPBLength                           := 0;
  1194.   FTRParams                            := TStringList.Create;
  1195.   FTRParamsChanged                     := True;
  1196.   TStringList(FTRParams).OnChange      := TRParamsChange;
  1197.   TStringList(FTRParams).OnChanging    := TRParamsChanging;
  1198.   FTimer                               := TTimer.Create(Self);
  1199.   FTimer.Enabled                       := False;
  1200.   FTimer.Interval                      := 0;
  1201.   FTimer.OnTimer                       := TimeoutTransaction;
  1202.   FDefaultAction                       := taCommit;
  1203. end;
  1204.  
  1205. destructor TIBTransaction.Destroy;
  1206. var
  1207.   i: Integer;
  1208. begin
  1209.   if FIBLoaded then
  1210.   begin
  1211.     if InTransaction then
  1212.       EndTransaction(FDefaultAction, True);
  1213.     for i := 0 to FSQLObjects.Count - 1 do if FSQLObjects[i] <> nil then
  1214.       SQLObjects[i].DoTransactionFree;
  1215.     RemoveSQLObjects;
  1216.     RemoveDatabases;
  1217.     IBAlloc(FTPB, 0, 0);
  1218.     FTRParams.Free;
  1219.     FSQLObjects.Free;
  1220.     FDatabases.Free;
  1221.   end;
  1222.   inherited Destroy;
  1223. end;
  1224.  
  1225. function TIBTransaction.Call(ErrCode: ISC_STATUS;
  1226.   RaiseError: Boolean): ISC_STATUS;
  1227. var
  1228.   i: Integer;
  1229. begin
  1230.   result := ErrCode;
  1231.   for i := 0 to FDatabases.Count - 1 do if FDatabases[i] <> nil then
  1232.     Databases[i].FCanTimeout := False;
  1233.   FCanTimeout := False;
  1234.   if RaiseError and (result > 0) then
  1235.     IBDataBaseError;
  1236. end;
  1237.  
  1238. procedure TIBTransaction.CheckDatabasesInList;
  1239. begin
  1240.   if GetDatabaseCount = 0 then
  1241.     IBError(ibxeNoDatabasesInTransaction, [nil]);
  1242. end;
  1243.  
  1244. procedure TIBTransaction.CheckInTransaction;
  1245. begin
  1246.   if FStreamedActive and (not InTransaction) then
  1247.     Loaded;
  1248.   if (FHandle = nil) then
  1249.     IBError(ibxeNotInTransaction, [nil]);
  1250. end;
  1251.  
  1252. procedure TIBTransaction.EnsureNotInTransaction;
  1253. begin
  1254.   if csDesigning in ComponentState then
  1255.   begin
  1256.     if FHandle <> nil then
  1257.       Rollback;
  1258.   end;
  1259. end;
  1260.  
  1261. procedure TIBTransaction.CheckNotInTransaction;
  1262. begin
  1263.   if (FHandle <> nil) then
  1264.     IBError(ibxeInTransaction, [nil]);
  1265. end;
  1266.  
  1267. function TIBTransaction.AddDatabase(db: TIBDatabase): Integer;
  1268. var
  1269.   i: Integer;
  1270.   nil_found: Boolean;
  1271. begin
  1272.   i := FindDatabase(db);
  1273.   if i <> -1 then begin
  1274.     result := i;
  1275.     exit;
  1276.   end;
  1277.   nil_found := False;
  1278.   i := 0;
  1279.   while (not nil_found) and (i < FDatabases.Count) do begin
  1280.     nil_found := (FDatabases[i] = nil);
  1281.     if (not nil_found) then Inc(i);
  1282.   end;
  1283.   if (nil_found) then begin
  1284.     FDatabases[i] := db;
  1285.     result := i;
  1286.   end else begin
  1287.     result := FDatabases.Count;
  1288.     FDatabases.Add(db);
  1289.   end;
  1290. end;
  1291.  
  1292. function TIBTransaction.AddSQLObject(ds: TIBBase): Integer;
  1293. begin
  1294.   result := 0;
  1295.   while (result < FSQLObjects.Count) and (FSQLObjects[result] <> nil) do
  1296.     Inc(result);
  1297.   if (result = FSQLObjects.Count) then
  1298.     FSQLObjects.Add(ds)
  1299.   else
  1300.     FSQLObjects[result] := ds;
  1301. end;
  1302.  
  1303. procedure TIBTransaction.Commit;
  1304. begin
  1305.   EndTransaction(TACommit, False);
  1306. end;
  1307.  
  1308. procedure TIBTransaction.CommitRetaining;
  1309. begin
  1310.   EndTransaction(TACommitRetaining, False);
  1311. end;
  1312.  
  1313. procedure TIBTransaction.EndTransaction(Action: TTransactionAction;
  1314.   Force: Boolean);
  1315. var
  1316.   status: ISC_STATUS;
  1317.   i: Integer;
  1318. begin
  1319.   CheckInTransaction;
  1320.   case Action of
  1321.     TARollback, TACommit: begin
  1322.       if (HandleIsShared) and
  1323.          (Action <> FDefaultAction) and
  1324.          (not Force) then
  1325.         IBError(ibxeCantEndSharedTransaction, [nil]);
  1326.       for i := 0 to FSQLObjects.Count - 1 do if FSQLObjects[i] <> nil then
  1327.         SQLObjects[i].DoBeforeTransactionEnd;
  1328.       if InTransaction then
  1329.       begin
  1330.         if HandleIsShared then begin
  1331.           FHandle := nil;
  1332.           FHandleIsShared := False;
  1333.           status := 0;
  1334.         end else if (Action = TARollback) then
  1335.           status := Call(isc_rollback_transaction(StatusVector, @FHandle), False)
  1336.         else
  1337.           status := Call(isc_commit_transaction(StatusVector, @FHandle), False);
  1338.         if ((Force) and (status > 0)) then
  1339.           status := Call(isc_rollback_transaction(StatusVector, @FHandle), False);
  1340.         if Force then
  1341.           FHandle := nil
  1342.         else if (status > 0) then
  1343.           IBDataBaseError;
  1344.         for i := 0 to FSQLObjects.Count - 1 do if FSQLObjects[i] <> nil then
  1345.           SQLObjects[i].DoAfterTransactionEnd;
  1346.       end;
  1347.     end;
  1348.     TACommitRetaining:
  1349.       Call(isc_commit_retaining(StatusVector, @FHandle), True);
  1350.     TARollbackRetaining:
  1351.       Call(isc_rollback_retaining(StatusVector, @FHandle), True);
  1352.   end;
  1353.   case Action of
  1354.     TACommit:
  1355.       MonitorHook.TRCommit(Self);
  1356.     TARollback:
  1357.       MonitorHook.TRRollback(Self);
  1358.     TACommitRetaining:
  1359.       MonitorHook.TRCommitRetaining(Self);
  1360.     TARollbackRetaining:
  1361.       MonitorHook.TRRollbackRetaining(Self);
  1362.   end;
  1363. end;
  1364.  
  1365. function TIBTransaction.GetDatabase(Index: Integer): TIBDatabase;
  1366. begin
  1367.   result := FDatabases[Index];
  1368. end;
  1369.  
  1370. function TIBTransaction.GetDatabaseCount: Integer;
  1371. var
  1372.   i, Cnt: Integer;
  1373. begin
  1374.   result := 0;
  1375.   Cnt := FDatabases.Count - 1;
  1376.   for i := 0 to Cnt do if FDatabases[i] <> nil then
  1377.     Inc(result);
  1378. end;
  1379.  
  1380. function TIBTransaction.GetSQLObject(Index: Integer): TIBBase;
  1381. begin
  1382.   result := FSQLObjects[Index];
  1383. end;
  1384.  
  1385. function TIBTransaction.GetSQLObjectCount: Integer;
  1386. var
  1387.   i, Cnt: Integer;
  1388. begin
  1389.   result := 0;
  1390.   Cnt := FSQLObjects.Count - 1;
  1391.   for i := 0 to Cnt do if FSQLObjects[i] <> nil then
  1392.     Inc(result);
  1393. end;
  1394.  
  1395. function TIBTransaction.GetInTransaction: Boolean;
  1396. begin
  1397.   result := (FHandle <> nil);
  1398. end;
  1399.  
  1400. function TIBTransaction.FindDatabase(db: TIBDatabase): Integer;
  1401. var
  1402.   i: Integer;
  1403. begin
  1404.   result := -1;
  1405.   for i := 0 to FDatabases.Count - 1 do
  1406.     if db = TIBDatabase(FDatabases[i]) then begin
  1407.       result := i;
  1408.       break;
  1409.     end;
  1410. end;
  1411.  
  1412. function TIBTransaction.FindDefaultDatabase: TIBDatabase;
  1413. var
  1414.   i: Integer;
  1415. begin
  1416.   result := FDefaultDatabase;
  1417.   if result = nil then
  1418.   begin
  1419.     for i := 0 to FDatabases.Count - 1 do
  1420.       if (TIBDatabase(FDatabases[i]) <> nil) and
  1421.         (TIBDatabase(FDatabases[i]).DefaultTransaction = self) then begin
  1422.         result := TIBDatabase(FDatabases[i]);
  1423.         break;
  1424.       end;
  1425.   end;
  1426. end;
  1427.  
  1428.  
  1429. function TIBTransaction.GetIdleTimer: Integer;
  1430. begin
  1431.   result := FTimer.Interval;
  1432. end;
  1433.  
  1434. procedure TIBTransaction.Loaded;
  1435. begin
  1436.   inherited Loaded;
  1437. end;
  1438.  
  1439. procedure TIBTransaction.BeforeDatabaseDisconnect(DB: TIBDatabase);
  1440. begin
  1441.   if InTransaction then
  1442.     EndTransaction(FDefaultAction, True);
  1443. end;
  1444.  
  1445. procedure TIBTransaction.RemoveDatabase(Idx: Integer);
  1446. var
  1447.   DB: TIBDatabase;
  1448. begin
  1449.   if ((Idx >= 0) and (FDatabases[Idx] <> nil)) then begin
  1450.     DB := Databases[Idx];
  1451.     FDatabases[Idx] := nil;
  1452.     DB.RemoveTransaction(DB.FindTransaction(Self));
  1453.     if DB = FDefaultDatabase then
  1454.       FDefaultDatabase := nil;
  1455.   end;
  1456. end;
  1457.  
  1458. procedure TIBTransaction.RemoveDatabases;
  1459. var
  1460.   i: Integer;
  1461. begin
  1462.   for i := 0 to FDatabases.Count - 1 do if FDatabases[i] <> nil then
  1463.     RemoveDatabase(i);
  1464. end;
  1465.  
  1466. procedure TIBTransaction.RemoveSQLObject(Idx: Integer);
  1467. var
  1468.   ds: TIBBase;
  1469. begin
  1470.   if ((Idx >= 0) and (FSQLObjects[Idx] <> nil)) then begin
  1471.     ds := SQLObjects[Idx];
  1472.     FSQLObjects[Idx] := nil;
  1473.     ds.Transaction := nil;
  1474.   end;
  1475. end;
  1476.  
  1477. procedure TIBTransaction.RemoveSQLObjects;
  1478. var
  1479.   i: Integer;
  1480. begin
  1481.   for i := 0 to FSQLObjects.Count - 1 do if FSQLObjects[i] <> nil then
  1482.     RemoveSQLObject(i);
  1483. end;
  1484.  
  1485. procedure TIBTransaction.Rollback;
  1486. begin
  1487.   EndTransaction(TARollback, False);
  1488. end;
  1489.  
  1490. procedure TIBTransaction.RollbackRetaining;
  1491. begin
  1492.   EndTransaction(TARollbackRetaining, False);
  1493. end;
  1494.  
  1495. procedure TIBTransaction.SetActive(Value: Boolean);
  1496. begin
  1497.   if csReading in ComponentState then
  1498.     FStreamedActive := Value
  1499.   else if Value and not InTransaction then
  1500.     StartTransaction
  1501.   else if not Value and InTransaction then
  1502.     Rollback;
  1503. end;
  1504.  
  1505. procedure TIBTransaction.SetDefaultAction(Value: TTransactionAction);
  1506. begin
  1507.   if (Value = taRollbackRetaining) and (GetIBClientVersion < 6) then
  1508.     IBError(ibxeIB60feature, [nil]);
  1509.   FDefaultAction := Value;
  1510. end;
  1511.  
  1512. procedure TIBTransaction.SetDefaultDatabase(Value: TIBDatabase);
  1513. var
  1514.   i: integer;
  1515. begin
  1516.   if (FDefaultDatabase <> nil) and (FDefaultDatabase <> Value) then
  1517.   begin
  1518.     i := FDefaultDatabase.FindTransaction(self);
  1519.     if (i <> -1) then
  1520.       FDefaultDatabase.RemoveTransaction(i);
  1521.   end;
  1522.   if (Value <> nil) and (FDefaultDatabase <> Value) then begin
  1523.     Value.AddTransaction(Self);
  1524.     AddDatabase(Value);
  1525.   end;
  1526.   FDefaultDatabase := Value;
  1527. end;
  1528.  
  1529. procedure TIBTransaction.SetHandle(Value: TISC_TR_HANDLE);
  1530. begin
  1531.   if (HandleIsShared) then
  1532.     EndTransaction(DefaultAction, True)
  1533.   else
  1534.     CheckNotInTransaction;
  1535.   FHandle := Value;
  1536.   FHandleIsShared := (Value <> nil);
  1537. end;
  1538.  
  1539. procedure TIBTransaction.Notification( AComponent: TComponent;
  1540.                                         Operation: TOperation);
  1541. var
  1542.   i: Integer;
  1543. begin
  1544.   inherited Notification( AComponent, Operation);
  1545.   if (Operation = opRemove) and (AComponent = FDefaultDatabase) then
  1546.   begin
  1547.     i := FindDatabase(FDefaultDatabase);
  1548.     if (i <> -1) then
  1549.       RemoveDatabase(i);
  1550.     FDefaultDatabase := nil;
  1551.   end;
  1552. end;
  1553.  
  1554. procedure TIBTransaction.SetIdleTimer(Value: Integer);
  1555. begin
  1556.   if Value < 0 then
  1557.     IBError(ibxeTimeoutNegative, [nil])
  1558.   else if (Value = 0) then begin
  1559.     FTimer.Enabled := False;
  1560.     FTimer.Interval := 0;
  1561.   end else if (Value > 0) then begin
  1562.     FTimer.Interval := Value;
  1563.     if not (csDesigning in ComponentState) then
  1564.       FTimer.Enabled := True;
  1565.   end;
  1566. end;
  1567.  
  1568. procedure TIBTransaction.SetTRParams(Value: TStrings);
  1569. begin
  1570.   FTRParams.Assign(Value);
  1571. end;
  1572.  
  1573. procedure TIBTransaction.StartTransaction;
  1574. var
  1575.   pteb: PISC_TEB_ARRAY;
  1576.   TPB: String;
  1577.   i: Integer;
  1578. begin
  1579.   CheckNotInTransaction;
  1580.   CheckDatabasesInList;
  1581.   for i := 0 to FDatabases.Count - 1 do
  1582.    if  FDatabases[i] <> nil then
  1583.    begin
  1584.      with TIBDatabase(FDatabases[i]) do
  1585.      if not Connected then
  1586.        if FStreamedConnected then begin
  1587.          Open;
  1588.          FStreamedConnected := False;
  1589.        end else
  1590.          IBError(ibxeDatabaseClosed, [nil]);
  1591.    end;
  1592.   if FTRParamsChanged then begin
  1593.     FTRParamsChanged := False;
  1594.     GenerateTPB(FTRParams, TPB, FTPBLength);
  1595.     IBAlloc(FTPB, 0, FTPBLength);
  1596.     Move(TPB[1], FTPB[0], FTPBLength);
  1597.   end;
  1598.  
  1599.   pteb := nil;
  1600.   IBAlloc(pteb, 0, DatabaseCount * SizeOf(TISC_TEB));
  1601.   try
  1602.     for i := 0 to DatabaseCount - 1 do if Databases[i] <> nil then begin
  1603.       pteb^[i].db_handle := @(Databases[i].Handle);
  1604.       pteb^[i].tpb_length := FTPBLength;
  1605.       pteb^[i].tpb_address := FTPB;
  1606.     end;
  1607.     if Call(isc_start_multiple(StatusVector, @FHandle,
  1608.                                DatabaseCount, PISC_TEB(pteb)), False) > 0 then begin
  1609.       FHandle := nil;
  1610.       IBDataBaseError;
  1611.     end;
  1612.     MonitorHook.TRStart(Self);
  1613.   finally
  1614.     IBAlloc(pteb, 0, 0);
  1615.   end;
  1616. end;
  1617.  
  1618. procedure TIBTransaction.TimeoutTransaction(Sender: TObject);
  1619. begin
  1620.   if InTransaction then begin
  1621.     if FCanTimeout then begin
  1622.       EndTransaction(FDefaultAction, True);
  1623.       if Assigned(FOnIdleTimer) then
  1624.         FOnIdleTimer(Self);
  1625.     end else begin
  1626.       FCanTimeout := True;
  1627.     end;
  1628.   end;
  1629. end;
  1630.  
  1631. procedure TIBTransaction.TRParamsChange(Sender: TObject);
  1632. begin
  1633.   FTRParamsChanged := True;
  1634. end;
  1635.  
  1636. procedure TIBTransaction.TRParamsChanging(Sender: TObject);
  1637. begin
  1638.   EnsureNotInTransaction;
  1639.   CheckNotInTransaction;
  1640. end;
  1641.  
  1642. { TIBBase }
  1643. constructor TIBBase.Create(AOwner: TObject);
  1644. begin
  1645.   FOwner := AOwner;
  1646. end;
  1647.  
  1648. destructor TIBBase.Destroy;
  1649. begin
  1650.   SetDatabase(nil);
  1651.   SetTransaction(nil);
  1652.   inherited;
  1653. end;
  1654.  
  1655. procedure TIBBase.CheckDatabase;
  1656. begin
  1657.   if (FDatabase = nil) then IBError(ibxeDatabaseNotAssigned, [nil]);
  1658.   FDatabase.CheckActive;
  1659. end;
  1660.  
  1661. procedure TIBBase.CheckTransaction;
  1662. begin
  1663.   if FTransaction = nil then IBError(ibxeTransactionNotAssigned, [nil]);
  1664.   FTransaction.CheckInTransaction;
  1665. end;
  1666.  
  1667. function TIBBase.GetDBHandle: PISC_DB_HANDLE;
  1668. begin
  1669.   CheckDatabase;
  1670.   result := @FDatabase.Handle;
  1671. end;
  1672.  
  1673. function TIBBase.GetTRHandle: PISC_TR_HANDLE;
  1674. begin
  1675.   CheckTransaction;
  1676.   result := @FTransaction.Handle;
  1677. end;
  1678.  
  1679. procedure TIBBase.DoBeforeDatabaseDisconnect;
  1680. begin
  1681.   if Assigned(BeforeDatabaseDisconnect) then
  1682.     BeforeDatabaseDisconnect(Self);
  1683. end;
  1684.  
  1685. procedure TIBBase.DoAfterDatabaseDisconnect;
  1686. begin
  1687.   if Assigned(AfterDatabaseDisconnect) then
  1688.     AfterDatabaseDisconnect(Self);
  1689. end;
  1690.  
  1691. procedure TIBBase.DoDatabaseFree;
  1692. begin
  1693.   if Assigned(OnDatabaseFree) then
  1694.     OnDatabaseFree(Self);
  1695.   SetDatabase(nil);
  1696.   SetTransaction(nil);
  1697. end;
  1698.  
  1699. procedure TIBBase.DoBeforeTransactionEnd;
  1700. begin
  1701.   if Assigned(BeforeTransactionEnd) then
  1702.     BeforeTransactionEnd(Self);
  1703. end;
  1704.  
  1705. procedure TIBBase.DoAfterTransactionEnd;
  1706. begin
  1707.   if Assigned(AfterTransactionEnd) then
  1708.     AfterTransactionEnd(Self);
  1709. end;
  1710.  
  1711. procedure TIBBase.DoTransactionFree;
  1712. begin
  1713.   if Assigned(OnTransactionFree) then
  1714.     OnTransactionFree(Self);
  1715.   FTransaction := nil;
  1716. end;
  1717.  
  1718. procedure TIBBase.SetDatabase(Value: TIBDatabase);
  1719. begin
  1720.   if (FDatabase <> nil) then
  1721.     FDatabase.RemoveSQLObject(FIndexInDatabase);
  1722.   FDatabase := Value;
  1723.   if (FDatabase <> nil) then begin
  1724.     FIndexInDatabase := FDatabase.AddSQLObject(Self);
  1725.     if (FTransaction = nil) then
  1726.       Transaction := FDatabase.FindDefaultTransaction;
  1727.   end;
  1728. end;
  1729.  
  1730. procedure TIBBase.SetTransaction(Value: TIBTransaction);
  1731. begin
  1732.   if (FTransaction <> nil) then
  1733.     FTransaction.RemoveSQLObject(FIndexInTransaction);
  1734.   FTransaction := Value;
  1735.   if (FTransaction <> nil) then
  1736.   begin
  1737.     FIndexInTransaction := FTransaction.AddSQLObject(Self);
  1738.     if (FDatabase = nil) then
  1739.       Database := FTransaction.FindDefaultDatabase;
  1740.   end;
  1741. end;
  1742.  
  1743. { GenerateDPB -
  1744.   Given a string containing a textual representation
  1745.   of the database parameters, generate a database
  1746.   parameter buffer, and return it and its length
  1747.   in DPB and DPBLength, respectively. }
  1748.  
  1749. procedure GenerateDPB(sl: TStrings; var DPB: string; var DPBLength: Short);
  1750. var
  1751.   i, j, pval: Integer;
  1752.   DPBVal: UShort;
  1753.   param_name, param_value: string;
  1754. begin
  1755.   { The DPB is initially empty, with the exception that
  1756.     the DPB version must be the first byte of the string. }
  1757.   DPBLength := 1;
  1758.   DPB := Char(isc_dpb_version1);
  1759.  
  1760.   {Iterate through the textual database parameters, constructing
  1761.    a DPB on-the-fly }
  1762.   for i := 0 to sl.Count - 1 do
  1763.   begin
  1764.     { Get the parameter's name and value from the list,
  1765.       and make sure that the name is all lowercase with
  1766.       no leading 'isc_dpb_' prefix
  1767.     }
  1768.     if (Trim(sl.Names[i]) = '') then continue;
  1769.     param_name := LowerCase(sl.Names[i]); {mbcs ok}
  1770.     param_value := Copy(sl[i], Pos('=', sl[i]) + 1, Length(sl[i])); {mbcs ok}
  1771.     if (Pos(DPBPrefix, param_name) = 1) then {mbcs ok}
  1772.       Delete(param_name, 1, Length(DPBPrefix));
  1773.      { We want to translate the parameter name to some Integer
  1774.        value. We do this by scanning through a list of known
  1775.        database parameter names (DPBConstantNames, defined above) }
  1776.     DPBVal := 0;
  1777.     { Find the parameter }
  1778.     for j := 1 to isc_dpb_last_dpb_constant do
  1779.       if (param_name = DPBConstantNames[j]) then
  1780.       begin
  1781.         DPBVal := j;
  1782.         break;
  1783.       end;
  1784.      {  A database parameter either contains a string value (case 1)
  1785.        or an Integer value (case 2)
  1786.        or no value at all (case 3)
  1787.        or an error needs to be generated (case else)  }
  1788.     case DPBVal of
  1789.       isc_dpb_user_name, isc_dpb_password, isc_dpb_password_enc,
  1790.       isc_dpb_sys_user_name, isc_dpb_license, isc_dpb_encrypt_key,
  1791.       isc_dpb_lc_messages, isc_dpb_lc_ctype,
  1792.       isc_dpb_sql_role_name:
  1793.       begin
  1794.         DPB := DPB +
  1795.                Char(DPBVal) +
  1796.                Char(Length(param_value)) +
  1797.                param_value;
  1798.         Inc(DPBLength, 2 + Length(param_value));
  1799.       end;
  1800.       isc_dpb_num_buffers, isc_dpb_dbkey_scope, isc_dpb_force_write,
  1801.       isc_dpb_no_reserve, isc_dpb_damaged, isc_dpb_verify:
  1802.       begin
  1803.         DPB := DPB +
  1804.                Char(DPBVal) +
  1805.                #1 +
  1806.                Char(StrToInt(param_value));
  1807.         Inc(DPBLength, 3);
  1808.       end;
  1809.       isc_dpb_sweep:
  1810.       begin
  1811.         DPB := DPB +
  1812.                Char(DPBVal) +
  1813.                #1 +
  1814.                Char(isc_dpb_records);
  1815.         Inc(DPBLength, 3);
  1816.       end;
  1817.       isc_dpb_sweep_interval:
  1818.       begin
  1819.         pval := StrToInt(param_value);
  1820.         DPB := DPB +
  1821.                Char(DPBVal) +
  1822.                #4 +
  1823.                PChar(@pval)[0] +
  1824.                PChar(@pval)[1] +
  1825.                PChar(@pval)[2] +
  1826.                PChar(@pval)[3];
  1827.         Inc(DPBLength, 6);
  1828.       end;
  1829.       isc_dpb_activate_shadow, isc_dpb_delete_shadow, isc_dpb_begin_log,
  1830.       isc_dpb_quit_log:
  1831.       begin
  1832.         DPB := DPB +
  1833.                Char(DPBVal) +
  1834.                #1 + #0;
  1835.         Inc(DPBLength, 3);
  1836.       end;
  1837.       else begin
  1838.         if (DPBVal > 0) and
  1839.            (DPBVal <= isc_dpb_last_dpb_constant) then
  1840.           IBError(ibxeDPBConstantNotSupported, [DPBConstantNames[DPBVal]])
  1841.         else
  1842.           IBError(ibxeDPBConstantUnknown, [DPBVal]);
  1843.       end;
  1844.     end;
  1845.   end;
  1846. end;
  1847.  
  1848. { GenerateTPB -
  1849.   Given a string containing a textual representation
  1850.   of the transaction parameters, generate a transaction
  1851.   parameter buffer, and return it and its length in
  1852.   TPB and TPBLength, respectively. }
  1853. procedure GenerateTPB(sl: TStrings; var TPB: string; var TPBLength: Short);
  1854. var
  1855.   i, j, TPBVal, ParamLength: Integer;
  1856.   param_name, param_value: string;
  1857. begin
  1858.   TPB := '';
  1859.   if (sl.Count = 0) then
  1860.     TPBLength := 0
  1861.   else begin
  1862.     TPBLength := sl.Count + 1;
  1863.     TPB := TPB + Char(isc_tpb_version3);
  1864.   end;
  1865.   for i := 0 to sl.Count - 1 do
  1866.   begin
  1867.     if (Trim(sl[i]) =  '') then
  1868.     begin
  1869.       Dec(TPBLength);
  1870.       Continue;
  1871.     end;
  1872.     if (Pos('=', sl[i]) = 0) then {mbcs ok}
  1873.       param_name := LowerCase(sl[i]) {mbcs ok}
  1874.     else begin
  1875.       param_name := LowerCase(sl.Names[i]); {mbcs ok}
  1876.       param_value := Copy(sl[i], Pos('=', sl[i]) + 1, Length(sl[i])); {mbcs ok}
  1877.     end;
  1878.     if (Pos(TPBPrefix, param_name) = 1) then {mbcs ok}
  1879.       Delete(param_name, 1, Length(TPBPrefix));
  1880.     TPBVal := 0;
  1881.     { Find the parameter }
  1882.     for j := 1 to isc_tpb_last_tpb_constant do
  1883.       if (param_name = TPBConstantNames[j]) then
  1884.       begin
  1885.         TPBVal := j;
  1886.         break;
  1887.       end;
  1888.     { Now act on it }
  1889.     case TPBVal of
  1890.       isc_tpb_consistency, isc_tpb_exclusive, isc_tpb_concurrency,
  1891.       isc_tpb_shared, isc_tpb_wait, isc_tpb_nowait, isc_tpb_read,
  1892.       isc_tpb_write, isc_tpb_ignore_limbo, isc_tpb_read_committed,
  1893.       isc_tpb_rec_version, isc_tpb_no_rec_version:
  1894.         TPB := TPB + Char(TPBVal);
  1895.       isc_tpb_lock_read, isc_tpb_lock_write:
  1896.       begin
  1897.         TPB := TPB + Char(TPBVal);
  1898.         { Now set the string parameter }
  1899.         ParamLength := Length(param_value);
  1900.         Inc(TPBLength, ParamLength + 1);
  1901.         TPB := TPB + Char(ParamLength) + param_value;
  1902.       end;
  1903.       else begin
  1904.         if (TPBVal > 0) and
  1905.            (TPBVal <= isc_tpb_last_tpb_constant) then
  1906.           IBError(ibxeTPBConstantNotSupported, [TPBConstantNames[TPBVal]])
  1907.         else
  1908.           IBError(ibxeTPBConstantUnknown, [TPBVal]);
  1909.       end;
  1910.     end;
  1911.   end;
  1912. end;
  1913.  
  1914. end.
  1915.  
  1916.  
  1917.  
  1918.  
  1919.  
  1920.