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