DBAdmin/dlg/ShutdownDatabaseDlgUnit.pas

(*
 * ShutdownDatabaseDlgUnit.pas
 * Copyright (C) 2018 Tony Whyman <tony@mwasoftware.co.uk>
 *
 * DBAdmin is free software: you can redistribute it and/or modify it
 * under the terms of the GNU General Public License as published by the
 * Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 * 
 * DBAdmin 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 General Public License for more details.
 * 
 * You should have received a copy of the GNU General Public License along
 * with this program.  If not, see <http://www.gnu.org/licenses/>.
 *)
unit ShutdownDatabaseDlgUnit;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  ComCtrls, ExtCtrls, IBServices, IB;

type

  { TShutdownDatabaseDlg }

  TShutdownDatabaseDlg = class(TForm)
    Bevel1: TBevel;
    CloseBtn: TButton;
    IBConfigService: TIBConfigService;
    ProgressBar1: TProgressBar;
    StatusMsg: TLabel;
    procedure CloseBtnClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    FShutDownmode: TShutdownMode;
    FDelay: integer;
    FAborting: boolean;
    FSecContextError: boolean;
    FShutdownWaitThread: TThread;
    procedure OnWaitCompleted(Sender: TObject);
  public
     procedure Shutdown(aService: TIBConfigService; aShutDownmode: TShutdownMode;
       aDelay: integer);
     property Aborting: boolean read FAborting;
  end;

var
  ShutdownDatabaseDlg: TShutdownDatabaseDlg;

implementation

{$R *.lfm}

uses IBErrorCodes;

resourcestring
  sWaitStatusMsg = 'Waiting for %s to shutdown';
  sDatabaseShutdown  = 'Database has been successfully shutdown';
  sOnCompleted = 'Shutdown of %s completed with response: %s';

type
    { TShutdownWaitThread }

  TShutdownWaitThread = class(TThread)
  private
    FErrorMessage: string;
    FIBConfigService: TIBConfigService;
    FOptions: TShutdownMode;
    FSecContextError: boolean;
    FSuccess: boolean;
    FWait: integer;
    FOnCompleted: TNotifyEvent;
    procedure DoCallback;
  protected
    procedure Execute; override;
  public
    constructor Create(aService: TIBConfigService; Options: TShutdownMode;
      Wait: Integer; OnCompleted: TNotifyEvent);
    destructor Destroy; override;
    procedure Abort;
    property Success: boolean read FSuccess;
    property SecContextError: boolean read FSecContextError;
    property ErrorMessage: string read FErrorMessage;
  end;


{ TShutdownWaitThread }

procedure TShutdownWaitThread.DoCallback;
begin
  if assigned(FOnCompleted) then
    FOnCompleted(self);
end;

procedure TShutdownWaitThread.Execute;
begin
  FSuccess := false;
  FIBConfigService.Active := true;
  try
    try
      FIBConfigService.ShutDownDatabase(FOptions,FWait);
      FErrorMessage := 'Completed without error';
      FSuccess := true;
    except
      on E: EIBInterBaseError do
        if E.IBErrorCode = isc_sec_context then
          FSecContextError := true
        else
          FErrorMessage := E.Message;

      on E: Exception do
        FErrorMessage := E.Message;
    end;
  finally
    if not FSecContextError then
    try
      while FIBConfigService.IsServiceRunning do;
    except   end;
    if Terminated and FSuccess then
      FIBConfigService.BringDatabaseOnline;
    FIBConfigService.Active := false;
  end;
  Synchronize(@DoCallback);
end;

constructor TShutdownWaitThread.Create(aService: TIBConfigService;
  Options: TShutdownMode; Wait: Integer; OnCompleted: TNotifyEvent);
begin
  inherited Create(false);
  FOptions := Options;
  FWait := Wait;
  FOnCompleted := OnCompleted;
  FreeOnTerminate := true;
  FIBConfigService := TIBConfigService.Create(nil);
  FIBConfigService.Assign(aService);
  FIBConfigService.DatabaseName := aService.DatabaseNAme;
end;

destructor TShutdownWaitThread.Destroy;
begin
  if FIBConfigService <> nil then FIBConfigService.Free;
  inherited Destroy;
end;

procedure TShutdownWaitThread.Abort;
begin
  Terminate;
end;

{ TShutdownDatabaseDlg }

procedure TShutdownDatabaseDlg.FormShow(Sender: TObject);
begin
  FAborting := false;
  StatusMsg.Caption := Format(sWaitStatusMsg,[IBConfigService.DatabaseName]);
  FShutdownWaitThread := TShutdownWaitThread.Create(IBConfigService,FShutDownMode,FDelay,@OnWaitCompleted);
