ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/iblocaldb/IBCMLocalDBSupport.pas
Revision: 85
Committed: Mon Jan 1 11:31:20 2018 UTC (6 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 6664 byte(s)
Log Message:
Change CreateNewDatabase to InternalCreateNewDatabase in Console Mode local DB support

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;
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 FDatabasePath: string;
44 procedure Add2Log(Sender: TObject; Msg: string);
45 procedure DoUpgrade(IBXScript: TIBXScript; TargetVersionNo: integer);
46 procedure WriteLog(Msg: string);
47 procedure HandleCreateDatabase(Sender: TObject; var DatabaseFileName: string);
48 protected
49 function InternalCreateNewDatabase(DBName:string; DBParams: TStrings; DBArchive: string): boolean; 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 public
54 property OnLogMessage: TOnLogMessage read FOnLogMessage write FOnLogMessage;
55 end;
56
57 implementation
58
59 uses IBServices, IBXUpgradeConfFile, IBDatabase;
60
61 resourcestring
62 sUpdateMsg = 'Applying Update from %s';
63 sCreatingDatabase= 'Creating new Database';
64
65 { TIBCMLocalDBSupport }
66
67 procedure TIBCMLocalDBSupport.Add2Log(Sender: TObject; Msg: string);
68 begin
69 WriteLog(Msg);
70 end;
71
72 procedure TIBCMLocalDBSupport.DoUpgrade(IBXScript: TIBXScript;
73 TargetVersionNo: integer);
74 var UpdateAvailable: boolean;
75 UpgradeInfo: TUpgradeInfo;
76 DBArchive: string;
77 LastVersionNo: integer;
78 begin
79 repeat
80 if CurrentDBVersionNo >= TargetVersionNo then break;
81 LastVersionNo := CurrentDBVersionNo;
82 UpdateAvailable := UpgradeConf.GetUpgradeInfo(CurrentDBVersionNo+1,UpgradeInfo);
83 if UpdateAvailable then
84 begin
85 if UpgradeInfo.BackupDB then
86 begin
87 DBArchive := ChangeFileExt(ActiveDatabasePathName,'');
88 DBArchive := DBArchive + '.' + IntToStr(CurrentDBVersionNo) + '.gbk';
89 SaveDatabase(DBArchive);
90 end;
91 Add2Log(self,UpgradeInfo.UserMessage);
92 Add2Log(self,Format(sUpdateMsg,[UpgradeInfo.UpdateSQLFile]));
93 if not IBXScript.PerformUpdate(UpgradeInfo.UpdateSQLFile,true) then
94 break;
95 UpdateVersionNo;
96 end;
97 until not UpdateAvailable or (LastVersionNo = CurrentDBVersionNo);
98 end;
99
100 procedure TIBCMLocalDBSupport.WriteLog(Msg: string);
101 begin
102 if assigned(OnLogMessage) then
103 OnLogMessage(self,Msg);
104 end;
105
106 procedure TIBCMLocalDBSupport.HandleCreateDatabase(Sender: TObject;
107 var DatabaseFileName: string);
108 begin
109 DatabaseFileName := FDatabasePath;
110 end;
111
112 function TIBCMLocalDBSupport.InternalCreateNewDatabase(DBName: string;
113 DBParams: TStrings; DBArchive: string): boolean;
114 var Service: TIBRestoreService;
115 Ext: string;
116 begin
117 Result := true;
118 CreateDir(ExtractFileDir(DBName));
119 Ext := AnsiUpperCase(ExtractFileExt(DBArchive));
120 if Ext = '.GBK' then
121 begin
122 Service := TIBRestoreService.Create(self);
123 with Service do
124 try
125 SetDBParams(DBParams);
126 LoginPrompt := false;
127 BackupFile.Clear;
128 DatabaseName.Clear;
129 Options := [CreateNewDB];
130 BackupFile.Add(DBArchive);
131 DatabaseName.Add(DBName);
132 Active := true;
133 WriteLog(sCreatingDatabase);
134 ServiceStart;
135 try
136 while not Eof do
137 WriteLog(Trim(GetNextLine));
138 finally
139 Active := false
140 end;
141 finally
142 Free
143 end;
144 end
145 else
146 if Ext = '.SQL' then
147 with TIBXScript.Create(self) do
148 try
149 Database := self.Database;
150 FDatabasePath := DBName;
151 OnCreateDatabase := @HandleCreateDatabase;
152 WriteLog(sCreatingDatabase);
153 Result := RunScript(DBArchive);
154 finally
155 Free
156 end
157 else
158 raise Exception.CreateFmt('Archive file (%s) has an unknown extension',[DBArchive]);
159 end;
160
161 function TIBCMLocalDBSupport.RestoreDatabaseFromArchive(DBName: string;
162 DBParams: TStrings; aFilename: string): boolean;
163 var Service: TIBRestoreService;
164 begin
165 Result := true;
166 Service := TIBRestoreService.Create(self);
167 with Service do
168 try
169 SetDBParams(DBParams);
170 LoginPrompt := false;
171 BackupFile.Clear;
172 DatabaseName.Clear;
173 Options := [replace];
174 BackupFile.Add(aFilename);
175 DatabaseName.Add(DBName);
176 Active := true;
177 ServiceStart;
178 try
179 while not Eof do
180 WriteLog(Trim(GetNextLine));
181 finally
182 Active := false
183 end;
184 finally
185 Free
186 end;
187 end;
188
189 function TIBCMLocalDBSupport.RunUpgradeDatabase(TargetVersionNo: integer
190 ): boolean;
191 var IBXScript: TIBXScript;
192 IBTransaction: TIBTransaction;
193 begin
194 Result := true;
195 IBXScript := TIBXScript.Create(self);
196 IBTransaction := TIBTransaction.Create(self);
197 try
198 IBXScript.Database := Database;
199 IBXScript.Transaction := IBTransaction;
200 IBXScript.OnErrorLog := @Add2Log;
201 IBXScript.OnOutputLog := @Add2Log;
202 IBTransaction.DefaultDatabase := Database;
203 IBTransaction.Params.Clear;
204 IBTransaction.Params.Add('concurrency');
205 IBTransaction.Params.Add('wait');
206 if assigned(UpgradeConf) then
207 IBXScript.GetParamValue := @UpgradeConf.GetParamValue;
208 DoUpgrade(IBXScript, TargetVersionNo);
209 finally
210 IBXScript.Free;
211 IBTransaction.Free;
212 end;
213
214 end;
215
216 function TIBCMLocalDBSupport.SaveDatabaseToArchive(DBName: string;
217 DBParams: TStrings; aFilename: string): boolean;
218 var Service: TIBBackupService;
219 begin
220 Result := true;
221 Service := TIBBackupService.Create(self);
222 with Service do
223 try
224 SetDBParams(DBParams);
225 LoginPrompt := false;
226 BackupFile.Clear;
227 DatabaseName := DBName;
228 BackupFile.Add(aFilename);
229 Active := true;
230 ServiceStart;
231 try
232 while not Eof do
233 WriteLog(Trim(GetNextLine));
234 finally
235 Active := false
236 end;
237 finally
238 Free
239 end;
240 end;
241
242 end.
243