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;
    procedure Add2Log(Sender: TObject; Msg: string);
    procedure DoUpgrade(IBXScript: TIBXScript; TargetVersionNo: integer);
    procedure WriteLog(Msg: string);
    procedure HandleOnGetNextLine(Sender: TObject; var Line: string);
    procedure IBXScriptCreateDatabase(Sender: TObject;
      var DatabaseFileName: 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;
    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;

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.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
  RestoreDatabase(DBArchive);
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);
    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:	272
Committed:	Mon Feb 4 13:34:37 2019 UTC (5 years, 9 months ago) by tony
Content type:	text/x-pascal
File size:	6123 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	FOnProgressEvent: TOnProgressEvent;
44	procedure Add2Log(Sender: TObject; Msg: string);
45	procedure DoUpgrade(IBXScript: TIBXScript; TargetVersionNo: integer);
46	procedure WriteLog(Msg: string);
47	procedure HandleOnGetNextLine(Sender: TObject; var Line: string);
48	procedure IBXScriptCreateDatabase(Sender: TObject;
49	var DatabaseFileName: string);
50	protected
51	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	property OnProgressEvent: TOnProgressEvent read FOnProgressEvent write FOnProgressEvent; {Progress Bar Support}
60	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	procedure TIBCMLocalDBSupport.DoUpgrade(IBXScript: TIBXScript;
79	TargetVersionNo: integer);
80	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	UpdateAvailable := UpgradeConf.GetUpgradeInfo(CurrentDBVersionNo+1,UpgradeInfo);
89	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	if not IBXScript.RunScript(UpgradeInfo.UpdateSQLFile) then
100	break;
101	UpdateVersionNo;
102	end;
103	until not UpdateAvailable or (LastVersionNo = CurrentDBVersionNo);
104	end;
105
106	procedure TIBCMLocalDBSupport.WriteLog(Msg: string);
107	begin
108	if assigned(OnLogMessage) then
109	OnLogMessage(self,Msg);
110	end;
111
112	procedure TIBCMLocalDBSupport.HandleOnGetNextLine(Sender: TObject;
113	var Line: string);
114	begin
115	if assigned(OnLogMessage) then
116	OnLogMessage(self,Line);
117	end;
118
119	procedure TIBCMLocalDBSupport.IBXScriptCreateDatabase(Sender: TObject;
120	var DatabaseFileName: string);
121	begin
122	DatabaseFileName := (Sender as TIBXScript).Database.Attachment.GetConnectString;
123	(Sender as TIBXScript).Database.DropDatabase;
124	end;
125
126	procedure TIBCMLocalDBSupport.Downgrade(DBArchive: string);
127	begin
128	RestoreDatabase(DBArchive);
129	end;
130
131	function TIBCMLocalDBSupport.InternalCreateNewDatabase(DBArchive: string
132	): boolean;
133	begin
134	Result := true;
135	if IsGbakFile(DBArchive) then
136	begin
137	with RestoreService do
138	begin
139	BackupFiles.Clear;
140	BackupFiles.Add(DBArchive);
141	Options := [Replace];
142	WriteLog(sCreatingDatabase);
143	Database.Attachment.Disconnect;
144	try
145	Execute(nil);
146	finally
147	Database.Attachment.Connect;
148	end;
149	end;
150	end
151	else
152	with TIBXScript.Create(self) do
153	try
154	Database := self.Database;
155	OnCreateDatabase := @IBXScriptCreateDatabase;
156	OnProgressEvent := FOnProgressEvent;
157	WriteLog(sCreatingDatabase);
158	Result := RunScript(DBArchive);
159	Add2Log(self,''); {ensure EOL sent}
160	finally
161	Free
162	end
163	end;
164
165	function TIBCMLocalDBSupport.RestoreDatabaseFromArchive(
166	aFilename: string): boolean;
167	begin
168	Result := true;
169	with RestoreService do
170	begin
171	BackupFiles.Clear;
172	BackupFiles.Add(aFilename);
173	Options := [Replace];
174	Execute(nil);
175	end;
176	end;
177
178	function TIBCMLocalDBSupport.RunUpgradeDatabase(TargetVersionNo: integer
179	): boolean;
180	var IBXScript: TIBXScript;
181	begin
182	Result := true;
183	IBXScript := TIBXScript.Create(self);
184	try
185	IBXScript.Database := Database;
186	IBXScript.OnErrorLog := @Add2Log;
187	IBXScript.OnOutputLog := @Add2Log;
188	if assigned(UpgradeConf) then
189	IBXScript.GetParamValue := @UpgradeConf.GetParamValue;
190	DoUpgrade(IBXScript, TargetVersionNo);
191	finally
192	IBXScript.Free;
193	end;
194
195	end;
196
197	function TIBCMLocalDBSupport.SaveDatabaseToArchive(aFilename: string): boolean;
198	var Service: TIBXClientSideBackupService;
199	begin
200	Result := true;
201	with BackupService do
202	begin
203	Execute(nil);
204	WriteLog(Format(sBackupDone,[aFileName]));
205	end;
206	end;
207
208	constructor TIBCMLocalDBSupport.Create(aOwner: TComponent);
209	begin
210	inherited Create(aOwner);
211	RestoreService.OnGetNextLine := @HandleOnGetNextLine;
212	BackupService.OnGetNextLine := @HandleOnGetNextLine;
213	end;
214
215	end.
216