PageRenderTime 33ms CodeModel.GetById 15ms app.highlight 8ms RepoModel.GetById 1ms app.codeStats 1ms

/Gedemin/IBX/IBServices.pas

http://gedemin.googlecode.com/
Pascal | 2067 lines | 1848 code | 145 blank | 74 comment | 130 complexity | 510acada417b3f00f88d5dbf6e4c4692 MD5 | raw file

Large files files are truncated, but you can click here to view the full file

   1{************************************************************************}
   2{                                                                        }
   3{       Borland Delphi Visual Component Library                          }
   4{       InterBase Express core components                                }
   5{                                                                        }
   6{       Copyright (c) 1998-2001 Borland Software 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 may obtain }
  16{    a copy of the License at http://www.borland.com/interbase/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 Borland Software Corporation are Copyright      }
  24{       (C) Borland Software Corporation. All Rights Reserved.           }
  25{    Contributor(s): Jeff Overcash                                       }
  26{                                                                        }
  27{************************************************************************}
  28
  29{
  30  InterBase Express provides component interfaces to
  31  functions introduced in InterBase 6.0.  The Services
  32  components (TIB*Service, TIBServerProperties) and
  33  Install components (TIBInstall, TIBUninstall, TIBSetup)
  34  function only if you have installed InterBase 6.0 or
  35  later software
  36}
  37
  38unit IBServices;
  39
  40interface
  41
  42uses
  43  SysUtils, Classes, 
  44  Controls, Forms,
  45  IBDialogs, IBHeader, IB, IBExternals;
  46
  47const
  48  DefaultBufferSize = 32000;
  49
  50  SPBPrefix = 'isc_spb_';
  51  SPBConstantNames: array[1..isc_spb_last_spb_constant] of String = (
  52    'user_name',
  53    'sys_user_name',
  54    'sys_user_name_enc',
  55    'password',
  56    'password_enc',
  57    'command_line',
  58    'db_name',
  59    'verbose',
  60    'options',
  61    'connect_timeout',
  62    'dummy_packet_interval',
  63    'sql_role_name'
  64  );
  65
  66  SPBConstantValues: array[1..isc_spb_last_spb_constant] of Integer = (
  67    isc_spb_user_name_mapped_to_server,
  68    isc_spb_sys_user_name_mapped_to_server,
  69    isc_spb_sys_user_name_enc_mapped_to_server,
  70    isc_spb_password_mapped_to_server,
  71    isc_spb_password_enc_mapped_to_server,
  72    isc_spb_command_line_mapped_to_server,
  73    isc_spb_dbname_mapped_to_server,
  74    isc_spb_verbose_mapped_to_server,
  75    isc_spb_options_mapped_to_server,
  76    isc_spb_connect_timeout_mapped_to_server,
  77    isc_spb_dummy_packet_interval_mapped_to_server,
  78    isc_spb_sql_role_name_mapped_to_server
  79  );
  80
  81type
  82  TProtocol = (TCP, SPX, NamedPipe, Local);
  83  TOutputBufferOption = (ByLine, ByChunk);
  84
  85  TIBCustomService = class;
  86
  87  TLoginEvent = procedure(Database: TIBCustomService;
  88    LoginParams: TStrings) of object;
  89
  90  TIBCustomService = class(TComponent)
  91  private
  92    FIBLoaded: Boolean;
  93    FParamsChanged : Boolean;
  94    FSPB, FQuerySPB : PChar;
  95    FSPBLength, FQuerySPBLength : Short;
  96    FTraceFlags: TTraceFlags;
  97    FOnLogin: TLoginEvent;
  98    FLoginPrompt: Boolean;
  99    FBufferSize: Integer;
 100    FOutputBuffer: PChar;
 101    FQueryParams: String;
 102    FServerName: string;
 103    FHandle: TISC_SVC_HANDLE;
 104    FStreamedActive  : Boolean;
 105    FOnAttach: TNotifyEvent;
 106    FOutputBufferOption: TOutputBufferOption;
 107    FProtocol: TProtocol;
 108    FParams: TStrings;
 109    function GetActive: Boolean;
 110    function GetServiceParamBySPB(const Idx: Integer): String;
 111    procedure SetActive(const Value: Boolean);
 112    procedure SetBufferSize(const Value: Integer);
 113    procedure SetParams(const Value: TStrings);
 114    procedure SetServerName(const Value: string);
 115    procedure SetProtocol(const Value: TProtocol);
 116    procedure SetServiceParamBySPB(const Idx: Integer;
 117      const Value: String);
 118    function IndexOfSPBConst(st: String): Integer;
 119    procedure ParamsChange(Sender: TObject);
 120    procedure ParamsChanging(Sender: TObject);
 121    procedure CheckServerName;
 122    function Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
 123    function ParseString(var RunLen: Integer): string;
 124    function ParseInteger(var RunLen: Integer): Integer;
 125    procedure GenerateSPB(sl: TStrings; var SPB: String; var SPBLength: Short);
 126
 127  protected
 128    procedure Loaded; override;
 129    function Login: Boolean;
 130    procedure CheckActive;
 131    procedure CheckInactive;
 132    property OutputBuffer : PChar read FOutputBuffer;
 133    property OutputBufferOption : TOutputBufferOption read FOutputBufferOption write FOutputBufferOption;
 134    property BufferSize : Integer read FBufferSize write SetBufferSize default DefaultBufferSize;
 135    procedure InternalServiceQuery;
 136    property ServiceQueryParams: String read FQueryParams write FQueryParams;
 137
 138  public
 139    constructor Create(AOwner: TComponent); override;
 140    destructor Destroy; override;
 141    procedure Attach;
 142    procedure Detach;
 143    property Handle: TISC_SVC_HANDLE read FHandle;
 144    property ServiceParamBySPB[const Idx: Integer]: String read GetServiceParamBySPB
 145                                                      write SetServiceParamBySPB;
 146  published
 147    property Active: Boolean read GetActive write SetActive default False;
 148    property ServerName: string read FServerName write SetServerName;
 149    property Protocol: TProtocol read FProtocol write SetProtocol default Local;
 150    property Params: TStrings read FParams write SetParams;
 151    property LoginPrompt: Boolean read FLoginPrompt write FLoginPrompt default True;
 152    property TraceFlags: TTraceFlags read FTraceFlags write FTraceFlags;
 153    property OnAttach: TNotifyEvent read FOnAttach write FOnAttach;
 154    property OnLogin: TLoginEvent read FOnLogin write FOnLogin;
 155  end;
 156
 157  TDatabaseInfo = class
 158  public
 159    NoOfAttachments: Integer;
 160    NoOfDatabases: Integer;
 161    DbName: array of string;
 162    constructor Create;
 163    destructor Destroy; override;
 164  end;
 165
 166  TLicenseInfo = class
 167  public
 168    Key: array of string;
 169    Id: array of string;
 170    Desc: array of string;
 171    LicensedUsers: Integer;
 172    constructor Create;
 173    destructor Destroy; override;
 174  end;
 175
 176  TLicenseMaskInfo = class
 177  public
 178    LicenseMask: Integer;
 179    CapabilityMask: Integer;
 180  end;
 181
 182  TConfigFileData = class
 183  public
 184    ConfigFileValue: array of integer;
 185    ConfigFileKey: array of integer;
 186    constructor Create;
 187    destructor Destroy; override;
 188  end;
 189
 190  TConfigParams = class
 191  public
 192    ConfigFileData: TConfigFileData;
 193    ConfigFileParams: array of string;
 194    BaseLocation: string;
 195    LockFileLocation: string;
 196    MessageFileLocation: string;
 197    SecurityDatabaseLocation: string;
 198    constructor Create;
 199    destructor Destroy; override;
 200  end;
 201
 202  TVersionInfo = class
 203    ServerVersion: String;
 204    ServerImplementation: string;
 205    ServiceVersion: Integer;
 206  end;
 207
 208  TPropertyOption = (Database, License, LicenseMask, ConfigParameters, Version);
 209  TPropertyOptions = set of TPropertyOption;
 210
 211  TIBServerProperties = class(TIBCustomService)
 212  private
 213    FOptions: TPropertyOptions;
 214    FDatabaseInfo: TDatabaseInfo;
 215    FLicenseInfo: TLicenseInfo;
 216    FLicenseMaskInfo: TLicenseMaskInfo;
 217    FVersionInfo: TVersionInfo;
 218    FConfigParams: TConfigParams;
 219    procedure ParseConfigFileData(var RunLen: Integer);
 220  public
 221    constructor Create(AOwner: TComponent); override;
 222    destructor Destroy; override;
 223    procedure Fetch;
 224    procedure FetchDatabaseInfo;
 225    procedure FetchLicenseInfo;
 226    procedure FetchLicenseMaskInfo;
 227    procedure FetchConfigParams;
 228    procedure FetchVersionInfo;
 229    property DatabaseInfo: TDatabaseInfo read FDatabaseInfo;
 230    property LicenseInfo: TLicenseInfo read FLicenseInfo;
 231    property LicenseMaskInfo: TLicenseMaskInfo read FLicenseMaskInfo;
 232    property VersionInfo: TVersionInfo read FVersionInfo;
 233    property ConfigParams: TConfigParams read FConfigParams;
 234  published
 235    property Options : TPropertyOptions read FOptions write FOptions;
 236  end;
 237
 238  TIBControlService = class (TIBCustomService)
 239  private
 240    FStartParams: String;
 241    FStartSPB: PChar;
 242    FStartSPBLength: Integer;
 243    function GetIsServiceRunning: Boolean;
 244  protected
 245    property ServiceStartParams: String read FStartParams write FStartParams;
 246    procedure SetServiceStartOptions; virtual;
 247    procedure ServiceStartAddParam (Value: string; param: Integer); overload;
 248    procedure ServiceStartAddParam (Value: Integer; param: Integer); overload;
 249    procedure ServiceStartAddByteParam (Value: Byte; param: Integer);
 250    procedure InternalServiceStart;
 251
 252  public
 253    constructor Create(AOwner: TComponent); override;
 254    procedure ServiceStart; virtual;
 255    property IsServiceRunning : Boolean read GetIsServiceRunning;
 256  end;
 257
 258  TIBControlAndQueryService = class (TIBControlService)
 259  private
 260    FEof: Boolean;
 261    FAction: Integer;
 262    procedure SetAction(Value: Integer);
 263  protected
 264    property Action: Integer read FAction write SetAction;
 265  public
 266    constructor create (AOwner: TComponent); override;
 267    function GetNextLine : String;
 268    function GetNextChunk : String;
 269    property Eof: boolean read FEof;
 270  published
 271    property BufferSize;
 272  end;
 273
 274  //TShutdownMode = (Forced, DenyTransaction, DenyAttachment);
 275  TShutdownModeEx = (smeForce, smeAttachment, smeTransaction);
 276  TOperationMode = (omNormal, omMulti, omSingle, omFull);
 277
 278  TIBConfigService = class(TIBControlService)
 279  private
 280    FDatabaseName: string;
 281    procedure SetDatabaseName(const Value: string);
 282  protected
 283
 284  public
 285    procedure ServiceStart; override;
 286    //procedure ShutdownDatabase (Options: TShutdownMode; Wait: Integer);
 287    procedure ShutdownDatabase (Options: TShutdownModeEx; Wait: Integer; OperationMode: TOperationMode);
 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  published
 297    property DatabaseName: string read FDatabaseName write SetDatabaseName;
 298  end;
 299
 300  TLicensingAction = (LicenseAdd, LicenseRemove);
 301  TIBLicensingService = class(TIBControlService)
 302  private
 303    FID: String;
 304    FKey: String;
 305    FAction: TLicensingAction;
 306    procedure SetAction(Value: TLicensingAction);
 307  protected
 308    procedure SetServiceStartOptions; override;
 309  public
 310    procedure AddLicense;
 311    procedure RemoveLicense;
 312  published
 313    property Action: TLicensingAction read FAction write SetAction default LicenseAdd;
 314    property Key: String read FKey write FKey;
 315    property ID: String  read FID write FID;
 316  end;
 317
 318  TIBLogService = class(TIBControlAndQueryService)
 319  private
 320
 321  protected
 322    procedure SetServiceStartOptions; override;
 323  public
 324  published
 325  end;
 326
 327  TStatOption = (DataPages, DbLog, HeaderPages, IndexPages, SystemRelations);
 328  TStatOptions = set of TStatOption;
 329
 330  TIBStatisticalService = class(TIBControlAndQueryService)
 331  private
 332    FDatabaseName: string;
 333    FOptions: TStatOptions;
 334    procedure SetDatabaseName(const Value: string);
 335  protected
 336    procedure SetServiceStartOptions; override;
 337  public
 338  published
 339    property DatabaseName: string read FDatabaseName write SetDatabaseName;
 340    property Options :  TStatOptions read FOptions write FOptions;
 341  end;
 342
 343
 344  TIBBackupRestoreService = class(TIBControlAndQueryService)
 345  private
 346    FVerbose: Boolean;
 347  protected
 348  public
 349  published
 350    property Verbose : Boolean read FVerbose write FVerbose default False;
 351  end;
 352
 353  TBackupOption = (IgnoreChecksums, IgnoreLimbo, MetadataOnly, NoGarbageCollection,
 354    OldMetadataDesc, NonTransportable, ConvertExtTables);
 355  TBackupOptions = set of TBackupOption;
 356
 357  TIBBackupService = class (TIBBackupRestoreService)
 358  private
 359    FDatabaseName: string;
 360    FOptions: TBackupOptions;
 361    FBackupFile: TStrings;
 362    FBlockingFactor: Integer;
 363    procedure SetBackupFile(const Value: TStrings);
 364  protected
 365    procedure SetServiceStartOptions; override;
 366  public
 367    constructor Create(AOwner: TComponent); override;
 368    destructor Destroy; override;
 369
 370  published
 371    { a name=value pair of filename and length }
 372    property BackupFile: TStrings read FBackupFile write SetBackupFile;
 373    property BlockingFactor: Integer read FBlockingFactor write FBlockingFactor;
 374    property DatabaseName: string read FDatabaseName write FDatabaseName;
 375    property Options : TBackupOptions read FOptions write FOptions;
 376  end;
 377
 378  TRestoreOption = (DeactivateIndexes, NoShadow, NoValidityCheck, OneRelationAtATime,
 379    Replace, CreateNewDB, UseAllSpace, FixFss);
 380
 381  TRestoreOptions = set of TRestoreOption;
 382  TIBRestoreService = class (TIBBackupRestoreService)
 383  private
 384    FDatabaseName: TStrings;
 385    FBackupFile: TStrings;
 386    FOptions: TRestoreOptions;
 387    FPageSize: Integer;
 388    FPageBuffers: Integer;
 389    FFixFssCharacterSet: String;
 390    procedure SetBackupFile(const Value: TStrings);
 391    procedure SetDatabaseName(const Value: TStrings);
 392  protected
 393    procedure SetServiceStartOptions; override;
 394  public
 395    constructor Create(AOwner: TComponent); override;
 396    destructor Destroy; override;
 397  published
 398    { a name=value pair of filename and length }
 399    property DatabaseName: TStrings read FDatabaseName write SetDatabaseName;
 400    property BackupFile: TStrings read FBackupFile write SetBackupFile;
 401    property PageSize: Integer read FPageSize write FPageSize default 4096;
 402    property PageBuffers: Integer read FPageBuffers write FPageBuffers;
 403    property FixFssCharacterSet: String read FFixFssCharacterSet write FFixFssCharacterSet;
 404    property Options : TRestoreOptions read FOptions write FOptions default [CreateNewDB];
 405  end;
 406
 407  TValidateOption = (LimboTransactions, CheckDB, IgnoreChecksum, KillShadows, MendDB,
 408    SweepDB, ValidateDB, ValidateFull);
 409  TValidateOptions = set of TValidateOption;
 410
 411  TTransactionGlobalAction = (CommitGlobal, RollbackGlobal, RecoverTwoPhaseGlobal,
 412                             NoGlobalAction);
 413  TTransactionState = (LimboState, CommitState, RollbackState, UnknownState);
 414  TTransactionAdvise = (CommitAdvise, RollbackAdvise, UnknownAdvise);
 415  TTransactionAction = (CommitAction, RollbackAction);
 416
 417  TLimboTransactionInfo = class
 418  public
 419    MultiDatabase: Boolean;
 420    ID: Integer;
 421    HostSite: String;
 422    RemoteSite: String;
 423    RemoteDatabasePath: String;
 424    State: TTransactionState;
 425    Advise: TTransactionAdvise;
 426    Action: TTransactionAction;
 427  end;
 428
 429  TIBValidationService = class(TIBControlAndQueryService)
 430  private
 431    FDatabaseName: string;
 432    FOptions: TValidateOptions;
 433    FLimboTransactionInfo: array of TLimboTransactionInfo;
 434    FGlobalAction: TTransactionGlobalAction;
 435    procedure SetDatabaseName(const Value: string);
 436    function GetLimboTransactionInfo(index: integer): TLimboTransactionInfo;
 437    function GetLimboTransactionInfoCount: integer;
 438
 439  protected
 440    procedure SetServiceStartOptions; override;
 441  public
 442    constructor Create(AOwner: TComponent); override;
 443    destructor Destroy; override;
 444    procedure FetchLimboTransactionInfo;
 445    procedure FixLimboTransactionErrors;
 446    property LimboTransactionInfo[Index: integer]: TLimboTransactionInfo read GetLimboTransactionInfo;
 447    property LimboTransactionInfoCount: Integer read GetLimboTransactionInfoCount;
 448
 449  published
 450    property DatabaseName: string read FDatabaseName write SetDatabaseName;
 451    property Options: TValidateOptions read FOptions write FOptions;
 452    property GlobalAction: TTransactionGlobalAction read FGlobalAction
 453                                         write FGlobalAction;
 454  end;
 455
 456  TUserInfo = class
 457  public
 458    UserName: string;
 459    FirstName: string;
 460    MiddleName: string;
 461    LastName: string;
 462    GroupID: Integer;
 463    UserID: Integer;
 464  end;
 465
 466  TSecurityAction = (ActionAddUser, ActionDeleteUser, ActionModifyUser, ActionDisplayUser);
 467  TSecurityModifyParam = (ModifyFirstName, ModifyMiddleName, ModifyLastName, ModifyUserId,
 468                         ModifyGroupId, ModifyPassword);
 469  TSecurityModifyParams = set of TSecurityModifyParam;
 470
 471  TIBSecurityService = class(TIBControlAndQueryService)
 472  private
 473    FUserID: Integer;
 474    FGroupID: Integer;
 475    FFirstName: string;
 476    FUserName: string;
 477    FPassword: string;
 478    FSQLRole: string;
 479    FLastName: string;
 480    FMiddleName: string;
 481    FUserInfo: array of TUserInfo;
 482    FSecurityAction: TSecurityAction;
 483    FModifyParams: TSecurityModifyParams;
 484    procedure ClearParams;
 485    procedure SetSecurityAction (Value: TSecurityAction);
 486    procedure SetFirstName (Value: String);
 487    procedure SetMiddleName (Value: String);
 488    procedure SetLastName (Value: String);
 489    procedure SetPassword (Value: String);
 490    procedure SetUserId (Value: Integer);
 491    procedure SetGroupId (Value: Integer);
 492
 493    procedure FetchUserInfo;
 494    function GetUserInfo(Index: Integer): TUserInfo;
 495    function GetUserInfoCount: Integer;
 496
 497  protected
 498    procedure Loaded; override;
 499    procedure SetServiceStartOptions; override;
 500  public
 501    constructor Create(AOwner: TComponent); override;
 502    destructor Destroy; override;
 503    procedure DisplayUsers;
 504    procedure DisplayUser(UserName: string);
 505    procedure AddUser;
 506    procedure DeleteUser;
 507    procedure ModifyUser;
 508    property  UserInfo[Index: Integer]: TUserInfo read GetUserInfo;
 509    property  UserInfoCount: Integer read GetUserInfoCount;
 510
 511  published
 512    property SecurityAction: TSecurityAction read FSecurityAction
 513                                             write SetSecurityAction;
 514    property SQlRole : string read FSQLRole write FSQLrole;
 515    property UserName : string read FUserName write FUserName;
 516    property FirstName : string read FFirstName write SetFirstName;
 517    property MiddleName : string read FMiddleName write SetMiddleName;
 518    property LastName : string read FLastName write SetLastName;
 519    property UserID : Integer read FUserID write SetUserID;
 520    property GroupID : Integer read FGroupID write SetGroupID;
 521    property Password : string read FPassword write setPassword;
 522  end;
 523
 524
 525implementation
 526
 527uses
 528  IBIntf,
 529  {$IFDEF GEDEMIN}
 530  IBSQLMonitor_Gedemin
 531  {$ELSE}
 532  IBSQLMonitor
 533  {$ENDIF}
 534  ;
 535
 536{ TIBCustomService }
 537
 538procedure TIBCustomService.Attach;
 539var
 540  SPB: String;
 541  ConnectString: String;
 542begin
 543  CheckInactive;
 544  CheckServerName;
 545
 546  if FLoginPrompt and not Login then
 547    IBError(ibxeOperationCancelled, [nil]);
 548
 549  { Generate a new SPB if necessary }
 550  if FParamsChanged then
 551  begin
 552    FParamsChanged := False;
 553    GenerateSPB(FParams, SPB, FSPBLength);
 554    IBAlloc(FSPB, 0, FsPBLength);
 555    Move(SPB[1], FSPB[0], FSPBLength);
 556  end;
 557  case FProtocol of
 558    TCP: ConnectString := FServerName + ':service_mgr'; {do not localize}
 559    SPX: ConnectString := FServerName + '@service_mgr'; {do not localize}
 560    NamedPipe: ConnectString := '\\' + FServerName + '\service_mgr'; {do not localize}
 561    Local: ConnectString := 'service_mgr'; {do not localize}
 562  end;
 563  if call(isc_service_attach(StatusVector, Length(ConnectString),
 564                         PChar(ConnectString), @FHandle,
 565                         FSPBLength, FSPB), False) > 0 then
 566  begin
 567    FHandle := nil;
 568    IBDataBaseError;
 569  end;
 570
 571  if Assigned(FOnAttach) then
 572    FOnAttach(Self);
 573  MonitorHook.ServiceAttach(Self);
 574end;
 575
 576procedure TIBCustomService.Loaded;
 577begin
 578  inherited Loaded;
 579  try
 580    if FStreamedActive and (not Active) then
 581      Attach;
 582  except
 583    if csDesigning in ComponentState then
 584      Application.HandleException(Self)
 585    else
 586      raise;
 587  end;
 588end;
 589
 590function TIBCustomService.Login: Boolean;
 591var
 592  IndexOfUser, IndexOfPassword: Integer;
 593  Username, Password: String;
 594  LoginParams: TStrings;
 595begin
 596  if Assigned(FOnLogin) then begin
 597    result := True;
 598    LoginParams := TStringList.Create;
 599    try
 600      LoginParams.Assign(Params);
 601      FOnLogin(Self, LoginParams);
 602      Params.Assign (LoginParams);
 603    finally
 604      LoginParams.Free;
 605    end;
 606  end
 607  else
 608  begin
 609    IndexOfUser := IndexOfSPBConst(SPBConstantNames[isc_spb_user_name]);
 610    if IndexOfUser <> -1 then
 611      Username := Copy(Params[IndexOfUser],
 612                                         Pos('=', Params[IndexOfUser]) + 1, {mbcs ok}
 613                                         Length(Params[IndexOfUser]));
 614    IndexOfPassword := IndexOfSPBConst(SPBConstantNames[isc_spb_password]);
 615    if IndexOfPassword <> -1 then
 616      Password := Copy(Params[IndexOfPassword],
 617                                         Pos('=', Params[IndexOfPassword]) + 1, {mbcs ok}
 618                                         Length(Params[IndexOfPassword]));
 619    result := ServerLoginDialog(serverName, Username, Password);
 620    if result then
 621    begin
 622      IndexOfPassword := IndexOfSPBConst(SPBConstantNames[isc_spb_password]);
 623      if IndexOfUser = -1 then
 624        Params.Add(SPBConstantNames[isc_spb_user_name] + '=' + Username)
 625      else
 626        Params[IndexOfUser] := SPBConstantNames[isc_spb_user_name] +
 627                                 '=' + Username;
 628      if IndexOfPassword = -1 then
 629        Params.Add(SPBConstantNames[isc_spb_password] + '=' + Password)
 630      else
 631        Params[IndexOfPassword] := SPBConstantNames[isc_spb_password] +
 632                                     '=' + Password;
 633    end;
 634  end;
 635end;
 636
 637procedure TIBCustomService.CheckActive;
 638begin
 639  if FStreamedActive and (not Active) then
 640    Loaded;
 641  if FHandle = nil then
 642    IBError(ibxeServiceActive, [nil]);
 643end;
 644
 645procedure TIBCustomService.CheckInactive;
 646begin
 647  if FHandle <> nil then
 648    IBError(ibxeServiceInActive, [nil]);
 649end;
 650
 651constructor TIBCustomService.Create(AOwner: TComponent);
 652begin
 653  inherited Create(AOwner);
 654  FIBLoaded := False;
 655  CheckIBLoaded;
 656  FIBLoaded := True;
 657  FProtocol := local;
 658  FserverName := '';
 659  FParams := TStringList.Create;
 660  FParamsChanged := True;
 661  TStringList(FParams).OnChange := ParamsChange;
 662  TStringList(FParams).OnChanging := ParamsChanging;
 663  FSPB := nil;
 664  FQuerySPB := nil;
 665  FBufferSize := DefaultBufferSize;
 666  FHandle := nil;
 667  FLoginPrompt := True;
 668  FTraceFlags := [];
 669  FOutputbuffer := nil;
 670end;
 671
 672destructor TIBCustomService.Destroy;
 673begin
 674  if FIBLoaded then
 675  begin
 676    if FHandle <> nil then
 677      Detach;
 678    FreeMem(FSPB);
 679    FSPB := nil;
 680    FParams.Free;
 681  end;
 682  ReallocMem(FOutputBuffer, 0);
 683  inherited Destroy;
 684end;
 685
 686procedure TIBCustomService.Detach;
 687begin
 688  CheckActive;
 689  if (Call(isc_service_detach(StatusVector, @FHandle), False) > 0) then
 690  begin
 691    FHandle := nil;
 692    IBDataBaseError;
 693  end
 694  else
 695    FHandle := nil;
 696  MonitorHook.ServiceDetach(Self);
 697end;
 698
 699function TIBCustomService.GetActive: Boolean;
 700begin
 701  result := FHandle <> nil;
 702end;
 703
 704function TIBCustomService.GetServiceParamBySPB(const Idx: Integer): String;
 705var
 706  ConstIdx, EqualsIdx: Integer;
 707begin
 708  if (Idx > 0) and (Idx <= isc_spb_last_spb_constant) then
 709  begin
 710    ConstIdx := IndexOfSPBConst(SPBConstantNames[Idx]);
 711    if ConstIdx = -1 then
 712      result := ''
 713    else
 714    begin
 715      result := Params[ConstIdx];
 716      EqualsIdx := Pos('=', result); {mbcs ok}
 717      if EqualsIdx = 0 then
 718        result := ''
 719      else
 720        result := Copy(result, EqualsIdx + 1, Length(result));
 721    end;
 722  end
 723  else
 724    result := '';
 725end;
 726
 727procedure TIBCustomService.InternalServiceQuery;
 728begin
 729  FQuerySPBLength := Length(FQueryParams);
 730  if FQuerySPBLength = 0 then
 731    IBError(ibxeQueryParamsError, [nil]);
 732  IBAlloc(FQuerySPB, 0, FQuerySPBLength);
 733  Move(FQueryParams[1], FQuerySPB[0], FQuerySPBLength);
 734  if (FOutputBuffer = nil) then
 735    IBAlloc(FOutputBuffer, 0, FBufferSize);
 736  try
 737    if call(isc_service_query(StatusVector, @FHandle, nil, 0, nil,
 738                           FQuerySPBLength, FQuerySPB,
 739                           FBufferSize, FOutputBuffer), False) > 0 then
 740    begin
 741      FHandle := nil;
 742      IBDataBaseError;
 743    end;
 744  finally
 745    FreeMem(FQuerySPB);
 746    FQuerySPB := nil;
 747    FQuerySPBLength := 0;
 748    FQueryParams := '';
 749  end;
 750  MonitorHook.ServiceQuery(Self);
 751end;
 752
 753procedure TIBCustomService.SetActive(const Value: Boolean);
 754begin
 755  if csReading in ComponentState then
 756    FStreamedActive := Value
 757  else
 758    if Value <> Active then   
 759      if Value then
 760        Attach
 761      else
 762        Detach;
 763end;
 764
 765procedure TIBCustomService.SetBufferSize(const Value: Integer);
 766begin
 767  if (Value <> FBufferSize) then
 768  begin
 769    FBufferSize := Value;
 770    if FOutputBuffer <> nil then
 771      IBAlloc(FOutputBuffer, 0, FBufferSize);
 772  end;
 773end;
 774
 775procedure TIBCustomService.SetParams(const Value: TStrings);
 776begin
 777  FParams.Assign(Value);
 778end;
 779
 780procedure TIBCustomService.SetServerName(const Value: string);
 781begin
 782  if FServerName <> Value then
 783  begin
 784    CheckInactive;
 785    FServerName := Value;
 786    if (FProtocol = Local) and (FServerName <> '') then
 787      FProtocol := TCP
 788    else
 789      if (FProtocol <> Local) and (FServerName = '') then
 790        FProtocol := Local;
 791  end;
 792end;
 793
 794procedure TIBCustomService.SetProtocol(const Value: TProtocol);
 795begin
 796  if FProtocol <> Value then
 797  begin
 798    CheckInactive;
 799    FProtocol := Value;
 800    if (Value = Local) then
 801      FServerName := '';
 802  end;
 803end;
 804
 805procedure TIBCustomService.SetServiceParamBySPB(const Idx: Integer;
 806  const Value: String);
 807var
 808  ConstIdx: Integer;
 809begin
 810  ConstIdx := IndexOfSPBConst(SPBConstantNames[Idx]);
 811  if (Value = '') then
 812  begin
 813    if ConstIdx <> -1 then
 814      Params.Delete(ConstIdx);
 815  end
 816  else
 817  begin
 818    if (ConstIdx = -1) then
 819      Params.Add(SPBConstantNames[Idx] + '=' + Value)
 820    else
 821      Params[ConstIdx] := SPBConstantNames[Idx] + '=' + Value;
 822  end;
 823end;
 824
 825function TIBCustomService.IndexOfSPBConst(st: String): Integer;
 826var
 827  i, pos_of_str: Integer;
 828begin
 829  result := -1;
 830  for i := 0 to Params.Count - 1 do
 831  begin
 832    pos_of_str := Pos(st, Params[i]); {mbcs ok}
 833    if (pos_of_str = 1) or (pos_of_str = Length(SPBPrefix) + 1) then
 834    begin
 835      result := i;
 836      break;
 837    end;
 838  end;
 839end;
 840
 841procedure TIBCustomService.ParamsChange(Sender: TObject);
 842begin
 843  FParamsChanged := True;
 844end;
 845
 846procedure TIBCustomService.ParamsChanging(Sender: TObject);
 847begin
 848  CheckInactive;
 849end;
 850
 851procedure TIBCustomService.CheckServerName;
 852begin
 853  if (FServerName = '') and (FProtocol <> Local) then
 854    IBError(ibxeServerNameMissing, [nil]);
 855end;
 856
 857function TIBCustomService.Call(ErrCode: ISC_STATUS;
 858  RaiseError: Boolean): ISC_STATUS;
 859begin
 860  result := ErrCode;
 861  if RaiseError and (ErrCode > 0) then
 862    IBDataBaseError;
 863end;
 864
 865function TIBCustomService.ParseString(var RunLen: Integer): string;
 866var
 867  Len: UShort;
 868  tmp: Char;
 869begin
 870  Len := isc_vax_integer(OutputBuffer + RunLen, 2);
 871  RunLen := RunLen + 2;
 872  if (Len <> 0) then
 873  begin
 874    tmp := OutputBuffer[RunLen + Len];
 875    OutputBuffer[RunLen + Len] := #0;
 876    result := String(PChar(@OutputBuffer[RunLen]));
 877    OutputBuffer[RunLen + Len] := tmp;
 878    RunLen := RunLen + Len;
 879  end
 880  else
 881    result := '';
 882end;
 883
 884function TIBCustomService.ParseInteger(var RunLen: Integer): Integer;
 885begin
 886  result := isc_vax_integer(OutputBuffer + RunLen, 4);
 887  RunLen := RunLen + 4;
 888end;
 889
 890{
 891 * GenerateSPB -
 892 *  Given a string containing a textual representation
 893 *  of the Service parameters, generate a service
 894 *  parameter buffer, and return it and its length
 895 *  in SPB and SPBLength, respectively.
 896}
 897procedure TIBCustomService.GenerateSPB(sl: TStrings; var SPB: String;
 898  var SPBLength: Short);
 899var
 900  i, j : Integer;
 901  SPBVal, SPBServerVal: UShort;
 902  param_name, param_value: String;
 903begin
 904  { The SPB is initially empty, with the exception that
 905   the SPB version must be the first byte of the string.
 906  }
 907  SPBLength := 2;
 908  SPB := Char(isc_spb_version);
 909  SPB := SPB + Char(isc_spb_current_version);
 910  { Iterate through the textual service parameters, constructing
 911   a SPB on-the-fly}
 912  for i := 0 to sl.Count - 1 do
 913  begin
 914   { Get the parameter's name and value from the list,
 915     and make sure that the name is all lowercase with
 916     no leading 'isc_spb_' prefix }
 917    if (Trim(sl.Names[i]) = '') then
 918      continue;
 919    param_name := LowerCase(sl.Names[i]); {mbcs ok}
 920    param_value := Copy(sl[i], Pos('=', sl[i]) + 1, Length(sl[i])); {mbcs ok}
 921    if (Pos(SPBPrefix, param_name) = 1) then {mbcs ok}
 922      Delete(param_name, 1, Length(SPBPrefix));
 923    { We want to translate the parameter name to some integer
 924      value. We do this by scanning through a list of known
 925      service parameter names (SPBConstantNames, defined above). }
 926    SPBVal := 0;
 927    SPBServerVal := 0;
 928    { Find the parameter }
 929    for j := 1 to isc_spb_last_spb_constant do
 930      if (param_name = SPBConstantNames[j]) then
 931      begin
 932        SPBVal := j;
 933        SPBServerVal := SPBConstantValues[j];
 934        break;
 935      end;
 936    case SPBVal of
 937      isc_spb_user_name, isc_spb_password:
 938      begin
 939        SPB := SPB +
 940               Char(SPBServerVal) +
 941               Char(Length(param_value)) +
 942               param_value;
 943        Inc(SPBLength, 2 + Length(param_value));
 944      end;
 945      else
 946      begin
 947        if (SPBVal > 0) and
 948           (SPBVal <= isc_dpb_last_dpb_constant) then
 949          IBError(ibxeSPBConstantNotSupported,
 950                   [SPBConstantNames[SPBVal]])
 951        else
 952          IBError(ibxeSPBConstantUnknown, [SPBVal]);
 953      end;
 954    end;
 955  end;
 956end;
 957
 958{ TIBServerProperties }
 959constructor TIBServerProperties.Create(AOwner: TComponent);
 960begin
 961  inherited Create(AOwner);
 962  FDatabaseInfo := TDatabaseInfo.Create;
 963  FLicenseInfo := TLicenseInfo.Create;
 964  FLicenseMaskInfo := TLicenseMaskInfo.Create;
 965  FVersionInfo := TVersionInfo.Create;
 966  FConfigParams := TConfigParams.Create;
 967end;
 968
 969destructor TIBServerProperties.Destroy;
 970begin
 971  FDatabaseInfo.Free;
 972  FLicenseInfo.Free;
 973  FLicenseMaskInfo.Free;
 974  FVersionInfo.Free;
 975  FConfigParams.Free;
 976  inherited Destroy;
 977end;
 978
 979procedure TIBServerProperties.ParseConfigFileData(var RunLen: Integer);
 980begin
 981  Inc(RunLen);
 982  with FConfigParams.ConfigFileData do
 983  begin
 984    SetLength (ConfigFileValue, Length(ConfigFileValue)+1);
 985    SetLength (ConfigFileKey, Length(ConfigFileKey)+1);
 986
 987    ConfigFileKey[High(ConfigFileKey)] := Integer(OutputBuffer[RunLen-1]);
 988    ConfigFileValue[High(ConfigFileValue)] := ParseInteger(RunLen);
 989  end;
 990end;
 991
 992procedure TIBServerProperties.Fetch;
 993begin
 994  if (Database in Options) then
 995    FetchDatabaseInfo;
 996  if (License in Options) then
 997    FetchLicenseInfo;
 998  if (LicenseMask in Options) then
 999    FetchLicenseMaskInfo;
1000  if (ConfigParameters in Options) then
1001    FetchConfigParams;
1002  if (Version in Options) then
1003    FetchVersionInfo;
1004end;
1005
1006procedure TIBServerProperties.FetchConfigParams;
1007var
1008  RunLen: Integer;
1009
1010begin
1011  ServiceQueryParams := Char(isc_info_svc_get_config) +
1012                        Char(isc_info_svc_get_env) +
1013                        Char(isc_info_svc_get_env_lock) +
1014                        Char(isc_info_svc_get_env_msg) +
1015                        Char(isc_info_svc_user_dbpath);
1016
1017  InternalServiceQuery;
1018  RunLen := 0;
1019  While (not (Integer(OutputBuffer[RunLen]) = isc_info_end)) do
1020  begin
1021    case Integer(OutputBuffer[RunLen]) of
1022      isc_info_svc_get_config:
1023      begin
1024        FConfigParams.ConfigFileData.ConfigFileKey := nil;
1025        FConfigParams.ConfigFileData.ConfigFileValue := nil;
1026        Inc (RunLen);
1027        while (not (Integer(OutputBuffer[RunLen]) = isc_info_flag_end)) do
1028          ParseConfigFileData (RunLen);
1029        if (Integer(OutputBuffer[RunLen]) = isc_info_flag_end) then
1030          Inc (RunLen);
1031      end;
1032
1033      isc_info_svc_get_env:
1034      begin
1035        Inc (RunLen);
1036        FConfigParams.BaseLocation := ParseString(RunLen);
1037      end;
1038
1039      isc_info_svc_get_env_lock:
1040      begin
1041        Inc (RunLen);
1042        FConfigParams.LockFileLocation := ParseString(RunLen);
1043      end;
1044
1045      isc_info_svc_get_env_msg:
1046      begin
1047        Inc (RunLen);
1048        FConfigParams.MessageFileLocation := ParseString(RunLen);
1049      end;
1050
1051      isc_info_svc_user_dbpath:
1052      begin
1053        Inc (RunLen);
1054        FConfigParams.SecurityDatabaseLocation := ParseString(RunLen);
1055      end;
1056      else
1057        IBError(ibxeOutputParsingError, [nil]);
1058    end;
1059  end;
1060end;
1061
1062procedure TIBServerProperties.FetchDatabaseInfo;
1063var
1064  i, RunLen: Integer;
1065begin
1066  ServiceQueryParams := Char(isc_info_svc_svr_db_info);
1067  InternalServiceQuery;
1068  if (OutputBuffer[0] <> Char(isc_info_svc_svr_db_info)) then
1069      IBError(ibxeOutputParsingError, [nil]);
1070  RunLen := 1;
1071  if (OutputBuffer[RunLen] <> Char(isc_spb_num_att)) then
1072      IBError(ibxeOutputParsingError, [nil]);
1073  Inc(RunLen);
1074  FDatabaseInfo.NoOfAttachments := ParseInteger(RunLen);
1075  if (OutputBuffer[RunLen] <> Char(isc_spb_num_db)) then
1076      IBError(ibxeOutputParsingError, [nil]);
1077  Inc(RunLen);
1078  FDatabaseInfo.NoOfDatabases := ParseInteger(RunLen);
1079  FDatabaseInfo.DbName := nil;
1080  SetLength(FDatabaseInfo.DbName, FDatabaseInfo.NoOfDatabases);
1081  i := 0;
1082  while (OutputBuffer[RunLen] <> Char(isc_info_flag_end)) do
1083  begin
1084    if (OutputBuffer[RunLen] <> Char(SPBConstantValues[isc_spb_dbname])) then
1085      IBError(ibxeOutputParsingError, [nil]);
1086    Inc(RunLen);
1087    FDatabaseInfo.DbName[i] := ParseString(RunLen);
1088    Inc (i);
1089  end;
1090end;
1091
1092procedure TIBServerProperties.FetchLicenseInfo;
1093var
1094  i, RunLen: Integer;
1095  done: Integer;
1096begin
1097  ServiceQueryParams := Char(isc_info_svc_get_license) +
1098                        Char(isc_info_svc_get_licensed_users);
1099  InternalServiceQuery;
1100  RunLen := 0;
1101  done := 0;
1102  i := 0;
1103  FLicenseInfo.key := nil;
1104  FLicenseInfo.id := nil;
1105  FLicenseInfo.desc := nil;
1106
1107  While done < 2 do begin
1108    Inc(Done);
1109    Inc(RunLen);
1110    case Integer(OutputBuffer[RunLen-1]) of
1111      isc_info_svc_get_license:
1112      begin
1113        while (OutputBuffer[RunLen] <> Char(isc_info_flag_end)) do
1114        begin
1115          if (i >= Length(FLicenseInfo.key)) then
1116          begin
1117            SetLength(FLicenseInfo.key, i + 10);
1118            SetLength(FLicenseInfo.id, i + 10);
1119            SetLength(FLicenseInfo.desc, i + 10);
1120          end;
1121          if (OutputBuffer[RunLen] <> Char(isc_spb_lic_id)) then
1122              IBError(ibxeOutputParsingError, [nil]);
1123          Inc(RunLen);
1124          FLicenseInfo.id[i] := ParseString(RunLen);
1125          if (OutputBuffer[RunLen] <> Char(isc_spb_lic_key)) then
1126              IBError(ibxeOutputParsingError, [nil]);
1127          Inc(RunLen);
1128          FLicenseInfo.key[i] := ParseString(RunLen);
1129          if (OutputBuffer[RunLen] <> Char(7)) then
1130              IBError(ibxeOutputParsingError, [nil]);
1131          Inc(RunLen);
1132          FLicenseInfo.desc[i] := ParseString(RunLen);
1133          Inc(i);
1134        end;
1135        Inc(RunLen);
1136        if (Length(FLicenseInfo.key) > i) then
1137        begin
1138          SetLength(FLicenseInfo.key, i);
1139          SetLength(FLicenseInfo.id, i);
1140          SetLength(FLicenseInfo.desc, i);
1141        end;
1142      end;
1143      isc_info_svc_get_licensed_users:
1144        FLicenseInfo.LicensedUsers := ParseInteger(RunLen);
1145      else
1146        IBError(ibxeOutputParsingError, [nil]);
1147    end;
1148  end;
1149end;
1150
1151procedure TIBServerProperties.FetchLicenseMaskInfo();
1152var
1153  done,RunLen:integer;
1154begin
1155  ServiceQueryParams := Char(isc_info_svc_get_license_mask) +
1156                        Char(isc_info_svc_capabilities);
1157  InternalServiceQuery;
1158  RunLen := 0;
1159  done := 0;
1160  While done <= 1 do
1161  begin
1162    Inc(done);
1163    Inc(RunLen);
1164    case Integer(OutputBuffer[RunLen-1]) of
1165      isc_info_svc_get_license_mask:
1166        FLicenseMaskInfo.LicenseMask := ParseInteger(RunLen);
1167      isc_info_svc_capabilities:
1168        FLicenseMaskInfo.CapabilityMask := ParseInteger(RunLen);
1169      else
1170        IBError(ibxeOutputParsingError, [nil]);
1171    end;
1172  end;
1173end;
1174
1175
1176procedure TIBServerProperties.FetchVersionInfo;
1177var
1178  RunLen: Integer;
1179  done: Integer;
1180begin
1181  ServiceQueryParams := Char(isc_info_svc_version) +
1182                        Char(isc_info_svc_server_version) +
1183                        Char(isc_info_svc_implementation);
1184  InternalServiceQuery;
1185  RunLen := 0;
1186  done := 0;
1187
1188  While done <= 2 do
1189  begin
1190    Inc(done);
1191    Inc(RunLen);
1192    case Integer(OutputBuffer[RunLen-1]) of
1193      isc_info_svc_version:
1194        FVersionInfo.ServiceVersion := ParseInteger(RunLen);
1195      isc_info_svc_server_version:
1196        FVersionInfo.ServerVersion := ParseString(RunLen);
1197      isc_info_svc_implementation:
1198        FVersionInfo.ServerImplementation := ParseString(RunLen);
1199      else
1200        IBError(ibxeOutputParsingError, [nil]);
1201    end;
1202  end;
1203end;
1204
1205{ TIBControlService }
1206procedure TIBControlService.SetServiceStartOptions;
1207begin
1208
1209end;
1210
1211function TIBControlService.GetIsServiceRunning: Boolean;
1212var
1213  RunLen: Integer;
1214begin
1215  ServiceQueryParams := Char(isc_info_svc_running);
1216  InternalServiceQuery;
1217  if (OutputBuffer[0] <> Char(isc_info_svc_running)) then
1218    IBError(ibxeOutputParsingError, [nil]);
1219  RunLen := 1;
1220  if (ParseInteger(RunLen) = 1) then
1221    result := True
1222  else
1223    result := False;
1224end;
1225
1226procedure TIBControlService.ServiceStartAddParam (Value: string; param: Integer);
1227var
1228  Len: UShort;
1229begin
1230  Len := Length(Value);
1231  if Len > 0 then
1232  begin
1233    FStartParams  := FStartParams +
1234                     Char(Param) +
1235                     PChar(@Len)[0] +
1236                     PChar(@Len)[1] +
1237                     Value;
1238  end;
1239end;
1240
1241procedure TIBControlService.ServiceStartAddParam (Value: Integer; param: Integer);
1242begin
1243  FStartParams  := FStartParams +
1244                   Char(Param) +
1245                   PChar(@Value)[0] +
1246                   PChar(@Value)[1] +
1247                   PChar(@Value)[2] +
1248                   PChar(@Value)[3];
1249end;
1250
1251procedure TIBControlService.ServiceStartAddByteParam (Value: Byte; param: Integer);
1252begin
1253  FStartParams  := FStartParams +
1254                   Char(Param) +
1255                   PChar(@Value)[0];
1256end;
1257
1258constructor TIBControlService.Create(AOwner: TComponent);
1259begin
1260  inherited create(AOwner);
1261  FStartParams := '';
1262  FStartSPB := nil;
1263  FStartSPBLength := 0;
1264end;
1265
1266procedure TIBControlService.InternalServiceStart;
1267begin
1268  FStartSPBLength := Length(FStartParams);
1269  if FStartSPBLength = 0 then
1270    IBError(ibxeStartParamsError, [nil]);
1271  IBAlloc(FStartSPB, 0, FStartSPBLength);
1272  Move(FStartParams[1], FStartSPB[0], FstartSPBLength);
1273  try
1274    if call(isc_service_start(StatusVector, @FHandle, nil,
1275                           FStartSPBLength, FStartSPB), False) > 0 then
1276    begin
1277      FHandle := nil;
1278      IBDataBaseError;
1279    end;
1280  finally
1281    FreeMem(FStartSPB);
1282    FStartSPB := nil;
1283    FStartSPBLength := 0;
1284    FStartParams := '';
1285  end;
1286  MonitorHook.ServiceStart(Self);
1287end;
1288
1289procedure TIBControlService.ServiceStart;
1290begin
1291  CheckActive;
1292  SetServiceStartOptions;
1293  InternalServiceStart;
1294end;
1295
1296{ TIBConfigService }
1297
1298procedure TIBConfigService.ServiceStart;
1299begin
1300  IBError(ibxeUseSpecificProcedures, [nil]);
1301end;
1302
1303procedure TIBConfigService.ActivateShadow;
1304begin
1305  ServiceStartParams  := Char(isc_action_svc_properties);
1306  ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
1307  ServiceStartAddParam (isc_spb_prp_activate, SPBConstantValues[isc_spb_options]);
1308  InternalServiceStart;
1309end;
1310
1311procedure TIBConfigService.BringDatabaseOnline;
1312begin
1313  ServiceStartParams  := Char(isc_action_svc_properties);
1314  ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
1315  ServiceStartAddParam (isc_spb_prp_db_online, SPBConstantValues[isc_spb_options]);
1316  InternalServiceStart;
1317end;
1318
1319procedure TIBConfigService.SetAsyncMode(Value: Boolean);
1320begin
1321  ServiceStartParams  := Char(isc_action_svc_properties);
1322  ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
1323  ServiceStartParams := ServiceStartParams +
1324                        Char(isc_spb_prp_write_mode);
1325  if Value then
1326    ServiceStartParams  := ServiceStartParams +
1327                           Char(isc_spb_prp_wm_async)
1328  else
1329    ServiceStartParams  := ServiceStartParams +
1330                           Char(isc_spb_prp_wm_sync);
1331  InternalServiceStart;
1332end;
1333
1334procedure TIBConfigService.SetDatabaseName(const Value: string);
1335begin
1336  FDatabaseName := Value;
1337end;
1338
1339procedure TIBConfigService.SetPageBuffers(Value: Integer);
1340begin
1341  ServiceStartParams  := Char(isc_action_svc_properties);
1342  ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
1343  ServiceStartAddParam (Value, isc_spb_prp_page_buffers);
1344  InternalServiceStart;
1345end;
1346
1347procedure TIBConfigService.SetReadOnly(Value: Boolean);
1348begin
1349  ServiceStartParams  := Char(isc_action_svc_properties);
1350  ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
1351  ServiceStartParams := ServiceStartParams +
1352                         Char(isc_spb_prp_access_mode);
1353  if Value then
1354    ServiceStartParams  := ServiceStartParams +
1355                           Char(isc_spb_prp_am_readonly)
1356  else
1357    ServiceStartParams  := ServiceStartParams +
1358                           Char(isc_spb_prp_am_readwrite);
1359  InternalServiceStart;
1360end;
1361
1362procedure TIBConfigService.SetReserveSpace(Value: Boolean);
1363begin
1364  ServiceStartParams  := Char(isc_action_svc_properties);
1365  ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
1366  ServiceStartParams := ServiceStartParams +
1367                        Char(isc_spb_prp_reserve_space);
1368  if Value then
1369    ServiceStartParams  := ServiceStartParams +
1370                           Char(isc_spb_prp_res)
1371  else
1372    ServiceStartParams  := ServiceStartParams +
1373                           Char(isc_spb_prp_res_use_full);
1374  InternalServiceStart;
1375end;
1376
1377procedure TIBConfigService.SetSweepInterval(Value: Integer);
1378begin
1379  ServiceStartParams  := Char(isc_action_svc_properties);
1380  ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
1381  ServiceStartAddParam (Value, isc_spb_prp_sweep_interval);
1382  InternalServiceStart;
1383end;
1384
1385procedure TIBConfigService.SetDBSqlDialect(Value: Integer);
1386begin
1387  ServiceStartParams  := Char(isc_action_svc_properties);
1388  ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
1389  ServiceStartAddParam (Value, isc_spb_prp_set_sql_dialect);
1390  InternalServiceStart;
1391end;
1392
1393{
1394  changes for 2.5 as discussed here:
1395  http://firebird.1100200.n4.nabble.com/New-shutdown-online-mode-via-Delphi-unrecognized-service-parameter-block-td1126894.html
1396}
1397procedure TIBConfigService.ShutdownDatabase(Options: TShutdownModeEx;
1398  Wait: Integer; OperationMode: TOperationMode);
1399begin
1400  ServiceStartParams := AnsiChar(isc_action_svc_properties);
1401  ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
1402  case OperationMode of
1403    omNormal: ServiceStartAddByteParam(isc_spb_prp_sm_normal, isc_spb_prp_shutdown_mode);
1404    omMulti: ServiceStartAddByteParam(isc_spb_prp_sm_multi, isc_spb_prp_shutdown_mode);
1405    omSingle: ServiceStartAddByteParam(isc_spb_prp_sm_single, isc_spb_prp_shutdown_mode);
1406    omFull: ServiceStartAddByteParam(isc_spb_prp_sm_full, isc_spb_prp_shutdown_mode);
1407  end;
1408  case Options of
1409    smeForce: ServiceStartAddParam(Wait, isc_spb_prp_force_shutdown);
1410    smeAttachment: ServiceStartAddParam(Wait, isc_spb_prp_attachments_shutdown);
1411    smeTransaction: ServiceStartAddParam(Wait, isc_spb_prp_transactions_shutdown);
1412  end;
1413  {ServiceStartParams  := Char(isc_action_svc_properties);
1414  ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
1415  if (Options = Forced) then
1416    ServiceStartAddParam (Wait, isc_spb_prp_shutdown_db)
1417  else if (Options = DenyTransaction) then
1418    ServiceStartAddParam (Wait, isc_spb_prp_deny_new_transactions)
1419  else
1420    ServiceStartAddParam (Wait, isc_spb_prp_deny_new_attachments);}
1421  InternalServiceStart;
1422end;
1423
1424{ TIBLicensingService }
1425procedure TIBLicensingService.SetAction(Value: TLicensingAction);
1426begin
1427  FAction := Value;
1428  if (Value = LicenseRemove) then
1429   FID := '';
1430end;
1431
1432procedure TIBLicensingService.AddLicense;
1433begin
1434  Action := LicenseAdd;
1435  Servicestart;
1436end;
1437
1438procedure TIBLicensingService.RemoveLicense;
1439begin
1440  Action := LicenseRemove;
1441  Servicestart;
1442end;
1443
1444procedure TIBLicensingService.SetServiceStartOptions;
1445begin
1446  if (FAction = LicenseAdd) then begin
1447    ServiceStartParams  := Char(isc_action_svc_add_license);
1448    ServiceStartAddParam (FKey, isc_spb_lic_key);
1449    ServiceStartAddParam (FID, isc_spb_lic_id);
1450  end
1451  else begin
1452    ServiceStartParams  := Char(isc_action_svc_remove_license);
1453    ServiceStartAddParam (FKey, isc_spb_lic_key);
1454  end;
1455end;
1456
1457{ TIBStatisticalService }
1458
1459procedure TIBStatisticalService.SetDatabaseName(const Value: string);
1460begin
1461  FDatabaseName := Value;
1462end;
1463
1464procedure TIBStatisticalService.SetServiceStartOptions;
1465var
1466  param: Integer;
1467begin
1468  if FDatabaseName = '' then
1469    IBError(ibxeStartParamsError, [nil]);
1470  param := 0;
1471  if (DataPages in Options) then
1472    param := param or isc_spb_sts_data_pages;
1473  if (DbLog in Options) then
1474    param := param or isc_spb_sts_db_log;
1475  if (HeaderPages in Options) then
1476    param := param or isc_spb_sts_hdr_pages;
1477  if (IndexPages in Options) then
1478    param := param or isc_spb_sts_idx_pages;
1479  if (SystemRelations in Options) then
1480    param := param or isc_spb_sts_sys_relations;
1481  Action := isc_action_svc_db_stats;
1482  ServiceStartParams  := Char(isc_action_svc_db_stats);
1483  ServiceStartAddParam (FDatabaseName, SPBConstantValues[isc_spb_dbname]);
1484  ServiceStartAddParam (param, SPBConstantValues[isc_spb_options]);
1485end;
1486
1487{ TIBBackupService }
1488procedure TIBBackupService.SetServiceStartOptions;
1489var
1490  param, i: Integer;
1491  value: String;
1492begin
1493  if FDatabaseName = '' then
1494    IBError(ibxeStartParamsError, [nil]);
1495  param := 0;
1496  if (IgnoreChecksums in Options) then
1497    param := param or isc_spb_bkp_ignore_checksums;
1498  if (IgnoreLimbo in Options) then
1499    param := param or isc_spb_bkp_ignore_limbo;
1500  if (MetadataOnly in Options) then
1501    param := param or isc_spb_bkp_metadata_only;
1502  if (NoGarbageCollection in Options) then
1503    param := param or isc_spb_bkp_no_garbage_collect;
1504  if (OldMetadataDesc in Options) then
1505    param := param or isc_spb_bkp_old_descriptions;
1506  if (NonTransportable in Options) then
1507    param := param or isc_spb_bkp_non_transportable;
1508  if (ConvertExtTables in Options) then
1509    param := param or isc_spb_bkp_convert;
1510  Action := isc_action_svc_backup;
1511  ServiceStartParams  := Char(isc_action_svc_backup);
1512  ServiceStartAddParam(FDatabaseName, SPBConstantValues[isc_spb_dbname]);
1513  ServiceStartAddParam(param, SPBConstantValues[isc_spb_options]);
1514  if Verbose then
1515    ServiceStartParams := ServiceStartParams + Char(SPBConstantValues[isc_spb_verbose]);
1516  if FBlockingFactor > 0 then
1517    ServiceStartAddParam(FBlockingFactor, isc_spb_bkp_factor);
1518  for i := 0 to FBackupFile.Count - 1 do
1519  begin
1520    if (Trim(FBackupFile[i]) = '') then
1521      continue;
1522    if (Pos('=', FBackupFile[i]) <> 0) then
1523    begin {mbcs ok}
1524      ServiceStartAddParam(FBackupFile.Names[i], isc_spb_bkp_file);
1525      value := Copy(FBackupFile[i], Pos('=', FBackupFile[i]) + 1, Length(FBackupFile.Names[i])); {mbcs ok}
1526      param := StrToInt(value);
1527      ServiceStartAddParam(param, isc_spb_bkp_length);
1528    end
1529    else
1530      ServiceStartAddParam(FBackupFile[i], isc_spb_bkp_file);
1531  end;
1532end;
1533
1534constructor TIBBackupService.Create(AOwner: TComponent);
1535begin
1536  inherited Create(AOwner);
1537  FBackupFile := TStringList.Create;
1538end;
1539
1540destructor TIBBackupService.Destroy;
1541begin
1542  FBackupFile.Free;
1543  inherited Destroy;
1544end;
1545
1546procedure TIBBackupService.SetBackupFile(const Value: TStrings);
1547begin
1548  FBackupFile.Assign(Value);
1549end;
1550
1551{ TIBRestoreService }
1552
1553procedure TIBRestoreService.SetServiceStartOptions;
1554var
1555  param, i: Integer;
1556  value: String;
1557begin
1558  param := 0;
1559  if (DeactivateIndexes in Options) then
1560    param := param or isc_spb_res_deactivate_idx;
1561  if (NoShadow in Options) then
1562    param := param or isc_spb_res_no_shadow;
1563  if (NoValidityCheck in Options) then
1564    param := param or isc_spb_res_no_validity;
1565  if (OneRelationAtATime in Options) then
1566    param := param or isc_…

Large files files are truncated, but you can click here to view the full file