iblocaldb/nongui/IBXCustomIBLocalDBSupport.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 IBXCustomIBLocalDBSupport;

{$mode objfpc}{$H+}

interface

uses
  Classes,  IBDatabase, SysUtils, IBXUpgradeConfFile, ibxscript,
  IB, IBXServices;

type

  { TCustomIBLocalDBSupport Properties

    * Database: reference to the TIBDatabase component for the local database
    * DatabaseName: filename (no path) to use for the Firebird Database file.
    * EmptyDBArchive: filename (optional path) holding the database initialisation archive.
      May either be absolute path or relative to shared data directory.
    * Enabled: when false component does nothing
    * FirebirdDirectory: Full path to directory holding firebird.conf. May either be
      absolute path or relative to the shared data directory. If empty, defaults to  shared data directory.
    * Name: Component Name
    * Options:
              iblAutoUpgrade: Automatically apply upgrade when database schema
                              version is lower than required.
              IblAllowDowngrade: Automatically apply downgrade when available to
                                 schema version compatible with the required version.
              iblQuiet:  true then no database overwrite warnings
    * RequiredVersionNo: The schema version number required by the application.
      TIBLocalDBSupport will normally try to upgrade/downgrade the schema to satisfy
      this requirement.
    * UpgradeConfFile: Path to upgrade configuration file. May either be absolute
      path or relative to the shared data directory.
    * VendorName: Used to construct path to Database Directory.

    Note that at design time paths may use '/' or '\' as directory separator. At
    run time, they must be specified using the appropriate Directory Separator
    for the current platform.

    Events:

    * OnGetDatabaseName: The  database name is normally computed automatically.
      However, this event allows an application to inspect and override the result.
    * OnNewDatabaseOpen: called after the successful initialisation of an empty local  database.
    * OnGetDBVersionNo: called to get the current database schema version number.
      If this event is not handled then schema upgrade/downgrade is never performed.
    * OnGetSharedDataDir: The shared data directory is normally computed automatically.
      However, this event allows an application to inspect and override the result.
      }

  TOnGetDatabaseName = procedure(Sender: TObject; var DBName: string) of object;
  TOnGetDBVersionNo = procedure (Sender: TObject; var VersionNo: integer) of object;
  TOnGetSharedDataDir = procedure(Sender: TObject; var SharedDataDir: string) of object;

  TIBLocalOption = (iblAutoUpgrade, iblAllowDowngrade, iblQuiet);
  TIBLocalOptions = set of TIBLocalOption;

  EIBLocalException = class(Exception);


  { TCustomIBLocalDBSupport }

  TCustomIBLocalDBSupport = class(TComponent)
  private
    { Private declarations }
    FServicesConnection: TIBXServicesConnection;
    FBackupService: TIBXServerSideBackupService;
    FRestoreService: TIBXServerSideRestoreService;
    FActiveDatabasePathName: string;
    FCurrentDBVersionNo: integer;
    FEmptyDBArchive: string;
    FEnabled: boolean;
    FFirebirdDirectory: string;
    FIBBase: TIBBase;
    FDatabaseName: string;
    FOnGetDatabaseName: TOnGetDatabaseName;
    FOnGetDBVersionNo: TOnGetDBVersionNo;
    FOnGetSharedDataDir: TOnGetSharedDataDir;
    FOnNewDatabaseOpen: TNotifyEvent;
    FOptions: TIBLocalOptions;
    FRequiredVersionNo: integer;
    FUpgradeConfFile: string;
    FNewDBCreated: boolean;
    FVendorName: string;
    FInUpgrade: boolean;
    FDownGradeArchive: string;
    FSharedDataDir: string;
    FUpgradeConf: TUpgradeConfFile;
    procedure CheckEnabled;
    function GetDatabase: TIBDatabase;
    function GetSharedDataDir: string;
    procedure SetDatabase(AValue: TIBDatabase);
    function GetDBNameAndPath: string;
    function MapSharedDataDir(aDataDir: string): string;
    procedure OnBeforeDatabaseConnect(Sender: TObject; DBParams: TStrings;
                              var DBName: string; var CreateIfNotExists: boolean);
    procedure OnDatabaseConnected(Sender: TObject);
    procedure OnAfterDatabaseDisconnect(Sender: TObject);
    procedure OnCreateDatabase(Sender: TObject);
    procedure PrepareDBParams(DBParams: TStrings);
    procedure SetDatabaseName(AValue: string);
    procedure SetFirebirdDirectory(AValue: string);
    procedure SetupFirebirdEnv;
    procedure UpgradeCheck;
  protected
    { Protected declarations }
    function AllowInitialisation: boolean; virtual;
    function AllowRestore: boolean; virtual;
    procedure CreateDir(DirName: string);
    function InternalCreateNewDatabase(DBArchive: string): boolean; virtual; abstract;
    procedure Downgrade(DBArchive: string); virtual;
    procedure DowngradeDone;
    procedure Loaded; override;
    function RestoreDatabaseFromArchive(aFilename: string): boolean; virtual; abstract;
    function RunUpgradeDatabase(TargetVersionNo: integer): boolean; virtual; abstract;
    function SaveDatabaseToArchive(aFilename: string): boolean; virtual; abstract;
    function UpdateVersionNo: boolean;
    property DownGradeArchive: string read FDownGradeArchive;
    property UpgradeConf: TUpgradeConfFile read FUpgradeConf;
    property RestoreService: TIBXServerSideRestoreService read FRestoreService;
    property BackupService: TIBXServerSideBackupService read FBackupService;
 public
    { Public declarations }
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;

    function DowngradePending: boolean;

    {NewDatabase: called to reinitialise the local database using the initialisation
     archive. Overwrites existing data so use carefully.}
    procedure NewDatabase;

    {Perform a downgrade to target version if backup archive available.
     Note: normally called from UpgradeCheck if iblAllowDowngrade in Options}
    procedure PerformDowngrade(TargetVersionNo: integer);

    {Perform schema upgrade to target version if upgrade scripts available.
     Note: normally called from UpgradeCheck if iblAllowUpgrade in Options}
    procedure PerformUpgrade(TargetVersionNo: integer);

    {RestoreDatabase: overwrites the existing local database with the specified
     gbak format archive. User is prompted to locate archive if filename empty.}
    procedure RestoreDatabase (filename: string = '');

    {SaveDatabase: Saves the current database into a gbak format archive. User
     is prompted for archive filename if filename empty.}
    procedure SaveDatabase(filename: string = '');

    property ActiveDatabasePathName: string read FActiveDatabasePathName;
    property CurrentDBVersionNo: integer read FCurrentDBVersionNo;
    property SharedDataDir: string read GetSharedDataDir;
    property ServicesConnection: TIBXServicesConnection read FServicesConnection;

    { Likely to be Published declarations }
    property Database: TIBDatabase read GetDatabase write SetDatabase;
    property DatabaseName: string read FDatabaseName write SetDatabaseName;
    property Enabled: boolean read FEnabled write FEnabled default true;
    property EmptyDBArchive: string read FEmptyDBArchive write FEmptyDBArchive;
    property FirebirdDirectory: string read FFirebirdDirectory write SetFirebirdDirectory;
    property Options: TIBLocalOptions read FOptions write FOptions;
    property RequiredVersionNo: integer read FRequiredVersionNo write FRequiredVersionNo;
    property UpgradeConfFile: string read FUpgradeConfFile write FUpgradeConfFile;
    property VendorName: string read FVendorName write FVendorName;
    property OnGetDatabaseName: TOnGetDatabaseName read FOnGetDatabaseName write FOnGetDatabaseName;
    property OnGetDBVersionNo: TOnGetDBVersionNo read FOnGetDBVersionNo write FOnGetDBVersionNo;
    property OnNewDatabaseOpen: TNotifyEvent read FOnNewDatabaseOpen write FOnNewDatabaseOpen;
    property OnGetSharedDataDir: TOnGetSharedDataDir read FOnGetSharedDataDir write FOnGetSharedDataDir;
 end;

  EIBLocalFatalError = class(Exception);

