ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/runtime/nongui/IBDatabase.pas
Revision: 263
Committed: Thu Dec 6 15:55:01 2018 UTC (5 years, 3 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/runtime/nongui/IBDatabase.pas
File size: 68303 byte(s)
Log Message:
Release 2.3.2 committed

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