fpc/packages/fcl-db/src/sqldb/interbase/fbadmin.pp

unit FBAdmin;

{ Interbase/Firebird Administration using the service manager

  Copyright (C) 2012 Ludo Brands

  This library is free software; you can redistribute it and/or modify it
  under the terms of the GNU Library General Public License as published by
  the Free Software Foundation; either version 2 of the License, or (at your
  option) any later version with the following modification:

  As a special exception, the copyright holders of this library give you
  permission to link this library with independent modules to produce an
  executable, regardless of the license terms of these independent modules,and
  to copy and distribute the resulting executable under terms of your choice,
  provided that you also meet, for each linked independent module, the terms
  and conditions of the license of that module. An independent module is a
  module which is not derived from or based on this library. If you modify
  this library, you may extend this exception to your version of the library,
  but you are not obligated to do so. If you do not wish to do so, delete this
  exception statement from your version.

  This program is distributed in the hope that it will be useful, but WITHOUT
  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
  for more details.

  You should have received a copy of the GNU Library General Public License
  along with this library; if not, write to the Free Software Foundation,
  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}

{$mode objfpc}{$H+}

{$Define LinkDynamically}

interface

uses
  Classes, SysUtils,
{$IfDef LinkDynamically}
  ibase60dyn,
{$Else}
  ibase60,
{$EndIf}
  IBConnection;

