ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBDatabase.pas
Revision: 80
Committed: Mon Jan 1 11:31:07 2018 UTC (6 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 63620 byte(s)
Log Message:
Fixes merged into public release

File Contents

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