implementation

{$IFDEF Unix} uses initc, regexpr {$ENDIF}
{$IFDEF WINDOWS} uses Windows ,Windirs {$ENDIF}, IBUtils;

resourcestring
  sNoDowngrade = 'Database Schema is %d. Unable to downgrade to version %d';
  sLocalDBDisabled = 'Local Database Access Disabled';
  sEmptyDBArchiveMissing = 'Unable to create database - no empty DB archive specified';
  sEmptyDBArchiveNotFound = 'Unable to create database - empty DB archive file (%s) not found';
  sNoEmbeddedServer = 'Firebird Embedded Server is required but is not installed';
  sCreateFailed = 'Unable to Create Personal Database';

{ TCustomIBLocalDBSupport }


procedure TCustomIBLocalDBSupport.CheckEnabled;
begin
  if not Enabled then
    raise EIBLocalException.Create(sLocalDBDisabled);
end;

function TCustomIBLocalDBSupport.GetDatabase: TIBDatabase;
begin
  Result := FIBBase.Database;
end;

function TCustomIBLocalDBSupport.GetSharedDataDir: string;
begin
  if FSharedDataDir = '' then
    FSharedDataDir := MapSharedDataDir(ExtractFilePath(ParamStr(0)));
  Result := FSharedDataDir;
end;

procedure TCustomIBLocalDBSupport.SetDatabase(AValue: TIBDatabase);
begin
  FIBBase.Database := AValue;
end;

function TCustomIBLocalDBSupport.MapSharedDataDir(aDataDir: string): string;
{$IFDEF UNIX}
var  RegexObj: TRegExpr;
{$ENDIF}
begin
  Result := aDataDir;
{$IFDEF UNIX}

  {Under Unix transform application exe paths that are in installed locations
   e.g. /usr/local/bin to corresponding shared data locations e.g. /usr/local/shared}
  RegexObj := TRegExpr.Create;
  try
    RegexObj.Expression := '^/usr(/local|)/(s|)bin/.*$';
    if RegexObj.Exec(aDataDir) then
      Result := '/usr' + RegexObj.Match[1] + '/share/' + ApplicationName + '/';
  finally
    RegexObj.Free;
  end;
{$ENDIF}
  if assigned (FOnGetSharedDataDir) then
    OnGetSharedDataDir(self,Result);
 {Ensure a trailing separator}
  if (Length(Result) > 0) and (Result[Length(Result)] <> DirectorySeparator) then
    Result := Result + DirectorySeparator;
end;

{$IFDEF Unix}
function setenv(name:Pchar; value:Pchar; replace:integer):integer;cdecl;external clib name 'setenv';
function unsetenv(name:Pchar):integer;cdecl;external clib name 'unsetenv';
function SetEnvironmentVariable(name:PChar; value:PChar):boolean;
// Set environment variable; if empty string given, remove it.
begin
  result:=false; //assume failure
  if value = '' then
  begin
    // Assume user wants to remove variable.
    if unsetenv(name)=0 then result:=true;
  end
  else
  begin
    // Non empty so set the variable
    if setenv(name, value, 1)=0 then result:=true;
  end;
end;
{$ENDIF}

procedure TCustomIBLocalDBSupport.OnBeforeDatabaseConnect(Sender: TObject;
  DBParams: TStrings; var DBName: string; var CreateIfNotExists: boolean);
