ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/examples/services/ShutdownDatabaseDlgUnit.pas
Revision: 209
Committed: Wed Mar 14 12:48:51 2018 UTC (6 years ago) by tony
Content type: text/x-pascal
File size: 5067 byte(s)
Log Message:
Fixes Merged

File Contents

# 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 ShutdownDatabaseDlgUnit;
28
29 {$mode objfpc}{$H+}
30
31 interface
32
33 uses
34 Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
35 ComCtrls, ExtCtrls, IBXServices, IB;
36
37 type
38
39 { TShutdownDatabaseDlg }
40
41 TShutdownDatabaseDlg = class(TForm)
42 Bevel1: TBevel;
43 CloseBtn: TButton;
44 IBConfigService: TIBXConfigService;
45 ProgressBar1: TProgressBar;
46 StatusMsg: TLabel;
47 procedure CloseBtnClick(Sender: TObject);
48 procedure FormShow(Sender: TObject);
49 private
50 FShutDownmode: TDBShutdownMode;
51 FDelay: integer;
52 FAborting: boolean;
53 FSecContextError: boolean;
54 FShutdownWaitThread: TThread;
55 procedure OnWaitCompleted(Sender: TObject);
56 public
57 procedure Shutdown(aDBName: string; aShutDownmode: TDBShutdownMode; aDelay: integer);
58 property Aborting: boolean read FAborting;
59 end;
60
61 var
62 ShutdownDatabaseDlg: TShutdownDatabaseDlg;
63
64 implementation
65
66 {$R *.lfm}
67
68 resourcestring
69 sWaitStatusMsg = 'Waiting for %s to shutdown';
70 sDatabaseShutdown = 'Database has been successfully shutdown';
71 sOnCompleted = 'Shutdown of %s completed with response: %s';
72
73 type
74 { TShutdownWaitThread }
75
76 TShutdownWaitThread = class(TThread)
77 private
78 FErrorMessage: string;
79 FIBConfigService: TIBXConfigService;
80 FOptions: TDBShutdownMode;
81 FSecContextError: boolean;
82 FSuccess: boolean;
83 FWait: integer;
84 FOnCompleted: TNotifyEvent;
85 procedure DoCallback;
86 protected
87 procedure Execute; override;
88 public
89 constructor Create(aService: TIBXConfigService; Options: TDBShutdownMode;
90 Wait: Integer; OnCompleted: TNotifyEvent);
91 destructor Destroy; override;
92 procedure Abort;
93 property Success: boolean read FSuccess;
94 property SecContextError: boolean read FSecContextError;
95 property ErrorMessage: string read FErrorMessage;
96 end;
97
98
99
100 { TShutdownWaitThread }
101
102 procedure TShutdownWaitThread.DoCallback;
103 begin
104 if assigned(FOnCompleted) then
105 FOnCompleted(self);
106 end;
107
108 procedure TShutdownWaitThread.Execute;
109 begin
110 FSuccess := false;
111 try
112 try
113 FIBConfigService.ShutDownDatabase(FOptions,FWait);
114 FErrorMessage := 'Completed without error';
115 FSuccess := true;
116 except
117 on E: Exception do
118 FErrorMessage := E.Message;
119 end;
120 finally
121 if Terminated and FSuccess then
122 FIBConfigService.BringDatabaseOnline;
123 end;
124 Synchronize(@DoCallback);
125 end;
126
127 constructor TShutdownWaitThread.Create(aService: TIBXConfigService;
128 Options: TDBShutdownMode; Wait: Integer; OnCompleted: TNotifyEvent);
129 begin
130 inherited Create(false);
131 FOptions := Options;
132 FWait := Wait;
133 FOnCompleted := OnCompleted;
134 FreeOnTerminate := true;
135 FIBConfigService := TIBXConfigService.Create(nil);
136 FIBConfigService.ServicesConnection := aService.ServicesConnection;
137 FIBConfigService.DatabaseName := aService.DatabaseNAme;
138 end;
139
140 destructor TShutdownWaitThread.Destroy;
141 begin
142 if FIBConfigService <> nil then FIBConfigService.Free;
143 inherited Destroy;
144 end;
145
146 procedure TShutdownWaitThread.Abort;
147 begin
148 Terminate;
149 end;
150
151 { TShutdownDatabaseDlg }
152
153 procedure TShutdownDatabaseDlg.FormShow(Sender: TObject);
154 begin
155 FAborting := false;
156 StatusMsg.Caption := Format(sWaitStatusMsg,[IBConfigService.DatabaseName]);
157 FShutdownWaitThread := TShutdownWaitThread.Create(IBConfigService,FShutDownMode,FDelay,@OnWaitCompleted);
158 end;
159
160 procedure TShutdownDatabaseDlg.CloseBtnClick(Sender: TObject);
161 begin
162 FAborting := true;
163 FShutdownWaitThread.Terminate;
164 Close;
165 end;
166
167 procedure TShutdownDatabaseDlg.OnWaitCompleted(Sender: TObject);
168 begin
169 with TShutdownWaitThread(Sender) do
170 if not FAborting then
171 MessageDlg(Format(sOnCompleted,[IBConfigService.DatabaseName,ErrorMessage]),
172 mtInformation,[mbOK],0);
173 FAborting := false;
174 Close;
175 end;
176
177 procedure TShutdownDatabaseDlg.Shutdown(aDBName: string;
178 aShutDownmode: TDBShutdownMode; aDelay: integer);
179 begin
180 IBConfigService.DatabaseName := aDBName;
181 FShutDownmode := aShutDownmode;
182 FDelay := aDelay;
183 FSecContextError := false;
184 if aDelay <= 0 then
185 begin
186 IBConfigService.ShutDownDatabase(aShutDownmode,0);
187 MessageDlg(sDatabaseShutdown,mtInformation,[mbOK],0);
188 end
189 else
190 ShowModal;
191 end;
192
193 end.
194