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, 6 months ago) by tony
File size: 89781 byte(s)
Log Message:
Fixes Merged
Line File contents
1 {************************************************************************}
2 { }
3 { Borland Delphi Visual Component Library }
4 { InterBase Express core components }
5 { }
6 { Copyright (c) 1998-2000 Inprise Corporation }
7 { }
8 { InterBase Express is based in part on the product }
9 { Free IB Components, written by Gregory H. Deatz for }
10 { Hoagland, Longo, Moran, Dunst & Doukas Company. }
11 { Free IB Components is used under license. }
12 { }
13 { The contents of this file are subject to the InterBase }
14 { Public License Version 1.0 (the "License"); you may not }
15 { use this file except in compliance with the License. You }
16 { may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17 { Software distributed under the License is distributed on }
18 { an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
19 { express or implied. See the License for the specific language }
20 { governing rights and limitations under the License. }
21 { The Original Code was created by InterBase Software Corporation }
22 { and its successors. }
23 { Portions created by Inprise Corporation are Copyright (C) Inprise }
24 { Corporation. All Rights Reserved. }
25 { Contributor(s): Jeff Overcash }
26 { }
27 { IBX For Lazarus (Firebird Express) }
28 { Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29 { Portions created by MWA Software are copyright McCallum Whyman }
30 { Associates Ltd 2011 - 2018 }
31 { }
32 {************************************************************************}
33
34 unit IBXServices;
35
36 {$mode objfpc}{$H+}
37
38 interface
39
40 uses
41 Classes, SysUtils, DB, IB, IBDatabase, IBTypes, IBSQLMonitor, IBExternals, memds;
42
43 type
44 TIBXCustomService = class;
45 TIBXControlService = class;
46 TIBXServicesConnection = class;
47
48 IIBXServicesClient = interface
49 procedure OnAfterConnect(Sender: TIBXServicesConnection; aDatabaseName: string);
50 procedure OnBeforeDisconnect(Sender: TIBXServicesConnection);
51 end;
52
53 TSecContextAction = (scRaiseError, scReconnect);
54
55 TIBXServicesLoginEvent = procedure(Service: TIBXServicesConnection; var aServerName: string; LoginParams: TStrings) of object;
56 TIBXServicesSecContextEvent = procedure(Service: TIBXServicesConnection; var aAction: TSecContextAction) of object;
57
58 { TIBXServicesConnection }
59
60 TIBXServicesConnection = class(TIBXMonitoredConnection)
61 private
62 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 procedure DoAfterPost; override;
644 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 procedure TIBXServicesLimboTransactionsList.DoAfterPost;
882 begin
883 if not FLoading then
884 inherited DoAfterPost;
885 end;
886
887 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 inherited DoAfterPost;
996 with FSource as TIBXSecurityService do
997 begin
998 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 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