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;
    FOnProgressEvent: TOnProgressEvent;
    function DoUpgrade(IBXScript: TIBXScript; TargetVersionNo: integer): boolean;
    procedure WriteLog(Msg: string);
    procedure HandleOnGetNextLine(Sender: TObject; var Line: string);
    procedure IBXScriptCreateDatabase(Sender: TObject;
      var DatabaseFileName: string);
  protected
    procedure Add2Log(Sender: TObject; Msg: string); override;
    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;
    property OnProgressEvent: TOnProgressEvent read FOnProgressEvent write FOnProgressEvent; {Progress Bar Support}
  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;

function TIBCMLocalDBSupport.DoUpgrade(IBXScript: TIBXScript;
  TargetVersionNo: integer): boolean;
var UpdateAvailable: boolean;
    UpgradeInfo: TUpgradeInfo;
    DBArchive: string;
    LastVersionNo: integer;
begin
  repeat
    if CurrentDBVersionNo >= TargetVersionNo then break;
    LastVersionNo := CurrentDBVersionNo;
    UpdateAvailable := UpgradeConf.GetUpgradeInfo(SectionHeaderTemplate,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]));
      Result := IBXScript.RunScript(UpgradeInfo.UpdateSQLFile);
      if not Result 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.IBXScriptCreateDatabase(Sender: TObject;
  var DatabaseFileName: string);
begin
  DatabaseFileName := (Sender as TIBXScript).Database.Attachment.GetConnectString;
  (Sender as TIBXScript).Database.DropDatabase;
end;

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

function TIBCMLocalDBSupport.InternalCreateNewDatabase(DBArchive: string
  ): boolean;
begin
  Result := true;
  if IsGbakFile(DBArchive) 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
  with TIBXScript.Create(self) do
  try
    Database := self.Database;
    OnCreateDatabase := @IBXScriptCreateDatabase;
    OnProgressEvent := FOnProgressEvent;
    WriteLog(sCreatingDatabase);
    Result := RunScript(DBArchive);
    Add2Log(self,''); {ensure EOL sent}
  finally
    Free
  end
end;

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

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

end;

function TIBCMLocalDBSupport.SaveDatabaseToArchive(aFilename: string): boolean;
begin
  Result := true;
  with BackupService do
  begin
    DatabaseName := Database.DatabaseName;
    BackupFiles.Clear;
    BackupFiles.Add(aFileName);
    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:	345
Committed:	Mon Aug 23 14:22:29 2021 UTC (3 years, 3 months ago) by tony
Content type:	text/x-pascal
File size:	6344 byte(s)
Log Message:	Merged into public release
#	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	tony	272	FOnProgressEvent: TOnProgressEvent;
44	tony	315	function DoUpgrade(IBXScript: TIBXScript; TargetVersionNo: integer): boolean;
45	tony	209	procedure WriteLog(Msg: string);
46			procedure HandleOnGetNextLine(Sender: TObject; var Line: string);
47	tony	272	procedure IBXScriptCreateDatabase(Sender: TObject;
48			var DatabaseFileName: string);
49	tony	209	protected
50	tony	315	procedure Add2Log(Sender: TObject; Msg: string); override;
51	tony	209	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	tony	272	property OnProgressEvent: TOnProgressEvent read FOnProgressEvent write FOnProgressEvent; {Progress Bar Support}
60	tony	209	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	tony	315	function TIBCMLocalDBSupport.DoUpgrade(IBXScript: TIBXScript;
79			TargetVersionNo: integer): boolean;
80	tony	209	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	tony	345	UpdateAvailable := UpgradeConf.GetUpgradeInfo(SectionHeaderTemplate,CurrentDBVersionNo+1,UpgradeInfo);
89	tony	209	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	tony	315	Result := IBXScript.RunScript(UpgradeInfo.UpdateSQLFile);
100			if not Result then
101	tony	209	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	tony	272	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	tony	209	procedure TIBCMLocalDBSupport.Downgrade(DBArchive: string);
128			begin
129	tony	315	inherited;
130	tony	209	RestoreDatabase(DBArchive);
131	tony	315	DowngradeDone;
132	tony	209	end;
133
134			function TIBCMLocalDBSupport.InternalCreateNewDatabase(DBArchive: string
135			): boolean;
136			begin
137			Result := true;
138	tony	272	if IsGbakFile(DBArchive) then
139	tony	209	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	tony	272	OnCreateDatabase := @IBXScriptCreateDatabase;
159			OnProgressEvent := FOnProgressEvent;
160	tony	209	WriteLog(sCreatingDatabase);
161			Result := RunScript(DBArchive);
162	tony	272	Add2Log(self,''); {ensure EOL sent}
163	tony	209	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	tony	315	DatabaseFiles.Clear;
177			DatabaseFiles.Add(Database.DatabaseName);
178	tony	209	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	tony	315	Result := DoUpgrade(IBXScript, TargetVersionNo);
195	tony	209	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	tony	315	DatabaseName := Database.DatabaseName;
207			BackupFiles.Clear;
208			BackupFiles.Add(aFileName);
209	tony	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