ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBDatabase.pas
Revision: 80
Committed: Mon Jan 1 11:31:07 2018 UTC (6 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 63620 byte(s)
Log Message:
Fixes merged into public release

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 }
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 FDefaultCharSetID: integer;
175 FDefaultCharSetName: RawByteString;
176 FDefaultCodePage: TSystemCodePage;
177 FDPB: IDPB;
178 FAllowStreamedConnected: boolean;
179 FHiddenPassword: string;
180 FOnCreateDatabase: TNotifyEvent;
181 FOnLogin: TIBDatabaseLoginEvent;
182 FSQLHourGlass: Boolean;
183 FTraceFlags: TTraceFlags;
184 FDBSQLDialect: Integer;
185 FSQLDialect: Integer;
186 FOnDialectDowngradeWarning: TNotifyEvent;
187 FSQLObjects: TList;
188 FTransactions: TList;
189 FDBName: TIBFileName;
190 FDBParams: TStrings;
191 FDBParamsChanged: Boolean;
192 FOnIdleTimer: TNotifyEvent;
193 FDefaultTransaction: TIBTransaction;
194 FInternalTransaction: TIBTransaction;
195 FTimer: TFPTimer;
196 FUserNames: TStringList;
197 FDataSets: TList;
198 FLoginCalled: boolean;
199 FUseDefaultSystemCodePage: boolean;
200 procedure EnsureInactive;
201 function GetDBSQLDialect: Integer;
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: RawByteString read FDefaultCharSetName;
267 property DefaultCharSetID: integer read FDefaultCharSetID;
268 property DefaultCodePage: TSystemCodePage read FDefaultCodePage;
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, RegExpr;
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 FDefaultCharSetName := '';
601 FDefaultCharSetID := 0;
602 FDefaultCodePage := CP_NONE;
603 end;
604
605 procedure TIBDataBase.CreateDatabase;
606 begin
607 CheckInactive;
608 CheckDatabaseName;
609 FCreateDatabase := true;
610 Connected := true;
611 end;
612
613 procedure TIBDataBase.CreateDatabase(createDatabaseSQL: string);
614 var RegexObj: TRegExpr;
615 begin
616 CheckInactive;
617 FAttachment := FirebirdAPI.CreateDatabase(createDatabaseSQL,FSQLDialect);
618 RegexObj := TRegExpr.Create;
619 try
620 {extact database file spec}
621 RegexObj.ModifierG := false; {turn off greedy matches}
622 RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''(.*)''';
623 if RegexObj.Exec(AnsiUpperCase(createDatabaseSQL)) then
624 FDBName := system.copy(createDatabaseSQL,RegexObj.MatchPos[2],RegexObj.MatchLen[2]);
625 finally
626 RegexObj.Free;
627 end;
628 if assigned(FOnCreateDatabase) and (FAttachment <> nil) then
629 OnCreateDatabase(self);
630 end;
631
632 procedure TIBDataBase.DropDatabase;
633 begin
634 CheckActive;
635 FAttachment.DropDatabase;
636 FAttachment := nil;
637 end;
638
639 procedure TIBDataBase.DBParamsChange(Sender: TObject);
640 begin
641 FDBParamsChanged := True;
642 end;
643
644 procedure TIBDataBase.DBParamsChanging(Sender: TObject);
645 begin
646 EnsureInactive;
647 CheckInactive;
648 end;
649
650 function TIBDataBase.FindTransaction(TR: TIBTransaction): Integer;
651 var
652 i: Integer;
653 begin
654 result := -1;
655 for i := 0 to FTransactions.Count - 1 do
656 if TR = Transactions[i] then
657 begin
658 result := i;
659 break;
660 end;
661 end;
662
663 function TIBDataBase.FindDefaultTransaction: TIBTransaction;
664 var
665 i: Integer;
666 begin
667 result := FDefaultTransaction;
668 if result = nil then
669 begin
670 for i := 0 to FTransactions.Count - 1 do
671 if (Transactions[i] <> nil) and
672 (TIBTransaction(Transactions[i]).DefaultDatabase = self) and
673 (TIBTransaction(Transactions[i]) <> FInternalTransaction) then
674 begin
675 result := TIBTransaction(Transactions[i]);
676 break;
677 end;
678 end;
679 end;
680
681 procedure TIBDataBase.ForceClose;
682 begin
683 if Connected then
684 InternalClose(True);
685 end;
686
687 function TIBDataBase.GetConnected: Boolean;
688 begin
689 result := (FAttachment <> nil) and FAttachment.IsConnected;
690 end;
691
692 function TIBDataBase.GetSQLObject(Index: Integer): TIBBase;
693 begin
694 result := FSQLObjects[Index];
695 end;
696
697 function TIBDataBase.GetSQLObjectCount: Integer;
698 var
699 i: Integer;
700 begin
701 result := 0;
702 for i := 0 to FSQLObjects.Count - 1 do if FSQLObjects[i] <> nil then
703 Inc(result);
704 end;
705
706 function TIBDataBase.GetIdleTimer: Integer;
707 begin
708 result := FTimer.Interval;
709 end;
710
711 function TIBDataBase.GetTransaction(Index: Integer): TIBTransaction;
712 begin
713 result := FTransactions[Index];
714 end;
715
716 function TIBDataBase.GetTransactionCount: Integer;
717 var
718 i: Integer;
719 begin
720 result := 0;
721 for i := 0 to FTransactions.Count - 1 do
722 if FTransactions[i] <> nil then
723 Inc(result);
724 end;
725
726 function TIBDataBase.IndexOfDBConst(st: String): Integer;
727 var
728 i, pos_of_str: Integer;
729 begin
730 result := -1;
731 for i := 0 to Params.Count - 1 do
732 begin
733 pos_of_str := Pos(st, AnsiLowerCase(Params[i])); {mbcs ok}
734 if (pos_of_str = 1) or (pos_of_str = Length(DPBPrefix) + 1) then
735 begin
736 result := i;
737 break;
738 end;
739 end;
740 end;
741
742 procedure TIBDataBase.InternalClose(Force: Boolean);
743 var
744 i: Integer;
745 begin
746 CheckActive;
747 { Tell all connected transactions that we're disconnecting.
748 This is so transactions can commit/rollback, accordingly
749 }
750 for i := 0 to FTransactions.Count - 1 do
751 begin
752 try
753 if FTransactions[i] <> nil then
754 Transactions[i].BeforeDatabaseDisconnect(Self);
755 except
756 if not Force then
757 raise;
758 end;
759 end;
760 for i := 0 to FSQLObjects.Count - 1 do
761 begin
762 try
763 if FSQLObjects[i] <> nil then
764 SQLObjects[i].DoBeforeDatabaseDisconnect;
765 except
766 if not Force then
767 raise;
768 end;
769 end;
770
771 FAttachment.Disconnect(Force);
772 FAttachment := nil;
773
774 if not (csDesigning in ComponentState) then
775 MonitorHook.DBDisconnect(Self);
776
777 for i := 0 to FSQLObjects.Count - 1 do
778 if FSQLObjects[i] <> nil then
779 SQLObjects[i].DoAfterDatabaseDisconnect;
780 end;
781
782 procedure TIBDataBase.CheckStreamConnect;
783 var
784 i: integer;
785 begin
786 try
787 if not (csDesigning in ComponentState) and StreamedConnected and (not Connected) then
788 begin
789 for i := 0 to FTransactions.Count - 1 do
790 if FTransactions[i] <> nil then
791 begin
792 with TIBTransaction(FTransactions[i]) do
793 if not Active then
794 if FStreamedActive and not InTransaction then
795 begin
796 StartTransaction;
797 FStreamedActive := False;
798 end;
799 end;
800 if (FDefaultTransaction <> nil) and
801 (FDefaultTransaction.FStreamedActive) and
802 (not FDefaultTransaction.InTransaction) then
803 FDefaultTransaction.StartTransaction;
804 StreamedConnected := False;
805 end;
806 except
807 if csDesigning in ComponentState then
808 HandleException(Self)
809 else
810 raise;
811 end;
812 end;
813
814 procedure TIBDataBase.HandleException(Sender: TObject);
815 var aParent: TComponent;
816 begin
817 aParent := Owner;
818 while aParent <> nil do
819 begin
820 if aParent is TCustomApplication then
821 begin
822 TCustomApplication(aParent).HandleException(Sender);
823 Exit;
824 end;
825 aParent := aParent.Owner;
826 end;
827 SysUtils.ShowException(ExceptObject,ExceptAddr);
828 end;
829
830 procedure TIBDataBase.Notification(AComponent: TComponent;
831 Operation: TOperation);
832 var
833 i: Integer;
834 begin
835 inherited Notification( AComponent, Operation);
836 if (Operation = opRemove) and (AComponent = FDefaultTransaction) then
837 begin
838 i := FindTransaction(FDefaultTransaction);
839 if (i <> -1) then
840 RemoveTransaction(i);
841 FDefaultTransaction := nil;
842 end;
843 end;
844
845 function TIBDataBase.Login(var aDatabaseName: string): Boolean;
846 var
847 IndexOfUser, IndexOfPassword: Integer;
848 Username, Password, OldPassword: String;
849 LoginParams: TStrings;
850
851 procedure HidePassword;
852 var
853 I: Integer;
854 IndexAt: Integer;
855 begin
856 IndexAt := 0;
857 for I := 0 to Params.Count -1 do
858 if Pos('password', LowerCase(Trim(Params.Names[i]))) = 1 then {mbcs ok}
859 begin
860 FHiddenPassword := Params.Values[Params.Names[i]];
861 IndexAt := I;
862 break;
863 end;
864 if IndexAt <> 0 then
865 Params.Delete(IndexAt);
866 end;
867
868 begin
869 Result := false;
870 if FLoginCalled then Exit;
871 FLoginCalled := true;
872 try
873 if Assigned(FOnLogin) and not (csDesigning in ComponentState) then
874 begin
875 result := True;
876 LoginParams := TStringList.Create;
877 try
878 LoginParams.Assign(Params);
879 FOnLogin(Self, LoginParams);
880 Params.Assign (LoginParams);
881 aDatabaseName := FDBName;
882 HidePassword;
883 finally
884 LoginParams.Free;
885 end;
886 end
887 else
888 if assigned(IBGUIInterface) then
889 begin
890 IndexOfUser := IndexOfDBConst(DPBConstantNames[isc_dpb_user_name]);
891 if IndexOfUser <> -1 then
892 Username := Copy(Params[IndexOfUser],
893 Pos('=', Params[IndexOfUser]) + 1, {mbcs ok}
894 Length(Params[IndexOfUser]));
895 IndexOfPassword := IndexOfDBConst(DPBConstantNames[isc_dpb_password]);
896 if IndexOfPassword <> -1 then
897 begin
898 Password := Copy(Params[IndexOfPassword],
899 Pos('=', Params[IndexOfPassword]) + 1, {mbcs ok}
900 Length(Params[IndexOfPassword]));
901 OldPassword := password;
902 end;
903
904 result := IBGUIInterface.LoginDialogEx(aDatabaseName, Username, Password, False);
905 if result then
906 begin
907 if Username <> '' then
908 begin
909 if IndexOfUser = -1 then
910 Params.Add(DPBConstantNames[isc_dpb_user_name] + '=' + Username)
911 else
912 Params[IndexOfUser] := DPBConstantNames[isc_dpb_user_name] +
913 '=' + Username;
914 end
915 else
916 if IndexOfUser <> -1 then
917 Params.Delete(IndexOfUser);
918 if (Password = OldPassword) then
919 FHiddenPassword := ''
920 else
921 begin
922 FHiddenPassword := Password;
923 if OldPassword <> '' then
924 HidePassword;
925 end;
926 end;
927 end
928 else
929 if LoginPrompt then
930 IBError(ibxeNoLoginDialog,[]);
931 finally
932 FLoginCalled := false
933 end;
934 end;
935
936 procedure TIBDataBase.DoConnect;
937 var
938 TempDBParams: TStrings;
939 I: integer;
940 aDBName: string;
941 Status: IStatus;
942 CharSetID: integer;
943 begin
944 CheckInactive;
945 CheckDatabaseName;
946 if (not LoginPrompt) and (FHiddenPassword <> '') then
947 begin
948 FHiddenPassword := '';
949 FDBParamsChanged := True;
950 end;
951 { Use builtin login prompt if requested }
952 aDBName := FDBName;
953 if (LoginPrompt or (csDesigning in ComponentState)) and not Login(aDBName) then
954 IBError(ibxeOperationCancelled, [nil]);
955
956 TempDBParams := TStringList.Create;
957 try
958 TempDBParams.Assign(FDBParams);
959 {$ifdef UNIX}
960 {See below for WINDOWS UseDefaultSystemCodePage}
961 if UseDefaultSystemCodePage then
962 TempDBParams.Values['lc_ctype'] :='UTF8';
963 {$endif}
964 {Opportunity to override defaults}
965 for i := 0 to FSQLObjects.Count - 1 do
966 begin
967 if FSQLObjects[i] <> nil then
968 SQLObjects[i].DoBeforeDatabaseConnect(TempDBParams,aDBName);
969 end;
970
971 repeat
972 { Generate a new DPB if necessary }
973 if (FDPB = nil) or FDBParamsChanged or (TempDBParams.Text <> FDBParams.Text) then
974 begin
975 FDBParamsChanged := False;
976 if (not LoginPrompt and not (csDesigning in ComponentState)) or (FHiddenPassword = '') then
977 FDPB := GenerateDPB(TempDBParams)
978 else
979 begin
980 TempDBParams.Values['password'] := FHiddenPassword;
981 FDPB := GenerateDPB(TempDBParams);
982 end;
983 end;
984
985 if FCreateDatabase then
986 begin
987 FCreateDatabase := false;
988 FAttachment := FirebirdAPI.CreateDatabase(aDBName,FDPB, false);
989 if assigned(FOnCreateDatabase) and (FAttachment <> nil) then
990 OnCreateDatabase(self);
991 end
992 else
993 FAttachment := FirebirdAPI.OpenDatabase(aDBName,FDPB,false);
994
995 if FAttachment = nil then
996 begin
997 Status := FirebirdAPI.GetStatus;
998 {$IFDEF UNIX}
999 if Pos(':',aDBName) = 0 then
1000 begin
1001 if ((Status.GetSQLCode = -901) and (Status.GetIBErrorCode = isc_random)) {Access permissions on firebird temp}
1002 or
1003 ((Status.GetSQLCode = -902) and (Status.GetIBErrorCode = isc_sys_request)) {Security DB Problem}
1004 or
1005 ((Status.GetSQLCode = -902) and (Status.GetIBErrorCode = isc_psw_attach)) {Security DB Problem}
1006 or
1007 ((Status.GetSQLCode = -904) and (Status.GetIBErrorCode = isc_lock_dir_access)) {Lock File Problem}
1008 then
1009 begin
1010 aDBName := 'localhost:' + aDBName;
1011 Continue;
1012 end
1013 end;
1014 {$ENDIF}
1015 if ((Status.GetSQLCode = -902) and (Status.GetIBErrorCode = isc_io_error)) {Database not found}
1016 and CreateIfNotExists and not (csDesigning in ComponentState) then
1017 FCreateDatabase := true
1018 else
1019 raise EIBInterBaseError.Create(Status);
1020 end;
1021
1022 if UseDefaultSystemCodePage and (FAttachment <> nil) then
1023 {Only now can we check the codepage in use by the Attachment.
1024 If not that required then re-open with required LCLType.}
1025 begin
1026 {$ifdef WINDOWS}
1027 if Attachment.CodePage2CharSetID(GetACP,CharSetID) then
1028 {$else}
1029 if Attachment.CodePage2CharSetID(DefaultSystemCodePage,CharSetID) then
1030 {$endif}
1031 begin
1032 FDefaultCharSetName := Attachment.GetCharsetName(CharSetID);
1033 if FDefaultCharSetName <> AnsiUpperCase(TempDBParams.Values['lc_ctype']) then
1034 begin
1035 TempDBParams.Values['lc_ctype'] := FDefaultCharSetName;
1036 FDBParamsChanged := True;
1037 FAttachment := nil;
1038 end
1039 end
1040 end;
1041
1042 until FAttachment <> nil;
1043
1044 FDefaultCharSetName := AnsiUpperCase(TempDBParams.Values['lc_ctype']);
1045 finally
1046 TempDBParams.Free;
1047 end;
1048 if FDefaultCharSetName <> '' then
1049 Attachment.CharSetName2CharSetID(FDefaultCharSetName,FDefaultCharSetID);
1050 Attachment.CharSetID2CodePage(FDefaultCharSetID,FDefaultCodePage);
1051
1052 if not (csDesigning in ComponentState) then
1053 FDBName := aDBName; {Synchronise at run time}
1054 FDBSQLDialect := GetDBSQLDialect;
1055 ValidateClientSQLDialect;
1056 for i := 0 to FSQLObjects.Count - 1 do
1057 begin
1058 if FSQLObjects[i] <> nil then
1059 SQLObjects[i].DoAfterDatabaseConnect;
1060 end;
1061 if not (csDesigning in ComponentState) then
1062 MonitorHook.DBConnect(Self);
1063 end;
1064
1065 procedure TIBDataBase.RemoveSQLObject(Idx: Integer);
1066 var
1067 ds: TIBBase;
1068 begin
1069 if (Idx >= 0) and (FSQLObjects[Idx] <> nil) then
1070 begin
1071 ds := SQLObjects[Idx];
1072 FSQLObjects[Idx] := nil;
1073 ds.Database := nil;
1074 if (ds.owner is TDataSet) then
1075 FDataSets.Remove(TDataSet(ds.Owner));
1076 end;
1077 end;
1078
1079 procedure TIBDataBase.RemoveSQLObjects;
1080 var
1081 i: Integer;
1082 begin
1083 for i := 0 to FSQLObjects.Count - 1 do if FSQLObjects[i] <> nil then
1084 begin
1085 RemoveSQLObject(i);
1086 if (TIBBase(FSQLObjects[i]).owner is TDataSet) then
1087 FDataSets.Remove(TDataSet(TIBBase(FSQLObjects[i]).owner));
1088 end;
1089 end;
1090
1091 procedure TIBDataBase.RemoveTransaction(Idx: Integer);
1092 var
1093 TR: TIBTransaction;
1094 begin
1095 if ((Idx >= 0) and (FTransactions[Idx] <> nil)) then
1096 begin
1097 TR := Transactions[Idx];
1098 FTransactions[Idx] := nil;
1099 TR.RemoveDatabase(TR.FindDatabase(Self));
1100 if TR = FDefaultTransaction then
1101 FDefaultTransaction := nil;
1102 end;
1103 end;
1104
1105 procedure TIBDataBase.RemoveTransactions;
1106 var
1107 i: Integer;
1108 begin
1109 for i := 0 to FTransactions.Count - 1 do if FTransactions[i] <> nil then
1110 RemoveTransaction(i);
1111 end;
1112
1113 procedure TIBDataBase.SetDatabaseName( const Value: TIBFileName);
1114 begin
1115 if FDBName <> Value then
1116 begin
1117 EnsureInactive;
1118 CheckInactive;
1119 FDBName := Value;
1120 end;
1121 end;
1122
1123 procedure TIBDataBase.SetDBParamByDPB( const Idx: Integer; Value: String);
1124 var
1125 ConstIdx: Integer;
1126 begin
1127 ConstIdx := IndexOfDBConst(DPBConstantNames[Idx]);
1128 if (Value = '') then
1129 begin
1130 if ConstIdx <> -1 then
1131 Params.Delete(ConstIdx);
1132 end
1133 else
1134 begin
1135 if (ConstIdx = -1) then
1136 Params.Add(DPBConstantNames[Idx] + '=' + Value)
1137 else
1138 Params[ConstIdx] := DPBConstantNames[Idx] + '=' + Value;
1139 end;
1140 end;
1141
1142 procedure TIBDataBase.SetDBParams(Value: TStrings);
1143 begin
1144 FDBParams.Assign(Value);
1145 end;
1146
1147 procedure TIBDataBase.SetDefaultTransaction(Value: TIBTransaction);
1148 var
1149 i: Integer;
1150 begin
1151 if (FDefaultTransaction <> nil) and (FDefaultTransaction <> Value) then
1152 begin
1153 i := FindTransaction(FDefaultTransaction);
1154 if (i <> -1) and (FDefaultTransaction.DefaultDatabase <> self) then
1155 RemoveTransaction(i);
1156 end;
1157 if (Value <> nil) and (FDefaultTransaction <> Value) then
1158 begin
1159 Value.AddDatabase(Self);
1160 AddTransaction(Value);
1161 end;
1162 FDefaultTransaction := Value;
1163 end;
1164
1165 procedure TIBDataBase.SetIdleTimer(Value: Integer);
1166 begin
1167 if Value < 0 then
1168 IBError(ibxeTimeoutNegative, [nil])
1169 else
1170 if (Value = 0) then
1171 begin
1172 FTimer.Enabled := False;
1173 FTimer.Interval := 0;
1174 end
1175 else
1176 if (Value > 0) then
1177 begin
1178 FTimer.Interval := Value;
1179 if not (csDesigning in ComponentState) then
1180 FTimer.Enabled := True;
1181 end;
1182 end;
1183
1184 function TIBDataBase.TestConnected: Boolean;
1185 var
1186 DatabaseInfo: TIBDatabaseInfo;
1187 begin
1188 result := Connected;
1189 if result then
1190 begin
1191 DatabaseInfo := TIBDatabaseInfo.Create(self);
1192 try
1193 DatabaseInfo.Database := self;
1194 { poke the server to see if connected }
1195 if DatabaseInfo.BaseLevel = 0 then ;
1196 DatabaseInfo.Free;
1197 except
1198 ForceClose;
1199 result := False;
1200 DatabaseInfo.Free;
1201 end;
1202 end;
1203 end;
1204
1205 procedure TIBDataBase.TimeoutConnection(Sender: TObject);
1206 begin
1207 if Connected then
1208 begin
1209 if not FAttachment.HasActivity then
1210 begin
1211 ForceClose;
1212 if Assigned(FOnIdleTimer) then
1213 FOnIdleTimer(Self);
1214 end
1215 end;
1216 end;
1217
1218 function TIBDataBase.GetIsReadOnly: Boolean;
1219 var
1220 DatabaseInfo: TIBDatabaseInfo;
1221 begin
1222 DatabaseInfo := TIBDatabaseInfo.Create(self);
1223 DatabaseInfo.Database := self;
1224 if (DatabaseInfo.ODSMajorVersion < 10) then
1225 result := false
1226 else
1227 begin
1228 if (DatabaseInfo.ReadOnly = 0) then
1229 result := false
1230 else
1231 result := true;
1232 end;
1233 DatabaseInfo.Free;
1234 end;
1235
1236 function TIBDataBase.GetSQLDialect: Integer;
1237 begin
1238 Result := FSQLDialect;
1239 end;
1240
1241
1242 procedure TIBDataBase.SetSQLDialect( const Value: Integer);
1243 begin
1244 if (Value < 1) then IBError(ibxeSQLDialectInvalid, [nil]);
1245 if ((FAttachment = nil) or (Value <= FDBSQLDialect)) then
1246 FSQLDialect := Value
1247 else
1248 IBError(ibxeSQLDialectInvalid, [nil]);
1249 end;
1250
1251 function TIBDataBase.GetDBSQLDialect: Integer;
1252 var
1253 DatabaseInfo: TIBDatabaseInfo;
1254 begin
1255 DatabaseInfo := TIBDatabaseInfo.Create(self);
1256 DatabaseInfo.Database := self;
1257 result := DatabaseInfo.DBSQLDialect;
1258 DatabaseInfo.Free;
1259 end;
1260
1261 procedure TIBDataBase.ValidateClientSQLDialect;
1262 begin
1263 if (FDBSQLDialect < FSQLDialect) then
1264 begin
1265 FSQLDialect := FDBSQLDialect;
1266 if Assigned (FOnDialectDowngradeWarning) then
1267 FOnDialectDowngradeWarning(self);
1268 end;
1269 end;
1270
1271 procedure TIBDataBase.ApplyUpdates( const DataSets: array of TDataSet);
1272 var
1273 I: Integer;
1274 DS: TIBCustomDataSet;
1275 TR: TIBTransaction;
1276 begin
1277 TR := nil;
1278 for I := 0 to High(DataSets) do
1279 begin
1280 DS := TIBCustomDataSet(DataSets[I]);
1281 if DS.Database <> Self then
1282 IBError(ibxeUpdateWrongDB, [nil]);
1283 if TR = nil then
1284 TR := DS.Transaction;
1285 if (DS.Transaction <> TR) or (TR = nil) then
1286 IBError(ibxeUpdateWrongTR, [nil]);
1287 end;
1288 TR.CheckInTransaction;
1289 for I := 0 to High(DataSets) do
1290 begin
1291 DS := TIBCustomDataSet(DataSets[I]);
1292 DS.ApplyUpdates;
1293 end;
1294 TR.CommitRetaining;
1295 end;
1296
1297 procedure TIBDataBase.CloseDataSets;
1298 var
1299 i: Integer;
1300 begin
1301 for i := 0 to DataSetCount - 1 do
1302 if (DataSets[i] <> nil) then
1303 DataSets[i].close;
1304 end;
1305
1306 function TIBDataBase.GetDataset(Index: longint): TDataset;
1307 begin
1308 if (Index >= 0) and (Index < FDataSets.Count) then
1309 Result := TDataSet(FDataSets[Index])
1310 else
1311 raise Exception.Create('Invalid Index to DataSets');
1312 end;
1313
1314 function TIBDataBase.GetDataSetCount: Longint;
1315 begin
1316 Result := FDataSets.Count;
1317 end;
1318
1319 procedure TIBDataBase.ReadState(Reader: TReader);
1320 begin
1321 FDBParams.Clear;
1322 inherited ReadState(Reader);
1323 end;
1324
1325 procedure TIBDataBase.SetConnected(Value: boolean);
1326 begin
1327 if StreamedConnected and not AllowStreamedConnected then
1328 begin
1329 StreamedConnected := false;
1330 Value := false
1331 end;
1332 inherited SetConnected(Value);
1333 end;
1334
1335 procedure TIBDataBase.GetFieldNames( const TableName: string; List: TStrings);
1336 var
1337 Query: TIBSQL;
1338 begin
1339 if TableName = '' then
1340 IBError(ibxeNoTableName, [nil]);
1341 if not Connected then
1342 Open;
1343 if not FInternalTransaction.Active then
1344 FInternalTransaction.StartTransaction;
1345 Query := TIBSQL.Create(self);
1346 try
1347 Query.GoToFirstRecordOnExecute := False;
1348 Query.Database := Self;
1349 Query.Transaction := FInternalTransaction;
1350 Query.SQL.Text := 'Select R.RDB$FIELD_NAME ' + {do not localize}
1351 'from RDB$RELATION_FIELDS R, RDB$FIELDS F ' + {do not localize}
1352 'where R.RDB$RELATION_NAME = ' + {do not localize}
1353 '''' +
1354 FormatIdentifierValue(SQLDialect, TableName) +
1355 ''' ' +
1356 'and R.RDB$FIELD_SOURCE = F.RDB$FIELD_NAME '; {do not localize}
1357 Query.Prepare;
1358 Query.ExecQuery;
1359 with List do
1360 begin
1361 BeginUpdate;
1362 try
1363 Clear;
1364 while (not Query.EOF) and Query.Next do
1365 List.Add(TrimRight(Query.FieldByName('RDB$FIELD_NAME').AsString)); {do not localize}
1366 finally
1367 EndUpdate;
1368 end;
1369 end;
1370 finally
1371 Query.free;
1372 FInternalTransaction.Commit;
1373 end;
1374 end;
1375
1376 procedure TIBDataBase.GetTableNames(List: TStrings; SystemTables: Boolean);
1377 var
1378 Query : TIBSQL;
1379 begin
1380 if not (csReading in ComponentState) then
1381 begin
1382 if not Connected then
1383 Open;
1384 if not FInternalTransaction.Active then
1385 FInternalTransaction.StartTransaction;
1386 Query := TIBSQL.Create(self);
1387 try
1388 Query.GoToFirstRecordOnExecute := False;
1389 Query.Database := Self;
1390 Query.Transaction := FInternalTransaction;
1391 if SystemTables then
1392 Query.SQL.Text := 'Select RDB$RELATION_NAME from RDB$RELATIONS' + {do not localize}
1393 ' where RDB$VIEW_BLR is NULL' {do not localize}
1394 else
1395 Query.SQL.Text := 'Select RDB$RELATION_NAME from RDB$RELATIONS' + {do not localize}
1396 ' where RDB$VIEW_BLR is NULL and RDB$SYSTEM_FLAG = 0'; {do not localize}
1397 Query.Prepare;
1398 Query.ExecQuery;
1399 with List do
1400 begin
1401 BeginUpdate;
1402 try
1403 Clear;
1404 while (not Query.EOF) and Query.Next do
1405 List.Add(TrimRight(Query.Fields[0].AsString));
1406 finally
1407 EndUpdate;
1408 end;
1409 end;
1410 finally
1411 Query.Free;
1412 FInternalTransaction.Commit;
1413 end;
1414 end;
1415 end;
1416
1417 { TIBTransaction }
1418
1419 constructor TIBTransaction.Create(AOwner: TComponent);
1420 begin
1421 inherited Create(AOwner);
1422 FDatabases := TList.Create;
1423 FSQLObjects := TList.Create;
1424 FTPB := nil;
1425 FTRParams := TStringList.Create;
1426 FTRParamsChanged := True;
1427 TStringList(FTRParams).OnChange := TRParamsChange;
1428 TStringList(FTRParams).OnChanging := TRParamsChanging;
1429 FTimer := TFPTimer.Create(Self);
1430 FTimer.Enabled := False;
1431 FTimer.Interval := 0;
1432 FTimer.OnTimer := TimeoutTransaction;
1433 FDefaultAction := taCommit;
1434 end;
1435
1436 destructor TIBTransaction.Destroy;
1437 var
1438 i: Integer;
1439 begin
1440 if InTransaction then
1441 EndTransaction(FDefaultAction, True);
1442 for i := 0 to FSQLObjects.Count - 1 do
1443 if FSQLObjects[i] <> nil then
1444 SQLObjects[i].DoTransactionFree;
1445 RemoveSQLObjects;
1446 RemoveDatabases;
1447 FTPB := nil;
1448 FTRParams.Free;
1449 FSQLObjects.Free;
1450 FDatabases.Free;
1451 inherited Destroy;
1452 end;
1453
1454 procedure TIBTransaction.CheckDatabasesInList;
1455 begin
1456 if GetDatabaseCount = 0 then
1457 IBError(ibxeNoDatabasesInTransaction, [nil]);
1458 end;
1459
1460 procedure TIBTransaction.CheckInTransaction;
1461 begin
1462 if FStreamedActive and (not InTransaction) then
1463 Loaded;
1464 if (TransactionIntf = nil) then
1465 IBError(ibxeNotInTransaction, [nil]);
1466 end;
1467
1468 procedure TIBTransaction.DoBeforeTransactionEnd;
1469 begin
1470 if Assigned(FBeforeTransactionEnd) then
1471 FBeforeTransactionEnd(self);
1472 end;
1473
1474 procedure TIBTransaction.DoAfterTransactionEnd;
1475 begin
1476 if Assigned(FAfterTransactionEnd) then
1477 FAfterTransactionEnd(self);
1478 end;
1479
1480 procedure TIBTransaction.DoOnStartTransaction;
1481 begin
1482 if assigned(FOnStartTransaction) then
1483 OnStartTransaction(self);
1484 end;
1485
1486 procedure TIBTransaction.DoAfterExecQuery(Sender: TObject);
1487 begin
1488 if assigned(FAfterExecQuery) then
1489 AfterExecQuery(Sender);
1490 end;
1491
1492 procedure TIBTransaction.DoAfterEdit(Sender: TObject);
1493 begin
1494 if assigned(FAfterEdit) then
1495 AfterEdit(Sender);
1496 end;
1497
1498 procedure TIBTransaction.DoAfterDelete(Sender: TObject);
1499 begin
1500 if assigned(FAfterDelete) then
1501 AfterDelete(Sender);
1502 end;
1503
1504 procedure TIBTransaction.DoAfterInsert(Sender: TObject);
1505 begin
1506 if assigned(FAfterInsert) then
1507 AfterInsert(Sender);
1508 end;
1509
1510 procedure TIBTransaction.DoAfterPost(Sender: TObject);
1511 begin
1512 if assigned(FAfterPost) then
1513 AfterPost(Sender);
1514 end;
1515
1516 procedure TIBTransaction.EnsureNotInTransaction;
1517 begin
1518 if csDesigning in ComponentState then
1519 begin
1520 if TransactionIntf <> nil then
1521 Rollback;
1522 end;
1523 end;
1524
1525 procedure TIBTransaction.CheckNotInTransaction;
1526 begin
1527 if (TransactionIntf <> nil) and TransactionIntf.InTransaction then
1528 IBError(ibxeInTransaction, [nil]);
1529 end;
1530
1531 function TIBTransaction.AddDatabase(db: TIBDatabase): Integer;
1532 var
1533 i: Integer;
1534 NilFound: Boolean;
1535 begin
1536 EnsureNotInTransaction;
1537 CheckNotInTransaction;
1538 FTransactionIntf := nil;
1539
1540 i := FindDatabase(db);
1541 if i <> -1 then
1542 begin
1543 result := i;
1544 exit;
1545 end;
1546 NilFound := False;
1547 i := 0;
1548 while (not NilFound) and (i < FDatabases.Count) do
1549 begin
1550 NilFound := (FDatabases[i] = nil);
1551 if (not NilFound) then
1552 Inc(i);
1553 end;
1554 if (NilFound) then
1555 begin
1556 FDatabases[i] := db;
1557 result := i;
1558 end
1559 else
1560 begin
1561 result := FDatabases.Count;
1562 FDatabases.Add(db);
1563 end;
1564 end;
1565
1566 function TIBTransaction.AddSQLObject(ds: TIBBase): Integer;
1567 begin
1568 result := 0;
1569 while (result < FSQLObjects.Count) and (FSQLObjects[result] <> nil) do
1570 Inc(result);
1571 if (result = FSQLObjects.Count) then
1572 FSQLObjects.Add(ds)
1573 else
1574 FSQLObjects[result] := ds;
1575 end;
1576
1577 procedure TIBTransaction.Commit;
1578 begin
1579 EndTransaction(TACommit, False);
1580 end;
1581
1582 procedure TIBTransaction.CommitRetaining;
1583 begin
1584 EndTransaction(TACommitRetaining, False);
1585 end;
1586
1587 procedure TIBTransaction.EndTransaction(Action: TTransactionAction;
1588 Force: Boolean);
1589 var
1590 i: Integer;
1591 begin
1592 CheckInTransaction;
1593 if FInEndTransaction then Exit;
1594 FInEndTransaction := true;
1595 FEndAction := Action;
1596 try
1597 case Action of
1598 TARollback, TACommit:
1599 begin
1600 try
1601 DoBeforeTransactionEnd;
1602 except on E: EIBInterBaseError do
1603 begin
1604 if not Force then
1605 raise;
1606 end;
1607 end;
1608
1609 for i := 0 to FSQLObjects.Count - 1 do if FSQLObjects[i] <> nil then
1610 try
1611 SQLObjects[i].DoBeforeTransactionEnd(Action);
1612 except on E: EIBInterBaseError do
1613 begin
1614 if not Force then
1615 raise;
1616 end;
1617 end;
1618
1619 if InTransaction then
1620 begin
1621 if (Action = TARollback) then
1622 FTransactionIntf.Rollback(Force)
1623 else
1624 try
1625 FTransactionIntf.Commit;
1626 except on E: EIBInterBaseError do
1627 begin
1628 if Force then
1629 FTransactionIntf.Rollback(Force)
1630 else
1631 raise;
1632 end;
1633 end;
1634
1635 for i := 0 to FSQLObjects.Count - 1 do if FSQLObjects[i] <> nil then
1636 try
1637 SQLObjects[i].DoAfterTransactionEnd;
1638 except on E: EIBInterBaseError do
1639 begin
1640 if not Force then
1641 raise;
1642 end;
1643 end;
1644 try
1645 DoAfterTransactionEnd;
1646 except on E: EIBInterBaseError do
1647 begin
1648 if not Force then
1649 raise;
1650 end;
1651 end;
1652 end;
1653 end;
1654 TACommitRetaining:
1655 FTransactionIntf.CommitRetaining;
1656
1657 TARollbackRetaining:
1658 FTransactionIntf.RollbackRetaining;
1659 end;
1660 if not (csDesigning in ComponentState) then
1661 begin
1662 case Action of
1663 TACommit:
1664 MonitorHook.TRCommit(Self);
1665 TARollback:
1666 MonitorHook.TRRollback(Self);
1667 TACommitRetaining:
1668 MonitorHook.TRCommitRetaining(Self);
1669 TARollbackRetaining:
1670 MonitorHook.TRRollbackRetaining(Self);
1671 end;
1672 end;
1673 finally
1674 FInEndTransaction := false
1675 end;
1676 end;
1677
1678 function TIBTransaction.GetDatabase(Index: Integer): TIBDatabase;
1679 begin
1680 result := FDatabases[Index];
1681 end;
1682
1683 function TIBTransaction.GetDatabaseCount: Integer;
1684 var
1685 i, Cnt: Integer;
1686 begin
1687 result := 0;
1688 Cnt := FDatabases.Count - 1;
1689 for i := 0 to Cnt do if FDatabases[i] <> nil then
1690 Inc(result);
1691 end;
1692
1693 function TIBTransaction.GetSQLObject(Index: Integer): TIBBase;
1694 begin
1695 result := FSQLObjects[Index];
1696 end;
1697
1698 function TIBTransaction.GetSQLObjectCount: Integer;
1699 var
1700 i, Cnt: Integer;
1701 begin
1702 result := 0;
1703 Cnt := FSQLObjects.Count - 1;
1704 for i := 0 to Cnt do if FSQLObjects[i] <> nil then
1705 Inc(result);
1706 end;
1707
1708 function TIBTransaction.GetInTransaction: Boolean;
1709 begin
1710 result := (TransactionIntf <> nil) and TransactionIntf.InTransaction;
1711 end;
1712
1713 function TIBTransaction.FindDatabase(db: TIBDatabase): Integer;
1714 var
1715 i: Integer;
1716 begin
1717 result := -1;
1718 for i := 0 to FDatabases.Count - 1 do
1719 if db = TIBDatabase(FDatabases[i]) then
1720 begin
1721 result := i;
1722 break;
1723 end;
1724 end;
1725
1726 function TIBTransaction.FindDefaultDatabase: TIBDatabase;
1727 var
1728 i: Integer;
1729 begin
1730 result := FDefaultDatabase;
1731 if result = nil then
1732 begin
1733 for i := 0 to FDatabases.Count - 1 do
1734 if (TIBDatabase(FDatabases[i]) <> nil) and
1735 (TIBDatabase(FDatabases[i]).DefaultTransaction = self) then
1736 begin
1737 result := TIBDatabase(FDatabases[i]);
1738 break;
1739 end;
1740 end;
1741 end;
1742
1743 function TIBTransaction.GetEndAction: TTransactionAction;
1744 begin
1745 if FInEndTransaction then
1746 Result := FEndAction
1747 else
1748 IBError(ibxeIB60feature, [nil])
1749 end;
1750
1751
1752 function TIBTransaction.GetIdleTimer: Integer;
1753 begin
1754 result := FTimer.Interval;
1755 end;
1756
1757 procedure TIBTransaction.Loaded;
1758 begin
1759 inherited Loaded;
1760 end;
1761
1762 procedure TIBTransaction.BeforeDatabaseDisconnect(DB: TIBDatabase);
1763 begin
1764 if InTransaction then
1765 EndTransaction(FDefaultAction, True);
1766 FTransactionIntf := nil;
1767 end;
1768
1769 procedure TIBTransaction.RemoveDatabase(Idx: Integer);
1770 var
1771 DB: TIBDatabase;
1772 begin
1773 if ((Idx >= 0) and (FDatabases[Idx] <> nil)) then
1774 begin
1775 EnsureNotInTransaction;
1776 CheckNotInTransaction;
1777 FTransactionIntf := nil;
1778
1779 DB := Databases[Idx];
1780 FDatabases[Idx] := nil;
1781 DB.RemoveTransaction(DB.FindTransaction(Self));
1782 if DB = FDefaultDatabase then
1783 FDefaultDatabase := nil;
1784 end;
1785 end;
1786
1787 procedure TIBTransaction.RemoveDatabases;
1788 var
1789 i: Integer;
1790 begin
1791 EnsureNotInTransaction;
1792 CheckNotInTransaction;
1793 FTransactionIntf := nil;
1794
1795 for i := 0 to FDatabases.Count - 1 do if FDatabases[i] <> nil then
1796 RemoveDatabase(i);
1797 end;
1798
1799 procedure TIBTransaction.RemoveSQLObject(Idx: Integer);
1800 var
1801 ds: TIBBase;
1802 begin
1803 if ((Idx >= 0) and (FSQLObjects[Idx] <> nil)) then
1804 begin
1805 ds := SQLObjects[Idx];
1806 FSQLObjects[Idx] := nil;
1807 ds.Transaction := nil;
1808 end;
1809 end;
1810
1811 procedure TIBTransaction.RemoveSQLObjects;
1812 var
1813 i: Integer;
1814 begin
1815 for i := 0 to FSQLObjects.Count - 1 do if FSQLObjects[i] <> nil then
1816 RemoveSQLObject(i);
1817 end;
1818
1819 procedure TIBTransaction.Rollback;
1820 begin
1821 EndTransaction(TARollback, False);
1822 end;
1823
1824 procedure TIBTransaction.RollbackRetaining;
1825 begin
1826 EndTransaction(TARollbackRetaining, False);
1827 end;
1828
1829 procedure TIBTransaction.SetActive(Value: Boolean);
1830 begin
1831 if csReading in ComponentState then
1832 FStreamedActive := Value
1833 else
1834 if Value and not InTransaction then
1835 StartTransaction
1836 else
1837 if not Value and InTransaction then
1838 Rollback;
1839 end;
1840
1841 procedure TIBTransaction.SetDefaultDatabase(Value: TIBDatabase);
1842 var
1843 i: integer;
1844 begin
1845 if (FDefaultDatabase <> nil) and (FDefaultDatabase <> Value) then
1846 begin
1847 i := FDefaultDatabase.FindTransaction(self);
1848 if (i <> -1) then
1849 FDefaultDatabase.RemoveTransaction(i);
1850 end;
1851 if (Value <> nil) and (FDefaultDatabase <> Value) then
1852 begin
1853 Value.AddTransaction(Self);
1854 AddDatabase(Value);
1855 for i := 0 to FSQLObjects.Count - 1 do
1856 if (FSQLObjects[i] <> nil) and
1857 (TIBBase(FSQLObjects[i]).Database = nil) then
1858 SetObjectProp(TIBBase(FSQLObjects[i]).Owner, 'Database', Value);
1859 end;
1860 FDefaultDatabase := Value;
1861 end;
1862
1863 procedure TIBTransaction.Notification( AComponent: TComponent;
1864 Operation: TOperation);
1865 var
1866 i: Integer;
1867 begin
1868 inherited Notification( AComponent, Operation);
1869 if (Operation = opRemove) and (AComponent = FDefaultDatabase) then
1870 begin
1871 i := FindDatabase(FDefaultDatabase);
1872 if (i <> -1) then
1873 RemoveDatabase(i);
1874 FDefaultDatabase := nil;
1875 end;
1876 end;
1877
1878 procedure TIBTransaction.SetIdleTimer(Value: Integer);
1879 begin
1880 if Value < 0 then
1881 IBError(ibxeTimeoutNegative, [nil])
1882 else
1883 if (Value = 0) then
1884 begin
1885 FTimer.Enabled := False;
1886 FTimer.Interval := 0;
1887 end
1888 else
1889 if (Value > 0) then
1890 begin
1891 FTimer.Interval := Value;
1892 if not (csDesigning in ComponentState) then
1893 FTimer.Enabled := True;
1894 end;
1895 end;
1896
1897 procedure TIBTransaction.SetTRParams(Value: TStrings);
1898 begin
1899 FTRParams.Assign(Value);
1900 end;
1901
1902 procedure TIBTransaction.StartTransaction;
1903 var
1904 i: Integer;
1905 Attachments: array of IAttachment;
1906 ValidDatabaseCount: integer;
1907 begin
1908 CheckNotInTransaction;
1909 CheckDatabasesInList;
1910 if TransactionIntf <> nil then
1911 begin
1912 TransactionIntf.Start(DefaultAction);
1913 Exit;
1914 end;
1915
1916 for i := 0 to FDatabases.Count - 1 do
1917 if FDatabases[i] <> nil then
1918 begin
1919 with TIBDatabase(FDatabases[i]) do
1920 if not Connected then
1921 if StreamedConnected then
1922 begin
1923 Open;
1924 StreamedConnected := False;
1925 end
1926 else
1927 IBError(ibxeDatabaseClosed, [nil]);
1928 end;
1929 if FTRParamsChanged then
1930 begin
1931 FTRParamsChanged := False;
1932 FTPB := GenerateTPB(FTRParams);
1933 end;
1934
1935 ValidDatabaseCount := 0;
1936 for i := 0 to DatabaseCount - 1 do
1937 if Databases[i] <> nil then Inc(ValidDatabaseCount);
1938
1939 if ValidDatabaseCount = 1 then
1940 FTransactionIntf := Databases[0].Attachment.StartTransaction(FTPB,DefaultAction)
1941 else
1942 begin
1943 SetLength(Attachments,ValidDatabaseCount);
1944 for i := 0 to DatabaseCount - 1 do
1945 if Databases[i] <> nil then
1946 Attachments[i] := Databases[i].Attachment;
1947
1948 FTransactionIntf := FirebirdAPI.StartTransaction(Attachments,FTPB,DefaultAction);
1949 end;
1950
1951 if not (csDesigning in ComponentState) then
1952 MonitorHook.TRStart(Self);
1953 DoOnStartTransaction;
1954 end;
1955
1956 procedure TIBTransaction.TimeoutTransaction(Sender: TObject);
1957 begin
1958 if InTransaction then
1959 begin
1960 if not TransactionIntf.HasActivity then
1961 begin
1962 EndTransaction(FDefaultAction, True);
1963 if Assigned(FOnIdleTimer) then
1964 FOnIdleTimer(Self);
1965 end
1966 end;
1967 end;
1968
1969 procedure TIBTransaction.TRParamsChange(Sender: TObject);
1970 begin
1971 FTRParamsChanged := True;
1972 end;
1973
1974 procedure TIBTransaction.TRParamsChanging(Sender: TObject);
1975 begin
1976 EnsureNotInTransaction;
1977 CheckNotInTransaction;
1978 FTransactionIntf := nil;
1979 end;
1980
1981 { TIBBase }
1982 constructor TIBBase.Create(AOwner: TObject);
1983 begin
1984 FOwner := AOwner;
1985 end;
1986
1987 destructor TIBBase.Destroy;
1988 begin
1989 SetDatabase(nil);
1990 SetTransaction(nil);
1991 inherited Destroy;
1992 end;
1993
1994 procedure TIBBase.HandleException(Sender: TObject);
1995 begin
1996 if assigned(Database) then
1997 Database.HandleException(Sender)
1998 else
1999 SysUtils.ShowException(ExceptObject,ExceptAddr);
2000 end;
2001
2002 procedure TIBBase.SetCursor;
2003 begin
2004 if Assigned(Database) and not Database.SQLHourGlass then
2005 Exit;
2006 if assigned(IBGUIInterface) then
2007 IBGUIInterface.SetCursor;
2008 end;
2009
2010 procedure TIBBase.RestoreCursor;
2011 begin
2012 if Assigned(Database) and not Database.SQLHourGlass then
2013 Exit;
2014 if assigned(IBGUIInterface) then
2015 IBGUIInterface.RestoreCursor;
2016 end;
2017
2018 procedure TIBBase.CheckDatabase;
2019 begin
2020 if (FDatabase = nil) then
2021 IBError(ibxeDatabaseNotAssigned, [nil]);
2022 FDatabase.CheckActive;
2023 end;
2024
2025 procedure TIBBase.CheckTransaction;
2026 begin
2027 if FTransaction = nil then
2028 IBError(ibxeTransactionNotAssigned, [nil]);
2029 FTransaction.CheckInTransaction;
2030 end;
2031
2032 procedure TIBBase.DoBeforeDatabaseConnect(DBParams: TStrings; var DBName: string
2033 );
2034 begin
2035 if assigned(FBeforeDatabaseConnect) then
2036 BeforeDatabaseConnect(self,DBParams,DBName);
2037 end;
2038
2039 procedure TIBBase.DoAfterDatabaseConnect;
2040 begin
2041 if assigned(FAfterDatabaseConnect) then
2042 AfterDatabaseConnect(self);
2043 end;
2044
2045 procedure TIBBase.DoBeforeDatabaseDisconnect;
2046 begin
2047 if Assigned(BeforeDatabaseDisconnect) then
2048 BeforeDatabaseDisconnect(Self);
2049 end;
2050
2051 procedure TIBBase.DoAfterDatabaseDisconnect;
2052 begin
2053 if Assigned(AfterDatabaseDisconnect) then
2054 AfterDatabaseDisconnect(Self);
2055 end;
2056
2057 procedure TIBBase.DoDatabaseFree;
2058 begin
2059 if Assigned(OnDatabaseFree) then
2060 OnDatabaseFree(Self);
2061 SetDatabase(nil);
2062 SetTransaction(nil);
2063 end;
2064
2065 procedure TIBBase.DoBeforeTransactionEnd(Action: TTransactionAction);
2066 begin
2067 if Assigned(BeforeTransactionEnd) then
2068 BeforeTransactionEnd(Self,Action);
2069 end;
2070
2071 procedure TIBBase.DoAfterTransactionEnd;
2072 begin
2073 if Assigned(AfterTransactionEnd) then
2074 AfterTransactionEnd(Self);
2075 end;
2076
2077 procedure TIBBase.DoTransactionFree;
2078 begin
2079 if Assigned(OnTransactionFree) then
2080 OnTransactionFree(Self);
2081 FTransaction := nil;
2082 end;
2083
2084 procedure TIBBase.DoAfterExecQuery(Sender: TObject);
2085 begin
2086 if FTransaction <> nil then
2087 FTransaction.DoAfterExecQuery(Sender);
2088 end;
2089
2090 procedure TIBBase.DoAfterEdit(Sender: TObject);
2091 begin
2092 if FTransaction <> nil then
2093 FTransaction.DoAfterEdit(Sender);
2094 end;
2095
2096 procedure TIBBase.DoAfterDelete(Sender: TObject);
2097 begin
2098 if FTransaction <> nil then
2099 FTransaction.DoAfterDelete(Sender);
2100 end;
2101
2102 procedure TIBBase.DoAfterInsert(Sender: TObject);
2103 begin
2104 if FTransaction <> nil then
2105 FTransaction.DoAfterInsert(Sender);
2106 end;
2107
2108 procedure TIBBase.DoAfterPost(Sender: TObject);
2109 begin
2110 if FTransaction <> nil then
2111 FTransaction.DoAfterPost(Sender);
2112 end;
2113
2114 procedure TIBBase.SetDatabase(Value: TIBDatabase);
2115 begin
2116 if (FDatabase <> nil) then
2117 FDatabase.RemoveSQLObject(FIndexInDatabase);
2118 FDatabase := Value;
2119 if (FDatabase <> nil) then
2120 begin
2121 FIndexInDatabase := FDatabase.AddSQLObject(Self);
2122 if (FTransaction = nil) then
2123 Transaction := FDatabase.FindDefaultTransaction;
2124 end;
2125 end;
2126
2127 procedure TIBBase.SetTransaction(Value: TIBTransaction);
2128 begin
2129 if (FTransaction <> nil) then
2130 FTransaction.RemoveSQLObject(FIndexInTransaction);
2131 FTransaction := Value;
2132 if (FTransaction <> nil) then
2133 begin
2134 FIndexInTransaction := FTransaction.AddSQLObject(Self);
2135 if (FDatabase = nil) then
2136 Database := FTransaction.FindDefaultDatabase;
2137 end;
2138 end;
2139
2140 { GenerateDPB -
2141 Given a string containing a textual representation
2142 of the database parameters, generate a database
2143 parameter buffer, and return it and its length
2144 in DPB and DPBLength, respectively. }
2145
2146 function GenerateDPB(sl: TStrings): IDPB;
2147 var
2148 i, j: Integer;
2149 DPBVal: UShort;
2150 ParamName, ParamValue: string;
2151 begin
2152 Result := FirebirdAPI.AllocateDPB;
2153
2154 {Iterate through the textual database parameters, constructing
2155 a DPB on-the-fly }
2156 for i := 0 to sl.Count - 1 do
2157 begin
2158 { Get the parameter's name and value from the list,
2159 and make sure that the name is all lowercase with
2160 no leading 'isc_dpb_' prefix
2161 }
2162 if (Trim(sl.Names[i]) = '') then
2163 continue;
2164 ParamName := LowerCase(sl.Names[i]); {mbcs ok}
2165 ParamValue := Copy(sl[i], Pos('=', sl[i]) + 1, Length(sl[i])); {mbcs ok}
2166 if (Pos(DPBPrefix, ParamName) = 1) then {mbcs ok}
2167 Delete(ParamName, 1, Length(DPBPrefix));
2168 { We want to translate the parameter name to some Integer
2169 value. We do this by scanning through a list of known
2170 database parameter names (DPBConstantNames, defined above) }
2171 DPBVal := 0;
2172 { Find the parameter }
2173 for j := 1 to isc_dpb_last_dpb_constant do
2174 if (ParamName = DPBConstantNames[j]) then
2175 begin
2176 DPBVal := j;
2177 break;
2178 end;
2179 { A database parameter either contains a string value (case 1)
2180 or an Integer value (case 2)
2181 or no value at all (case 3)
2182 or an error needs to be generated (case else) }
2183 case DPBVal of
2184 isc_dpb_user_name, isc_dpb_password, isc_dpb_password_enc,
2185 isc_dpb_sys_user_name, isc_dpb_license, isc_dpb_encrypt_key,
2186 isc_dpb_lc_messages, isc_dpb_lc_ctype,
2187 isc_dpb_sql_role_name, isc_dpb_sql_dialect:
2188 begin
2189 if DPBVal = isc_dpb_sql_dialect then
2190 ParamValue[1] := Char(Ord(ParamValue[1]) - 48);
2191 Result.Add(DPBVal).SetAsString(ParamValue);
2192 end;
2193
2194 isc_dpb_num_buffers, isc_dpb_dbkey_scope, isc_dpb_force_write,
2195 isc_dpb_no_reserve, isc_dpb_damaged, isc_dpb_verify:
2196 Result.Add(DPBVal).SetAsByte(byte(ParamValue[1]));
2197
2198 isc_dpb_sweep:
2199 Result.Add(DPBVal).SetAsByte(isc_dpb_records);
2200
2201 isc_dpb_sweep_interval:
2202 Result.Add(DPBVal).SetAsInteger(StrToInt(ParamValue));
2203
2204 isc_dpb_activate_shadow, isc_dpb_delete_shadow, isc_dpb_begin_log,
2205 isc_dpb_quit_log:
2206 Result.Add(DPBVal).SetAsByte(0);
2207 else
2208 begin
2209 if (DPBVal > 0) and
2210 (DPBVal <= isc_dpb_last_dpb_constant) then
2211 IBError(ibxeDPBConstantNotSupported, [DPBConstantNames[DPBVal]])
2212 else
2213 IBError(ibxeDPBConstantUnknownEx, [sl.Names[i]]);
2214 end;
2215 end;
2216 end;
2217 end;
2218
2219 { GenerateTPB -
2220 Given a string containing a textual representation
2221 of the transaction parameters, generate a transaction
2222 parameter buffer, and return it and its length in
2223 TPB and TPBLength, respectively. }
2224 function GenerateTPB(sl: TStrings): ITPB;
2225 var
2226 i, j, TPBVal: Integer;
2227 ParamName, ParamValue: string;
2228 begin
2229 Result := FirebirdAPI.AllocateTPB;
2230 for i := 0 to sl.Count - 1 do
2231 begin
2232 if (Trim(sl[i]) = '') then
2233 Continue;
2234
2235 if (Pos('=', sl[i]) = 0) then {mbcs ok}
2236 ParamName := LowerCase(sl[i]) {mbcs ok}
2237 else
2238 begin
2239 ParamName := LowerCase(sl.Names[i]); {mbcs ok}
2240 ParamValue := Copy(sl[i], Pos('=', sl[i]) + 1, Length(sl[i])); {mbcs ok}
2241 end;
2242 if (Pos(TPBPrefix, ParamName) = 1) then {mbcs ok}
2243 Delete(ParamName, 1, Length(TPBPrefix));
2244 TPBVal := 0;
2245 { Find the parameter }
2246 for j := 1 to isc_tpb_last_tpb_constant do
2247 if (ParamName = TPBConstantNames[j]) then
2248 begin
2249 TPBVal := j;
2250 break;
2251 end;
2252 { Now act on it }
2253 case TPBVal of
2254 isc_tpb_consistency, isc_tpb_exclusive, isc_tpb_protected,
2255 isc_tpb_concurrency, isc_tpb_shared, isc_tpb_wait, isc_tpb_nowait,
2256 isc_tpb_read, isc_tpb_write, isc_tpb_ignore_limbo,
2257 isc_tpb_read_committed, isc_tpb_rec_version, isc_tpb_no_rec_version:
2258 Result.Add(TPBVal);
2259
2260 isc_tpb_lock_read, isc_tpb_lock_write:
2261 Result.Add(TPBVal).SetAsString(ParamValue);
2262
2263 else
2264 begin
2265 if (TPBVal > 0) and
2266 (TPBVal <= isc_tpb_last_tpb_constant) then
2267 IBError(ibxeTPBConstantNotSupported, [TPBConstantNames[TPBVal]])
2268 else
2269 IBError(ibxeTPBConstantUnknownEx, [sl.Names[i]]);
2270 end;
2271 end;
2272 end;
2273 end;
2274
2275 end.
2276
2277
2278
2279
2280