ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/iblocaldb/gui/IBLocalDBSupport.pas
Revision: 209
Committed: Wed Mar 14 12:48:51 2018 UTC (6 years ago) by tony
Content type: text/x-pascal
File size: 5411 byte(s)
Log Message:
Fixes Merged

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