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

# 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