examples/services/MainFormUnit.pas

(*
 *  IBX For Lazarus (Firebird Express)
 *
 *  The contents of this file are subject to the Initial Developer's
 *  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 here:
 *
 *    http://www.firebirdsql.org/index.php?op=doc&id=idpl
 *
 *  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 Initial Developer of the Original Code is Tony Whyman.
 *
 *  The Original Code is (C) 2015 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*) 
            
unit MainFormUnit;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  ActnList, Menus, IBServices, IB;

type

  TRunServiceProc = procedure of object;

  { TMainForm }

  TMainForm = class(TForm)
    IBConfigService1: TIBConfigService;
    MenuItem6: TMenuItem;
    Shutdown: TAction;
    BringOnline: TAction;
    MenuItem1: TMenuItem;
    MenuItem5: TMenuItem;
    Sweep: TAction;
    LimboTransactions: TAction;
    MenuItem2: TMenuItem;
    MenuItem3: TMenuItem;
    MenuItem4: TMenuItem;
    PopupMenu1: TPopupMenu;
    Validate: TAction;
    Statistics: TAction;
    ActionList1: TActionList;
    CLoseBtn: TButton;
    BackupBtn: TButton;
    RestoreBtn: TButton;
    ServerLOgBtn: TButton;
    DatabaseBtn: TButton;
    UsersBtn: TButton;
    IBLogService1: TIBLogService;
    IBOnlineValidationService1: TIBOnlineValidationService;
    IBServerProperties1: TIBServerProperties;
    IBStatisticalService1: TIBStatisticalService;
    IBValidationService1: TIBValidationService;
    Memo1: TMemo;
    procedure BringOnlineExecute(Sender: TObject);
    procedure BringOnlineUpdate(Sender: TObject);
    procedure CLoseBtnClick(Sender: TObject);
    procedure BackupBtnClick(Sender: TObject);
    procedure RestoreBtnClick(Sender: TObject);
    procedure ServerLOgBtnClick(Sender: TObject);
    procedure DatabaseBtnClick(Sender: TObject);
    procedure ShutdownExecute(Sender: TObject);
    procedure SweepExecute(Sender: TObject);
    procedure UsersBtnClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure IBServerProperties1Login(Service: TIBCustomService;
      LoginParams: TStrings);
    procedure AltSecDBLogin(Service: TIBCustomService;
      LoginParams: TStrings);
    procedure LimboTransactionsExecute(Sender: TObject);
    procedure StatisticsExecute(Sender: TObject);
    procedure ValidateExecute(Sender: TObject);
  private
    { private declarations }
    FValidationService: TIBControlAndQueryService;
    FDBName: string;
    FServerUserName: string;
    FServerPassword: string;
    FShutDownMode: TShutdownMode;
    FDelay: integer;
    procedure SetDBName(AValue: string);
    procedure UseServerLogin;
    function RunService(aService: TIBCustomService; RunProc: TRunServiceProc
      ): boolean;
    procedure RunShowStatistics;
    procedure RunValidation;
    procedure RunLimboTransactions;
    procedure RunSweep;
    procedure RunBringOnline;
    procedure RunShutdown;
    property DBName: string read FDBName write SetDBName;
  public
    { public declarations }
    function IsDatabaseOnline: boolean;
  end;

var
  MainForm: TMainForm;

implementation

{$R *.lfm}

uses IBErrorCodes, FBMessages, ServicesLoginDlgUnit, SelectValidationDlgUnit, SelectDBDlgUnit,
  BackupDlgUnit, RestoreDlgUnit,  ListUsersUnit, LimboTransactionsUnit, AltDBSvcLoginDlgUnit,
  ShutdownDatabaseDlgUnit, ShutdownRegDlgUnit;

resourcestring
  sDBSweep     = 'Database sweep started';
  sSweepOK     = 'Sweep successfully completed';


{ TMainForm }

