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