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
    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(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,
  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(DBName: string;
  DBParams: TStrings; DBArchive: string): boolean;
var Ext: string;
begin
  CreateDir(ExtractFileDir(DBName));
  Ext := AnsiUpperCase(ExtractFileExt(DBArchive));
  if Ext = '.GBK' then
    Result := IBXCreateDatabaseDlg.CreateNewDatabase(DBName,DBParams,DBArchive)
  else
  if Ext = '.SQL' then
  begin
    Database.DatabaseName := DBName;
    Result := IBXCreateDatabaseFromSQLDlgUnit.CreateNewDatabase(Database,DBArchive)
  end
  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(DBName: string;
  DBParams: TStrings; aFilename: string): boolean;
begin
  Result := IBXCreateDatabaseDlg.RestoreDatabaseFromArchive(DBName,DBParams,aFileName);
end;

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

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

end.

Revision:	80
Committed:	Mon Jan 1 11:31:07 2018 UTC (6 years, 3 months ago) by tony
Content type:	text/x-pascal
File size:	5596 byte(s)
Log Message:	Fixes merged into public release
#	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			procedure DoDowngrade(Data: PtrInt);
42	tony	80	procedure HandleGetDBVersionNo(Sender: TObject; var VersionNo: integer);
43			procedure HandleUpgradeStepCompleted(Sender: TObject);
44	tony	37	protected
45			function AllowInitialisation: boolean; override;
46			function AllowRestore: boolean; override;
47	tony	80	function InternalCreateNewDatabase(DBName: string; DBParams: TStrings;
48			DBArchive: string): boolean; override;
49	tony	37	procedure Downgrade(DBArchive: string); override;
50			function RestoreDatabaseFromArchive(DBName:string; DBParams: TStrings; aFilename: string): boolean; override;
51			function RunUpgradeDatabase(TargetVersionNo: integer): boolean; override;
52			function SaveDatabaseToArchive(DBName: string; DBParams:TStrings; aFilename: string): boolean; override;
53			published
54			property Database;
55			property DatabaseName;
56			property Enabled;
57			property EmptyDBArchive;
58			property FirebirdDirectory;
59			property Options;
60			property RequiredVersionNo;
61			property UpgradeConfFile;
62			property VendorName;
63			property OnGetDatabaseName;
64			property OnGetDBVersionNo;
65			property OnNewDatabaseOpen;
66			property OnGetSharedDataDir;
67			end;
68
69
70			implementation
71
72			uses IBXUpgradeDatabaseDlg, IBXCreateDatabaseDlg, IBXSaveDatabaseDlg, IBServices,
73	tony	80	Registry, IBXCreateDatabaseFromSQLDlgUnit;
74	tony	37
75			resourcestring
76			sDowngradePrompt = 'Database Version %d found but Version %d expected. If you have '+
77			'reinstalled this application after a failed upgrade then '+
78			'it may be possible to restore a saved archive of the database '+
79			'taken immediately before the upgrade. Do you want to do this?';
80
81			sReplaceBackup = 'This action will replace the current database with the backup. '+
82			'All data in the current database will be lost!';
83			sReplaceInitial = 'This action will replace the current database with an initial database. '+
84			'All data in the current database will be lost!';
85
86			{ TIBLocalDBSupport }
87
88			procedure TIBLocalDBSupport.DoDowngrade(Data: PtrInt);
89			begin
90			if AppDestroying in Application.Flags then Exit;
91			RestoreDatabase(DownGradeArchive);
92			DowngradeDone;
93			end;
94
95	tony	80	procedure TIBLocalDBSupport.HandleGetDBVersionNo(Sender: TObject;
96			var VersionNo: integer);
97	tony	37	begin
98	tony	80	VersionNo := CurrentDBVersionNo;
99	tony	37	end;
100
101	tony	80	procedure TIBLocalDBSupport.HandleUpgradeStepCompleted(Sender: TObject);
102			begin
103			UpdateVersionNo;
104			end;
105
106	tony	37	function TIBLocalDBSupport.AllowInitialisation: boolean;
107			begin
108			Result := (iblQuiet in Options) or
109			(MessageDlg(sReplaceInitial, mtWarning,[mbOK,mbCancel],0) = mrOK);
110			end;
111
112			function TIBLocalDBSupport.AllowRestore: boolean;
113			begin
114			Result := (iblQuiet in Options) or
115			(MessageDlg(sReplaceBackup,mtWarning,[mbOK,mbCancel],0) = mrOK);
116			end;
117
118	tony	80	function TIBLocalDBSupport.InternalCreateNewDatabase(DBName: string;
119	tony	37	DBParams: TStrings; DBArchive: string): boolean;
120	tony	80	var Ext: string;
121	tony	37	begin
122			CreateDir(ExtractFileDir(DBName));
123	tony	80	Ext := AnsiUpperCase(ExtractFileExt(DBArchive));
124			if Ext = '.GBK' then
125			Result := IBXCreateDatabaseDlg.CreateNewDatabase(DBName,DBParams,DBArchive)
126			else
127			if Ext = '.SQL' then
128			begin
129			Database.DatabaseName := DBName;
130			Result := IBXCreateDatabaseFromSQLDlgUnit.CreateNewDatabase(Database,DBArchive)
131			end
132			else
133			raise Exception.CreateFmt('Archive file (%s) has an unknown extension',[DBArchive]);
134	tony	37	end;
135
136			procedure TIBLocalDBSupport.Downgrade(DBArchive: string);
137			begin
138			if (iblQuiet in Options) or
139			(MessageDlg(Format(sDowngradePrompt, [CurrentDBVersionNo,RequiredVersionNo]),
140			mtWarning,[mbYes,mbNo],0) = mrYes) then
141			begin
142			inherited Downgrade(DBArchive);
143			Application.QueueAsyncCall(@DoDowngrade,0);
144			end;
145			end;
146
147			function TIBLocalDBSupport.RestoreDatabaseFromArchive(DBName: string;
148			DBParams: TStrings; aFilename: string): boolean;
149			begin
150	tony	80	Result := IBXCreateDatabaseDlg.RestoreDatabaseFromArchive(DBName,DBParams,aFileName);
151	tony	37	end;
152
153			function TIBLocalDBSupport.RunUpgradeDatabase(TargetVersionNo: integer
154			): boolean;
155			begin
156	tony	80	Result := IBXUpgradeDatabaseDlg.RunUpgradeDatabase(Database,UpgradeConf,
157			ChangeFileExt(ActiveDatabasePathName,''),
158			TargetVersionNo,@HandleGetDBVersionNo, @HandleUpgradeStepCompleted);
159	tony	37	end;
160
161			function TIBLocalDBSupport.SaveDatabaseToArchive(DBName: string;
162			DBParams: TStrings; aFilename: string): boolean;
163			begin
164	tony	80	Result := IBXSaveDatabaseDlg.SaveDatabaseToArchive(DBName,DBParams,aFileName);
165	tony	37	end;
166
167			end.
168