procedure TMainForm.FormShow(Sender: TObject);
var i: integer;
begin
  {Set IB Exceptions to only show text message - omit SQLCode and Engine Code}
  FirebirdAPI.GetStatus.SetIBDataBaseErrorMessages([ShowIBMessage]);
  RestoreDlg.IBRestoreService1.DatabaseName.Clear;
  RestoreDlg.IBRestoreService1.DatabaseName.Add(GetTempDir + 'mytest.fdb');
  FDBName := IBStatisticalService1.DatabaseName;
  with IBServerProperties1 do
  begin
    while not Active do
    begin
      try
        Active := true;
      except
       on E:EIBClientError do
        begin
          Close;
          Exit
        end;
       On E:Exception do
         MessageDlg(E.Message,mtError,[mbOK],0);
      end;
    end; {Loop until logged in or user cancels}

    {Display the server properties}
    FetchVersionInfo;
    Memo1.Lines.Add('Server Version = ' + VersionInfo.ServerVersion);
    Memo1.Lines.Add('Server Implementation = ' + VersionInfo.ServerImplementation);
    Memo1.Lines.Add('Service Version = ' + IntToStr(VersionInfo.ServiceVersion));
    Memo1.Lines.Add(Format('Firebird Release = %d.%d.%d (Build no. %d)',[ServerVersionNo[1],
                                                             ServerVersionNo[2],
                                                             ServerVersionNo[3],
                                                             ServerVersionNo[4]]));
    FetchDatabaseInfo;
    Memo1.Lines.Add('No. of attachments = ' + IntToStr(DatabaseInfo.NoOfAttachments));
    Memo1.Lines.Add('No. of databases = ' + IntToStr(DatabaseInfo.NoOfDatabases));
    for i := 0 to DatabaseInfo.NoOfDatabases - 1 do
      Memo1.Lines.Add('DB Name = ' + DatabaseInfo.DbName[i]);
    FetchConfigParams;
    Memo1.Lines.Add('Base Location = ' + ConfigParams.BaseLocation);
    Memo1.Lines.Add('Lock File Location = ' + ConfigParams.LockFileLocation);
    Memo1.Lines.Add('Security Database Location = ' + ConfigParams.SecurityDatabaseLocation);
    Memo1.Lines.Add('Message File Location = ' + ConfigParams.MessageFileLocation);
    for i := Low(ConfigParams.ConfigFileParams) to High(ConfigParams.ConfigFileParams) do
      writeln(ConfigParams.ConfigFileParams[i]);
    for i := Low(ConfigParams.ConfigFileData.ConfigFileKey) to High(ConfigParams.ConfigFileData.ConfigFileKey) do
      writeln(ConfigParams.ConfigFileData.ConfigFileKey[i],' = ',ConfigParams.ConfigFileData.ConfigFileValue[i]);
  end;
  IBServerProperties1.OnLogin := @AltSecDBLogin;
  {Leave IBServerProperties1 as active and use this as the common service interface}
end;

{This is the initial logon to the default security database on the server}

procedure TMainForm.IBServerProperties1Login(Service: TIBCustomService;
  LoginParams: TStrings);
var aServiceName: string;
    aUserName: string;
    aPassword: string;
begin
  aServiceName := Service.ServerName;
  aUserName := LoginParams.Values['user_name'];
  aPassword := '';
  if SvcLoginDlg.ShowModal(aServiceName, aUserName, aPassword) = mrOK then
  begin
    Service.ServerName := aServiceName;
    LoginParams.Values['user_name'] := aUserName;
    LoginParams.Values['password'] := aPassword;
    FServerUserName := aUserName;
    FServerPassword := aPassword;
  end
  else
    IBError(ibxeOperationCancelled, [nil]);
end;

{This is the login dialog for a alt. security database}

procedure TMainForm.AltSecDBLogin(Service: TIBCustomService;
  LoginParams: TStrings);
var aServiceName: string;
    aUserName: string;
    aPassword: string;
begin
  aServiceName := Service.ServerName;
  aUserName := LoginParams.Values['user_name'];
  aPassword := '';
  if AltDBSvcLoginDlg.ShowModal(aServiceName, aUserName, aPassword) = mrOK then
  begin
    Service.ServerName := aServiceName;
    LoginParams.Values['user_name'] := aUserName;
    LoginParams.Values['password'] := aPassword;
  end
  else
    IBError(ibxeOperationCancelled, [nil]);
end;

procedure TMainForm.LimboTransactionsExecute(Sender: TObject);
var aDBName: string;
begin
  aDBName := DBName;
  with LimboTransactionsForm do
  begin
    if SelectDBDlg.ShowModal(aDBName) = mrOK then
    begin
      DBName := aDBName;
      RunService(LimboTransactionValidation,@RunLimboTransactions);
    end;
  end;
end;

procedure TMainForm.StatisticsExecute(Sender: TObject);
var aDBName: string;
begin
  aDBName := DBName;
  if SelectDBDlg.ShowModal(aDBName) = mrOK then
  begin
    DBName := aDBName;
    IBStatisticalService1.Options := [DataPages];
    RunService(IBStatisticalService1,@RunShowStatistics);
  end;
end;

procedure TMainForm.ValidateExecute(Sender: TObject);
var UseOnlineValidation: boolean;
    aDBName: string;
begin
  UseOnlineValidation := false;
  aDBName := DBName;
  if SelectValidationDlg.ShowModal(IBServerProperties1.ServerName,aDBName,UseOnlineValidation) = mrOK then
  begin
    DBName := aDBName;
    if UseOnlineValidation then
      FValidationService := IBOnlineValidationService1
    else
    begin
      FValidationService :=  IBValidationService1;
      IBValidationService1.Options := [ValidateFull];
    end;
    RunService(FValidationService,@RunValidation);
  end;
end;

procedure TMainForm.SetDBName(AValue: string);
begin
  if FDBName = AValue then Exit;
  UseServerLogin;
  FDBName := AValue;
end;

procedure TMainForm.UseServerLogin;
var index: integer;
begin
  index := IBServerProperties1.Params.IndexOfName('expected_db');
  if index <> -1 then
  begin
    {Log back in at Server Level}
    IBServerProperties1.Active := false;
    IBServerProperties1.LoginPrompt := false;
    IBServerProperties1.Params.Values['user_name'] := FServerUserName;
    IBServerProperties1.Params.Values['password'] := FServerPassword;
    IBServerProperties1.Params.Delete(index);
    IBServerProperties1.Active := true;
  end;
