trunk/iblocaldb/IBCMLocalDBSupport.pas

(*
 *  IBX For Lazarus (Firebird Express)
 *
 *  The contents of this file are subject to the Initial Developer's
 *  Public License Version 1.0 (the "License"); you may not use this
 *  file except in compliance with the License. You may obtain a copy
 *  of the License here:
 *
 *    http://www.firebirdsql.org/index.php?op=doc&id=idpl
 *
 *  Software distributed under the License is distributed on an "AS
 *  IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
 *  implied. See the License for the specific language governing rights
 *  and limitations under the License.
 *
 *  The Initial Developer of the Original Code is Tony Whyman.
 *
 *  The Original Code is (C) 2014 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*)
unit IBCMLocalDBSupport;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, IBXCustomIBLocalDBSupport, ibxscript;

type
  TOnLogMessage = procedure(Sender: TObject; Msg: string) of object;

  { TIBCMLocalDBSupport }

  TIBCMLocalDBSupport = class(TCustomIBLocalDBSupport)
  private
    FOnLogMessage: TOnLogMessage;
    FDatabasePath: string;
    procedure Add2Log(Sender: TObject; Msg: string);
    procedure DoUpgrade(IBXScript: TIBXScript; TargetVersionNo: integer);
    procedure WriteLog(Msg: string);
    procedure HandleCreateDatabase(Sender: TObject; var DatabaseFileName: string);
  protected
    function InternalCreateNewDatabase(DBName:string; DBParams: TStrings; DBArchive: string): boolean; override;
    function RestoreDatabaseFromArchive(DBName:string; DBParams: TStrings; aFilename: string): boolean; override;
    function RunUpgradeDatabase(TargetVersionNo: integer): boolean; override;
    function SaveDatabaseToArchive(DBName: string; DBParams:TStrings; aFilename: string): boolean; override;
  public
    property OnLogMessage: TOnLogMessage read FOnLogMessage write FOnLogMessage;
  end;

implementation

uses IBServices, IBXUpgradeConfFile, IBDatabase;

resourcestring
  sUpdateMsg =       'Applying Update from %s';
  sCreatingDatabase= 'Creating new Database';

{ TIBCMLocalDBSupport }

procedure TIBCMLocalDBSupport.Add2Log(Sender: TObject; Msg: string);
begin
  WriteLog(Msg);
end;

procedure TIBCMLocalDBSupport.DoUpgrade(IBXScript: TIBXScript;
  TargetVersionNo: integer);
var UpdateAvailable: boolean;
    UpgradeInfo: TUpgradeInfo;
    DBArchive: string;
    LastVersionNo: integer;
begin
  repeat
    if CurrentDBVersionNo >= TargetVersionNo then break;
    LastVersionNo := CurrentDBVersionNo;
    UpdateAvailable := UpgradeConf.GetUpgradeInfo(CurrentDBVersionNo+1,UpgradeInfo);
    if UpdateAvailable then
    begin
      if UpgradeInfo.BackupDB then
      begin
       DBArchive := ChangeFileExt(ActiveDatabasePathName,'');
       DBArchive := DBArchive + '.' + IntToStr(CurrentDBVersionNo) + '.gbk';
       SaveDatabase(DBArchive);
      end;
      Add2Log(self,UpgradeInfo.UserMessage);
      Add2Log(self,Format(sUpdateMsg,[UpgradeInfo.UpdateSQLFile]));
      if not IBXScript.PerformUpdate(UpgradeInfo.UpdateSQLFile,true) then
       break;
      UpdateVersionNo;
    end;
  until not UpdateAvailable or (LastVersionNo = CurrentDBVersionNo);
end;

procedure TIBCMLocalDBSupport.WriteLog(Msg: string);
begin
  if assigned(OnLogMessage) then
    OnLogMessage(self,Msg);
end;

procedure TIBCMLocalDBSupport.HandleCreateDatabase(Sender: TObject;
  var DatabaseFileName: string);
begin
  DatabaseFileName := FDatabasePath;
end;

function TIBCMLocalDBSupport.InternalCreateNewDatabase(DBName: string;
  DBParams: TStrings; DBArchive: string): boolean;
var Service: TIBRestoreService;
    Ext: string;
begin
  Result := true;
  CreateDir(ExtractFileDir(DBName));
  Ext := AnsiUpperCase(ExtractFileExt(DBArchive));
  if Ext = '.GBK' then
  begin
    Service := TIBRestoreService.Create(self);
    with Service do
    try
     SetDBParams(DBParams);
     LoginPrompt := false;
     BackupFile.Clear;
     DatabaseName.Clear;
     Options := [CreateNewDB];
     BackupFile.Add(DBArchive);
     DatabaseName.Add(DBName);
     Active := true;
     WriteLog(sCreatingDatabase);
     ServiceStart;
     try
       while not Eof do
         WriteLog(Trim(GetNextLine));
     finally
       Active := false
     end;
    finally
      Free
    end;
  end
  else
  if Ext = '.SQL' then
  with TIBXScript.Create(self) do
  try
    Database := self.Database;
    FDatabasePath := DBName;
    OnCreateDatabase := @HandleCreateDatabase;
    WriteLog(sCreatingDatabase);
    Result := RunScript(DBArchive);
  finally
    Free
  end
  else
    raise Exception.CreateFmt('Archive file (%s) has an unknown extension',[DBArchive]);