type
  TIBBackupOption=(IBBkpVerbose,IBBkpIgnoreChecksums,IBBkpIgnoreLimbo,IBBkpMetadataOnly,
     IBBkpNoGarbageCollect,IBBkpOldDescriptions,IBBkpNonTransportable,IBBkpConvert);
  TIBBackupOptions= set of TIBBackupOption;
  TIBRestoreOption=(IBResVerbose,IBResDeactivateIdx,IBResNoShadow,IBResNoValidity,
     IBResOneAtaTime,IBResReplace,IBResCreate,IBResUseAllSpace,IBResAMReadOnly,IBResAMReadWrite,
     IBFixFssData, IBFixFssMeta);
  TIBRestoreOptions= set of TIBRestoreOption;
  TServiceProtocol=(IBSPLOCAL,IBSPTCPIP,IBSPNETBEUI,IBSPNAMEDPIPE);
  TIBOnOutput= procedure(Sender: TObject; msg: string; IBAdminAction: string) of object;
  TIBStatOption = (IBDataPages, IBDbLog, IBHeaderPages, IBIndexPages, IBSystemRelations,
    IBRecordVersions, IBStatTables);
  TIBStatOptions = set of TIBStatOption;

  { TFBAdmin }

  TFBAdmin=class(TComponent)
  private
    FErrorCode: longint;
    FErrorMsg: string;
    FFixFssDataCharSet: String;
    FHost: string;
    FOnOutput: TIBOnOutput;
    FOutput: TStringList;
    FPassword: string;
    FPort: word;
    FProtocol: TServiceProtocol;
    FServerImplementation: string;
    FServerLockDir: string;
    FServerMsgDir: string;
    FServerRootDir: string;
    FServerSecDBDir: string;
    FServerVersion: string;
    FStatus: array [0..19] of ISC_STATUS;
    FSvcHandle: isc_svc_handle;
    FUseExceptions: boolean;
    FUser: string;
    function CheckConnected(ProcName: string):boolean;
    procedure CheckError(ProcName : string; Status : PISC_STATUS);
    function GetDBInfo:boolean;
    function GetIBLongint(buffer:string; var bufptr:integer):longint;overload;
    function GetIBString(buffer:string; var bufptr:integer):string;overload;
    function GetOutput(IBAdminAction:string):boolean;
    function IBParamSerialize(isccode:byte;value:string):string;
    procedure IBRaiseError(GDSErrorCode:Longint; const msg : string; const args : array of const);
    function IBSPBParamSerialize(isccode:byte;value:string):string;
    function IBSPBParamSerialize(isccode:byte;value:longint):string;
    function MakeBackupOptions(options:TIBBackupOptions):longint;
    function MakeRestoreOptions(options:TIBRestoreOptions):longint;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    //Connect to service manager. Specify User,Password and, for remote databases,
    //Host and, if not standard, Port
    function Connect:boolean;
    //Disconnect from service manager. Done automatically when destroying component
    function DisConnect:boolean;
    //Backup database to a single file on the server.
    //Include IBBkpVerbose in Options to get progress feedback through the OnOutput Handler
    function Backup(Database,Filename:string;Options:TIBBackupOptions;RoleName:string=''):boolean;
    //Backup database to multiple files with length FileSize on the server.
    //Filenames is the list of filenames to use. The last file specified has no size limit.
    //Include IBBkpVerbose in Options to get progress feedback through the OnOutput Handler
    function BackupMultiFile(Database:string;Filenames:TStrings;FileSize:longint;
      Options:TIBBackupOptions;RoleName:string=''):boolean;
    //Restore database from a single file on the server.
    //Include IBResReplace to restore in and existing database or IBResCreate
    //to create a a new one.
    //Include IBResVerbose in Options to get progress feedback through the OnOutput Handler
    function Restore(Database,Filename:string;Options:TIBRestoreOptions;RoleName:string=''):boolean;
    //Restore database from multiple files on the server.
    //Filenames is the list of files to use.
    //Include IBResReplace to restore in and existing database or IBResCreate
    //to create a a new one.
    //Include IBResVerbose in Options to get progress feedback through the OnOutput Handler
    function RestoreMultiFile(Database:string;Filenames:TStrings;
      Options:TIBRestoreOptions;RoleName:string=''):boolean;
    //Add a new user.
    function AddUser(UserName,Password:string;RoleName:string='';
      GroupName:string='';FirstName:string='';MiddleName:string='';
      LastName:string='';UserID: longint = 0; GroupID: longint = 0):boolean;
    //Modify an existing user.
    function ModifyUser(UserName,Password:string;RoleName:string='';
      GroupName:string='';FirstName:string='';MiddleName:string='';
      LastName:string='';UserID: longint = 0; GroupID: longint = 0):boolean;
    //Delete an existing user.
    function DeleteUser(UserName:string;RoleName:string=''):boolean;
    //Get the details of an existing user.
    function GetUser(UserName:string;var GroupName,FirstName,MiddleName,
      LastName:string;var UserID, GroupID: longint):boolean;
    //Get the list of all users
    function GetUsers(Users:TStrings):boolean;
    //Get database server log file
    function GetDatabaseLog:boolean;
    //Get database statistics
    function GetDatabaseStats(Database:string;Options:TIBStatOptions;TableNames:String = ''): boolean;
    //Database server version
    property ServerVersion:string read FServerVersion;
    //Implementation string of the database server
    property ServerImplementation:string read FServerImplementation;
    //Setting of $FIREBIRD or $INTERBASE
    property ServerRootDir:string read FServerRootDir;
    //Setting of $FIREBIRD_LCK or $INTERBASE_LCK
    property ServerLockDir:string read FServerLockDir;
    //Setting of $FIREBIRD_MSG or $INTERBASE_MSG
    property ServerMsgDir:string read FServerMsgDir;
    //Path to the security database in use by the server
    property ServerSecDBDir:string read FServerSecDBDir;
    // FixFxxData/FixFxxMetaData code page
    property FixFssDataCharSet: String read FFixFssDataCharSet write FFixFssDataCharSet;
  published
    //User name to connect to service manager
    property User: string read FUser write FUser;
    //User name to connect to service manager
    property Password: string read FPassword write FPassword;
    //Database Host
    property Host: string read FHost write FHost;
    //Database Port, Default:3050
    property Port: word read FPort write FPort default 3050;
    //Protocol used to connect to service manager. One of:
    //IBSPLOCAL: Host and port ignored
    //IBSPTCPIP: Connect to Host:Port
    //IBSPNETBEUI: Connect to \\Host\
    //IBSPNAMEDPIPE: Connect to //Host/
    property Protocol: TServiceProtocol read FProtocol write FProtocol;
    //Errorcode returned in status vector or 0 for TFBAdmin errors
    property ErrorCode:longint read FErrorCode;
    //Errormsg returned in status vector or by TFBAdmin
    property ErrorMsg:string read FErrorMsg;
    //Raise exceptions when error encounterd. Default: false
    property UseExceptions:boolean read FUseExceptions write FUseExceptions;
    //Service output messages
    //Result from Backup and Restore operations and GetLog
    property Output:TStringList read FOutput;
    //Event handler for Service output messages
    //Used in Backup and Restore operations and GetLog
    property OnOutput: TIBOnOutput read FOnOutput write FOnOutput;
  end;


