ViewVC Help

View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing

root/public/ibx/trunk/iblocaldb/IBXCustomIBLocalDBSupport.pas

Comparing ibx/trunk/iblocaldb/IBXCustomIBLocalDBSupport.pas (file contents):
Revision 79 by tony, Tue Dec 6 10:33:46 2016 UTC vs.
Revision 80 by tony, Mon Jan 1 11:31:07 2018 UTC

#	Line 80 | Line 80 | type
80		TIBLocalOption = (iblAutoUpgrade, iblAllowDowngrade, iblQuiet);
81		TIBLocalOptions = set of TIBLocalOption;
82
83	+	EIBLocalException = class(Exception);
84	+
85
86		{ TCustomIBLocalDBSupport }
87
#	Line 106 | Line 108 | type
108		FDownGradeArchive: string;
109		FSharedDataDir: string;
110		FUpgradeConf: TUpgradeConfFile;
111	+	FInCreateNew: boolean;
112	+	FSavedAfterConnect: TNotifyEvent;
113	+	FSavedAfterDisconnect: TNotifyEvent;
114	+	FSavedBeforeConnect: TNotifyEvent;
115	+	FSavedBeforeDisconnect: TNotifyEvent;
116		procedure CheckEnabled;
117		procedure CreateDatabase(DBName: string; DBParams: TStrings; Overwrite: boolean);
118		function GetDatabase: TIBDatabase;
119	+	function GetSharedDataDir: string;
120		procedure SetDatabase(AValue: TIBDatabase);
121		function GetDBNameAndPath: string;
122		procedure InitDatabaseParameters(DBParams: TStrings;
#	Line 123 | Line 131 | type
131		procedure SetFirebirdDirectory(AValue: string);
132		procedure SetupFirebirdEnv;
133		procedure UpgradeCheck;
134	+	procedure SaveEvents;
135	+	procedure RestoreEvents;
136		protected
137		{ Protected declarations }
138		function AllowInitialisation: boolean; virtual;
139		function AllowRestore: boolean; virtual;
140		procedure CreateDir(DirName: string);
141	<	function CreateNewDatabase(DBName:string; DBParams: TStrings; DBArchive: string): boolean; virtual; abstract;
142	<	procedure HandleGetParamValue(Sender: TObject; ParamName: string; var BlobID: TISC_QUAD);
141	>	function InternalCreateNewDatabase(DBName:string; DBParams: TStrings; DBArchive: string): boolean; virtual; abstract;
142	>	function CreateNewDatabase(DBName:string; DBParams: TStrings; DBArchive: string): boolean;
143		procedure Downgrade(DBArchive: string); virtual;
144		procedure DowngradeDone;
145		procedure Loaded; override;
#	Line 166 | Line 176 | type
176		is prompted for archive filename if filename empty.}
177		procedure SaveDatabase(filename: string = '');
178
169	–	{Copies database parameters as give in the DBParams to the Service
170	–	omitting any parameters not appropriate for TIBService. Typically, the
171	–	DBParams are TIBDatabase.Params}
172	–	class procedure SetDBParams(aService: TIBCustomService; DBParams: TStrings);
173	–
179		property ActiveDatabasePathName: string read FActiveDatabasePathName;
180		property CurrentDBVersionNo: integer read FCurrentDBVersionNo;
181	+	property SharedDataDir: string read GetSharedDataDir;
182
183		{ Likely to be Published declarations }
184		property Database: TIBDatabase read GetDatabase write SetDatabase;
#	Line 194 | Line 200 | type
200
201		implementation
202
203	<	uses  DB, IBBlob, ZStream
204	<	{$IFDEF Unix} ,initc, regexpr {$ENDIF}
199	<	{$IFDEF WINDOWS} ,Windows ,Windirs {$ENDIF};
203	>	{$IFDEF Unix} uses initc, regexpr {$ENDIF}
204	>	{$IFDEF WINDOWS} uses Windows ,Windirs {$ENDIF};
205
206		resourcestring
207		sNoDowngrade = 'Database Schema is %d. Unable to downgrade to version %d';
208		sLocalDBDisabled = 'Local Database Access Disabled';
209		sEmptyDBArchiveMissing = 'Unable to create database - no empty DB archive specified';
210	<	sEmptyDBArchiveNotFound = 'Unable to create database - empty DB archive file not found';
210	>	sEmptyDBArchiveNotFound = 'Unable to create database - empty DB archive file (%s) not found';
211		sNoEmbeddedServer = 'Firebird Embedded Server is required but is not installed';
212	+	sCreateFailed = 'Unable to Create Personal Database';
213
214		{ TCustomIBLocalDBSupport }
215
216
211	–	procedure TCustomIBLocalDBSupport.HandleGetParamValue(Sender: TObject;
212	–	ParamName: string; var BlobID: TISC_QUAD);
213	–	var Blob: TIBBlobStream;
214	–	Source: TStream;
215	–	FileName: string;
216	–	begin
217	–	Blob := TIBBlobStream.Create;
218	–	try
219	–	Blob.Database := (Sender as TIBXScript).Database;
220	–	Blob.Transaction := (Sender as TIBXScript).Transaction;
221	–	Blob.Mode := bmWrite;
222	–	if not assigned(UpgradeConf) or
223	–	not UpgradeConf.GetSourceFile(ParamName,FileName) then Exit;
224	–
225	–	if CompareText(ExtractFileExt(FileName),'.gz') = 0 then  {gzip compressed file}
226	–	Source := TGZFileStream.Create(FileName,gzopenread)
227	–	else
228	–	Source := TFileStream.Create(FileName,fmOpenRead or fmShareDenyNone);
229	–	try
230	–	Blob.CopyFrom(Source,0)
231	–	finally
232	–	Source.Free
233	–	end;
234	–	Blob.Finalize;
235	–	BlobID := Blob.BlobID
236	–	finally
237	–	Blob.Free
238	–	end
239	–	end;
240	–
217		procedure TCustomIBLocalDBSupport.CheckEnabled;
218		begin
219		if not Enabled then
220	<	raise Exception.Create(sLocalDBDisabled);
220	>	raise EIBLocalException.Create(sLocalDBDisabled);
221		end;
222
223		procedure TCustomIBLocalDBSupport.CreateDatabase(DBName: string; DBParams: TStrings;
#	Line 251 | Line 227 | begin
227		CheckEnabled;
228		DBArchive := EmptyDBArchive;
229		if DBArchive = '' then
230	<	raise Exception.Create(sEmptyDBArchiveMissing);
230	>	raise EIBLocalException.Create(sEmptyDBArchiveMissing);
231
232		if not TUpgradeConfFile.IsAbsolutePath(DBArchive) then
233	<	DBArchive := FSharedDataDir + DBArchive;
233	>	DBArchive := SharedDataDir + DBArchive;
234
235		if not FileExists(DBArchive) then
236	<	raise Exception.Create(sEmptyDBArchiveNotFound);
236	>	raise EIBLocalException.CreateFmt(sEmptyDBArchiveNotFound,[DBArchive]);
237
238		if FileExists(DBName) then
239		begin
#	Line 267 | Line 243 | begin
243		end;
244
245		SetupFirebirdEnv;
246	<	CreateNewDatabase(DBName,DBParams,DBArchive);
247	<	FNewDBCreated := true;
246	>	SaveEvents;
247	>	try
248	>	if not CreateNewDatabase(DBName,DBParams,DBArchive) then
249	>	begin
250	>	Database.Connected := true;
251	>	Database.DropDatabase;
252	>	raise EIBLocalException.Create(sCreateFailed);
253	>	end
254	>	else
255	>	FNewDBCreated := true;
256	>	finally
257	>	RestoreEvents;
258	>	end;
259		end;
260
261		function TCustomIBLocalDBSupport.GetDatabase: TIBDatabase;
#	Line 276 | Line 263 | begin
263		Result := FIBBase.Database;
264		end;
265
266	+	function TCustomIBLocalDBSupport.GetSharedDataDir: string;
267	+	begin
268	+	if FSharedDataDir = '' then
269	+	FSharedDataDir := MapSharedDataDir(ExtractFilePath(ParamStr(0)));
270	+	Result := FSharedDataDir;
271	+	end;
272	+
273		procedure TCustomIBLocalDBSupport.SetDatabase(AValue: TIBDatabase);
274		begin
275		FIBBase.Database := AValue;
#	Line 290 | Line 284 | begin
284		{$IFDEF UNIX}
285
286		{Under Unix transform application exe paths that are in installed locations
287	<	e.g. /usr/local/bin to corresponding shared data locations ee.g. /usr/local/shared}
287	>	e.g. /usr/local/bin to corresponding shared data locations e.g. /usr/local/shared}
288		RegexObj := TRegExpr.Create;
289		try
290		RegexObj.Expression := '^/usr(/local|)/(s|)bin/.*$';
#	Line 300 | Line 294 | begin
294		RegexObj.Free;
295		end;
296		{$ENDIF}
297	<	if assigned (OnGetSharedDataDir) then
297	>	if assigned (FOnGetSharedDataDir) then
298		OnGetSharedDataDir(self,Result);
299	+	{Ensure a trailing separator}
300	+	if (Length(Result) > 0) and (Result[Length(Result)] <> DirectorySeparator) then
301	+	Result := Result + DirectorySeparator;
302		end;
303
304		{$IFDEF Unix}
#	Line 327 | Line 324 | end;
324		procedure TCustomIBLocalDBSupport.OnBeforeDatabaseConnect(Sender: TObject;
325		DBParams: TStrings; var DBName: string);
326		begin
327	<	if not Enabled or (csDesigning in ComponentState) then Exit;
327	>	if FInCreateNew or not Enabled or (csDesigning in ComponentState) then Exit;
328
329		if not FirebirdAPI.IsEmbeddedServer then
330		raise EIBLocalFatalError.Create(sNoEmbeddedServer);
#	Line 362 | Line 359 | begin
359		end;
360
361		procedure TCustomIBLocalDBSupport.SetupFirebirdEnv;
362	+	var sdd: string;
363		begin
364		if sysutils.GetEnvironmentVariable('FIREBIRD') = '' then
365		begin
366		if FirebirdDirectory <> '' then
367		begin
368		if not TUpgradeConfFile.IsAbsolutePath(FirebirdDirectory) then
369	<	FirebirdDirectory := FSharedDataDir + FirebirdDirectory;
369	>	FirebirdDirectory := SharedDataDir + FirebirdDirectory;
370		if FileExists(FirebirdDirectory + DirectorySeparator + 'firebird.conf') then
371		begin
372		SetEnvironmentVariable('FIREBIRD',PChar(FirebirdDirectory));
373		Exit;
374		end;
375		end;
376	<	if FileExists(FSharedDataDir + 'firebird.conf') then
377	<	SetEnvironmentVariable('FIREBIRD',PChar(FSharedDataDir));
376	>	if FileExists(SharedDataDir + 'firebird.conf') then
377	>	begin
378	>	sdd := SharedDataDir;
379	>	SetEnvironmentVariable('FIREBIRD',PChar(sdd));
380	>	end;
381		end;
382		end;
383
#	Line 393 | Line 394 | begin
394		PerformUpgrade(RequiredVersionNo);
395		end;
396
397	+	procedure TCustomIBLocalDBSupport.SaveEvents;
398	+	begin
399	+	FSavedAfterConnect := Database.AfterConnect;
400	+	Database.AfterConnect := nil;
401	+	FSavedAfterDisconnect := Database.AfterDisconnect;
402	+	Database.AfterDisconnect := nil;
403	+	FSavedBeforeConnect := Database.BeforeConnect;
404	+	Database.BeforeConnect := nil;
405	+	FSavedBeforeDisconnect := Database.BeforeDisconnect;
406	+	Database.BeforeDisconnect := nil;
407	+	end;
408	+
409	+	procedure TCustomIBLocalDBSupport.RestoreEvents;
410	+	begin
411	+	Database.AfterConnect := FSavedAfterConnect;
412	+	Database.AfterDisconnect := FSavedAfterDisconnect;
413	+	Database.BeforeConnect := FSavedBeforeConnect;
414	+	Database.BeforeDisconnect := FSavedBeforeDisconnect;
415	+	end;
416	+
417		function TCustomIBLocalDBSupport.AllowInitialisation: boolean;
418		begin
419		Result := true;
#	Line 413 | Line 434 | begin
434		mkdir(DirName);
435		end;
436
437	+	function TCustomIBLocalDBSupport.CreateNewDatabase(DBName: string;
438	+	DBParams: TStrings; DBArchive: string): boolean;
439	+	begin
440	+	Result := false;
441	+	if FInCreateNew then Exit;
442	+	FInCreateNew := true;
443	+	try
444	+	Result := InternalCreateNewDatabase(DBName,DBParams,DBArchive);
445	+	finally
446	+	FInCreateNew := false;
447	+	end;
448	+	end;
449	+
450		procedure TCustomIBLocalDBSupport.Downgrade(DBArchive: string);
451		begin
452		FDownGradeArchive := DBArchive;
#	Line 467 | Line 501 | begin
501		FDatabaseName := ExtractFileName(AValue);
502		end;
503
470	–	class procedure TCustomIBLocalDBSupport.SetDBParams(aService: TIBCustomService;
471	–	DBParams: TStrings);
472	–	var i: integer;
473	–	j: integer;
474	–	k: integer;
475	–	ParamName: string;
476	–	begin
477	–	aService.Params.Clear;
478	–	for i := 0 to DBParams.Count - 1 do
479	–	begin
480	–	ParamName := DBParams[i];
481	–	k := Pos('=',ParamName);
482	–	if k > 0 then system.Delete(ParamName,k,Length(ParamName)-k+1);
483	–	for j := 1 to isc_spb_last_spb_constant do
484	–	if ParamName = SPBConstantNames[j] then
485	–	begin
486	–	aService.Params.Add(DBParams[i]);
487	–	break;
488	–	end;
489	–	end;
490	–	end;
491	–
504		function TCustomIBLocalDBSupport.UpdateVersionNo: boolean;
505		begin
506		Result := assigned(OnGetDBVersionNo);
#	Line 506 | Line 518 | begin
518		FIBBase.AfterDatabaseDisconnect := @OnAfterDatabaseDisconnect;
519		FUpgradeConfFile := 'upgrade.conf';
520		FOptions := [iblAutoUpgrade, iblAllowDowngrade];
509	–	FSharedDataDir := MapSharedDataDir(ExtractFilePath(ParamStr(0)));
521		end;
522
523		destructor TCustomIBLocalDBSupport.Destroy;
#	Line 557 | Line 568 | procedure TCustomIBLocalDBSupport.Perfor
568		if Result = '' then Exit;
569
570		if not TUpgradeConfFile.IsAbsolutePath(Result) then
571	<	Result := FSharedDataDir + Result;
571	>	Result := SharedDataDir + Result;
572		end;
573
574		begin

Diff Legend

–	Removed lines
+	Added lines
<	Changed lines
>	Changed lines