ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBDatabase.pas
Revision: 60
Committed: Mon Mar 27 15:21:02 2017 UTC (7 years ago) by tony
Content type: text/x-pascal
File size: 62480 byte(s)
Log Message:

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 if UseDefaultSystemCodePage then
960 begin
961 {$ifdef WINDOWS}
962 if Attachment.CodePage2CharSetID(GetACP,CharSetID) then
963 TempDBParams.Values['lc_ctype'] := Attachment.GetCharsetName(CharSetID)
964 {$else}
965 if Attachment.CodePage2CharSetID(DefaultSystemCodePage,CharSetID) then
966 TempDBParams.Values['lc_ctype'] := Attachment.GetCharsetName(CharSetID)
967 {$endif}
968 else
969 TempDBParams.Values['lc_ctype'] :='UTF8';
970 end;
971 {Opportunity to override defaults}
972 for i := 0 to FSQLObjects.Count - 1 do
973 begin
974 if FSQLObjects[i] <> nil then
975 SQLObjects[i].DoBeforeDatabaseConnect(TempDBParams,aDBName);
976 end;
977
978 FDefaultCharSetName := AnsiUpperCase(TempDBParams.Values['lc_ctype']);
979 { Generate a new DPB if necessary }
980 if (FDBParamsChanged or (TempDBParams.Text <> FDBParams.Text)) then
981 begin
982 FDBParamsChanged := False;
983 if (not LoginPrompt and not (csDesigning in ComponentState)) or (FHiddenPassword = '') then
984 FDPB := GenerateDPB(TempDBParams)
985 else
986 begin
987 TempDBParams.Add('password=' + FHiddenPassword);
988 FDPB := GenerateDPB(TempDBParams);
989 end;
990 end;
991 finally
992 TempDBParams.Free;
993 end;
994
995 repeat
996 if FCreateDatabase then
997 begin
998 FCreateDatabase := false;
999 FAttachment := FirebirdAPI.CreateDatabase(aDBName,FDPB, false);
1000 if assigned(FOnCreateDatabase) and (FAttachment <> nil) then
1001 OnCreateDatabase(self);
1002 end
1003 else
1004 FAttachment := FirebirdAPI.OpenDatabase(aDBName,FDPB,false);
1005 if FAttachment = nil then
1006 begin
1007 Status := FirebirdAPI.GetStatus;
1008 {$IFDEF UNIX}
1009 if Pos(':',aDBName) = 0 then
1010 begin
1011 if ((Status.GetSQLCode = -901) and (Status.GetIBErrorCode = isc_random)) {Access permissions on firebird temp}
1012 or
1013 ((Status.GetSQLCode = -902) and (Status.GetIBErrorCode = isc_sys_request)) {Security DB Problem}
1014 or
1015 ((Status.GetSQLCode = -902) and (Status.GetIBErrorCode = isc_psw_attach)) {Security DB Problem}
1016 or
1017 ((Status.GetSQLCode = -904) and (Status.GetIBErrorCode = isc_lock_dir_access)) {Lock File Problem}
1018 then
1019 begin
1020 aDBName := 'localhost:' + aDBName;
1021 Continue;
1022 end
1023 end;
1024 {$ENDIF}
1025 if ((Status.GetSQLCode = -902) and (Status.GetIBErrorCode = isc_io_error)) {Database not found}
1026 and CreateIfNotExists and not (csDesigning in ComponentState) then
1027 FCreateDatabase := true
1028 else
1029 raise EIBInterBaseError.Create(Status);
1030 end;
1031 until FAttachment <> nil;
1032
1033 if FDefaultCharSetName <> '' then
1034 Attachment.CharSetName2CharSetID(FDefaultCharSetName,FDefaultCharSetID);
1035 Attachment.CharSetID2CodePage(FDefaultCharSetID,FDefaultCodePage);
1036
1037 if not (csDesigning in ComponentState) then
1038 FDBName := aDBName; {Synchronise at run time}
1039 FDBSQLDialect := GetDBSQLDialect;
1040 ValidateClientSQLDialect;
1041 for i := 0 to FSQLObjects.Count - 1 do
1042 begin
1043 if FSQLObjects[i] <> nil then
1044 SQLObjects[i].DoAfterDatabaseConnect;
1045 end;
1046 if not (csDesigning in ComponentState) then
1047 MonitorHook.DBConnect(Self);
1048 end;
1049
1050 procedure TIBDataBase.RemoveSQLObject(Idx: Integer);
1051 var
1052 ds: TIBBase;
1053 begin
1054 if (Idx >= 0) and (FSQLObjects[Idx] <> nil) then
1055 begin
1056 ds := SQLObjects[Idx];
1057 FSQLObjects[Idx] := nil;
1058 ds.Database := nil;
1059 if (ds.owner is TDataSet) then
1060 FDataSets.Remove(TDataSet(ds.Owner));
1061 end;
1062 end;
1063
1064 procedure TIBDataBase.RemoveSQLObjects;
1065 var
1066 i: Integer;
1067 begin
1068 for i := 0 to FSQLObjects.Count - 1 do if FSQLObjects[i] <> nil then
1069 begin
1070 RemoveSQLObject(i);
1071 if (TIBBase(FSQLObjects[i]).owner is TDataSet) then
1072 FDataSets.Remove(TDataSet(TIBBase(FSQLObjects[i]).owner));
1073 end;
1074 end;
1075
1076 procedure TIBDataBase.RemoveTransaction(Idx: Integer);
1077 var
1078 TR: TIBTransaction;
1079 begin
1080 if ((Idx >= 0) and (FTransactions[Idx] <> nil)) then
1081 begin
1082 TR := Transactions[Idx];
1083 FTransactions[Idx] := nil;
1084 TR.RemoveDatabase(TR.FindDatabase(Self));
1085 if TR = FDefaultTransaction then
1086 FDefaultTransaction := nil;
1087 end;
1088 end;
1089
1090 procedure TIBDataBase.RemoveTransactions;
1091 var
1092 i: Integer;
1093 begin
1094 for i := 0 to FTransactions.Count - 1 do if FTransactions[i] <> nil then
1095 RemoveTransaction(i);
1096 end;
1097
1098 procedure TIBDataBase.SetDatabaseName( const Value: TIBFileName);
1099 begin
1100 if FDBName <> Value then
1101 begin
1102 EnsureInactive;
1103 CheckInactive;
1104 FDBName := Value;
1105 end;
1106 end;
1107
1108 procedure TIBDataBase.SetDBParamByDPB( const Idx: Integer; Value: String);
1109 var
1110 ConstIdx: Integer;
1111 begin
1112 ConstIdx := IndexOfDBConst(DPBConstantNames[Idx]);
1113 if (Value = '') then
1114 begin
1115 if ConstIdx <> -1 then
1116 Params.Delete(ConstIdx);
1117 end
1118 else
1119 begin
1120 if (ConstIdx = -1) then
1121 Params.Add(DPBConstantNames[Idx] + '=' + Value)
1122 else
1123 Params[ConstIdx] := DPBConstantNames[Idx] + '=' + Value;
1124 end;
1125 end;
1126
1127 procedure TIBDataBase.SetDBParams(Value: TStrings);
1128 begin
1129 FDBParams.Assign(Value);
1130 end;
1131
1132 procedure TIBDataBase.SetDefaultTransaction(Value: TIBTransaction);
1133 var
1134 i: Integer;
1135 begin
1136 if (FDefaultTransaction <> nil) and (FDefaultTransaction <> Value) then
1137 begin
1138 i := FindTransaction(FDefaultTransaction);
1139 if (i <> -1) and (FDefaultTransaction.DefaultDatabase <> self) then
1140 RemoveTransaction(i);
1141 end;
1142 if (Value <> nil) and (FDefaultTransaction <> Value) then
1143 begin
1144 Value.AddDatabase(Self);
1145 AddTransaction(Value);
1146 end;
1147 FDefaultTransaction := Value;
1148 end;
1149
1150 procedure TIBDataBase.SetIdleTimer(Value: Integer);
1151 begin
1152 if Value < 0 then
1153 IBError(ibxeTimeoutNegative, [nil])
1154 else
1155 if (Value = 0) then
1156 begin
1157 FTimer.Enabled := False;
1158 FTimer.Interval := 0;
1159 end
1160 else
1161 if (Value > 0) then
1162 begin
1163 FTimer.Interval := Value;
1164 if not (csDesigning in ComponentState) then
1165 FTimer.Enabled := True;
1166 end;
1167 end;
1168
1169 function TIBDataBase.TestConnected: Boolean;
1170 var
1171 DatabaseInfo: TIBDatabaseInfo;
1172 begin
1173 result := Connected;
1174 if result then
1175 begin
1176 DatabaseInfo := TIBDatabaseInfo.Create(self);
1177 try
1178 DatabaseInfo.Database := self;
1179 { poke the server to see if connected }
1180 if DatabaseInfo.BaseLevel = 0 then ;
1181 DatabaseInfo.Free;
1182 except
1183 ForceClose;
1184 result := False;
1185 DatabaseInfo.Free;
1186 end;
1187 end;
1188 end;
1189
1190 procedure TIBDataBase.TimeoutConnection(Sender: TObject);
1191 begin
1192 if Connected then
1193 begin
1194 if not FAttachment.HasActivity then
1195 begin
1196 ForceClose;
1197 if Assigned(FOnIdleTimer) then
1198 FOnIdleTimer(Self);
1199 end
1200 end;
1201 end;
1202
1203 function TIBDataBase.GetIsReadOnly: Boolean;
1204 var
1205 DatabaseInfo: TIBDatabaseInfo;
1206 begin
1207 DatabaseInfo := TIBDatabaseInfo.Create(self);
1208 DatabaseInfo.Database := self;
1209 if (DatabaseInfo.ODSMajorVersion < 10) then
1210 result := false
1211 else
1212 begin
1213 if (DatabaseInfo.ReadOnly = 0) then
1214 result := false
1215 else
1216 result := true;
1217 end;
1218 DatabaseInfo.Free;
1219 end;
1220
1221 function TIBDataBase.GetSQLDialect: Integer;
1222 begin
1223 Result := FSQLDialect;
1224 end;
1225
1226
1227 procedure TIBDataBase.SetSQLDialect( const Value: Integer);
1228 begin
1229 if (Value < 1) then IBError(ibxeSQLDialectInvalid, [nil]);
1230 if ((FAttachment = nil) or (Value <= FDBSQLDialect)) then
1231 FSQLDialect := Value
1232 else
1233 IBError(ibxeSQLDialectInvalid, [nil]);
1234 end;
1235
1236 function TIBDataBase.GetDBSQLDialect: Integer;
1237 var
1238 DatabaseInfo: TIBDatabaseInfo;
1239 begin
1240 DatabaseInfo := TIBDatabaseInfo.Create(self);
1241 DatabaseInfo.Database := self;
1242 result := DatabaseInfo.DBSQLDialect;
1243 DatabaseInfo.Free;
1244 end;
1245
1246 procedure TIBDataBase.ValidateClientSQLDialect;
1247 begin
1248 if (FDBSQLDialect < FSQLDialect) then
1249 begin
1250 FSQLDialect := FDBSQLDialect;
1251 if Assigned (FOnDialectDowngradeWarning) then
1252 FOnDialectDowngradeWarning(self);
1253 end;
1254 end;
1255
1256 procedure TIBDataBase.ApplyUpdates( const DataSets: array of TDataSet);
1257 var
1258 I: Integer;
1259 DS: TIBCustomDataSet;
1260 TR: TIBTransaction;
1261 begin
1262 TR := nil;
1263 for I := 0 to High(DataSets) do
1264 begin
1265 DS := TIBCustomDataSet(DataSets[I]);
1266 if DS.Database <> Self then
1267 IBError(ibxeUpdateWrongDB, [nil]);
1268 if TR = nil then
1269 TR := DS.Transaction;
1270 if (DS.Transaction <> TR) or (TR = nil) then
1271 IBError(ibxeUpdateWrongTR, [nil]);
1272 end;
1273 TR.CheckInTransaction;
1274 for I := 0 to High(DataSets) do
1275 begin
1276 DS := TIBCustomDataSet(DataSets[I]);
1277 DS.ApplyUpdates;
1278 end;
1279 TR.CommitRetaining;
1280 end;
1281
1282 procedure TIBDataBase.CloseDataSets;
1283 var
1284 i: Integer;
1285 begin
1286 for i := 0 to DataSetCount - 1 do
1287 if (DataSets[i] <> nil) then
1288 DataSets[i].close;
1289 end;
1290
1291 function TIBDataBase.GetDataset(Index: longint): TDataset;
1292 begin
1293 if (Index >= 0) and (Index < FDataSets.Count) then
1294 Result := TDataSet(FDataSets[Index])
1295 else
1296 raise Exception.Create('Invalid Index to DataSets');
1297 end;
1298
1299 function TIBDataBase.GetDataSetCount: Longint;
1300 begin
1301 Result := FDataSets.Count;
1302 end;
1303
1304 procedure TIBDataBase.ReadState(Reader: TReader);
1305 begin
1306 FDBParams.Clear;
1307 inherited ReadState(Reader);
1308 end;
1309
1310 procedure TIBDataBase.SetConnected(Value: boolean);
1311 begin
1312 if StreamedConnected and not AllowStreamedConnected then
1313 begin
1314 StreamedConnected := false;
1315 Value := false
1316 end;
1317 inherited SetConnected(Value);
1318 end;
1319
1320 procedure TIBDataBase.GetFieldNames( const TableName: string; List: TStrings);
1321 var
1322 Query: TIBSQL;
1323 begin
1324 if TableName = '' then
1325 IBError(ibxeNoTableName, [nil]);
1326 if not Connected then
1327 Open;
1328 if not FInternalTransaction.Active then
1329 FInternalTransaction.StartTransaction;
1330 Query := TIBSQL.Create(self);
1331 try
1332 Query.GoToFirstRecordOnExecute := False;
1333 Query.Database := Self;
1334 Query.Transaction := FInternalTransaction;
1335 Query.SQL.Text := 'Select R.RDB$FIELD_NAME ' + {do not localize}
1336 'from RDB$RELATION_FIELDS R, RDB$FIELDS F ' + {do not localize}
1337 'where R.RDB$RELATION_NAME = ' + {do not localize}
1338 '''' +
1339 FormatIdentifierValue(SQLDialect, TableName) +
1340 ''' ' +
1341 'and R.RDB$FIELD_SOURCE = F.RDB$FIELD_NAME '; {do not localize}
1342 Query.Prepare;
1343 Query.ExecQuery;
1344 with List do
1345 begin
1346 BeginUpdate;
1347 try
1348 Clear;
1349 while (not Query.EOF) and Query.Next do
1350 List.Add(TrimRight(Query.FieldByName('RDB$FIELD_NAME').AsString)); {do not localize}
1351 finally
1352 EndUpdate;
1353 end;
1354 end;
1355 finally
1356 Query.free;
1357 FInternalTransaction.Commit;
1358 end;
1359 end;
1360
1361 procedure TIBDataBase.GetTableNames(List: TStrings; SystemTables: Boolean);
1362 var
1363 Query : TIBSQL;
1364 begin
1365 if not (csReading in ComponentState) then
1366 begin
1367 if not Connected then
1368 Open;
1369 if not FInternalTransaction.Active then
1370 FInternalTransaction.StartTransaction;
1371 Query := TIBSQL.Create(self);
1372 try
1373 Query.GoToFirstRecordOnExecute := False;
1374 Query.Database := Self;
1375 Query.Transaction := FInternalTransaction;
1376 if SystemTables then
1377 Query.SQL.Text := 'Select RDB$RELATION_NAME from RDB$RELATIONS' + {do not localize}
1378 ' where RDB$VIEW_BLR is NULL' {do not localize}
1379 else
1380 Query.SQL.Text := 'Select RDB$RELATION_NAME from RDB$RELATIONS' + {do not localize}
1381 ' where RDB$VIEW_BLR is NULL and RDB$SYSTEM_FLAG = 0'; {do not localize}
1382 Query.Prepare;
1383 Query.ExecQuery;
1384 with List do
1385 begin
1386 BeginUpdate;
1387 try
1388 Clear;
1389 while (not Query.EOF) and Query.Next do
1390 List.Add(TrimRight(Query.Fields[0].AsString));
1391 finally
1392 EndUpdate;
1393 end;
1394 end;
1395 finally
1396 Query.Free;
1397 FInternalTransaction.Commit;
1398 end;
1399 end;
1400 end;
1401
1402 { TIBTransaction }
1403
1404 constructor TIBTransaction.Create(AOwner: TComponent);
1405 begin
1406 inherited Create(AOwner);
1407 FDatabases := TList.Create;
1408 FSQLObjects := TList.Create;
1409 FTPB := nil;
1410 FTRParams := TStringList.Create;
1411 FTRParamsChanged := True;
1412 TStringList(FTRParams).OnChange := TRParamsChange;
1413 TStringList(FTRParams).OnChanging := TRParamsChanging;
1414 FTimer := TFPTimer.Create(Self);
1415 FTimer.Enabled := False;
1416 FTimer.Interval := 0;
1417 FTimer.OnTimer := TimeoutTransaction;
1418 FDefaultAction := taCommit;
1419 end;
1420
1421 destructor TIBTransaction.Destroy;
1422 var
1423 i: Integer;
1424 begin
1425 if InTransaction then
1426 EndTransaction(FDefaultAction, True);
1427 for i := 0 to FSQLObjects.Count - 1 do
1428 if FSQLObjects[i] <> nil then
1429 SQLObjects[i].DoTransactionFree;
1430 RemoveSQLObjects;
1431 RemoveDatabases;
1432 FTPB := nil;
1433 FTRParams.Free;
1434 FSQLObjects.Free;
1435 FDatabases.Free;
1436 inherited Destroy;
1437 end;
1438
1439 procedure TIBTransaction.CheckDatabasesInList;
1440 begin
1441 if GetDatabaseCount = 0 then
1442 IBError(ibxeNoDatabasesInTransaction, [nil]);
1443 end;
1444
1445 procedure TIBTransaction.CheckInTransaction;
1446 begin
1447 if FStreamedActive and (not InTransaction) then
1448 Loaded;
1449 if (TransactionIntf = nil) then
1450 IBError(ibxeNotInTransaction, [nil]);
1451 end;
1452
1453 procedure TIBTransaction.DoBeforeTransactionEnd;
1454 begin
1455 if Assigned(FBeforeTransactionEnd) then
1456 FBeforeTransactionEnd(self);
1457 end;
1458
1459 procedure TIBTransaction.DoAfterTransactionEnd;
1460 begin
1461 if Assigned(FAfterTransactionEnd) then
1462 FAfterTransactionEnd(self);
1463 end;
1464
1465 procedure TIBTransaction.DoOnStartTransaction;
1466 begin
1467 if assigned(FOnStartTransaction) then
1468 OnStartTransaction(self);
1469 end;
1470
1471 procedure TIBTransaction.DoAfterExecQuery(Sender: TObject);
1472 begin
1473 if assigned(FAfterExecQuery) then
1474 AfterExecQuery(Sender);
1475 end;
1476
1477 procedure TIBTransaction.DoAfterEdit(Sender: TObject);
1478 begin
1479 if assigned(FAfterEdit) then
1480 AfterEdit(Sender);
1481 end;
1482
1483 procedure TIBTransaction.DoAfterDelete(Sender: TObject);
1484 begin
1485 if assigned(FAfterDelete) then
1486 AfterDelete(Sender);
1487 end;
1488
1489 procedure TIBTransaction.DoAfterInsert(Sender: TObject);
1490 begin
1491 if assigned(FAfterInsert) then
1492 AfterInsert(Sender);
1493 end;
1494
1495 procedure TIBTransaction.DoAfterPost(Sender: TObject);
1496 begin
1497 if assigned(FAfterPost) then
1498 AfterPost(Sender);
1499 end;
1500
1501 procedure TIBTransaction.EnsureNotInTransaction;
1502 begin
1503 if csDesigning in ComponentState then
1504 begin
1505 if TransactionIntf <> nil then
1506 Rollback;
1507 end;
1508 end;
1509
1510 procedure TIBTransaction.CheckNotInTransaction;
1511 begin
1512 if (TransactionIntf <> nil) and TransactionIntf.InTransaction then
1513 IBError(ibxeInTransaction, [nil]);
1514 end;
1515
1516 function TIBTransaction.AddDatabase(db: TIBDatabase): Integer;
1517 var
1518 i: Integer;
1519 NilFound: Boolean;
1520 begin
1521 EnsureNotInTransaction;
1522 CheckNotInTransaction;
1523 FTransactionIntf := nil;
1524
1525 i := FindDatabase(db);
1526 if i <> -1 then
1527 begin
1528 result := i;
1529 exit;
1530 end;
1531 NilFound := False;
1532 i := 0;
1533 while (not NilFound) and (i < FDatabases.Count) do
1534 begin
1535 NilFound := (FDatabases[i] = nil);
1536 if (not NilFound) then
1537 Inc(i);
1538 end;
1539 if (NilFound) then
1540 begin
1541 FDatabases[i] := db;
1542 result := i;
1543 end
1544 else
1545 begin
1546 result := FDatabases.Count;
1547 FDatabases.Add(db);
1548 end;
1549 end;
1550
1551 function TIBTransaction.AddSQLObject(ds: TIBBase): Integer;
1552 begin
1553 result := 0;
1554 while (result < FSQLObjects.Count) and (FSQLObjects[result] <> nil) do
1555 Inc(result);
1556 if (result = FSQLObjects.Count) then
1557 FSQLObjects.Add(ds)
1558 else
1559 FSQLObjects[result] := ds;
1560 end;
1561
1562 procedure TIBTransaction.Commit;
1563 begin
1564 EndTransaction(TACommit, False);
1565 end;
1566
1567 procedure TIBTransaction.CommitRetaining;
1568 begin
1569 EndTransaction(TACommitRetaining, False);
1570 end;
1571
1572 procedure TIBTransaction.EndTransaction(Action: TTransactionAction;
1573 Force: Boolean);
1574 var
1575 i: Integer;
1576 begin
1577 CheckInTransaction;
1578 if FInEndTransaction then Exit;
1579 FInEndTransaction := true;
1580 FEndAction := Action;
1581 try
1582 case Action of
1583 TARollback, TACommit:
1584 begin
1585 DoBeforeTransactionEnd;
1586 for i := 0 to FSQLObjects.Count - 1 do if FSQLObjects[i] <> nil then
1587 SQLObjects[i].DoBeforeTransactionEnd(Action);
1588 if InTransaction then
1589 begin
1590 if (Action = TARollback) then
1591 FTransactionIntf.Rollback(Force)
1592 else
1593 try
1594 FTransactionIntf.Commit;
1595 except on E: EIBInterBaseError do
1596 begin
1597 if Force then
1598 FTransactionIntf.Rollback(Force)
1599 else
1600 raise;
1601 end;
1602 end;
1603
1604 for i := 0 to FSQLObjects.Count - 1 do if FSQLObjects[i] <> nil then
1605 SQLObjects[i].DoAfterTransactionEnd;
1606 DoAfterTransactionEnd;
1607 end;
1608 end;
1609 TACommitRetaining:
1610 FTransactionIntf.CommitRetaining;
1611
1612 TARollbackRetaining:
1613 FTransactionIntf.RollbackRetaining;
1614 end;
1615 if not (csDesigning in ComponentState) then
1616 begin
1617 case Action of
1618 TACommit:
1619 MonitorHook.TRCommit(Self);
1620 TARollback:
1621 MonitorHook.TRRollback(Self);
1622 TACommitRetaining:
1623 MonitorHook.TRCommitRetaining(Self);
1624 TARollbackRetaining:
1625 MonitorHook.TRRollbackRetaining(Self);
1626 end;
1627 end;
1628 finally
1629 FInEndTransaction := false
1630 end;
1631 end;
1632
1633 function TIBTransaction.GetDatabase(Index: Integer): TIBDatabase;
1634 begin
1635 result := FDatabases[Index];
1636 end;
1637
1638 function TIBTransaction.GetDatabaseCount: Integer;
1639 var
1640 i, Cnt: Integer;
1641 begin
1642 result := 0;
1643 Cnt := FDatabases.Count - 1;
1644 for i := 0 to Cnt do if FDatabases[i] <> nil then
1645 Inc(result);
1646 end;
1647
1648 function TIBTransaction.GetSQLObject(Index: Integer): TIBBase;
1649 begin
1650 result := FSQLObjects[Index];
1651 end;
1652
1653 function TIBTransaction.GetSQLObjectCount: Integer;
1654 var
1655 i, Cnt: Integer;
1656 begin
1657 result := 0;
1658 Cnt := FSQLObjects.Count - 1;
1659 for i := 0 to Cnt do if FSQLObjects[i] <> nil then
1660 Inc(result);
1661 end;
1662
1663 function TIBTransaction.GetInTransaction: Boolean;
1664 begin
1665 result := (TransactionIntf <> nil) and TransactionIntf.InTransaction;
1666 end;
1667
1668 function TIBTransaction.FindDatabase(db: TIBDatabase): Integer;
1669 var
1670 i: Integer;
1671 begin
1672 result := -1;
1673 for i := 0 to FDatabases.Count - 1 do
1674 if db = TIBDatabase(FDatabases[i]) then
1675 begin
1676 result := i;
1677 break;
1678 end;
1679 end;
1680
1681 function TIBTransaction.FindDefaultDatabase: TIBDatabase;
1682 var
1683 i: Integer;
1684 begin
1685 result := FDefaultDatabase;
1686 if result = nil then
1687 begin
1688 for i := 0 to FDatabases.Count - 1 do
1689 if (TIBDatabase(FDatabases[i]) <> nil) and
1690 (TIBDatabase(FDatabases[i]).DefaultTransaction = self) then
1691 begin
1692 result := TIBDatabase(FDatabases[i]);
1693 break;
1694 end;
1695 end;
1696 end;
1697
1698 function TIBTransaction.GetEndAction: TTransactionAction;
1699 begin
1700 if FInEndTransaction then
1701 Result := FEndAction
1702 else
1703 IBError(ibxeIB60feature, [nil])
1704 end;
1705
1706
1707 function TIBTransaction.GetIdleTimer: Integer;
1708 begin
1709 result := FTimer.Interval;
1710 end;
1711
1712 procedure TIBTransaction.Loaded;
1713 begin
1714 inherited Loaded;
1715 end;
1716
1717 procedure TIBTransaction.BeforeDatabaseDisconnect(DB: TIBDatabase);
1718 begin
1719 if InTransaction then
1720 EndTransaction(FDefaultAction, True);
1721 FTransactionIntf := nil;
1722 end;
1723
1724 procedure TIBTransaction.RemoveDatabase(Idx: Integer);
1725 var
1726 DB: TIBDatabase;
1727 begin
1728 if ((Idx >= 0) and (FDatabases[Idx] <> nil)) then
1729 begin
1730 EnsureNotInTransaction;
1731 CheckNotInTransaction;
1732 FTransactionIntf := nil;
1733
1734 DB := Databases[Idx];
1735 FDatabases[Idx] := nil;
1736 DB.RemoveTransaction(DB.FindTransaction(Self));
1737 if DB = FDefaultDatabase then
1738 FDefaultDatabase := nil;
1739 end;
1740 end;
1741
1742 procedure TIBTransaction.RemoveDatabases;
1743 var
1744 i: Integer;
1745 begin
1746 EnsureNotInTransaction;
1747 CheckNotInTransaction;
1748 FTransactionIntf := nil;
1749
1750 for i := 0 to FDatabases.Count - 1 do if FDatabases[i] <> nil then
1751 RemoveDatabase(i);
1752 end;
1753
1754 procedure TIBTransaction.RemoveSQLObject(Idx: Integer);
1755 var
1756 ds: TIBBase;
1757 begin
1758 if ((Idx >= 0) and (FSQLObjects[Idx] <> nil)) then
1759 begin
1760 ds := SQLObjects[Idx];
1761 FSQLObjects[Idx] := nil;
1762 ds.Transaction := nil;
1763 end;
1764 end;
1765
1766 procedure TIBTransaction.RemoveSQLObjects;
1767 var
1768 i: Integer;
1769 begin
1770 for i := 0 to FSQLObjects.Count - 1 do if FSQLObjects[i] <> nil then
1771 RemoveSQLObject(i);
1772 end;
1773
1774 procedure TIBTransaction.Rollback;
1775 begin
1776 EndTransaction(TARollback, False);
1777 end;
1778
1779 procedure TIBTransaction.RollbackRetaining;
1780 begin
1781 EndTransaction(TARollbackRetaining, False);
1782 end;
1783
1784 procedure TIBTransaction.SetActive(Value: Boolean);
1785 begin
1786 if csReading in ComponentState then
1787 FStreamedActive := Value
1788 else
1789 if Value and not InTransaction then
1790 StartTransaction
1791 else
1792 if not Value and InTransaction then
1793 Rollback;
1794 end;
1795
1796 procedure TIBTransaction.SetDefaultDatabase(Value: TIBDatabase);
1797 var
1798 i: integer;
1799 begin
1800 if (FDefaultDatabase <> nil) and (FDefaultDatabase <> Value) then
1801 begin
1802 i := FDefaultDatabase.FindTransaction(self);
1803 if (i <> -1) then
1804 FDefaultDatabase.RemoveTransaction(i);
1805 end;
1806 if (Value <> nil) and (FDefaultDatabase <> Value) then
1807 begin
1808 Value.AddTransaction(Self);
1809 AddDatabase(Value);
1810 for i := 0 to FSQLObjects.Count - 1 do
1811 if (FSQLObjects[i] <> nil) and
1812 (TIBBase(FSQLObjects[i]).Database = nil) then
1813 SetObjectProp(TIBBase(FSQLObjects[i]).Owner, 'Database', Value);
1814 end;
1815 FDefaultDatabase := Value;
1816 end;
1817
1818 procedure TIBTransaction.Notification( AComponent: TComponent;
1819 Operation: TOperation);
1820 var
1821 i: Integer;
1822 begin
1823 inherited Notification( AComponent, Operation);
1824 if (Operation = opRemove) and (AComponent = FDefaultDatabase) then
1825 begin
1826 i := FindDatabase(FDefaultDatabase);
1827 if (i <> -1) then
1828 RemoveDatabase(i);
1829 FDefaultDatabase := nil;
1830 end;
1831 end;
1832
1833 procedure TIBTransaction.SetIdleTimer(Value: Integer);
1834 begin
1835 if Value < 0 then
1836 IBError(ibxeTimeoutNegative, [nil])
1837 else
1838 if (Value = 0) then
1839 begin
1840 FTimer.Enabled := False;
1841 FTimer.Interval := 0;
1842 end
1843 else
1844 if (Value > 0) then
1845 begin
1846 FTimer.Interval := Value;
1847 if not (csDesigning in ComponentState) then
1848 FTimer.Enabled := True;
1849 end;
1850 end;
1851
1852 procedure TIBTransaction.SetTRParams(Value: TStrings);
1853 begin
1854 FTRParams.Assign(Value);
1855 end;
1856
1857 procedure TIBTransaction.StartTransaction;
1858 var
1859 i: Integer;
1860 Attachments: array of IAttachment;
1861 ValidDatabaseCount: integer;
1862 begin
1863 CheckNotInTransaction;
1864 CheckDatabasesInList;
1865 if TransactionIntf <> nil then
1866 begin
1867 TransactionIntf.Start(DefaultAction);
1868 Exit;
1869 end;
1870
1871 for i := 0 to FDatabases.Count - 1 do
1872 if FDatabases[i] <> nil then
1873 begin
1874 with TIBDatabase(FDatabases[i]) do
1875 if not Connected then
1876 if StreamedConnected then
1877 begin
1878 Open;
1879 StreamedConnected := False;
1880 end
1881 else
1882 IBError(ibxeDatabaseClosed, [nil]);
1883 end;
1884 if FTRParamsChanged then
1885 begin
1886 FTRParamsChanged := False;
1887 FTPB := GenerateTPB(FTRParams);
1888 end;
1889
1890 ValidDatabaseCount := 0;
1891 for i := 0 to DatabaseCount - 1 do
1892 if Databases[i] <> nil then Inc(ValidDatabaseCount);
1893
1894 if ValidDatabaseCount = 1 then
1895 FTransactionIntf := Databases[0].Attachment.StartTransaction(FTPB,DefaultAction)
1896 else
1897 begin
1898 SetLength(Attachments,ValidDatabaseCount);
1899 for i := 0 to DatabaseCount - 1 do
1900 if Databases[i] <> nil then
1901 Attachments[i] := Databases[i].Attachment;
1902
1903 FTransactionIntf := FirebirdAPI.StartTransaction(Attachments,FTPB,DefaultAction);
1904 end;
1905
1906 if not (csDesigning in ComponentState) then
1907 MonitorHook.TRStart(Self);
1908 DoOnStartTransaction;
1909 end;
1910
1911 procedure TIBTransaction.TimeoutTransaction(Sender: TObject);
1912 begin
1913 if InTransaction then
1914 begin
1915 if not TransactionIntf.HasActivity then
1916 begin
1917 EndTransaction(FDefaultAction, True);
1918 if Assigned(FOnIdleTimer) then
1919 FOnIdleTimer(Self);
1920 end
1921 end;
1922 end;
1923
1924 procedure TIBTransaction.TRParamsChange(Sender: TObject);
1925 begin
1926 FTRParamsChanged := True;
1927 end;
1928
1929 procedure TIBTransaction.TRParamsChanging(Sender: TObject);
1930 begin
1931 EnsureNotInTransaction;
1932 CheckNotInTransaction;
1933 FTransactionIntf := nil;
1934 end;
1935
1936 { TIBBase }
1937 constructor TIBBase.Create(AOwner: TObject);
1938 begin
1939 FOwner := AOwner;
1940 end;
1941
1942 destructor TIBBase.Destroy;
1943 begin
1944 SetDatabase(nil);
1945 SetTransaction(nil);
1946 inherited Destroy;
1947 end;
1948
1949 procedure TIBBase.HandleException(Sender: TObject);
1950 begin
1951 if assigned(Database) then
1952 Database.HandleException(Sender)
1953 else
1954 SysUtils.ShowException(ExceptObject,ExceptAddr);
1955 end;
1956
1957 procedure TIBBase.SetCursor;
1958 begin
1959 if Assigned(Database) and not Database.SQLHourGlass then
1960 Exit;
1961 if assigned(IBGUIInterface) then
1962 IBGUIInterface.SetCursor;
1963 end;
1964
1965 procedure TIBBase.RestoreCursor;
1966 begin
1967 if Assigned(Database) and not Database.SQLHourGlass then
1968 Exit;
1969 if assigned(IBGUIInterface) then
1970 IBGUIInterface.RestoreCursor;
1971 end;
1972
1973 procedure TIBBase.CheckDatabase;
1974 begin
1975 if (FDatabase = nil) then
1976 IBError(ibxeDatabaseNotAssigned, [nil]);
1977 FDatabase.CheckActive;
1978 end;
1979
1980 procedure TIBBase.CheckTransaction;
1981 begin
1982 if FTransaction = nil then
1983 IBError(ibxeTransactionNotAssigned, [nil]);
1984 FTransaction.CheckInTransaction;
1985 end;
1986
1987 procedure TIBBase.DoBeforeDatabaseConnect(DBParams: TStrings; var DBName: string
1988 );
1989 begin
1990 if assigned(FBeforeDatabaseConnect) then
1991 BeforeDatabaseConnect(self,DBParams,DBName);
1992 end;
1993
1994 procedure TIBBase.DoAfterDatabaseConnect;
1995 begin
1996 if assigned(FAfterDatabaseConnect) then
1997 AfterDatabaseConnect(self);
1998 end;
1999
2000 procedure TIBBase.DoBeforeDatabaseDisconnect;
2001 begin
2002 if Assigned(BeforeDatabaseDisconnect) then
2003 BeforeDatabaseDisconnect(Self);
2004 end;
2005
2006 procedure TIBBase.DoAfterDatabaseDisconnect;
2007 begin
2008 if Assigned(AfterDatabaseDisconnect) then
2009 AfterDatabaseDisconnect(Self);
2010 end;
2011
2012 procedure TIBBase.DoDatabaseFree;
2013 begin
2014 if Assigned(OnDatabaseFree) then
2015 OnDatabaseFree(Self);
2016 SetDatabase(nil);
2017 SetTransaction(nil);
2018 end;
2019
2020 procedure TIBBase.DoBeforeTransactionEnd(Action: TTransactionAction);
2021 begin
2022 if Assigned(BeforeTransactionEnd) then
2023 BeforeTransactionEnd(Self,Action);
2024 end;
2025
2026 procedure TIBBase.DoAfterTransactionEnd;
2027 begin
2028 if Assigned(AfterTransactionEnd) then
2029 AfterTransactionEnd(Self);
2030 end;
2031
2032 procedure TIBBase.DoTransactionFree;
2033 begin
2034 if Assigned(OnTransactionFree) then
2035 OnTransactionFree(Self);
2036 FTransaction := nil;
2037 end;
2038
2039 procedure TIBBase.DoAfterExecQuery(Sender: TObject);
2040 begin
2041 if FTransaction <> nil then
2042 FTransaction.DoAfterExecQuery(Sender);
2043 end;
2044
2045 procedure TIBBase.DoAfterEdit(Sender: TObject);
2046 begin
2047 if FTransaction <> nil then
2048 FTransaction.DoAfterEdit(Sender);
2049 end;
2050
2051 procedure TIBBase.DoAfterDelete(Sender: TObject);
2052 begin
2053 if FTransaction <> nil then
2054 FTransaction.DoAfterDelete(Sender);
2055 end;
2056
2057 procedure TIBBase.DoAfterInsert(Sender: TObject);
2058 begin
2059 if FTransaction <> nil then
2060 FTransaction.DoAfterInsert(Sender);
2061 end;
2062
2063 procedure TIBBase.DoAfterPost(Sender: TObject);
2064 begin
2065 if FTransaction <> nil then
2066 FTransaction.DoAfterPost(Sender);
2067 end;
2068
2069 procedure TIBBase.SetDatabase(Value: TIBDatabase);
2070 begin
2071 if (FDatabase <> nil) then
2072 FDatabase.RemoveSQLObject(FIndexInDatabase);
2073 FDatabase := Value;
2074 if (FDatabase <> nil) then
2075 begin
2076 FIndexInDatabase := FDatabase.AddSQLObject(Self);
2077 if (FTransaction = nil) then
2078 Transaction := FDatabase.FindDefaultTransaction;
2079 end;
2080 end;
2081
2082 procedure TIBBase.SetTransaction(Value: TIBTransaction);
2083 begin
2084 if (FTransaction <> nil) then
2085 FTransaction.RemoveSQLObject(FIndexInTransaction);
2086 FTransaction := Value;
2087 if (FTransaction <> nil) then
2088 begin
2089 FIndexInTransaction := FTransaction.AddSQLObject(Self);
2090 if (FDatabase = nil) then
2091 Database := FTransaction.FindDefaultDatabase;
2092 end;
2093 end;
2094
2095 { GenerateDPB -
2096 Given a string containing a textual representation
2097 of the database parameters, generate a database
2098 parameter buffer, and return it and its length
2099 in DPB and DPBLength, respectively. }
2100
2101 function GenerateDPB(sl: TStrings): IDPB;
2102 var
2103 i, j: Integer;
2104 DPBVal: UShort;
2105 ParamName, ParamValue: string;
2106 begin
2107 Result := FirebirdAPI.AllocateDPB;
2108
2109 {Iterate through the textual database parameters, constructing
2110 a DPB on-the-fly }
2111 for i := 0 to sl.Count - 1 do
2112 begin
2113 { Get the parameter's name and value from the list,
2114 and make sure that the name is all lowercase with
2115 no leading 'isc_dpb_' prefix
2116 }
2117 if (Trim(sl.Names[i]) = '') then
2118 continue;
2119 ParamName := LowerCase(sl.Names[i]); {mbcs ok}
2120 ParamValue := Copy(sl[i], Pos('=', sl[i]) + 1, Length(sl[i])); {mbcs ok}
2121 if (Pos(DPBPrefix, ParamName) = 1) then {mbcs ok}
2122 Delete(ParamName, 1, Length(DPBPrefix));
2123 { We want to translate the parameter name to some Integer
2124 value. We do this by scanning through a list of known
2125 database parameter names (DPBConstantNames, defined above) }
2126 DPBVal := 0;
2127 { Find the parameter }
2128 for j := 1 to isc_dpb_last_dpb_constant do
2129 if (ParamName = DPBConstantNames[j]) then
2130 begin
2131 DPBVal := j;
2132 break;
2133 end;
2134 { A database parameter either contains a string value (case 1)
2135 or an Integer value (case 2)
2136 or no value at all (case 3)
2137 or an error needs to be generated (case else) }
2138 case DPBVal of
2139 isc_dpb_user_name, isc_dpb_password, isc_dpb_password_enc,
2140 isc_dpb_sys_user_name, isc_dpb_license, isc_dpb_encrypt_key,
2141 isc_dpb_lc_messages, isc_dpb_lc_ctype,
2142 isc_dpb_sql_role_name, isc_dpb_sql_dialect:
2143 begin
2144 if DPBVal = isc_dpb_sql_dialect then
2145 ParamValue[1] := Char(Ord(ParamValue[1]) - 48);
2146 Result.Add(DPBVal).SetAsString(ParamValue);
2147 end;
2148
2149 isc_dpb_num_buffers, isc_dpb_dbkey_scope, isc_dpb_force_write,
2150 isc_dpb_no_reserve, isc_dpb_damaged, isc_dpb_verify:
2151 Result.Add(DPBVal).SetAsByte(byte(ParamValue[1]));
2152
2153 isc_dpb_sweep:
2154 Result.Add(DPBVal).SetAsByte(isc_dpb_records);
2155
2156 isc_dpb_sweep_interval:
2157 Result.Add(DPBVal).SetAsInteger(StrToInt(ParamValue));
2158
2159 isc_dpb_activate_shadow, isc_dpb_delete_shadow, isc_dpb_begin_log,
2160 isc_dpb_quit_log:
2161 Result.Add(DPBVal).SetAsByte(0);
2162 else
2163 begin
2164 if (DPBVal > 0) and
2165 (DPBVal <= isc_dpb_last_dpb_constant) then
2166 IBError(ibxeDPBConstantNotSupported, [DPBConstantNames[DPBVal]])
2167 else
2168 IBError(ibxeDPBConstantUnknownEx, [sl.Names[i]]);
2169 end;
2170 end;
2171 end;
2172 end;
2173
2174 { GenerateTPB -
2175 Given a string containing a textual representation
2176 of the transaction parameters, generate a transaction
2177 parameter buffer, and return it and its length in
2178 TPB and TPBLength, respectively. }
2179 function GenerateTPB(sl: TStrings): ITPB;
2180 var
2181 i, j, TPBVal: Integer;
2182 ParamName, ParamValue: string;
2183 begin
2184 Result := FirebirdAPI.AllocateTPB;
2185 for i := 0 to sl.Count - 1 do
2186 begin
2187 if (Trim(sl[i]) = '') then
2188 Continue;
2189
2190 if (Pos('=', sl[i]) = 0) then {mbcs ok}
2191 ParamName := LowerCase(sl[i]) {mbcs ok}
2192 else
2193 begin
2194 ParamName := LowerCase(sl.Names[i]); {mbcs ok}
2195 ParamValue := Copy(sl[i], Pos('=', sl[i]) + 1, Length(sl[i])); {mbcs ok}
2196 end;
2197 if (Pos(TPBPrefix, ParamName) = 1) then {mbcs ok}
2198 Delete(ParamName, 1, Length(TPBPrefix));
2199 TPBVal := 0;
2200 { Find the parameter }
2201 for j := 1 to isc_tpb_last_tpb_constant do
2202 if (ParamName = TPBConstantNames[j]) then
2203 begin
2204 TPBVal := j;
2205 break;
2206 end;
2207 { Now act on it }
2208 case TPBVal of
2209 isc_tpb_consistency, isc_tpb_exclusive, isc_tpb_protected,
2210 isc_tpb_concurrency, isc_tpb_shared, isc_tpb_wait, isc_tpb_nowait,
2211 isc_tpb_read, isc_tpb_write, isc_tpb_ignore_limbo,
2212 isc_tpb_read_committed, isc_tpb_rec_version, isc_tpb_no_rec_version:
2213 Result.Add(TPBVal);
2214
2215 isc_tpb_lock_read, isc_tpb_lock_write:
2216 Result.Add(TPBVal).SetAsString(ParamValue);
2217
2218 else
2219 begin
2220 if (TPBVal > 0) and
2221 (TPBVal <= isc_tpb_last_tpb_constant) then
2222 IBError(ibxeTPBConstantNotSupported, [TPBConstantNames[TPBVal]])
2223 else
2224 IBError(ibxeTPBConstantUnknownEx, [sl.Names[i]]);
2225 end;
2226 end;
2227 end;
2228 end;
2229
2230 end.
2231
2232
2233
2234
2235