implementation

resourcestring
  SErrNotConnected = '%s : %s : Not connected.';
  SErrError = '%s : %s : %s';
  SErrConnected = '%s : Connect : Already connected.';
  SErrRestoreOptionsError = '%s : Restore : Nothing to do. Specify IBResReplace or IBResCreate in Options.';
  SErrRestoreMultiOptionsError = '%s : RestoreMultiFile : Nothing to do. Specify IBResReplace or IBResCreate in Options.';
  SErrUserDoesNotExist = '%s : GetUser : User does not exist.';
  SErrUserInvalidReply = '%s : GetUser : Invalid reply (%d).';
  SErrUsersInvalidReply = '%s : GetUsers : Invalid reply (%d).';

{ TFBAdmin }

function TFBAdmin.IBParamSerialize(isccode: byte; value: string): string;
begin
  result:=chr(isccode)+chr(Length(value))+value;
end;

procedure TFBAdmin.IBRaiseError(GDSErrorCode: Longint; const msg: string;
  const args: array of const);
begin
  FErrorMsg:=Format(msg,args);
  FErrorCode:=GDSErrorCode;
  if FUseExceptions then
    raise EIBDatabaseError.CreateFmt(msg,args,nil,GDSErrorCode,'');
end;

function TFBAdmin.IBSPBParamSerialize(isccode: byte; value: string): string;
begin
  result:=chr(isccode)+chr(Length(value) and $ff)+chr((Length(value)shr 8) and $ff)+value;
end;

function TFBAdmin.IBSPBParamSerialize(isccode: byte; value: longint): string;
begin
  result:=chr(isccode)+chr(value and $ff)+chr((value shr 8) and $ff)
     +chr((value shr 16) and $ff)+chr((value shr 24) and $ff);
end;

function TFBAdmin.MakeBackupOptions(options: TIBBackupOptions): longint;
begin
  result:=0;
  if IBBkpConvert in Options then
    result:=result or isc_spb_bkp_convert;
  if IBBkpIgnoreChecksums in Options then
    result:=result or isc_spb_bkp_ignore_checksums;
  if IBBkpIgnoreLimbo in Options then
    result:=result or isc_spb_bkp_ignore_limbo;
  if IBBkpMetadataOnly  in Options then
    result:=result or isc_spb_bkp_metadata_only;
  if IBBkpNoGarbageCollect in Options then
    result:=result or isc_spb_bkp_no_garbage_collect;
  if IBBkpNonTransportable in Options then
    result:=result or isc_spb_bkp_non_transportable;
  if IBBkpOldDescriptions  in Options then
    result:=result or isc_spb_bkp_old_descriptions;
end;

function TFBAdmin.MakeRestoreOptions(options: TIBRestoreOptions): longint;
begin
  result:=0;
  if IBResCreate in Options then
    result:=result or isc_spb_res_create;
  if IBResDeactivateIdx in Options then
    result:=result or isc_spb_res_deactivate_idx;
  if IBResNoShadow in Options then
    result:=result or isc_spb_res_no_shadow;
  if IBResNoValidity in Options then
    result:=result or isc_spb_res_no_validity;
  if IBResOneAtaTime in Options then
    result:=result or isc_spb_res_one_at_a_time;
  if IBResReplace in Options then
    result:=result or isc_spb_res_replace;
  if IBResUseAllSpace in Options then
    result:=result or isc_spb_res_use_all_space;
end;


function TFBAdmin.CheckConnected(ProcName: string): boolean;
begin
  result:=false;
  if FSvcHandle=FB_API_NULLHANDLE then
    begin
    IBRaiseError(0,SErrNotConnected,[self.Name,ProcName]);
    exit;
    end;
  result:=true;
end;

procedure TFBAdmin.CheckError(ProcName: string; Status: PISC_STATUS);
var
  buf : array [0..1023] of char;
  Msg : string;
  Err : longint;

