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
#	User	Rev	Content
1	tony	37	(*
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