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
#	Content
1	(*
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