begin
  if ((Status[0] = 1) and (Status[1] <> 0)) then
  begin
    Err := Status[1];
    msg := '';
    while isc_interprete(Buf, @Status) > 0 do
      Msg := Msg + LineEnding +' -' + StrPas(Buf);
    IBRaiseError(Err,SErrError,[self.Name,ProcName,Msg]);
  end;
end;

function TFBAdmin.GetDBInfo: boolean;

  function QueryInfo(isc:byte):string;
  var
    spb:string;
    len:integer;
  begin
    result:='';
    spb:=chr(isc);
    setlength(result,255);
    if (isc_service_query(@FStatus[0], @FSvcHandle, nil, 0, nil, length(spb),
      @spb[1],255,@result[1])=0) and (result[1]=chr(isc)) then
      begin
      len:=isc_vax_integer(@result[2],2);
      delete(result,1,3); // remove cmd and len
      setlength(result,len);
      end;
  end;

begin
  FServerImplementation:= QueryInfo(isc_info_svc_implementation);
  FServerLockDir:= QueryInfo(isc_info_svc_get_env_lock);
  FServerMsgDir:= QueryInfo(isc_info_svc_get_env_msg);
  FServerRootDir:= QueryInfo(isc_info_svc_get_env);
  FServerSecDBDir:= QueryInfo(isc_info_svc_user_dbpath);
  FServerVersion:= QueryInfo(isc_info_svc_server_version);
end;

function TFBAdmin.GetIBLongint(buffer: string; var bufptr: integer): longint;
begin
  bufptr:=bufptr+1;
  result:=isc_vax_integer(@Buffer[bufptr], 4);
  bufptr:=bufptr+4;
end;

function TFBAdmin.GetIBString(buffer: string; var bufptr: integer): string;
var
  len:integer;
begin
  bufptr:=bufptr+1;
  len:=isc_vax_integer(@buffer[bufptr], 2);
  bufptr:=bufptr+2;
  result:=copy(buffer,bufptr,len);
  bufptr:=bufptr+len;
end;

function TFBAdmin.GetOutput(IBAdminAction: string): boolean;
var
  len:integer;
  buffer:string;
  spb:string;
const
  BUFFERSIZE=1000;
begin
  len:=0;
  FOutput.Clear;
  spb:=chr(isc_info_svc_line);
  repeat
    setlength(buffer,BUFFERSIZE);
    result:=isc_service_query(@FStatus[0], @FSvcHandle, nil, 0, nil, length(spb),
      @spb[1],BUFFERSIZE,@buffer[1])=0;
    if not result then
      begin
      CheckError('GetOutput',FStatus);
      exit;
      end;
    if buffer[1]=chr(isc_info_svc_line) then
      begin
      len:=isc_vax_integer(@buffer[2],2);
      delete(buffer,1,3); // remove cmd and len
      setlength(buffer,len);
      FOutput.Add(buffer);
      if assigned(FOnOutput) then
        begin
        FOnOutput(Self,buffer,IBAdminAction);
        end;
      end;
  until len=0;
end;

constructor TFBAdmin.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FPort:= 3050;
  FOutput:=TStringList.Create;
  FFixFssDataCharSet:= '';
end;

destructor TFBAdmin.Destroy;
begin
  if FSvcHandle<>FB_API_NULLHANDLE then
    DisConnect;
  FOutput.Destroy;
  inherited Destroy;
end;

function TFBAdmin.Connect: boolean;
var
  Service:string;
  spb:string;
begin
  result:=false;
  {$IfDef LinkDynamically}
  result:=InitialiseIBase60<>0;
  {$EndIf}
  if FSvcHandle<>FB_API_NULLHANDLE then
    raise EIBDatabaseError.CreateFmt(SErrConnected,[Self.Name],nil,0,'');
  Service:='service_mgr';
  case FProtocol of
    IBSPTCPIP:if FPort=3050 then
        service:=FHost+':'+service
      else
        service:=FHost+'/'+IntTostr(FPort)+':'+service;
    IBSPNETBEUI:service:='\\'+FHost+'\'+service;
    IBSPNAMEDPIPE:service:='//'+FHost+'/'+service;
  end;
  spb:=chr(isc_spb_version)+chr(isc_spb_current_version)+
    IBParamSerialize(isc_spb_user_name,FUser)+
    IBParamSerialize(isc_spb_password,FPassword);
  result:=isc_service_attach(@FStatus[0], 0,PChar(Service), @FSvcHandle,
      length(spb), @spb[1]) = 0;
  if not result then
    CheckError('Connect',FStatus)
  else
    GetDBInfo;
