ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBDatabase.pas
Revision: 39
Committed: Tue May 17 08:14:52 2016 UTC (8 years, 6 months ago) by tony
Content type: text/x-pascal
File size: 69819 byte(s)
Log Message: 
Committing updates for Release R1-4-1

File Contents

# User Rev Content
1 tony 33 {************************************************************************}
2     { }
3     { Borland Delphi Visual Component Library }
4     { InterBase Express core components }
5     { }
6     { Copyright (c) 1998-2000 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     { The contents of this file are subject to the InterBase }
14     { Public License Version 1.0 (the "License"); you may not }
15     { use this file except in compliance with the License. You }
16     { may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17     { Software distributed under the License is distributed on }
18     { an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
19     { express or implied. See the License for the specific language }
20     { governing rights and limitations under the License. }
21     { The Original Code was created by InterBase Software Corporation }
22     { and its successors. }
23     { Portions created by Inprise Corporation are Copyright (C) Inprise }
24     { Corporation. All Rights Reserved. }
25     { Contributor(s): Jeff Overcash }
26     { }
27     { IBX For Lazarus (Firebird Express) }
28     { Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29     { Portions created by MWA Software are copyright McCallum Whyman }
30     { Associates Ltd 2011 }
31     { }
32     {************************************************************************}
33    
34     unit IBDatabase;
35    
36     {$Mode Delphi}
37    
38 tony 39 {$IF FPC_FULLVERSION >= 20700 }
39     {$codepage UTF8}
40     {$DEFINE HAS_ANSISTRING_CODEPAGE}
41     {$ENDIF}
42    
43 tony 33 interface
44    
45     uses
46     {$IFDEF WINDOWS }
47     Windows,
48     {$ELSE}
49     unix,
50     {$ENDIF}
51     SysUtils, Classes, FPTimer, IBHeader, IBExternals, DB,
52     IB, CustApp;
53    
54     const
55     DPBPrefix = 'isc_dpb_';
56     DPBConstantNames: array[1..isc_dpb_last_dpb_constant] of string = (
57     'cdd_pathname',
58     'allocation',
59     'journal',
60     'page_size',
61     'num_buffers',
62     'buffer_length',
63     'debug',
64     'garbage_collect',
65     'verify',
66     'sweep',
67     'enable_journal',
68     'disable_journal',
69     'dbkey_scope',
70     'number_of_users',
71     'trace',
72     'no_garbage_collect',
73     'damaged',
74     'license',
75     'sys_user_name',
76     'encrypt_key',
77     'activate_shadow',
78     'sweep_interval',
79     'delete_shadow',
80     'force_write',
81     'begin_log',
82     'quit_log',
83     'no_reserve',
84     'user_name',
85     'password',
86     'password_enc',
87     'sys_user_name_enc',
88     'interp',
89     'online_dump',
90     'old_file_size',
91     'old_num_files',
92     'old_file',
93     'old_start_page',
94     'old_start_seqno',
95     'old_start_file',
96     'drop_walfile',
97     'old_dump_id',
98     'wal_backup_dir',
99     'wal_chkptlen',
100     'wal_numbufs',
101     'wal_bufsize',
102     'wal_grp_cmt_wait',
103     'lc_messages',
104     'lc_ctype',
105     'cache_manager',
106     'shutdown',
107     'online',
108     'shutdown_delay',
109     'reserved',
110     'overwrite',
111     'sec_attach',
112     'disable_wal',
113     'connect_timeout',
114     'dummy_packet_interval',
115     'gbak_attach',
116     'sql_role_name',
117     'set_page_buffers',
118     'working_directory',
119     'sql_dialect',
120     'set_db_readonly',
121     'set_db_sql_dialect',
122     'gfix_attach',
123     'gstat_attach'
124     );
125    
126     TPBPrefix = 'isc_tpb_';
127     TPBConstantNames: array[1..isc_tpb_last_tpb_constant] of string = (
128     'consistency',
129     'concurrency',
130     'shared',
131     'protected',
132     'exclusive',
133     'wait',
134     'nowait',
135     'read',
136     'write',
137     'lock_read',
138     'lock_write',
139     'verb_time',
140     'commit_time',
141     'ignore_limbo',
142     'read_committed',
143     'autocommit',
144     'rec_version',
145     'no_rec_version',
146     'restart_requests',
147     'no_auto_undo'
148     );
149    
150     type
151    
152     TIBDatabase = class;
153     TIBTransaction = class;
154     TIBBase = class;
155    
156     TIBDatabaseLoginEvent = procedure(Database: TIBDatabase;
157     LoginParams: TStrings) of object;
158    
159     TIBFileName = type string;
160     { TIBDatabase }
161     TIBDataBase = class(TCustomConnection)
162     private
163     FAllowStreamedConnected: boolean;
164     FHiddenPassword: string;
165     FIBLoaded: Boolean;
166     FOnLogin: TIBDatabaseLoginEvent;
167     FSQLHourGlass: Boolean;
168     FTraceFlags: TTraceFlags;
169     FDBSQLDialect: Integer;
170     FSQLDialect: Integer;
171     FOnDialectDowngradeWarning: TNotifyEvent;
172     FCanTimeout: Boolean;
173     FSQLObjects: TList;
174     FTransactions: TList;
175     FDBName: TIBFileName;
176     FDBParams: TStrings;
177     FDBParamsChanged: Boolean;
178     FDPB: PChar;
179     FDPBLength: Short;
180     FHandle: TISC_DB_HANDLE;
181     FHandleIsShared: Boolean;
182     FOnIdleTimer: TNotifyEvent;
183     FDefaultTransaction: TIBTransaction;
184     FInternalTransaction: TIBTransaction;
185     FStreamedConnected: Boolean;
186     FTimer: TFPTimer;
187     FUserNames: TStringList;
188     FDataSets: TList;
189     FLoginCalled: boolean;
190     FCharSetSizes: array of integer;
191 tony 39 FCharSetNames: array of RawByteString;
192     FDefaultCharSetName: RawByteString;
193     {$IFDEF HAS_ANSISTRING_CODEPAGE}
194     FCodePages: array of TSystemCodePage;
195     FDefaultCodePage: TSystemCodePage;
196     {$ENDIF}
197     FUseDefaultSystemCodePage: boolean;
198 tony 33 procedure EnsureInactive;
199     function GetDBSQLDialect: Integer;
200     function GetSQLDialect: Integer;
201     procedure SetSQLDialect(const Value: Integer);
202     procedure ValidateClientSQLDialect;
203     procedure DBParamsChange(Sender: TObject);
204     procedure DBParamsChanging(Sender: TObject);
205     function GetSQLObject(Index: Integer): TIBBase;
206     function GetSQLObjectCount: Integer;
207     function GetDBParamByDPB(const Idx: Integer): String;
208     function GetIdleTimer: Integer;
209     function GetTransaction(Index: Integer): TIBTransaction;
210     function GetTransactionCount: Integer;
211 tony 39 function Login(var aDatabaseName: string): Boolean;
212 tony 33 procedure LoadCharSetInfo;
213     procedure SetDatabaseName(const Value: TIBFileName);
214     procedure SetDBParamByDPB(const Idx: Integer; Value: String);
215     procedure SetDBParams(Value: TStrings);
216     procedure SetDefaultTransaction(Value: TIBTransaction);
217     procedure SetIdleTimer(Value: Integer);
218     procedure TimeoutConnection(Sender: TObject);
219     function GetIsReadOnly: Boolean;
220     function AddSQLObject(ds: TIBBase): Integer;
221     procedure RemoveSQLObject(Idx: Integer);
222     procedure RemoveSQLObjects;
223     procedure InternalClose(Force: Boolean);
224    
225     protected
226     procedure DoConnect; override;
227     procedure DoDisconnect; override;
228     function GetConnected: Boolean; override;
229     procedure CheckStreamConnect;
230     procedure HandleException(Sender: TObject);
231     procedure Notification( AComponent: TComponent; Operation: TOperation); override;
232     function GetDataset(Index : longint) : TDataset; override;
233     function GetDataSetCount : Longint; override;
234     procedure ReadState(Reader: TReader); override;
235     procedure SetConnected (Value : boolean); override;
236     public
237     constructor Create(AOwner: TComponent); override;
238     destructor Destroy; override;
239     procedure ApplyUpdates(const DataSets: array of TDataSet);
240     procedure CloseDataSets;
241     procedure CheckActive;
242     procedure CheckInactive;
243     procedure CreateDatabase;
244     procedure DropDatabase;
245     procedure ForceClose;
246     procedure GetFieldNames(const TableName: string; List: TStrings);
247     procedure GetTableNames(List: TStrings; SystemTables: Boolean = False);
248     function IndexOfDBConst(st: String): Integer;
249     function TestConnected: Boolean;
250     procedure CheckDatabaseName;
251     function Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
252     function AddTransaction(TR: TIBTransaction): Integer;
253     function FindTransaction(TR: TIBTransaction): Integer;
254     function FindDefaultTransaction(): TIBTransaction;
255     procedure RemoveTransaction(Idx: Integer);
256     procedure RemoveTransactions;
257     procedure SetHandle(Value: TISC_DB_HANDLE);
258    
259     property Handle: TISC_DB_HANDLE read FHandle;
260     property IsReadOnly: Boolean read GetIsReadOnly;
261     property DBParamByDPB[const Idx: Integer]: String read GetDBParamByDPB
262     write SetDBParamByDPB;
263     property SQLObjectCount: Integer read GetSQLObjectCount;
264     property SQLObjects[Index: Integer]: TIBBase read GetSQLObject;
265     property HandleIsShared: Boolean read FHandleIsShared;
266     property TransactionCount: Integer read GetTransactionCount;
267     property Transactions[Index: Integer]: TIBTransaction read GetTransaction;
268     property InternalTransaction: TIBTransaction read FInternalTransaction;
269 tony 39 property DefaultCharSetName: RawByteString read FDefaultCharSetName;
270     {$IFDEF HAS_ANSISTRING_CODEPAGE}
271     property DefaultCodePage: TSystemCodePage read FDefaultCodePage;
272     {$ENDIF}
273 tony 33
274     published
275     property Connected;
276     property AllowStreamedConnected: boolean read FAllowStreamedConnected
277     write FAllowStreamedConnected;
278     property DatabaseName: TIBFileName read FDBName write SetDatabaseName;
279     property Params: TStrings read FDBParams write SetDBParams;
280     property LoginPrompt default True;
281     property DefaultTransaction: TIBTransaction read FDefaultTransaction
282     write SetDefaultTransaction;
283     property IdleTimer: Integer read GetIdleTimer write SetIdleTimer;
284     property SQLDialect : Integer read GetSQLDialect write SetSQLDialect default 3;
285     property SQLHourGlass: Boolean read FSQLHourGlass write FSQLHourGlass default true;
286     property DBSQLDialect : Integer read FDBSQLDialect;
287     property TraceFlags: TTraceFlags read FTraceFlags write FTraceFlags;
288 tony 39 property UseDefaultSystemCodePage: boolean read FUseDefaultSystemCodePage
289     write FUseDefaultSystemCodePage;
290 tony 33 property AfterConnect;
291     property AfterDisconnect;
292     property BeforeConnect;
293     property BeforeDisconnect;
294     property OnLogin: TIBDatabaseLoginEvent read FOnLogin write FOnLogin;
295     property OnIdleTimer: TNotifyEvent read FOnIdleTimer write FOnIdleTimer;
296     property OnDialectDowngradeWarning: TNotifyEvent read FOnDialectDowngradeWarning write FOnDialectDowngradeWarning;
297     end;
298    
299     { TIBTransaction }
300    
301     TTransactionAction = (TARollback, TACommit, TARollbackRetaining, TACommitRetaining);
302    
303     TIBTransaction = class(TComponent)
304     private
305     FAfterDelete: TNotifyEvent;
306     FAfterEdit: TNotifyEvent;
307     FAfterExecQuery: TNotifyEvent;
308     FAfterInsert: TNotifyEvent;
309     FAfterPost: TNotifyEvent;
310     FAfterTransactionEnd: TNotifyEvent;
311     FBeforeTransactionEnd: TNotifyEvent;
312     FIBLoaded: Boolean;
313     FCanTimeout : Boolean;
314     FDatabases : TList;
315     FOnStartTransaction: TNotifyEvent;
316     FSQLObjects : TList;
317     FDefaultDatabase : TIBDatabase;
318     FHandle : TISC_TR_HANDLE;
319     FHandleIsShared : Boolean;
320     FOnIdleTimer : TNotifyEvent;
321     FStreamedActive : Boolean;
322     FTPB : PChar;
323     FTPBLength : Short;
324     FTimer : TFPTimer;
325     FDefaultAction : TTransactionAction;
326     FTRParams : TStrings;
327     FTRParamsChanged : Boolean;
328     FInEndTransaction : boolean;
329     FEndAction : TTransactionAction;
330     procedure DoBeforeTransactionEnd;
331     procedure DoAfterTransactionEnd;
332     procedure DoOnStartTransaction;
333     procedure DoAfterExecQuery(Sender: TObject);
334     procedure DoAfterEdit(Sender: TObject);
335     procedure DoAfterDelete(Sender: TObject);
336     procedure DoAfterInsert(Sender: TObject);
337     procedure DoAfterPost(Sender: TObject);
338     procedure EnsureNotInTransaction;
339     procedure EndTransaction(Action: TTransactionAction; Force: Boolean);
340     function GetDatabase(Index: Integer): TIBDatabase;
341     function GetDatabaseCount: Integer;
342     function GetSQLObject(Index: Integer): TIBBase;
343     function GetSQLObjectCount: Integer;
344     function GetInTransaction: Boolean;
345     function GetIdleTimer: Integer;
346     procedure BeforeDatabaseDisconnect(DB: TIBDatabase);
347     procedure SetActive(Value: Boolean);
348     procedure SetDefaultAction(Value: TTransactionAction);
349     procedure SetDefaultDatabase(Value: TIBDatabase);
350     procedure SetIdleTimer(Value: Integer);
351     procedure SetTRParams(Value: TStrings);
352     procedure TimeoutTransaction(Sender: TObject);
353     procedure TRParamsChange(Sender: TObject);
354     procedure TRParamsChanging(Sender: TObject);
355     function AddSQLObject(ds: TIBBase): Integer;
356     procedure RemoveSQLObject(Idx: Integer);
357     procedure RemoveSQLObjects;
358    
359     protected
360     procedure Loaded; override;
361     procedure SetHandle(Value: TISC_TR_HANDLE);
362     procedure Notification( AComponent: TComponent; Operation: TOperation); override;
363    
364     public
365     constructor Create(AOwner: TComponent); override;
366     destructor Destroy; override;
367     function Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
368     procedure Commit;
369     procedure CommitRetaining;
370     procedure Rollback;
371     procedure RollbackRetaining;
372     procedure StartTransaction;
373     procedure CheckInTransaction;
374     procedure CheckNotInTransaction;
375    
376     function AddDatabase(db: TIBDatabase): Integer;
377     function FindDatabase(db: TIBDatabase): Integer;
378     function FindDefaultDatabase: TIBDatabase;
379     function GetEndAction: TTransactionAction;
380     procedure RemoveDatabase(Idx: Integer);
381     procedure RemoveDatabases;
382     procedure CheckDatabasesInList;
383    
384     property DatabaseCount: Integer read GetDatabaseCount;
385     property Databases[Index: Integer]: TIBDatabase read GetDatabase;
386     property SQLObjectCount: Integer read GetSQLObjectCount;
387     property SQLObjects[Index: Integer]: TIBBase read GetSQLObject;
388     property Handle: TISC_TR_HANDLE read FHandle;
389     property HandleIsShared: Boolean read FHandleIsShared;
390     property InTransaction: Boolean read GetInTransaction;
391     property TPB: PChar read FTPB;
392     property TPBLength: Short read FTPBLength;
393     published
394     property Active: Boolean read GetInTransaction write SetActive;
395     property DefaultDatabase: TIBDatabase read FDefaultDatabase
396     write SetDefaultDatabase;
397     property IdleTimer: Integer read GetIdleTimer write SetIdleTimer default 0;
398     property DefaultAction: TTransactionAction read FDefaultAction write SetDefaultAction default taCommit;
399     property Params: TStrings read FTRParams write SetTRParams;
400     property OnIdleTimer: TNotifyEvent read FOnIdleTimer write FOnIdleTimer;
401     property BeforeTransactionEnd: TNotifyEvent read FBeforeTransactionEnd
402     write FBeforeTransactionEnd;
403     property AfterTransactionEnd: TNotifyEvent read FAfterTransactionEnd
404     write FAfterTransactionEnd;
405     property OnStartTransaction: TNotifyEvent read FOnStartTransaction
406     write FOnStartTransaction;
407     property AfterExecQuery: TNotifyEvent read FAfterExecQuery
408     write FAfterExecQuery;
409     property AfterEdit: TNotifyEvent read FAfterEdit write FAfterEdit;
410     property AfterDelete: TNotifyEvent read FAfterDelete write FAfterDelete;
411     property AfterInsert: TNotifyEvent read FAfterInsert write FAfterInsert;
412     property AfterPost: TNotifyEvent read FAfterPost write FAfterPost;
413     end;
414    
415     TTransactionEndEvent = procedure(Sender:TObject; Action: TTransactionAction) of object;
416     TBeforeDatabaseConnectEvent = procedure (Sender: TObject; DBParams: TStrings;
417     var DBName: string) of object;
418    
419     { TIBBase }
420    
421     { Virtually all components in IB are "descendents" of TIBBase.
422     It is to more easily manage the database and transaction
423     connections. }
424     TIBBase = class(TObject)
425     protected
426     FBeforeDatabaseConnect: TBeforeDatabaseConnectEvent;
427     FDatabase: TIBDatabase;
428     FIndexInDatabase: Integer;
429     FTransaction: TIBTransaction;
430     FIndexInTransaction: Integer;
431     FOwner: TObject;
432     FBeforeDatabaseDisconnect: TNotifyEvent;
433     FAfterDatabaseDisconnect: TNotifyEvent;
434     FAfterDatabaseConnect: TNotifyEvent;
435     FOnDatabaseFree: TNotifyEvent;
436     FBeforeTransactionEnd: TTransactionEndEvent;
437     FAfterTransactionEnd: TNotifyEvent;
438     FOnTransactionFree: TNotifyEvent;
439    
440     procedure DoBeforeDatabaseConnect(DBParams: TStrings;
441     var DBName: string); virtual;
442     procedure DoAfterDatabaseConnect; virtual;
443     procedure DoBeforeDatabaseDisconnect; virtual;
444     procedure DoAfterDatabaseDisconnect; virtual;
445     procedure DoDatabaseFree; virtual;
446     procedure DoBeforeTransactionEnd(Action: TTransactionAction); virtual;
447     procedure DoAfterTransactionEnd; virtual;
448     procedure DoTransactionFree; virtual;
449     function GetDBHandle: PISC_DB_HANDLE; virtual;
450     function GetTRHandle: PISC_TR_HANDLE; virtual;
451     procedure SetDatabase(Value: TIBDatabase); virtual;
452     procedure SetTransaction(Value: TIBTransaction); virtual;
453     public
454     constructor Create(AOwner: TObject);
455     destructor Destroy; override;
456     procedure CheckDatabase; virtual;
457     procedure CheckTransaction; virtual;
458     procedure DoAfterExecQuery(Sender: TObject); virtual;
459     procedure DoAfterEdit(Sender: TObject); virtual;
460     procedure DoAfterDelete(Sender: TObject); virtual;
461     procedure DoAfterInsert(Sender: TObject); virtual;
462     procedure DoAfterPost(Sender: TObject); virtual;
463     function GetCharSetSize(CharSetID: integer): integer;
464 tony 35 function GetDefaultCharSetSize: integer;
465     function GetCharSetName(CharSetID: integer): string;
466 tony 39 function GetDefaultCharSetName: RawByteString;
467     {$IFDEF HAS_ANSISTRING_CODEPAGE}
468     function GetCodePage(CharSetID: integer): TSystemCodePage;
469     function GetDefaultCodePage: TSystemCodePage;
470     {$ENDIF}
471 tony 33 procedure HandleException(Sender: TObject);
472     procedure SetCursor;
473     procedure RestoreCursor;
474     public
475     property BeforeDatabaseConnect: TBeforeDatabaseConnectEvent read FBeforeDatabaseConnect
476     write FBeforeDatabaseConnect;
477     property AfterDatabaseConnect: TNotifyEvent read FAfterDatabaseConnect
478     write FAfterDatabaseConnect;
479     property BeforeDatabaseDisconnect: TNotifyEvent read FBeforeDatabaseDisconnect
480     write FBeforeDatabaseDisconnect;
481     property AfterDatabaseDisconnect: TNotifyEvent read FAfterDatabaseDisconnect
482     write FAfterDatabaseDisconnect;
483     property OnDatabaseFree: TNotifyEvent read FOnDatabaseFree write FOnDatabaseFree;
484     property BeforeTransactionEnd: TTransactionEndEvent read FBeforeTransactionEnd write FBeforeTransactionEnd;
485     property AfterTransactionEnd: TNotifyEvent read FAfterTransactionEnd write FAfterTransactionEnd;
486     property OnTransactionFree: TNotifyEvent read FOnTransactionFree write FOnTransactionFree;
487     property Database: TIBDatabase read FDatabase
488     write SetDatabase;
489     property DBHandle: PISC_DB_HANDLE read GetDBHandle;
490     property Owner: TObject read FOwner;
491     property TRHandle: PISC_TR_HANDLE read GetTRHandle;
492     property Transaction: TIBTransaction read FTransaction
493     write SetTransaction;
494     end;
495    
496     procedure GenerateDPB(sl: TStrings; var DPB: string; var DPBLength: Short);
497     procedure GenerateTPB(sl: TStrings; var TPB: string; var TPBLength: Short);
498    
499    
500     implementation
501    
502     uses IBIntf, IBSQLMonitor, IBCustomDataSet, IBDatabaseInfo, IBSQL, IBUtils,
503 tony 39 typInfo, IBCodePage;
504 tony 33
505     { TIBDatabase }
506    
507 tony 39 constructor TIBDataBase.Create(AOwner: TComponent);
508 tony 33 begin
509     inherited Create(AOwner);
510     FIBLoaded := False;
511     CheckIBLoaded;
512     FIBLoaded := True;
513     LoginPrompt := True;
514     FSQLObjects := TList.Create;
515     FTransactions := TList.Create;
516     FDBName := '';
517     FDBParams := TStringList.Create;
518     FSQLHourGlass := true;
519     if (AOwner <> nil) and
520     (AOwner is TCustomApplication) and
521     TCustomApplication(AOWner).ConsoleApplication then
522     LoginPrompt := false;
523 tony 39 {$IFDEF HAS_ANSISTRING_CODEPAGE}
524     FDefaultCodePage := CP_NONE;
525     {$ENDIF}
526 tony 33 FDBParamsChanged := True;
527     TStringList(FDBParams).OnChange := DBParamsChange;
528     TStringList(FDBParams).OnChanging := DBParamsChanging;
529     FDPB := nil;
530     FHandle := nil;
531     FUserNames := nil;
532     FInternalTransaction := TIBTransaction.Create(self);
533     FInternalTransaction.DefaultDatabase := Self;
534     FTimer := TFPTimer.Create(Self);
535     FTimer.Enabled := False;
536     FTimer.Interval := 0;
537     FTimer.OnTimer := TimeoutConnection;
538     FDBSQLDialect := 1;
539     FSQLDialect := 3;
540     FTraceFlags := [];
541     FDataSets := TList.Create;
542     CheckStreamConnect;
543     end;
544    
545     destructor TIBDataBase.Destroy;
546     var
547     i: Integer;
548     begin
549     if FIBLoaded then
550     begin
551     IdleTimer := 0;
552     if FHandle <> nil then
553     ForceClose;
554     for i := 0 to FSQLObjects.Count - 1 do
555     if FSQLObjects[i] <> nil then
556     SQLObjects[i].DoDatabaseFree;
557     RemoveSQLObjects;
558     RemoveTransactions;
559     FInternalTransaction.Free;
560     FreeMem(FDPB);
561     FDPB := nil;
562     FDBParams.Free;
563     FSQLObjects.Free;
564     FUserNames.Free;
565     FTransactions.Free;
566     end;
567     FDataSets.Free;
568     inherited Destroy;
569     end;
570    
571     function TIBDataBase.Call(ErrCode: ISC_STATUS; RaiseError: Boolean
572     ): ISC_STATUS;
573     begin
574     result := ErrCode;
575     FCanTimeout := False;
576     if RaiseError and (ErrCode > 0) then
577     IBDataBaseError;
578     end;
579    
580     procedure TIBDataBase.CheckActive;
581     begin
582     if StreamedConnected and (not Connected) then
583     Loaded;
584     if FHandle = nil then
585     IBError(ibxeDatabaseClosed, [nil]);
586     end;
587    
588     procedure TIBDataBase.EnsureInactive;
589     begin
590     if csDesigning in ComponentState then
591     begin
592     if FHandle <> nil then
593     Close;
594     end
595     end;
596    
597     procedure TIBDataBase.CheckInactive;
598     begin
599     if FHandle <> nil then
600     IBError(ibxeDatabaseOpen, [nil]);
601     end;
602    
603     procedure TIBDataBase.CheckDatabaseName;
604     begin
605 tony 37 if (Trim(FDBName) = '') then
606 tony 33 IBError(ibxeDatabaseNameMissing, [nil]);
607     end;
608    
609     function TIBDataBase.AddSQLObject(ds: TIBBase): Integer;
610     begin
611     result := 0;
612     if (ds.Owner is TIBCustomDataSet) then
613     FDataSets.Add(ds.Owner);
614     while (result < FSQLObjects.Count) and (FSQLObjects[result] <> nil) do
615     Inc(result);
616     if (result = FSQLObjects.Count) then
617     FSQLObjects.Add(ds)
618     else
619     FSQLObjects[result] := ds;
620     end;
621    
622     function TIBDataBase.AddTransaction(TR: TIBTransaction): Integer;
623     begin
624     result := FindTransaction(TR);
625     if result <> -1 then
626     begin
627     result := -1;
628     exit;
629     end;
630     result := 0;
631     while (result < FTransactions.Count) and (FTransactions[result] <> nil) do
632     Inc(result);
633     if (result = FTransactions.Count) then
634     FTransactions.Add(TR)
635     else
636     FTransactions[result] := TR;
637     end;
638    
639     procedure TIBDataBase.DoDisconnect;
640     begin
641     if Connected then
642     InternalClose(False);
643     FDBSQLDialect := 1;
644     SetLength(FCharSetSizes,0);
645 tony 35 SetLength(FCharSetNames,0);
646 tony 39 FDefaultCharSetName := '';
647     {$IFDEF HAS_ANSISTRING_CODEPAGE}
648     SetLength(FCodePages,0);
649     FDefaultCodePage := CP_NONE;
650     {$ENDIF}
651 tony 33 end;
652    
653     procedure TIBDataBase.CreateDatabase;
654     var
655     tr_handle: TISC_TR_HANDLE;
656     begin
657     CheckInactive;
658     tr_handle := nil;
659     Call(
660     isc_dsql_execute_immediate(StatusVector, @FHandle, @tr_handle, 0,
661     PChar('CREATE DATABASE ''' + FDBName + ''' ' + {do not localize}
662     Params.Text), SQLDialect, nil),
663     True);
664     end;
665    
666     procedure TIBDataBase.DropDatabase;
667     begin
668     CheckActive;
669     Call(isc_drop_database(StatusVector, @FHandle), True);
670     end;
671    
672     procedure TIBDataBase.DBParamsChange(Sender: TObject);
673     begin
674     FDBParamsChanged := True;
675     end;
676    
677     procedure TIBDataBase.DBParamsChanging(Sender: TObject);
678     begin
679     EnsureInactive;
680     CheckInactive;
681     end;
682    
683     function TIBDataBase.FindTransaction(TR: TIBTransaction): Integer;
684     var
685     i: Integer;
686     begin
687     result := -1;
688     for i := 0 to FTransactions.Count - 1 do
689     if TR = Transactions[i] then
690     begin
691     result := i;
692     break;
693     end;
694     end;
695    
696     function TIBDataBase.FindDefaultTransaction: TIBTransaction;
697     var
698     i: Integer;
699     begin
700     result := FDefaultTransaction;
701     if result = nil then
702     begin
703     for i := 0 to FTransactions.Count - 1 do
704     if (Transactions[i] <> nil) and
705     (TIBTransaction(Transactions[i]).DefaultDatabase = self) and
706     (TIBTransaction(Transactions[i]) <> FInternalTransaction) then
707     begin
708     result := TIBTransaction(Transactions[i]);
709     break;
710     end;
711     end;
712     end;
713    
714     procedure TIBDataBase.ForceClose;
715     begin
716     if Connected then
717     InternalClose(True);
718     end;
719    
720     function TIBDataBase.GetConnected: Boolean;
721     begin
722     result := FHandle <> nil;
723     end;
724    
725     function TIBDataBase.GetSQLObject(Index: Integer): TIBBase;
726     begin
727     result := FSQLObjects[Index];
728     end;
729    
730     function TIBDataBase.GetSQLObjectCount: Integer;
731     var
732     i: Integer;
733     begin
734     result := 0;
735     for i := 0 to FSQLObjects.Count - 1 do if FSQLObjects[i] <> nil then
736     Inc(result);
737     end;
738    
739     function TIBDataBase.GetDBParamByDPB( const Idx: Integer): String;
740     var
741     ConstIdx, EqualsIdx: Integer;
742     begin
743     if (Idx > 0) and (Idx <= isc_dpb_last_dpb_constant) then
744     begin
745     ConstIdx := IndexOfDBConst(DPBConstantNames[Idx]);
746     if ConstIdx = -1 then
747     result := ''
748     else
749     begin
750     result := Params[ConstIdx];
751     EqualsIdx := Pos('=', result); {mbcs ok}
752     if EqualsIdx = 0 then
753     result := ''
754     else
755     result := Copy(result, EqualsIdx + 1, Length(result));
756     end;
757     end
758     else
759     result := '';
760     end;
761    
762     function TIBDataBase.GetIdleTimer: Integer;
763     begin
764     result := FTimer.Interval;
765     end;
766    
767     function TIBDataBase.GetTransaction(Index: Integer): TIBTransaction;
768     begin
769     result := FTransactions[Index];
770     end;
771    
772     function TIBDataBase.GetTransactionCount: Integer;
773     var
774     i: Integer;
775     begin
776     result := 0;
777     for i := 0 to FTransactions.Count - 1 do
778     if FTransactions[i] <> nil then
779     Inc(result);
780     end;
781    
782     function TIBDataBase.IndexOfDBConst(st: String): Integer;
783     var
784     i, pos_of_str: Integer;
785     begin
786     result := -1;
787     for i := 0 to Params.Count - 1 do
788     begin
789     pos_of_str := Pos(st, AnsiLowerCase(Params[i])); {mbcs ok}
790     if (pos_of_str = 1) or (pos_of_str = Length(DPBPrefix) + 1) then
791     begin
792     result := i;
793     break;
794     end;
795     end;
796     end;
797    
798     procedure TIBDataBase.InternalClose(Force: Boolean);
799     var
800     i: Integer;
801     begin
802     CheckActive;
803     { Tell all connected transactions that we're disconnecting.
804     This is so transactions can commit/rollback, accordingly
805     }
806     for i := 0 to FTransactions.Count - 1 do
807     begin
808     try
809     if FTransactions[i] <> nil then
810     Transactions[i].BeforeDatabaseDisconnect(Self);
811     except
812     if not Force then
813     raise;
814     end;
815     end;
816     for i := 0 to FSQLObjects.Count - 1 do
817     begin
818     try
819     if FSQLObjects[i] <> nil then
820     SQLObjects[i].DoBeforeDatabaseDisconnect;
821     except
822     if not Force then
823     raise;
824     end;
825     end;
826    
827     if (not HandleIsShared) and
828     (Call(isc_detach_database(StatusVector, @FHandle), False) > 0) and
829     (not Force) then
830     IBDataBaseError
831     else
832     begin
833     FHandle := nil;
834     FHandleIsShared := False;
835     end;
836    
837     if not (csDesigning in ComponentState) then
838     MonitorHook.DBDisconnect(Self);
839    
840     for i := 0 to FSQLObjects.Count - 1 do
841     if FSQLObjects[i] <> nil then
842     SQLObjects[i].DoAfterDatabaseDisconnect;
843     end;
844    
845     procedure TIBDataBase.LoadCharSetInfo;
846     var Query: TIBSQL;
847     i: integer;
848     begin
849     if not FInternalTransaction.Active then
850     FInternalTransaction.StartTransaction;
851     Query := TIBSQL.Create(self);
852     try
853     Query.Database := Self;
854     Query.Transaction := FInternalTransaction;
855 tony 35 Query.SQL.Text := 'Select RDB$CHARACTER_SET_ID, RDB$BYTES_PER_CHARACTER, RDB$CHARACTER_SET_NAME ' +
856 tony 33 'From RDB$CHARACTER_SETS Order by 1 DESC'; {do not localize}
857     Query.Prepare;
858     Query.ExecQuery;
859     if not Query.EOF then
860     begin
861     SetLength(FCharSetSizes,Query.FieldByName('RDB$CHARACTER_SET_ID').AsInteger + 1);
862 tony 35 SetLength(FCharSetNames,Query.FieldByName('RDB$CHARACTER_SET_ID').AsInteger + 1);
863 tony 39 {$IFDEF HAS_ANSISTRING_CODEPAGE}
864     SetLength(FCodePages, Query.FieldByName('RDB$CHARACTER_SET_ID').AsInteger + 1);
865     {$ENDIF}
866 tony 33 for i := 0 to Length(FCharSetSizes) - 1 do FCharSetSizes[i] := 1;
867     repeat
868     FCharSetSizes[Query.FieldByName('RDB$CHARACTER_SET_ID').AsInteger] :=
869     Query.FieldByName('RDB$BYTES_PER_CHARACTER').AsInteger;
870 tony 35 FCharSetNames[Query.FieldByName('RDB$CHARACTER_SET_ID').AsInteger] :=
871 tony 39 Trim(Query.FieldByName('RDB$CHARACTER_SET_NAME').AsString);
872     {$IFDEF HAS_ANSISTRING_CODEPAGE}
873     FCodePages[Query.FieldByName('RDB$CHARACTER_SET_ID').AsInteger] :=
874     IBGetCodePage(Trim(Query.FieldByName('RDB$CHARACTER_SET_NAME').AsString));
875     {$ENDIF}
876 tony 33 Query.Next;
877     until Query.EOF;
878     end;
879     finally
880     Query.free;
881     FInternalTransaction.Commit;
882     end;
883     end;
884    
885     procedure TIBDataBase.CheckStreamConnect;
886     var
887     i: integer;
888     begin
889     try
890     if not (csDesigning in ComponentState) and StreamedConnected and (not Connected) then
891     begin
892     for i := 0 to FTransactions.Count - 1 do
893     if FTransactions[i] <> nil then
894     begin
895     with TIBTransaction(FTransactions[i]) do
896     if not Active then
897     if FStreamedActive and not InTransaction then
898     begin
899     StartTransaction;
900     FStreamedActive := False;
901     end;
902     end;
903     if (FDefaultTransaction <> nil) and
904     (FDefaultTransaction.FStreamedActive) and
905     (not FDefaultTransaction.InTransaction) then
906     FDefaultTransaction.StartTransaction;
907     FStreamedConnected := False;
908     end;
909     except
910     if csDesigning in ComponentState then
911     HandleException(Self)
912     else
913     raise;
914     end;
915     end;
916    
917     procedure TIBDataBase.HandleException(Sender: TObject);
918     var aParent: TComponent;
919     begin
920     aParent := Owner;
921     while aParent <> nil do
922     begin
923     if aParent is TCustomApplication then
924     begin
925     TCustomApplication(aParent).HandleException(Sender);
926     Exit;
927     end;
928     aParent := aParent.Owner;
929     end;
930     SysUtils.ShowException(ExceptObject,ExceptAddr);
931     end;
932    
933     procedure TIBDataBase.Notification(AComponent: TComponent;
934     Operation: TOperation);
935     var
936     i: Integer;
937     begin
938     inherited Notification( AComponent, Operation);
939     if (Operation = opRemove) and (AComponent = FDefaultTransaction) then
940     begin
941     i := FindTransaction(FDefaultTransaction);
942     if (i <> -1) then
943     RemoveTransaction(i);
944     FDefaultTransaction := nil;
945     end;
946     end;
947    
948 tony 39 function TIBDataBase.Login(var aDatabaseName: string): Boolean;
949 tony 33 var
950     IndexOfUser, IndexOfPassword: Integer;
951     Username, Password, OldPassword: String;
952     LoginParams: TStrings;
953    
954     procedure HidePassword;
955     var
956     I: Integer;
957     IndexAt: Integer;
958     begin
959     IndexAt := 0;
960     for I := 0 to Params.Count -1 do
961     if Pos('password', LowerCase(Trim(Params.Names[i]))) = 1 then {mbcs ok}
962     begin
963     FHiddenPassword := Params.Values[Params.Names[i]];
964     IndexAt := I;
965     break;
966     end;
967     if IndexAt <> 0 then
968     Params.Delete(IndexAt);
969     end;
970    
971     begin
972     Result := false;
973     if FLoginCalled then Exit;
974     FLoginCalled := true;
975     try
976     if Assigned(FOnLogin) and not (csDesigning in ComponentState) then
977     begin
978     result := True;
979     LoginParams := TStringList.Create;
980     try
981     LoginParams.Assign(Params);
982     FOnLogin(Self, LoginParams);
983     Params.Assign (LoginParams);
984 tony 39 aDatabaseName := FDBName;
985 tony 33 HidePassword;
986     finally
987     LoginParams.Free;
988     end;
989     end
990     else
991     if assigned(IBGUIInterface) then
992     begin
993     IndexOfUser := IndexOfDBConst(DPBConstantNames[isc_dpb_user_name]);
994     if IndexOfUser <> -1 then
995     Username := Copy(Params[IndexOfUser],
996     Pos('=', Params[IndexOfUser]) + 1, {mbcs ok}
997     Length(Params[IndexOfUser]));
998     IndexOfPassword := IndexOfDBConst(DPBConstantNames[isc_dpb_password]);
999     if IndexOfPassword <> -1 then
1000     begin
1001     Password := Copy(Params[IndexOfPassword],
1002     Pos('=', Params[IndexOfPassword]) + 1, {mbcs ok}
1003     Length(Params[IndexOfPassword]));
1004     OldPassword := password;
1005     end;
1006 tony 39 result := IBGUIInterface.LoginDialogEx(aDatabaseName, Username, Password, False);
1007 tony 33 if result then
1008     begin
1009     if IndexOfUser = -1 then
1010     Params.Add(DPBConstantNames[isc_dpb_user_name] + '=' + Username)
1011     else
1012     Params[IndexOfUser] := DPBConstantNames[isc_dpb_user_name] +
1013     '=' + Username;
1014     if (Password = OldPassword) then
1015     FHiddenPassword := ''
1016     else
1017     begin
1018     FHiddenPassword := Password;
1019     if OldPassword <> '' then
1020     HidePassword;
1021     end;
1022     end;
1023     end
1024     else
1025     if LoginPrompt then
1026     IBError(ibxeNoLoginDialog,[]);
1027     finally
1028     FLoginCalled := false
1029     end;
1030     end;
1031    
1032     procedure TIBDataBase.DoConnect;
1033     var
1034     DPB: String;
1035     TempDBParams: TStrings;
1036     I: integer;
1037     aDBName: string;
1038 tony 37
1039     {Call error analysis}
1040     sqlcode: Long;
1041     IBErrorCode: Long;
1042     status_vector: PISC_STATUS;
1043 tony 39 {$ifdef WINDOWS}
1044     acp: uint;
1045     {$endif}
1046 tony 33 begin
1047     CheckInactive;
1048     CheckDatabaseName;
1049     if (not LoginPrompt) and (FHiddenPassword <> '') then
1050     begin
1051     FHiddenPassword := '';
1052     FDBParamsChanged := True;
1053     end;
1054     { Use builtin login prompt if requested }
1055 tony 39 aDBName := FDBName;
1056     if (LoginPrompt or (csDesigning in ComponentState)) and not Login(aDBName) then
1057 tony 33 IBError(ibxeOperationCancelled, [nil]);
1058    
1059     TempDBParams := TStringList.Create;
1060     try
1061     TempDBParams.Assign(FDBParams);
1062 tony 39 if UseDefaultSystemCodePage then
1063     begin
1064     {$ifdef WINDOWS}
1065     acp := GetACP;
1066     {$IFDEF HAS_ANSISTRING_CODEPAGE}
1067     TempDBParams.Values['lc_ctype'] := IBGetCharacterSetName(acp);
1068     FDefaultCodePage := IBGetCodePage(AnsiUpperCase(TempDBParams.Values['lc_ctype']));
1069     {$ELSE}
1070     if (acp >= 1250) and (acp <= 1258) then
1071     TempDBParams.Values['lc_ctype'] := Format('WIN%d',[acp])
1072     else
1073     TempDBParams.Values['lc_ctype'] :='UTF8';
1074     {$ENDIF}
1075     {$else}
1076     {$IFDEF HAS_ANSISTRING_CODEPAGE}
1077     TempDBParams.Values['lc_ctype'] := IBGetCharacterSetName(DefaultSystemCodePage);
1078     FDefaultCodePage := IBGetCodePage(AnsiUpperCase(TempDBParams.Values['lc_ctype']));
1079     {$ELSE}
1080     TempDBParams.Values['lc_ctype'] :='UTF8';
1081     {$ENDIF}
1082     {$endif}
1083     end;
1084 tony 35 {Opportunity to override defaults}
1085 tony 33 for i := 0 to FSQLObjects.Count - 1 do
1086     begin
1087     if FSQLObjects[i] <> nil then
1088     SQLObjects[i].DoBeforeDatabaseConnect(TempDBParams,aDBName);
1089     end;
1090 tony 39 FDefaultCharSetName := AnsiUpperCase(TempDBParams.Values['lc_ctype']);
1091 tony 33
1092     { Generate a new DPB if necessary }
1093     if (FDBParamsChanged or (TempDBParams.Text <> FDBParams.Text)) then
1094     begin
1095     FDBParamsChanged := False;
1096     if (not LoginPrompt and not (csDesigning in ComponentState)) or (FHiddenPassword = '') then
1097     GenerateDPB(TempDBParams, DPB, FDPBLength)
1098     else
1099     begin
1100     TempDBParams.Add('password=' + FHiddenPassword);
1101     GenerateDPB(TempDBParams, DPB, FDPBLength);
1102     end;
1103     IBAlloc(FDPB, 0, FDPBLength);
1104     Move(DPB[1], FDPB[0], FDPBLength);
1105     end;
1106     finally
1107     TempDBParams.Free;
1108     end;
1109 tony 37 repeat
1110     if Call(isc_attach_database(StatusVector, Length(aDBName),
1111 tony 33 PChar(aDBName), @FHandle,
1112     FDPBLength, FDPB), False) > 0 then
1113 tony 37 begin
1114     {$IFDEF UNIX}
1115     if IsEmbeddedServer and (Pos(':',aDBName) = 0) then
1116     begin
1117     status_vector := StatusVector;
1118     IBErrorCode := StatusVectorArray[1];
1119     sqlcode := isc_sqlcode(StatusVector);
1120    
1121     if ((sqlcode = -901) and (IBErrorCode = 335544382)) {Access permissions on firebird temp}
1122     or
1123     ((sqlcode = -902) and (IBErrorCode = 335544373)) {Security DB Problem}
1124     then
1125     begin
1126     aDBName := 'localhost:' + aDBName;
1127     Continue;
1128     end;
1129     end;
1130     {$ENDIF}
1131     FHandle := nil;
1132     IBDataBaseError;
1133     end;
1134     until FHandle <> nil;
1135 tony 33 if not (csDesigning in ComponentState) then
1136     FDBName := aDBName; {Synchronise at run time}
1137     FDBSQLDialect := GetDBSQLDialect;
1138     ValidateClientSQLDialect;
1139     for i := 0 to FSQLObjects.Count - 1 do
1140     begin
1141     if FSQLObjects[i] <> nil then
1142     SQLObjects[i].DoAfterDatabaseConnect;
1143     end;
1144     if not (csDesigning in ComponentState) then
1145     MonitorHook.DBConnect(Self);
1146     LoadCharSetInfo;
1147     end;
1148    
1149     procedure TIBDataBase.RemoveSQLObject(Idx: Integer);
1150     var
1151     ds: TIBBase;
1152     begin
1153     if (Idx >= 0) and (FSQLObjects[Idx] <> nil) then
1154     begin
1155     ds := SQLObjects[Idx];
1156     FSQLObjects[Idx] := nil;
1157     ds.Database := nil;
1158     if (ds.owner is TDataSet) then
1159     FDataSets.Remove(TDataSet(ds.Owner));
1160     end;
1161     end;
1162    
1163     procedure TIBDataBase.RemoveSQLObjects;
1164     var
1165     i: Integer;
1166     begin
1167     for i := 0 to FSQLObjects.Count - 1 do if FSQLObjects[i] <> nil then
1168     begin
1169     RemoveSQLObject(i);
1170     if (TIBBase(FSQLObjects[i]).owner is TDataSet) then
1171     FDataSets.Remove(TDataSet(TIBBase(FSQLObjects[i]).owner));
1172     end;
1173     end;
1174    
1175     procedure TIBDataBase.RemoveTransaction(Idx: Integer);
1176     var
1177     TR: TIBTransaction;
1178     begin
1179     if ((Idx >= 0) and (FTransactions[Idx] <> nil)) then
1180     begin
1181     TR := Transactions[Idx];
1182     FTransactions[Idx] := nil;
1183     TR.RemoveDatabase(TR.FindDatabase(Self));
1184     if TR = FDefaultTransaction then
1185     FDefaultTransaction := nil;
1186     end;
1187     end;
1188    
1189     procedure TIBDataBase.RemoveTransactions;
1190     var
1191     i: Integer;
1192     begin
1193     for i := 0 to FTransactions.Count - 1 do if FTransactions[i] <> nil then
1194     RemoveTransaction(i);
1195     end;
1196    
1197     procedure TIBDataBase.SetDatabaseName( const Value: TIBFileName);
1198     begin
1199     if FDBName <> Value then
1200     begin
1201     EnsureInactive;
1202     CheckInactive;
1203     FDBName := Value;
1204     end;
1205     end;
1206    
1207     procedure TIBDataBase.SetDBParamByDPB( const Idx: Integer; Value: String);
1208     var
1209     ConstIdx: Integer;
1210     begin
1211     ConstIdx := IndexOfDBConst(DPBConstantNames[Idx]);
1212     if (Value = '') then
1213     begin
1214     if ConstIdx <> -1 then
1215     Params.Delete(ConstIdx);
1216     end
1217     else
1218     begin
1219     if (ConstIdx = -1) then
1220     Params.Add(DPBConstantNames[Idx] + '=' + Value)
1221     else
1222     Params[ConstIdx] := DPBConstantNames[Idx] + '=' + Value;
1223     end;
1224     end;
1225    
1226     procedure TIBDataBase.SetDBParams(Value: TStrings);
1227     begin
1228     FDBParams.Assign(Value);
1229     end;
1230    
1231     procedure TIBDataBase.SetDefaultTransaction(Value: TIBTransaction);
1232     var
1233     i: Integer;
1234     begin
1235     if (FDefaultTransaction <> nil) and (FDefaultTransaction <> Value) then
1236     begin
1237     i := FindTransaction(FDefaultTransaction);
1238     if (i <> -1) and (FDefaultTransaction.DefaultDatabase <> self) then
1239     RemoveTransaction(i);
1240     end;
1241     if (Value <> nil) and (FDefaultTransaction <> Value) then
1242     begin
1243     Value.AddDatabase(Self);
1244     AddTransaction(Value);
1245     end;
1246     FDefaultTransaction := Value;
1247     end;
1248    
1249     procedure TIBDataBase.SetHandle(Value: TISC_DB_HANDLE);
1250     begin
1251     if HandleIsShared then
1252     Close
1253     else
1254     CheckInactive;
1255     FHandle := Value;
1256     FHandleIsShared := (Value <> nil);
1257     end;
1258    
1259     procedure TIBDataBase.SetIdleTimer(Value: Integer);
1260     begin
1261     if Value < 0 then
1262     IBError(ibxeTimeoutNegative, [nil])
1263     else
1264     if (Value = 0) then
1265     begin
1266     FTimer.Enabled := False;
1267     FTimer.Interval := 0;
1268     end
1269     else
1270     if (Value > 0) then
1271     begin
1272     FTimer.Interval := Value;
1273     if not (csDesigning in ComponentState) then
1274     FTimer.Enabled := True;
1275     end;
1276     end;
1277    
1278     function TIBDataBase.TestConnected: Boolean;
1279     var
1280     DatabaseInfo: TIBDatabaseInfo;
1281     begin
1282     result := Connected;
1283     if result then
1284     begin
1285     DatabaseInfo := TIBDatabaseInfo.Create(self);
1286     try
1287     DatabaseInfo.Database := self;
1288     { poke the server to see if connected }
1289     if DatabaseInfo.BaseLevel = 0 then ;
1290     DatabaseInfo.Free;
1291     except
1292     ForceClose;
1293     result := False;
1294     DatabaseInfo.Free;
1295     end;
1296     end;
1297     end;
1298    
1299     procedure TIBDataBase.TimeoutConnection(Sender: TObject);
1300     begin
1301     if Connected then
1302     begin
1303     if FCanTimeout then
1304     begin
1305     ForceClose;
1306     if Assigned(FOnIdleTimer) then
1307     FOnIdleTimer(Self);
1308     end
1309     else
1310     FCanTimeout := True;
1311     end;
1312     end;
1313    
1314     function TIBDataBase.GetIsReadOnly: Boolean;
1315     var
1316     DatabaseInfo: TIBDatabaseInfo;
1317     begin
1318     DatabaseInfo := TIBDatabaseInfo.Create(self);
1319     DatabaseInfo.Database := self;
1320     if (DatabaseInfo.ODSMajorVersion < 10) then
1321     result := false
1322     else
1323     begin
1324     if (DatabaseInfo.ReadOnly = 0) then
1325     result := false
1326     else
1327     result := true;
1328     end;
1329     DatabaseInfo.Free;
1330     end;
1331    
1332     function TIBDataBase.GetSQLDialect: Integer;
1333     begin
1334     Result := FSQLDialect;
1335     end;
1336    
1337    
1338     procedure TIBDataBase.SetSQLDialect( const Value: Integer);
1339     begin
1340     if (Value < 1) then IBError(ibxeSQLDialectInvalid, [nil]);
1341     if ((FHandle = nil) or (Value <= FDBSQLDialect)) then
1342     FSQLDialect := Value
1343     else
1344     IBError(ibxeSQLDialectInvalid, [nil]);
1345     end;
1346    
1347     function TIBDataBase.GetDBSQLDialect: Integer;
1348     var
1349     DatabaseInfo: TIBDatabaseInfo;
1350     begin
1351     DatabaseInfo := TIBDatabaseInfo.Create(self);
1352     DatabaseInfo.Database := self;
1353     result := DatabaseInfo.DBSQLDialect;
1354     DatabaseInfo.Free;
1355     end;
1356    
1357     procedure TIBDataBase.ValidateClientSQLDialect;
1358     begin
1359     if (FDBSQLDialect < FSQLDialect) then
1360     begin
1361     FSQLDialect := FDBSQLDialect;
1362     if Assigned (FOnDialectDowngradeWarning) then
1363     FOnDialectDowngradeWarning(self);
1364     end;
1365     end;
1366    
1367     procedure TIBDataBase.ApplyUpdates( const DataSets: array of TDataSet);
1368     var
1369     I: Integer;
1370     DS: TIBCustomDataSet;
1371     TR: TIBTransaction;
1372     begin
1373     TR := nil;
1374     for I := 0 to High(DataSets) do
1375     begin
1376     DS := TIBCustomDataSet(DataSets[I]);
1377     if DS.Database <> Self then
1378     IBError(ibxeUpdateWrongDB, [nil]);
1379     if TR = nil then
1380     TR := DS.Transaction;
1381     if (DS.Transaction <> TR) or (TR = nil) then
1382     IBError(ibxeUpdateWrongTR, [nil]);
1383     end;
1384     TR.CheckInTransaction;
1385     for I := 0 to High(DataSets) do
1386     begin
1387     DS := TIBCustomDataSet(DataSets[I]);
1388     DS.ApplyUpdates;
1389     end;
1390     TR.CommitRetaining;
1391     end;
1392    
1393     procedure TIBDataBase.CloseDataSets;
1394     var
1395     i: Integer;
1396     begin
1397     for i := 0 to DataSetCount - 1 do
1398     if (DataSets[i] <> nil) then
1399     DataSets[i].close;
1400     end;
1401    
1402     function TIBDataBase.GetDataset(Index: longint): TDataset;
1403     begin
1404     if (Index >= 0) and (Index < FDataSets.Count) then
1405     Result := TDataSet(FDataSets[Index])
1406     else
1407     raise Exception.Create('Invalid Index to DataSets');
1408     end;
1409    
1410     function TIBDataBase.GetDataSetCount: Longint;
1411     begin
1412     Result := FDataSets.Count;
1413     end;
1414    
1415     procedure TIBDataBase.ReadState(Reader: TReader);
1416     begin
1417     FDBParams.Clear;
1418     inherited ReadState(Reader);
1419     end;
1420    
1421     procedure TIBDataBase.SetConnected(Value: boolean);
1422     begin
1423     if StreamedConnected and not AllowStreamedConnected then
1424     begin
1425     StreamedConnected := false;
1426     Value := false
1427     end;
1428     inherited SetConnected(Value);
1429     end;
1430    
1431     procedure TIBDataBase.GetFieldNames( const TableName: string; List: TStrings);
1432     var
1433     Query: TIBSQL;
1434     begin
1435     if TableName = '' then
1436     IBError(ibxeNoTableName, [nil]);
1437     if not Connected then
1438     Open;
1439     if not FInternalTransaction.Active then
1440     FInternalTransaction.StartTransaction;
1441     Query := TIBSQL.Create(self);
1442     try
1443     Query.GoToFirstRecordOnExecute := False;
1444     Query.Database := Self;
1445     Query.Transaction := FInternalTransaction;
1446     Query.SQL.Text := 'Select R.RDB$FIELD_NAME ' + {do not localize}
1447     'from RDB$RELATION_FIELDS R, RDB$FIELDS F ' + {do not localize}
1448     'where R.RDB$RELATION_NAME = ' + {do not localize}
1449     '''' +
1450     FormatIdentifierValue(SQLDialect, TableName) +
1451     ''' ' +
1452     'and R.RDB$FIELD_SOURCE = F.RDB$FIELD_NAME '; {do not localize}
1453     Query.Prepare;
1454     Query.ExecQuery;
1455     with List do
1456     begin
1457     BeginUpdate;
1458     try
1459     Clear;
1460     while (not Query.EOF) and (Query.Next <> nil) do
1461     List.Add(TrimRight(Query.Current.ByName('RDB$FIELD_NAME').AsString)); {do not localize}
1462     finally
1463     EndUpdate;
1464     end;
1465     end;
1466     finally
1467     Query.free;
1468     FInternalTransaction.Commit;
1469     end;
1470     end;
1471    
1472     procedure TIBDataBase.GetTableNames(List: TStrings; SystemTables: Boolean);
1473     var
1474     Query : TIBSQL;
1475     begin
1476     if not (csReading in ComponentState) then
1477     begin
1478     if not Connected then
1479     Open;
1480     if not FInternalTransaction.Active then
1481     FInternalTransaction.StartTransaction;
1482     Query := TIBSQL.Create(self);
1483     try
1484     Query.GoToFirstRecordOnExecute := False;
1485     Query.Database := Self;
1486     Query.Transaction := FInternalTransaction;
1487     if SystemTables then
1488     Query.SQL.Text := 'Select RDB$RELATION_NAME from RDB$RELATIONS' + {do not localize}
1489     ' where RDB$VIEW_BLR is NULL' {do not localize}
1490     else
1491     Query.SQL.Text := 'Select RDB$RELATION_NAME from RDB$RELATIONS' + {do not localize}
1492     ' where RDB$VIEW_BLR is NULL and RDB$SYSTEM_FLAG = 0'; {do not localize}
1493     Query.Prepare;
1494     Query.ExecQuery;
1495     with List do
1496     begin
1497     BeginUpdate;
1498     try
1499     Clear;
1500     while (not Query.EOF) and (Query.Next <> nil) do
1501     List.Add(TrimRight(Query.Current[0].AsString));
1502     finally
1503     EndUpdate;
1504     end;
1505     end;
1506     finally
1507     Query.Free;
1508     FInternalTransaction.Commit;
1509     end;
1510     end;
1511     end;
1512    
1513     { TIBTransaction }
1514    
1515     constructor TIBTransaction.Create(AOwner: TComponent);
1516     begin
1517     inherited Create(AOwner);
1518     FIBLoaded := False;
1519     CheckIBLoaded;
1520     FIBLoaded := True;
1521     CheckIBLoaded;
1522     FDatabases := TList.Create;
1523     FSQLObjects := TList.Create;
1524     FHandle := nil;
1525     FTPB := nil;
1526     FTPBLength := 0;
1527     FTRParams := TStringList.Create;
1528     FTRParamsChanged := True;
1529     TStringList(FTRParams).OnChange := TRParamsChange;
1530     TStringList(FTRParams).OnChanging := TRParamsChanging;
1531     FTimer := TFPTimer.Create(Self);
1532     FTimer.Enabled := False;
1533     FTimer.Interval := 0;
1534     FTimer.OnTimer := TimeoutTransaction;
1535     FDefaultAction := taCommit;
1536     end;
1537    
1538     destructor TIBTransaction.Destroy;
1539     var
1540     i: Integer;
1541     begin
1542     if FIBLoaded then
1543     begin
1544     if InTransaction then
1545     EndTransaction(FDefaultAction, True);
1546     for i := 0 to FSQLObjects.Count - 1 do
1547     if FSQLObjects[i] <> nil then
1548     SQLObjects[i].DoTransactionFree;
1549     RemoveSQLObjects;
1550     RemoveDatabases;
1551     FreeMem(FTPB);
1552     FTPB := nil;
1553     FTRParams.Free;
1554     FSQLObjects.Free;
1555     FDatabases.Free;
1556     end;
1557     inherited Destroy;
1558     end;
1559    
1560     function TIBTransaction.Call(ErrCode: ISC_STATUS;
1561     RaiseError: Boolean): ISC_STATUS;
1562     var
1563     i: Integer;
1564     begin
1565     result := ErrCode;
1566     for i := 0 to FDatabases.Count - 1 do if FDatabases[i] <> nil then
1567     Databases[i].FCanTimeout := False;
1568     FCanTimeout := False;
1569     if RaiseError and (result > 0) then
1570     IBDataBaseError;
1571     end;
1572    
1573     procedure TIBTransaction.CheckDatabasesInList;
1574     begin
1575     if GetDatabaseCount = 0 then
1576     IBError(ibxeNoDatabasesInTransaction, [nil]);
1577     end;
1578    
1579     procedure TIBTransaction.CheckInTransaction;
1580     begin
1581     if FStreamedActive and (not InTransaction) then
1582     Loaded;
1583     if (FHandle = nil) then
1584     IBError(ibxeNotInTransaction, [nil]);
1585     end;
1586    
1587     procedure TIBTransaction.DoBeforeTransactionEnd;
1588     begin
1589     if Assigned(FBeforeTransactionEnd) then
1590     FBeforeTransactionEnd(self);
1591     end;
1592    
1593     procedure TIBTransaction.DoAfterTransactionEnd;
1594     begin
1595     if Assigned(FAfterTransactionEnd) then
1596     FAfterTransactionEnd(self);
1597     end;
1598    
1599     procedure TIBTransaction.DoOnStartTransaction;
1600     begin
1601     if assigned(FOnStartTransaction) then
1602     OnStartTransaction(self);
1603     end;
1604    
1605     procedure TIBTransaction.DoAfterExecQuery(Sender: TObject);
1606     begin
1607     if assigned(FAfterExecQuery) then
1608     AfterExecQuery(Sender);
1609     end;
1610    
1611     procedure TIBTransaction.DoAfterEdit(Sender: TObject);
1612     begin
1613     if assigned(FAfterEdit) then
1614     AfterEdit(Sender);
1615     end;
1616    
1617     procedure TIBTransaction.DoAfterDelete(Sender: TObject);
1618     begin
1619     if assigned(FAfterDelete) then
1620     AfterDelete(Sender);
1621     end;
1622    
1623     procedure TIBTransaction.DoAfterInsert(Sender: TObject);
1624     begin
1625     if assigned(FAfterInsert) then
1626     AfterInsert(Sender);
1627     end;
1628    
1629     procedure TIBTransaction.DoAfterPost(Sender: TObject);
1630     begin
1631     if assigned(FAfterPost) then
1632     AfterPost(Sender);
1633     end;
1634    
1635     procedure TIBTransaction.EnsureNotInTransaction;
1636     begin
1637     if csDesigning in ComponentState then
1638     begin
1639     if FHandle <> nil then
1640     Rollback;
1641     end;
1642     end;
1643    
1644     procedure TIBTransaction.CheckNotInTransaction;
1645     begin
1646     if (FHandle <> nil) then
1647     IBError(ibxeInTransaction, [nil]);
1648     end;
1649    
1650     function TIBTransaction.AddDatabase(db: TIBDatabase): Integer;
1651     var
1652     i: Integer;
1653     NilFound: Boolean;
1654     begin
1655     i := FindDatabase(db);
1656     if i <> -1 then
1657     begin
1658     result := i;
1659     exit;
1660     end;
1661     NilFound := False;
1662     i := 0;
1663     while (not NilFound) and (i < FDatabases.Count) do
1664     begin
1665     NilFound := (FDatabases[i] = nil);
1666     if (not NilFound) then
1667     Inc(i);
1668     end;
1669     if (NilFound) then
1670     begin
1671     FDatabases[i] := db;
1672     result := i;
1673     end
1674     else
1675     begin
1676     result := FDatabases.Count;
1677     FDatabases.Add(db);
1678     end;
1679     end;
1680    
1681     function TIBTransaction.AddSQLObject(ds: TIBBase): Integer;
1682     begin
1683     result := 0;
1684     while (result < FSQLObjects.Count) and (FSQLObjects[result] <> nil) do
1685     Inc(result);
1686     if (result = FSQLObjects.Count) then
1687     FSQLObjects.Add(ds)
1688     else
1689     FSQLObjects[result] := ds;
1690     end;
1691    
1692     procedure TIBTransaction.Commit;
1693     begin
1694     EndTransaction(TACommit, False);
1695     end;
1696    
1697     procedure TIBTransaction.CommitRetaining;
1698     begin
1699     EndTransaction(TACommitRetaining, False);
1700     end;
1701    
1702     procedure TIBTransaction.EndTransaction(Action: TTransactionAction;
1703     Force: Boolean);
1704     var
1705     status: ISC_STATUS;
1706     i: Integer;
1707     begin
1708     CheckInTransaction;
1709     if FInEndTransaction then Exit;
1710     FInEndTransaction := true;
1711     FEndAction := Action;
1712     try
1713     case Action of
1714     TARollback, TACommit:
1715     begin
1716     if (HandleIsShared) and
1717     (Action <> FDefaultAction) and
1718     (not Force) then
1719     IBError(ibxeCantEndSharedTransaction, [nil]);
1720     DoBeforeTransactionEnd;
1721     for i := 0 to FSQLObjects.Count - 1 do if FSQLObjects[i] <> nil then
1722     SQLObjects[i].DoBeforeTransactionEnd(Action);
1723     if InTransaction then
1724     begin
1725     if HandleIsShared then
1726     begin
1727     FHandle := nil;
1728     FHandleIsShared := False;
1729     status := 0;
1730     end
1731     else
1732     if (Action = TARollback) then
1733     status := Call(isc_rollback_transaction(StatusVector, @FHandle), False)
1734     else
1735     status := Call(isc_commit_transaction(StatusVector, @FHandle), False);
1736     if ((Force) and (status > 0)) then
1737     status := Call(isc_rollback_transaction(StatusVector, @FHandle), False);
1738     if Force then
1739     FHandle := nil
1740     else
1741     if (status > 0) then
1742     IBDataBaseError;
1743     for i := 0 to FSQLObjects.Count - 1 do if FSQLObjects[i] <> nil then
1744     SQLObjects[i].DoAfterTransactionEnd;
1745     DoAfterTransactionEnd;
1746     end;
1747     end;
1748     TACommitRetaining:
1749     Call(isc_commit_retaining(StatusVector, @FHandle), True);
1750     TARollbackRetaining:
1751     Call(isc_rollback_retaining(StatusVector, @FHandle), True);
1752     end;
1753     if not (csDesigning in ComponentState) then
1754     begin
1755     case Action of
1756     TACommit:
1757     MonitorHook.TRCommit(Self);
1758     TARollback:
1759     MonitorHook.TRRollback(Self);
1760     TACommitRetaining:
1761     MonitorHook.TRCommitRetaining(Self);
1762     TARollbackRetaining:
1763     MonitorHook.TRRollbackRetaining(Self);
1764     end;
1765     end;
1766     finally
1767     FInEndTransaction := false
1768     end;
1769     end;
1770    
1771     function TIBTransaction.GetDatabase(Index: Integer): TIBDatabase;
1772     begin
1773     result := FDatabases[Index];
1774     end;
1775    
1776     function TIBTransaction.GetDatabaseCount: Integer;
1777     var
1778     i, Cnt: Integer;
1779     begin
1780     result := 0;
1781     Cnt := FDatabases.Count - 1;
1782     for i := 0 to Cnt do if FDatabases[i] <> nil then
1783     Inc(result);
1784     end;
1785    
1786     function TIBTransaction.GetSQLObject(Index: Integer): TIBBase;
1787     begin
1788     result := FSQLObjects[Index];
1789     end;
1790    
1791     function TIBTransaction.GetSQLObjectCount: Integer;
1792     var
1793     i, Cnt: Integer;
1794     begin
1795     result := 0;
1796     Cnt := FSQLObjects.Count - 1;
1797     for i := 0 to Cnt do if FSQLObjects[i] <> nil then
1798     Inc(result);
1799     end;
1800    
1801     function TIBTransaction.GetInTransaction: Boolean;
1802     begin
1803     result := (FHandle <> nil);
1804     end;
1805    
1806     function TIBTransaction.FindDatabase(db: TIBDatabase): Integer;
1807     var
1808     i: Integer;
1809     begin
1810     result := -1;
1811     for i := 0 to FDatabases.Count - 1 do
1812     if db = TIBDatabase(FDatabases[i]) then
1813     begin
1814     result := i;
1815     break;
1816     end;
1817     end;
1818    
1819     function TIBTransaction.FindDefaultDatabase: TIBDatabase;
1820     var
1821     i: Integer;
1822     begin
1823     result := FDefaultDatabase;
1824     if result = nil then
1825     begin
1826     for i := 0 to FDatabases.Count - 1 do
1827     if (TIBDatabase(FDatabases[i]) <> nil) and
1828     (TIBDatabase(FDatabases[i]).DefaultTransaction = self) then
1829     begin
1830     result := TIBDatabase(FDatabases[i]);
1831     break;
1832     end;
1833     end;
1834     end;
1835    
1836     function TIBTransaction.GetEndAction: TTransactionAction;
1837     begin
1838     if FInEndTransaction then
1839     Result := FEndAction
1840     else
1841     IBError(ibxeIB60feature, [nil])
1842     end;
1843    
1844    
1845     function TIBTransaction.GetIdleTimer: Integer;
1846     begin
1847     result := FTimer.Interval;
1848     end;
1849    
1850     procedure TIBTransaction.Loaded;
1851     begin
1852     inherited Loaded;
1853     end;
1854    
1855     procedure TIBTransaction.BeforeDatabaseDisconnect(DB: TIBDatabase);
1856     begin
1857     if InTransaction then
1858     EndTransaction(FDefaultAction, True);
1859     end;
1860    
1861     procedure TIBTransaction.RemoveDatabase(Idx: Integer);
1862     var
1863     DB: TIBDatabase;
1864     begin
1865     if ((Idx >= 0) and (FDatabases[Idx] <> nil)) then
1866     begin
1867     DB := Databases[Idx];
1868     FDatabases[Idx] := nil;
1869     DB.RemoveTransaction(DB.FindTransaction(Self));
1870     if DB = FDefaultDatabase then
1871     FDefaultDatabase := nil;
1872     end;
1873     end;
1874    
1875     procedure TIBTransaction.RemoveDatabases;
1876     var
1877     i: Integer;
1878     begin
1879     for i := 0 to FDatabases.Count - 1 do if FDatabases[i] <> nil then
1880     RemoveDatabase(i);
1881     end;
1882    
1883     procedure TIBTransaction.RemoveSQLObject(Idx: Integer);
1884     var
1885     ds: TIBBase;
1886     begin
1887     if ((Idx >= 0) and (FSQLObjects[Idx] <> nil)) then
1888     begin
1889     ds := SQLObjects[Idx];
1890     FSQLObjects[Idx] := nil;
1891     ds.Transaction := nil;
1892     end;
1893     end;
1894    
1895     procedure TIBTransaction.RemoveSQLObjects;
1896     var
1897     i: Integer;
1898     begin
1899     for i := 0 to FSQLObjects.Count - 1 do if FSQLObjects[i] <> nil then
1900     RemoveSQLObject(i);
1901     end;
1902    
1903     procedure TIBTransaction.Rollback;
1904     begin
1905     EndTransaction(TARollback, False);
1906     end;
1907    
1908     procedure TIBTransaction.RollbackRetaining;
1909     begin
1910     EndTransaction(TARollbackRetaining, False);
1911     end;
1912    
1913     procedure TIBTransaction.SetActive(Value: Boolean);
1914     begin
1915     if csReading in ComponentState then
1916     FStreamedActive := Value
1917     else
1918     if Value and not InTransaction then
1919     StartTransaction
1920     else
1921     if not Value and InTransaction then
1922     Rollback;
1923     end;
1924    
1925     procedure TIBTransaction.SetDefaultAction(Value: TTransactionAction);
1926     begin
1927     (* if (Value = taRollbackRetaining) and (GetIBClientVersion < 6) then
1928     IBError(ibxeIB60feature, [nil]);*)
1929     FDefaultAction := Value;
1930     end;
1931    
1932     procedure TIBTransaction.SetDefaultDatabase(Value: TIBDatabase);
1933     var
1934     i: integer;
1935     begin
1936     if (FDefaultDatabase <> nil) and (FDefaultDatabase <> Value) then
1937     begin
1938     i := FDefaultDatabase.FindTransaction(self);
1939     if (i <> -1) then
1940     FDefaultDatabase.RemoveTransaction(i);
1941     end;
1942     if (Value <> nil) and (FDefaultDatabase <> Value) then
1943     begin
1944     Value.AddTransaction(Self);
1945     AddDatabase(Value);
1946     for i := 0 to FSQLObjects.Count - 1 do
1947     if (FSQLObjects[i] <> nil) and
1948     (TIBBase(FSQLObjects[i]).Database = nil) then
1949     SetObjectProp(TIBBase(FSQLObjects[i]).Owner, 'Database', Value);
1950     end;
1951     FDefaultDatabase := Value;
1952     end;
1953    
1954     procedure TIBTransaction.SetHandle(Value: TISC_TR_HANDLE);
1955     begin
1956     if (HandleIsShared) then
1957     EndTransaction(DefaultAction, True)
1958     else
1959     CheckNotInTransaction;
1960     FHandle := Value;
1961     FHandleIsShared := (Value <> nil);
1962     end;
1963    
1964     procedure TIBTransaction.Notification( AComponent: TComponent;
1965     Operation: TOperation);
1966     var
1967     i: Integer;
1968     begin
1969     inherited Notification( AComponent, Operation);
1970     if (Operation = opRemove) and (AComponent = FDefaultDatabase) then
1971     begin
1972     i := FindDatabase(FDefaultDatabase);
1973     if (i <> -1) then
1974     RemoveDatabase(i);
1975     FDefaultDatabase := nil;
1976     end;
1977     end;
1978    
1979     procedure TIBTransaction.SetIdleTimer(Value: Integer);
1980     begin
1981     if Value < 0 then
1982     IBError(ibxeTimeoutNegative, [nil])
1983     else
1984     if (Value = 0) then
1985     begin
1986     FTimer.Enabled := False;
1987     FTimer.Interval := 0;
1988     end
1989     else
1990     if (Value > 0) then
1991     begin
1992     FTimer.Interval := Value;
1993     if not (csDesigning in ComponentState) then
1994     FTimer.Enabled := True;
1995     end;
1996     end;
1997    
1998     procedure TIBTransaction.SetTRParams(Value: TStrings);
1999     begin
2000     FTRParams.Assign(Value);
2001     end;
2002    
2003     procedure TIBTransaction.StartTransaction;
2004     var
2005     pteb: PISC_TEB_ARRAY;
2006     TPB: String;
2007     i: Integer;
2008     begin
2009     CheckNotInTransaction;
2010     CheckDatabasesInList;
2011     for i := 0 to FDatabases.Count - 1 do
2012     if FDatabases[i] <> nil then
2013     begin
2014     with TIBDatabase(FDatabases[i]) do
2015     if not Connected then
2016     if FStreamedConnected then
2017     begin
2018     Open;
2019     FStreamedConnected := False;
2020     end
2021     else
2022     IBError(ibxeDatabaseClosed, [nil]);
2023     end;
2024     if FTRParamsChanged then
2025     begin
2026     FTRParamsChanged := False;
2027     GenerateTPB(FTRParams, TPB, FTPBLength);
2028     if FTPBLength > 0 then
2029     begin
2030     IBAlloc(FTPB, 0, FTPBLength);
2031     Move(TPB[1], FTPB[0], FTPBLength);
2032     end;
2033     end;
2034    
2035     pteb := nil;
2036     IBAlloc(pteb, 0, DatabaseCount * SizeOf(TISC_TEB));
2037     try
2038     for i := 0 to DatabaseCount - 1 do if Databases[i] <> nil then
2039     begin
2040     pteb^[i].db_handle := @(Databases[i].Handle);
2041     pteb^[i].tpb_length := FTPBLength;
2042     pteb^[i].tpb_address := FTPB;
2043     end;
2044     if Call(isc_start_multiple(StatusVector, @FHandle,
2045     DatabaseCount, PISC_TEB(pteb)), False) > 0 then
2046     begin
2047     FHandle := nil;
2048     IBDataBaseError;
2049     end;
2050     if not (csDesigning in ComponentState) then
2051     MonitorHook.TRStart(Self);
2052     finally
2053     FreeMem(pteb);
2054     end;
2055     DoOnStartTransaction;
2056     end;
2057    
2058     procedure TIBTransaction.TimeoutTransaction(Sender: TObject);
2059     begin
2060     if InTransaction then
2061     begin
2062     if FCanTimeout then
2063     begin
2064     EndTransaction(FDefaultAction, True);
2065     if Assigned(FOnIdleTimer) then
2066     FOnIdleTimer(Self);
2067     end
2068     else
2069     FCanTimeout := True;
2070     end;
2071     end;
2072    
2073     procedure TIBTransaction.TRParamsChange(Sender: TObject);
2074     begin
2075     FTRParamsChanged := True;
2076     end;
2077    
2078     procedure TIBTransaction.TRParamsChanging(Sender: TObject);
2079     begin
2080     EnsureNotInTransaction;
2081     CheckNotInTransaction;
2082     end;
2083    
2084     { TIBBase }
2085     constructor TIBBase.Create(AOwner: TObject);
2086     begin
2087     FOwner := AOwner;
2088     end;
2089    
2090     destructor TIBBase.Destroy;
2091     begin
2092     SetDatabase(nil);
2093     SetTransaction(nil);
2094     inherited Destroy;
2095     end;
2096    
2097     function TIBBase.GetCharSetSize(CharSetID: integer): integer;
2098     begin
2099     if (CharSetID >= 0) and (CharSetID < Length(Database.FCharSetSizes)) then
2100     Result := Database.FCharSetSizes[CharSetID]
2101     else
2102     Result := 1; {Unknown character set}
2103     end;
2104    
2105 tony 35 function TIBBase.GetDefaultCharSetSize: integer;
2106     var DefaultCharSetName: string;
2107     i: integer;
2108     begin
2109     DefaultCharSetName := GetDefaultCharSetName;
2110     Result := 4; {worse case}
2111     for i := 0 to Length(Database.FCharSetSizes) - 1 do
2112     if Database.FCharSetNames[i] = DefaultCharSetName then
2113     begin
2114     Result := Database.FCharSetSizes[i];
2115     break;
2116     end;
2117     end;
2118    
2119     function TIBBase.GetCharSetName(CharSetID: integer): string;
2120     begin
2121     if (CharSetID >= 0) and (CharSetID < Length(Database.FCharSetNames)) then
2122     Result := Database.FCharSetNames[CharSetID]
2123     else
2124     Result := ''; {Unknown character set}
2125     end;
2126    
2127 tony 39 function TIBBase.GetDefaultCharSetName: RawByteString;
2128 tony 35 begin
2129 tony 39 Result := Database.FDefaultCharSetName;
2130 tony 35 end;
2131    
2132 tony 39 {$IFDEF HAS_ANSISTRING_CODEPAGE}
2133     function TIBBase.GetCodePage(CharSetID: integer): TSystemCodePage;
2134     begin
2135     if (CharSetID >= 0) and (CharSetID < Length(Database.FCodePages)) then
2136     Result := Database.FCodePages[CharSetID]
2137     else
2138     Result := CP_NONE; {Unknown character set}
2139     end;
2140    
2141     function TIBBase.GetDefaultCodePage: TSystemCodePage;
2142     begin
2143     Result := Database.FDefaultCodePage;
2144     end;
2145    
2146     {$ENDIF}
2147    
2148 tony 33 procedure TIBBase.HandleException(Sender: TObject);
2149     begin
2150     if assigned(Database) then
2151     Database.HandleException(Sender)
2152     else
2153     SysUtils.ShowException(ExceptObject,ExceptAddr);
2154     end;
2155    
2156     procedure TIBBase.SetCursor;
2157     begin
2158     if Assigned(Database) and not Database.SQLHourGlass then
2159     Exit;
2160     if assigned(IBGUIInterface) then
2161     IBGUIInterface.SetCursor;
2162     end;
2163    
2164     procedure TIBBase.RestoreCursor;
2165     begin
2166     if Assigned(Database) and not Database.SQLHourGlass then
2167     Exit;
2168     if assigned(IBGUIInterface) then
2169     IBGUIInterface.RestoreCursor;
2170     end;
2171    
2172     procedure TIBBase.CheckDatabase;
2173     begin
2174     if (FDatabase = nil) then
2175     IBError(ibxeDatabaseNotAssigned, [nil]);
2176     FDatabase.CheckActive;
2177     end;
2178    
2179     procedure TIBBase.CheckTransaction;
2180     begin
2181     if FTransaction = nil then
2182     IBError(ibxeTransactionNotAssigned, [nil]);
2183     FTransaction.CheckInTransaction;
2184     end;
2185    
2186     function TIBBase.GetDBHandle: PISC_DB_HANDLE;
2187     begin
2188     CheckDatabase;
2189     result := @FDatabase.Handle;
2190     end;
2191    
2192     function TIBBase.GetTRHandle: PISC_TR_HANDLE;
2193     begin
2194     CheckTransaction;
2195     result := @FTransaction.Handle;
2196     end;
2197    
2198     procedure TIBBase.DoBeforeDatabaseConnect(DBParams: TStrings; var DBName: string
2199     );
2200     begin
2201     if assigned(FBeforeDatabaseConnect) then
2202     BeforeDatabaseConnect(self,DBParams,DBName);
2203     end;
2204    
2205     procedure TIBBase.DoAfterDatabaseConnect;
2206     begin
2207     if assigned(FAfterDatabaseConnect) then
2208     AfterDatabaseConnect(self);
2209     end;
2210    
2211     procedure TIBBase.DoBeforeDatabaseDisconnect;
2212     begin
2213     if Assigned(BeforeDatabaseDisconnect) then
2214     BeforeDatabaseDisconnect(Self);
2215     end;
2216    
2217     procedure TIBBase.DoAfterDatabaseDisconnect;
2218     begin
2219     if Assigned(AfterDatabaseDisconnect) then
2220     AfterDatabaseDisconnect(Self);
2221     end;
2222    
2223     procedure TIBBase.DoDatabaseFree;
2224     begin
2225     if Assigned(OnDatabaseFree) then
2226     OnDatabaseFree(Self);
2227     SetDatabase(nil);
2228     SetTransaction(nil);
2229     end;
2230    
2231     procedure TIBBase.DoBeforeTransactionEnd(Action: TTransactionAction);
2232     begin
2233     if Assigned(BeforeTransactionEnd) then
2234     BeforeTransactionEnd(Self,Action);
2235     end;
2236    
2237     procedure TIBBase.DoAfterTransactionEnd;
2238     begin
2239     if Assigned(AfterTransactionEnd) then
2240     AfterTransactionEnd(Self);
2241     end;
2242    
2243     procedure TIBBase.DoTransactionFree;
2244     begin
2245     if Assigned(OnTransactionFree) then
2246     OnTransactionFree(Self);
2247     FTransaction := nil;
2248     end;
2249    
2250     procedure TIBBase.DoAfterExecQuery(Sender: TObject);
2251     begin
2252     if FTransaction <> nil then
2253     FTransaction.DoAfterExecQuery(Sender);
2254     end;
2255    
2256     procedure TIBBase.DoAfterEdit(Sender: TObject);
2257     begin
2258     if FTransaction <> nil then
2259     FTransaction.DoAfterEdit(Sender);
2260     end;
2261    
2262     procedure TIBBase.DoAfterDelete(Sender: TObject);
2263     begin
2264     if FTransaction <> nil then
2265     FTransaction.DoAfterDelete(Sender);
2266     end;
2267    
2268     procedure TIBBase.DoAfterInsert(Sender: TObject);
2269     begin
2270     if FTransaction <> nil then
2271     FTransaction.DoAfterInsert(Sender);
2272     end;
2273    
2274     procedure TIBBase.DoAfterPost(Sender: TObject);
2275     begin
2276     if FTransaction <> nil then
2277     FTransaction.DoAfterPost(Sender);
2278     end;
2279    
2280     procedure TIBBase.SetDatabase(Value: TIBDatabase);
2281     begin
2282     if (FDatabase <> nil) then
2283     FDatabase.RemoveSQLObject(FIndexInDatabase);
2284     FDatabase := Value;
2285     if (FDatabase <> nil) then
2286     begin
2287     FIndexInDatabase := FDatabase.AddSQLObject(Self);
2288     if (FTransaction = nil) then
2289     Transaction := FDatabase.FindDefaultTransaction;
2290     end;
2291     end;
2292    
2293     procedure TIBBase.SetTransaction(Value: TIBTransaction);
2294     begin
2295     if (FTransaction <> nil) then
2296     FTransaction.RemoveSQLObject(FIndexInTransaction);
2297     FTransaction := Value;
2298     if (FTransaction <> nil) then
2299     begin
2300     FIndexInTransaction := FTransaction.AddSQLObject(Self);
2301     if (FDatabase = nil) then
2302     Database := FTransaction.FindDefaultDatabase;
2303     end;
2304     end;
2305    
2306     { GenerateDPB -
2307     Given a string containing a textual representation
2308     of the database parameters, generate a database
2309     parameter buffer, and return it and its length
2310     in DPB and DPBLength, respectively. }
2311    
2312     procedure GenerateDPB(sl: TStrings; var DPB: string; var DPBLength: Short);
2313     var
2314     i, j, pval: Integer;
2315     DPBVal: UShort;
2316     ParamName, ParamValue: string;
2317     begin
2318     { The DPB is initially empty, with the exception that
2319     the DPB version must be the first byte of the string. }
2320     DPBLength := 1;
2321     DPB := Char(isc_dpb_version1);
2322    
2323     {Iterate through the textual database parameters, constructing
2324     a DPB on-the-fly }
2325     for i := 0 to sl.Count - 1 do
2326     begin
2327     { Get the parameter's name and value from the list,
2328     and make sure that the name is all lowercase with
2329     no leading 'isc_dpb_' prefix
2330     }
2331     if (Trim(sl.Names[i]) = '') then
2332     continue;
2333     ParamName := LowerCase(sl.Names[i]); {mbcs ok}
2334     ParamValue := Copy(sl[i], Pos('=', sl[i]) + 1, Length(sl[i])); {mbcs ok}
2335     if (Pos(DPBPrefix, ParamName) = 1) then {mbcs ok}
2336     Delete(ParamName, 1, Length(DPBPrefix));
2337     { We want to translate the parameter name to some Integer
2338     value. We do this by scanning through a list of known
2339     database parameter names (DPBConstantNames, defined above) }
2340     DPBVal := 0;
2341     { Find the parameter }
2342     for j := 1 to isc_dpb_last_dpb_constant do
2343     if (ParamName = DPBConstantNames[j]) then
2344     begin
2345     DPBVal := j;
2346     break;
2347     end;
2348     { A database parameter either contains a string value (case 1)
2349     or an Integer value (case 2)
2350     or no value at all (case 3)
2351     or an error needs to be generated (case else) }
2352     case DPBVal of
2353     isc_dpb_user_name, isc_dpb_password, isc_dpb_password_enc,
2354     isc_dpb_sys_user_name, isc_dpb_license, isc_dpb_encrypt_key,
2355     isc_dpb_lc_messages, isc_dpb_lc_ctype,
2356     isc_dpb_sql_role_name, isc_dpb_sql_dialect:
2357     begin
2358     if DPBVal = isc_dpb_sql_dialect then
2359     ParamValue[1] := Char(Ord(ParamValue[1]) - 48);
2360     DPB := DPB +
2361     Char(DPBVal) +
2362     Char(Length(ParamValue)) +
2363     ParamValue;
2364     Inc(DPBLength, 2 + Length(ParamValue));
2365     end;
2366     isc_dpb_num_buffers, isc_dpb_dbkey_scope, isc_dpb_force_write,
2367     isc_dpb_no_reserve, isc_dpb_damaged, isc_dpb_verify:
2368     begin
2369     DPB := DPB +
2370     Char(DPBVal) +
2371     #1 +
2372     Char(StrToInt(ParamValue));
2373     Inc(DPBLength, 3);
2374     end;
2375     isc_dpb_sweep:
2376     begin
2377     DPB := DPB +
2378     Char(DPBVal) +
2379     #1 +
2380     Char(isc_dpb_records);
2381     Inc(DPBLength, 3);
2382     end;
2383     isc_dpb_sweep_interval:
2384     begin
2385     pval := StrToInt(ParamValue);
2386     DPB := DPB +
2387     Char(DPBVal) +
2388     #4 +
2389     PChar(@pval)[0] +
2390     PChar(@pval)[1] +
2391     PChar(@pval)[2] +
2392     PChar(@pval)[3];
2393     Inc(DPBLength, 6);
2394     end;
2395     isc_dpb_activate_shadow, isc_dpb_delete_shadow, isc_dpb_begin_log,
2396     isc_dpb_quit_log:
2397     begin
2398     DPB := DPB +
2399     Char(DPBVal) +
2400     #1 + #0;
2401     Inc(DPBLength, 3);
2402     end;
2403     else
2404     begin
2405     if (DPBVal > 0) and
2406     (DPBVal <= isc_dpb_last_dpb_constant) then
2407     IBError(ibxeDPBConstantNotSupported, [DPBConstantNames[DPBVal]])
2408     else
2409     IBError(ibxeDPBConstantUnknownEx, [sl.Names[i]]);
2410     end;
2411     end;
2412     end;
2413     end;
2414    
2415     { GenerateTPB -
2416     Given a string containing a textual representation
2417     of the transaction parameters, generate a transaction
2418     parameter buffer, and return it and its length in
2419     TPB and TPBLength, respectively. }
2420     procedure GenerateTPB(sl: TStrings; var TPB: string; var TPBLength: Short);
2421     var
2422     i, j, TPBVal, ParamLength: Integer;
2423     ParamName, ParamValue: string;
2424     begin
2425     TPB := '';
2426     if (sl.Count = 0) then
2427     TPBLength := 0
2428     else
2429     begin
2430     TPBLength := sl.Count + 1;
2431     TPB := TPB + Char(isc_tpb_version3);
2432     end;
2433     for i := 0 to sl.Count - 1 do
2434     begin
2435     if (Trim(sl[i]) = '') then
2436     begin
2437     Dec(TPBLength);
2438     Continue;
2439     end;
2440     if (Pos('=', sl[i]) = 0) then {mbcs ok}
2441     ParamName := LowerCase(sl[i]) {mbcs ok}
2442     else
2443     begin
2444     ParamName := LowerCase(sl.Names[i]); {mbcs ok}
2445     ParamValue := Copy(sl[i], Pos('=', sl[i]) + 1, Length(sl[i])); {mbcs ok}
2446     end;
2447     if (Pos(TPBPrefix, ParamName) = 1) then {mbcs ok}
2448     Delete(ParamName, 1, Length(TPBPrefix));
2449     TPBVal := 0;
2450     { Find the parameter }
2451     for j := 1 to isc_tpb_last_tpb_constant do
2452     if (ParamName = TPBConstantNames[j]) then
2453     begin
2454     TPBVal := j;
2455     break;
2456     end;
2457     { Now act on it }
2458     case TPBVal of
2459     isc_tpb_consistency, isc_tpb_exclusive, isc_tpb_protected,
2460     isc_tpb_concurrency, isc_tpb_shared, isc_tpb_wait, isc_tpb_nowait,
2461     isc_tpb_read, isc_tpb_write, isc_tpb_ignore_limbo,
2462     isc_tpb_read_committed, isc_tpb_rec_version, isc_tpb_no_rec_version:
2463     TPB := TPB + Char(TPBVal);
2464     isc_tpb_lock_read, isc_tpb_lock_write:
2465     begin
2466     TPB := TPB + Char(TPBVal);
2467     { Now set the string parameter }
2468     ParamLength := Length(ParamValue);
2469     Inc(TPBLength, ParamLength + 1);
2470     TPB := TPB + Char(ParamLength) + ParamValue;
2471     end;
2472     else
2473     begin
2474     if (TPBVal > 0) and
2475     (TPBVal <= isc_tpb_last_tpb_constant) then
2476     IBError(ibxeTPBConstantNotSupported, [TPBConstantNames[TPBVal]])
2477     else
2478     IBError(ibxeTPBConstantUnknownEx, [sl.Names[i]]);
2479     end;
2480     end;
2481     end;
2482     end;
2483    
2484     end.
2485    
2486    
2487    
2488    
2489