ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBDatabase.pas
Revision: 37
Committed: Mon Feb 15 14:44:25 2016 UTC (8 years, 1 month ago) by tony
Content type: text/x-pascal
File size: 67371 byte(s)
Log Message:
Committing updates for Release R1-4-0

File Contents

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