end;

function TFBAdmin.DisConnect: boolean;

begin
  result:=CheckConnected('DisConnect');
  result:= isc_service_detach(@FStatus[0], @FSvcHandle) = 0;
  if not result then
    CheckError('DisConnect',FStatus);
  FSvcHandle:=FB_API_NULLHANDLE;
  {$IfDef LinkDynamically}
  ReleaseIBase60;
  {$EndIf}
  result:=true;
end;

function TFBAdmin.Backup(Database, Filename: string; Options: TIBBackupOptions;
  RoleName: string): boolean;
var
  spb:string;
begin
  result:=CheckConnected('Backup');
  spb:=chr(isc_action_svc_backup)+IBSPBParamSerialize(isc_spb_dbname,Database)
    +IBSPBParamSerialize(isc_spb_bkp_file,Filename);
  if RoleName<>'' then
    spb:=spb+IBSPBParamSerialize(isc_spb_sql_role_name,copy(RoleName,1,31));
  if IBBkpVerbose in Options then
    spb:=spb+chr(isc_spb_verbose);
  spb:=spb+IBSPBParamSerialize(isc_spb_options,MakeBackupOptions(Options));
  result:=isc_service_start(@FStatus[0], @FSvcHandle, nil, length(spb),
    @spb[1])=0;
  if not result then
    begin
    CheckError('Backup',FStatus);
    exit;
    end;
  if IBBkpVerbose in Options then
    result:=GetOutput('Backup');
end;

function TFBAdmin.BackupMultiFile(Database: string; Filenames: TStrings;
  FileSize: longint; Options: TIBBackupOptions; RoleName: string): boolean;
var
  spb:string;
  i:integer;
begin
  result:=CheckConnected('BackupMultiFile');
  spb:=chr(isc_action_svc_backup)+IBSPBParamSerialize(isc_spb_dbname,Database);
  for i:=0 to Filenames.Count-1 do
    begin
    spb:=spb+IBSPBParamSerialize(isc_spb_bkp_file,Filenames[i]);
    spb:=spb+IBSPBParamSerialize(isc_spb_bkp_length,FileSize);
    end;
  if RoleName<>'' then
    spb:=spb+IBSPBParamSerialize(isc_spb_sql_role_name,copy(RoleName,1,31));
  if IBBkpVerbose in Options then
    spb:=spb+chr(isc_spb_verbose);
  spb:=spb+IBSPBParamSerialize(isc_spb_options,MakeBackupOptions(Options));
  result:=isc_service_start(@FStatus[0], @FSvcHandle, nil, length(spb),
    @spb[1])=0;
  if not result then
    begin
    CheckError('BackupMultiFile',FStatus);
    exit;
    end;
  if IBBkpVerbose in Options then
    result:=GetOutput('BackupMultiFile');
end;

function TFBAdmin.Restore(Database, Filename: string;
  Options: TIBRestoreOptions; RoleName: string): boolean;
var
  spb:string;
begin
  result:=CheckConnected('Restore');
  if not ((IBResReplace in Options) or (IBResCreate in Options)) then
    begin
    result:=false;
    IBRaiseError(0,SErrRestoreOptionsError,[self.Name]);
    exit;
    end;
  spb:=chr(isc_action_svc_restore)+IBSPBParamSerialize(isc_spb_dbname,Database)
    +IBSPBParamSerialize(isc_spb_bkp_file,Filename);
  if RoleName<>'' then
    spb:=spb+IBSPBParamSerialize(isc_spb_sql_role_name,copy(RoleName,1,31));
  if IBResVerbose in Options then
    spb:=spb+chr(isc_spb_verbose);
  if (IBResAMReadOnly in Options) or (IBResAMReadWrite in Options) then
    begin
    if (IBResAMReadOnly in Options) then   //ReadOnly overrides ReadWrite
      spb:=spb+chr(isc_spb_res_access_mode)+chr(isc_spb_res_am_readonly)
    else
      spb:=spb+chr(isc_spb_res_access_mode)+chr(isc_spb_res_am_readwrite);
    end;
  if (IBFixFssData in Options) and (FixFssDataCharSet > ' ') then
    spb:=spb+IBSPBParamSerialize(isc_spb_res_fix_fss_data, FixFssDataCharSet);
  if (IBFixFssMeta in Options) and (FixFssDataCharSet > ' ') then
    spb:=spb+IBSPBParamSerialize(isc_spb_res_fix_fss_metadata, FixFssDataCharSet);
  spb:=spb+IBSPBParamSerialize(isc_spb_options,MakeRestoreOptions(Options));
  result:=isc_service_start(@FStatus[0], @FSvcHandle, nil, length(spb),
    @spb[1])=0;
  if not result then
    begin
    CheckError('Restore',FStatus);
    exit;
    end;
  if IBResVerbose in Options then
    result:=GetOutput('Restore');
