ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/nongui/IBDatabase.pas
Revision: 272
Committed: Mon Feb 4 13:34:37 2019 UTC (5 years, 1 month ago) by tony
Content type: text/x-pascal
File size: 71092 byte(s)
Log Message:
Fixes merged

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