begin
  if not Enabled or (csDesigning in ComponentState) then Exit;

  if not FirebirdAPI.IsEmbeddedServer then
     raise EIBLocalFatalError.Create(sNoEmbeddedServer);

  DBName := GetDBNameAndPath;
  CreateDir(ExtractFileDir(DBName));
  FActiveDatabasePathName := DBName;
  SetupFirebirdEnv;
  CreateIfNotExists := true;
  PrepareDBParams(DBParams);
end;

procedure TCustomIBLocalDBSupport.OnDatabaseConnected(Sender: TObject);
begin
  if not Enabled or (csDesigning in ComponentState) or
      FInUpgrade then Exit; {Avoids problem if RECONNECT used in script}

  UpgradeCheck;

  if not DowngradePending and FNewDBCreated and assigned(FOnNewDatabaseOpen) then
    OnNewDatabaseOpen(self);
  FNewDBCreated := false;
end;

procedure TCustomIBLocalDBSupport.OnAfterDatabaseDisconnect(Sender: TObject);
begin
  FActiveDatabasePathName := '';
end;

procedure TCustomIBLocalDBSupport.OnCreateDatabase(Sender: TObject);
var DBArchive: string;
begin
 CheckEnabled;
 DBArchive := EmptyDBArchive;
 if DBArchive = '' then
   raise EIBLocalException.Create(sEmptyDBArchiveMissing);

 if not TUpgradeConfFile.IsAbsolutePath(DBArchive) then
   DBArchive := SharedDataDir + DBArchive;

 if not FileExists(DBArchive) then
   raise EIBLocalException.CreateFmt(sEmptyDBArchiveNotFound,[DBArchive]);

 ServicesConnection.ConnectUsing(Database);
 try
   if not InternalCreateNewDatabase(DBArchive) then
   begin
     Database.DropDatabase;
     raise EIBLocalException.Create(sCreateFailed);
   end;
 finally
   ServicesConnection.Connected := false;
 end;
 FNewDBCreated := true;
end;

procedure TCustomIBLocalDBSupport.SetFirebirdDirectory(AValue: string);
begin
  if FFirebirdDirectory = AValue then Exit;
  FFirebirdDirectory := ExcludeTrailingPathDelimiter(AValue);
end;

procedure TCustomIBLocalDBSupport.SetupFirebirdEnv;
var sdd: string;
begin
  if sysutils.GetEnvironmentVariable('FIREBIRD') = '' then
  begin
    if FirebirdDirectory <> '' then
    begin
      if not TUpgradeConfFile.IsAbsolutePath(FirebirdDirectory) then
        FirebirdDirectory := SharedDataDir + FirebirdDirectory;
      if FileExists(FirebirdDirectory + DirectorySeparator + 'firebird.conf') then
      begin
        SetEnvironmentVariable('FIREBIRD',PChar(FirebirdDirectory));
        Exit;
      end;
    end;
    if FileExists(SharedDataDir + 'firebird.conf') then
    begin
      sdd := SharedDataDir;
      SetEnvironmentVariable('FIREBIRD',PChar(sdd));
    end;
  end;
end;

procedure TCustomIBLocalDBSupport.UpgradeCheck;
begin
  if not UpdateVersionNo then
    Exit;

  if (CurrentDBVersionNo > RequiredVersionNo) and (iblAllowDowngrade in FOptions)then
    {Possible recovery after failed upgrade}
    PerformDowngrade(RequiredVersionNo)
  else
  if (CurrentDBVersionNo < RequiredVersionNo) and (iblAutoUpgrade in FOptions) then
    PerformUpgrade(RequiredVersionNo);
end;

function TCustomIBLocalDBSupport.AllowInitialisation: boolean;
begin
  Result := true;
end;

function TCustomIBLocalDBSupport.AllowRestore: boolean;
begin
  Result := true;
end;

procedure TCustomIBLocalDBSupport.CreateDir(DirName: string);
var ParentDirName: string;
begin
  ParentDirName := ExtractFileDir(DirName);
  if not DirectoryExists(ParentDirName) and (ParentDirName <> DirName) then
    CreateDir(ParentDirName);
  if not DirectoryExists(DirName) then
    mkdir(DirName);
end;

procedure TCustomIBLocalDBSupport.Downgrade(DBArchive: string);
begin
  FDownGradeArchive := DBArchive;
end;

procedure TCustomIBLocalDBSupport.DowngradeDone;
begin
  FDownGradeArchive := '';
  UpdateVersionNo;
end;

function TCustomIBLocalDBSupport.GetDBNameAndPath: string;
begin
  Result := DatabaseName;
  if VendorName <> '' then
    Result := VendorName + DirectorySeparator + Result
  else
  if Sysutils.VendorName <> '' then
    Result := SysUtils.VendorName + DirectorySeparator + Result;
  {$IFDEF UNIX}
  Result := GetUserDir + '.' + Result;
  {$ENDIF}
  {$IFDEF WINDOWS}
  Result := GetWindowsSpecialDir(CSIDL_LOCAL_APPDATA) + Result;
  {$ENDIF}
  if assigned(OnGetDatabaseName) then
    OnGetDatabaseName(self,Result);
end;

procedure TCustomIBLocalDBSupport.PrepareDBParams(DBParams: TStrings);

  procedure Remove(s: string);
  var i: integer;
  begin
    i := DBParams.IndexOfName(s);
    if i <> -1 then
      DBParams.Delete(i);
  end;

begin
    Remove('user_name');
    Remove('password');
    DBParams.Values['user_name'] := 'SYSDBA';
    {$IFDEF WINDOWS}
      DBParams.Values['password'] := 'masterkey';
    {$ENDIF}