end;


function TFBAdmin.RestoreMultiFile(Database: string; Filenames: TStrings;
  Options: TIBRestoreOptions; RoleName: string): boolean;
var
  spb:string;
  i:integer;
begin
  result:=CheckConnected('RestoreMultiFile');
  if not ((IBResReplace in Options) or (IBResCreate in Options)) then
    begin
    result:=false;
    IBRaiseError(0,SErrRestoreMultiOptionsError,[self.Name]);
    exit;
    end;
  spb:=chr(isc_action_svc_restore)+IBSPBParamSerialize(isc_spb_dbname,Database);
  for i:=0 to Filenames.Count-1 do
    spb:=spb+IBSPBParamSerialize(isc_spb_bkp_file,Filenames[i]);
  if RoleName<>'' then
    spb:=spb+IBSPBParamSerialize(isc_spb_sql_role_name,copy(RoleName,1,31));
  if IBResVerbose in Options then
    spb:=spb+chr(isc_spb_verbose);
  if (IBResAMReadOnly in Options) or (IBResAMReadWrite in Options) then
    begin
    if (IBResAMReadOnly in Options) then   //ReadOnly overrides ReadWrite
      spb:=spb+chr(isc_spb_res_access_mode)+chr(isc_spb_res_am_readonly)
    else
      spb:=spb+chr(isc_spb_res_access_mode)+chr(isc_spb_res_am_readwrite);
    end;
  spb:=spb+IBSPBParamSerialize(isc_spb_options,MakeRestoreOptions(Options));
  result:=isc_service_start(@FStatus[0], @FSvcHandle, nil, length(spb),
    @spb[1])=0;
  if not result then
    begin
    CheckError('RestoreMultiFile',FStatus);
    exit;
    end;
  if IBResVerbose in Options then
    result:=GetOutput('RestoreMultiFile');
end;

function TFBAdmin.AddUser(UserName, Password: string; RoleName: string;
  GroupName: string; FirstName: string; MiddleName: string; LastName: string;
  UserID: longint; GroupID: longint): boolean;
var
  spb:string;
begin
  result:=CheckConnected('AddUser');
  spb:=chr(isc_action_svc_add_user)+IBSPBParamSerialize(isc_spb_sec_username,copy(UserName,1,31))+
    IBSPBParamSerialize(isc_spb_sec_password,copy(Password,1,8));
  if RoleName<>'' then
    spb:=spb+IBSPBParamSerialize(isc_spb_sql_role_name,copy(RoleName,1,31));
  if GroupName<>'' then
    spb:=spb+IBSPBParamSerialize(isc_spb_sec_groupname,copy(GroupName,1,31));
  if FirstName<>'' then
    spb:=spb+IBSPBParamSerialize(isc_spb_sec_firstname,copy(FirstName,1,255));
  if MiddleName<>'' then
    spb:=spb+IBSPBParamSerialize(isc_spb_sec_middlename,copy(MiddleName,1,255));
  if LastName<>'' then
    spb:=spb+IBSPBParamSerialize(isc_spb_sec_lastname,copy(LastName,1,255));
  if UserID<>0 then
    spb:=spb+IBSPBParamSerialize(isc_spb_sec_userid,UserID);
  if GroupID<>0 then
    spb:=spb+IBSPBParamSerialize(isc_spb_sec_groupid,GroupID);
  result:=isc_service_start(@FStatus[0], @FSvcHandle, nil, length(spb),
    @spb[1])=0;
  if not result then
    CheckError('AddUser',FStatus);