end;

procedure TShutdownDatabaseDlg.CloseBtnClick(Sender: TObject);
begin
  FAborting := true;
  FShutdownWaitThread.Terminate;
  Close;
end;

procedure TShutdownDatabaseDlg.OnWaitCompleted(Sender: TObject);
begin
  with TShutdownWaitThread(Sender) do
    if not Success and SecContextError then
      self.FSecContextError := true
    else
    if not FAborting then
      MessageDlg(Format(sOnCompleted,[IBConfigService.DatabaseName,ErrorMessage]),
               mtInformation,[mbOK],0);
  FAborting := false;
  Close;
end;

procedure TShutdownDatabaseDlg.Shutdown(aService: TIBConfigService;
  aShutDownmode: TShutdownMode; aDelay: integer);
begin
  IBConfigService.Assign(aService);
  IBConfigService.DatabaseName := aService.DatabaseName;
  FShutDownmode := aShutDownmode;
  FDelay := aDelay;
  FSecContextError := false;
  if aDelay <= 0 then
  begin
    IBConfigService.Active := true;
    try
      IBConfigService.ShutDownDatabase(aShutDownmode,0);
      while IBConfigService.IsServiceRunning do;
      if aDelay = 0 then
        MessageDlg(sDatabaseShutdown,mtInformation,[mbOK],0);
    finally
      IBConfigService.Active := false;
    end
  end
  else
  begin
    ShowModal;
    if FSecContextError  then
      raise EIBInterBaseError.Create(FirebirdAPI.getStatus); {re-raise the error}
  end;
end;

end.

