ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/nongui/IBXServices.pas
Revision: 291
Committed: Fri Apr 17 10:26:08 2020 UTC (3 years, 11 months ago) by tony
Content type: text/x-pascal
File size: 94756 byte(s)
Log Message:
Changed for 2.3.4 merged into public release

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 - 2018 }
31 { }
32 {************************************************************************}
33
34 unit IBXServices;
35
36 {$mode objfpc}{$H+}
37
38 interface
39
40 uses
41 Classes, SysUtils, DB, IB, IBDatabase, IBTypes, IBSQLMonitor, IBExternals, memds;
42
43 type
44 TIBXCustomService = class;
45 TIBXControlService = class;
46 TIBXServicesConnection = class;
47
48 IIBXServicesClient = interface
49 procedure OnAfterConnect(Sender: TIBXServicesConnection; aDatabaseName: string);
50 procedure OnBeforeDisconnect(Sender: TIBXServicesConnection);
51 end;
52
53 TSecContextAction = (scRaiseError, scReconnect);
54
55 TIBXServicesLoginEvent = procedure(Service: TIBXServicesConnection; var aServerName: string; LoginParams: TStrings) of object;
56 TIBXServicesSecContextEvent = procedure(Service: TIBXServicesConnection; var aAction: TSecContextAction) of object;
57
58 { TIBXServicesConnection }
59
60 TIBXServicesConnection = class(TIBXMonitoredConnection)
61 private
62 FConfigOverrides: TStrings;
63 FDatabase: TIBDatabase;
64 FFirebirdAPI: IFirebirdAPI;
65 FConnectString: string;
66 FFirebirdLibraryPathName: TIBFileName;
67 FOnSecurityContextException: TIBXServicesSecContextEvent;
68 FParams: TStrings;
69 FIBXServices: array of IIBXServicesClient;
70 FOnLogin: TIBXServicesLoginEvent;
71 FService: IServiceManager;
72 FPortNo: string;
73 FServerName: string;
74 FProtocol: TProtocol;
75 FServerVersionNo: array [1..4] of integer;
76 FExpectedDB: string;
77 procedure CheckActive;
78 procedure CheckInactive;
79 procedure CheckServerName;
80 function GenerateSPB(sl: TStrings): ISPB;
81 function GetFirebirdAPI: IFirebirdAPI;
82 function GetServerVersionNo(index: integer): integer;
83 function GetSPBConstName(action: byte): string;
84 function GetWireCompression: boolean;
85 procedure HandleException(Sender: TObject);
86 procedure HandleSecContextException(Sender: TIBXControlService; var action: TSecContextAction);
87 function Login(var aServerName: string; LoginParams: TStrings): Boolean;
88 procedure ParseServerVersionNo;
89 procedure ParamsChanging(Sender: TObject);
90 procedure SetConfigOverrides(AValue: TStrings);
91 procedure SetConnectString(AValue: string);
92 procedure SetFirebirdLibraryPathName(AValue: TIBFileName);
93 procedure SetParams(AValue: TStrings);
94 procedure SetPortNo(AValue: string);
95 procedure SetProtocol(AValue: TProtocol);
96 procedure SetServerName(AValue: string);
97 procedure SetServiceIntf(AValue: IServiceManager); overload;
98 procedure SetWireCompression(AValue: boolean);
99 protected
100 procedure DoConnect; override;
101 procedure DoDisconnect; override;
102 function GetConnected: Boolean; override;
103 function GetDataset(Index : longint) : TDataset; override;
104 function GetDataSetCount : Longint; override;
105 procedure ReadState(Reader: TReader); override;
106 procedure RegisterIntf(intf: IIBXServicesClient);
107 procedure UnRegisterIntf(intf: IIBXServicesClient);
108 public
109 constructor Create(AOwner: TComponent); override;
110 destructor Destroy; override;
111 procedure ConnectUsing(aDatabase: TIBDatabase);
112 {Copies database parameters as give in the DBParams to the Services connection
113 omitting any parameters not appropriate for Services API. Typically, the
114 DBParams are TIBDatabase.Params}
115 procedure SetDBParams(DBParams: TStrings);
116 procedure SetServiceIntf(aServiceIntf: IServiceManager; aDatabase: TIBDatabase); overload;
117 property FirebirdAPI: IFirebirdAPI read GetFirebirdAPI;
118 property ServerVersionNo[index: integer]: integer read GetServerVersionNo;
119 property ServiceIntf: IServiceManager read FService write SetServiceIntf;
120 published
121 property Connected;
122 property ConnectString: string read FConnectString write SetConnectString;
123 property ConfigOverrides: TStrings read FConfigOverrides write SetConfigOverrides;
124 property FirebirdLibraryPathName: TIBFileName read FFirebirdLibraryPathName
125 write SetFirebirdLibraryPathName;
126 property LoginPrompt default True;
127 property Protocol: TProtocol read FProtocol write SetProtocol default Local;
128 property PortNo: string read FPortNo write SetPortNo;
129 property Params: TStrings read FParams write SetParams;
130 property ServerName: string read FServerName write SetServerName;
131 property TraceFlags;
132 property WireCompression: boolean read GetWireCompression write SetWireCompression
133 stored false;
134 property AfterConnect;
135 property AfterDisconnect;
136 property BeforeConnect;
137 property BeforeDisconnect;
138 property OnLogin: TIBXServicesLoginEvent read FOnLogin write FOnLogin;
139 property OnSecurityContextException: TIBXServicesSecContextEvent read FOnSecurityContextException
140 write FOnSecurityContextException;
141 end;
142
143 { TIBXCustomService }
144
145 TIBXCustomService = class(TIBXMonitoredService,IIBXServicesClient)
146 private
147 FSRB: ISRB;
148 FSQPB: ISQPB;
149 FServiceQueryResults: IServiceQueryResults;
150 FServicesConnection: TIBXServicesConnection;
151 procedure CheckActive;
152 function GetSQPB: ISQPB;
153 function GetSRB: ISRB;
154 procedure SetServicesConnection(AValue: TIBXServicesConnection);
155 protected
156 procedure Clear; virtual;
157 procedure OnAfterConnect(Sender: TIBXServicesConnection; aDatabaseName: string); virtual;
158 procedure OnBeforeDisconnect(Sender: TIBXServicesConnection); virtual;
159 procedure InternalServiceQuery(RaiseExceptionOnError: boolean=true);
160 procedure DoServiceQuery; virtual;
161 procedure Notification( AComponent: TComponent; Operation: TOperation); override;
162 property SRB: ISRB read GetSRB;
163 property SQPB: ISQPB read GetSQPB;
164 property ServiceQueryResults: IServiceQueryResults read FServiceQueryResults;
165 public
166 constructor Create(AOwner: TComponent); override;
167 destructor Destroy; override;
168 procedure Assign(Source: TPersistent); override;
169 published
170 property ServicesConnection: TIBXServicesConnection read FServicesConnection
171 write SetServicesConnection;
172 property TraceFlags;
173 end;
174
175 { TDatabaseInfo }
176
177 TDatabaseInfo = class
178 public
179 NoOfAttachments: Integer;
180 NoOfDatabases: Integer;
181 DbName: array of string;
182 constructor Create;
183 destructor Destroy; override;
184 end;
185
186 { TConfigFileData }
187
188 TConfigFileData = class
189 public
190 ConfigFileValue: array of integer;
191 ConfigFileKey: array of integer;
192 constructor Create;
193 destructor Destroy; override;
194 end;
195
196 { TConfigParams }
197
198 TConfigParams = class
199 public
200 ConfigFileData: TConfigFileData;
201 ConfigFileParams: array of string;
202 BaseLocation: string;
203 LockFileLocation: string;
204 MessageFileLocation: string;
205 SecurityDatabaseLocation: string;
206 constructor Create;
207 destructor Destroy; override;
208 end;
209
210 TVersionInfo = class
211 ServerVersion: String;
212 ServerImplementation: string;
213 ServiceVersion: Integer;
214 end;
215
216 { TIBXServerProperties }
217
218 TIBXServerProperties = class(TIBXCustomService)
219 private
220 FDatabaseInfo: TDatabaseInfo;
221 FVersionInfo: TVersionInfo;
222 FConfigParams: TConfigParams;
223 function GetConfigParams: TConfigParams;
224 function GetDatabaseInfo: TDatabaseInfo;
225 function GetVersionInfo: TVersionInfo;
226 protected
227 procedure Clear; override;
228 public
229 property DatabaseInfo: TDatabaseInfo read GetDatabaseInfo;
230 property VersionInfo: TVersionInfo read GetVersionInfo;
231 property ConfigParams: TConfigParams read GetConfigParams;
232 end;
233
234 { TIBXControlService }
235
236 TIBXControlService = class(TIBXCustomService)
237 private
238 FDatabaseName: string;
239 FAction: TSecContextAction;
240 FLastStartSRB: ISRB;
241 function GetIsServiceRunning: Boolean;
242 procedure HandleSecContextErr;
243 procedure CallSecContextException;
244 procedure SetDatabaseName(AValue: string);
245 protected
246 procedure DatabaseNameChanged; virtual;
247 procedure OnAfterConnect(Sender: TIBXServicesConnection; aDatabaseName: string); override;
248 procedure AddDBNameToSRB;
249 procedure CheckServiceNotRunning;
250 procedure InternalServiceStart;
251 procedure DoServiceQuery; override;
252 procedure SetServiceStartOptions; virtual;
253 procedure ServiceStart; virtual;
254 procedure WaitForServiceStop(AbortAfter: integer=5 {seconds});
255 property DatabaseName: string read FDatabaseName write SetDatabaseName;
256 public
257 procedure Assign(Source: TPersistent); override;
258 property IsServiceRunning : Boolean read GetIsServiceRunning;
259 end;
260
261 TIBXOnGetNextLine = procedure(Sender: TObject; var Line: string) of object;
262
263 { TIBXControlAndQueryService }
264
265 TIBXControlAndQueryService = class (TIBXControlService)
266 private
267 FEof: Boolean;
268 FSendBytes: integer;
269 FOnGetNextLine: TIBXOnGetNextLine;
270 FServiceStarted: boolean;
271 FDataSets: TList;
272 protected
273 function GetNextLine : String;
274 function GetNextChunk : String;
275 procedure ServiceStart; override;
276 function ReceiveNextChunk(stream: TStream): integer;
277 function SendNextChunk(stream: TStream; var line: String): integer;
278 procedure DoOnGetNextLine(Line: string);
279 procedure OnBeforeDisconnect(Sender: TIBXServicesConnection); override;
280 procedure Notification( AComponent: TComponent; Operation: TOperation); override;
281 procedure RegisterDataSet(aDataSet: TDataSet);
282 procedure UnRegisterDataSet(aDataSet: TDataSet);
283 public
284 constructor Create(aOwner: TComponent); override;
285 destructor Destroy; override;
286 procedure Execute(OutputLog: TStrings); virtual;
287 property Eof: boolean read FEof;
288 published
289 property OnGetNextLine: TIBXOnGetNextLine read FOnGetNextLine write FOnGetNextLine;
290 end;
291
292 { TIBXLogService }
293
294 TIBXLogService = class(TIBXControlAndQueryService)
295 protected
296 procedure SetServiceStartOptions; override;
297 end;
298
299 TDBShutdownMode = (Forced, DenyTransaction, DenyAttachment);
300
301 { TIBXConfigService }
302
303 TIBXConfigService = class(TIBXControlService)
304 public
305 procedure ShutdownDatabase (Options: TDBShutdownMode; Wait: Integer);
306 procedure SetSweepInterval (Value: Integer);
307 procedure SetDBSqlDialect (Value: Integer);
308 procedure SetPageBuffers (Value: Integer);
309 procedure ActivateShadow;
310 procedure BringDatabaseOnline;
311 procedure SetReserveSpace (Value: Boolean);
312 procedure SetAsyncMode (Value: Boolean);
313 procedure SetReadOnly (Value: Boolean);
314 procedure SetNoLinger;
315 published
316 property DatabaseName;
317 end;
318
319 TStatOption = (DataPages, HeaderPages, IndexPages, SystemRelations);
320 TStatOptions = set of TStatOption;
321
322 { TIBXStatisticalService }
323
324 TIBXStatisticalService = class(TIBXControlAndQueryService)
325 private
326 FOptions: TStatOptions;
327 protected
328 procedure SetServiceStartOptions; override;
329 published
330 property DatabaseName;
331 property Options: TStatOptions read FOptions write FOptions;
332 end;
333
334 TBackupStatsOption = (bsTotalTime,bsTimeDelta,bsPageReads,bsPageWrites);
335 TBackupStatsOptions = set of TBackupStatsOption;
336
337 { TIBXBackupRestoreService }
338
339 TIBXBackupRestoreService = class(TIBXControlAndQueryService)
340 private
341 FStatisticsRequested: TBackupStatsOptions;
342 FVerbose: Boolean;
343 protected
344 procedure SetServiceStartOptions; override;
345 property Verbose : Boolean read FVerbose write FVerbose default False;
346 property StatisticsRequested: TBackupStatsOptions read FStatisticsRequested write FStatisticsRequested;
347 published
348 end;
349
350 TBackupOption = (IgnoreChecksums, IgnoreLimbo, MetadataOnly, NoGarbageCollection,
351 OldMetadataDesc, NonTransportable, ConvertExtTables, NoDBTriggers);
352 TBackupOptions = set of TBackupOption;
353
354 { TIBXBackupService }
355
356 TIBXBackupService = class (TIBXBackupRestoreService)
357 private
358 FOptions: TBackupOptions;
359 FBlockingFactor: Integer;
360 protected
361 procedure SetServiceStartOptions; override;
362 procedure SetBackupTarget; virtual; abstract;
363 published
364 property BlockingFactor: Integer read FBlockingFactor write FBlockingFactor;
365 property DatabaseName;
366 property Options : TBackupOptions read FOptions write FOptions;
367 end;
368
369 { TIBXClientSideBackupService }
370
371 TIBXClientSideBackupService = class(TIBXBackupService)
372 protected
373 procedure Execute(OutputLog: TStrings); override;
374 procedure SetBackupTarget; override;
375 public
376 procedure BackupToStream(S: TStream; var BytesWritten: integer);
377 procedure BackupToFile(aFileName: string; var BytesWritten: integer);
378 end;
379
380 { TIBXServerSideBackupService }
381
382 TIBXServerSideBackupService = class(TIBXBackupService)
383 private
384 FBackupFiles: TStrings;
385 procedure SetBackupFile(const Value: TStrings);
386 protected
387 procedure SetBackupTarget; override;
388 public
389 constructor Create(AOwner: TComponent); override;
390 destructor Destroy; override;
391 {Use inherited Execute method to perform backup}
392 published
393 { a name=value pair of filename and length }
394 property BackupFiles: TStrings read FBackupFiles write SetBackupFile;
395 property StatisticsRequested;
396 property Verbose;
397 end;
398
399 TRestoreOption = (DeactivateIndexes, NoShadow, NoValidityCheck, OneRelationAtATime,
400 Replace, CreateNewDB, UseAllSpace, RestoreMetaDataOnly);
401
402 TRestoreOptions = set of TRestoreOption;
403
404 { TIBXRestoreService }
405
406 TIBXRestoreService = class (TIBXBackupRestoreService)
407 private
408 FDatabaseFiles: TStrings;
409 FOptions: TRestoreOptions;
410 FPageSize: Integer;
411 FPageBuffers: Integer;
412 procedure SetDatabaseFiles(const Value: TStrings);
413 protected
414 procedure DatabaseNameChanged; override;
415 procedure SetServiceStartOptions; override;
416 procedure SetArchiveSource; virtual; abstract;
417 public
418 constructor Create(AOwner: TComponent); override;
419 destructor Destroy; override;
420 published
421 { a name=value pair of filename and length }
422 property DatabaseFiles: TStrings read FDatabaseFiles write SetDatabaseFiles;
423 property PageSize: Integer read FPageSize write FPageSize;
424 property PageBuffers: Integer read FPageBuffers write FPageBuffers;
425 property Options : TRestoreOptions read FOptions write FOptions default [CreateNewDB];
426 property StatisticsRequested;
427 property Verbose;
428 end;
429
430 { TIBXClientSideRestoreService }
431
432 TIBXClientSideRestoreService = class(TIBXRestoreService)
433 protected
434 procedure Execute(OutputLog: TStrings); override;
435 procedure SetArchiveSource; override;
436 public
437 procedure RestoreFromStream(S: TStream; OutputLog: TStrings);
438 procedure RestoreFromFile(aFileName: string; OutputLog: TStrings);
439 procedure RestoreFromFiles(FileList: TStrings; OutputLog: TStrings);
440 end;
441
442 { TIBXServerSideRestoreService }
443
444 TIBXServerSideRestoreService = class(TIBXRestoreService)
445 private
446 FBackupFiles: TStrings;
447 procedure SetBackupFiles(const Value: TStrings);
448 protected
449 procedure SetArchiveSource; override;
450 public
451 constructor Create(AOwner: TComponent); override;
452 destructor Destroy; override;
453 {use inherited Execute method to perform restore}
454 published
455 property BackupFiles: TStrings read FBackupFiles write SetBackupFiles;
456 end;
457
458 { TIBXOnlineValidationService }
459
460 TIBXOnlineValidationService = class(TIBXControlAndQueryService)
461 private
462 FExcludeIndexes: string;
463 FExcludeTables: string;
464 FIncludeIndexes: string;
465 FIncludeTables: string;
466 FLockTimeout: integer;
467 protected
468 procedure SetServiceStartOptions; override;
469 procedure ServiceStart; override;
470 public
471 constructor Create(AOwner: TComponent); override;
472 published
473 property IncludeTables: string read FIncludeTables write FIncludeTables;
474 property ExcludeTables: string read FExcludeTables write FExcludeTables;
475 property IncludeIndexes: string read FIncludeIndexes write FIncludeIndexes;
476 property ExcludeIndexes: string read FExcludeIndexes write FExcludeIndexes;
477 property LockTimeout: integer read FLockTimeout write FLockTimeout default 10;
478 property DatabaseName;
479 end;
480
481 TValidateOption = (CheckDB, IgnoreChecksum, KillShadows, MendDB,
482 SweepDB, ValidateDB, ValidateFull);
483 TValidateOptions = set of TValidateOption;
484
485 { TIBXValidationService }
486
487 TIBXValidationService = class(TIBXControlAndQueryService)
488 private
489 FOptions: TValidateOptions;
490 protected
491 procedure SetServiceStartOptions; override;
492 public
493 {use inherited Execute method to perform validation}
494 published
495 property DatabaseName;
496 property Options: TValidateOptions read FOptions write FOptions;
497 end;
498
499 TUserInfo = class
500 public
501 UserName: string;
502 FirstName: string;
503 MiddleName: string;
504 LastName: string;
505 GroupID: Integer;
506 UserID: Integer;
507 AdminRole: boolean;
508 end;
509
510 TSecurityAction = (ActionAddUser, ActionDeleteUser, ActionModifyUser, ActionDisplayUser);
511 TSecurityModifyParam = (ModifyFirstName, ModifyMiddleName, ModifyLastName, ModifyUserId,
512 ModifyGroupId, ModifyPassword, ModifyAdminRole);
513 TSecurityModifyParams = set of TSecurityModifyParam;
514
515 { TIBXSecurityService }
516
517 TIBXSecurityService = class(TIBXControlAndQueryService)
518 private
519 FAdminRole: boolean;
520 FUserID: Integer;
521 FGroupID: Integer;
522 FFirstName: string;
523 FUserName: string;
524 FPassword: string;
525 FSQLRole: string;
526 FLastName: string;
527 FMiddleName: string;
528 FUserInfo: array of TUserInfo;
529 FSecurityAction: TSecurityAction;
530 FModifyParams: TSecurityModifyParams;
531 procedure ClearParams;
532 procedure SetAdminRole(AValue: boolean);
533 procedure SetSecurityAction (Value: TSecurityAction);
534 procedure SetFirstName (Value: String);
535 procedure SetMiddleName (Value: String);
536 procedure SetLastName (Value: String);
537 procedure SetPassword (Value: String);
538 procedure SetUserId (Value: Integer);
539 procedure SetGroupId (Value: Integer);
540
541 procedure FetchUserInfo;
542 function GetUserInfo(Index: Integer): TUserInfo;
543 function GetUserInfoCount: Integer;
544
545 protected
546 procedure Execute(OutputLog: TStrings); override;
547 procedure Loaded; override;
548 procedure SetServiceStartOptions; override;
549 property SecurityAction: TSecurityAction read FSecurityAction
550 write SetSecurityAction;
551 public
552 constructor Create(AOwner: TComponent); override;
553 destructor Destroy; override;
554 procedure DisplayUsers;
555 procedure DisplayUser(aUserName: string);
556 procedure AddUser;
557 procedure DeleteUser;
558 procedure ModifyUser;
559 function HasAdminRole: boolean;
560 procedure SetAutoAdmin(Value: Boolean);
561 property UserInfo[Index: Integer]: TUserInfo read GetUserInfo;
562 property UserInfoCount: Integer read GetUserInfoCount;
563
564 published
565 property SQlRole : string read FSQLRole write FSQLrole;
566 property UserName : string read FUserName write FUserName;
567 property FirstName : string read FFirstName write SetFirstName;
568 property MiddleName : string read FMiddleName write SetMiddleName;
569 property LastName : string read FLastName write SetLastName;
570 property UserID : Integer read FUserID write SetUserID;
571 property GroupID : Integer read FGroupID write SetGroupID;
572 property Password : string read FPassword write setPassword;
573 property AdminRole: boolean read FAdminRole write SetAdminRole;
574 end;
575
576 TTransactionGlobalAction = (CommitGlobal, RollbackGlobal, RecoverTwoPhaseGlobal,
577 NoGlobalAction);
578 TTransactionState = (LimboState, CommitState, RollbackState, UnknownState);
579 TTransactionAdvise = (CommitAdvise, RollbackAdvise, UnknownAdvise);
580 TTransactionAction = (CommitAction, RollbackAction);
581
582 TLimboTransactionInfo = class
583 public
584 MultiDatabase: Boolean;
585 ID: Integer;
586 HostSite: String;
587 RemoteSite: String;
588 RemoteDatabasePath: String;
589 State: TTransactionState;
590 Advise: TTransactionAdvise;
591 Action: TTransactionAction;
592 end;
593
594 { TIBXLimboTransactionResolutionService }
595
596 TIBXLimboTransactionResolutionService = class(TIBXControlAndQueryService)
597 private
598 FLimboTransactionInfo: array of TLimboTransactionInfo;
599 FGlobalAction: TTransactionGlobalAction;
600 function GetLimboTransactionInfo(index: integer): TLimboTransactionInfo;
601 function GetLimboTransactionInfoCount: integer;
602 function FetchLimboTransactionInfo: integer;
603
604 protected
605 procedure SetServiceStartOptions; override;
606 public
607 destructor Destroy; override;
608 procedure Clear; override;
609 procedure Execute(OutputLog: TStrings); override;
610 property LimboTransactionInfo[Index: integer]: TLimboTransactionInfo read GetLimboTransactionInfo;
611 property LimboTransactionInfoCount: Integer read GetLimboTransactionInfoCount;
612
613 published
614 property DatabaseName;
615 property GlobalAction: TTransactionGlobalAction read FGlobalAction
616 write FGlobalAction;
617
618 end;
619
620 TRequiredSources = class of TIBXControlAndQueryService;
621
622 { TIBXServicesDataSet }
623
624 TIBXServicesDataSet = class(TMemDataSet)
625 private
626 FSource: TIBXControlAndQueryService;
627 procedure SetSource(AValue: TIBXControlAndQueryService);
628 protected
629 FRequiredSource: TRequiredSources;
630 procedure DoBeforeClose; override;
631 procedure Notification( AComponent: TComponent; Operation: TOperation); override;
632 public
633 destructor Destroy; override;
634 published
635 property Source: TIBXControlAndQueryService read FSource write SetSource;
636 end;
637
638 { TIBXServicesUserList }
639
640 TIBXServicesUserList = class(TIBXServicesDataSet)
641 private
642 FLoading: boolean;
643 protected
644 procedure DoBeforePost; override;
645 procedure DoAfterInsert; override;
646 procedure DoAfterPost; override;
647 procedure DoAfterOpen; override;
648 procedure InternalDelete; override;
649 public
650 constructor Create(AOwner:TComponent); override;
651 end;
652
653 { TIBXServicesLimboTransactionsList }
654
655 TIBXServicesLimboTransactionsList = class(TIBXServicesDataSet)
656 private
657 FLoading: boolean;
658 protected
659 procedure DoBeforeInsert; override;
660 procedure DoAfterOpen; override;
661 procedure DoAfterPost; override;
662 procedure DoBeforePost; override;
663 public
664 constructor Create(AOwner:TComponent); override;
665 procedure Delete; override;
666 procedure FixErrors(GlobalAction: TTransactionGlobalAction; OutputLog: TStrings);
667 end;
668
669 function IsGbakFile(aFileName: string): boolean;
670
671 implementation
672
673 uses IBMessages, IBUtils, RegExpr, CustApp, IBErrorCodes;
674
675 const
676 SPBPrefix = 'isc_spb_';
677 isc_spb_last_spb_constant = 13;
678 SPBConstantNames: array[1..isc_spb_last_spb_constant] of String = (
679 'user_name',
680 'sys_user_name',
681 'sys_user_name_enc',
682 'password',
683 'password_enc',
684 'command_line',
685 'db_name',
686 'verbose',
687 'options',
688 'connect_timeout',
689 'dummy_packet_interval',
690 'sql_role_name',
691 'expected_db'
692 );
693
694 SPBConstantValues: array[1..isc_spb_last_spb_constant] of Integer = (
695 isc_spb_user_name,
696 isc_spb_sys_user_name,
697 isc_spb_sys_user_name_enc,
698 isc_spb_password,
699 isc_spb_password_enc,
700 isc_spb_command_line,
701 isc_spb_dbname,
702 isc_spb_verbose,
703 isc_spb_options,
704 isc_spb_connect_timeout,
705 isc_spb_dummy_packet_interval,
706 isc_spb_sql_role_name,
707 isc_spb_expected_db
708 );
709
710 function IsGbakFile(aFileName: string): boolean;
711 const
712 Signature = #$00#$02#$04;
713 var F: TFilestream;
714 Buffer: array [1..3] of char;
715 begin
716 Result := false;
717 F := TFileStream.Create(aFileName,fmOpenRead);
718 try
719 F.Read(Buffer,3);
720 Result := CompareText(Buffer,Signature) = 0;
721 finally
722 F.Free;
723 end;
724 end;
725
726 { TIBXClientSideRestoreService }
727
728 procedure TIBXClientSideRestoreService.Execute(OutputLog: TStrings);
729 begin
730 // Do nothing
731 end;
732
733 procedure TIBXClientSideRestoreService.SetArchiveSource;
734 begin
735 SRB.Add(isc_spb_bkp_file).AsString := 'stdin';
736 end;
737
738 procedure TIBXClientSideRestoreService.RestoreFromStream(S: TStream;
739 OutputLog: TStrings);
740 var line: string;
741 begin
742 ServiceStart;
743 try
744 while not Eof do
745 begin
746 SendNextChunk(S,line);
747 if line <> '' then
748 begin
749 DoOnGetNextLine(line);
750 if OutputLog <> nil then
751 OutputLog.Add(line);
752 end;
753 end;
754 finally
755 WaitForServiceStop; {flush}
756 end;
757 end;
758
759 procedure TIBXClientSideRestoreService.RestoreFromFile(aFileName: string;
760 OutputLog: TStrings);
761 var F: TFileStream;
762 begin
763 F := TFileStream.Create(aFileName,fmOpenRead);
764 try
765 RestoreFromStream(F,OutputLog)
766 finally
767 F.Free;
768 end;
769 end;
770
771 procedure TIBXClientSideRestoreService.RestoreFromFiles(FileList: TStrings;
772 OutputLog: TStrings);
773 var i: integer;
774 F: TFileStream;
775 line: string;
776 begin
777 ServiceStart;
778 for i := 0 to FileList.Count - 1 do
779 begin
780 F := TFileStream.Create(FileList[i],fmOpenRead);
781 try
782 while Eof do
783 begin
784 SendNextChunk(F,line);
785 if line <> '' then
786 begin
787 DoOnGetNextLine(line);
788 if OutputLog <> nil then
789 OutputLog.Add(line);
790 end;
791 end;
792 finally
793 F.Free;
794 WaitForServiceStop; {flush}
795 FEof := false;
796 end;
797 end;
798 end;
799
800 { TIBXClientSideBackupService }
801
802 procedure TIBXClientSideBackupService.Execute(OutputLog: TStrings);
803 begin
804 //Do nothing
805 end;
806
807 procedure TIBXClientSideBackupService.SetBackupTarget;
808 begin
809 SRB.Add(isc_spb_bkp_file).AsString := 'stdout';
810 end;
811
812 procedure TIBXClientSideBackupService.BackupToStream(S: TStream;
813 var BytesWritten: integer);
814 var InitialSize: integer;
815 begin
816 InitialSize := S.Size;
817 ServiceStart;
818 while not Eof do
819 ReceiveNextChunk(S);
820 BytesWritten := S.Size - InitialSize;
821 WaitForServiceStop;
822 end;
823
824 procedure TIBXClientSideBackupService.BackupToFile(aFileName: string;
825 var BytesWritten: integer);
826 var F: TFileStream;
827 begin
828 F := TFileStream.Create(aFileName,fmCreate);
829 try
830 BackupToStream(F,BytesWritten);
831 finally
832 F.Free;
833 end;
834 end;
835
836 { TIBXServicesLimboTransactionsList }
837
838 procedure TIBXServicesLimboTransactionsList.DoBeforeInsert;
839 begin
840 inherited DoBeforeInsert;
841 if not FLoading then
842 IBError(ibxeNoLimboTransactionInsert,[nil]);
843 end;
844
845 procedure TIBXServicesLimboTransactionsList.DoAfterOpen;
846
847 function TypeToStr(MultiDatabase: boolean): string;
848 begin
849 if MultiDatabase then
850 Result := 'Multi DB'
851 else
852 Result := 'Single DB';
853 end;
854
855 function StateToStr(State: TTransactionState): string;
856 begin
857 case State of
858 LimboState:
859 Result := 'Limbo';
860 CommitState:
861 Result := 'Commit';
862 RollbackState:
863 Result := 'Rollback';
864 else
865 Result := 'Unknown';
866 end;
867 end;
868
869 function AdviseToStr(Advise: TTransactionAdvise): string;
870 begin
871 case Advise of
872 CommitAdvise:
873 Result := 'Commit';
874 RollbackAdvise:
875 Result := 'Rollback';
876 else
877 Result := 'Unknown';
878 end;
879 end;
880
881 function ActionToStr(anAction: TTransactionAction): string;
882 begin
883 case anAction of
884 CommitAction:
885 Result := 'Commit';
886 RollbackAction:
887 Result := 'Rollback';
888 end;
889 end;
890
891 var i: integer;
892 begin
893 if FLoading then Exit;
894 FLoading := true;
895 with FSource as TIBXLimboTransactionResolutionService do
896 try
897 for i := 0 to LimboTransactionInfoCount - 1 do
898 with LimboTransactionInfo[i] do
899 begin
900 Append;
901 FieldByName('TransactionID').AsInteger := ID;
902 FieldByName('TransactionType').AsString := TypeToStr(MultiDatabase);
903 FieldByName('HostSite').AsString := HostSite;
904 FieldByName('RemoteSite').AsString := RemoteSite;
905 FieldByName('DatabasePath').AsString := RemoteDatabasePath;
906 FieldByName('State').AsString := StateToStr(State);
907 FieldByName('RecommendedAction').AsString := AdviseToStr(Advise);
908 FieldByName('RequestedAction').AsString := ActionToStr(Action);
909 Post;
910 end;
911 finally
912 FLoading := false;
913 end;
914 inherited DoAfterOpen;
915 end;
916
917 procedure TIBXServicesLimboTransactionsList.DoAfterPost;
918 begin
919 if not FLoading then
920 inherited DoAfterPost;
921 end;
922
923 procedure TIBXServicesLimboTransactionsList.DoBeforePost;
924 var i: integer;
925 begin
926 inherited DoBeforePost;
927 if FLoading then Exit;
928 with FSource as TIBXLimboTransactionResolutionService do
929 for i := 0 to LimboTransactionInfoCount - 1 do
930 with LimboTransactionInfo[i] do
931 begin
932 if ID = FieldByName('TransactionID').AsInteger then
933 begin
934 if FieldByName('RequestedAction').AsString = 'Commit' then
935 Action := CommitAction
936 else
937 if FieldByName('RequestedAction').AsString = 'Rollback' then
938 Action := RollbackAction;
939 break;
940 end;
941 end;
942 end;
943
944
945 constructor TIBXServicesLimboTransactionsList.Create(AOwner: TComponent);
946 var i: integer;
947 begin
948 inherited Create(AOwner);
949 FRequiredSource := TIBXLimboTransactionResolutionService;
950 with FieldDefs do
951 if Count = 0 then
952 begin
953 Add('TransactionID',ftInteger);
954 Add('TransactionType',ftString,16);
955 Add('HostSite',ftString,256);
956 Add('RemoteSite',ftString,256);
957 Add('DatabasePath',ftString,256);
958 Add('State',ftString,32);
959 Add('RecommendedAction',ftString,32);
960 Add('RequestedAction',ftString,32);
961 for i := 0 to Count - 2 do
962 Items[i].Attributes := Items[i].Attributes + [faReadOnly];
963 end;
964 end;
965
966 procedure TIBXServicesLimboTransactionsList.Delete;
967 begin
968 //Do nothing
969 end;
970
971 procedure TIBXServicesLimboTransactionsList.FixErrors(
972 GlobalAction: TTransactionGlobalAction; OutputLog: TStrings);
973 begin
974 if State = dsEdit then Post;
975 (FSource as TIBXLimboTransactionResolutionService).GlobalAction := GlobalAction;
976 (FSource as TIBXLimboTransactionResolutionService).Execute(OutputLog);
977 Active := false;
978 Active := true;
979 end;
980
981 { TIBXServicesUserList }
982
983 procedure TIBXServicesUserList.DoBeforePost;
984 procedure SetParams;
985 begin
986 with FSource as TIBXSecurityService do
987 begin
988 UserID := FieldByName('UserID').AsInteger;
989 GroupID := FieldByName('GroupID').AsInteger;
990 UserName := FieldByName('SEC$USER_NAME').AsString;
991 FirstName := FieldByName('SEC$FIRST_NAME').AsString;
992 MiddleName := FieldByName('SEC$MIDDLE_NAME').AsString;
993 LastName := FieldByName('SEC$LAST_NAME').AsString;
994 if not FieldByName('SEC$PASSWORD').IsNull then
995 Password := FieldByName('SEC$PASSWORD').AsString;
996 AdminRole := FieldByName('SEC$ADMIN').AsBoolean;
997 end;
998 end;
999
1000 begin
1001 inherited DoBeforePost;
1002 if FLoading then Exit;
1003 case State of
1004 dsEdit:
1005 begin
1006 SetParams;
1007 (FSource as TIBXSecurityService).ModifyUser;
1008 end;
1009 dsInsert:
1010 begin
1011 SetParams;
1012 (FSource as TIBXSecurityService).AddUser;
1013 end;
1014 end;
1015 end;
1016
1017 procedure TIBXServicesUserList.DoAfterInsert;
1018 begin
1019 FieldByName('UserID').AsInteger := 0;
1020 FieldByName('GroupID').AsInteger := 0;
1021 FieldByName('SEC$PASSWORD').Clear;
1022 FieldByName('SEC$ADMIN').AsBoolean := false;
1023 inherited DoAfterInsert;
1024 end;
1025
1026 procedure TIBXServicesUserList.DoAfterPost;
1027 begin
1028 {Refresh}
1029 if not FLoading then
1030 begin
1031 inherited DoAfterPost;
1032 with FSource as TIBXSecurityService do
1033 begin
1034 DisplayUser(FieldByName('SEC$USER_NAME').AsString);
1035 if UserInfoCount > 0 then
1036 with UserInfo[0] do
1037 begin
1038 FieldByName('UserID').AsInteger := UserID;
1039 FieldByName('GroupID').AsInteger := GroupID;
1040 FieldByName('SEC$USER_NAME').AsString := UserName;
1041 FieldByName('SEC$FIRST_NAME').AsString := FirstName;
1042 FieldByName('SEC$MIDDLE_NAME').AsString := MiddleName;
1043 FieldByName('SEC$LAST_NAME').AsString := LastName;
1044 FieldByName('SEC$PASSWORD').Clear;
1045 FieldByName('SEC$ADMIN').AsBoolean := AdminRole;
1046 end;
1047 end;
1048 end;
1049 end;
1050
1051 procedure TIBXServicesUserList.DoAfterOpen;
1052 var i: integer;
1053 Buf: TStringList;
1054 begin
1055 buf := TStringList.Create; {Used to sort user info}
1056 try
1057 with FSource as TIBXSecurityService do
1058 begin
1059 buf.Sorted := true;
1060 DisplayUsers;
1061 FLoading := true;
1062 try
1063 for i := 0 to UserInfoCount - 1 do
1064 buf.AddObject(UserInfo[i].UserName,UserInfo[i]);
1065
1066 for i := 0 to buf.Count - 1 do
1067 with TUserInfo(buf.Objects[i]) do
1068 begin
1069 Append;
1070 FieldByName('UserID').AsInteger := UserID;
1071 FieldByName('GroupID').AsInteger := GroupID;
1072 FieldByName('SEC$USER_NAME').AsString := UserName;
1073 FieldByName('SEC$FIRST_NAME').AsString := FirstName;
1074 FieldByName('SEC$MIDDLE_NAME').AsString := MiddleName;
1075 FieldByName('SEC$LAST_NAME').AsString := LastName;
1076 FieldByName('SEC$PASSWORD').Clear;
1077 FieldByName('SEC$ADMIN').AsBoolean := AdminRole;
1078 Post;
1079 end;
1080 finally
1081 FLoading := false;
1082 end;
1083 end;
1084 finally
1085 Buf.Free;
1086 end;
1087 inherited DoAfterOpen;
1088 end;
1089
1090 procedure TIBXServicesUserList.InternalDelete;
1091 begin
1092 with FSource as TIBXSecurityService do
1093 begin
1094 UserName := FieldByName('SEC$USER_NAME').AsString;
1095 DeleteUser;
1096 end;
1097 inherited InternalDelete;
1098 end;
1099
1100 constructor TIBXServicesUserList.Create(AOwner: TComponent);
1101 begin
1102 inherited Create(AOwner);
1103 FRequiredSource := TIBXSecurityService;
1104 with FieldDefs do
1105 if Count = 0 then
1106 begin
1107 Add('UserID',ftInteger);
1108 Add('GroupID',ftInteger);
1109 Add('SEC$USER_NAME',ftString,31);
1110 Add('SEC$FIRST_NAME',ftString,32);
1111 Add('SEC$MIDDLE_NAME',ftString,32);
1112 Add('SEC$LAST_NAME',ftString,32);
1113 Add('SEC$PASSWORD',ftString,32);
1114 Add('SEC$ADMIN',ftBoolean);
1115 end;
1116 end;
1117
1118 { TIBXServicesDataSet }
1119
1120 procedure TIBXServicesDataSet.SetSource(AValue: TIBXControlAndQueryService);
1121 begin
1122 if FSource = AValue then Exit;
1123 if (AValue <> nil) and not (AValue is FRequiredSource) then
1124 IBError(ibxeNotRequiredDataSetSource,[AValue.ClassName]);
1125 if FSource <> nil then
1126 begin
1127 FSource.UnRegisterDataSet(self);
1128 RemoveFreeNotification(FSource);
1129 end;
1130 FSource := AValue;
1131 if FSource <> nil then
1132 begin
1133 FSource.RegisterDataSet(self);
1134 FreeNotification(FSource);
1135 end;
1136 end;
1137
1138 procedure TIBXServicesDataSet.DoBeforeClose;
1139 begin
1140 if csDestroying in ComponentState then Exit;
1141 if State in [dsEdit,dsInsert] then Post;
1142 Clear(false);
1143 inherited DoBeforeClose;
1144 end;
1145
1146 procedure TIBXServicesDataSet.Notification(AComponent: TComponent;
1147 Operation: TOperation);
1148 begin
1149 inherited Notification(AComponent, Operation);
1150 if (Operation = opRemove) and (AComponent = FSource) then
1151 FSource := nil;
1152 end;
1153
1154 destructor TIBXServicesDataSet.Destroy;
1155 begin
1156 Source := nil;
1157 inherited Destroy;
1158 end;
1159
1160 { TIBXLimboTransactionResolutionService }
1161
1162 function TIBXLimboTransactionResolutionService.GetLimboTransactionInfo(
1163 index: integer): TLimboTransactionInfo;
1164 begin
1165 if index < GetLimboTransactionInfoCount then
1166 Result := FLimboTransactionInfo[index]
1167 else
1168 Result := nil;
1169 end;
1170
1171 function TIBXLimboTransactionResolutionService.GetLimboTransactionInfoCount: integer;
1172 begin
1173 Result := Length(FLimboTransactionInfo);
1174 if Result = 0 then
1175 Result := FetchLimboTransactionInfo;
1176 end;
1177
1178 procedure TIBXLimboTransactionResolutionService.SetServiceStartOptions;
1179 var i: integer;
1180 begin
1181 SRB.Add(isc_action_svc_repair);
1182 AddDBNameToSRB;
1183 if Length(FLimboTransactionInfo) = 0 then
1184 SRB.Add(isc_spb_options).AsInteger := isc_spb_rpr_list_limbo_trans
1185 else
1186 {Fixing existing transactions}
1187 begin
1188 case FGlobalAction of
1189 NoGlobalAction:
1190 begin
1191 for i := 0 to LimboTransactionInfoCount - 1 do
1192 begin
1193 if (FLimboTransactionInfo[i].Action = CommitAction) then
1194 SRB.Add(isc_spb_rpr_commit_trans).AsInteger := FLimboTransactionInfo[i].ID
1195 else
1196 SRB.Add(isc_spb_rpr_rollback_trans).AsInteger := FLimboTransactionInfo[i].ID;
1197 end;
1198 end;
1199
1200 CommitGlobal:
1201 begin
1202 for i := 0 to LimboTransactionInfoCount - 1 do
1203 SRB.Add(isc_spb_rpr_commit_trans).AsInteger := FLimboTransactionInfo[i].ID;
1204 end;
1205
1206 RollbackGlobal:
1207 begin
1208 for i := 0 to LimboTransactionInfoCount - 1 do
1209 SRB.Add(isc_spb_rpr_rollback_trans).AsInteger := FLimboTransactionInfo[i].ID;
1210 end;
1211
1212 RecoverTwoPhaseGlobal:
1213 begin
1214 for i := 0 to LimboTransactionInfoCount - 1 do
1215 SRB.Add(isc_spb_rpr_recover_two_phase).AsInteger := FLimboTransactionInfo[i].ID;
1216 end;
1217 end;
1218 end;
1219 end;
1220
1221 destructor TIBXLimboTransactionResolutionService.Destroy;
1222 begin
1223 Clear;
1224 inherited Destroy;
1225 end;
1226
1227 procedure TIBXLimboTransactionResolutionService.Clear;
1228 var
1229 i : Integer;
1230 begin
1231 for i := 0 to High(FLimboTransactionInfo) do
1232 FLimboTransactionInfo[i].Free;
1233 SetLength(FLimboTransactionInfo,0);
1234 end;
1235
1236
1237 function TIBXLimboTransactionResolutionService.FetchLimboTransactionInfo: integer;
1238
1239 procedure NextLimboTransaction(index: integer);
1240 begin
1241 SetLength(FLimboTransactionInfo, index+1);
1242 FLimboTransactionInfo[index] := TLimboTransactionInfo.Create;
1243 { if no advice commit as default }
1244 FLimboTransactionInfo[index].Advise := UnknownAdvise;
1245 FLimboTransactionInfo[index].Action:= CommitAction;
1246 end;
1247
1248 var
1249 i,j, k: Integer;
1250 begin
1251 Clear;
1252 Result := 0;
1253 ServiceStart;
1254 SRB.Add(isc_info_svc_limbo_trans);
1255 InternalServiceQuery;
1256
1257 k := -1;
1258 for i := 0 to FServiceQueryResults.Count - 1 do
1259 with FServiceQueryResults[i] do
1260 case getItemType of
1261 isc_info_svc_limbo_trans:
1262 begin
1263 if FServiceQueryResults[i].Count = 0 then continue;
1264 NextLimboTransaction(0);
1265 for j := 0 to FServiceQueryResults[i].Count - 1 do
1266 begin
1267 with FServiceQueryResults[i][j] do
1268 begin
1269 case getItemType of
1270 isc_spb_single_tra_id:
1271 begin
1272 Inc(k);
1273 if k > 0 then
1274 NextLimboTransaction(k);
1275 FLimboTransactionInfo[k].MultiDatabase := False;
1276 FLimboTransactionInfo[k].ID := AsInteger;
1277 end;
1278
1279 isc_spb_multi_tra_id:
1280 begin
1281 Inc(k);
1282 if k > 0 then
1283 NextLimboTransaction(k);
1284 FLimboTransactionInfo[k].MultiDatabase := True;
1285 FLimboTransactionInfo[k].ID := AsInteger;
1286 end;
1287
1288 isc_spb_tra_host_site:
1289 FLimboTransactionInfo[k].HostSite := AsString;
1290
1291 isc_spb_tra_state:
1292 case AsByte of
1293 isc_spb_tra_state_limbo:
1294 FLimboTransactionInfo[k].State := LimboState;
1295
1296 isc_spb_tra_state_commit:
1297 FLimboTransactionInfo[k].State := CommitState;
1298
1299 isc_spb_tra_state_rollback:
1300 FLimboTransactionInfo[k].State := RollbackState;
1301
1302 else
1303 FLimboTransactionInfo[k].State := UnknownState;
1304 end;
1305
1306 isc_spb_tra_remote_site:
1307 FLimboTransactionInfo[k].RemoteSite := AsString;
1308
1309 isc_spb_tra_db_path:
1310 FLimboTransactionInfo[k].RemoteDatabasePath := AsString;
1311
1312 isc_spb_tra_advise:
1313 with FLimboTransactionInfo[k] do
1314 begin
1315 case (AsByte) of
1316 isc_spb_tra_advise_commit:
1317 begin
1318 Advise := CommitAdvise;
1319 Action:= CommitAction;
1320 end;
1321
1322 isc_spb_tra_advise_rollback:
1323 begin
1324 Advise := RollbackAdvise;
1325 Action := RollbackAction;
1326 end;
1327
1328 else
1329 Advise := UnknownAdvise;
1330 end;
1331 end;
1332
1333 else
1334 IBError(ibxeOutputParsingError, [getItemType]);
1335 end;
1336 end;
1337 end;
1338 end;
1339 else
1340 IBError(ibxeOutputParsingError, [getItemType]);
1341 end;
1342 Result := Length(FLimboTransactionInfo);
1343 end;
1344
1345 procedure TIBXLimboTransactionResolutionService.Execute(OutputLog: TStrings);
1346 begin
1347 if Length(FLimboTransactionInfo) > 0 then
1348 begin
1349 ServiceStart; {Fix is implicit in non-zero list of Limbo transactions}
1350 while not Eof do
1351 OutputLog.Add(GetNextLine);
1352 WaitForServiceStop;
1353 Clear;
1354 end;
1355 end;
1356
1357 { TIBXSecurityService }
1358
1359 constructor TIBXSecurityService.Create(AOwner: TComponent);
1360 begin
1361 inherited Create(AOwner);
1362 FModifyParams := [];
1363 end;
1364
1365 destructor TIBXSecurityService.Destroy;
1366 var
1367 i : Integer;
1368 begin
1369 for i := 0 to High(FUserInfo) do
1370 FUserInfo[i].Free;
1371 FUserInfo := nil;
1372 inherited Destroy;
1373 end;
1374
1375 procedure TIBXSecurityService.Execute(OutputLog: TStrings);
1376 begin
1377 //Do nothing
1378 end;
1379
1380 procedure TIBXSecurityService.FetchUserInfo;
1381 var
1382 i, j, k: Integer;
1383 begin
1384 SRB.Add(isc_info_svc_get_users);
1385 InternalServiceQuery;
1386
1387 for i := 0 to High(FUserInfo) do
1388 FUserInfo[i].Free;
1389 for i := 0 to FServiceQueryResults.Count - 1 do
1390 with FServiceQueryResults[i] do
1391 begin
1392 case getItemType of
1393 isc_info_svc_get_users:
1394 begin
1395 SetLength(FUserInfo,1);
1396 k := 0;
1397 FUserInfo[0] := TUserInfo.Create;
1398 FUserInfo[0].UserName := '';
1399 for j := 0 to FServiceQueryResults[i].Count - 1 do
1400 begin
1401 with FServiceQueryResults[i][j] do
1402 case getItemType of
1403 isc_spb_sec_username:
1404 begin
1405 if FUserInfo[k].UserName <> '' then
1406 begin
1407 Inc(k);
1408 SetLength(FUserInfo,k+1);
1409 if FUserInfo[k] = nil then
1410 FUserInfo[k] := TUserInfo.Create;
1411 end;
1412 FUserInfo[k].UserName := AsString;
1413 end;
1414
1415 isc_spb_sec_firstname:
1416 FUserInfo[k].FirstName := AsString;
1417
1418 isc_spb_sec_middlename:
1419 FUserInfo[k].MiddleName := AsString;
1420
1421 isc_spb_sec_lastname:
1422 FUserInfo[k].LastName := AsString;
1423
1424 isc_spb_sec_userId:
1425 FUserInfo[k].UserId := AsInteger;
1426
1427 isc_spb_sec_groupid:
1428 FUserInfo[k].GroupID := AsInteger;
1429
1430 isc_spb_sec_admin:
1431 FUserInfo[k].AdminRole := AsInteger <> 0;
1432
1433 else
1434 IBError(ibxeOutputParsingError, [getItemType]);
1435 end;
1436 end;
1437 end;
1438 else
1439 IBError(ibxeOutputParsingError, [getItemType]);
1440 end;
1441 end;
1442 end;
1443
1444 function TIBXSecurityService.GetUserInfo(Index: Integer): TUserInfo;
1445 begin
1446 if Index <= High(FUSerInfo) then
1447 result := FUserInfo[Index]
1448 else
1449 result := nil;
1450 end;
1451
1452 function TIBXSecurityService.GetUserInfoCount: Integer;
1453 begin
1454 Result := Length(FUserInfo);
1455 end;
1456
1457 procedure TIBXSecurityService.AddUser;
1458 begin
1459 SecurityAction := ActionAddUser;
1460 ServiceStart;
1461 WaitForServiceStop;
1462 end;
1463
1464 procedure TIBXSecurityService.DeleteUser;
1465 begin
1466 SecurityAction := ActionDeleteUser;
1467 ServiceStart;
1468 WaitForServiceStop;
1469 end;
1470
1471 procedure TIBXSecurityService.DisplayUsers;
1472 begin
1473 SecurityAction := ActionDisplayUser;
1474 ClearParams;
1475 FUserName := '';
1476 ServiceStart;
1477 FetchUserInfo;
1478 end;
1479
1480 procedure TIBXSecurityService.DisplayUser(aUserName: string);
1481 begin
1482 SecurityAction := ActionDisplayUser;
1483 ClearParams;
1484 FUserName := aUserName;
1485 ServiceStart;
1486 FetchUserInfo;
1487 end;
1488
1489 procedure TIBXSecurityService.ModifyUser;
1490 begin
1491 SecurityAction := ActionModifyUser;
1492 ServiceStart;
1493 WaitForServiceStop;
1494 end;
1495
1496 function TIBXSecurityService.HasAdminRole: boolean;
1497 begin
1498 CheckActive;
1499 with ServicesConnection do
1500 Result := (ServerVersionNo[1] > 2) or
1501 ((ServerVersionNo[1] = 2) and (ServerVersionNo[2] = 5));
1502 end;
1503
1504 procedure TIBXSecurityService.SetAutoAdmin(Value: Boolean);
1505 begin
1506 CheckActive;
1507 {only available for Firebird 2.5 and later}
1508 with ServicesConnection do
1509 if (ServerVersionNo[1] < 2) or
1510 ((ServerVersionNo[1] = 2) and (ServerVersionNo[2] < 5)) then Exit;
1511 if Value then
1512 SRB.Add(isc_action_svc_set_mapping)
1513 else
1514 SRB.Add(isc_action_svc_drop_mapping);
1515 InternalServiceStart;
1516 WaitForServiceStop;
1517 end;
1518
1519 procedure TIBXSecurityService.SetSecurityAction (Value: TSecurityAction);
1520 begin
1521 FSecurityAction := Value;
1522 if Value = ActionDeleteUser then
1523 ClearParams;
1524 end;
1525
1526 procedure TIBXSecurityService.ClearParams;
1527 begin
1528 FModifyParams := [];
1529 FFirstName := '';
1530 FMiddleName := '';
1531 FLastName := '';
1532 FGroupID := 0;
1533 FUserID := 0;
1534 FPassword := '';
1535 end;
1536
1537 procedure TIBXSecurityService.SetAdminRole(AValue: boolean);
1538 begin
1539 FAdminRole := AValue;
1540 Include (FModifyParams, ModifyAdminRole);
1541 end;
1542
1543 procedure TIBXSecurityService.SetFirstName (Value: String);
1544 begin
1545 FFirstName := Value;
1546 Include (FModifyParams, ModifyFirstName);
1547 end;
1548
1549 procedure TIBXSecurityService.SetMiddleName (Value: String);
1550 begin
1551 FMiddleName := Value;
1552 Include (FModifyParams, ModifyMiddleName);
1553 end;
1554
1555 procedure TIBXSecurityService.SetLastName (Value: String);
1556 begin
1557 FLastName := Value;
1558 Include (FModifyParams, ModifyLastName);
1559 end;
1560
1561 procedure TIBXSecurityService.SetPassword (Value: String);
1562 begin
1563 FPassword := Value;
1564 Include (FModifyParams, ModifyPassword);
1565 end;
1566
1567 procedure TIBXSecurityService.SetUserId (Value: Integer);
1568 begin
1569 FUserId := Value;
1570 Include (FModifyParams, ModifyUserId);
1571 end;
1572
1573 procedure TIBXSecurityService.SetGroupId (Value: Integer);
1574 begin
1575 FGroupId := Value;
1576 Include (FModifyParams, ModifyGroupId);
1577 end;
1578
1579 procedure TIBXSecurityService.Loaded;
1580 begin
1581 inherited Loaded;
1582 ClearParams;
1583 end;
1584
1585 procedure TIBXSecurityService.SetServiceStartOptions;
1586 var
1587 Len: UShort;
1588
1589 begin
1590 case FSecurityAction of
1591 ActionDisplayUser:
1592 begin
1593 if HasAdminRole then
1594 SRB.Add(isc_action_svc_display_user_adm) {Firebird 2.5 and later only}
1595 else
1596 SRB.Add(isc_action_svc_display_user);
1597 if UserName <> '' then
1598 SRB.Add(isc_spb_sec_username).AsString := UserName;
1599 end;
1600
1601 ActionAddUser:
1602 begin
1603 if ( Pos(' ', FUserName) > 0 ) then
1604 IBError(ibxeStartParamsError, [nil]);
1605 Len := Length(FUserName);
1606 if (Len = 0) then
1607 IBError(ibxeStartParamsError, [nil]);
1608 SRB.Add(isc_action_svc_add_user);
1609 SRB.Add(isc_spb_sec_username).AsString := FUserName;
1610 if FSQLRole <> '' then
1611 SRB.Add(isc_spb_sql_role_name).AsString := FSQLRole;
1612 SRB.Add(isc_spb_sec_userid).AsInteger := FUserID;
1613 SRB.Add(isc_spb_sec_groupid).AsInteger := FGroupID;
1614 SRB.Add(isc_spb_sec_password).AsString := FPassword;
1615 SRB.Add(isc_spb_sec_firstname).AsString := FFirstName;
1616 SRB.Add(isc_spb_sec_middlename).AsString := FMiddleName;
1617 SRB.Add(isc_spb_sec_lastname).AsString := FLastName;
1618 if HasAdminRole then
1619 SRB.Add(isc_spb_sec_admin).AsInteger := ord(FAdminRole);
1620 end;
1621
1622 ActionDeleteUser:
1623 begin
1624 Len := Length(FUserName);
1625 if (Len = 0) then
1626 IBError(ibxeStartParamsError, [nil]);
1627 SRB.Add(isc_action_svc_delete_user);
1628 SRB.Add(isc_spb_sec_username).AsString := FUserName;
1629 if FSQLRole <> '' then
1630 SRB.Add(isc_spb_sql_role_name).AsString := FSQLRole;
1631 end;
1632
1633 ActionModifyUser:
1634 begin
1635 Len := Length(FUserName);
1636 if (Len = 0) then
1637 IBError(ibxeStartParamsError, [nil]);
1638 SRB.Add(isc_action_svc_modify_user);
1639 SRB.Add(isc_spb_sec_username).AsString := FUserName;
1640 if FSQLRole <> '' then
1641 SRB.Add(isc_spb_sql_role_name).AsString := FSQLRole;
1642 if (ModifyUserId in FModifyParams) then
1643 SRB.Add(isc_spb_sec_userid).AsInteger := FUserID;
1644 if (ModifyGroupId in FModifyParams) then
1645 SRB.Add(isc_spb_sec_groupid).AsInteger := FGroupID;
1646 if (ModifyPassword in FModifyParams) then
1647 SRB.Add(isc_spb_sec_password).AsString := FPassword;
1648 if (ModifyFirstName in FModifyParams) then
1649 SRB.Add(isc_spb_sec_firstname).AsString := FFirstName;
1650 if (ModifyMiddleName in FModifyParams) then
1651 SRB.Add(isc_spb_sec_middlename).AsString := FMiddleName;
1652 if (ModifyLastName in FModifyParams) then
1653 SRB.Add(isc_spb_sec_lastname).AsString := FLastName;
1654 if (ModifyAdminRole in FModifyParams) and HasAdminRole then
1655 begin
1656 if FAdminRole then
1657 SRB.Add(isc_spb_sec_admin).AsInteger := 1
1658 else
1659 SRB.Add(isc_spb_sec_admin).AsInteger := 0;
1660 end;
1661 end;
1662 end;
1663 ClearParams;
1664 end;
1665
1666
1667 { TIBXValidationService }
1668
1669 procedure TIBXValidationService.SetServiceStartOptions;
1670 var
1671 param: Integer;
1672 begin
1673 SRB.Add(isc_action_svc_repair);
1674 AddDBNAmeToSRB;
1675
1676 param := 0;
1677 if (SweepDB in Options) then
1678 param := param or isc_spb_rpr_sweep_db;
1679 if (ValidateDB in Options) then
1680 param := param or isc_spb_rpr_validate_db;
1681
1682 if (CheckDB in Options) then
1683 param := param or isc_spb_rpr_check_db;
1684 if (IgnoreChecksum in Options) then
1685 param := param or isc_spb_rpr_ignore_checksum;
1686 if (KillShadows in Options) then
1687 param := param or isc_spb_rpr_kill_shadows;
1688 if (MendDB in Options) then
1689 param := param or isc_spb_rpr_mend_db;
1690 if (ValidateFull in Options) then
1691 begin
1692 param := param or isc_spb_rpr_full;
1693 if not (MendDB in Options) then
1694 param := param or isc_spb_rpr_validate_db;
1695 end;
1696 if param > 0 then
1697 SRB.Add(isc_spb_options).AsInteger := param;
1698 end;
1699
1700 { TIBXOnlineValidationService }
1701
1702 procedure TIBXOnlineValidationService.SetServiceStartOptions;
1703 begin
1704 SRB.Add(isc_action_svc_validate);
1705 AddDBNameToSRB;
1706 if IncludeTables <> '' then
1707 SRB.Add(isc_spb_val_tab_incl).AsString := IncludeTables;
1708 if ExcludeTables <> '' then
1709 SRB.Add(isc_spb_val_tab_excl).AsString := ExcludeTables;
1710 if IncludeIndexes <> '' then
1711 SRB.Add(isc_spb_val_idx_incl).AsString := IncludeIndexes;
1712 if ExcludeIndexes <> '' then
1713 SRB.Add(isc_spb_val_idx_excl).AsString := ExcludeIndexes;
1714 if LockTimeout <> 0 then
1715 SRB.Add(isc_spb_val_lock_timeout).AsInteger := LockTimeout;
1716 end;
1717
1718 constructor TIBXOnlineValidationService.Create(AOwner: TComponent);
1719 begin
1720 inherited Create(AOwner);
1721 FLockTimeout := 10;
1722 end;
1723
1724 procedure TIBXOnlineValidationService.ServiceStart;
1725 begin
1726 CheckActive;
1727 {Firebird 2.5 and later}
1728 with ServicesConnection do
1729 if (ServerVersionNo[1] < 2) or
1730 ((ServerVersionNo[1] = 2) and (ServerVersionNo[2] < 5)) then
1731 IBError(ibxeServiceUnavailable,[]);
1732 inherited ServiceStart;
1733 end;
1734
1735 { TIBXServerSideRestoreService }
1736
1737 procedure TIBXServerSideRestoreService.SetBackupFiles(const Value: TStrings);
1738 begin
1739 FBackupFiles.Assign(Value);
1740 end;
1741
1742 procedure TIBXServerSideRestoreService.SetArchiveSource;
1743 var i: integer;
1744 begin
1745 for i := 0 to FBackupFiles.Count - 1 do
1746 begin
1747 if (Trim(FBackupFiles[i]) = '') then continue;
1748 if (Pos('=', FBackupFiles[i]) <> 0) then {mbcs ok}
1749 begin
1750 SRB.Add(isc_spb_bkp_file).AsString := FBackupFiles.Names[i];
1751 SRB.Add(isc_spb_bkp_length).AsInteger := StrToInt(FBackupFiles.ValueFromIndex[i]);
1752 end
1753 else
1754 SRB.Add(isc_spb_bkp_file).AsString := FBackupFiles[i];
1755 end
1756 end;
1757
1758 constructor TIBXServerSideRestoreService.Create(AOwner: TComponent);
1759 begin
1760 inherited Create(AOwner);
1761 FBackupFiles := TStringList.Create;
1762 end;
1763
1764 destructor TIBXServerSideRestoreService.Destroy;
1765 begin
1766 if assigned(FBackupFiles) then FBackupFiles.Free;
1767 inherited Destroy;
1768 end;
1769
1770 { TIBXRestoreService }
1771
1772 procedure TIBXRestoreService.SetDatabaseFiles(const Value: TStrings);
1773 begin
1774 FDatabaseFiles.Assign(Value);
1775 end;
1776
1777 procedure TIBXRestoreService.DatabaseNameChanged;
1778 begin
1779 inherited DatabaseNameChanged;
1780 DatabaseFiles.Clear;
1781 DatabaseFiles.Add(DatabaseName);
1782 end;
1783
1784 procedure TIBXRestoreService.SetServiceStartOptions;
1785 var
1786 param: Integer;
1787 i: integer;
1788 begin
1789 SRB.Add(isc_action_svc_restore);
1790 inherited SetServiceStartOptions;
1791
1792 param := 0;
1793 if (DeactivateIndexes in Options) then
1794 param := param or isc_spb_res_deactivate_idx;
1795 if (NoShadow in Options) then
1796 param := param or isc_spb_res_no_shadow;
1797 if (NoValidityCheck in Options) then
1798 param := param or isc_spb_res_no_validity;
1799 if (OneRelationAtATime in Options) then
1800 param := param or isc_spb_res_one_at_a_time;
1801 if (Replace in Options) then
1802 param := param or isc_spb_res_replace;
1803 if (CreateNewDB in Options) then
1804 param := param or isc_spb_res_create;
1805 if (UseAllSpace in Options) then
1806 param := param or isc_spb_res_use_all_space;
1807 if (RestoreMetaDataOnly in Options) then
1808 param := param or isc_spb_res_metadata_only;
1809 SRB.Add(isc_spb_options).AsInteger := param;
1810
1811 if FPageSize > 0 then
1812 SRB.Add(isc_spb_res_page_size).AsInteger := FPageSize;
1813 if FPageBuffers > 0 then
1814 SRB.Add(isc_spb_res_buffers).AsInteger := FPageBuffers;
1815
1816 SetArchiveSource;
1817
1818 if FDatabaseFiles.Count > 0 then
1819 FDatabaseName := FDatabaseFiles[0]; {needed if an isc_sec_context error}
1820 for i := 0 to FDatabaseFiles.Count - 1 do
1821 begin
1822 if (Trim(FDatabaseFiles[i]) = '') then continue;
1823 if (Pos('=', FDatabaseFiles[i]) <> 0) then {mbcs ok}
1824 begin
1825 SRB.Add(isc_spb_dbname).AsString := FDatabaseFiles.Names[i];
1826 SRB.Add(isc_spb_res_length).AsInteger := StrToInt(FDatabaseFiles.ValueFromIndex[i]);
1827 end
1828 else
1829 SRB.Add(isc_spb_dbname).AsString := FDatabaseFiles[i];
1830 end;
1831 end;
1832
1833 constructor TIBXRestoreService.Create(AOwner: TComponent);
1834 begin
1835 inherited Create(AOwner);
1836 FDatabaseFiles := TStringList.Create;
1837 Include (FOptions, CreateNewDB);
1838 end;
1839
1840 destructor TIBXRestoreService.Destroy;
1841 begin
1842 if FDatabaseFiles <> nil then FDatabaseFiles.Free;
1843 inherited Destroy;
1844 end;
1845
1846 { TIBXServerSideBackupService }
1847
1848 procedure TIBXServerSideBackupService.SetBackupFile(const Value: TStrings);
1849 begin
1850 FBackupFiles.Assign(Value);
1851 end;
1852
1853 procedure TIBXServerSideBackupService.SetBackupTarget;
1854 var i: integer;
1855 begin
1856 for i := 0 to FBackupFiles.Count - 1 do
1857 begin
1858 if (Trim(FBackupFiles[i]) = '') then
1859 continue;
1860 if (Pos('=', FBackupFiles[i]) <> 0) then
1861 begin {mbcs ok}
1862 SRB.Add(isc_spb_bkp_file).AsString := FBackupFiles.Names[i];
1863 SRB.Add(isc_spb_bkp_length).AsInteger := StrToInt(FBackupFiles.ValueFromIndex[i]);
1864 end
1865 else
1866 SRB.Add(isc_spb_bkp_file).AsString := FBackupFiles[i];
1867 end;
1868 end;
1869
1870 constructor TIBXServerSideBackupService.Create(AOwner: TComponent);
1871 begin
1872 inherited Create(AOwner);
1873 FBackupFiles := TStringList.Create;
1874 end;
1875
1876 destructor TIBXServerSideBackupService.Destroy;
1877 begin
1878 if assigned(FBackupFiles) then FBackupFiles.Free;
1879 inherited Destroy;
1880 end;
1881
1882 { TIBXBackupService }
1883
1884 procedure TIBXBackupService.SetServiceStartOptions;
1885 var
1886 param: Integer;
1887 begin
1888 SRB.Add(isc_action_svc_backup);
1889 AddDBNameToSRB;
1890 inherited SetServiceStartOptions;
1891
1892 param := 0;
1893 if (IgnoreChecksums in Options) then
1894 param := param or isc_spb_bkp_ignore_checksums;
1895 if (IgnoreLimbo in Options) then
1896 param := param or isc_spb_bkp_ignore_limbo;
1897 if (MetadataOnly in Options) then
1898 param := param or isc_spb_bkp_metadata_only;
1899 if (NoGarbageCollection in Options) then
1900 param := param or isc_spb_bkp_no_garbage_collect;
1901 if (OldMetadataDesc in Options) then
1902 param := param or isc_spb_bkp_old_descriptions;
1903 if (NonTransportable in Options) then
1904 param := param or isc_spb_bkp_non_transportable;
1905 if (ConvertExtTables in Options) then
1906 param := param or isc_spb_bkp_convert;
1907 {Firebird 2.5 and later}
1908 with ServicesConnection do
1909 if (ServerVersionNo[1] > 2) or
1910 ((ServerVersionNo[1] = 2) and (ServerVersionNo[2] = 5)) then
1911 begin
1912 if (NoDBTriggers in Options) then
1913 param := param or isc_spb_bkp_no_triggers;
1914 end;
1915 SRB.Add(isc_spb_options).AsInteger := param;
1916
1917 if FBlockingFactor > 0 then
1918 SRB.Add(isc_spb_bkp_factor).AsInteger := FBlockingFactor;
1919 SetBackupTarget;
1920 end;
1921
1922 { TIBXBackupRestoreService }
1923
1924 procedure TIBXBackupRestoreService.SetServiceStartOptions;
1925 var options: string;
1926 begin
1927 if Verbose then
1928 SRB.Add(isc_spb_verbose);
1929
1930 with ServicesConnection do
1931 {Firebird 2.5.5 and later}
1932 if (ServerVersionNo[1] < 2) or
1933 ((ServerVersionNo[1] = 2) and ((ServerVersionNo[2] < 5) or
1934 ((ServerVersionNo[2] = 5) and (ServerVersionNo[3] < 5)))) then Exit;
1935
1936 if StatisticsRequested <> [] then
1937 begin
1938 options := '';
1939 if bsTotalTime in StatisticsRequested then
1940 options += 'T';
1941 if bsTimeDelta in StatisticsRequested then
1942 options += 'D';
1943 if bsPageReads in StatisticsRequested then
1944 options += 'R';
1945 if bsPageWrites in StatisticsRequested then
1946 options += 'W';
1947 SRB.Add(isc_spb_bkp_stat).AsString := options;
1948 end;
1949 end;
1950
1951
1952 { TIBXStatisticalService }
1953
1954 procedure TIBXStatisticalService.SetServiceStartOptions;
1955 var param: integer;
1956 begin
1957 SRB.Add(isc_action_svc_db_stats);
1958 AddDBNameToSRB;
1959
1960 param := 0;
1961 if (DataPages in Options) then
1962 param := param or isc_spb_sts_data_pages;
1963 if (HeaderPages in Options) then
1964 param := param or isc_spb_sts_hdr_pages;
1965 if (IndexPages in Options) then
1966 param := param or isc_spb_sts_idx_pages;
1967 if (SystemRelations in Options) then
1968 param := param or isc_spb_sts_sys_relations;
1969 SRB.Add(isc_spb_options).AsInteger := param;
1970 end;
1971
1972 { TIBXConfigService }
1973
1974 procedure TIBXConfigService.ShutdownDatabase(Options: TDBShutdownMode;
1975 Wait: Integer);
1976 begin
1977 SRB.Add(isc_action_svc_properties);
1978 AddDBNameToSRB;
1979 if (Options = Forced) then
1980 SRB.Add(isc_spb_prp_shutdown_db).AsInteger := Wait
1981 else if (Options = DenyTransaction) then
1982 SRB.Add(isc_spb_prp_deny_new_transactions).AsInteger := Wait
1983 else
1984 SRB.Add(isc_spb_prp_deny_new_attachments).AsInteger := Wait;
1985 InternalServiceStart;
1986 WaitForServiceStop;
1987 end;
1988
1989 procedure TIBXConfigService.SetSweepInterval(Value: Integer);
1990 begin
1991 CheckActive;
1992 SRB.Add(isc_action_svc_properties);
1993 AddDBNameToSRB;
1994 SRB.Add(isc_spb_prp_sweep_interval).AsInteger := Value;
1995 InternalServiceStart;
1996 WaitForServiceStop;
1997 end;
1998
1999 procedure TIBXConfigService.SetDBSqlDialect(Value: Integer);
2000 begin
2001 SRB.Add(isc_action_svc_properties);
2002 AddDBNameToSRB;
2003 SRB.Add(isc_spb_prp_set_sql_dialect).AsInteger := Value;
2004 InternalServiceStart;
2005 WaitForServiceStop;
2006 end;
2007
2008 procedure TIBXConfigService.SetPageBuffers(Value: Integer);
2009 begin
2010 SRB.Add(isc_action_svc_properties);
2011 AddDBNameToSRB;
2012 SRB.Add(isc_spb_prp_page_buffers).AsInteger := Value;
2013 InternalServiceStart;
2014 WaitForServiceStop;
2015 end;
2016
2017 procedure TIBXConfigService.ActivateShadow;
2018 begin
2019 SRB.Add(isc_action_svc_properties);
2020 AddDBNameToSRB;
2021 SRB.Add(isc_spb_options).AsInteger := isc_spb_prp_activate;
2022 InternalServiceStart;
2023 WaitForServiceStop;
2024 end;
2025
2026 procedure TIBXConfigService.BringDatabaseOnline;
2027 begin
2028 SRB.Add(isc_action_svc_properties);
2029 AddDBNameToSRB;
2030 SRB.Add(isc_spb_options).AsInteger := isc_spb_prp_db_online;
2031 InternalServiceStart;
2032 WaitForServiceStop;
2033 end;
2034
2035 procedure TIBXConfigService.SetReserveSpace(Value: Boolean);
2036 begin
2037 SRB.Add(isc_action_svc_properties);
2038 AddDBNameToSRB;
2039 with SRB.Add(isc_spb_prp_reserve_space) do
2040 if Value then
2041 AsByte := isc_spb_prp_res
2042 else
2043 AsByte := isc_spb_prp_res_use_full;
2044 InternalServiceStart;
2045 WaitForServiceStop;
2046 end;
2047
2048 procedure TIBXConfigService.SetAsyncMode(Value: Boolean);
2049 begin
2050 SRB.Add(isc_action_svc_properties);
2051 AddDBNameToSRB;
2052 with SRB.Add(isc_spb_prp_write_mode) do
2053 if Value then
2054 AsByte := isc_spb_prp_wm_async
2055 else
2056 AsByte := isc_spb_prp_wm_sync;
2057 InternalServiceStart;
2058 WaitForServiceStop;
2059 end;
2060
2061 procedure TIBXConfigService.SetReadOnly(Value: Boolean);
2062 begin
2063 SRB.Add(isc_action_svc_properties);
2064 AddDBNameToSRB;
2065 with SRB.Add(isc_spb_prp_access_mode) do
2066 if Value then
2067 AsByte := isc_spb_prp_am_readonly
2068 else
2069 AsByte := isc_spb_prp_am_readwrite;
2070 InternalServiceStart;
2071 WaitForServiceStop;
2072 end;
2073
2074 procedure TIBXConfigService.SetNoLinger;
2075 begin
2076 SRB.Add(isc_action_svc_properties);
2077 AddDBNameToSRB;
2078 SRB.Add(isc_spb_options).AsInteger := isc_spb_prp_nolinger;
2079 InternalServiceStart;
2080 WaitForServiceStop;
2081 end;
2082
2083 { TIBXLogService }
2084
2085 procedure TIBXLogService.SetServiceStartOptions;
2086 begin
2087 SRB.Add(isc_action_svc_get_ib_log);
2088 end;
2089
2090 { TIBXControlAndQueryService }
2091
2092 function TIBXControlAndQueryService.GetNextLine: String;
2093 var
2094 i: Integer;
2095 begin
2096 Result := '';
2097 if (FEof = True) then
2098 Exit;
2099 if not FServiceStarted then
2100 IBError(ibxeServiceNotStarted,[nil]);
2101
2102 SRB.Add(isc_info_svc_line);
2103 InternalServiceQuery;
2104
2105 for i := 0 to FServiceQueryResults.Count - 1 do
2106 with FServiceQueryResults[i] do
2107 begin
2108 case getItemType of
2109 isc_info_svc_line:
2110 Result := AsString;
2111 else
2112 IBError(ibxeOutputParsingError, [getItemType]);
2113 end;
2114 end;
2115 FEof := Result = '';
2116 Result := Trim(Result);
2117 DoOnGetNextLine(Result);
2118 if FEof then
2119 FServiceStarted := false;
2120 end;
2121
2122 function TIBXControlAndQueryService.GetNextChunk: String;
2123 var
2124 i: Integer;
2125 begin
2126 if (FEof = True) then
2127 begin
2128 Result := '';
2129 exit;
2130 end;
2131 if not FServiceStarted then
2132 IBError(ibxeServiceNotStarted,[nil]);
2133
2134 SRB.Add(isc_info_svc_to_eof);
2135 InternalServiceQuery;
2136
2137 FEof := True;
2138 for i := 0 to FServiceQueryResults.Count - 1 do
2139 with FServiceQueryResults[i] do
2140 begin
2141 case getItemType of
2142 isc_info_svc_to_eof:
2143 Result := AsString;
2144
2145 isc_info_truncated:
2146 FEof := False;
2147 else
2148 IBError(ibxeOutputParsingError, [getItemType]);
2149 end;
2150 end;
2151 if FEof then
2152 FServiceStarted := false;
2153 end;
2154
2155 procedure TIBXControlAndQueryService.ServiceStart;
2156 begin
2157 FEof := false;
2158 FSendBytes := 0;
2159 inherited ServiceStart;
2160 FServiceStarted := true;
2161 end;
2162
2163 function TIBXControlAndQueryService.ReceiveNextChunk(stream: TStream): integer;
2164 var
2165 i: Integer;
2166 TimeOut: boolean;
2167 begin
2168 Result := 0;
2169 TimeOut := false;
2170 if (FEof = True) then
2171 Exit;
2172 if not FServiceStarted then
2173 IBError(ibxeServiceNotStarted,[nil]);
2174
2175 SQPB.Add(isc_info_svc_timeout).AsInteger := 1;
2176 SRB.Add(isc_info_svc_to_eof);
2177 InternalServiceQuery;
2178
2179 FEof := True;
2180 for i := 0 to FServiceQueryResults.Count - 1 do
2181 with FServiceQueryResults[i] do
2182 begin
2183 case getItemType of
2184 isc_info_svc_to_eof:
2185 begin
2186 Result := CopyTo(stream,0);
2187 FEof := (Result = 0) and not TimeOut;
2188 end;
2189
2190 isc_info_truncated:
2191 FEof := False;
2192
2193 isc_info_svc_timeout:
2194 begin
2195 FEof := False;
2196 TimeOut := true;
2197 end
2198
2199 else
2200 IBError(ibxeOutputParsingError, [getItemType]);
2201 end;
2202 end;
2203 if FEof then
2204 FServiceStarted := false;
2205 end;
2206
2207 function TIBXControlAndQueryService.SendNextChunk(stream: TStream;
2208 var line: String): integer;
2209 var
2210 i: Integer;
2211 begin
2212 Result := 0;
2213 line := '';
2214 if (FEof = True) then
2215 Exit;
2216
2217 if not FServiceStarted then
2218 IBError(ibxeServiceNotStarted,[nil]);
2219
2220 SRB.Add(isc_info_svc_line);
2221 SRB.Add(isc_info_svc_stdin);
2222
2223 SQPB.Add(isc_info_svc_timeout).AsInteger := 1;
2224 if FSendBytes > 0 then
2225 Result := SQPB.Add(isc_info_svc_line).CopyFrom(stream,FSendBytes);
2226 try
2227 InternalServiceQuery;
2228 except
2229 FSendBytes := 0;
2230 raise;
2231 end;
2232
2233 FSendBytes := 0;
2234 for i := 0 to FServiceQueryResults.Count - 1 do
2235 with FServiceQueryResults[i] do
2236 begin
2237 case getItemType of
2238 isc_info_svc_line:
2239 line := AsString;
2240
2241 isc_info_svc_stdin:
2242 FSendBytes := AsInteger;
2243
2244 isc_info_svc_timeout,
2245 isc_info_data_not_ready:
2246 {ignore};
2247 else
2248 IBError(ibxeOutputParsingError, [getItemType]);
2249 end;
2250 end;
2251 FEOF := (FSendBytes = 0) and (line = '');
2252 if FEof then
2253 FServiceStarted := false;
2254 end;
2255
2256 procedure TIBXControlAndQueryService.DoOnGetNextLine(Line: string);
2257 begin
2258 if assigned(FOnGetNextLine) then
2259 OnGetNextLine(self,Line);
2260 end;
2261
2262 procedure TIBXControlAndQueryService.OnBeforeDisconnect(
2263 Sender: TIBXServicesConnection);
2264 var i: integer;
2265 begin
2266 inherited OnBeforeDisconnect(Sender);
2267 for i := 0 to FDataSets.Count - 1 do
2268 TDataSet(FDataSets[i]).Active := false;
2269 end;
2270
2271 procedure TIBXControlAndQueryService.Notification(AComponent: TComponent;
2272 Operation: TOperation);
2273 begin
2274 inherited Notification(AComponent, Operation);
2275 if (Operation = opRemove) and (AComponent is TDataSet) then
2276 FDataSets.Remove(AComponent);
2277 end;
2278
2279 procedure TIBXControlAndQueryService.RegisterDataSet(aDataSet: TDataSet);
2280 begin
2281 if FDataSets.IndexOf(aDataset) = -1 then
2282 begin
2283 FDataSets.Add(aDataSet);
2284 FreeNotification(ADataSet);
2285 end;
2286 end;
2287
2288 procedure TIBXControlAndQueryService.UnRegisterDataSet(aDataSet: TDataSet);
2289 begin
2290 FDataSets.Remove(aDataSet);
2291 RemoveFreeNotification(aDataset);
2292 end;
2293
2294 constructor TIBXControlAndQueryService.Create(aOwner: TComponent);
2295 begin
2296 inherited Create(aOwner);
2297 FDataSets := TList.Create;
2298 end;
2299
2300 destructor TIBXControlAndQueryService.Destroy;
2301 begin
2302 inherited Destroy;
2303 if assigned(FDataSets) then FDataSets.Free;
2304 end;
2305
2306 procedure TIBXControlAndQueryService.Execute(OutputLog: TStrings);
2307 begin
2308 ServiceStart;
2309 try
2310 while not Eof do
2311 if OutputLog <> nil then
2312 OutputLog.Add(GetNextLine)
2313 else
2314 GetNextLine;
2315 finally
2316 WaitForServiceStop; {flush}
2317 end;
2318 end;
2319
2320 { TIBXControlService }
2321
2322 function TIBXControlService.GetIsServiceRunning: Boolean;
2323 begin
2324 Result := (ServicesConnection <> nil) and (ServicesConnection.Connected);
2325 if Result then
2326 begin
2327 SRB.Add(isc_info_svc_running);
2328 InternalServiceQuery(false);
2329 Result := (FServiceQueryResults <> nil) and (FServiceQueryResults.Count > 0) and
2330 (FServiceQueryResults[0].getItemType = isc_info_svc_running) and
2331 (FServiceQueryResults[0].AsInteger = 1);
2332 end;
2333 end;
2334
2335 procedure TIBXControlService.HandleSecContextErr;
2336 begin
2337 FAction := scRaiseError;
2338 if MainThreadID = TThread.CurrentThread.ThreadID then
2339 CallSecContextException
2340 else
2341 TThread.Synchronize(TThread.CurrentThread,@CallSecContextException);
2342 end;
2343
2344 procedure TIBXControlService.CallSecContextException;
2345 begin
2346 ServicesConnection.HandleSecContextException(self,FAction)
2347 end;
2348
2349 procedure TIBXControlService.SetDatabaseName(AValue: string);
2350 begin
2351 if FDatabaseName = AValue then Exit;
2352 CheckServiceNotRunning;
2353 FDatabaseName := AValue;
2354 DatabaseNameChanged;
2355 end;
2356
2357 procedure TIBXControlService.DatabaseNameChanged;
2358 begin
2359 //Do nothing
2360 end;
2361
2362 procedure TIBXControlService.OnAfterConnect(Sender: TIBXServicesConnection;
2363 aDatabaseName: string);
2364 begin
2365 inherited OnAfterConnect(Sender,aDatabaseName);
2366 if aDatabaseName <> '' then
2367 DatabaseName := aDatabaseName;
2368 end;
2369
2370 procedure TIBXControlService.AddDBNameToSRB;
2371 begin
2372 if FDatabaseName = '' then
2373 IBError(ibxeStartParamsError, [nil]);
2374 SRB.Add(isc_spb_dbname).AsString := FDatabaseName;
2375 end;
2376
2377 procedure TIBXControlService.CheckServiceNotRunning;
2378 begin
2379 if IsServiceRunning then
2380 IBError(ibxeServiceRunning,[nil]);
2381 end;
2382
2383 procedure TIBXControlService.InternalServiceStart;
2384 var done: boolean;
2385 theError: EIBInterBaseError;
2386 begin
2387 if SRB = nil then
2388 IBError(ibxeStartParamsError, [nil]);
2389
2390 FLastStartSRB := SRB;
2391 done := false;
2392 theError := nil;
2393 try
2394 repeat
2395 CheckActive;
2396 done := ServicesConnection.ServiceIntf.Start(SRB,false);
2397 if not done then
2398 begin
2399 theError := EIBInterBaseError.Create(ServicesConnection.GetFirebirdAPI.GetStatus);
2400 if theError.IBErrorCode = isc_sec_context then
2401 begin
2402 HandleSecContextErr;
2403 if FAction = scRaiseError then
2404 raise theError
2405 else
2406 begin
2407 theError.Free;
2408 FSRB := FLastStartSRB;
2409 end;
2410 end
2411 else
2412 raise theError;
2413 end;
2414 until done;
2415 finally
2416 FSRB := nil;
2417 end;
2418 if tfService in ServicesConnection.TraceFlags then
2419 MonitorHook.ServiceStart(Self);
2420 end;
2421
2422 procedure TIBXControlService.DoServiceQuery;
2423 var done: boolean;
2424 LastSRB: ISRB;
2425 LastSQPB: ISQPB;
2426 theError: EIBInterBaseError;
2427 begin
2428 done := false;
2429 theError := nil;
2430 repeat
2431 LastSRB := SRB;
2432 LastSQPB := SQPB;
2433 inherited DoServiceQuery;
2434 done := FServiceQueryResults <> nil;
2435 if not done then
2436 begin
2437 if ServicesConnection.GetFirebirdAPI.GetStatus.GetIBErrorCode = isc_sec_context then
2438 begin
2439 theError := EIBInterBaseError.Create(ServicesConnection.GetFirebirdAPI.GetStatus); {save exception}
2440 HandleSecContextErr;
2441 if FAction = scReconnect then
2442 begin
2443 {Restart service}
2444 theError.Free;
2445 FSRB := FLastStartSRB;
2446 InternalServiceStart;
2447 FSRB := LastSRB;
2448 FSQPB := LastSQPB;
2449 end
2450 else
2451 raise theError;
2452 end
2453 else
2454 break; {Let the caller handle the error}
2455 end;
2456 until done;
2457 end;
2458
2459 procedure TIBXControlService.SetServiceStartOptions;
2460 begin
2461 //Do nothing
2462 end;
2463
2464 procedure TIBXControlService.ServiceStart;
2465 begin
2466 CheckActive;
2467 CheckServiceNotRunning;
2468 SetServiceStartOptions;
2469 InternalServiceStart;
2470 end;
2471
2472 procedure TIBXControlService.WaitForServiceStop(AbortAfter: integer);
2473 var WaitUntil: TDateTime;
2474 begin
2475 WaitUntil := Now + EncodeTime(0,0,AbortAfter,0);
2476 while IsServiceRunning do
2477 begin
2478 sleep(500);
2479 if Now > WaitUntil then Exit;
2480 end;
2481 end;
2482
2483 procedure TIBXControlService.Assign(Source: TPersistent);
2484 begin
2485 inherited Assign(Source);
2486 if Source is TIBXControlService then
2487 DatabaseName := TIBXControlService(Source).DatabaseName;
2488 end;
2489
2490 { TConfigParams }
2491
2492 constructor TConfigParams.Create;
2493 begin
2494 ConfigFileData := TConfigFileData.Create;
2495 ConfigFileParams := nil;
2496 end;
2497
2498 destructor TConfigParams.Destroy;
2499 begin
2500 ConfigFileData.Free;
2501 ConfigFileParams := nil;
2502 inherited Destroy;
2503 end;
2504
2505 { TConfigFileData }
2506
2507 constructor TConfigFileData.Create;
2508 begin
2509 ConfigFileValue := nil;
2510 ConfigFileKey := nil;
2511 end;
2512
2513 destructor TConfigFileData.Destroy;
2514 begin
2515 ConfigFileValue := nil;
2516 ConfigFileKey := nil;
2517 inherited Destroy;
2518 end;
2519
2520 { TDatabaseInfo }
2521
2522 constructor TDatabaseInfo.Create;
2523 begin
2524 DbName := nil;
2525 end;
2526
2527 destructor TDatabaseInfo.Destroy;
2528 begin
2529 DbName := nil;
2530 inherited Destroy;
2531 end;
2532
2533 { TIBXServerProperties }
2534
2535 function TIBXServerProperties.GetConfigParams: TConfigParams;
2536 var i, j: Integer;
2537 begin
2538 CheckActive;
2539 if FConfigParams = nil then
2540 begin
2541 SRB.Add(isc_info_svc_get_config);
2542 SRB.Add(isc_info_svc_get_env);
2543 SRB.Add(isc_info_svc_get_env_lock);
2544 SRB.Add(isc_info_svc_get_env_msg);
2545 SRB.Add(isc_info_svc_user_dbpath);
2546
2547 InternalServiceQuery;
2548
2549 FConfigParams := TConfigParams.Create;
2550 for i := 0 to FServiceQueryResults.Count - 1 do
2551 with FServiceQueryResults[i] do
2552 begin
2553 case getItemType of
2554 isc_info_svc_get_config:
2555 begin
2556 SetLength (FConfigParams.ConfigFileData.ConfigFileValue, Count);
2557 SetLength (FConfigParams.ConfigFileData.ConfigFileKey, Count);
2558
2559 for j := 0 to Count - 1 do
2560 begin
2561 FConfigParams.ConfigFileData.ConfigFileKey[j] := Items[j].getItemType;
2562 FConfigParams.ConfigFileData.ConfigFileValue[j] := Items[j].AsInteger;
2563 end;
2564 end;
2565
2566 isc_info_svc_get_env:
2567 FConfigParams.BaseLocation := AsString;
2568
2569 isc_info_svc_get_env_lock:
2570 FConfigParams.LockFileLocation := AsString;
2571
2572 isc_info_svc_get_env_msg:
2573 FConfigParams.MessageFileLocation := AsString;
2574
2575 isc_info_svc_user_dbpath:
2576 FConfigParams.SecurityDatabaseLocation := AsString;
2577
2578 else
2579 IBError(ibxeOutputParsingError, [getItemType]);
2580 end;
2581 end;
2582 end;
2583 Result := FConfigParams;
2584 end;
2585
2586 function TIBXServerProperties.GetDatabaseInfo: TDatabaseInfo;
2587 var i,j: Integer;
2588 begin
2589 if FDatabaseInfo = nil then
2590 begin
2591 SRB.Add(isc_info_svc_svr_db_info);
2592 InternalServiceQuery;
2593
2594 FDatabaseInfo := TDatabaseInfo.Create;
2595 SetLength(FDatabaseInfo.DbName,0);
2596 for i := 0 to FServiceQueryResults.Count - 1 do
2597 with FServiceQueryResults[i] do
2598 begin
2599 case getItemType of
2600 isc_info_svc_svr_db_info:
2601 for j := 0 to FServiceQueryResults[i].Count - 1 do
2602 with FServiceQueryResults[i][j] do
2603 case getItemType of
2604 isc_spb_num_att:
2605 FDatabaseInfo.NoOfAttachments := AsInteger;
2606
2607 isc_spb_num_db:
2608 FDatabaseInfo.NoOfDatabases := AsInteger;
2609
2610 isc_spb_dbname:
2611 begin
2612 SetLength(FDatabaseInfo.DbName,length(FDatabaseInfo.DbName)+1);
2613 FDatabaseInfo.DbName[length(FDatabaseInfo.DbName)-1] := AsString;
2614 end;
2615 else
2616 IBError(ibxeOutputParsingError, [getItemType]);
2617 end;
2618 else
2619 IBError(ibxeOutputParsingError, [getItemType]);
2620 end;
2621 end;
2622 end;
2623 Result := FDatabaseInfo;
2624 end;
2625
2626 function TIBXServerProperties.GetVersionInfo: TVersionInfo;
2627 var i : Integer;
2628 begin
2629 if FVersionInfo = nil then
2630 begin
2631 SRB.Add(isc_info_svc_version);
2632 SRB.Add(isc_info_svc_server_version);
2633 SRB.Add(isc_info_svc_implementation);
2634 InternalServiceQuery;
2635
2636 FVersionInfo := TVersionInfo.Create;
2637 for i := 0 to FServiceQueryResults.Count - 1 do
2638 with FServiceQueryResults[i] do
2639 begin
2640 case getItemType of
2641 isc_info_svc_version:
2642 FVersionInfo.ServiceVersion := AsInteger;
2643 isc_info_svc_server_version:
2644 FVersionInfo.ServerVersion := AsString;
2645 isc_info_svc_implementation:
2646 FVersionInfo.ServerImplementation := AsString;
2647 else
2648 IBError(ibxeOutputParsingError, [getItemType]);
2649 end;
2650 end;
2651 end;
2652 Result := FVersionInfo;
2653 end;
2654
2655 procedure TIBXServerProperties.Clear;
2656 begin
2657 inherited;
2658 if assigned(FDatabaseInfo) then FreeAndNil(FDatabaseInfo);
2659 if assigned(FVersionInfo) then FreeAndNil(FVersionInfo);
2660 if assigned(FConfigParams) then FreeAndNil(FConfigParams);
2661 end;
2662
2663 { TIBXCustomService }
2664
2665 procedure TIBXCustomService.CheckActive;
2666 begin
2667 if ServicesConnection = nil then
2668 IBError(ibxeServiceActive,[nil]);
2669 ServicesConnection.CheckActive;
2670 end;
2671
2672 function TIBXCustomService.GetSQPB: ISQPB;
2673 begin
2674 CheckActive;
2675 if FSQPB = nil then
2676 FSQPB := ServicesConnection.ServiceIntf.AllocateSQPB;
2677 Result := FSQPB;
2678 end;
2679
2680 function TIBXCustomService.GetSRB: ISRB;
2681 begin
2682 CheckActive;
2683 if FSRB = nil then
2684 FSRB := ServicesConnection.ServiceIntf.AllocateSRB;
2685 Result := FSRB;
2686 end;
2687
2688 procedure TIBXCustomService.SetServicesConnection(AValue: TIBXServicesConnection
2689 );
2690 begin
2691 if FServicesConnection = AValue then Exit;
2692 if FServicesConnection <> nil then
2693 begin
2694 FServicesConnection.UnRegisterIntf(self);
2695 RemoveFreeNotification(FServicesConnection);
2696 end;
2697 Clear;
2698 FServicesConnection := AValue;
2699 if FServicesConnection <> nil then
2700 begin
2701 FServicesConnection.RegisterIntf(self);
2702 FreeNotification(FServicesConnection);
2703 end;
2704 end;
2705
2706 procedure TIBXCustomService.OnBeforeDisconnect(Sender: TIBXServicesConnection);
2707 begin
2708 Clear;
2709 end;
2710
2711 procedure TIBXCustomService.InternalServiceQuery(RaiseExceptionOnError: boolean
2712 );
2713 begin
2714 CheckActive;
2715 try
2716 FServiceQueryResults := nil;
2717 DoServiceQuery;
2718 if (FServiceQueryResults = nil) and RaiseExceptionOnError then
2719 raise EIBInterBaseError.Create(ServicesConnection.GetFirebirdAPI.GetStatus);
2720 finally
2721 FSQPB := nil;
2722 FSRB := nil;
2723 end;
2724 if tfService in ServicesConnection.TraceFlags then
2725 MonitorHook.ServiceQuery(Self);
2726 end;
2727
2728 procedure TIBXCustomService.DoServiceQuery;
2729 begin
2730 FServiceQueryResults := ServicesConnection.ServiceIntf.Query(FSQPB,FSRB,false);
2731 end;
2732
2733 procedure TIBXCustomService.Notification(AComponent: TComponent;
2734 Operation: TOperation);
2735 begin
2736 inherited Notification(AComponent, Operation);
2737 if (Operation = opRemove) and (AComponent = ServicesConnection) then
2738 ServicesConnection := nil;
2739 end;
2740
2741 constructor TIBXCustomService.Create(AOwner: TComponent);
2742 begin
2743 inherited Create(AOwner);
2744 FSRB := nil;
2745 FServiceQueryResults := nil;
2746 FSQPB := nil;
2747 end;
2748
2749 destructor TIBXCustomService.Destroy;
2750 begin
2751 if ServicesConnection <> nil then
2752 begin
2753 OnBeforeDisconnect(ServicesConnection);
2754 ServicesConnection := nil;
2755 end;
2756 inherited Destroy;
2757 end;
2758
2759 procedure TIBXCustomService.Assign(Source: TPersistent);
2760 begin
2761 if Source is TIBXCustomService then
2762 ServicesConnection := TIBXCustomService(Source).ServicesConnection;
2763 end;
2764
2765 procedure TIBXCustomService.Clear;
2766 begin
2767 FSRB := nil;
2768 FServiceQueryResults := nil;
2769 FSQPB := nil;
2770 end;
2771
2772 procedure TIBXCustomService.OnAfterConnect(Sender: TIBXServicesConnection;
2773 aDatabaseName: string);
2774 begin
2775 //Do nothing
2776 end;
2777
2778 { TIBXServicesConnection }
2779
2780 procedure TIBXServicesConnection.SetParams(AValue: TStrings);
2781 begin
2782 FParams.Assign(AValue);
2783 end;
2784
2785 procedure TIBXServicesConnection.SetPortNo(AValue: string);
2786 begin
2787 if FPortNo = AValue then Exit;
2788 Connected := false;
2789 FPortNo := AValue;
2790 FConnectString := MakeConnectString(FServerName,'service_mgr',FProtocol,FPortNo);
2791 end;
2792
2793 procedure TIBXServicesConnection.CheckActive;
2794 begin
2795 if StreamedConnected and (not Connected) then
2796 Loaded;
2797 if FService = nil then
2798 IBError(ibxeServiceActive, [nil]);
2799 end;
2800
2801 procedure TIBXServicesConnection.CheckInactive;
2802 begin
2803 if FService <> nil then
2804 IBError(ibxeServiceInActive, [nil]);
2805 end;
2806
2807 procedure TIBXServicesConnection.CheckServerName;
2808 begin
2809 if (FServerName = '') and (FProtocol <> Local) then
2810 IBError(ibxeServerNameMissing, [nil]);
2811 end;
2812
2813 {
2814 * GenerateSPB -
2815 * Given a string containing a textual representation
2816 * of the Service parameters, generate a service
2817 * parameter buffer, and return it .
2818 }
2819 function TIBXServicesConnection.GenerateSPB(sl: TStrings): ISPB;
2820 var
2821 i, j: integer;
2822 SPBServerVal: UShort;
2823 param_name, param_value: String;
2824 begin
2825 { The SPB is initially empty, with the exception that
2826 the SPB version must be the first byte of the string.
2827 }
2828 Result := FirebirdAPI.AllocateSPB;
2829
2830 { Iterate through the textual service parameters, constructing
2831 a SPB on-the-fly }
2832 for i := 0 to sl.Count - 1 do
2833 begin
2834 { Get the parameter's name and value from the list,
2835 and make sure that the name is all lowercase with
2836 no leading 'isc_spb_' prefix }
2837 if (Trim(sl.Names[i]) = '') then continue;
2838 param_name := LowerCase(sl.Names[i]); {mbcs ok}
2839 param_value := sl.ValueFromIndex[i];
2840 if (Pos(SPBPrefix, param_name) = 1) then {mbcs ok}
2841 Delete(param_name, 1, Length(SPBPrefix));
2842 { We want to translate the parameter name to some integer
2843 value. We do this by scanning through a list of known
2844 service parameter names (SPBConstantNames, defined above). }
2845 SPBServerVal := 0;
2846 { Find the parameter }
2847 for j := 1 to isc_spb_last_spb_constant do
2848 if (param_name = SPBConstantNames[j]) then
2849 begin
2850 SPBServerVal := SPBConstantValues[j];
2851 break;
2852 end;
2853 case SPBServerVal of
2854 isc_spb_user_name,
2855 isc_spb_password,
2856 isc_spb_sql_role_name,
2857 isc_spb_expected_db:
2858 Result.Add(SPBServerVal).AsString := param_value;
2859 else
2860 begin
2861 if GetSPBConstName(SPBServerVal) <> '' then
2862 IBError(ibxeSPBConstantNotSupported,
2863 [GetSPBConstName(SPBServerVal)])
2864 else
2865 IBError(ibxeSPBConstantUnknown, [SPBServerVal]);
2866 end;
2867 end;
2868 end;
2869 if FConfigOverrides.Count > 0 then
2870 Result.Add(isc_spb_config).SetAsString(FConfigOverrides.Text);
2871 end;
2872
2873 function TIBXServicesConnection.GetFirebirdAPI: IFirebirdAPI;
2874 var fblib: IFirebirdLibrary;
2875 begin
2876 if FFirebirdAPI = nil then
2877 begin
2878 if (csDesigning in ComponentState) or (Trim(FFirebirdLibraryPathName) = '') then
2879 FFirebirdAPI := IB.FirebirdAPI
2880 else
2881 begin
2882 fblib := IB.LoadFBLibrary(FFirebirdLibraryPathName);
2883 if assigned(fblib) then
2884 FFirebirdAPI := fblib.GetFirebirdAPI;
2885 end;
2886 end;
2887 Result := FFirebirdAPI;
2888 end;
2889
2890 function TIBXServicesConnection.GetServerVersionNo(index: integer): integer;
2891 begin
2892 CheckActive;
2893 if (index >= Low(FServerVersionNo)) and (index <= High(FServerVersionNo)) then
2894 Result := FServerVersionNo[index]
2895 else
2896 IBError(ibxeInfoBufferIndexError,[index]);
2897 end;
2898
2899 function TIBXServicesConnection.GetSPBConstName(action: byte): string;
2900 var i: integer;
2901 begin
2902 Result := '';
2903 for i := Low(SPBConstantValues) to High(SPBConstantValues) do
2904 if SPBConstantValues[i] = action then
2905 begin
2906 Result := SPBConstantNames[i];
2907 break;
2908 end;
2909 end;
2910
2911 function TIBXServicesConnection.GetWireCompression: boolean;
2912 begin
2913 Result := CompareText(FConfigOverrides.Values['WireCompression'],'true') = 0;
2914 end;
2915
2916 procedure TIBXServicesConnection.HandleException(Sender: TObject);
2917 var aParent: TComponent;
2918 begin
2919 aParent := Owner;
2920 while aParent <> nil do
2921 begin
2922 if aParent is TCustomApplication then
2923 begin
2924 TCustomApplication(aParent).HandleException(Sender);
2925 Exit;
2926 end;
2927 aParent := aParent.Owner;
2928 end;
2929 SysUtils.ShowException(ExceptObject,ExceptAddr);
2930 end;
2931
2932 procedure TIBXServicesConnection.HandleSecContextException(
2933 Sender: TIBXControlService; var action: TSecContextAction);
2934 var OldServiceIntf: IServiceManager;
2935 begin
2936 action := scRaiseError;
2937 if assigned(FOnSecurityContextException) then
2938 OnSecurityContextException(self,action);
2939
2940 if action = scReconnect then
2941 begin
2942 FExpectedDB := Sender.DatabaseName;
2943 try
2944 OldServiceIntf := FService;
2945 Connected := false;
2946 while not Connected do
2947 begin
2948 try
2949 Connected := true;
2950 except
2951 on E:EIBClientError do
2952 begin
2953 action := scRaiseError;
2954 FService := OldServiceIntf;
2955 break;
2956 end;
2957 else
2958 HandleException(self);
2959 end;
2960 end;
2961 finally
2962 FExpectedDB := '';
2963 end;
2964 end;
2965 end;
2966
2967 function TIBXServicesConnection.Login(var aServerName: string;
2968 LoginParams: TStrings): Boolean;
2969 var
2970 IndexOfUser, IndexOfPassword: Integer;
2971 Username, Password: String;
2972 ExtLoginParams: TStrings;
2973 begin
2974 if Assigned(FOnLogin) then
2975 begin
2976 Result := True;
2977 ExtLoginParams := TStringList.Create;
2978 try
2979 ExtLoginParams.Assign(Params);
2980 FOnLogin(Self, aServerName, ExtLoginParams);
2981 LoginParams.Assign (ExtLoginParams);
2982 finally
2983 ExtLoginParams.Free;
2984 end;
2985 end
2986 else
2987 if assigned(IBGUIInterface) then
2988 begin
2989 IndexOfUser := LoginParams.IndexOfName(GetSPBConstName(isc_spb_user_name));
2990 if IndexOfUser <> -1 then
2991 Username := LoginParams.ValueFromIndex[IndexOfUser]
2992 else
2993 UserName := '';
2994 IndexOfPassword :=LoginParams.IndexOfName(GetSPBConstName(isc_spb_password));
2995 if IndexOfPassword <> -1 then
2996 Password := LoginParams.ValueFromIndex[IndexOfPassword]
2997 else
2998 Password := '';
2999
3000 result := IBGUIInterface.ServerLoginDialog(aServerName, Username, Password);
3001 if result then
3002 begin
3003 LoginParams.Values[GetSPBConstName(isc_spb_user_name)] := UserName;
3004 LoginParams.Values[GetSPBConstName(isc_spb_password)] := Password;
3005 end
3006 end
3007 else
3008 IBError(ibxeNoLoginDialog,[]);
3009 end;
3010
3011 procedure TIBXServicesConnection.ParseServerVersionNo;
3012 var Req: ISRB;
3013 Results: IServiceQueryResults;
3014 RegexObj: TRegExpr;
3015 s: string;
3016 begin
3017 Req := FService.AllocateSRB;
3018 Req.Add(isc_info_svc_server_version);
3019 Results := FService.Query(nil,Req);
3020 if (Results.Count = 1) and (Results[0].getItemType = isc_info_svc_server_version) then
3021 RegexObj := TRegExpr.Create;
3022 try
3023 {extact database file spec}
3024 RegexObj.ModifierG := false; {turn off greedy matches}
3025 RegexObj.Expression := '[A-Z][A-Z]-V([0-9]+)\.([0-9]+)\.([0-9]+)\.([0-9]+) .*';
3026 s := Results[0].AsString;
3027 if RegexObj.Exec(s) then
3028 begin
3029 FServerVersionNo[1] := StrToInt(RegexObj.Match[1]);
3030 FServerVersionNo[2] := StrToInt(RegexObj.Match[2]);
3031 FServerVersionNo[3] := StrToInt(RegexObj.Match[3]);
3032 FServerVersionNo[4] := StrToInt(RegexObj.Match[4]);
3033 end;
3034 finally
3035 RegexObj.Free;
3036 end;
3037 end;
3038
3039 procedure TIBXServicesConnection.ParamsChanging(Sender: TObject);
3040 begin
3041 CheckInactive;
3042 end;
3043
3044 procedure TIBXServicesConnection.SetConfigOverrides(AValue: TStrings);
3045 begin
3046 if FConfigOverrides = AValue then Exit;
3047 FConfigOverrides.Assign(AValue);
3048 end;
3049
3050 procedure TIBXServicesConnection.SetConnectString(AValue: string);
3051 var aServiceName: AnsiString;
3052 aProtocol: TProtocolAll;
3053 begin
3054 if FConnectString = AValue then Exit;
3055 Connected := false;
3056 if not ParseConnectString(AValue,FServerName,aServiceName,aProtocol,FPortNo)
3057 or (aServiceName <> 'service_mgr') or (aProtocol = unknownProtocol) then
3058 IBError(ibxeBadConnectString, [nil]);
3059 FConnectString := AValue;
3060 FProtocol := TProtocol(aProtocol);
3061 end;
3062
3063 procedure TIBXServicesConnection.SetFirebirdLibraryPathName(AValue: TIBFileName
3064 );
3065 begin
3066 if FFirebirdLibraryPathName = AValue then Exit;
3067 FFirebirdLibraryPathName := AValue;
3068 Connected := false;
3069 FFirebirdAPI := nil;
3070 end;
3071
3072 procedure TIBXServicesConnection.SetProtocol(AValue: TProtocol);
3073 begin
3074 if FProtocol = AValue then Exit;
3075 Connected := false;
3076 FProtocol := AValue;
3077 FConnectString := MakeConnectString(FServerName,'service_mgr',FProtocol,FPortNo);
3078 end;
3079
3080 procedure TIBXServicesConnection.SetServerName(AValue: string);
3081 begin
3082 if FServerName = AValue then Exit;
3083 Connected := false;
3084 FServerName := AValue;
3085 FConnectString := MakeConnectString(FServerName,'service_mgr',FProtocol,FPortNo);
3086 end;
3087
3088 procedure TIBXServicesConnection.SetServiceIntf(AValue: IServiceManager);
3089 begin
3090 SetServiceIntf(AValue,nil);
3091 end;
3092
3093 procedure TIBXServicesConnection.SetWireCompression(AValue: boolean);
3094 var Index: integer;
3095 begin
3096 if AValue then
3097 FConfigOverrides.Values['WireCompression'] := 'true'
3098 else
3099 begin
3100 Index := FConfigOverrides.IndexOfName('WireCompression');
3101 if Index <> -1 then
3102 FConfigOverrides.Delete(Index);
3103 end;
3104 end;
3105
3106 procedure TIBXServicesConnection.DoConnect;
3107
3108 var aServerName: string;
3109 aProtocol: TProtocolAll;
3110 aPortNo: string;
3111 aDBName: string;
3112 TempSvcParams: TStrings;
3113 SPB: ISPB;
3114 PW: ISPBItem;
3115 i: integer;
3116 begin
3117 CheckInactive;
3118 CheckServerName;
3119
3120 aServerName := FServerName;
3121 aProtocol := FProtocol;
3122 aPortNo := PortNo;
3123 aDBName := '';
3124
3125 if FDatabase <> nil then
3126 {Get Connect String from Database Connect String}
3127 begin
3128 FFirebirdAPI := FDatabase.FirebirdAPI;
3129 FConfigOverrides.Assign(FDatabase.ConfigOverrides);
3130 if ParseConnectString(FDatabase.Attachment.GetConnectString,aServerName,aDBName,aProtocol,aPortNo) and
3131 (aProtocol = Local) and
3132 (FDatabase.Attachment.GetRemoteProtocol <> '') then
3133 begin
3134 {Use loopback if database does not use embedded server}
3135 aServerName := 'Localhost';
3136 aProtocol := TCP;
3137 end;
3138 end;
3139
3140 TempSvcParams := TStringList.Create;
3141 try
3142 TempSvcParams.Assign(FParams);
3143 if LoginPrompt and not Login(aServerName,TempSvcParams) then
3144 IBError(ibxeOperationCancelled, [nil]);
3145
3146 {Use of non-default security database}
3147 if FExpectedDB <> '' then {set when handling an isc_sec_context exception}
3148 TempSvcParams.Values['expected_db'] := FExpectedDB
3149 else
3150 if (FDatabase <> nil) and (FDatabase.Attachment.GetSecurityDatabase <> 'Default')
3151 and (aDBName <> '') then
3152 {Connect using database using non-default security database}
3153 TempSvcParams.Values['expected_db'] := aDBName;
3154 SPB := GenerateSPB(TempSvcParams);
3155 finally
3156 TempSvcParams.Free;
3157 end;
3158
3159 FService := FirebirdAPI.GetServiceManager(aServerName,aPortNo,aProtocol,SPB);
3160 FServername := aServerName;
3161 FProtocol := aProtocol;
3162 FPortNo := aPortNo;
3163 FConnectString := MakeConnectString(FServerName,'service_mgr',FProtocol,FPortNo);
3164 PW := FService.getSPB.Find(isc_spb_password);
3165 if PW <> nil then PW.AsString := 'xxxxxxxx'; {Hide password}
3166
3167 ParseServerVersionNo;
3168
3169 for i := low(FIBXServices) to high(FIBXServices) do
3170 FIBXServices[i].OnAfterConnect(self,aDBName);
3171
3172 if tfService in TraceFlags then
3173 MonitorHook.ServiceAttach(Self);
3174 end;
3175
3176 procedure TIBXServicesConnection.DoDisconnect;
3177 var i: integer;
3178 begin
3179 CheckActive;
3180 for i := 0 to Length(FIBXServices) - 1 do
3181 FIBXServices[i].OnBeforeDisconnect(self);
3182 FService := nil;
3183 if tfService in TraceFlags then
3184 MonitorHook.ServiceDetach(Self);
3185 end;
3186
3187 function TIBXServicesConnection.GetConnected: Boolean;
3188 begin
3189 Result := FService <> nil;
3190 end;
3191
3192 function TIBXServicesConnection.GetDataset(Index: longint): TDataset;
3193 begin
3194 Result := inherited GetDataset(Index);
3195 end;
3196
3197 function TIBXServicesConnection.GetDataSetCount: Longint;
3198 begin
3199 Result := inherited GetDataSetCount;
3200 end;
3201
3202 procedure TIBXServicesConnection.ReadState(Reader: TReader);
3203 begin
3204 FParams.Clear;
3205 inherited ReadState(Reader);
3206 end;
3207
3208 procedure TIBXServicesConnection.RegisterIntf(intf: IIBXServicesClient);
3209 begin
3210 Setlength(FIBXServices,Length(FIBXServices) + 1);
3211 FIBXServices[Length(FIBXServices)-1] := intf;
3212 end;
3213
3214 procedure TIBXServicesConnection.UnRegisterIntf(intf: IIBXServicesClient);
3215 var i, j: integer;
3216 begin
3217 for i := length(FIBXServices) - 1 downto 0 do
3218 if FIBXServices[i] = intf then
3219 begin
3220 for j := i + 1 to length(FIBXServices) - 1 do
3221 FIBXServices[j-1] := FIBXServices[j];
3222 SetLength(FIBXServices,Length(FIBXServices)-1);
3223 break;
3224 end;
3225 end;
3226
3227 constructor TIBXServicesConnection.Create(AOwner: TComponent);
3228 begin
3229 inherited Create(AOwner);
3230 FServerName := '';
3231 FParams := TStringList.Create;
3232 FConfigOverrides := TStringList.Create;
3233 Setlength(FIBXServices,0);
3234 TStringList(FParams).OnChanging := @ParamsChanging;
3235 FService := nil;
3236 FProtocol := Local;
3237 LoginPrompt := true;
3238 if (AOwner <> nil) and
3239 (AOwner is TCustomApplication) and
3240 TCustomApplication(AOwner).ConsoleApplication then
3241 LoginPrompt := false;
3242 end;
3243
3244 destructor TIBXServicesConnection.Destroy;
3245 begin
3246 inherited Destroy;
3247 Setlength(FIBXServices,0);
3248 if assigned(FParams) then FParams.Free;
3249 if assigned (FConfigOverrides) then FConfigOverrides.Free;
3250 FFirebirdAPI := nil;
3251 end;
3252
3253 procedure TIBXServicesConnection.ConnectUsing(aDatabase: TIBDatabase);
3254 begin
3255 if not aDatabase.Connected then
3256 IBError(ibxeDatabaseNotConnected,[nil]);
3257 Connected := false;
3258 FDatabase := aDatabase;
3259 try
3260 Connected := true;
3261 finally
3262 FDatabase := nil;
3263 end;
3264 end;
3265
3266 procedure TIBXServicesConnection.SetDBParams(DBParams: TStrings);
3267 var i: integer;
3268 j: integer;
3269 k: integer;
3270 ParamName: string;
3271 begin
3272 Params.Clear;
3273 for i := 0 to DBParams.Count - 1 do
3274 begin
3275 ParamName := DBParams[i];
3276 k := Pos('=',ParamName);
3277 if k > 0 then system.Delete(ParamName,k,Length(ParamName)-k+1);
3278 for j := 1 to isc_spb_last_spb_constant do
3279 if CompareText(ParamName,SPBConstantNames[j]) = 0 then
3280 begin
3281 Params.Add(DBParams[i]);
3282 break;
3283 end;
3284 end;
3285 end;
3286
3287 procedure TIBXServicesConnection.SetServiceIntf(aServiceIntf: IServiceManager;
3288 aDatabase: TIBDatabase);
3289 var i: integer;
3290 var aServerName,aDatabaseName: AnsiString;
3291 aProtocol: TProtocolAll;
3292 aPortNo: AnsiString;
3293 begin
3294 if FService = aServiceIntf then Exit;
3295 if FService <> nil then
3296 begin
3297 if Assigned(BeforeDisconnect) then
3298 BeforeDisconnect(self);
3299 for i := 0 to Length(FIBXServices) - 1 do
3300 FIBXServices[i].OnBeforeDisconnect(self);
3301 FService := nil;
3302 if Assigned(AfterDisconnect) then
3303 AfterDisconnect(self);
3304 end;
3305 FFirebirdAPI := nil;
3306 if aServiceIntf <> nil then
3307 begin
3308 if Assigned(BeforeConnect) then
3309 BeforeConnect(self);
3310 FService := aServiceIntf;
3311 ParseServerVersionNo;
3312 FServername := FService.getServerName;
3313 FProtocol := FService.getProtocol;
3314 FPortNo := FService.getPortNo;
3315 FConnectString := MakeConnectString(FServerName,'service_mgr',FProtocol,FPortNo);
3316 if FFirebirdLibraryPathName <> '' then
3317 FFirebirdLibraryPathName := FService.getFirebirdAPI.GetFBLibrary.GetLibraryFilePath;
3318 if aDatabase <> nil then
3319 begin
3320 if ParseConnectString(aDatabase.DatabaseName,aServerName,aDatabaseName,aProtocol,aPortNo) then
3321 for i := low(FIBXServices) to high(FIBXServices) do
3322 FIBXServices[i].OnAfterConnect(self,aDatabaseName);
3323 end;
3324 if Assigned(AfterConnect) then
3325 AfterConnect(self);
3326 end;
3327 end;
3328
3329 end.
3330