ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBDatabase.pas
Revision: 43
Committed: Thu Sep 22 17:10:15 2016 UTC (7 years, 6 months ago) by tony
Content type: text/x-pascal
File size: 66650 byte(s)
Log Message:
Committing updates for Release R1-4-3

File Contents

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