trunk/iblocaldb/IBLocalDBSupport.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) 2014 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*)
unit IBLocalDBSupport;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, LResources, Forms, Controls,  Dialogs, IBXCustomIBLocalDBSupport;

type

  { TIBLocalDBSupport }

  TIBLocalDBSupport = class(TCustomIBLocalDBSupport)
  private
    FTargetVersionNo: integer;
    procedure DoDowngrade(Data: PtrInt);
    procedure HandleDoUpgrade(Sender: TObject);
  protected
    function AllowInitialisation: boolean; override;
    function AllowRestore: boolean; override;
    function CreateNewDatabase(DBName:string; DBParams: TStrings; DBArchive: string): boolean; override;
    procedure Downgrade(DBArchive: string); override;
    function RestoreDatabaseFromArchive(DBName:string; DBParams: TStrings; aFilename: string): boolean; override;
    function RunUpgradeDatabase(TargetVersionNo: integer): boolean; override;
    function SaveDatabaseToArchive(DBName: string; DBParams:TStrings; aFilename: string): boolean; override;
  published
    property Database;
    property DatabaseName;
    property Enabled;
    property EmptyDBArchive;
    property FirebirdDirectory;
    property Options;
    property RequiredVersionNo;
    property UpgradeConfFile;
    property VendorName;
    property OnGetDatabaseName;
    property OnGetDBVersionNo;
    property OnNewDatabaseOpen;
    property OnGetSharedDataDir;
  end;


implementation

uses IBXUpgradeDatabaseDlg, IBXCreateDatabaseDlg, IBXSaveDatabaseDlg, IBServices,
  IBXUpgradeConfFile, Registry;

resourcestring
  sDowngradePrompt = 'Database Version %d found but Version %d expected. If you have '+
                     'reinstalled this application after a failed upgrade then '+
                     'it may be possible to restore a saved archive of the database '+
                     'taken immediately before the upgrade. Do you want to do this?';

  sReplaceBackup =   'This action will replace the current database with the backup. '+
                              'All data in the current database will be lost!';
  sReplaceInitial =   'This action will replace the current database with an initial database. '+
                              'All data in the current database will be lost!';
  sUpdateMsg =       'Applying Update from %s';
  sUpdateStarted =   '%s Update Started';
  sUpdateEnded =     '%s Update Completed';
  sUpdateFailed    = 'Update Failed - %s';

{ TIBLocalDBSupport }

procedure TIBLocalDBSupport.DoDowngrade(Data: PtrInt);
begin
  if AppDestroying in Application.Flags then Exit;
   RestoreDatabase(DownGradeArchive);
   DowngradeDone;
end;

procedure TIBLocalDBSupport.HandleDoUpgrade(Sender: TObject);
var UpdateAvailable: boolean;
    UpgradeInfo: TUpgradeInfo;
    DBArchive: string;
    LastVersionNo: integer;
begin
  with (Sender as TUpgradeDatabaseDlg) do
  repeat
    if CurrentDBVersionNo >= FTargetVersionNo then break;
    LastVersionNo := CurrentDBVersionNo;
    UpdateAvailable := UpgradeConf.GetUpgradeInfo(CurrentDBVersionNo+1,UpgradeInfo);
    if UpdateAvailable then
    begin
      if UpgradeInfo.BackupDB then
      begin
       DBArchive := ChangeFileExt(ActiveDatabasePathName,'');
       DBArchive := DBArchive + '.' + IntToStr(CurrentDBVersionNo) + '.gbk';
       SaveDatabase(DBArchive);
      end;
      Add2Log(UpgradeInfo.UserMessage);
      Status.Caption := UpgradeInfo.UserMessage;
      Application.ProcessMessages;
      Add2Log(Format(sUpdateMsg,[UpgradeInfo.UpdateSQLFile]));
      Add2Log(Format(sUpdateStarted,[DateTimeToStr(Now)]));
      if not IBXScript.PerformUpdate(UpgradeInfo.UpdateSQLFile,true) then
      begin
       Add2Log(Format(sUpdateFailed,[DateTimeToStr(Now)]));
       SuccessfulCompletion := false;
       break;
      end;
      Add2Log(Format(sUpdateEnded,[DateTimeToStr(Now)]));
      UpdateVersionNo;
    end;
  until not UpdateAvailable or (LastVersionNo = CurrentDBVersionNo);
end;

