ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/iblocaldb/nongui/IBCMLocalDBSupport.pas
Revision: 315
Committed: Thu Feb 25 11:56:36 2021 UTC (3 years, 1 month ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/iblocaldb/nongui/IBCMLocalDBSupport.pas
File size: 6322 byte(s)
Log Message:
Updated for IBX 4 release

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 IBCMLocalDBSupport;
27    
28     {$mode objfpc}{$H+}
29    
30     interface
31    
32     uses
33     Classes, SysUtils, IBXCustomIBLocalDBSupport, ibxscript, IBXServices;
34    
35     type
36     TOnLogMessage = procedure(Sender: TObject; Msg: string) of object;
37    
38     { TIBCMLocalDBSupport }
39    
40     TIBCMLocalDBSupport = class(TCustomIBLocalDBSupport)
41     private
42     FOnLogMessage: TOnLogMessage;
43 tony 272 FOnProgressEvent: TOnProgressEvent;
44 tony 315 function DoUpgrade(IBXScript: TIBXScript; TargetVersionNo: integer): boolean;
45 tony 209 procedure WriteLog(Msg: string);
46     procedure HandleOnGetNextLine(Sender: TObject; var Line: string);
47 tony 272 procedure IBXScriptCreateDatabase(Sender: TObject;
48     var DatabaseFileName: string);
49 tony 209 protected
50 tony 315 procedure Add2Log(Sender: TObject; Msg: string); override;
51 tony 209 procedure Downgrade(DBArchive: string); override;
52     function InternalCreateNewDatabase(DBArchive: string): boolean; override;
53     function RestoreDatabaseFromArchive(aFilename: string): boolean; override;
54     function RunUpgradeDatabase(TargetVersionNo: integer): boolean; override;
55     function SaveDatabaseToArchive( aFilename: string): boolean; override;
56     public
57     constructor Create(aOwner: TComponent); override;
58     property OnLogMessage: TOnLogMessage read FOnLogMessage write FOnLogMessage;
59 tony 272 property OnProgressEvent: TOnProgressEvent read FOnProgressEvent write FOnProgressEvent; {Progress Bar Support}
60 tony 209 end;
61    
62     implementation
63    
64     uses IBXUpgradeConfFile, IBDatabase;
65    
66     resourcestring
67     sUpdateMsg = 'Applying Update from %s';
68     sCreatingDatabase = 'Creating new Database';
69     sBackupDone = 'Database Archived to %s';
70    
71     { TIBCMLocalDBSupport }
72    
73     procedure TIBCMLocalDBSupport.Add2Log(Sender: TObject; Msg: string);
74     begin
75     WriteLog(Msg);
76     end;
77    
78 tony 315 function TIBCMLocalDBSupport.DoUpgrade(IBXScript: TIBXScript;
79     TargetVersionNo: integer): boolean;
80 tony 209 var UpdateAvailable: boolean;
81     UpgradeInfo: TUpgradeInfo;
82     DBArchive: string;
83     LastVersionNo: integer;
84     begin
85     repeat
86     if CurrentDBVersionNo >= TargetVersionNo then break;
87     LastVersionNo := CurrentDBVersionNo;
88     UpdateAvailable := UpgradeConf.GetUpgradeInfo(CurrentDBVersionNo+1,UpgradeInfo);
89     if UpdateAvailable then
90     begin
91     if UpgradeInfo.BackupDB then
92     begin
93     DBArchive := ChangeFileExt(ActiveDatabasePathName,'');
94     DBArchive := DBArchive + '.' + IntToStr(CurrentDBVersionNo) + '.gbk';
95     SaveDatabaseToArchive(DBArchive);
96     end;
97     Add2Log(self,UpgradeInfo.UserMessage);
98     Add2Log(self,Format(sUpdateMsg,[UpgradeInfo.UpdateSQLFile]));
99 tony 315 Result := IBXScript.RunScript(UpgradeInfo.UpdateSQLFile);
100     if not Result then
101 tony 209 break;
102     UpdateVersionNo;
103     end;
104     until not UpdateAvailable or (LastVersionNo = CurrentDBVersionNo);
105     end;
106    
107     procedure TIBCMLocalDBSupport.WriteLog(Msg: string);
108     begin
109     if assigned(OnLogMessage) then
110     OnLogMessage(self,Msg);
111     end;
112    
113     procedure TIBCMLocalDBSupport.HandleOnGetNextLine(Sender: TObject;
114     var Line: string);
115     begin
116     if assigned(OnLogMessage) then
117     OnLogMessage(self,Line);
118     end;
119    
120 tony 272 procedure TIBCMLocalDBSupport.IBXScriptCreateDatabase(Sender: TObject;
121     var DatabaseFileName: string);
122     begin
123     DatabaseFileName := (Sender as TIBXScript).Database.Attachment.GetConnectString;
124     (Sender as TIBXScript).Database.DropDatabase;
125     end;
126    
127 tony 209 procedure TIBCMLocalDBSupport.Downgrade(DBArchive: string);
128     begin
129 tony 315 inherited;
130 tony 209 RestoreDatabase(DBArchive);
131 tony 315 DowngradeDone;
132 tony 209 end;
133    
134     function TIBCMLocalDBSupport.InternalCreateNewDatabase(DBArchive: string
135     ): boolean;
136     begin
137     Result := true;
138 tony 272 if IsGbakFile(DBArchive) then
139 tony 209 begin
140     with RestoreService do
141     begin
142     BackupFiles.Clear;
143     BackupFiles.Add(DBArchive);
144     Options := [Replace];
145     WriteLog(sCreatingDatabase);
146     Database.Attachment.Disconnect;
147     try
148     Execute(nil);
149     finally
150     Database.Attachment.Connect;
151     end;
152     end;
153     end
154     else
155     with TIBXScript.Create(self) do
156     try
157     Database := self.Database;
158 tony 272 OnCreateDatabase := @IBXScriptCreateDatabase;
159     OnProgressEvent := FOnProgressEvent;
160 tony 209 WriteLog(sCreatingDatabase);
161     Result := RunScript(DBArchive);
162 tony 272 Add2Log(self,''); {ensure EOL sent}
163 tony 209 finally
164     Free
165     end
166     end;
167    
168     function TIBCMLocalDBSupport.RestoreDatabaseFromArchive(
169     aFilename: string): boolean;
170     begin
171     Result := true;
172     with RestoreService do
173     begin
174     BackupFiles.Clear;
175     BackupFiles.Add(aFilename);
176 tony 315 DatabaseFiles.Clear;
177     DatabaseFiles.Add(Database.DatabaseName);
178 tony 209 Options := [Replace];
179     Execute(nil);
180     end;
181     end;
182    
183     function TIBCMLocalDBSupport.RunUpgradeDatabase(TargetVersionNo: integer
184     ): boolean;
185     var IBXScript: TIBXScript;
186     begin
187     IBXScript := TIBXScript.Create(self);
188     try
189     IBXScript.Database := Database;
190     IBXScript.OnErrorLog := @Add2Log;
191     IBXScript.OnOutputLog := @Add2Log;
192     if assigned(UpgradeConf) then
193     IBXScript.GetParamValue := @UpgradeConf.GetParamValue;
194 tony 315 Result := DoUpgrade(IBXScript, TargetVersionNo);
195 tony 209 finally
196     IBXScript.Free;
197     end;
198    
199     end;
200    
201     function TIBCMLocalDBSupport.SaveDatabaseToArchive(aFilename: string): boolean;
202     begin
203     Result := true;
204     with BackupService do
205     begin
206 tony 315 DatabaseName := Database.DatabaseName;
207     BackupFiles.Clear;
208     BackupFiles.Add(aFileName);
209 tony 209 Execute(nil);
210     WriteLog(Format(sBackupDone,[aFileName]));
211     end;
212     end;
213    
214     constructor TIBCMLocalDBSupport.Create(aOwner: TComponent);
215     begin
216     inherited Create(aOwner);
217     RestoreService.OnGetNextLine := @HandleOnGetNextLine;
218     BackupService.OnGetNextLine := @HandleOnGetNextLine;
219     end;
220    
221     end.
222