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