ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBDatabase.pas
Revision: 17
Committed: Sat Dec 28 19:22:24 2013 UTC (10 years, 3 months ago) by tony
Content type: text/x-pascal
File size: 59696 byte(s)
Log Message:
Committing updates for Release R1-0-5

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