end;

{Common code for launching a service that might need to use and alt. security database}

function TMainForm.RunService(aService: TIBCustomService; RunProc: TRunServiceProc
  ): boolean;

  procedure AltDBLogin;
  var index: integer;
  begin
    with IBServerProperties1 do
    begin
      Active := false;
      LoginPrompt := true;
      Params.Add('expected_db='+DBName);
      index := Params.IndexOfName('password');
      if index <> -1 then
        Params.Delete(index);

      {Now make sure we are logged in}

      while not Active do
      begin
        try
          Active := true;
        except
         on E:EIBClientError do
            raise;
         On E:Exception do
         begin
           MessageDlg(E.Message,mtError,[mbOK],0);
           Active := false;
         end;
        end;
      end; {Loop until logged in or user cancels}

    end;
  end;

begin
  Result := false;
  if aService is TIBValidationService then
    TIBValidationService(aService).DatabaseName := DBName
  else
  if aService is TIBOnlineValidationService then
      TIBOnlineValidationService(aService).DatabaseName := DBName
  else
  if aService is TIBStatisticalService then
    TIBStatisticalService(aService).DatabaseName := DBName
  else
  if aService is TIBConfigService then
    TIBConfigService(aService).DatabaseName := DBName;
  try
    repeat
      with aService do
      begin
        Active := false;
        Assign(IBServerProperties1);
      end;
      try
        RunProc;
        Result := true;
      except
        on E:EIBClientError do {Typically Login cancelled}
          begin
            MessageDlg(E.Message,mtError,[mbOK],0);
            Exit;
          end;
         on E: EIBInterBaseError do
           if E.IBErrorCode = isc_sec_context then {Need expected_db}
             AltDBLogin
           else
             raise;
        end;
      aService.Active := false;
    until Result;
  except on E:Exception do
    MessageDlg(E.Message,mtError,[mbOK],0);
  end;
end;

procedure TMainForm.RunShowStatistics;
begin
  with IBStatisticalService1 do
  begin
    ServiceStart;
    Memo1.Lines.Add('Database Statistics for ' + IBStatisticalService1.DatabaseName);
    while not Eof do
    begin
      Memo1.Lines.Add(GetNextLine);
      Application.ProcessMessages;
    end;
  end;
end;

procedure TMainForm.RunValidation;
begin
  with FValidationService do
  begin
    ServiceStart;
    Memo1.Lines.Add('Running...');
    while not Eof do
    begin
      Memo1.Lines.Add(GetNextLine);
      Application.ProcessMessages;
    end;
    Memo1.Lines.Add('Validation Completed');
    MessageDlg('Validation Completed',mtInformation,[mbOK],0);
  end;
end;

procedure TMainForm.RunLimboTransactions;
begin
  with LimboTransactionsForm do
  begin
    {test access credentials}
    LimboTransactionValidation.ServiceStart;
    LimboTransactionValidation.FetchLimboTransactionInfo;
    ShowModal;
  end;
end;

procedure TMainForm.RunSweep;
var ReportCount: integer;
begin
  ReportCount := 0;
  with IBValidationService1 do
  begin
    Memo1.Lines.Add(Format(sDBSweep,[DatabaseName]));
    try
      ServiceStart;
      While not Eof do
      begin
        Inc(ReportCount);
        Memo1.Lines.Add(GetNextLine);
        Application.ProcessMessages;
      end
    finally
      while IsServiceRunning do;
    end
  end;
  Memo1.Lines.Add(sSweepOK);
end;

function TMainForm.IsDatabaseOnline: boolean;
var Line: string;
begin
  {Scan header page to see if database is online - assumes that service is already set up}
  Result := true;
  with IBStatisticalService1 do
  begin
    Assign(IBServerProperties1);
    Options := [HeaderPages];
    Active := True;
    try
      ServiceStart;
      while not Eof do
      begin
         Line := GetNextLine;
         if (Pos('Attributes',Line) <> 0) and ((Pos('database shutdown',Line) <> 0)
                   or (Pos('multi-user maintenance',Line) <> 0)) then
           Result := false;

      end;
      while IsServiceRunning do;
    finally
      Active := False;
    end
  end;
end;

procedure TMainForm.RunBringOnline;
begin
  if IsDatabaseOnline then
    MessageDlg('Database is already online!',mtInformation,[mbOK],0)
  else
  begin
    IBConfigService1.Assign(IBServerProperties1);
    IBConfigService1.DatabaseName := DBName;
    IBConfigService1.BringDatabaseOnline;
    while IBConfigService1.IsServiceRunning do;
    if IsDatabaseOnline then
      MessageDlg('Database is back online',mtInformation,[mbOK],0)
    else
      MessageDlg('Database is still shutdown!',mtError,[mbOK],0);
  end;
end;

