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