ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/runtime/nongui/IBDatabase.pas
Revision: 315
Committed: Thu Feb 25 11:56:36 2021 UTC (3 years, 1 month ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/runtime/nongui/IBDatabase.pas
File size: 68172 byte(s)
Log Message:
Updated for IBX 4 release

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