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

# 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 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 FOnProgressEvent: TOnProgressEvent;
44 function DoUpgrade(IBXScript: TIBXScript; TargetVersionNo: integer): boolean;
45 procedure WriteLog(Msg: string);
46 procedure HandleOnGetNextLine(Sender: TObject; var Line: string);
47 procedure IBXScriptCreateDatabase(Sender: TObject;
48 var DatabaseFileName: string);
49 protected
50 procedure Add2Log(Sender: TObject; Msg: string); override;
51 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 property OnProgressEvent: TOnProgressEvent read FOnProgressEvent write FOnProgressEvent; {Progress Bar Support}
60 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 function TIBCMLocalDBSupport.DoUpgrade(IBXScript: TIBXScript;
79 TargetVersionNo: integer): boolean;
80 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 Result := IBXScript.RunScript(UpgradeInfo.UpdateSQLFile);
100 if not Result then
101 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 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 procedure TIBCMLocalDBSupport.Downgrade(DBArchive: string);
128 begin
129 inherited;
130 RestoreDatabase(DBArchive);
131 DowngradeDone;
132 end;
133
134 function TIBCMLocalDBSupport.InternalCreateNewDatabase(DBArchive: string
135 ): boolean;
136 begin
137 Result := true;
138 if IsGbakFile(DBArchive) then
139 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 OnCreateDatabase := @IBXScriptCreateDatabase;
159 OnProgressEvent := FOnProgressEvent;
160 WriteLog(sCreatingDatabase);
161 Result := RunScript(DBArchive);
162 Add2Log(self,''); {ensure EOL sent}
163 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 DatabaseFiles.Clear;
177 DatabaseFiles.Add(Database.DatabaseName);
178 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 Result := DoUpgrade(IBXScript, TargetVersionNo);
195 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 DatabaseName := Database.DatabaseName;
207 BackupFiles.Clear;
208 BackupFiles.Add(aFileName);
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