end;

procedure TCustomIBLocalDBSupport.SetDatabaseName(AValue: string);
begin
  if FDatabaseName = AValue then Exit;
  FDatabaseName := ExtractFileName(AValue);
end;

function TCustomIBLocalDBSupport.UpdateVersionNo: boolean;
begin
  Result := assigned(OnGetDBVersionNo);
  if Result then
    OnGetDBVersionNo(self,FCurrentDBVersionNo); {Update Version No}
end;

constructor TCustomIBLocalDBSupport.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  FEnabled := true;
  FIBBase := TIBBase.Create(self);
  FIBBase.AfterDatabaseConnect := @OnDatabaseConnected;
  FIBBase.BeforeDatabaseConnect := @OnBeforeDatabaseConnect;
  FIBBase.AfterDatabaseDisconnect := @OnAfterDatabaseDisconnect;
  FIBBase.OnCreateDatabase := @OnCreateDatabase;
  FUpgradeConfFile := 'upgrade.conf';
  FOptions := [iblAutoUpgrade, iblAllowDowngrade];
  FServicesConnection := TIBXServicesConnection.Create(self);
  FServicesConnection.LoginPrompt := false;
  FServicesConnection.Params.Values['user_name'] := 'SYSDBA';
  FBackupService := TIBXServerSideBackupService.Create(self);
  FBackupService.ServicesConnection := FServicesConnection;
  FBackupService.Verbose := true;
  FRestoreService := TIBXServerSideRestoreService.Create(self);
  FRestoreService.ServicesConnection := FServicesConnection;
  FRestoreService.Verbose := true;
end;

destructor TCustomIBLocalDBSupport.Destroy;
begin
  if assigned(FIBBase) then FreeAndNil(FIBBase);
  inherited Destroy;
end;

function TCustomIBLocalDBSupport.DowngradePending: boolean;
begin
  Result := FDownGradeArchive <> '';
end;

procedure TCustomIBLocalDBSupport.NewDatabase;
begin
  CheckEnabled;
  if not AllowInitialisation then Exit;

  Database.DropDatabase;
  Database.Connected := true;
end;

procedure TCustomIBLocalDBSupport.PerformDowngrade(TargetVersionNo: integer);
var DBArchive: string;
begin
  DBArchive := ChangeFileExt(ActiveDatabasePathName,'') +
                   '.' + IntToStr(TargetVersionNo) + '.gbk';
  if FileExists(DBArchive) then
    Downgrade(DBArchive)
  else
    raise EIBLocalFatalError.CreateFmt(sNoDowngrade,[CurrentDBVersionNo,TargetVersionNo]);
end;

procedure TCustomIBLocalDBSupport.PerformUpgrade(TargetVersionNo: integer);

  function GetUpgradeConfFile: string;
  begin
    Result := UpgradeConfFile;
    if Result = '' then Exit;

    if not TUpgradeConfFile.IsAbsolutePath(Result) then
      Result := SharedDataDir + Result;
  end;

begin
  if FInUpgrade then Exit;

  FUpgradeConf := TUpgradeConfFile.Create(GetUpgradeConfFile);
  try
    FUpgradeConf.CheckUpgradeAvailable(TargetVersionNo);
    FInUpgrade := true;
    try
      ServicesConnection.ConnectUsing(Database);
      try
        RunUpgradeDatabase(TargetVersionNo);
      finally
        ServicesConnection.Connected := false;
      end;
    finally
      FInUpgrade := false;
    end;
  finally
    FreeAndNil(FUpgradeConf);
  end;
end;

procedure TCustomIBLocalDBSupport.Loaded;
begin
  inherited Loaded;
  if (Database <> nil) and (Database.DatabaseName = '') then
    Database.DatabaseName := ' '; {Avoid CheckDatabaseName Error}
  DoDirSeparators(FEmptyDBArchive);
  DoDirSeparators(FFirebirdDirectory);
  DoDirSeparators(FUpgradeConfFile);
end;

procedure TCustomIBLocalDBSupport.RestoreDatabase(filename: string);
begin
  CheckEnabled;
  if not AllowRestore then Exit;

  ServicesConnection.ConnectUsing(Database);
  Database.Connected := false;
  try
    RestoreDatabaseFromArchive(filename);
  finally
    ServicesConnection.Connected := false;
    Database.Connected := true;
  end;
end;

procedure TCustomIBLocalDBSupport.SaveDatabase(filename: string);
begin
  CheckEnabled;
  ServicesConnection.ConnectUsing(Database);
  try
    SaveDatabaseToArchive(filename);
  finally
    ServicesConnection.Connected := false;
  end;
end;

