ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/iblocaldb/IBLocalDBSupport.pas
Revision: 80
Committed: Mon Jan 1 11:31:07 2018 UTC (6 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 5596 byte(s)
Log Message:
Fixes merged into public release

File Contents

# 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(DBName: string; DBParams: TStrings;
48 DBArchive: string): boolean; override;
49 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 Registry, IBXCreateDatabaseFromSQLDlgUnit;
74
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 procedure TIBLocalDBSupport.HandleGetDBVersionNo(Sender: TObject;
96 var VersionNo: integer);
97 begin
98 VersionNo := CurrentDBVersionNo;
99 end;
100
101 procedure TIBLocalDBSupport.HandleUpgradeStepCompleted(Sender: TObject);
102 begin
103 UpdateVersionNo;
104 end;
105
106 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 function TIBLocalDBSupport.InternalCreateNewDatabase(DBName: string;
119 DBParams: TStrings; DBArchive: string): boolean;
120 var Ext: string;
121 begin
122 CreateDir(ExtractFileDir(DBName));
123 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 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 Result := IBXCreateDatabaseDlg.RestoreDatabaseFromArchive(DBName,DBParams,aFileName);
151 end;
152
153 function TIBLocalDBSupport.RunUpgradeDatabase(TargetVersionNo: integer
154 ): boolean;
155 begin
156 Result := IBXUpgradeDatabaseDlg.RunUpgradeDatabase(Database,UpgradeConf,
157 ChangeFileExt(ActiveDatabasePathName,''),
158 TargetVersionNo,@HandleGetDBVersionNo, @HandleUpgradeStepCompleted);
159 end;
160
161 function TIBLocalDBSupport.SaveDatabaseToArchive(DBName: string;
162 DBParams: TStrings; aFilename: string): boolean;
163 begin
164 Result := IBXSaveDatabaseDlg.SaveDatabaseToArchive(DBName,DBParams,aFileName);
165 end;
166
167 end.
168