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;
    procedure Add2Log(Sender: TObject; Msg: string);
    procedure DoUpgrade(IBXScript: TIBXScript; TargetVersionNo: integer);
    procedure WriteLog(Msg: string);
  protected
    function CreateNewDatabase(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;

function TIBCMLocalDBSupport.CreateNewDatabase(DBName: string;
  DBParams: TStrings; DBArchive: string): boolean;
var Service: TIBRestoreService;
begin
  CreateDir(ExtractFileDir(DBName));
  Service := TIBRestoreService.Create(self);
  with Service do
  try
   SetDBParams(Service,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;

function TIBCMLocalDBSupport.RestoreDatabaseFromArchive(DBName: string;
  DBParams: TStrings; aFilename: string): boolean;
var Service: TIBRestoreService;
begin
  Service := TIBRestoreService.Create(self);
  with Service do
  try
    SetDBParams(Service,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
  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');
    IBXScript.GetParamValue := @HandleGetParamValue;
    DoUpgrade(IBXScript, TargetVersionNo);
  finally
    Free
  end;

end;

function TIBCMLocalDBSupport.SaveDatabaseToArchive(DBName: string;
  DBParams: TStrings; aFilename: string): boolean;
var Service: TIBBackupService;
begin
  Service := TIBBackupService.Create(self);
  with Service do
  try
   SetDBParams(Service,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:	37
Committed:	Mon Feb 15 14:44:25 2016 UTC (8 years, 9 months ago) by tony
Content type:	text/x-pascal
File size:	5748 byte(s)
Log Message:	Committing updates for Release R1-4-0
#	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			procedure Add2Log(Sender: TObject; Msg: string);
44			procedure DoUpgrade(IBXScript: TIBXScript; TargetVersionNo: integer);
45			procedure WriteLog(Msg: string);
46			protected
47			function CreateNewDatabase(DBName:string; DBParams: TStrings; DBArchive: string): boolean; override;
48			function RestoreDatabaseFromArchive(DBName:string; DBParams: TStrings; aFilename: string): boolean; override;
49			function RunUpgradeDatabase(TargetVersionNo: integer): boolean; override;
50			function SaveDatabaseToArchive(DBName: string; DBParams:TStrings; aFilename: string): boolean; override;
51			public
52			property OnLogMessage: TOnLogMessage read FOnLogMessage write FOnLogMessage;
53			end;
54
55			implementation
56
57			uses IBServices, IBXUpgradeConfFile, IBDatabase;
58
59			resourcestring
60			sUpdateMsg = 'Applying Update from %s';
61			sCreatingDatabase= 'Creating new Database';
62
63			{ TIBCMLocalDBSupport }
64
65			procedure TIBCMLocalDBSupport.Add2Log(Sender: TObject; Msg: string);
66			begin
67			WriteLog(Msg);
68			end;
69
70			procedure TIBCMLocalDBSupport.DoUpgrade(IBXScript: TIBXScript;
71			TargetVersionNo: integer);
72			var UpdateAvailable: boolean;
73			UpgradeInfo: TUpgradeInfo;
74			DBArchive: string;
75			LastVersionNo: integer;
76			begin
77			repeat
78			if CurrentDBVersionNo >= TargetVersionNo then break;
79			LastVersionNo := CurrentDBVersionNo;
80			UpdateAvailable := UpgradeConf.GetUpgradeInfo(CurrentDBVersionNo+1,UpgradeInfo);
81			if UpdateAvailable then
82			begin
83			if UpgradeInfo.BackupDB then
84			begin
85			DBArchive := ChangeFileExt(ActiveDatabasePathName,'');
86			DBArchive := DBArchive + '.' + IntToStr(CurrentDBVersionNo) + '.gbk';
87			SaveDatabase(DBArchive);
88			end;
89			Add2Log(self,UpgradeInfo.UserMessage);
90			Add2Log(self,Format(sUpdateMsg,[UpgradeInfo.UpdateSQLFile]));
91			if not IBXScript.PerformUpdate(UpgradeInfo.UpdateSQLFile,true) then
92			break;
93			UpdateVersionNo;
94			end;
95			until not UpdateAvailable or (LastVersionNo = CurrentDBVersionNo);
96			end;
97
98			procedure TIBCMLocalDBSupport.WriteLog(Msg: string);
99			begin
100			if assigned(OnLogMessage) then
101			OnLogMessage(self,Msg);
102			end;
103
104			function TIBCMLocalDBSupport.CreateNewDatabase(DBName: string;
105			DBParams: TStrings; DBArchive: string): boolean;
106			var Service: TIBRestoreService;
107			begin
108			CreateDir(ExtractFileDir(DBName));
109			Service := TIBRestoreService.Create(self);
110			with Service do
111			try
112			SetDBParams(Service,DBParams);
113			LoginPrompt := false;
114			BackupFile.Clear;
115			DatabaseName.Clear;
116			Options := [CreateNewDB];
117			BackupFile.Add(DBArchive);
118			DatabaseName.Add(DBName);
119			Active := true;
120			WriteLog(sCreatingDatabase);
121			ServiceStart;
122			try
123			while not Eof do
124			WriteLog(Trim(GetNextLine));
125			finally
126			Active := false
127			end;
128			finally
129			Free
130			end;
131
132			end;
133
134			function TIBCMLocalDBSupport.RestoreDatabaseFromArchive(DBName: string;
135			DBParams: TStrings; aFilename: string): boolean;
136			var Service: TIBRestoreService;
137			begin
138			Service := TIBRestoreService.Create(self);
139			with Service do
140			try
141			SetDBParams(Service,DBParams);
142			LoginPrompt := false;
143			BackupFile.Clear;
144			DatabaseName.Clear;
145			Options := [replace];
146			BackupFile.Add(aFilename);
147			DatabaseName.Add(DBName);
148			Active := true;
149			ServiceStart;
150			try
151			while not Eof do
152			WriteLog(Trim(GetNextLine));
153			finally
154			Active := false
155			end;
156			finally
157			Free
158			end;
159			end;
160
161			function TIBCMLocalDBSupport.RunUpgradeDatabase(TargetVersionNo: integer
162			): boolean;
163			var IBXScript: TIBXScript;
164			IBTransaction: TIBTransaction;
165			begin
166			IBXScript := TIBXScript.Create(self);
167			IBTransaction := TIBTransaction.Create(self);
168			try
169			IBXScript.Database := Database;
170			IBXScript.Transaction := IBTransaction;
171			IBXScript.OnErrorLog := @Add2Log;
172			IBXScript.OnOutputLog := @Add2Log;
173			IBTransaction.DefaultDatabase := Database;
174			IBTransaction.Params.Clear;
175			IBTransaction.Params.Add('concurrency');
176			IBTransaction.Params.Add('wait');
177			IBXScript.GetParamValue := @HandleGetParamValue;
178			DoUpgrade(IBXScript, TargetVersionNo);
179			finally
180			Free
181			end;
182
183			end;
184
185			function TIBCMLocalDBSupport.SaveDatabaseToArchive(DBName: string;
186			DBParams: TStrings; aFilename: string): boolean;
187			var Service: TIBBackupService;
188			begin
189			Service := TIBBackupService.Create(self);
190			with Service do
191			try
192			SetDBParams(Service,DBParams);
193			LoginPrompt := false;
194			BackupFile.Clear;
195			DatabaseName := DBName;
196			BackupFile.Add(aFilename);
197			Active := true;
198			ServiceStart;
199			try
200			while not Eof do
201			WriteLog(Trim(GetNextLine));
202			finally
203			Active := false
204			end;
205			finally
206			Free
207			end;
208			end;
209
210			end.
211