ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/runtime/nongui/IBDatabase.pas
Revision: 362
Committed: Tue Dec 7 13:27:39 2021 UTC (2 years, 3 months ago) by tony
Content type: text/x-pascal
File size: 68172 byte(s)
Log Message:
initiate test release

File Contents

# Content
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
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 TIBDataBase = class(TIBXMonitoredConnection)
62 private
63 type TIBDatabaseCloseActions = (caNormal,caForce, caDropDatabase);
64 private
65 FCloseAction: TIBDatabaseCloseActions;
66 FAttachment: IAttachment;
67 FConfigOverrides: TStrings;
68 FCreateDatabase: boolean;
69 FCreateIfNotExists: boolean;
70 FAllowStreamedConnected: boolean;
71 FFirebirdLibraryPathName: TIBFileName;
72 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 FUseHiddenPassword: boolean;
91 FFirebirdAPI: IFirebirdAPI;
92 procedure EnsureInactive;
93 function GetAuthenticationMethod: string;
94 function GetDBSQLDialect: Integer;
95 function GetDefaultCharSetID: integer;
96 function GetDefaultCharSetName: AnsiString;
97 function GetDefaultCodePage: TSystemCodePage;
98 function GetDPBConstantNames(index: byte): string;
99 function GetFirebirdAPI: IFirebirdAPI;
100 function GetRemoteProtocol: string;
101 function GetSQLObjectsCount: Integer;
102 function GetWireCompression: boolean;
103 procedure SetAttachment(AValue: IAttachment);
104 procedure SetConfigOverrides(AValue: TStrings);
105 procedure SetFirebirdLibraryPathName(AValue: TIBFileName);
106 procedure SetSQLDialect(const Value: Integer);
107 procedure SetWireCompression(AValue: boolean);
108 procedure ValidateClientSQLDialect;
109 procedure DBParamsChange(Sender: TObject);
110 procedure DBParamsChanging(Sender: TObject);
111 function GenerateDPB(FirebirdAPI: IFirebirdAPI; sl: TStrings): IDPB;
112 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 procedure SetDBParamByDPB(const Idx: byte; Value: String);
120 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 procedure InternalBeforeClose;
130 procedure InternalAfterClose;
131 procedure InternalBeforeConnect(aDBParams: TStrings; var aDBName: string;
132 var aCreateIfNotExists: boolean);
133 procedure InternalAfterConnect;
134 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 procedure ReConnect;
167 procedure RemoveTransaction(Idx: Integer);
168 procedure RemoveTransactions;
169
170 property Attachment: IAttachment read FAttachment write SetAttachment;
171 property FirebirdAPI: IFirebirdAPI read GetFirebirdAPI;
172 property DPBConstantNames[index: byte]: string read GetDPBConstantNames;
173 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 property FirebirdLibraryPathName: TIBFileName read FFirebirdLibraryPathName
194 write SetFirebirdLibraryPathName;
195 property Params: TStrings read FDBParams write SetDBParams;
196 property ConfigOverrides: TStrings read FConfigOverrides write SetConfigOverrides;
197 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 property TraceFlags;
204 property UseDefaultSystemCodePage: boolean read FUseDefaultSystemCodePage
205 write FUseDefaultSystemCodePage;
206 property WireCompression: boolean read GetWireCompression write SetWireCompression
207 stored false;
208 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 property OnDialectDowngradeWarning: TNotifyEvent read FOnDialectDowngradeWarning
216 write FOnDialectDowngradeWarning;
217 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 function GetTPBConstantNames(index: byte): string;
264 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 function GenerateTPB(FirebirdAPI: IFirebirdAPI; sl: TStrings): ITPB;
275
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 property TPBConstantNames[index: byte]: string read GetTPBConstantNames;
307 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 typInfo, IBMessages, IBErrorCodes {$IFDEF WINDOWS}, Windirs {$ENDIF};
408
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 FConfigOverrides := TStringList.Create;
418 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 FTimer.Free;
453 FInternalTransaction.Free;
454 FConfigOverrides.Free;
455 FDBParams.Free;
456 FSQLObjects.Free;
457 FTransactions.Free;
458 FDataSets.Free;
459 FFirebirdAPI := nil;
460 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 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 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 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 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 end;
751
752 procedure TIBDataBase.InternalAfterClose;
753 var
754 i: Integer;
755 begin
756 for i := 0 to FSQLObjects.Count - 1 do
757 if FSQLObjects[i] <> nil then
758 SQLObjects[i].DoAfterDatabaseDisconnect;
759 end;
760
761 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 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 if (not LoginPrompt) and (FHiddenPassword <> '') and not FUseHiddenPassword then
989 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 InternalBeforeConnect(TempDBParams,aDBName,aCreateIfNotExists);
1014
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 if not FUseHiddenPassword and (not LoginPrompt and not (csDesigning in ComponentState)) or (FHiddenPassword = '') then
1021 DPB := GenerateDPB(FirebirdAPI,TempDBParams)
1022 else
1023 begin
1024 TempDBParams.Values['password'] := FHiddenPassword;
1025 DPB := GenerateDPB(FirebirdAPI,TempDBParams);
1026 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 DPB := nil
1036 else
1037 DoOnCreateDatabase;
1038 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 InternalAfterConnect;
1101 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 procedure TIBDataBase.SetDBParamByDPB( const Idx: byte; Value: String);
1164 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 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 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 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 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 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 function TIBDataBase.GetWireCompression: boolean;
1365 begin
1366 Result := CompareText(FConfigOverrides.Values['WireCompression'],'true') = 0;
1367 end;
1368
1369 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 procedure TIBDataBase.SetConfigOverrides(AValue: TStrings);
1399 begin
1400 if FConfigOverrides = AValue then Exit;
1401 FConfigOverrides.Assign(AValue);
1402 end;
1403
1404 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 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 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 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 if FTRParamsChanged or (FTPB = nil) then
2087 begin
2088 FTRParamsChanged := False;
2089 FTPB := GenerateTPB(Databases[0].FirebirdAPI,FTRParams);
2090 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 FTransactionIntf := Databases[0].FirebirdAPI.StartTransaction(Attachments,FTPB,DefaultAction);
2106 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 function TIBDataBase.GenerateDPB(FirebirdAPI: IFirebirdAPI; sl: TStrings): IDPB;
2311 var
2312 i: Integer;
2313 ParamValue: string;
2314 DPBItem: IDPBItem;
2315 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
2329 DPBItem := Result.AddByTypeName(sl.Names[i]); {mbcs ok}
2330 ParamValue := sl.ValueFromIndex[i]; {mbcs ok}
2331 { 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 case DPBItem.getParamType of
2336 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 isc_dpb_sql_role_name:
2340 DPBItem.SetAsString(ParamValue);
2341
2342 isc_dpb_sql_dialect:
2343 begin
2344 if (ParamValue = '') or (ParamValue[1] = '3') then
2345 DPBItem.SetAsString(#03)
2346 else
2347 DPBItem.SetAsString(#01)
2348 end;
2349
2350
2351 isc_dpb_num_buffers, isc_dpb_dbkey_scope, isc_dpb_force_write,
2352 isc_dpb_no_reserve, isc_dpb_damaged, isc_dpb_verify:
2353 DPBItem.SetAsByte(byte(ParamValue[1]));
2354
2355 isc_dpb_sweep:
2356 DPBItem.SetAsByte(isc_dpb_records);
2357
2358 isc_dpb_sweep_interval:
2359 DPBItem.SetAsInteger(StrToInt(ParamValue));
2360
2361 isc_dpb_activate_shadow, isc_dpb_delete_shadow, isc_dpb_begin_log,
2362 isc_dpb_map_attach, isc_dpb_quit_log:
2363 DPBItem.SetAsByte(0);
2364 else
2365 IBError(ibxeDPBConstantNotSupported, [DPBItem.getParamTypeName])
2366 end;
2367 end;
2368 if FConfigOverrides.Count > 0 then
2369 Result.Add(isc_dpb_config).SetAsString(FConfigOverrides.Text);
2370 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 function TIBTransaction.GenerateTPB(FirebirdAPI: IFirebirdAPI; sl: TStrings): ITPB;
2378 var
2379 i: Integer;
2380 ParamName, ParamValue: string;
2381 TPBItem: ITPBItem;
2382 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 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 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 {nothing more to do};
2400
2401 isc_tpb_lock_read, isc_tpb_lock_write:
2402 TPBItem.SetAsString(ParamValue);
2403
2404 else
2405 IBError(ibxeTPBConstantNotSupported, [TPBItem.getParamTypeName])
2406 end;
2407 end;
2408 end;
2409
2410 end.
2411
2412
2413
2414
2415