ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/iblocaldb/IBLocalDBSupport.pas
Revision: 37
Committed: Mon Feb 15 14:44:25 2016 UTC (8 years, 1 month ago) by tony
Content type: text/x-pascal
File size: 8086 byte(s)
Log Message:
Committing updates for Release R1-4-0

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) 2014 Tony Whyman, MWA Software
19 * (http://www.mwasoftware.co.uk).
20 *
21 * All Rights Reserved.
22 *
23 * Contributor(s): ______________________________________.
24 *
25 *)
26 unit IBLocalDBSupport;
27
28 {$mode objfpc}{$H+}
29
30 interface
31
32 uses
33 Classes, SysUtils, LResources, Forms, Controls, Dialogs, IBXCustomIBLocalDBSupport;
34
35 type
36
37 { TIBLocalDBSupport }
38
39 TIBLocalDBSupport = class(TCustomIBLocalDBSupport)
40 private
41 FTargetVersionNo: integer;
42 procedure DoDowngrade(Data: PtrInt);
43 procedure HandleDoUpgrade(Sender: TObject);
44 protected
45 function AllowInitialisation: boolean; override;
46 function AllowRestore: boolean; override;
47 function CreateNewDatabase(DBName:string; DBParams: TStrings; DBArchive: string): boolean; override;
48 procedure Downgrade(DBArchive: string); override;
49 function RestoreDatabaseFromArchive(DBName:string; DBParams: TStrings; aFilename: string): boolean; override;
50 function RunUpgradeDatabase(TargetVersionNo: integer): boolean; override;
51 function SaveDatabaseToArchive(DBName: string; DBParams:TStrings; aFilename: string): boolean; override;
52 published
53 property Database;
54 property DatabaseName;
55 property Enabled;
56 property EmptyDBArchive;
57 property FirebirdDirectory;
58 property Options;
59 property RequiredVersionNo;
60 property UpgradeConfFile;
61 property VendorName;
62 property OnGetDatabaseName;
63 property OnGetDBVersionNo;
64 property OnNewDatabaseOpen;
65 property OnGetSharedDataDir;
66 end;
67
68
69 implementation
70
71 uses IBXUpgradeDatabaseDlg, IBXCreateDatabaseDlg, IBXSaveDatabaseDlg, IBServices,
72 IBXUpgradeConfFile, Registry;
73
74 resourcestring
75 sDowngradePrompt = 'Database Version %d found but Version %d expected. If you have '+
76 'reinstalled this application after a failed upgrade then '+
77 'it may be possible to restore a saved archive of the database '+
78 'taken immediately before the upgrade. Do you want to do this?';
79
80 sReplaceBackup = 'This action will replace the current database with the backup. '+
81 'All data in the current database will be lost!';
82 sReplaceInitial = 'This action will replace the current database with an initial database. '+
83 'All data in the current database will be lost!';
84 sUpdateMsg = 'Applying Update from %s';
85 sUpdateStarted = '%s Update Started';
86 sUpdateEnded = '%s Update Completed';
87 sUpdateFailed = 'Update Failed - %s';
88
89 { TIBLocalDBSupport }
90
91 procedure TIBLocalDBSupport.DoDowngrade(Data: PtrInt);
92 begin
93 if AppDestroying in Application.Flags then Exit;
94 RestoreDatabase(DownGradeArchive);
95 DowngradeDone;
96 end;
97
98 procedure TIBLocalDBSupport.HandleDoUpgrade(Sender: TObject);
99 var UpdateAvailable: boolean;
100 UpgradeInfo: TUpgradeInfo;
101 DBArchive: string;
102 LastVersionNo: integer;
103 begin
104 with (Sender as TUpgradeDatabaseDlg) do
105 repeat
106 if CurrentDBVersionNo >= FTargetVersionNo then break;
107 LastVersionNo := CurrentDBVersionNo;
108 UpdateAvailable := UpgradeConf.GetUpgradeInfo(CurrentDBVersionNo+1,UpgradeInfo);
109 if UpdateAvailable then
110 begin
111 if UpgradeInfo.BackupDB then
112 begin
113 DBArchive := ChangeFileExt(ActiveDatabasePathName,'');
114 DBArchive := DBArchive + '.' + IntToStr(CurrentDBVersionNo) + '.gbk';
115 SaveDatabase(DBArchive);
116 end;
117 Add2Log(UpgradeInfo.UserMessage);
118 Status.Caption := UpgradeInfo.UserMessage;
119 Application.ProcessMessages;
120 Add2Log(Format(sUpdateMsg,[UpgradeInfo.UpdateSQLFile]));
121 Add2Log(Format(sUpdateStarted,[DateTimeToStr(Now)]));
122 if not IBXScript.PerformUpdate(UpgradeInfo.UpdateSQLFile,true) then
123 begin
124 Add2Log(Format(sUpdateFailed,[DateTimeToStr(Now)]));
125 SuccessfulCompletion := false;
126 break;
127 end;
128 Add2Log(Format(sUpdateEnded,[DateTimeToStr(Now)]));
129 UpdateVersionNo;
130 end;
131 until not UpdateAvailable or (LastVersionNo = CurrentDBVersionNo);
132 end;
133
134 function TIBLocalDBSupport.AllowInitialisation: boolean;
135 begin
136 Result := (iblQuiet in Options) or
137 (MessageDlg(sReplaceInitial, mtWarning,[mbOK,mbCancel],0) = mrOK);
138 end;
139
140 function TIBLocalDBSupport.AllowRestore: boolean;
141 begin
142 Result := (iblQuiet in Options) or
143 (MessageDlg(sReplaceBackup,mtWarning,[mbOK,mbCancel],0) = mrOK);
144 end;
145
146 function TIBLocalDBSupport.CreateNewDatabase(DBName: string;
147 DBParams: TStrings; DBArchive: string): boolean;
148 begin
149 CreateDir(ExtractFileDir(DBName));
150 with TCreateDatabaseDlg.Create(Application) do
151 try
152 SetDBParams(IBRestoreService1,DBParams);
153 IBRestoreService1.BackupFile.Clear;
154 IBRestoreService1.DatabaseName.Clear;
155 IBRestoreService1.Options := [CreateNewDB];
156 IBRestoreService1.BackupFile.Add(DBArchive);
157 IBRestoreService1.DatabaseName.Add(DBName);
158 Result := ShowModal = mrOK;
159 finally
160 Free
161 end;
162 end;
163
164 procedure TIBLocalDBSupport.Downgrade(DBArchive: string);
165 begin
166 if (iblQuiet in Options) or
167 (MessageDlg(Format(sDowngradePrompt, [CurrentDBVersionNo,RequiredVersionNo]),
168 mtWarning,[mbYes,mbNo],0) = mrYes) then
169 begin
170 inherited Downgrade(DBArchive);
171 Application.QueueAsyncCall(@DoDowngrade,0);
172 end;
173 end;
174
175 function TIBLocalDBSupport.RestoreDatabaseFromArchive(DBName: string;
176 DBParams: TStrings; aFilename: string): boolean;
177 begin
178 with TCreateDatabaseDlg.Create(Application) do
179 try
180 if (aFilename = '') or not FileExists(aFileName) then
181 begin
182 OpenDialog1.InitialDir := GetUserDir;
183 if OpenDialog1.Execute then
184 aFilename := OpenDialog1.FileName
185 else
186 Exit;
187 end;
188 SetDBParams(IBRestoreService1,DBParams);
189 IBRestoreService1.BackupFile.Clear;
190 IBRestoreService1.DatabaseName.Clear;
191 IBRestoreService1.Options := [replace];
192 IBRestoreService1.BackupFile.Add(aFilename);
193 IBRestoreService1.DatabaseName.Add(DBName);
194 Result := ShowModal = mrOK;
195 finally
196 Free
197 end;
198 end;
199
200 function TIBLocalDBSupport.RunUpgradeDatabase(TargetVersionNo: integer
201 ): boolean;
202 begin
203 FTargetVersionNo := TargetVersionNo;
204 with TUpgradeDatabaseDlg.Create(Application) do
205 try
206 IBXScript.Database := Database;
207 UpdateTransaction.DefaultDatabase := Database;
208 OnDoUpgrade := @HandleDoUpgrade;
209 IBXScript.GetParamValue := @HandleGetParamValue;
210 Result := ShowModal = mrOK;
211 finally
212 Free
213 end;
214 end;
215
216 {$IFDEF WINDOWS}
217 const
218 rgShellFolders = 'Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders';
219 rgPersonal = 'Personal';
220 {$ENDIF}
221
222 function TIBLocalDBSupport.SaveDatabaseToArchive(DBName: string;
223 DBParams: TStrings; aFilename: string): boolean;
224 begin
225 with TSaveDatabaseDlg.Create(Application) do
226 try
227 if aFilename = '' then
228 begin
229 SaveDialog1.InitialDir := GetUserDir;
230 {$IFDEF WINDOWS}
231 with TRegistry.Create do
232 try
233 if OpenKey(rgShellFolders,false) then
234 begin
235 SaveDialog1.InitialDir := ReadString(rgPersonal)
236 end;
237 finally
238 Free
239 end;
240 {$ENDIF}
241 if SaveDialog1.Execute then
242 aFilename := SaveDialog1.FileName
243 else
244 Exit;
245 end;
246 SetDBParams(IBBackupService1,DBParams);
247 IBBackupService1.BackupFile.Clear;
248 IBBackupService1.DatabaseName := DBName;
249 IBBackupService1.BackupFile.Add(aFilename);
250 Result := ShowModal = mrOK
251 finally
252 Free
253 end;
254 end;
255
256 end.
257