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