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, 8 months ago) by tony
Content type:	text/x-pascal
File size:	5734 byte(s)
Log Message:	Fixes Merged
#	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, 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