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