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
#	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	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