Revision:	158
Committed:	Thu Mar 1 11:23:33 2018 UTC (6 years, 1 month ago) by tony
Content type:	text/x-pascal
File size:	5737 byte(s)
Log Message:	Repository resync
#	User	Rev	Content
1	tony	158	(*
2			* ShutdownDatabaseDlgUnit.pas
3			* Copyright (C) 2018 Tony Whyman <tony@mwasoftware.co.uk>
4			*
5			* DBAdmin is free software: you can redistribute it and/or modify it
6			* under the terms of the GNU General Public License as published by the
7			* Free Software Foundation, either version 3 of the License, or
8			* (at your option) any later version.
9			*
10			* DBAdmin is distributed in the hope that it will be useful, but
11			* WITHOUT ANY WARRANTY; without even the implied warranty of
12			* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
13			* See the GNU General Public License for more details.
14			*
15			* You should have received a copy of the GNU General Public License along
16			* with this program. If not, see <http://www.gnu.org/licenses/>.
17			*)
18			unit ShutdownDatabaseDlgUnit;
19
20			{$mode objfpc}{$H+}
21
22			interface
23
24			uses
25			Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
26			ComCtrls, ExtCtrls, IBServices, IB;
27
28			type
29
30			{ TShutdownDatabaseDlg }
31
32			TShutdownDatabaseDlg = class(TForm)
33			Bevel1: TBevel;
34			CloseBtn: TButton;
35			IBConfigService: TIBConfigService;
36			ProgressBar1: TProgressBar;
37			StatusMsg: TLabel;
38			procedure CloseBtnClick(Sender: TObject);
39			procedure FormShow(Sender: TObject);
40			private
41			FShutDownmode: TShutdownMode;
42			FDelay: integer;
43			FAborting: boolean;
44			FSecContextError: boolean;
45			FShutdownWaitThread: TThread;
46			procedure OnWaitCompleted(Sender: TObject);
47			public
48			procedure Shutdown(aService: TIBConfigService; aShutDownmode: TShutdownMode;
49			aDelay: integer);
50			property Aborting: boolean read FAborting;
51			end;
52
53			var
54			ShutdownDatabaseDlg: TShutdownDatabaseDlg;
55
56			implementation
57
58			{$R *.lfm}
59
60			uses IBErrorCodes;
61
62			resourcestring
63			sWaitStatusMsg = 'Waiting for %s to shutdown';
64			sDatabaseShutdown = 'Database has been successfully shutdown';
65			sOnCompleted = 'Shutdown of %s completed with response: %s';
66
67			type
68			{ TShutdownWaitThread }
69
70			TShutdownWaitThread = class(TThread)
71			private
72			FErrorMessage: string;
73			FIBConfigService: TIBConfigService;
74			FOptions: TShutdownMode;
75			FSecContextError: boolean;
76			FSuccess: boolean;
77			FWait: integer;
78			FOnCompleted: TNotifyEvent;
79			procedure DoCallback;
80			protected
81			procedure Execute; override;
82			public
83			constructor Create(aService: TIBConfigService; Options: TShutdownMode;
84			Wait: Integer; OnCompleted: TNotifyEvent);
85			destructor Destroy; override;
86			procedure Abort;
87			property Success: boolean read FSuccess;
88			property SecContextError: boolean read FSecContextError;
89			property ErrorMessage: string read FErrorMessage;
90			end;
91
92
93
94			{ TShutdownWaitThread }
95
96			procedure TShutdownWaitThread.DoCallback;
97			begin
98			if assigned(FOnCompleted) then
99			FOnCompleted(self);
100			end;
101
102			procedure TShutdownWaitThread.Execute;
103			begin
104			FSuccess := false;
105			FIBConfigService.Active := true;
106			try
107			try
108			FIBConfigService.ShutDownDatabase(FOptions,FWait);
109			FErrorMessage := 'Completed without error';
110			FSuccess := true;
111			except
112			on E: EIBInterBaseError do
113			if E.IBErrorCode = isc_sec_context then
114			FSecContextError := true
115			else
116			FErrorMessage := E.Message;
117
118			on E: Exception do
119			FErrorMessage := E.Message;
120			end;
121			finally
122			if not FSecContextError then
123			try
124			while FIBConfigService.IsServiceRunning do;
125			except end;
126			if Terminated and FSuccess then
127			FIBConfigService.BringDatabaseOnline;
128			FIBConfigService.Active := false;
129			end;
130			Synchronize(@DoCallback);
131			end;
132
133			constructor TShutdownWaitThread.Create(aService: TIBConfigService;
134			Options: TShutdownMode; Wait: Integer; OnCompleted: TNotifyEvent);
135			begin
136			inherited Create(false);
137			FOptions := Options;
138			FWait := Wait;
139			FOnCompleted := OnCompleted;
140			FreeOnTerminate := true;
141			FIBConfigService := TIBConfigService.Create(nil);
142			FIBConfigService.Assign(aService);
143			FIBConfigService.DatabaseName := aService.DatabaseNAme;
144			end;
145
146			destructor TShutdownWaitThread.Destroy;
147			begin
148			if FIBConfigService <> nil then FIBConfigService.Free;
149			inherited Destroy;
150			end;
151
152			procedure TShutdownWaitThread.Abort;
153			begin
154			Terminate;
155			end;
156
157			{ TShutdownDatabaseDlg }
158
159			procedure TShutdownDatabaseDlg.FormShow(Sender: TObject);
160			begin
161			FAborting := false;
162			StatusMsg.Caption := Format(sWaitStatusMsg,[IBConfigService.DatabaseName]);
163			FShutdownWaitThread := TShutdownWaitThread.Create(IBConfigService,FShutDownMode,FDelay,@OnWaitCompleted);
164			end;
165
166			procedure TShutdownDatabaseDlg.CloseBtnClick(Sender: TObject);
167			begin
168			FAborting := true;
169			FShutdownWaitThread.Terminate;
170			Close;
171			end;
172
173			procedure TShutdownDatabaseDlg.OnWaitCompleted(Sender: TObject);
174			begin
175			with TShutdownWaitThread(Sender) do
176			if not Success and SecContextError then
177			self.FSecContextError := true
178			else
179			if not FAborting then
180			MessageDlg(Format(sOnCompleted,[IBConfigService.DatabaseName,ErrorMessage]),
181			mtInformation,[mbOK],0);
182			FAborting := false;
183			Close;
184			end;
185
186			procedure TShutdownDatabaseDlg.Shutdown(aService: TIBConfigService;
187			aShutDownmode: TShutdownMode; aDelay: integer);
188			begin
189			IBConfigService.Assign(aService);
190			IBConfigService.DatabaseName := aService.DatabaseName;
191			FShutDownmode := aShutDownmode;
192			FDelay := aDelay;
193			FSecContextError := false;
194			if aDelay <= 0 then
195			begin
196			IBConfigService.Active := true;
197			try
198			IBConfigService.ShutDownDatabase(aShutDownmode,0);
199			while IBConfigService.IsServiceRunning do;
200			if aDelay = 0 then
201			MessageDlg(sDatabaseShutdown,mtInformation,[mbOK],0);
202			finally
203			IBConfigService.Active := false;
204			end
205			end
206			else
207			begin
208			ShowModal;
209			if FSecContextError then
210			raise EIBInterBaseError.Create(FirebirdAPI.getStatus); {re-raise the error}
211			end;
212			end;
213
214			end.
215