function TIBLocalDBSupport.AllowInitialisation: boolean;
begin
  Result := (iblQuiet in Options) or
            (MessageDlg(sReplaceInitial, mtWarning,[mbOK,mbCancel],0) = mrOK);
end;

function TIBLocalDBSupport.AllowRestore: boolean;
begin
  Result := (iblQuiet in Options) or
            (MessageDlg(sReplaceBackup,mtWarning,[mbOK,mbCancel],0) = mrOK);
end;

function TIBLocalDBSupport.CreateNewDatabase(DBName: string;
  DBParams: TStrings; DBArchive: string): boolean;
begin
  CreateDir(ExtractFileDir(DBName));
  with TCreateDatabaseDlg.Create(Application) do
  try
   SetDBParams(IBRestoreService1,DBParams);
   IBRestoreService1.BackupFile.Clear;
   IBRestoreService1.DatabaseName.Clear;
   IBRestoreService1.Options := [CreateNewDB];
   IBRestoreService1.BackupFile.Add(DBArchive);
   IBRestoreService1.DatabaseName.Add(DBName);
   Result := ShowModal = mrOK;
  finally
    Free
  end;
end;

procedure TIBLocalDBSupport.Downgrade(DBArchive: string);
begin
  if  (iblQuiet in Options) or
      (MessageDlg(Format(sDowngradePrompt, [CurrentDBVersionNo,RequiredVersionNo]),
                     mtWarning,[mbYes,mbNo],0) = mrYes) then
  begin
    inherited Downgrade(DBArchive);
    Application.QueueAsyncCall(@DoDowngrade,0);
  end;
end;

function TIBLocalDBSupport.RestoreDatabaseFromArchive(DBName: string;
  DBParams: TStrings; aFilename: string): boolean;
begin
  with TCreateDatabaseDlg.Create(Application) do
  try
    if (aFilename = '') or not FileExists(aFileName) then
    begin
     OpenDialog1.InitialDir := GetUserDir;
     if OpenDialog1.Execute then
       aFilename := OpenDialog1.FileName
     else
       Exit;
    end;
    SetDBParams(IBRestoreService1,DBParams);
    IBRestoreService1.BackupFile.Clear;
    IBRestoreService1.DatabaseName.Clear;
    IBRestoreService1.Options := [replace];
    IBRestoreService1.BackupFile.Add(aFilename);
    IBRestoreService1.DatabaseName.Add(DBName);
    Result := ShowModal = mrOK;
  finally
    Free
  end;
end;

function TIBLocalDBSupport.RunUpgradeDatabase(TargetVersionNo: integer
  ): boolean;
begin
  FTargetVersionNo := TargetVersionNo;
  with TUpgradeDatabaseDlg.Create(Application) do
  try
    IBXScript.Database := Database;
    UpdateTransaction.DefaultDatabase := Database;
    OnDoUpgrade := @HandleDoUpgrade;
    IBXScript.GetParamValue := @HandleGetParamValue;
    Result := ShowModal = mrOK;
  finally
    Free
  end;
end;

{$IFDEF WINDOWS}
const
  rgShellFolders      = 'Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders';
  rgPersonal          = 'Personal';
{$ENDIF}

function TIBLocalDBSupport.SaveDatabaseToArchive(DBName: string;
  DBParams: TStrings; aFilename: string): boolean;
begin
  with TSaveDatabaseDlg.Create(Application) do
  try
   if aFilename = ''  then
   begin
     SaveDialog1.InitialDir := GetUserDir;
     {$IFDEF WINDOWS}
     with TRegistry.Create do
     try
       if OpenKey(rgShellFolders,false) then
       begin
         SaveDialog1.InitialDir := ReadString(rgPersonal)
       end;
     finally
       Free
     end;
     {$ENDIF}
     if SaveDialog1.Execute then
       aFilename := SaveDialog1.FileName
     else
       Exit;
   end;
   SetDBParams(IBBackupService1,DBParams);
   IBBackupService1.BackupFile.Clear;
   IBBackupService1.DatabaseName := DBName;
   IBBackupService1.BackupFile.Add(aFilename);
   Result := ShowModal = mrOK
  finally
    Free
  end;
end;

end.

Revision:	37
Committed:	Mon Feb 15 14:44:25 2016 UTC (8 years, 9 months ago) by tony
Content type:	text/x-pascal
File size:	8086 byte(s)
Log Message:	Committing updates for Release R1-4-0
#	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