end;

function TFBAdmin.ModifyUser(UserName, Password: string; RoleName: string;
  GroupName: string; FirstName: string; MiddleName: string; LastName: string;
  UserID: longint; GroupID: longint): boolean;
var
  spb:string;
begin
  result:=CheckConnected('ModifyUser');
  spb:=chr(isc_action_svc_modify_user)+IBSPBParamSerialize(isc_spb_sec_username,copy(UserName,1,31))+
    IBSPBParamSerialize(isc_spb_sec_password,copy(Password,1,8));
  if RoleName<>'' then
    spb:=spb+IBSPBParamSerialize(isc_spb_sql_role_name,copy(RoleName,1,31));
  if GroupName<>'' then
    spb:=spb+IBSPBParamSerialize(isc_spb_sec_groupname,copy(GroupName,1,31));
  if FirstName<>'' then
    spb:=spb+IBSPBParamSerialize(isc_spb_sec_firstname,copy(FirstName,1,255));
  if MiddleName<>'' then
    spb:=spb+IBSPBParamSerialize(isc_spb_sec_middlename,copy(MiddleName,1,255));
  if LastName<>'' then
    spb:=spb+IBSPBParamSerialize(isc_spb_sec_lastname,copy(LastName,1,255));
  if UserID<>0 then
    spb:=spb+IBSPBParamSerialize(isc_spb_sec_userid,UserID);
  if GroupID<>0 then
    spb:=spb+IBSPBParamSerialize(isc_spb_sec_groupid,GroupID);
  result:=isc_service_start(@FStatus[0], @FSvcHandle, nil, length(spb),
    @spb[1])=0;
  if not result then
    CheckError('ModifyUser',FStatus);
end;

function TFBAdmin.DeleteUser(UserName: string; RoleName: string): boolean;
var
  spb:string;
begin
  result:=CheckConnected('DeleteUser');
  spb:=chr(isc_action_svc_delete_user)+IBSPBParamSerialize(isc_spb_sec_username,copy(UserName,1,31));
  if RoleName<>'' then
    spb:=spb+IBSPBParamSerialize(isc_spb_sql_role_name,copy(RoleName,1,31));
  result:=isc_service_start(@FStatus[0], @FSvcHandle, nil, length(spb),
    @spb[1])=0;
  if not result then
    CheckError('DeleteUser',FStatus);
end;

function TFBAdmin.GetUser(UserName: string; var GroupName, FirstName,
  MiddleName, LastName: string; var UserID, GroupID: longint): boolean;
var
  spb:string;
  buffer:string;
  bufptr:integer;
const
  BUFFERSIZE=1000;
begin
  result:=CheckConnected('GetUser');
  spb:=chr(isc_action_svc_display_user)+IBSPBParamSerialize(isc_spb_sec_username,copy(UserName,1,31));
  result:=isc_service_start(@FStatus[0], @FSvcHandle, nil, length(spb),
    @spb[1])=0;
  if not result then
    begin
    CheckError('GetUser',FStatus);
    exit;
    end;
  //retrieve result
  spb:=chr(isc_info_svc_get_users);
  setlength(buffer,BUFFERSIZE);
  result:=isc_service_query(@FStatus[0], @FSvcHandle, nil, 0, nil, length(spb),
    @spb[1],BUFFERSIZE,@buffer[1])=0;
  if not result then
    begin
    CheckError('GetUser',FStatus);
    exit;
    end;
  bufptr:=4;
  if buffer[1]=chr(isc_info_svc_get_users) then
    begin
    if buffer[bufptr]=chr(isc_info_end) then
      begin
      result:=false;
      IBRaiseError(0,SErrUserDoesNotExist,[self.Name]);
      exit;
      end;
    while buffer[bufptr]<>chr(isc_info_end) do
      begin
      case buffer[bufptr] of
        chr(isc_spb_sec_username):GetIBString(buffer,bufptr);  //trash result
        chr(isc_spb_sec_groupname):GroupName:=GetIBString(buffer,bufptr);
        chr(isc_spb_sec_firstname):FirstName:=GetIBString(buffer,bufptr);
        chr(isc_spb_sec_middlename):MiddleName:=GetIBString(buffer,bufptr);
        chr(isc_spb_sec_lastname):LastName:=GetIBString(buffer,bufptr);
        chr(isc_spb_sec_userid):UserID:=GetIBLongint(buffer,bufptr);
        chr(isc_spb_sec_groupid):GroupID:=GetIBLongint(buffer,bufptr);
        else
          begin
          result:=false;
          IBRaiseError(0,SErrUserInvalidReply,[self.Name,ord(buffer[bufptr])]);
          exit;
          end;
        end;
      end;
    end;
