ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBDatabase.pas
Revision: 29
Committed: Sat May 9 11:37:49 2015 UTC (8 years, 10 months ago) by tony
Content type: text/x-pascal
File size: 66482 byte(s)
Log Message:
Committing updates for Release R1-2-4

File Contents

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