iblocaldb/nongui/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, IBXServices;

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);
    procedure HandleOnGetNextLine(Sender: TObject; var Line: string);
  protected
    procedure Downgrade(DBArchive: string); override;
    function InternalCreateNewDatabase(DBArchive: string): boolean; override;
    function RestoreDatabaseFromArchive(aFilename: string): boolean; override;
    function RunUpgradeDatabase(TargetVersionNo: integer): boolean; override;
    function SaveDatabaseToArchive( aFilename: string): boolean; override;
  public
    constructor Create(aOwner: TComponent); override;
    property OnLogMessage: TOnLogMessage read FOnLogMessage write FOnLogMessage;
  end;

implementation

uses IBXUpgradeConfFile, IBDatabase;

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

{ 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';
       SaveDatabaseToArchive(DBArchive);
      end;
      Add2Log(self,UpgradeInfo.UserMessage);
      Add2Log(self,Format(sUpdateMsg,[UpgradeInfo.UpdateSQLFile]));
      if not IBXScript.RunScript(UpgradeInfo.UpdateSQLFile) 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.HandleOnGetNextLine(Sender: TObject;
  var Line: string);
begin
  if assigned(OnLogMessage) then
    OnLogMessage(self,Line);
end;

procedure TIBCMLocalDBSupport.Downgrade(DBArchive: string);
begin
  RestoreDatabase(DBArchive);
end;

function TIBCMLocalDBSupport.InternalCreateNewDatabase(DBArchive: string
  ): boolean;
var Ext: string;
begin
  Result := true;
  Ext := AnsiUpperCase(ExtractFileExt(DBArchive));
  if Ext = '.GBK' then
  begin
    with RestoreService do
    begin
      BackupFiles.Clear;
      BackupFiles.Add(DBArchive);
      Options := [Replace];
      WriteLog(sCreatingDatabase);
      Database.Attachment.Disconnect;
      try
        Execute(nil);
      finally
        Database.Attachment.Connect;
      end;
    end;
  end
  else
  if (Ext = '.SQL') and Database.Connected then
  with TIBXScript.Create(self) do
  try
    Database := self.Database;
    IgnoreCreateDatabase := true;
    WriteLog(sCreatingDatabase);
    Result := RunScript(DBArchive);
  finally
    Free
  end
  else
    raise Exception.CreateFmt('Archive file (%s) has an unknown extension',[DBArchive]);
end;

function TIBCMLocalDBSupport.RestoreDatabaseFromArchive(
  aFilename: string): boolean;
begin
  Result := true;
  with RestoreService do
  begin
    BackupFiles.Clear;
    BackupFiles.Add(aFilename);
    Options := [Replace];
    Execute(nil);
  end;
end;

function TIBCMLocalDBSupport.RunUpgradeDatabase(TargetVersionNo: integer
  ): boolean;
var IBXScript: TIBXScript;
begin
  Result := true;
  IBXScript := TIBXScript.Create(self);
  try
    IBXScript.Database := Database;
    IBXScript.OnErrorLog := @Add2Log;
    IBXScript.OnOutputLog := @Add2Log;
    if assigned(UpgradeConf) then
      IBXScript.GetParamValue := @UpgradeConf.GetParamValue;
    DoUpgrade(IBXScript, TargetVersionNo);
  finally
    IBXScript.Free;
  end;

end;

function TIBCMLocalDBSupport.SaveDatabaseToArchive(aFilename: string): boolean;
var Service: TIBXClientSideBackupService;
begin
  Result := true;
  with BackupService do
  begin
    Execute(nil);
    WriteLog(Format(sBackupDone,[aFileName]));
  end;
end;

constructor TIBCMLocalDBSupport.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  RestoreService.OnGetNextLine := @HandleOnGetNextLine;
  BackupService.OnGetNextLine := @HandleOnGetNextLine;
end;

end.

Revision:	209
Committed:	Wed Mar 14 12:48:51 2018 UTC (6 years, 1 month ago) by tony
Content type:	text/x-pascal
Original Path:	*ibx/trunk/iblocaldb/nongui/IBCMLocalDBSupport.pas*
File size:	5734 byte(s)
Log Message:	Fixes Merged
#	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			procedure Add2Log(Sender: TObject; Msg: string);
44			procedure DoUpgrade(IBXScript: TIBXScript; TargetVersionNo: integer);
45			procedure WriteLog(Msg: string);
46			procedure HandleOnGetNextLine(Sender: TObject; var Line: string);
47			protected
48			procedure Downgrade(DBArchive: string); override;
49			function InternalCreateNewDatabase(DBArchive: string): boolean; override;
50			function RestoreDatabaseFromArchive(aFilename: string): boolean; override;
51			function RunUpgradeDatabase(TargetVersionNo: integer): boolean; override;
52			function SaveDatabaseToArchive( aFilename: string): boolean; override;
53			public
54			constructor Create(aOwner: TComponent); override;
55			property OnLogMessage: TOnLogMessage read FOnLogMessage write FOnLogMessage;
56			end;
57
58			implementation
59
60			uses IBXUpgradeConfFile, IBDatabase;
61
62			resourcestring
63			sUpdateMsg = 'Applying Update from %s';
64			sCreatingDatabase = 'Creating new Database';
65			sBackupDone = 'Database Archived to %s';
66
67			{ TIBCMLocalDBSupport }
68
69			procedure TIBCMLocalDBSupport.Add2Log(Sender: TObject; Msg: string);
70			begin
71			WriteLog(Msg);
72			end;
73
74			procedure TIBCMLocalDBSupport.DoUpgrade(IBXScript: TIBXScript;
75			TargetVersionNo: integer);
76			var UpdateAvailable: boolean;
77			UpgradeInfo: TUpgradeInfo;
78			DBArchive: string;
79			LastVersionNo: integer;
80			begin
81			repeat
82			if CurrentDBVersionNo >= TargetVersionNo then break;
83			LastVersionNo := CurrentDBVersionNo;
84			UpdateAvailable := UpgradeConf.GetUpgradeInfo(CurrentDBVersionNo+1,UpgradeInfo);
85			if UpdateAvailable then
86			begin
87			if UpgradeInfo.BackupDB then
88			begin
89			DBArchive := ChangeFileExt(ActiveDatabasePathName,'');
90			DBArchive := DBArchive + '.' + IntToStr(CurrentDBVersionNo) + '.gbk';
91			SaveDatabaseToArchive(DBArchive);
92			end;
93			Add2Log(self,UpgradeInfo.UserMessage);
94			Add2Log(self,Format(sUpdateMsg,[UpgradeInfo.UpdateSQLFile]));
95			if not IBXScript.RunScript(UpgradeInfo.UpdateSQLFile) then
96			break;
97			UpdateVersionNo;
98			end;
99			until not UpdateAvailable or (LastVersionNo = CurrentDBVersionNo);
100			end;
101
102			procedure TIBCMLocalDBSupport.WriteLog(Msg: string);
103			begin
104			if assigned(OnLogMessage) then
105			OnLogMessage(self,Msg);
106			end;
107
108			procedure TIBCMLocalDBSupport.HandleOnGetNextLine(Sender: TObject;
109			var Line: string);
110			begin
111			if assigned(OnLogMessage) then
112			OnLogMessage(self,Line);
113			end;
114
115			procedure TIBCMLocalDBSupport.Downgrade(DBArchive: string);
116			begin
117			RestoreDatabase(DBArchive);
118			end;
119
120			function TIBCMLocalDBSupport.InternalCreateNewDatabase(DBArchive: string
121			): boolean;
122			var Ext: string;
123			begin
124			Result := true;
125			Ext := AnsiUpperCase(ExtractFileExt(DBArchive));
126			if Ext = '.GBK' then
127			begin
128			with RestoreService do
129			begin
130			BackupFiles.Clear;
131			BackupFiles.Add(DBArchive);
132			Options := [Replace];
133			WriteLog(sCreatingDatabase);
134			Database.Attachment.Disconnect;
135			try
136			Execute(nil);
137			finally
138			Database.Attachment.Connect;
139			end;
140			end;
141			end
142			else
143			if (Ext = '.SQL') and Database.Connected then
144			with TIBXScript.Create(self) do
145			try
146			Database := self.Database;
147			IgnoreCreateDatabase := true;
148			WriteLog(sCreatingDatabase);
149			Result := RunScript(DBArchive);
150			finally
151			Free
152			end
153			else
154			raise Exception.CreateFmt('Archive file (%s) has an unknown extension',[DBArchive]);
155			end;
156
157			function TIBCMLocalDBSupport.RestoreDatabaseFromArchive(
158			aFilename: string): boolean;
159			begin
160			Result := true;
161			with RestoreService do
162			begin
163			BackupFiles.Clear;
164			BackupFiles.Add(aFilename);
165			Options := [Replace];
166			Execute(nil);
167			end;
168			end;
169
170			function TIBCMLocalDBSupport.RunUpgradeDatabase(TargetVersionNo: integer
171			): boolean;
172			var IBXScript: TIBXScript;
173			begin
174			Result := true;
175			IBXScript := TIBXScript.Create(self);
176			try
177			IBXScript.Database := Database;
178			IBXScript.OnErrorLog := @Add2Log;
179			IBXScript.OnOutputLog := @Add2Log;
180			if assigned(UpgradeConf) then
181			IBXScript.GetParamValue := @UpgradeConf.GetParamValue;
182			DoUpgrade(IBXScript, TargetVersionNo);
183			finally
184			IBXScript.Free;
185			end;
186
187			end;
188
189			function TIBCMLocalDBSupport.SaveDatabaseToArchive(aFilename: string): boolean;
190			var Service: TIBXClientSideBackupService;
191			begin
192			Result := true;
193			with BackupService do
194			begin
195			Execute(nil);
196			WriteLog(Format(sBackupDone,[aFileName]));
197			end;
198			end;
199
200			constructor TIBCMLocalDBSupport.Create(aOwner: TComponent);
201			begin
202			inherited Create(aOwner);
203			RestoreService.OnGetNextLine := @HandleOnGetNextLine;
204			BackupService.OnGetNextLine := @HandleOnGetNextLine;
205			end;
206
207			end.
208