/Gedemin/IBX/IBServices.pas
Pascal | 2067 lines | 1848 code | 145 blank | 74 comment | 130 complexity | 510acada417b3f00f88d5dbf6e4c4692 MD5 | raw file
Possible License(s): AGPL-3.0, MPL-2.0-no-copyleft-exception, GPL-2.0, LGPL-2.0, LGPL-2.1
- {************************************************************************}
- { }
- { Borland Delphi Visual Component Library }
- { InterBase Express core components }
- { }
- { Copyright (c) 1998-2001 Borland Software Corporation }
- { }
- { InterBase Express is based in part on the product }
- { Free IB Components, written by Gregory H. Deatz for }
- { Hoagland, Longo, Moran, Dunst & Doukas Company. }
- { Free IB Components is used under license. }
- { }
- { The contents of this file are subject to the InterBase }
- { Public License Version 1.0 (the "License"); you may not }
- { use this file except in compliance with the License. You may obtain }
- { a copy of the License at http://www.borland.com/interbase/IPL.html }
- { Software distributed under the License is distributed on }
- { an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
- { express or implied. See the License for the specific language }
- { governing rights and limitations under the License. }
- { The Original Code was created by InterBase Software Corporation }
- { and its successors. }
- { Portions created by Borland Software Corporation are Copyright }
- { (C) Borland Software Corporation. All Rights Reserved. }
- { Contributor(s): Jeff Overcash }
- { }
- {************************************************************************}
-
- {
- InterBase Express provides component interfaces to
- functions introduced in InterBase 6.0. The Services
- components (TIB*Service, TIBServerProperties) and
- Install components (TIBInstall, TIBUninstall, TIBSetup)
- function only if you have installed InterBase 6.0 or
- later software
- }
-
- unit IBServices;
-
- interface
-
- uses
- SysUtils, Classes,
- Controls, Forms,
- IBDialogs, IBHeader, IB, IBExternals;
-
- const
- DefaultBufferSize = 32000;
-
- SPBPrefix = 'isc_spb_';
- SPBConstantNames: array[1..isc_spb_last_spb_constant] of String = (
- 'user_name',
- 'sys_user_name',
- 'sys_user_name_enc',
- 'password',
- 'password_enc',
- 'command_line',
- 'db_name',
- 'verbose',
- 'options',
- 'connect_timeout',
- 'dummy_packet_interval',
- 'sql_role_name'
- );
-
- SPBConstantValues: array[1..isc_spb_last_spb_constant] of Integer = (
- isc_spb_user_name_mapped_to_server,
- isc_spb_sys_user_name_mapped_to_server,
- isc_spb_sys_user_name_enc_mapped_to_server,
- isc_spb_password_mapped_to_server,
- isc_spb_password_enc_mapped_to_server,
- isc_spb_command_line_mapped_to_server,
- isc_spb_dbname_mapped_to_server,
- isc_spb_verbose_mapped_to_server,
- isc_spb_options_mapped_to_server,
- isc_spb_connect_timeout_mapped_to_server,
- isc_spb_dummy_packet_interval_mapped_to_server,
- isc_spb_sql_role_name_mapped_to_server
- );
-
- type
- TProtocol = (TCP, SPX, NamedPipe, Local);
- TOutputBufferOption = (ByLine, ByChunk);
-
- TIBCustomService = class;
-
- TLoginEvent = procedure(Database: TIBCustomService;
- LoginParams: TStrings) of object;
-
- TIBCustomService = class(TComponent)
- private
- FIBLoaded: Boolean;
- FParamsChanged : Boolean;
- FSPB, FQuerySPB : PChar;
- FSPBLength, FQuerySPBLength : Short;
- FTraceFlags: TTraceFlags;
- FOnLogin: TLoginEvent;
- FLoginPrompt: Boolean;
- FBufferSize: Integer;
- FOutputBuffer: PChar;
- FQueryParams: String;
- FServerName: string;
- FHandle: TISC_SVC_HANDLE;
- FStreamedActive : Boolean;
- FOnAttach: TNotifyEvent;
- FOutputBufferOption: TOutputBufferOption;
- FProtocol: TProtocol;
- FParams: TStrings;
- function GetActive: Boolean;
- function GetServiceParamBySPB(const Idx: Integer): String;
- procedure SetActive(const Value: Boolean);
- procedure SetBufferSize(const Value: Integer);
- procedure SetParams(const Value: TStrings);
- procedure SetServerName(const Value: string);
- procedure SetProtocol(const Value: TProtocol);
- procedure SetServiceParamBySPB(const Idx: Integer;
- const Value: String);
- function IndexOfSPBConst(st: String): Integer;
- procedure ParamsChange(Sender: TObject);
- procedure ParamsChanging(Sender: TObject);
- procedure CheckServerName;
- function Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
- function ParseString(var RunLen: Integer): string;
- function ParseInteger(var RunLen: Integer): Integer;
- procedure GenerateSPB(sl: TStrings; var SPB: String; var SPBLength: Short);
-
- protected
- procedure Loaded; override;
- function Login: Boolean;
- procedure CheckActive;
- procedure CheckInactive;
- property OutputBuffer : PChar read FOutputBuffer;
- property OutputBufferOption : TOutputBufferOption read FOutputBufferOption write FOutputBufferOption;
- property BufferSize : Integer read FBufferSize write SetBufferSize default DefaultBufferSize;
- procedure InternalServiceQuery;
- property ServiceQueryParams: String read FQueryParams write FQueryParams;
-
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- procedure Attach;
- procedure Detach;
- property Handle: TISC_SVC_HANDLE read FHandle;
- property ServiceParamBySPB[const Idx: Integer]: String read GetServiceParamBySPB
- write SetServiceParamBySPB;
- published
- property Active: Boolean read GetActive write SetActive default False;
- property ServerName: string read FServerName write SetServerName;
- property Protocol: TProtocol read FProtocol write SetProtocol default Local;
- property Params: TStrings read FParams write SetParams;
- property LoginPrompt: Boolean read FLoginPrompt write FLoginPrompt default True;
- property TraceFlags: TTraceFlags read FTraceFlags write FTraceFlags;
- property OnAttach: TNotifyEvent read FOnAttach write FOnAttach;
- property OnLogin: TLoginEvent read FOnLogin write FOnLogin;
- end;
-
- TDatabaseInfo = class
- public
- NoOfAttachments: Integer;
- NoOfDatabases: Integer;
- DbName: array of string;
- constructor Create;
- destructor Destroy; override;
- end;
-
- TLicenseInfo = class
- public
- Key: array of string;
- Id: array of string;
- Desc: array of string;
- LicensedUsers: Integer;
- constructor Create;
- destructor Destroy; override;
- end;
-
- TLicenseMaskInfo = class
- public
- LicenseMask: Integer;
- CapabilityMask: Integer;
- end;
-
- TConfigFileData = class
- public
- ConfigFileValue: array of integer;
- ConfigFileKey: array of integer;
- constructor Create;
- destructor Destroy; override;
- end;
-
- TConfigParams = class
- public
- ConfigFileData: TConfigFileData;
- ConfigFileParams: array of string;
- BaseLocation: string;
- LockFileLocation: string;
- MessageFileLocation: string;
- SecurityDatabaseLocation: string;
- constructor Create;
- destructor Destroy; override;
- end;
-
- TVersionInfo = class
- ServerVersion: String;
- ServerImplementation: string;
- ServiceVersion: Integer;
- end;
-
- TPropertyOption = (Database, License, LicenseMask, ConfigParameters, Version);
- TPropertyOptions = set of TPropertyOption;
-
- TIBServerProperties = class(TIBCustomService)
- private
- FOptions: TPropertyOptions;
- FDatabaseInfo: TDatabaseInfo;
- FLicenseInfo: TLicenseInfo;
- FLicenseMaskInfo: TLicenseMaskInfo;
- FVersionInfo: TVersionInfo;
- FConfigParams: TConfigParams;
- procedure ParseConfigFileData(var RunLen: Integer);
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- procedure Fetch;
- procedure FetchDatabaseInfo;
- procedure FetchLicenseInfo;
- procedure FetchLicenseMaskInfo;
- procedure FetchConfigParams;
- procedure FetchVersionInfo;
- property DatabaseInfo: TDatabaseInfo read FDatabaseInfo;
- property LicenseInfo: TLicenseInfo read FLicenseInfo;
- property LicenseMaskInfo: TLicenseMaskInfo read FLicenseMaskInfo;
- property VersionInfo: TVersionInfo read FVersionInfo;
- property ConfigParams: TConfigParams read FConfigParams;
- published
- property Options : TPropertyOptions read FOptions write FOptions;
- end;
-
- TIBControlService = class (TIBCustomService)
- private
- FStartParams: String;
- FStartSPB: PChar;
- FStartSPBLength: Integer;
- function GetIsServiceRunning: Boolean;
- protected
- property ServiceStartParams: String read FStartParams write FStartParams;
- procedure SetServiceStartOptions; virtual;
- procedure ServiceStartAddParam (Value: string; param: Integer); overload;
- procedure ServiceStartAddParam (Value: Integer; param: Integer); overload;
- procedure ServiceStartAddByteParam (Value: Byte; param: Integer);
- procedure InternalServiceStart;
-
- public
- constructor Create(AOwner: TComponent); override;
- procedure ServiceStart; virtual;
- property IsServiceRunning : Boolean read GetIsServiceRunning;
- end;
-
- TIBControlAndQueryService = class (TIBControlService)
- private
- FEof: Boolean;
- FAction: Integer;
- procedure SetAction(Value: Integer);
- protected
- property Action: Integer read FAction write SetAction;
- public
- constructor create (AOwner: TComponent); override;
- function GetNextLine : String;
- function GetNextChunk : String;
- property Eof: boolean read FEof;
- published
- property BufferSize;
- end;
-
- //TShutdownMode = (Forced, DenyTransaction, DenyAttachment);
- TShutdownModeEx = (smeForce, smeAttachment, smeTransaction);
- TOperationMode = (omNormal, omMulti, omSingle, omFull);
-
- TIBConfigService = class(TIBControlService)
- private
- FDatabaseName: string;
- procedure SetDatabaseName(const Value: string);
- protected
-
- public
- procedure ServiceStart; override;
- //procedure ShutdownDatabase (Options: TShutdownMode; Wait: Integer);
- procedure ShutdownDatabase (Options: TShutdownModeEx; Wait: Integer; OperationMode: TOperationMode);
- procedure SetSweepInterval (Value: Integer);
- procedure SetDBSqlDialect (Value: Integer);
- procedure SetPageBuffers (Value: Integer);
- procedure ActivateShadow;
- procedure BringDatabaseOnline;
- procedure SetReserveSpace (Value: Boolean);
- procedure SetAsyncMode (Value: Boolean);
- procedure SetReadOnly (Value: Boolean);
- published
- property DatabaseName: string read FDatabaseName write SetDatabaseName;
- end;
-
- TLicensingAction = (LicenseAdd, LicenseRemove);
- TIBLicensingService = class(TIBControlService)
- private
- FID: String;
- FKey: String;
- FAction: TLicensingAction;
- procedure SetAction(Value: TLicensingAction);
- protected
- procedure SetServiceStartOptions; override;
- public
- procedure AddLicense;
- procedure RemoveLicense;
- published
- property Action: TLicensingAction read FAction write SetAction default LicenseAdd;
- property Key: String read FKey write FKey;
- property ID: String read FID write FID;
- end;
-
- TIBLogService = class(TIBControlAndQueryService)
- private
-
- protected
- procedure SetServiceStartOptions; override;
- public
- published
- end;
-
- TStatOption = (DataPages, DbLog, HeaderPages, IndexPages, SystemRelations);
- TStatOptions = set of TStatOption;
-
- TIBStatisticalService = class(TIBControlAndQueryService)
- private
- FDatabaseName: string;
- FOptions: TStatOptions;
- procedure SetDatabaseName(const Value: string);
- protected
- procedure SetServiceStartOptions; override;
- public
- published
- property DatabaseName: string read FDatabaseName write SetDatabaseName;
- property Options : TStatOptions read FOptions write FOptions;
- end;
-
-
- TIBBackupRestoreService = class(TIBControlAndQueryService)
- private
- FVerbose: Boolean;
- protected
- public
- published
- property Verbose : Boolean read FVerbose write FVerbose default False;
- end;
-
- TBackupOption = (IgnoreChecksums, IgnoreLimbo, MetadataOnly, NoGarbageCollection,
- OldMetadataDesc, NonTransportable, ConvertExtTables);
- TBackupOptions = set of TBackupOption;
-
- TIBBackupService = class (TIBBackupRestoreService)
- private
- FDatabaseName: string;
- FOptions: TBackupOptions;
- FBackupFile: TStrings;
- FBlockingFactor: Integer;
- procedure SetBackupFile(const Value: TStrings);
- protected
- procedure SetServiceStartOptions; override;
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
-
- published
- { a name=value pair of filename and length }
- property BackupFile: TStrings read FBackupFile write SetBackupFile;
- property BlockingFactor: Integer read FBlockingFactor write FBlockingFactor;
- property DatabaseName: string read FDatabaseName write FDatabaseName;
- property Options : TBackupOptions read FOptions write FOptions;
- end;
-
- TRestoreOption = (DeactivateIndexes, NoShadow, NoValidityCheck, OneRelationAtATime,
- Replace, CreateNewDB, UseAllSpace, FixFss);
-
- TRestoreOptions = set of TRestoreOption;
- TIBRestoreService = class (TIBBackupRestoreService)
- private
- FDatabaseName: TStrings;
- FBackupFile: TStrings;
- FOptions: TRestoreOptions;
- FPageSize: Integer;
- FPageBuffers: Integer;
- FFixFssCharacterSet: String;
- procedure SetBackupFile(const Value: TStrings);
- procedure SetDatabaseName(const Value: TStrings);
- protected
- procedure SetServiceStartOptions; override;
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- published
- { a name=value pair of filename and length }
- property DatabaseName: TStrings read FDatabaseName write SetDatabaseName;
- property BackupFile: TStrings read FBackupFile write SetBackupFile;
- property PageSize: Integer read FPageSize write FPageSize default 4096;
- property PageBuffers: Integer read FPageBuffers write FPageBuffers;
- property FixFssCharacterSet: String read FFixFssCharacterSet write FFixFssCharacterSet;
- property Options : TRestoreOptions read FOptions write FOptions default [CreateNewDB];
- end;
-
- TValidateOption = (LimboTransactions, CheckDB, IgnoreChecksum, KillShadows, MendDB,
- SweepDB, ValidateDB, ValidateFull);
- TValidateOptions = set of TValidateOption;
-
- TTransactionGlobalAction = (CommitGlobal, RollbackGlobal, RecoverTwoPhaseGlobal,
- NoGlobalAction);
- TTransactionState = (LimboState, CommitState, RollbackState, UnknownState);
- TTransactionAdvise = (CommitAdvise, RollbackAdvise, UnknownAdvise);
- TTransactionAction = (CommitAction, RollbackAction);
-
- TLimboTransactionInfo = class
- public
- MultiDatabase: Boolean;
- ID: Integer;
- HostSite: String;
- RemoteSite: String;
- RemoteDatabasePath: String;
- State: TTransactionState;
- Advise: TTransactionAdvise;
- Action: TTransactionAction;
- end;
-
- TIBValidationService = class(TIBControlAndQueryService)
- private
- FDatabaseName: string;
- FOptions: TValidateOptions;
- FLimboTransactionInfo: array of TLimboTransactionInfo;
- FGlobalAction: TTransactionGlobalAction;
- procedure SetDatabaseName(const Value: string);
- function GetLimboTransactionInfo(index: integer): TLimboTransactionInfo;
- function GetLimboTransactionInfoCount: integer;
-
- protected
- procedure SetServiceStartOptions; override;
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- procedure FetchLimboTransactionInfo;
- procedure FixLimboTransactionErrors;
- property LimboTransactionInfo[Index: integer]: TLimboTransactionInfo read GetLimboTransactionInfo;
- property LimboTransactionInfoCount: Integer read GetLimboTransactionInfoCount;
-
- published
- property DatabaseName: string read FDatabaseName write SetDatabaseName;
- property Options: TValidateOptions read FOptions write FOptions;
- property GlobalAction: TTransactionGlobalAction read FGlobalAction
- write FGlobalAction;
- end;
-
- TUserInfo = class
- public
- UserName: string;
- FirstName: string;
- MiddleName: string;
- LastName: string;
- GroupID: Integer;
- UserID: Integer;
- end;
-
- TSecurityAction = (ActionAddUser, ActionDeleteUser, ActionModifyUser, ActionDisplayUser);
- TSecurityModifyParam = (ModifyFirstName, ModifyMiddleName, ModifyLastName, ModifyUserId,
- ModifyGroupId, ModifyPassword);
- TSecurityModifyParams = set of TSecurityModifyParam;
-
- TIBSecurityService = class(TIBControlAndQueryService)
- private
- FUserID: Integer;
- FGroupID: Integer;
- FFirstName: string;
- FUserName: string;
- FPassword: string;
- FSQLRole: string;
- FLastName: string;
- FMiddleName: string;
- FUserInfo: array of TUserInfo;
- FSecurityAction: TSecurityAction;
- FModifyParams: TSecurityModifyParams;
- procedure ClearParams;
- procedure SetSecurityAction (Value: TSecurityAction);
- procedure SetFirstName (Value: String);
- procedure SetMiddleName (Value: String);
- procedure SetLastName (Value: String);
- procedure SetPassword (Value: String);
- procedure SetUserId (Value: Integer);
- procedure SetGroupId (Value: Integer);
-
- procedure FetchUserInfo;
- function GetUserInfo(Index: Integer): TUserInfo;
- function GetUserInfoCount: Integer;
-
- protected
- procedure Loaded; override;
- procedure SetServiceStartOptions; override;
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- procedure DisplayUsers;
- procedure DisplayUser(UserName: string);
- procedure AddUser;
- procedure DeleteUser;
- procedure ModifyUser;
- property UserInfo[Index: Integer]: TUserInfo read GetUserInfo;
- property UserInfoCount: Integer read GetUserInfoCount;
-
- published
- property SecurityAction: TSecurityAction read FSecurityAction
- write SetSecurityAction;
- property SQlRole : string read FSQLRole write FSQLrole;
- property UserName : string read FUserName write FUserName;
- property FirstName : string read FFirstName write SetFirstName;
- property MiddleName : string read FMiddleName write SetMiddleName;
- property LastName : string read FLastName write SetLastName;
- property UserID : Integer read FUserID write SetUserID;
- property GroupID : Integer read FGroupID write SetGroupID;
- property Password : string read FPassword write setPassword;
- end;
-
-
- implementation
-
- uses
- IBIntf,
- {$IFDEF GEDEMIN}
- IBSQLMonitor_Gedemin
- {$ELSE}
- IBSQLMonitor
- {$ENDIF}
- ;
-
- { TIBCustomService }
-
- procedure TIBCustomService.Attach;
- var
- SPB: String;
- ConnectString: String;
- begin
- CheckInactive;
- CheckServerName;
-
- if FLoginPrompt and not Login then
- IBError(ibxeOperationCancelled, [nil]);
-
- { Generate a new SPB if necessary }
- if FParamsChanged then
- begin
- FParamsChanged := False;
- GenerateSPB(FParams, SPB, FSPBLength);
- IBAlloc(FSPB, 0, FsPBLength);
- Move(SPB[1], FSPB[0], FSPBLength);
- end;
- case FProtocol of
- TCP: ConnectString := FServerName + ':service_mgr'; {do not localize}
- SPX: ConnectString := FServerName + '@service_mgr'; {do not localize}
- NamedPipe: ConnectString := '\\' + FServerName + '\service_mgr'; {do not localize}
- Local: ConnectString := 'service_mgr'; {do not localize}
- end;
- if call(isc_service_attach(StatusVector, Length(ConnectString),
- PChar(ConnectString), @FHandle,
- FSPBLength, FSPB), False) > 0 then
- begin
- FHandle := nil;
- IBDataBaseError;
- end;
-
- if Assigned(FOnAttach) then
- FOnAttach(Self);
- MonitorHook.ServiceAttach(Self);
- end;
-
- procedure TIBCustomService.Loaded;
- begin
- inherited Loaded;
- try
- if FStreamedActive and (not Active) then
- Attach;
- except
- if csDesigning in ComponentState then
- Application.HandleException(Self)
- else
- raise;
- end;
- end;
-
- function TIBCustomService.Login: Boolean;
- var
- IndexOfUser, IndexOfPassword: Integer;
- Username, Password: String;
- LoginParams: TStrings;
- begin
- if Assigned(FOnLogin) then begin
- result := True;
- LoginParams := TStringList.Create;
- try
- LoginParams.Assign(Params);
- FOnLogin(Self, LoginParams);
- Params.Assign (LoginParams);
- finally
- LoginParams.Free;
- end;
- end
- else
- begin
- IndexOfUser := IndexOfSPBConst(SPBConstantNames[isc_spb_user_name]);
- if IndexOfUser <> -1 then
- Username := Copy(Params[IndexOfUser],
- Pos('=', Params[IndexOfUser]) + 1, {mbcs ok}
- Length(Params[IndexOfUser]));
- IndexOfPassword := IndexOfSPBConst(SPBConstantNames[isc_spb_password]);
- if IndexOfPassword <> -1 then
- Password := Copy(Params[IndexOfPassword],
- Pos('=', Params[IndexOfPassword]) + 1, {mbcs ok}
- Length(Params[IndexOfPassword]));
- result := ServerLoginDialog(serverName, Username, Password);
- if result then
- begin
- IndexOfPassword := IndexOfSPBConst(SPBConstantNames[isc_spb_password]);
- if IndexOfUser = -1 then
- Params.Add(SPBConstantNames[isc_spb_user_name] + '=' + Username)
- else
- Params[IndexOfUser] := SPBConstantNames[isc_spb_user_name] +
- '=' + Username;
- if IndexOfPassword = -1 then
- Params.Add(SPBConstantNames[isc_spb_password] + '=' + Password)
- else
- Params[IndexOfPassword] := SPBConstantNames[isc_spb_password] +
- '=' + Password;
- end;
- end;
- end;
-
- procedure TIBCustomService.CheckActive;
- begin
- if FStreamedActive and (not Active) then
- Loaded;
- if FHandle = nil then
- IBError(ibxeServiceActive, [nil]);
- end;
-
- procedure TIBCustomService.CheckInactive;
- begin
- if FHandle <> nil then
- IBError(ibxeServiceInActive, [nil]);
- end;
-
- constructor TIBCustomService.Create(AOwner: TComponent);
- begin
- inherited Create(AOwner);
- FIBLoaded := False;
- CheckIBLoaded;
- FIBLoaded := True;
- FProtocol := local;
- FserverName := '';
- FParams := TStringList.Create;
- FParamsChanged := True;
- TStringList(FParams).OnChange := ParamsChange;
- TStringList(FParams).OnChanging := ParamsChanging;
- FSPB := nil;
- FQuerySPB := nil;
- FBufferSize := DefaultBufferSize;
- FHandle := nil;
- FLoginPrompt := True;
- FTraceFlags := [];
- FOutputbuffer := nil;
- end;
-
- destructor TIBCustomService.Destroy;
- begin
- if FIBLoaded then
- begin
- if FHandle <> nil then
- Detach;
- FreeMem(FSPB);
- FSPB := nil;
- FParams.Free;
- end;
- ReallocMem(FOutputBuffer, 0);
- inherited Destroy;
- end;
-
- procedure TIBCustomService.Detach;
- begin
- CheckActive;
- if (Call(isc_service_detach(StatusVector, @FHandle), False) > 0) then
- begin
- FHandle := nil;
- IBDataBaseError;
- end
- else
- FHandle := nil;
- MonitorHook.ServiceDetach(Self);
- end;
-
- function TIBCustomService.GetActive: Boolean;
- begin
- result := FHandle <> nil;
- end;
-
- function TIBCustomService.GetServiceParamBySPB(const Idx: Integer): String;
- var
- ConstIdx, EqualsIdx: Integer;
- begin
- if (Idx > 0) and (Idx <= isc_spb_last_spb_constant) then
- begin
- ConstIdx := IndexOfSPBConst(SPBConstantNames[Idx]);
- if ConstIdx = -1 then
- result := ''
- else
- begin
- result := Params[ConstIdx];
- EqualsIdx := Pos('=', result); {mbcs ok}
- if EqualsIdx = 0 then
- result := ''
- else
- result := Copy(result, EqualsIdx + 1, Length(result));
- end;
- end
- else
- result := '';
- end;
-
- procedure TIBCustomService.InternalServiceQuery;
- begin
- FQuerySPBLength := Length(FQueryParams);
- if FQuerySPBLength = 0 then
- IBError(ibxeQueryParamsError, [nil]);
- IBAlloc(FQuerySPB, 0, FQuerySPBLength);
- Move(FQueryParams[1], FQuerySPB[0], FQuerySPBLength);
- if (FOutputBuffer = nil) then
- IBAlloc(FOutputBuffer, 0, FBufferSize);
- try
- if call(isc_service_query(StatusVector, @FHandle, nil, 0, nil,
- FQuerySPBLength, FQuerySPB,
- FBufferSize, FOutputBuffer), False) > 0 then
- begin
- FHandle := nil;
- IBDataBaseError;
- end;
- finally
- FreeMem(FQuerySPB);
- FQuerySPB := nil;
- FQuerySPBLength := 0;
- FQueryParams := '';
- end;
- MonitorHook.ServiceQuery(Self);
- end;
-
- procedure TIBCustomService.SetActive(const Value: Boolean);
- begin
- if csReading in ComponentState then
- FStreamedActive := Value
- else
- if Value <> Active then
- if Value then
- Attach
- else
- Detach;
- end;
-
- procedure TIBCustomService.SetBufferSize(const Value: Integer);
- begin
- if (Value <> FBufferSize) then
- begin
- FBufferSize := Value;
- if FOutputBuffer <> nil then
- IBAlloc(FOutputBuffer, 0, FBufferSize);
- end;
- end;
-
- procedure TIBCustomService.SetParams(const Value: TStrings);
- begin
- FParams.Assign(Value);
- end;
-
- procedure TIBCustomService.SetServerName(const Value: string);
- begin
- if FServerName <> Value then
- begin
- CheckInactive;
- FServerName := Value;
- if (FProtocol = Local) and (FServerName <> '') then
- FProtocol := TCP
- else
- if (FProtocol <> Local) and (FServerName = '') then
- FProtocol := Local;
- end;
- end;
-
- procedure TIBCustomService.SetProtocol(const Value: TProtocol);
- begin
- if FProtocol <> Value then
- begin
- CheckInactive;
- FProtocol := Value;
- if (Value = Local) then
- FServerName := '';
- end;
- end;
-
- procedure TIBCustomService.SetServiceParamBySPB(const Idx: Integer;
- const Value: String);
- var
- ConstIdx: Integer;
- begin
- ConstIdx := IndexOfSPBConst(SPBConstantNames[Idx]);
- if (Value = '') then
- begin
- if ConstIdx <> -1 then
- Params.Delete(ConstIdx);
- end
- else
- begin
- if (ConstIdx = -1) then
- Params.Add(SPBConstantNames[Idx] + '=' + Value)
- else
- Params[ConstIdx] := SPBConstantNames[Idx] + '=' + Value;
- end;
- end;
-
- function TIBCustomService.IndexOfSPBConst(st: String): Integer;
- var
- i, pos_of_str: Integer;
- begin
- result := -1;
- for i := 0 to Params.Count - 1 do
- begin
- pos_of_str := Pos(st, Params[i]); {mbcs ok}
- if (pos_of_str = 1) or (pos_of_str = Length(SPBPrefix) + 1) then
- begin
- result := i;
- break;
- end;
- end;
- end;
-
- procedure TIBCustomService.ParamsChange(Sender: TObject);
- begin
- FParamsChanged := True;
- end;
-
- procedure TIBCustomService.ParamsChanging(Sender: TObject);
- begin
- CheckInactive;
- end;
-
- procedure TIBCustomService.CheckServerName;
- begin
- if (FServerName = '') and (FProtocol <> Local) then
- IBError(ibxeServerNameMissing, [nil]);
- end;
-
- function TIBCustomService.Call(ErrCode: ISC_STATUS;
- RaiseError: Boolean): ISC_STATUS;
- begin
- result := ErrCode;
- if RaiseError and (ErrCode > 0) then
- IBDataBaseError;
- end;
-
- function TIBCustomService.ParseString(var RunLen: Integer): string;
- var
- Len: UShort;
- tmp: Char;
- begin
- Len := isc_vax_integer(OutputBuffer + RunLen, 2);
- RunLen := RunLen + 2;
- if (Len <> 0) then
- begin
- tmp := OutputBuffer[RunLen + Len];
- OutputBuffer[RunLen + Len] := #0;
- result := String(PChar(@OutputBuffer[RunLen]));
- OutputBuffer[RunLen + Len] := tmp;
- RunLen := RunLen + Len;
- end
- else
- result := '';
- end;
-
- function TIBCustomService.ParseInteger(var RunLen: Integer): Integer;
- begin
- result := isc_vax_integer(OutputBuffer + RunLen, 4);
- RunLen := RunLen + 4;
- end;
-
- {
- * GenerateSPB -
- * Given a string containing a textual representation
- * of the Service parameters, generate a service
- * parameter buffer, and return it and its length
- * in SPB and SPBLength, respectively.
- }
- procedure TIBCustomService.GenerateSPB(sl: TStrings; var SPB: String;
- var SPBLength: Short);
- var
- i, j : Integer;
- SPBVal, SPBServerVal: UShort;
- param_name, param_value: String;
- begin
- { The SPB is initially empty, with the exception that
- the SPB version must be the first byte of the string.
- }
- SPBLength := 2;
- SPB := Char(isc_spb_version);
- SPB := SPB + Char(isc_spb_current_version);
- { Iterate through the textual service parameters, constructing
- a SPB on-the-fly}
- for i := 0 to sl.Count - 1 do
- begin
- { Get the parameter's name and value from the list,
- and make sure that the name is all lowercase with
- no leading 'isc_spb_' prefix }
- if (Trim(sl.Names[i]) = '') then
- continue;
- param_name := LowerCase(sl.Names[i]); {mbcs ok}
- param_value := Copy(sl[i], Pos('=', sl[i]) + 1, Length(sl[i])); {mbcs ok}
- if (Pos(SPBPrefix, param_name) = 1) then {mbcs ok}
- Delete(param_name, 1, Length(SPBPrefix));
- { We want to translate the parameter name to some integer
- value. We do this by scanning through a list of known
- service parameter names (SPBConstantNames, defined above). }
- SPBVal := 0;
- SPBServerVal := 0;
- { Find the parameter }
- for j := 1 to isc_spb_last_spb_constant do
- if (param_name = SPBConstantNames[j]) then
- begin
- SPBVal := j;
- SPBServerVal := SPBConstantValues[j];
- break;
- end;
- case SPBVal of
- isc_spb_user_name, isc_spb_password:
- begin
- SPB := SPB +
- Char(SPBServerVal) +
- Char(Length(param_value)) +
- param_value;
- Inc(SPBLength, 2 + Length(param_value));
- end;
- else
- begin
- if (SPBVal > 0) and
- (SPBVal <= isc_dpb_last_dpb_constant) then
- IBError(ibxeSPBConstantNotSupported,
- [SPBConstantNames[SPBVal]])
- else
- IBError(ibxeSPBConstantUnknown, [SPBVal]);
- end;
- end;
- end;
- end;
-
- { TIBServerProperties }
- constructor TIBServerProperties.Create(AOwner: TComponent);
- begin
- inherited Create(AOwner);
- FDatabaseInfo := TDatabaseInfo.Create;
- FLicenseInfo := TLicenseInfo.Create;
- FLicenseMaskInfo := TLicenseMaskInfo.Create;
- FVersionInfo := TVersionInfo.Create;
- FConfigParams := TConfigParams.Create;
- end;
-
- destructor TIBServerProperties.Destroy;
- begin
- FDatabaseInfo.Free;
- FLicenseInfo.Free;
- FLicenseMaskInfo.Free;
- FVersionInfo.Free;
- FConfigParams.Free;
- inherited Destroy;
- end;
-
- procedure TIBServerProperties.ParseConfigFileData(var RunLen: Integer);
- begin
- Inc(RunLen);
- with FConfigParams.ConfigFileData do
- begin
- SetLength (ConfigFileValue, Length(ConfigFileValue)+1);
- SetLength (ConfigFileKey, Length(ConfigFileKey)+1);
-
- ConfigFileKey[High(ConfigFileKey)] := Integer(OutputBuffer[RunLen-1]);
- ConfigFileValue[High(ConfigFileValue)] := ParseInteger(RunLen);
- end;
- end;
-
- procedure TIBServerProperties.Fetch;
- begin
- if (Database in Options) then
- FetchDatabaseInfo;
- if (License in Options) then
- FetchLicenseInfo;
- if (LicenseMask in Options) then
- FetchLicenseMaskInfo;
- if (ConfigParameters in Options) then
- FetchConfigParams;
- if (Version in Options) then
- FetchVersionInfo;
- end;
-
- procedure TIBServerProperties.FetchConfigParams;
- var
- RunLen: Integer;
-
- begin
- ServiceQueryParams := Char(isc_info_svc_get_config) +
- Char(isc_info_svc_get_env) +
- Char(isc_info_svc_get_env_lock) +
- Char(isc_info_svc_get_env_msg) +
- Char(isc_info_svc_user_dbpath);
-
- InternalServiceQuery;
- RunLen := 0;
- While (not (Integer(OutputBuffer[RunLen]) = isc_info_end)) do
- begin
- case Integer(OutputBuffer[RunLen]) of
- isc_info_svc_get_config:
- begin
- FConfigParams.ConfigFileData.ConfigFileKey := nil;
- FConfigParams.ConfigFileData.ConfigFileValue := nil;
- Inc (RunLen);
- while (not (Integer(OutputBuffer[RunLen]) = isc_info_flag_end)) do
- ParseConfigFileData (RunLen);
- if (Integer(OutputBuffer[RunLen]) = isc_info_flag_end) then
- Inc (RunLen);
- end;
-
- isc_info_svc_get_env:
- begin
- Inc (RunLen);
- FConfigParams.BaseLocation := ParseString(RunLen);
- end;
-
- isc_info_svc_get_env_lock:
- begin
- Inc (RunLen);
- FConfigParams.LockFileLocation := ParseString(RunLen);
- end;
-
- isc_info_svc_get_env_msg:
- begin
- Inc (RunLen);
- FConfigParams.MessageFileLocation := ParseString(RunLen);
- end;
-
- isc_info_svc_user_dbpath:
- begin
- Inc (RunLen);
- FConfigParams.SecurityDatabaseLocation := ParseString(RunLen);
- end;
- else
- IBError(ibxeOutputParsingError, [nil]);
- end;
- end;
- end;
-
- procedure TIBServerProperties.FetchDatabaseInfo;
- var
- i, RunLen: Integer;
- begin
- ServiceQueryParams := Char(isc_info_svc_svr_db_info);
- InternalServiceQuery;
- if (OutputBuffer[0] <> Char(isc_info_svc_svr_db_info)) then
- IBError(ibxeOutputParsingError, [nil]);
- RunLen := 1;
- if (OutputBuffer[RunLen] <> Char(isc_spb_num_att)) then
- IBError(ibxeOutputParsingError, [nil]);
- Inc(RunLen);
- FDatabaseInfo.NoOfAttachments := ParseInteger(RunLen);
- if (OutputBuffer[RunLen] <> Char(isc_spb_num_db)) then
- IBError(ibxeOutputParsingError, [nil]);
- Inc(RunLen);
- FDatabaseInfo.NoOfDatabases := ParseInteger(RunLen);
- FDatabaseInfo.DbName := nil;
- SetLength(FDatabaseInfo.DbName, FDatabaseInfo.NoOfDatabases);
- i := 0;
- while (OutputBuffer[RunLen] <> Char(isc_info_flag_end)) do
- begin
- if (OutputBuffer[RunLen] <> Char(SPBConstantValues[isc_spb_dbname])) then
- IBError(ibxeOutputParsingError, [nil]);
- Inc(RunLen);
- FDatabaseInfo.DbName[i] := ParseString(RunLen);
- Inc (i);
- end;
- end;
-
- procedure TIBServerProperties.FetchLicenseInfo;
- var
- i, RunLen: Integer;
- done: Integer;
- begin
- ServiceQueryParams := Char(isc_info_svc_get_license) +
- Char(isc_info_svc_get_licensed_users);
- InternalServiceQuery;
- RunLen := 0;
- done := 0;
- i := 0;
- FLicenseInfo.key := nil;
- FLicenseInfo.id := nil;
- FLicenseInfo.desc := nil;
-
- While done < 2 do begin
- Inc(Done);
- Inc(RunLen);
- case Integer(OutputBuffer[RunLen-1]) of
- isc_info_svc_get_license:
- begin
- while (OutputBuffer[RunLen] <> Char(isc_info_flag_end)) do
- begin
- if (i >= Length(FLicenseInfo.key)) then
- begin
- SetLength(FLicenseInfo.key, i + 10);
- SetLength(FLicenseInfo.id, i + 10);
- SetLength(FLicenseInfo.desc, i + 10);
- end;
- if (OutputBuffer[RunLen] <> Char(isc_spb_lic_id)) then
- IBError(ibxeOutputParsingError, [nil]);
- Inc(RunLen);
- FLicenseInfo.id[i] := ParseString(RunLen);
- if (OutputBuffer[RunLen] <> Char(isc_spb_lic_key)) then
- IBError(ibxeOutputParsingError, [nil]);
- Inc(RunLen);
- FLicenseInfo.key[i] := ParseString(RunLen);
- if (OutputBuffer[RunLen] <> Char(7)) then
- IBError(ibxeOutputParsingError, [nil]);
- Inc(RunLen);
- FLicenseInfo.desc[i] := ParseString(RunLen);
- Inc(i);
- end;
- Inc(RunLen);
- if (Length(FLicenseInfo.key) > i) then
- begin
- SetLength(FLicenseInfo.key, i);
- SetLength(FLicenseInfo.id, i);
- SetLength(FLicenseInfo.desc, i);
- end;
- end;
- isc_info_svc_get_licensed_users:
- FLicenseInfo.LicensedUsers := ParseInteger(RunLen);
- else
- IBError(ibxeOutputParsingError, [nil]);
- end;
- end;
- end;
-
- procedure TIBServerProperties.FetchLicenseMaskInfo();
- var
- done,RunLen:integer;
- begin
- ServiceQueryParams := Char(isc_info_svc_get_license_mask) +
- Char(isc_info_svc_capabilities);
- InternalServiceQuery;
- RunLen := 0;
- done := 0;
- While done <= 1 do
- begin
- Inc(done);
- Inc(RunLen);
- case Integer(OutputBuffer[RunLen-1]) of
- isc_info_svc_get_license_mask:
- FLicenseMaskInfo.LicenseMask := ParseInteger(RunLen);
- isc_info_svc_capabilities:
- FLicenseMaskInfo.CapabilityMask := ParseInteger(RunLen);
- else
- IBError(ibxeOutputParsingError, [nil]);
- end;
- end;
- end;
-
-
- procedure TIBServerProperties.FetchVersionInfo;
- var
- RunLen: Integer;
- done: Integer;
- begin
- ServiceQueryParams := Char(isc_info_svc_version) +
- Char(isc_info_svc_server_version) +
- Char(isc_info_svc_implementation);
- InternalServiceQuery;
- RunLen := 0;
- done := 0;
-
- While done <= 2 do
- begin
- Inc(done);
- Inc(RunLen);
- case Integer(OutputBuffer[RunLen-1]) of
- isc_info_svc_version:
- FVersionInfo.ServiceVersion := ParseInteger(RunLen);
- isc_info_svc_server_version:
- FVersionInfo.ServerVersion := ParseString(RunLen);
- isc_info_svc_implementation:
- FVersionInfo.ServerImplementation := ParseString(RunLen);
- else
- IBError(ibxeOutputParsingError, [nil]);
- end;
- end;
- end;
-
- { TIBControlService }
- procedure TIBControlService.SetServiceStartOptions;
- begin
-
- end;
-
- function TIBControlService.GetIsServiceRunning: Boolean;
- var
- RunLen: Integer;
- begin
- ServiceQueryParams := Char(isc_info_svc_running);
- InternalServiceQuery;
- if (OutputBuffer[0] <> Char(isc_info_svc_running)) then
- IBError(ibxeOutputParsingError, [nil]);
- RunLen := 1;
- if (ParseInteger(RunLen) = 1) then
- result := True
- else
- result := False;
- end;
-
- procedure TIBControlService.ServiceStartAddParam (Value: string; param: Integer);
- var
- Len: UShort;
- begin
- Len := Length(Value);
- if Len > 0 then
- begin
- FStartParams := FStartParams +
- Char(Param) +
- PChar(@Len)[0] +
- PChar(@Len)[1] +
- Value;
- end;
- end;
-
- procedure TIBControlService.ServiceStartAddParam (Value: Integer; param: Integer);
- begin
- FStartParams := FStartParams +
- Char(Param) +
- PChar(@Value)[0] +
- PChar(@Value)[1] +
- PChar(@Value)[2] +
- PChar(@Value)[3];
- end;
-
- procedure TIBControlService.ServiceStartAddByteParam (Value: Byte; param: Integer);
- begin
- FStartParams := FStartParams +
- Char(Param) +
- PChar(@Value)[0];
- end;
-
- constructor TIBControlService.Create(AOwner: TComponent);
- begin
- inherited create(AOwner);
- FStartParams := '';
- FStartSPB := nil;
- FStartSPBLength := 0;
- end;
-
- procedure TIBControlService.InternalServiceStart;
- begin
- FStartSPBLength := Length(FStartParams);
- if FStartSPBLength = 0 then
- IBError(ibxeStartParamsError, [nil]);
- IBAlloc(FStartSPB, 0, FStartSPBLength);
- Move(FStartParams[1], FStartSPB[0], FstartSPBLength);
- try
- if call(isc_service_start(StatusVector, @FHandle, nil,
- FStartSPBLength, FStartSPB), False) > 0 then
- begin
- FHandle := nil;
- IBDataBaseError;
- end;
- finally
- FreeMem(FStartSPB);
- FStartSPB := nil;
- FStartSPBLength := 0;
- FStartParams := '';
- end;
- MonitorHook.ServiceStart(Self);
- end;
-
- procedure TIBControlService.ServiceStart;
- begin
- CheckActive;
- SetServiceStartOptions;
- InternalServiceStart;
- end;
-
- { TIBConfigService }
-
- procedure TIBConfigService.ServiceStart;
- begin
- IBError(ibxeUseSpecificProcedures, [nil]);
- end;
-
- procedure TIBConfigService.ActivateShadow;
- begin
- ServiceStartParams := Char(isc_action_svc_properties);
- ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
- ServiceStartAddParam (isc_spb_prp_activate, SPBConstantValues[isc_spb_options]);
- InternalServiceStart;
- end;
-
- procedure TIBConfigService.BringDatabaseOnline;
- begin
- ServiceStartParams := Char(isc_action_svc_properties);
- ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
- ServiceStartAddParam (isc_spb_prp_db_online, SPBConstantValues[isc_spb_options]);
- InternalServiceStart;
- end;
-
- procedure TIBConfigService.SetAsyncMode(Value: Boolean);
- begin
- ServiceStartParams := Char(isc_action_svc_properties);
- ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
- ServiceStartParams := ServiceStartParams +
- Char(isc_spb_prp_write_mode);
- if Value then
- ServiceStartParams := ServiceStartParams +
- Char(isc_spb_prp_wm_async)
- else
- ServiceStartParams := ServiceStartParams +
- Char(isc_spb_prp_wm_sync);
- InternalServiceStart;
- end;
-
- procedure TIBConfigService.SetDatabaseName(const Value: string);
- begin
- FDatabaseName := Value;
- end;
-
- procedure TIBConfigService.SetPageBuffers(Value: Integer);
- begin
- ServiceStartParams := Char(isc_action_svc_properties);
- ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
- ServiceStartAddParam (Value, isc_spb_prp_page_buffers);
- InternalServiceStart;
- end;
-
- procedure TIBConfigService.SetReadOnly(Value: Boolean);
- begin
- ServiceStartParams := Char(isc_action_svc_properties);
- ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
- ServiceStartParams := ServiceStartParams +
- Char(isc_spb_prp_access_mode);
- if Value then
- ServiceStartParams := ServiceStartParams +
- Char(isc_spb_prp_am_readonly)
- else
- ServiceStartParams := ServiceStartParams +
- Char(isc_spb_prp_am_readwrite);
- InternalServiceStart;
- end;
-
- procedure TIBConfigService.SetReserveSpace(Value: Boolean);
- begin
- ServiceStartParams := Char(isc_action_svc_properties);
- ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
- ServiceStartParams := ServiceStartParams +
- Char(isc_spb_prp_reserve_space);
- if Value then
- ServiceStartParams := ServiceStartParams +
- Char(isc_spb_prp_res)
- else
- ServiceStartParams := ServiceStartParams +
- Char(isc_spb_prp_res_use_full);
- InternalServiceStart;
- end;
-
- procedure TIBConfigService.SetSweepInterval(Value: Integer);
- begin
- ServiceStartParams := Char(isc_action_svc_properties);
- ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
- ServiceStartAddParam (Value, isc_spb_prp_sweep_interval);
- InternalServiceStart;
- end;
-
- procedure TIBConfigService.SetDBSqlDialect(Value: Integer);
- begin
- ServiceStartParams := Char(isc_action_svc_properties);
- ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
- ServiceStartAddParam (Value, isc_spb_prp_set_sql_dialect);
- InternalServiceStart;
- end;
-
- {
- changes for 2.5 as discussed here:
- http://firebird.1100200.n4.nabble.com/New-shutdown-online-mode-via-Delphi-unrecognized-service-parameter-block-td1126894.html
- }
- procedure TIBConfigService.ShutdownDatabase(Options: TShutdownModeEx;
- Wait: Integer; OperationMode: TOperationMode);
- begin
- ServiceStartParams := AnsiChar(isc_action_svc_properties);
- ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
- case OperationMode of
- omNormal: ServiceStartAddByteParam(isc_spb_prp_sm_normal, isc_spb_prp_shutdown_mode);
- omMulti: ServiceStartAddByteParam(isc_spb_prp_sm_multi, isc_spb_prp_shutdown_mode);
- omSingle: ServiceStartAddByteParam(isc_spb_prp_sm_single, isc_spb_prp_shutdown_mode);
- omFull: ServiceStartAddByteParam(isc_spb_prp_sm_full, isc_spb_prp_shutdown_mode);
- end;
- case Options of
- smeForce: ServiceStartAddParam(Wait, isc_spb_prp_force_shutdown);
- smeAttachment: ServiceStartAddParam(Wait, isc_spb_prp_attachments_shutdown);
- smeTransaction: ServiceStartAddParam(Wait, isc_spb_prp_transactions_shutdown);
- end;
- {ServiceStartParams := Char(isc_action_svc_properties);
- ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
- if (Options = Forced) then
- ServiceStartAddParam (Wait, isc_spb_prp_shutdown_db)
- else if (Options = DenyTransaction) then
- ServiceStartAddParam (Wait, isc_spb_prp_deny_new_transactions)
- else
- ServiceStartAddParam (Wait, isc_spb_prp_deny_new_attachments);}
- InternalServiceStart;
- end;
-
- { TIBLicensingService }
- procedure TIBLicensingService.SetAction(Value: TLicensingAction);
- begin
- FAction := Value;
- if (Value = LicenseRemove) then
- FID := '';
- end;
-
- procedure TIBLicensingService.AddLicense;
- begin
- Action := LicenseAdd;
- Servicestart;
- end;
-
- procedure TIBLicensingService.RemoveLicense;
- begin
- Action := LicenseRemove;
- Servicestart;
- end;
-
- procedure TIBLicensingService.SetServiceStartOptions;
- begin
- if (FAction = LicenseAdd) then begin
- ServiceStartParams := Char(isc_action_svc_add_license);
- ServiceStartAddParam (FKey, isc_spb_lic_key);
- ServiceStartAddParam (FID, isc_spb_lic_id);
- end
- else begin
- ServiceStartParams := Char(isc_action_svc_remove_license);
- ServiceStartAddParam (FKey, isc_spb_lic_key);
- end;
- end;
-
- { TIBStatisticalService }
-
- procedure TIBStatisticalService.SetDatabaseName(const Value: string);
- begin
- FDatabaseName := Value;
- end;
-
- procedure TIBStatisticalService.SetServiceStartOptions;
- var
- param: Integer;
- begin
- if FDatabaseName = '' then
- IBError(ibxeStartParamsError, [nil]);
- param := 0;
- if (DataPages in Options) then
- param := param or isc_spb_sts_data_pages;
- if (DbLog in Options) then
- param := param or isc_spb_sts_db_log;
- if (HeaderPages in Options) then
- param := param or isc_spb_sts_hdr_pages;
- if (IndexPages in Options) then
- param := param or isc_spb_sts_idx_pages;
- if (SystemRelations in Options) then
- param := param or isc_spb_sts_sys_relations;
- Action := isc_action_svc_db_stats;
- ServiceStartParams := Char(isc_action_svc_db_stats);
- ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
- ServiceStartAddParam (param, SPBConstantValues[isc_spb_options]);
- end;
-
- { TIBBackupService }
- procedure TIBBackupService.SetServiceStartOptions;
- var
- param, i: Integer;
- value: String;
- begin
- if FDatabaseName = '' then
- IBError(ibxeStartParamsError, [nil]);
- param := 0;
- if (IgnoreChecksums in Options) then
- param := param or isc_spb_bkp_ignore_checksums;
- if (IgnoreLimbo in Options) then
- param := param or isc_spb_bkp_ignore_limbo;
- if (MetadataOnly in Options) then
- param := param or isc_spb_bkp_metadata_only;
- if (NoGarbageCollection in Options) then
- param := param or isc_spb_bkp_no_garbage_collect;
- if (OldMetadataDesc in Options) then
- param := param or isc_spb_bkp_old_descriptions;
- if (NonTransportable in Options) then
- param := param or isc_spb_bkp_non_transportable;
- if (ConvertExtTables in Options) then
- param := param or isc_spb_bkp_convert;
- Action := isc_action_svc_backup;
- ServiceStartParams := Char(isc_action_svc_backup);
- ServiceStartAddParam(FDatabaseName, SPBConstantValues[isc_spb_dbname]);
- ServiceStartAddParam(param, SPBConstantValues[isc_spb_options]);
- if Verbose then
- ServiceStartParams := ServiceStartParams + Char(SPBConstantValues[isc_spb_verbose]);
- if FBlockingFactor > 0 then
- ServiceStartAddParam(FBlockingFactor, isc_spb_bkp_factor);
- for i := 0 to FBackupFile.Count - 1 do
- begin
- if (Trim(FBackupFile[i]) = '') then
- continue;
- if (Pos('=', FBackupFile[i]) <> 0) then
- begin {mbcs ok}
- ServiceStartAddParam(FBackupFile.Names[i], isc_spb_bkp_file);
- value := Copy(FBackupFile[i], Pos('=', FBackupFile[i]) + 1, Length(FBackupFile.Names[i])); {mbcs ok}
- param := StrToInt(value);
- ServiceStartAddParam(param, isc_spb_bkp_length);
- end
- else
- ServiceStartAddParam(FBackupFile[i], isc_spb_bkp_file);
- end;
- end;
-
- constructor TIBBackupService.Create(AOwner: TComponent);
- begin
- inherited Create(AOwner);
- FBackupFile := TStringList.Create;
- end;
-
- destructor TIBBackupService.Destroy;
- begin
- FBackupFile.Free;
- inherited Destroy;
- end;
-
- procedure TIBBackupService.SetBackupFile(const Value: TStrings);
- begin
- FBackupFile.Assign(Value);
- end;
-
- { TIBRestoreService }
-
- procedure TIBRestoreService.SetServiceStartOptions;
- var
- param, i: Integer;
- value: String;
- begin
- param := 0;
- if (DeactivateIndexes in Options) then
- param := param or isc_spb_res_deactivate_idx;
- if (NoShadow in Options) then
- param := param or isc_spb_res_no_shadow;
- if (NoValidityCheck in Options) then
- param := param or isc_spb_res_no_validity;
- if (OneRelationAtATime in Options) then
- param := param or isc_spb_res_one_at_a_time;
- if (Replace in Options) then
- param := param or isc_spb_res_replace;
- if (CreateNewDB in Options) then
- param := param or isc_spb_res_create;
- if (UseAllSpace in Options) then
- param := param or isc_spb_res_use_all_space;
- Action := isc_action_svc_restore;
- ServiceStartParams := Char(isc_action_svc_restore);
- ServiceStartAddParam(param, SPBConstantValues[isc_spb_options]);
- if Verbose then ServiceStartParams := ServiceStartParams + Char(SPBConstantValues[isc_spb_verbose]);
- if FPageSize > 0 then
- ServiceStartAddParam(FPageSize, isc_spb_res_page_size);
- if FPageBuffers > 0 then
- ServiceStartAddParam(FPageBuffers, isc_spb_res_buffers);
- // ??????? ???????? ??? ??????????? ?? ? ODS 11.1 +
- if FFixFssCharacterSet <> '' then
- begin
- ServiceStartAddParam(FixFssCharacterSet, isc_spb_res_fix_fss_data);
- ServiceStartAddParam(FixFssCharacterSet, isc_spb_res_fix_fss_metadata);
- end;
- for i := 0 to FBackupFile.Count - 1 do
- begin
- if (Trim(FBackupFile[i]) = '') then continue;
- if (Pos('=', FBackupFile[i]) <> 0) then {mbcs ok}
- begin
- ServiceStartAddParam(FBackupFile.Names[i], isc_spb_bkp_file);
- value := Copy(FBackupFile[i], Pos('=', FBackupFile[i]) + 1, Length(FBackupFile.Names[i])); {mbcs ok}
- param := StrToInt(value);
- ServiceStartAddParam(param, isc_spb_bkp_length);
- end
- else
- ServiceStartAddParam(FBackupFile[i], isc_spb_bkp_file);
- end;
- for i := 0 to FDatabaseName.Count - 1 do
- begin
- if (Trim(FDatabaseName[i]) = '') then continue;
- if (Pos('=', FDatabaseName[i]) <> 0) then {mbcs ok}
- begin
- ServiceStartAddParam(FDatabaseName.Names[i], SPBConstantValues[isc_spb_dbname]);
- value := Copy(FDatabaseName[i], Pos('=', FDatabaseName[i]) + 1, Length(FDatabaseName[i])); {mbcs ok}
- param := StrToInt(value);
- ServiceStartAddParam(param, isc_spb_res_length);
- end
- else
- ServiceStartAddParam(FDatabaseName[i], SPBConstantValues[isc_spb_dbname]);
- end;
- end;
-
- constructor TIBRestoreService.Create(AOwner: TComponent);
- begin
- inherited Create(AOwner);
- FDatabaseName := TStringList.Create;
- FBackupFile := TStringList.Create;
- Include (FOptions, CreateNewDB);
- FPageSize := 4096;
- FixFssCharacterSet := '';
- end;
-
- destructor TIBRestoreService.Destroy;
- begin
- FDatabaseName.Free;
- FBackupFile.Free;
- inherited Destroy;
- end;
-
- procedure TIBRestoreService.SetBackupFile(const Value: TStrings);
- begin
- FBackupFile.Assign(Value);
- end;
-
- procedure TIBRestoreService.SetDatabaseName(const Value: TStrings);
- begin
- FDatabaseName.Assign(Value);
- end;
-
- { TIBValidationService }
- constructor TIBValidationService.Create(AOwner: TComponent);
- begin
- inherited Create(AOwner);
- end;
-
- destructor TIBValidationService.Destroy;
- var
- i : Integer;
- begin
- for i := 0 to High(FLimboTransactionInfo) do
- FLimboTransactionInfo[i].Free;
- FLimboTransactionInfo := nil;
- inherited Destroy;
- end;
-
- procedure TIBValidationService.FetchLimboTransactionInfo;
- var
- i, RunLen: Integer;
- Value: Char;
- begin
- ServiceQueryParams := Char(isc_info_svc_limbo_trans);
- InternalServiceQuery;
- RunLen := 0;
- if (OutputBuffer[RunLen] <> Char(isc_info_svc_limbo_trans)) then
- IBError(ibxeOutputParsingError, [nil]);
- Inc(RunLen, 3);
- for i := 0 to High(FLimboTransactionInfo) do
- FLimboTransactionInfo[i].Free;
- FLimboTransactionInfo := nil;
- i := 0;
- while (OutputBuffer[RunLen] <> Char(isc_info_end)) do
- begin
- if (i >= Length(FLimboTransactionInfo)) then
- SetLength(FLimboTransactionInfo, i + 10);
- if FLimboTransactionInfo[i] = nil then
- FLimboTransactionInfo[i] := TLimboTransactionInfo.Create;
- with FLimboTransactionInfo[i] do
- begin
- if (OutputBuffer[RunLen] = Char(isc_spb_single_tra_id)) then
- begin
- Inc(RunLen);
- MultiDatabase := False;
- ID := ParseInteger(RunLen);
- end
- else
- begin
- Inc(RunLen);
- MultiDatabase := True;
- ID := ParseInteger(RunLen);
- HostSite := ParseString(RunLen);
- if (OutputBuffer[RunLen] <> Char(isc_spb_tra_state)) then
- IBError(ibxeOutputParsingError, [nil]);
- Inc(RunLen);
- Value := OutputBuffer[RunLen];
- Inc(RunLen);
- if (Value = Char(isc_spb_tra_state_limbo)) then
- State := LimboState
- else
- if (Value = Char(isc_spb_tra_state_commit)) then
- State := CommitState
- else
- if (Value = Char(isc_spb_tra_state_rollback)) then
- State := RollbackState
- else
- State := UnknownState;
- RemoteSite := ParseString(RunLen);
- RemoteDatabasePath := ParseString(RunLen);
- Value := OutputBuffer[RunLen];
- Inc(RunLen);
- if (Value = Char(isc_spb_tra_advise_commit)) then
- begin
- Advise := CommitAdvise;
- Action:= CommitAction;
- end
- else
- if (Value = Char(isc_spb_tra_advise_rollback)) then
- begin
- Advise := RollbackAdvise;
- Action := RollbackAction;
- end
- else
- begin
- { if no advice commit as default }
- Advise := UnknownAdvise;
- Action:= CommitAction;
- end;
- end;
- Inc (i);
- end;
- end;
- if (i > 0) then
- SetLength(FLimboTransactionInfo, i+1);
- end;
-
- procedure TIBValidationService.FixLimboTransactionErrors;
- var
- i: Integer;
- begin
- ServiceStartParams := Char(isc_action_svc_repair);
- ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
- if (FGlobalAction = NoGlobalAction) then
- begin
- i := 0;
- while (FLimboTransactionInfo[i].ID <> 0) do
- begin
- if (FLimboTransactionInfo[i].Action = CommitAction) then
- ServiceStartAddParam (FLimboTransactionInfo[i].ID, isc_spb_rpr_commit_trans)
- else
- ServiceStartAddParam (FLimboTransactionInfo[i].ID, isc_spb_rpr_rollback_trans);
- Inc(i);
- end;
- end
- else
- begin
- i := 0;
- if (FGlobalAction = CommitGlobal) then
- while (FLimboTransactionInfo[i].ID <> 0) do
- begin
- ServiceStartAddParam (FLimboTransactionInfo[i].ID, isc_spb_rpr_commit_trans);
- Inc(i);
- end
- else
- while (FLimboTransactionInfo[i].ID <> 0) do
- begin
- ServiceStartAddParam (FLimboTransactionInfo[i].ID, isc_spb_rpr_rollback_trans);
- Inc(i);
- end;
- end;
- InternalServiceStart;
- end;
-
- function TIBValidationService.GetLimboTransactionInfo(index: integer): TLimboTransactionInfo;
- begin
- if index <= High(FLimboTransactionInfo) then
- result := FLimboTransactionInfo[index]
- else
- result := nil;
- end;
-
- function TIBValidationService.GetLimboTransactionInfoCount: integer;
- begin
- Result := High(FLimboTransactionInfo);
- end;
-
- procedure TIBValidationService.SetDatabaseName(const Value: string);
- begin
- FDatabaseName := Value;
- end;
-
- procedure TIBValidationService.SetServiceStartOptions;
- var
- param: Integer;
- begin
- Action := isc_action_svc_repair;
- if FDatabaseName = '' then
- IBError(ibxeStartParamsError, [nil]);
- param := 0;
- if (SweepDB in Options) then
- param := param or isc_spb_rpr_sweep_db;
- if (ValidateDB in Options) then
- param := param or isc_spb_rpr_validate_db;
- ServiceStartParams := Char(isc_action_svc_repair);
- ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
- if param > 0 then
- ServiceStartAddParam (param, SPBConstantValues[isc_spb_options]);
- param := 0;
- if (LimboTransactions in Options) then
- param := param or isc_spb_rpr_list_limbo_trans;
- if (CheckDB in Options) then
- param := param or isc_spb_rpr_check_db;
- if (IgnoreChecksum in Options) then
- param := param or isc_spb_rpr_ignore_checksum;
- if (KillShadows in Options) then
- param := param or isc_spb_rpr_kill_shadows;
- if (MendDB in Options) then
- param := param or isc_spb_rpr_mend_db;
- if (ValidateFull in Options) then
- begin
- param := param or isc_spb_rpr_full;
- if not (MendDB in Options) then
- param := param or isc_spb_rpr_validate_db;
- end;
- if param > 0 then
- ServiceStartAddParam (param, SPBConstantValues[isc_spb_options]);
- end;
-
- { TIBSecurityService }
- constructor TIBSecurityService.Create(AOwner: TComponent);
- begin
- inherited Create(AOwner);
- FModifyParams := [];
- end;
-
- destructor TIBSecurityService.Destroy;
- var
- i : Integer;
- begin
- for i := 0 to High(FUserInfo) do
- FUserInfo[i].Free;
- FUserInfo := nil;
- inherited Destroy;
- end;
-
- procedure TIBSecurityService.FetchUserInfo;
- var
- i, RunLen: Integer;
- begin
- ServiceQueryParams := Char(isc_info_svc_get_users);
- InternalServiceQuery;
- RunLen := 0;
- if (OutputBuffer[RunLen] <> Char(isc_info_svc_get_users)) then
- IBError(ibxeOutputParsingError, [nil]);
- Inc(RunLen);
- for i := 0 to High(FUserInfo) do
- FUserInfo[i].Free;
- FUserInfo := nil;
- i := 0;
- { Don't have any use for the combined length
- so increment past by 2 }
- Inc(RunLen, 2);
- while (OutputBuffer[RunLen] <> Char(isc_info_end)) do
- begin
- if (i >= Length(FUSerInfo)) then
- SetLength(FUserInfo, i + 10);
- if (OutputBuffer[RunLen] <> Char(isc_spb_sec_username)) then
- IBError(ibxeOutputParsingError, [nil]);
- Inc(RunLen);
- if FUserInfo[i] = nil then
- FUserInfo[i] := TUserInfo.Create;
- FUserInfo[i].UserName := ParseString(RunLen);
- if (OutputBuffer[RunLen] <> Char(isc_spb_sec_firstname)) then
- IBError(ibxeOutputParsingError, [nil]);
- Inc(RunLen);
- FUserInfo[i].FirstName := ParseString(RunLen);
- if (OutputBuffer[RunLen] <> Char(isc_spb_sec_middlename)) then
- IBError(ibxeOutputParsingError, [nil]);
- Inc(RunLen);
- FUserInfo[i].MiddleName := ParseString(RunLen);
- if (OutputBuffer[RunLen] <> Char(isc_spb_sec_lastname)) then
- IBError(ibxeOutputParsingError, [nil]);
- Inc(RunLen);
- FUserInfo[i].LastName := ParseString(RunLen);
- if (OutputBuffer[RunLen] <> Char(isc_spb_sec_userId)) then
- IBError(ibxeOutputParsingError, [nil]);
- Inc(RunLen);
- FUserInfo[i].UserId := ParseInteger(RunLen);
- if (OutputBuffer[RunLen] <> Char(isc_spb_sec_groupid)) then
- IBError(ibxeOutputParsingError, [nil]);
- Inc(RunLen);
- FUserInfo[i].GroupID := ParseInteger(RunLen);
- Inc (i);
- end;
- if (i > 0) then
- SetLength(FUserInfo, i+1);
- end;
-
- function TIBSecurityService.GetUserInfo(Index: Integer): TUserInfo;
- begin
- if Index <= High(FUSerInfo) then
- result := FUserInfo[Index]
- else
- result := nil;
- end;
-
- function TIBSecurityService.GetUserInfoCount: Integer;
- begin
- Result := High(FUSerInfo);
- end;
-
- procedure TIBSecurityService.AddUser;
- begin
- SecurityAction := ActionAddUser;
- ServiceStart;
- end;
-
- procedure TIBSecurityService.DeleteUser;
- begin
- SecurityAction := ActionDeleteUser;
- ServiceStart;
- end;
-
- procedure TIBSecurityService.DisplayUsers;
- begin
- SecurityAction := ActionDisplayUser;
- ServiceStartParams := Char(isc_action_svc_display_user);
- InternalServiceStart;
- FetchUserInfo;
- end;
-
- procedure TIBSecurityService.DisplayUser(UserName: String);
- begin
- SecurityAction := ActionDisplayUser;
- ServiceStartParams := Char(isc_action_svc_display_user);
- ServiceStartAddParam (UserName, isc_spb_sec_username);
- InternalServiceStart;
- FetchUserInfo;
- end;
-
- procedure TIBSecurityService.ModifyUser;
- begin
- SecurityAction := ActionModifyUser;
- ServiceStart;
- end;
-
- procedure TIBSecurityService.SetSecurityAction (Value: TSecurityAction);
- begin
- FSecurityAction := Value;
- if Value = ActionDeleteUser then
- ClearParams;
- end;
-
- procedure TIBSecurityService.ClearParams;
- begin
- FModifyParams := [];
- FFirstName := '';
- FMiddleName := '';
- FLastName := '';
- FGroupID := 0;
- FUserID := 0;
- FPassword := '';
- end;
-
- procedure TIBSecurityService.SetFirstName (Value: String);
- begin
- FFirstName := Value;
- Include (FModifyParams, ModifyFirstName);
- end;
-
- procedure TIBSecurityService.SetMiddleName (Value: String);
- begin
- FMiddleName := Value;
- Include (FModifyParams, ModifyMiddleName);
- end;
-
- procedure TIBSecurityService.SetLastName (Value: String);
- begin
- FLastName := Value;
- Include (FModifyParams, ModifyLastName);
- end;
-
- procedure TIBSecurityService.SetPassword (Value: String);
- begin
- FPassword := Value;
- Include (FModifyParams, ModifyPassword);
- end;
-
- procedure TIBSecurityService.SetUserId (Value: Integer);
- begin
- FUserId := Value;
- Include (FModifyParams, ModifyUserId);
- end;
-
- procedure TIBSecurityService.SetGroupId (Value: Integer);
- begin
- FGroupId := Value;
- Include (FModifyParams, ModifyGroupId);
- end;
-
- procedure TIBSecurityService.Loaded;
- begin
- inherited Loaded;
- ClearParams;
- end;
-
- procedure TIBSecurityService.SetServiceStartOptions;
- var
- Len: UShort;
-
- begin
- case FSecurityAction of
- ActionAddUser:
- begin
- Action := isc_action_svc_add_user;
- if ( Pos(' ', FUserName) > 0 ) then
- IBError(ibxeStartParamsError, [nil]);
- Len := Length(FUserName);
- if (Len = 0) then
- IBError(ibxeStartParamsError, [nil]);
- ServiceStartParams := Char(isc_action_svc_add_user);
- ServiceStartAddParam (FUserName, isc_spb_sec_username);
- ServiceStartAddParam (FUserID, isc_spb_sec_userid);
- ServiceStartAddParam (FGroupID, isc_spb_sec_groupid);
- ServiceStartAddParam (FPassword, isc_spb_sec_password);
- ServiceStartAddParam (FFirstName, isc_spb_sec_firstname);
- ServiceStartAddParam (FMiddleName, isc_spb_sec_middlename);
- ServiceStartAddParam (FLastName, isc_spb_sec_lastname);
- ServiceStartAddParam (FSQLRole, SPBConstantValues[isc_spb_sql_role_name]);
- end;
- ActionDeleteUser:
- begin
- Action := isc_action_svc_delete_user;
- Len := Length(FUserName);
- if (Len = 0) then
- IBError(ibxeStartParamsError, [nil]);
- ServiceStartParams := Char(isc_action_svc_delete_user);
- ServiceStartAddParam (FUserName, isc_spb_sec_username);
- end;
- ActionModifyUser:
- begin
- Action := isc_action_svc_modify_user;
- Len := Length(FUserName);
- if (Len = 0) then
- IBError(ibxeStartParamsError, [nil]);
- ServiceStartParams := Char(isc_action_svc_modify_user);
- ServiceStartAddParam (FUserName, isc_spb_sec_username);
- if (ModifyUserId in FModifyParams) then
- ServiceStartAddParam (FUserID, isc_spb_sec_userid);
- if (ModifyGroupId in FModifyParams) then
- ServiceStartAddParam (FGroupID, isc_spb_sec_groupid);
- if (ModifyPassword in FModifyParams) then
- ServiceStartAddParam (FPassword, isc_spb_sec_password);
- if (ModifyFirstName in FModifyParams) then
- ServiceStartAddParam (FFirstName, isc_spb_sec_firstname);
- if (ModifyMiddleName in FModifyParams) then
- ServiceStartAddParam (FMiddleName, isc_spb_sec_middlename);
- if (ModifyLastName in FModifyParams) then
- ServiceStartAddParam (FLastName, isc_spb_sec_lastname);
- ServiceStartAddParam (FSQLRole, SPBConstantValues[isc_spb_sql_role_name]);
- end;
- end;
- ClearParams;
- end;
-
- { TIBUnStructuredService }
- constructor TIBControl