ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBDatabase.pas
Revision: 5
Committed: Fri Feb 18 16:26:16 2011 UTC (13 years, 1 month ago) by tony
Content type: text/x-pascal
File size: 55770 byte(s)
Log Message:
Committing updates for Release pre-release

File Contents

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