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
#	User	Rev	Content
1	tony	209	(*
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.