ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/runtime/nongui/IBDatabase.pas
Revision: 267
Committed: Fri Dec 28 10:44:23 2018 UTC (5 years, 3 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/runtime/nongui/IBDatabase.pas
File size: 69488 byte(s)
Log Message:
Fixes Merged

File Contents

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