procedure TMainForm.RunShutdown;
begin
  if not IsDatabaseOnline then
    MessageDlg('Database is already shutdown!',mtInformation,[mbOK],0)
  else
  begin
    ShutdownDatabaseDlg.IBConfigService.DatabaseName := DBName;
    ShutdownDatabaseDlg.Shutdown(FShutDownMode,FDelay);
  end;
end;

procedure TMainForm.CLoseBtnClick(Sender: TObject);
begin
  Close
end;

procedure TMainForm.BringOnlineExecute(Sender: TObject);
var aDBName: string;
begin
  aDBName := DBName;
  if SelectDBDlg.ShowModal(aDBName) = mrOK then
  begin
    DBName := aDBName;
    RunService(IBStatisticalService1,@RunBringOnline);
  end;
end;

procedure TMainForm.BringOnlineUpdate(Sender: TObject);
begin
  (Sender as TAction).Enabled := not ShutdownDatabaseDlg.Aborting;
end;

procedure TMainForm.BackupBtnClick(Sender: TObject);
begin
  BackupDlg.IBBackupService1.ServerName := IBServerProperties1.ServerName;
  BackupDlg.IBBackupService1.DatabaseName := DBName;
  if BackupDlg.ShowModal = mrOK then
  begin
    DBName := BackupDlg.IBBackupService1.DatabaseName;
    Runservice(BackupDlg.IBBackupService1,@BackupDlg.RunBackup);
  end;
end;

procedure TMainForm.RestoreBtnClick(Sender: TObject);
begin
  RestoreDlg.IBRestoreService1.ServerName := IBServerProperties1.ServerName;
  RestoreDlg.IBRestoreService1.DatabaseName[0] := DBName;
  if RestoreDlg.ShowModal = mrOK then
  begin
    DBName := RestoreDlg.IBRestoreService1.DatabaseName[0];
    UseServerLogin; {Avoid server hanging if we use an alt. sec. database wrongly}
    RunService(RestoreDlg.IBRestoreService1,@RestoreDlg.RunRestore);
  end;
end;

procedure TMainForm.ServerLOgBtnClick(Sender: TObject);
begin
  Memo1.Lines.Add('Server Log');
  {No chance that we will need an alt. security database - so just assign it the
   server connection}
  IBLogService1.Assign(IBServerProperties1);
  with IBLogService1 do
  begin
    ServiceStart;
    while not Eof do
    begin
      Memo1.Lines.Add(GetNextLine);
      Application.ProcessMessages;
    end;
  end;
end;

procedure TMainForm.DatabaseBtnClick(Sender: TObject);
begin
  PopupMenu1.PopUp(Mouse.CursorPos.X,Mouse.CursorPos.Y);
end;

procedure TMainForm.ShutdownExecute(Sender: TObject);
var aDBName: string;
begin
  aDBName := DBName;
  FShutDownMode := DenyTransaction;
  if ShutdownReqDlg.ShowModal(aDBName,FShutDownMode,FDelay) = mrOK then
  begin
    DBName := aDBName;
    RunService(ShutdownDatabaseDlg.IBConfigService,@RunShutdown);
  end;
end;

procedure TMainForm.SweepExecute(Sender: TObject);
var aDBName: string;
begin
  aDBName := DBName;
  if SelectDBDlg.ShowModal(aDBName) = mrOK then
  begin
    DBName := aDBName;
    IBValidationService1.Options := [SweepDB];
    RunService(IBValidationService1,@RunSweep);
  end;
end;

procedure TMainForm.UsersBtnClick(Sender: TObject);
begin
  UseServerLogin;
  with ListUsersForm do
  begin
    {No chance that we will need an alt. security database - so just assign it the
     server connection}
    IBSecurityService1.Assign(IBServerProperties1);
    ShowModal;
  end;
end;

end.

