ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBDatabase.pas
Revision: 7
Committed: Sun Aug 5 18:28:19 2012 UTC (11 years, 7 months ago) by tony
Content type: text/x-pascal
File size: 57046 byte(s)
Log Message:
Committing updates for Release R1-0-0

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