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;
    FInOnCreateDB: boolean;
    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 InOnCreateDB: boolean read FInOnCreateDB;
    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 FInOnCreateDB or not Enabled or (csDesigning in ComponentState) then Exit;

  if not assigned(Database) or not Database.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 FInOnCreateDB then Exit;
  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
 if FInOnCreateDB then Exit;

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