ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBDatabase.pas
Revision: 47
Committed: Mon Jan 9 15:31:51 2017 UTC (7 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 62263 byte(s)
Log Message:
Committing updates for Release R2-0-1

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