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, 2 months ago) by tony
Content type:	text/x-pascal
File size:	5748 byte(s)
Log Message:	Committing updates for Release R1-4-0
#	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;
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