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