end;

function TIBCMLocalDBSupport.RestoreDatabaseFromArchive(DBName: string;
  DBParams: TStrings; aFilename: string): boolean;
var Service: TIBRestoreService;
begin
  Result := true;
  Service := TIBRestoreService.Create(self);
  with Service do
  try
    SetDBParams(DBParams);
    LoginPrompt := false;
    BackupFile.Clear;
    DatabaseName.Clear;
    Options := [replace];
    BackupFile.Add(aFilename);
    DatabaseName.Add(DBName);
    Active := true;
    ServiceStart;
    try
      while not Eof do
        WriteLog(Trim(GetNextLine));
    finally
      Active := false
    end;
  finally
    Free
  end;
end;

function TIBCMLocalDBSupport.RunUpgradeDatabase(TargetVersionNo: integer
  ): boolean;
var IBXScript: TIBXScript;
    IBTransaction: TIBTransaction;
begin
  Result := true;
  IBXScript := TIBXScript.Create(self);
  IBTransaction := TIBTransaction.Create(self);
  try
    IBXScript.Database := Database;
    IBXScript.Transaction := IBTransaction;
    IBXScript.OnErrorLog := @Add2Log;
    IBXScript.OnOutputLog := @Add2Log;
    IBTransaction.DefaultDatabase := Database;
    IBTransaction.Params.Clear;
    IBTransaction.Params.Add('concurrency');
    IBTransaction.Params.Add('wait');
    if assigned(UpgradeConf) then
      IBXScript.GetParamValue := @UpgradeConf.GetParamValue;
    DoUpgrade(IBXScript, TargetVersionNo);
  finally
    IBXScript.Free;
    IBTransaction.Free;
  end;

end;

function TIBCMLocalDBSupport.SaveDatabaseToArchive(DBName: string;
  DBParams: TStrings; aFilename: string): boolean;
var Service: TIBBackupService;
begin
  Result := true;
  Service := TIBBackupService.Create(self);
  with Service do
  try
   SetDBParams(DBParams);
   LoginPrompt := false;
   BackupFile.Clear;
   DatabaseName := DBName;
   BackupFile.Add(aFilename);
   Active := true;
   ServiceStart;
   try
     while not Eof do
       WriteLog(Trim(GetNextLine));
   finally
     Active := false
   end;
  finally
    Free
  end;
end;

end.

Revision:	85
Committed:	Mon Jan 1 11:31:20 2018 UTC (6 years, 3 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
#	User	Rev	Content
1	tony	37	(*
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	tony	80	FDatabasePath: string;
44	tony	37	procedure Add2Log(Sender: TObject; Msg: string);
45			procedure DoUpgrade(IBXScript: TIBXScript; TargetVersionNo: integer);
46			procedure WriteLog(Msg: string);
47	tony	80	procedure HandleCreateDatabase(Sender: TObject; var DatabaseFileName: string);
48	tony	37	protected
49	tony	85	function InternalCreateNewDatabase(DBName:string; DBParams: TStrings; DBArchive: string): boolean; override;
50	tony	37	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	tony	80	procedure TIBCMLocalDBSupport.HandleCreateDatabase(Sender: TObject;
107			var DatabaseFileName: string);
108			begin
109			DatabaseFileName := FDatabasePath;
110			end;
111
112	tony	85	function TIBCMLocalDBSupport.InternalCreateNewDatabase(DBName: string;
113	tony	37	DBParams: TStrings; DBArchive: string): boolean;
114			var Service: TIBRestoreService;
115	tony	80	Ext: string;
116	tony	37	begin
117	tony	80	Result := true;
118	tony	37	CreateDir(ExtractFileDir(DBName));
119	tony	80	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	tony	37	try
149	tony	80	Database := self.Database;
150			FDatabasePath := DBName;
151			OnCreateDatabase := @HandleCreateDatabase;
152			WriteLog(sCreatingDatabase);
153			Result := RunScript(DBArchive);
154	tony	37	finally
155			Free
156	tony	80	end
157			else
158			raise Exception.CreateFmt('Archive file (%s) has an unknown extension',[DBArchive]);
159	tony	37	end;
160
161			function TIBCMLocalDBSupport.RestoreDatabaseFromArchive(DBName: string;
162			DBParams: TStrings; aFilename: string): boolean;
163			var Service: TIBRestoreService;
164			begin
165	tony	80	Result := true;
166	tony	37	Service := TIBRestoreService.Create(self);
167			with Service do
168			try
169	tony	80	SetDBParams(DBParams);
170	tony	37	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	tony	80	Result := true;
195	tony	37	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	tony	80	if assigned(UpgradeConf) then
207			IBXScript.GetParamValue := @UpgradeConf.GetParamValue;
208	tony	37	DoUpgrade(IBXScript, TargetVersionNo);
209			finally
210	tony	45	IBXScript.Free;
211			IBTransaction.Free;
212	tony	37	end;
213
214			end;
215
216			function TIBCMLocalDBSupport.SaveDatabaseToArchive(DBName: string;
217			DBParams: TStrings; aFilename: string): boolean;
218			var Service: TIBBackupService;
219			begin
220	tony	80	Result := true;
221	tony	37	Service := TIBBackupService.Create(self);
222			with Service do
223			try
224	tony	80	SetDBParams(DBParams);
225	tony	37	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