iblocaldb/gui/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
    procedure DoDowngrade(Data: PtrInt);
    procedure HandleGetDBVersionNo(Sender: TObject; var VersionNo: integer);
    procedure HandleUpgradeStepCompleted(Sender: TObject);
  protected
    function AllowInitialisation: boolean; override;
    function AllowRestore: boolean; override;
    function InternalCreateNewDatabase(DBArchive: string): boolean; override;
    procedure Downgrade(DBArchive: string); override;
    function RestoreDatabaseFromArchive(aFilename: string): boolean; override;
    function RunUpgradeDatabase(TargetVersionNo: integer): boolean; override;
    function SaveDatabaseToArchive(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,
  Registry, IBXCreateDatabaseFromSQLDlgUnit;

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!';

{ TIBLocalDBSupport }

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

procedure TIBLocalDBSupport.HandleGetDBVersionNo(Sender: TObject;
  var VersionNo: integer);
begin
  VersionNo := CurrentDBVersionNo;
end;

procedure TIBLocalDBSupport.HandleUpgradeStepCompleted(Sender: TObject);
begin
  UpdateVersionNo;
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.InternalCreateNewDatabase(DBArchive: string
  ): boolean;
var Ext: string;
begin
  Ext := AnsiUpperCase(ExtractFileExt(DBArchive));
  if Ext = '.GBK' then
  begin
    Database.Attachment.Disconnect;
    try
      Result := IBXCreateDatabaseDlg.RestoreDatabaseFromArchive(RestoreService,DBArchive)
    finally
      Database.Attachment.Connect;
    end;
  end
  else
  if Ext = '.SQL' then
    Result := IBXCreateDatabaseFromSQLDlgUnit.CreateNewDatabase(Database,DBArchive)
  else
    raise Exception.CreateFmt('Archive file (%s) has an unknown extension',[DBArchive]);
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(aFilename: string
  ): boolean;
begin
  Result := IBXCreateDatabaseDlg.RestoreDatabaseFromArchive(RestoreService,aFileName);
end;

function TIBLocalDBSupport.RunUpgradeDatabase(TargetVersionNo: integer
  ): boolean;
begin
  Result := IBXUpgradeDatabaseDlg.RunUpgradeDatabase(Database,BackupService,UpgradeConf,
                  ChangeFileExt(ActiveDatabasePathName,''),
                  TargetVersionNo,@HandleGetDBVersionNo, @HandleUpgradeStepCompleted);
end;

function TIBLocalDBSupport.SaveDatabaseToArchive(aFilename: string): boolean;
begin
  Result := IBXSaveDatabaseDlg.SaveDatabaseToArchive(BackupService,aFileName);
end;

end.

Revision:	209
Committed:	Wed Mar 14 12:48:51 2018 UTC (6 years, 9 months ago) by tony
Content type:	text/x-pascal
File size:	5411 byte(s)
Log Message:	Fixes Merged
#	User	Rev	Content
1	tony	209	(*
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			procedure DoDowngrade(Data: PtrInt);
42			procedure HandleGetDBVersionNo(Sender: TObject; var VersionNo: integer);
43			procedure HandleUpgradeStepCompleted(Sender: TObject);
44			protected
45			function AllowInitialisation: boolean; override;
46			function AllowRestore: boolean; override;
47			function InternalCreateNewDatabase(DBArchive: string): boolean; override;
48			procedure Downgrade(DBArchive: string); override;
49			function RestoreDatabaseFromArchive(aFilename: string): boolean; override;
50			function RunUpgradeDatabase(TargetVersionNo: integer): boolean; override;
51			function SaveDatabaseToArchive(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,
72			Registry, IBXCreateDatabaseFromSQLDlgUnit;
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
85			{ TIBLocalDBSupport }
86
87			procedure TIBLocalDBSupport.DoDowngrade(Data: PtrInt);
88			begin
89			if AppDestroying in Application.Flags then Exit;
90			RestoreDatabase(DownGradeArchive);
91			DowngradeDone;
92			end;
93
94			procedure TIBLocalDBSupport.HandleGetDBVersionNo(Sender: TObject;
95			var VersionNo: integer);
96			begin
97			VersionNo := CurrentDBVersionNo;
98			end;
99
100			procedure TIBLocalDBSupport.HandleUpgradeStepCompleted(Sender: TObject);
101			begin
102			UpdateVersionNo;
103			end;
104
105			function TIBLocalDBSupport.AllowInitialisation: boolean;
106			begin
107			Result := (iblQuiet in Options) or
108			(MessageDlg(sReplaceInitial, mtWarning,[mbOK,mbCancel],0) = mrOK);
109			end;
110
111			function TIBLocalDBSupport.AllowRestore: boolean;
112			begin
113			Result := (iblQuiet in Options) or
114			(MessageDlg(sReplaceBackup,mtWarning,[mbOK,mbCancel],0) = mrOK);
115			end;
116
117			function TIBLocalDBSupport.InternalCreateNewDatabase(DBArchive: string
118			): boolean;
119			var Ext: string;
120			begin
121			Ext := AnsiUpperCase(ExtractFileExt(DBArchive));
122			if Ext = '.GBK' then
123			begin
124			Database.Attachment.Disconnect;
125			try
126			Result := IBXCreateDatabaseDlg.RestoreDatabaseFromArchive(RestoreService,DBArchive)
127			finally
128			Database.Attachment.Connect;
129			end;
130			end
131			else
132			if Ext = '.SQL' then
133			Result := IBXCreateDatabaseFromSQLDlgUnit.CreateNewDatabase(Database,DBArchive)
134			else
135			raise Exception.CreateFmt('Archive file (%s) has an unknown extension',[DBArchive]);
136			end;
137
138			procedure TIBLocalDBSupport.Downgrade(DBArchive: string);
139			begin
140			if (iblQuiet in Options) or
141			(MessageDlg(Format(sDowngradePrompt, [CurrentDBVersionNo,RequiredVersionNo]),
142			mtWarning,[mbYes,mbNo],0) = mrYes) then
143			begin
144			inherited Downgrade(DBArchive);
145			Application.QueueAsyncCall(@DoDowngrade,0);
146			end;
147			end;
148
149			function TIBLocalDBSupport.RestoreDatabaseFromArchive(aFilename: string
150			): boolean;
151			begin
152			Result := IBXCreateDatabaseDlg.RestoreDatabaseFromArchive(RestoreService,aFileName);
153			end;
154
155			function TIBLocalDBSupport.RunUpgradeDatabase(TargetVersionNo: integer
156			): boolean;
157			begin
158			Result := IBXUpgradeDatabaseDlg.RunUpgradeDatabase(Database,BackupService,UpgradeConf,
159			ChangeFileExt(ActiveDatabasePathName,''),
160			TargetVersionNo,@HandleGetDBVersionNo, @HandleUpgradeStepCompleted);
161			end;
162
163			function TIBLocalDBSupport.SaveDatabaseToArchive(aFilename: string): boolean;
164			begin
165			Result := IBXSaveDatabaseDlg.SaveDatabaseToArchive(BackupService,aFileName);
166			end;
167
168			end.
169