end;

function TFBAdmin.GetUsers(Users: TStrings): boolean;
var
  spb:string;
  buffer:string;
  bufptr:integer;
const
  BUFFERSIZE=1000;
begin
  result:=CheckConnected('GetUsers');
  spb:=chr(isc_action_svc_display_user);
  result:=isc_service_start(@FStatus[0], @FSvcHandle, nil, length(spb),
    @spb[1])=0;
  if not result then
    begin
    CheckError('GetUsers',FStatus);
    exit;
    end;
  //retrieve result
  spb:=chr(isc_info_svc_get_users);
  setlength(buffer,BUFFERSIZE);
  result:=isc_service_query(@FStatus[0], @FSvcHandle, nil, 0, nil, length(spb),
    @spb[1],BUFFERSIZE,@buffer[1])=0;
  if not result then
    begin
    CheckError('GetUsers',FStatus);
    exit;
    end;
  bufptr:=4;
  Users.Clear;
  if buffer[1]=chr(isc_info_svc_get_users) then
    begin
    while buffer[bufptr]<>chr(isc_info_end) do
      begin
      case buffer[bufptr] of
        chr(isc_spb_sec_username):Users.Add(GetIBString(buffer,bufptr));
        chr(isc_spb_sec_groupname),
        chr(isc_spb_sec_firstname),
        chr(isc_spb_sec_middlename),
        chr(isc_spb_sec_lastname):GetIBString(buffer,bufptr);       //trash result
        chr(isc_spb_sec_userid),
        chr(isc_spb_sec_groupid):GetIBLongint(buffer,bufptr);       //trash result
        else
          begin
          result:=false;
          IBRaiseError(0,SErrUsersInvalidReply,[self.Name,ord(buffer[bufptr])]);
          exit;
          end;
        end;
      end;
    end;
end;


function TFBAdmin.GetDatabaseLog: boolean;
var
  spb:string;
begin
  result:=CheckConnected('GetLogFile');
  spb:=chr(isc_action_svc_get_ib_log);
  result:=isc_service_start(@FStatus[0], @FSvcHandle, nil, length(spb),
    @spb[1])=0;
  if not result then
    begin
    CheckError('GetLogFile',FStatus);
    exit;
    end;
  result:=GetOutput('GetLogFile');
end;

function TFBAdmin.GetDatabaseStats(Database:string;Options: TIBStatOptions; TableNames: String
  ): boolean;
var
  spb:string;
  param: Integer;
begin
  Result:=CheckConnected('GetDatabaseStats');
  param := 0;
  if (IBDataPages in Options) then
    param := param or isc_spb_sts_data_pages;
  if (IBDbLog in Options) then
    param := param or isc_spb_sts_db_log;
  if (IBHeaderPages in Options) then
    param := param or isc_spb_sts_hdr_pages;
  if (IBIndexPages in Options) then
    param := param or isc_spb_sts_idx_pages;
  if (IBSystemRelations in Options) then
    param := param or isc_spb_sts_sys_relations;
  if (IBRecordVersions in Options) then
    param := param or isc_spb_sts_record_versions;
  if (IBStatTables in Options) then
    param := param or isc_spb_sts_table;
  spb  := Char(isc_action_svc_db_stats)+IBSPBParamSerialize(isc_spb_dbname,Database)+
    IBSPBParamSerialize(isc_spb_options, param);
  if (IBStatTables in Options) and (TableNames <> '') then
    spb := spb+IBSPBParamSerialize(isc_spb_command_line, TableNames);
  Result:=isc_service_start(@FStatus[0], @FSvcHandle, nil, length(spb),
    @spb[1])=0;
  if not Result then
    begin
    CheckError('GetDatabaseStats',FStatus);
    exit;
    end;
  Result:=GetOutput('GetDatabaseStats');
end;

end.