ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBDatabase.pas
Revision: 23
Committed: Fri Mar 13 10:26:52 2015 UTC (9 years ago) by tony
Content type: text/x-pascal
File size: 60949 byte(s)
Log Message:
Committing updates for Release R1-2-1

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