Revision:	143
Committed:	Fri Feb 23 12:11:21 2018 UTC (6 years, 9 months ago) by tony
Content type:	text/x-pascal
File size:	17242 byte(s)
Log Message:	Fixes Merged
#	User	Rev	Content
1	tony	143	(*
2			* IBX For Lazarus (Firebird Express)
3			*
4			* The contents of this file are subject to the Initial Developer's
5			* Public License Version 1.0 (the "License"); you may not use this
6			* file except in compliance with the License. You may obtain a copy
7			* of the License here:
8			*
9			* http://www.firebirdsql.org/index.php?op=doc&id=idpl
10			*
11			* Software distributed under the License is distributed on an "AS
12			* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
13			* implied. See the License for the specific language governing rights
14			* and limitations under the License.
15			*
16			* The Initial Developer of the Original Code is Tony Whyman.
17			*
18			* The Original Code is (C) 2015 Tony Whyman, MWA Software
19			* (http://www.mwasoftware.co.uk).
20			*
21			* All Rights Reserved.
22			*
23			* Contributor(s): ______________________________________.
24			*
25			*)
26
27			unit MainFormUnit;
28
29			{$mode objfpc}{$H+}
30
31			interface
32
33			uses
34			Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
35			ActnList, Menus, IBServices, IB;
36
37			type
38
39			TRunServiceProc = procedure of object;
40
41			{ TMainForm }
42
43			TMainForm = class(TForm)
44			IBConfigService1: TIBConfigService;
45			MenuItem6: TMenuItem;
46			Shutdown: TAction;
47			BringOnline: TAction;
48			MenuItem1: TMenuItem;
49			MenuItem5: TMenuItem;
50			Sweep: TAction;
51			LimboTransactions: TAction;
52			MenuItem2: TMenuItem;
53			MenuItem3: TMenuItem;
54			MenuItem4: TMenuItem;
55			PopupMenu1: TPopupMenu;
56			Validate: TAction;
57			Statistics: TAction;
58			ActionList1: TActionList;
59			CLoseBtn: TButton;
60			BackupBtn: TButton;
61			RestoreBtn: TButton;
62			ServerLOgBtn: TButton;
63			DatabaseBtn: TButton;
64			UsersBtn: TButton;
65			IBLogService1: TIBLogService;
66			IBOnlineValidationService1: TIBOnlineValidationService;
67			IBServerProperties1: TIBServerProperties;
68			IBStatisticalService1: TIBStatisticalService;
69			IBValidationService1: TIBValidationService;
70			Memo1: TMemo;
71			procedure BringOnlineExecute(Sender: TObject);
72			procedure BringOnlineUpdate(Sender: TObject);
73			procedure CLoseBtnClick(Sender: TObject);
74			procedure BackupBtnClick(Sender: TObject);
75			procedure RestoreBtnClick(Sender: TObject);
76			procedure ServerLOgBtnClick(Sender: TObject);
77			procedure DatabaseBtnClick(Sender: TObject);
78			procedure ShutdownExecute(Sender: TObject);
79			procedure SweepExecute(Sender: TObject);
80			procedure UsersBtnClick(Sender: TObject);
81			procedure FormShow(Sender: TObject);
82			procedure IBServerProperties1Login(Service: TIBCustomService;
83			LoginParams: TStrings);
84			procedure AltSecDBLogin(Service: TIBCustomService;
85			LoginParams: TStrings);
86			procedure LimboTransactionsExecute(Sender: TObject);
87			procedure StatisticsExecute(Sender: TObject);
88			procedure ValidateExecute(Sender: TObject);
89			private
90			{ private declarations }
91			FValidationService: TIBControlAndQueryService;
92			FDBName: string;
93			FServerUserName: string;
94			FServerPassword: string;
95			FShutDownMode: TShutdownMode;
96			FDelay: integer;
97			procedure SetDBName(AValue: string);
98			procedure UseServerLogin;
99			function RunService(aService: TIBCustomService; RunProc: TRunServiceProc
100			): boolean;
101			procedure RunShowStatistics;
102			procedure RunValidation;
103			procedure RunLimboTransactions;
104			procedure RunSweep;
105			procedure RunBringOnline;
106			procedure RunShutdown;
107			property DBName: string read FDBName write SetDBName;
108			public
109			{ public declarations }
110			function IsDatabaseOnline: boolean;
111			end;
112
113			var
114			MainForm: TMainForm;
115
116			implementation
117
118			{$R *.lfm}
119
120			uses IBErrorCodes, FBMessages, ServicesLoginDlgUnit, SelectValidationDlgUnit, SelectDBDlgUnit,
121			BackupDlgUnit, RestoreDlgUnit, ListUsersUnit, LimboTransactionsUnit, AltDBSvcLoginDlgUnit,
122			ShutdownDatabaseDlgUnit, ShutdownRegDlgUnit;
123
124			resourcestring
125			sDBSweep = 'Database sweep started';
126			sSweepOK = 'Sweep successfully completed';
127
128
129			{ TMainForm }
130
131			procedure TMainForm.FormShow(Sender: TObject);
132			var i: integer;
133			begin
134			{Set IB Exceptions to only show text message - omit SQLCode and Engine Code}
135			FirebirdAPI.GetStatus.SetIBDataBaseErrorMessages([ShowIBMessage]);
136			RestoreDlg.IBRestoreService1.DatabaseName.Clear;
137			RestoreDlg.IBRestoreService1.DatabaseName.Add(GetTempDir + 'mytest.fdb');
138			FDBName := IBStatisticalService1.DatabaseName;
139			with IBServerProperties1 do
140			begin
141			while not Active do
142			begin
143			try
144			Active := true;
145			except
146			on E:EIBClientError do
147			begin
148			Close;
149			Exit
150			end;
151			On E:Exception do
152			MessageDlg(E.Message,mtError,[mbOK],0);
153			end;
154			end; {Loop until logged in or user cancels}
155
156			{Display the server properties}
157			FetchVersionInfo;
158			Memo1.Lines.Add('Server Version = ' + VersionInfo.ServerVersion);
159			Memo1.Lines.Add('Server Implementation = ' + VersionInfo.ServerImplementation);
160			Memo1.Lines.Add('Service Version = ' + IntToStr(VersionInfo.ServiceVersion));
161			Memo1.Lines.Add(Format('Firebird Release = %d.%d.%d (Build no. %d)',[ServerVersionNo[1],
162			ServerVersionNo[2],
163			ServerVersionNo[3],
164			ServerVersionNo[4]]));
165			FetchDatabaseInfo;
166			Memo1.Lines.Add('No. of attachments = ' + IntToStr(DatabaseInfo.NoOfAttachments));
167			Memo1.Lines.Add('No. of databases = ' + IntToStr(DatabaseInfo.NoOfDatabases));
168			for i := 0 to DatabaseInfo.NoOfDatabases - 1 do
169			Memo1.Lines.Add('DB Name = ' + DatabaseInfo.DbName[i]);
170			FetchConfigParams;
171			Memo1.Lines.Add('Base Location = ' + ConfigParams.BaseLocation);
172			Memo1.Lines.Add('Lock File Location = ' + ConfigParams.LockFileLocation);
173			Memo1.Lines.Add('Security Database Location = ' + ConfigParams.SecurityDatabaseLocation);
174			Memo1.Lines.Add('Message File Location = ' + ConfigParams.MessageFileLocation);
175			for i := Low(ConfigParams.ConfigFileParams) to High(ConfigParams.ConfigFileParams) do
176			writeln(ConfigParams.ConfigFileParams[i]);
177			for i := Low(ConfigParams.ConfigFileData.ConfigFileKey) to High(ConfigParams.ConfigFileData.ConfigFileKey) do
178			writeln(ConfigParams.ConfigFileData.ConfigFileKey[i],' = ',ConfigParams.ConfigFileData.ConfigFileValue[i]);
179			end;
180			IBServerProperties1.OnLogin := @AltSecDBLogin;
181			{Leave IBServerProperties1 as active and use this as the common service interface}
182			end;
183
184			{This is the initial logon to the default security database on the server}
185
186			procedure TMainForm.IBServerProperties1Login(Service: TIBCustomService;
187			LoginParams: TStrings);
188			var aServiceName: string;
189			aUserName: string;
190			aPassword: string;
191			begin
192			aServiceName := Service.ServerName;
193			aUserName := LoginParams.Values['user_name'];
194			aPassword := '';
195			if SvcLoginDlg.ShowModal(aServiceName, aUserName, aPassword) = mrOK then
196			begin
197			Service.ServerName := aServiceName;
198			LoginParams.Values['user_name'] := aUserName;
199			LoginParams.Values['password'] := aPassword;
200			FServerUserName := aUserName;
201			FServerPassword := aPassword;
202			end
203			else
204			IBError(ibxeOperationCancelled, [nil]);
205			end;
206
207			{This is the login dialog for a alt. security database}
208
209			procedure TMainForm.AltSecDBLogin(Service: TIBCustomService;
210			LoginParams: TStrings);
211			var aServiceName: string;
212			aUserName: string;
213			aPassword: string;
214			begin
215			aServiceName := Service.ServerName;
216			aUserName := LoginParams.Values['user_name'];
217			aPassword := '';
218			if AltDBSvcLoginDlg.ShowModal(aServiceName, aUserName, aPassword) = mrOK then
219			begin
220			Service.ServerName := aServiceName;
221			LoginParams.Values['user_name'] := aUserName;
222			LoginParams.Values['password'] := aPassword;
223			end
224			else
225			IBError(ibxeOperationCancelled, [nil]);
226			end;
227
228			procedure TMainForm.LimboTransactionsExecute(Sender: TObject);
229			var aDBName: string;
230			begin
231			aDBName := DBName;
232			with LimboTransactionsForm do
233			begin
234			if SelectDBDlg.ShowModal(aDBName) = mrOK then
235			begin
236			DBName := aDBName;
237			RunService(LimboTransactionValidation,@RunLimboTransactions);
238			end;
239			end;
240			end;
241
242			procedure TMainForm.StatisticsExecute(Sender: TObject);
243			var aDBName: string;
244			begin
245			aDBName := DBName;
246			if SelectDBDlg.ShowModal(aDBName) = mrOK then
247			begin
248			DBName := aDBName;
249			IBStatisticalService1.Options := [DataPages];
250			RunService(IBStatisticalService1,@RunShowStatistics);
251			end;
252			end;
253
254			procedure TMainForm.ValidateExecute(Sender: TObject);
255			var UseOnlineValidation: boolean;
256			aDBName: string;
257			begin
258			UseOnlineValidation := false;
259			aDBName := DBName;
260			if SelectValidationDlg.ShowModal(IBServerProperties1.ServerName,aDBName,UseOnlineValidation) = mrOK then
261			begin
262			DBName := aDBName;
263			if UseOnlineValidation then
264			FValidationService := IBOnlineValidationService1
265			else
266			begin
267			FValidationService := IBValidationService1;
268			IBValidationService1.Options := [ValidateFull];
269			end;
270			RunService(FValidationService,@RunValidation);
271			end;
272			end;
273
274			procedure TMainForm.SetDBName(AValue: string);
275			begin
276			if FDBName = AValue then Exit;
277			UseServerLogin;
278			FDBName := AValue;
279			end;
280
281			procedure TMainForm.UseServerLogin;
282			var index: integer;
283			begin
284			index := IBServerProperties1.Params.IndexOfName('expected_db');
285			if index <> -1 then
286			begin
287			{Log back in at Server Level}
288			IBServerProperties1.Active := false;
289			IBServerProperties1.LoginPrompt := false;
290			IBServerProperties1.Params.Values['user_name'] := FServerUserName;
291			IBServerProperties1.Params.Values['password'] := FServerPassword;
292			IBServerProperties1.Params.Delete(index);
293			IBServerProperties1.Active := true;
294			end;
295			end;
296
297			{Common code for launching a service that might need to use and alt. security database}
298
299			function TMainForm.RunService(aService: TIBCustomService; RunProc: TRunServiceProc
300			): boolean;
301
302			procedure AltDBLogin;
303			var index: integer;
304			begin
305			with IBServerProperties1 do
306			begin
307			Active := false;
308			LoginPrompt := true;
309			Params.Add('expected_db='+DBName);
310			index := Params.IndexOfName('password');
311			if index <> -1 then
312			Params.Delete(index);
313
314			{Now make sure we are logged in}
315
316			while not Active do
317			begin
318			try
319			Active := true;
320			except
321			on E:EIBClientError do
322			raise;
323			On E:Exception do
324			begin
325			MessageDlg(E.Message,mtError,[mbOK],0);
326			Active := false;
327			end;
328			end;
329			end; {Loop until logged in or user cancels}
330
331			end;
332			end;
333
334			begin
335			Result := false;
336			if aService is TIBValidationService then
337			TIBValidationService(aService).DatabaseName := DBName
338			else
339			if aService is TIBOnlineValidationService then
340			TIBOnlineValidationService(aService).DatabaseName := DBName
341			else
342			if aService is TIBStatisticalService then
343			TIBStatisticalService(aService).DatabaseName := DBName
344			else
345			if aService is TIBConfigService then
346			TIBConfigService(aService).DatabaseName := DBName;
347			try
348			repeat
349			with aService do
350			begin
351			Active := false;
352			Assign(IBServerProperties1);
353			end;
354			try
355			RunProc;
356			Result := true;
357			except
358			on E:EIBClientError do {Typically Login cancelled}
359			begin
360			MessageDlg(E.Message,mtError,[mbOK],0);
361			Exit;
362			end;
363			on E: EIBInterBaseError do
364			if E.IBErrorCode = isc_sec_context then {Need expected_db}
365			AltDBLogin
366			else
367			raise;
368			end;
369			aService.Active := false;
370			until Result;
371			except on E:Exception do
372			MessageDlg(E.Message,mtError,[mbOK],0);
373			end;
374			end;
375
376			procedure TMainForm.RunShowStatistics;
377			begin
378			with IBStatisticalService1 do
379			begin
380			ServiceStart;
381			Memo1.Lines.Add('Database Statistics for ' + IBStatisticalService1.DatabaseName);
382			while not Eof do
383			begin
384			Memo1.Lines.Add(GetNextLine);
385			Application.ProcessMessages;
386			end;
387			end;
388			end;
389
390			procedure TMainForm.RunValidation;
391			begin
392			with FValidationService do
393			begin
394			ServiceStart;
395			Memo1.Lines.Add('Running...');
396			while not Eof do
397			begin
398			Memo1.Lines.Add(GetNextLine);
399			Application.ProcessMessages;
400			end;
401			Memo1.Lines.Add('Validation Completed');
402			MessageDlg('Validation Completed',mtInformation,[mbOK],0);
403			end;
404			end;
405
406			procedure TMainForm.RunLimboTransactions;
407			begin
408			with LimboTransactionsForm do
409			begin
410			{test access credentials}
411			LimboTransactionValidation.ServiceStart;
412			LimboTransactionValidation.FetchLimboTransactionInfo;
413			ShowModal;
414			end;
415			end;
416
417			procedure TMainForm.RunSweep;
418			var ReportCount: integer;
419			begin
420			ReportCount := 0;
421			with IBValidationService1 do
422			begin
423			Memo1.Lines.Add(Format(sDBSweep,[DatabaseName]));
424			try
425			ServiceStart;
426			While not Eof do
427			begin
428			Inc(ReportCount);
429			Memo1.Lines.Add(GetNextLine);
430			Application.ProcessMessages;
431			end
432			finally
433			while IsServiceRunning do;
434			end
435			end;
436			Memo1.Lines.Add(sSweepOK);
437			end;
438
439			function TMainForm.IsDatabaseOnline: boolean;
440			var Line: string;
441			begin
442			{Scan header page to see if database is online - assumes that service is already set up}
443			Result := true;
444			with IBStatisticalService1 do
445			begin
446			Assign(IBServerProperties1);
447			Options := [HeaderPages];
448			Active := True;
449			try
450			ServiceStart;
451			while not Eof do
452			begin
453			Line := GetNextLine;
454			if (Pos('Attributes',Line) <> 0) and ((Pos('database shutdown',Line) <> 0)
455			or (Pos('multi-user maintenance',Line) <> 0)) then
456			Result := false;
457
458			end;
459			while IsServiceRunning do;
460			finally
461			Active := False;
462			end
463			end;
464			end;
465
466			procedure TMainForm.RunBringOnline;
467			begin
468			if IsDatabaseOnline then
469			MessageDlg('Database is already online!',mtInformation,[mbOK],0)
470			else
471			begin
472			IBConfigService1.Assign(IBServerProperties1);
473			IBConfigService1.DatabaseName := DBName;
474			IBConfigService1.BringDatabaseOnline;
475			while IBConfigService1.IsServiceRunning do;
476			if IsDatabaseOnline then
477			MessageDlg('Database is back online',mtInformation,[mbOK],0)
478			else
479			MessageDlg('Database is still shutdown!',mtError,[mbOK],0);
480			end;
481			end;
482
483			procedure TMainForm.RunShutdown;
484			begin
485			if not IsDatabaseOnline then
486			MessageDlg('Database is already shutdown!',mtInformation,[mbOK],0)
487			else
488			begin
489			ShutdownDatabaseDlg.IBConfigService.DatabaseName := DBName;
490			ShutdownDatabaseDlg.Shutdown(FShutDownMode,FDelay);
491			end;
492			end;
493
494			procedure TMainForm.CLoseBtnClick(Sender: TObject);
495			begin
496			Close
497			end;
498
499			procedure TMainForm.BringOnlineExecute(Sender: TObject);
500			var aDBName: string;
501			begin
502			aDBName := DBName;
503			if SelectDBDlg.ShowModal(aDBName) = mrOK then
504			begin
505			DBName := aDBName;
506			RunService(IBStatisticalService1,@RunBringOnline);
507			end;
508			end;
509
510			procedure TMainForm.BringOnlineUpdate(Sender: TObject);
511			begin
512			(Sender as TAction).Enabled := not ShutdownDatabaseDlg.Aborting;
513			end;
514
515			procedure TMainForm.BackupBtnClick(Sender: TObject);
516			begin
517			BackupDlg.IBBackupService1.ServerName := IBServerProperties1.ServerName;
518			BackupDlg.IBBackupService1.DatabaseName := DBName;
519			if BackupDlg.ShowModal = mrOK then
520			begin
521			DBName := BackupDlg.IBBackupService1.DatabaseName;
522			Runservice(BackupDlg.IBBackupService1,@BackupDlg.RunBackup);
523			end;
524			end;
525
526			procedure TMainForm.RestoreBtnClick(Sender: TObject);
527			begin
528			RestoreDlg.IBRestoreService1.ServerName := IBServerProperties1.ServerName;
529			RestoreDlg.IBRestoreService1.DatabaseName[0] := DBName;
530			if RestoreDlg.ShowModal = mrOK then
531			begin
532			DBName := RestoreDlg.IBRestoreService1.DatabaseName[0];
533			UseServerLogin; {Avoid server hanging if we use an alt. sec. database wrongly}
534			RunService(RestoreDlg.IBRestoreService1,@RestoreDlg.RunRestore);
535			end;
536			end;
537
538			procedure TMainForm.ServerLOgBtnClick(Sender: TObject);
539			begin
540			Memo1.Lines.Add('Server Log');
541			{No chance that we will need an alt. security database - so just assign it the
542			server connection}
543			IBLogService1.Assign(IBServerProperties1);
544			with IBLogService1 do
545			begin
546			ServiceStart;
547			while not Eof do
548			begin
549			Memo1.Lines.Add(GetNextLine);
550			Application.ProcessMessages;
551			end;
552			end;
553			end;
554
555			procedure TMainForm.DatabaseBtnClick(Sender: TObject);
556			begin
557			PopupMenu1.PopUp(Mouse.CursorPos.X,Mouse.CursorPos.Y);
558			end;
559
560			procedure TMainForm.ShutdownExecute(Sender: TObject);
561			var aDBName: string;
562			begin
563			aDBName := DBName;
564			FShutDownMode := DenyTransaction;
565			if ShutdownReqDlg.ShowModal(aDBName,FShutDownMode,FDelay) = mrOK then
566			begin
567			DBName := aDBName;
568			RunService(ShutdownDatabaseDlg.IBConfigService,@RunShutdown);
569			end;
570			end;
571
572			procedure TMainForm.SweepExecute(Sender: TObject);
573			var aDBName: string;
574			begin
575			aDBName := DBName;
576			if SelectDBDlg.ShowModal(aDBName) = mrOK then
577			begin
578			DBName := aDBName;
579			IBValidationService1.Options := [SweepDB];
580			RunService(IBValidationService1,@RunSweep);
581			end;
582			end;
583
584			procedure TMainForm.UsersBtnClick(Sender: TObject);
585			begin
586			UseServerLogin;
587			with ListUsersForm do
588			begin
589			{No chance that we will need an alt. security database - so just assign it the
590			server connection}
591			IBSecurityService1.Assign(IBServerProperties1);
592			ShowModal;
593			end;
594			end;
595
596			end.
597