end.
Revision:	209
Committed:	Wed Mar 14 12:48:51 2018 UTC (6 years, 1 month ago) by tony
Content type:	text/x-pascal
File size:	19929 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 IBXCustomIBLocalDBSupport;
27
28	{$mode objfpc}{$H+}
29
30	interface
31
32	uses
33	Classes, IBDatabase, SysUtils, IBXUpgradeConfFile, ibxscript,
34	IB, IBXServices;
35
36	type
37
38	{ TCustomIBLocalDBSupport Properties
39
40	* Database: reference to the TIBDatabase component for the local database
41	* DatabaseName: filename (no path) to use for the Firebird Database file.
42	* EmptyDBArchive: filename (optional path) holding the database initialisation archive.
43	May either be absolute path or relative to shared data directory.
44	* Enabled: when false component does nothing
45	* FirebirdDirectory: Full path to directory holding firebird.conf. May either be
46	absolute path or relative to the shared data directory. If empty, defaults to shared data directory.
47	* Name: Component Name
48	* Options:
49	iblAutoUpgrade: Automatically apply upgrade when database schema
50	version is lower than required.
51	IblAllowDowngrade: Automatically apply downgrade when available to
52	schema version compatible with the required version.
53	iblQuiet: true then no database overwrite warnings
54	* RequiredVersionNo: The schema version number required by the application.
55	TIBLocalDBSupport will normally try to upgrade/downgrade the schema to satisfy
56	this requirement.
57	* UpgradeConfFile: Path to upgrade configuration file. May either be absolute
58	path or relative to the shared data directory.
59	* VendorName: Used to construct path to Database Directory.
60
61	Note that at design time paths may use '/' or '\' as directory separator. At
62	run time, they must be specified using the appropriate Directory Separator
63	for the current platform.
64
65	Events:
66
67	* OnGetDatabaseName: The database name is normally computed automatically.
68	However, this event allows an application to inspect and override the result.
69	* OnNewDatabaseOpen: called after the successful initialisation of an empty local database.
70	* OnGetDBVersionNo: called to get the current database schema version number.
71	If this event is not handled then schema upgrade/downgrade is never performed.
72	* OnGetSharedDataDir: The shared data directory is normally computed automatically.
73	However, this event allows an application to inspect and override the result.
74	}
75
76	TOnGetDatabaseName = procedure(Sender: TObject; var DBName: string) of object;
77	TOnGetDBVersionNo = procedure (Sender: TObject; var VersionNo: integer) of object;
78	TOnGetSharedDataDir = procedure(Sender: TObject; var SharedDataDir: string) of object;
79
80	TIBLocalOption = (iblAutoUpgrade, iblAllowDowngrade, iblQuiet);
81	TIBLocalOptions = set of TIBLocalOption;
82
83	EIBLocalException = class(Exception);
84
85
86	{ TCustomIBLocalDBSupport }
87
88	TCustomIBLocalDBSupport = class(TComponent)
89	private
90	{ Private declarations }
91	FServicesConnection: TIBXServicesConnection;
92	FBackupService: TIBXServerSideBackupService;
93	FRestoreService: TIBXServerSideRestoreService;
94	FActiveDatabasePathName: string;
95	FCurrentDBVersionNo: integer;
96	FEmptyDBArchive: string;
97	FEnabled: boolean;
98	FFirebirdDirectory: string;
99	FIBBase: TIBBase;
100	FDatabaseName: string;
101	FOnGetDatabaseName: TOnGetDatabaseName;
102	FOnGetDBVersionNo: TOnGetDBVersionNo;
103	FOnGetSharedDataDir: TOnGetSharedDataDir;
104	FOnNewDatabaseOpen: TNotifyEvent;
105	FOptions: TIBLocalOptions;
106	FRequiredVersionNo: integer;
107	FUpgradeConfFile: string;
108	FNewDBCreated: boolean;
109	FVendorName: string;
110	FInUpgrade: boolean;
111	FDownGradeArchive: string;
112	FSharedDataDir: string;
113	FUpgradeConf: TUpgradeConfFile;
114	procedure CheckEnabled;
115	function GetDatabase: TIBDatabase;
116	function GetSharedDataDir: string;
117	procedure SetDatabase(AValue: TIBDatabase);
118	function GetDBNameAndPath: string;
119	function MapSharedDataDir(aDataDir: string): string;
120	procedure OnBeforeDatabaseConnect(Sender: TObject; DBParams: TStrings;
121	var DBName: string; var CreateIfNotExists: boolean);
122	procedure OnDatabaseConnected(Sender: TObject);
123	procedure OnAfterDatabaseDisconnect(Sender: TObject);
124	procedure OnCreateDatabase(Sender: TObject);
125	procedure PrepareDBParams(DBParams: TStrings);
126	procedure SetDatabaseName(AValue: string);
127	procedure SetFirebirdDirectory(AValue: string);
128	procedure SetupFirebirdEnv;
129	procedure UpgradeCheck;
130	protected
131	{ Protected declarations }
132	function AllowInitialisation: boolean; virtual;
133	function AllowRestore: boolean; virtual;
134	procedure CreateDir(DirName: string);
135	function InternalCreateNewDatabase(DBArchive: string): boolean; virtual; abstract;
136	procedure Downgrade(DBArchive: string); virtual;
137	procedure DowngradeDone;
138	procedure Loaded; override;
139	function RestoreDatabaseFromArchive(aFilename: string): boolean; virtual; abstract;
140	function RunUpgradeDatabase(TargetVersionNo: integer): boolean; virtual; abstract;
141	function SaveDatabaseToArchive(aFilename: string): boolean; virtual; abstract;
142	function UpdateVersionNo: boolean;
143	property DownGradeArchive: string read FDownGradeArchive;
144	property UpgradeConf: TUpgradeConfFile read FUpgradeConf;
145	property RestoreService: TIBXServerSideRestoreService read FRestoreService;
146	property BackupService: TIBXServerSideBackupService read FBackupService;
147	public
148	{ Public declarations }
149	constructor Create(aOwner: TComponent); override;
150	destructor Destroy; override;
151
152	function DowngradePending: boolean;
153
154	{NewDatabase: called to reinitialise the local database using the initialisation
155	archive. Overwrites existing data so use carefully.}
156	procedure NewDatabase;
157
158	{Perform a downgrade to target version if backup archive available.
159	Note: normally called from UpgradeCheck if iblAllowDowngrade in Options}
160	procedure PerformDowngrade(TargetVersionNo: integer);
161
162	{Perform schema upgrade to target version if upgrade scripts available.
163	Note: normally called from UpgradeCheck if iblAllowUpgrade in Options}
164	procedure PerformUpgrade(TargetVersionNo: integer);
165
166	{RestoreDatabase: overwrites the existing local database with the specified
167	gbak format archive. User is prompted to locate archive if filename empty.}
168	procedure RestoreDatabase (filename: string = '');
169
170	{SaveDatabase: Saves the current database into a gbak format archive. User
171	is prompted for archive filename if filename empty.}
172	procedure SaveDatabase(filename: string = '');
173
174	property ActiveDatabasePathName: string read FActiveDatabasePathName;
175	property CurrentDBVersionNo: integer read FCurrentDBVersionNo;
176	property SharedDataDir: string read GetSharedDataDir;
177	property ServicesConnection: TIBXServicesConnection read FServicesConnection;
178
179	{ Likely to be Published declarations }
180	property Database: TIBDatabase read GetDatabase write SetDatabase;
181	property DatabaseName: string read FDatabaseName write SetDatabaseName;
182	property Enabled: boolean read FEnabled write FEnabled default true;
183	property EmptyDBArchive: string read FEmptyDBArchive write FEmptyDBArchive;
184	property FirebirdDirectory: string read FFirebirdDirectory write SetFirebirdDirectory;
185	property Options: TIBLocalOptions read FOptions write FOptions;
186	property RequiredVersionNo: integer read FRequiredVersionNo write FRequiredVersionNo;
187	property UpgradeConfFile: string read FUpgradeConfFile write FUpgradeConfFile;
188	property VendorName: string read FVendorName write FVendorName;
189	property OnGetDatabaseName: TOnGetDatabaseName read FOnGetDatabaseName write FOnGetDatabaseName;
190	property OnGetDBVersionNo: TOnGetDBVersionNo read FOnGetDBVersionNo write FOnGetDBVersionNo;
191	property OnNewDatabaseOpen: TNotifyEvent read FOnNewDatabaseOpen write FOnNewDatabaseOpen;
192	property OnGetSharedDataDir: TOnGetSharedDataDir read FOnGetSharedDataDir write FOnGetSharedDataDir;
193	end;
194
195	EIBLocalFatalError = class(Exception);
196
197	implementation
198
199	{$IFDEF Unix} uses initc, regexpr {$ENDIF}
200	{$IFDEF WINDOWS} uses Windows ,Windirs {$ENDIF}, IBUtils;
201
202	resourcestring
203	sNoDowngrade = 'Database Schema is %d. Unable to downgrade to version %d';
204	sLocalDBDisabled = 'Local Database Access Disabled';
205	sEmptyDBArchiveMissing = 'Unable to create database - no empty DB archive specified';
206	sEmptyDBArchiveNotFound = 'Unable to create database - empty DB archive file (%s) not found';
207	sNoEmbeddedServer = 'Firebird Embedded Server is required but is not installed';
208	sCreateFailed = 'Unable to Create Personal Database';
209
210	{ TCustomIBLocalDBSupport }
211
212
213	procedure TCustomIBLocalDBSupport.CheckEnabled;
214	begin
215	if not Enabled then
216	raise EIBLocalException.Create(sLocalDBDisabled);
217	end;
218
219	function TCustomIBLocalDBSupport.GetDatabase: TIBDatabase;
220	begin
221	Result := FIBBase.Database;
222	end;
223
224	function TCustomIBLocalDBSupport.GetSharedDataDir: string;
225	begin
226	if FSharedDataDir = '' then
227	FSharedDataDir := MapSharedDataDir(ExtractFilePath(ParamStr(0)));
228	Result := FSharedDataDir;
229	end;
230
231	procedure TCustomIBLocalDBSupport.SetDatabase(AValue: TIBDatabase);
232	begin
233	FIBBase.Database := AValue;
234	end;
235
236	function TCustomIBLocalDBSupport.MapSharedDataDir(aDataDir: string): string;
237	{$IFDEF UNIX}
238	var RegexObj: TRegExpr;
239	{$ENDIF}
240	begin
241	Result := aDataDir;
242	{$IFDEF UNIX}
243
244	{Under Unix transform application exe paths that are in installed locations
245	e.g. /usr/local/bin to corresponding shared data locations e.g. /usr/local/shared}
246	RegexObj := TRegExpr.Create;
247	try
248	RegexObj.Expression := '^/usr(/local\|)/(s\|)bin/.*$';
249	if RegexObj.Exec(aDataDir) then
250	Result := '/usr' + RegexObj.Match[1] + '/share/' + ApplicationName + '/';
251	finally
252	RegexObj.Free;
253	end;
254	{$ENDIF}
255	if assigned (FOnGetSharedDataDir) then
256	OnGetSharedDataDir(self,Result);
257	{Ensure a trailing separator}
258	if (Length(Result) > 0) and (Result[Length(Result)] <> DirectorySeparator) then
259	Result := Result + DirectorySeparator;
260	end;
261
262	{$IFDEF Unix}
263	function setenv(name:Pchar; value:Pchar; replace:integer):integer;cdecl;external clib name 'setenv';
264	function unsetenv(name:Pchar):integer;cdecl;external clib name 'unsetenv';
265	function SetEnvironmentVariable(name:PChar; value:PChar):boolean;
266	// Set environment variable; if empty string given, remove it.
267	begin
268	result:=false; //assume failure
269	if value = '' then
270	begin
271	// Assume user wants to remove variable.
272	if unsetenv(name)=0 then result:=true;
273	end
274	else
275	begin
276	// Non empty so set the variable
277	if setenv(name, value, 1)=0 then result:=true;
278	end;
279	end;
280	{$ENDIF}
281
282	procedure TCustomIBLocalDBSupport.OnBeforeDatabaseConnect(Sender: TObject;
283	DBParams: TStrings; var DBName: string; var CreateIfNotExists: boolean);
284	begin
285	if not Enabled or (csDesigning in ComponentState) then Exit;
286
287	if not FirebirdAPI.IsEmbeddedServer then
288	raise EIBLocalFatalError.Create(sNoEmbeddedServer);
289
290	DBName := GetDBNameAndPath;
291	CreateDir(ExtractFileDir(DBName));
292	FActiveDatabasePathName := DBName;
293	SetupFirebirdEnv;
294	CreateIfNotExists := true;
295	PrepareDBParams(DBParams);
296	end;
297
298	procedure TCustomIBLocalDBSupport.OnDatabaseConnected(Sender: TObject);
299	begin
300	if not Enabled or (csDesigning in ComponentState) or
301	FInUpgrade then Exit; {Avoids problem if RECONNECT used in script}
302
303	UpgradeCheck;
304
305	if not DowngradePending and FNewDBCreated and assigned(FOnNewDatabaseOpen) then
306	OnNewDatabaseOpen(self);
307	FNewDBCreated := false;
308	end;
309
310	procedure TCustomIBLocalDBSupport.OnAfterDatabaseDisconnect(Sender: TObject);
311	begin
312	FActiveDatabasePathName := '';
313	end;
314
315	procedure TCustomIBLocalDBSupport.OnCreateDatabase(Sender: TObject);
316	var DBArchive: string;
317	begin
318	CheckEnabled;
319	DBArchive := EmptyDBArchive;
320	if DBArchive = '' then
321	raise EIBLocalException.Create(sEmptyDBArchiveMissing);
322
323	if not TUpgradeConfFile.IsAbsolutePath(DBArchive) then
324	DBArchive := SharedDataDir + DBArchive;
325
326	if not FileExists(DBArchive) then
327	raise EIBLocalException.CreateFmt(sEmptyDBArchiveNotFound,[DBArchive]);
328
329	ServicesConnection.ConnectUsing(Database);
330	try
331	if not InternalCreateNewDatabase(DBArchive) then
332	begin
333	Database.DropDatabase;
334	raise EIBLocalException.Create(sCreateFailed);
335	end;
336	finally
337	ServicesConnection.Connected := false;
338	end;
339	FNewDBCreated := true;
340	end;
341
342	procedure TCustomIBLocalDBSupport.SetFirebirdDirectory(AValue: string);
343	begin
344	if FFirebirdDirectory = AValue then Exit;
345	FFirebirdDirectory := ExcludeTrailingPathDelimiter(AValue);
346	end;
347
348	procedure TCustomIBLocalDBSupport.SetupFirebirdEnv;
349	var sdd: string;
350	begin
351	if sysutils.GetEnvironmentVariable('FIREBIRD') = '' then
352	begin
353	if FirebirdDirectory <> '' then
354	begin
355	if not TUpgradeConfFile.IsAbsolutePath(FirebirdDirectory) then
356	FirebirdDirectory := SharedDataDir + FirebirdDirectory;
357	if FileExists(FirebirdDirectory + DirectorySeparator + 'firebird.conf') then
358	begin
359	SetEnvironmentVariable('FIREBIRD',PChar(FirebirdDirectory));
360	Exit;
361	end;
362	end;
363	if FileExists(SharedDataDir + 'firebird.conf') then
364	begin
365	sdd := SharedDataDir;
366	SetEnvironmentVariable('FIREBIRD',PChar(sdd));
367	end;
368	end;
369	end;
370
371	procedure TCustomIBLocalDBSupport.UpgradeCheck;
372	begin
373	if not UpdateVersionNo then
374	Exit;
375
376	if (CurrentDBVersionNo > RequiredVersionNo) and (iblAllowDowngrade in FOptions)then
377	{Possible recovery after failed upgrade}
378	PerformDowngrade(RequiredVersionNo)
379	else
380	if (CurrentDBVersionNo < RequiredVersionNo) and (iblAutoUpgrade in FOptions) then
381	PerformUpgrade(RequiredVersionNo);
382	end;
383
384	function TCustomIBLocalDBSupport.AllowInitialisation: boolean;
385	begin
386	Result := true;
387	end;
388
389	function TCustomIBLocalDBSupport.AllowRestore: boolean;
390	begin
391	Result := true;
392	end;
393
394	procedure TCustomIBLocalDBSupport.CreateDir(DirName: string);
395	var ParentDirName: string;
396	begin
397	ParentDirName := ExtractFileDir(DirName);
398	if not DirectoryExists(ParentDirName) and (ParentDirName <> DirName) then
399	CreateDir(ParentDirName);
400	if not DirectoryExists(DirName) then
401	mkdir(DirName);
402	end;
403
404	procedure TCustomIBLocalDBSupport.Downgrade(DBArchive: string);
405	begin
406	FDownGradeArchive := DBArchive;
407	end;
408
409	procedure TCustomIBLocalDBSupport.DowngradeDone;
410	begin
411	FDownGradeArchive := '';
412	UpdateVersionNo;
413	end;
414
415	function TCustomIBLocalDBSupport.GetDBNameAndPath: string;
416	begin
417	Result := DatabaseName;
418	if VendorName <> '' then
419	Result := VendorName + DirectorySeparator + Result
420	else
421	if Sysutils.VendorName <> '' then
422	Result := SysUtils.VendorName + DirectorySeparator + Result;
423	{$IFDEF UNIX}
424	Result := GetUserDir + '.' + Result;
425	{$ENDIF}
426	{$IFDEF WINDOWS}
427	Result := GetWindowsSpecialDir(CSIDL_LOCAL_APPDATA) + Result;
428	{$ENDIF}
429	if assigned(OnGetDatabaseName) then
430	OnGetDatabaseName(self,Result);
431	end;
432
433	procedure TCustomIBLocalDBSupport.PrepareDBParams(DBParams: TStrings);
434
435	procedure Remove(s: string);
436	var i: integer;
437	begin
438	i := DBParams.IndexOfName(s);
439	if i <> -1 then
440	DBParams.Delete(i);
441	end;
442
443	begin
444	Remove('user_name');
445	Remove('password');
446	DBParams.Values['user_name'] := 'SYSDBA';
447	{$IFDEF WINDOWS}
448	DBParams.Values['password'] := 'masterkey';
449	{$ENDIF}
450	end;
451
452	procedure TCustomIBLocalDBSupport.SetDatabaseName(AValue: string);
453	begin
454	if FDatabaseName = AValue then Exit;
455	FDatabaseName := ExtractFileName(AValue);
456	end;
457
458	function TCustomIBLocalDBSupport.UpdateVersionNo: boolean;
459	begin
460	Result := assigned(OnGetDBVersionNo);
461	if Result then
462	OnGetDBVersionNo(self,FCurrentDBVersionNo); {Update Version No}
463	end;
464
465	constructor TCustomIBLocalDBSupport.Create(aOwner: TComponent);
466	begin
467	inherited Create(aOwner);
468	FEnabled := true;
469	FIBBase := TIBBase.Create(self);
470	FIBBase.AfterDatabaseConnect := @OnDatabaseConnected;
471	FIBBase.BeforeDatabaseConnect := @OnBeforeDatabaseConnect;
472	FIBBase.AfterDatabaseDisconnect := @OnAfterDatabaseDisconnect;
473	FIBBase.OnCreateDatabase := @OnCreateDatabase;
474	FUpgradeConfFile := 'upgrade.conf';
475	FOptions := [iblAutoUpgrade, iblAllowDowngrade];
476	FServicesConnection := TIBXServicesConnection.Create(self);
477	FServicesConnection.LoginPrompt := false;
478	FServicesConnection.Params.Values['user_name'] := 'SYSDBA';
479	FBackupService := TIBXServerSideBackupService.Create(self);
480	FBackupService.ServicesConnection := FServicesConnection;
481	FBackupService.Verbose := true;
482	FRestoreService := TIBXServerSideRestoreService.Create(self);
483	FRestoreService.ServicesConnection := FServicesConnection;
484	FRestoreService.Verbose := true;
485	end;
486
487	destructor TCustomIBLocalDBSupport.Destroy;
488	begin
489	if assigned(FIBBase) then FreeAndNil(FIBBase);
490	inherited Destroy;
491	end;
492
493	function TCustomIBLocalDBSupport.DowngradePending: boolean;
494	begin
495	Result := FDownGradeArchive <> '';
496	end;
497
498	procedure TCustomIBLocalDBSupport.NewDatabase;
499	begin
500	CheckEnabled;
501	if not AllowInitialisation then Exit;
502
503	Database.DropDatabase;
504	Database.Connected := true;
505	end;
506
507	procedure TCustomIBLocalDBSupport.PerformDowngrade(TargetVersionNo: integer);
508	var DBArchive: string;
509	begin
510	DBArchive := ChangeFileExt(ActiveDatabasePathName,'') +
511	'.' + IntToStr(TargetVersionNo) + '.gbk';
512	if FileExists(DBArchive) then
513	Downgrade(DBArchive)
514	else
515	raise EIBLocalFatalError.CreateFmt(sNoDowngrade,[CurrentDBVersionNo,TargetVersionNo]);
516	end;
517
518	procedure TCustomIBLocalDBSupport.PerformUpgrade(TargetVersionNo: integer);
519
520	function GetUpgradeConfFile: string;
521	begin
522	Result := UpgradeConfFile;
523	if Result = '' then Exit;
524
525	if not TUpgradeConfFile.IsAbsolutePath(Result) then
526	Result := SharedDataDir + Result;
527	end;
528
529	begin
530	if FInUpgrade then Exit;
531
532	FUpgradeConf := TUpgradeConfFile.Create(GetUpgradeConfFile);
533	try
534	FUpgradeConf.CheckUpgradeAvailable(TargetVersionNo);
535	FInUpgrade := true;
536	try
537	ServicesConnection.ConnectUsing(Database);
538	try
539	RunUpgradeDatabase(TargetVersionNo);
540	finally
541	ServicesConnection.Connected := false;
542	end;
543	finally
544	FInUpgrade := false;
545	end;
546	finally
547	FreeAndNil(FUpgradeConf);
548	end;
549	end;
550
551	procedure TCustomIBLocalDBSupport.Loaded;
552	begin
553	inherited Loaded;
554	if (Database <> nil) and (Database.DatabaseName = '') then
555	Database.DatabaseName := ' '; {Avoid CheckDatabaseName Error}
556	DoDirSeparators(FEmptyDBArchive);
557	DoDirSeparators(FFirebirdDirectory);
558	DoDirSeparators(FUpgradeConfFile);
559	end;
560
561	procedure TCustomIBLocalDBSupport.RestoreDatabase(filename: string);
562	begin
563	CheckEnabled;
564	if not AllowRestore then Exit;
565
566	ServicesConnection.ConnectUsing(Database);
567	Database.Connected := false;
568	try
569	RestoreDatabaseFromArchive(filename);
570	finally
571	ServicesConnection.Connected := false;
572	Database.Connected := true;
573	end;
574	end;
575
576	procedure TCustomIBLocalDBSupport.SaveDatabase(filename: string);
577	begin
578	CheckEnabled;
579	ServicesConnection.ConnectUsing(Database);
580	try
581	SaveDatabaseToArchive(filename);
582	finally
583	ServicesConnection.Connected := false;
584	end;
585	end;
586
587	end.