fbintf/client/FBClientAPI.pas

(*
 *  Firebird Interface (fbintf). The fbintf components provide a set of
 *  Pascal language bindings for the Firebird API. Although predominantly
 *  a new development they include source code taken from IBX and may be
 *  considered a derived product. This software thus also includes the copyright
 *  notice and license conditions from IBX.
 *
 *  Except for those parts dervied from IBX, 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) 2016 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*)
{************************************************************************}
{                                                                        }
{       Borland Delphi Visual Component Library                          }
{       InterBase Express core components                                }
{                                                                        }
{       Copyright (c) 1998-2000 Inprise Corporation                      }
{                                                                        }
{    InterBase Express is based in part on the product                   }
{    Free IB Components, written by Gregory H. Deatz for                 }
{    Hoagland, Longo, Moran, Dunst & Doukas Company.                     }
{    Free IB Components is used under license.                           }
{                                                                        }
{    The contents of this file are subject to the InterBase              }
{    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 at http://www.Inprise.com/IPL.html }
{    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 Original Code was created by InterBase Software Corporation     }
{       and its successors.                                              }
{    Portions created by Inprise Corporation are Copyright (C) Inprise   }
{       Corporation. All Rights Reserved.                                }
{    Contributor(s): Jeff Overcash                                       }
{                                                                        }
{    IBX For Lazarus (Firebird Express)                                  }
{    Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
{    Portions created by MWA Software are copyright McCallum Whyman      }
{    Associates Ltd 2011 - 2015                                                }
{                                                                        }
{************************************************************************}
unit FBClientAPI;
{$IFDEF MSWINDOWS} 
{$DEFINE WINDOWS} 
{$ENDIF}

{$IFDEF FPC}
{$mode delphi}
{$codepage UTF8}
{$interfaces COM}
{$ENDIF}

interface

uses
  Classes,
    {$IFDEF WINDOWS}Windows, {$ENDIF}
    {$IFDEF FPC} Dynlibs, {$ENDIF}
   IB, IBHeader, FBActivityMonitor, FBMessages, IBExternals, FmtBCD;

{For Linux see result of GetFirebirdLibList method}
{$IFDEF DARWIN}
const
FIREBIRD_SO2 = 'libfbclient.dylib';
{$ENDIF}
{$IFDEF WINDOWS}
const
IBASE_DLL = 'gds32.dll';
FIREBIRD_CLIENT = 'fbclient.dll'; {do not localize}
FIREBIRD_EMBEDDED = 'fbembed.dll';
{$ENDIF}

const
  {fb_shutdown reasons}
  fb_shutrsn_svc_stopped          = -1;
  fb_shutrsn_no_connection        = -2;
  fb_shutrsn_app_stopped          = -3;
  fb_shutrsn_signal               = -5;
  fb_shutrsn_services             = -6;
  fb_shutrsn_exit_called          = -7;

const
    DefaultTimeZoneFile = '/etc/timezone';

const
  IBLocalBufferLength = 512;
  IBBigLocalBufferLength = IBLocalBufferLength * 2;
  IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;

type
  TStatusVector              = array[0..19] of NativeInt;
  PStatusVector              = ^TStatusVector;

  TFBClientAPI = class;

  { TFBStatus }

  TFBStatus = class(TFBInterfacedObject)
  private
    FIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
  protected
    FOwner: TFBClientAPI;
  public
    constructor Create(aOwner: TFBClientAPI);
    function StatusVector: PStatusVector; virtual; abstract;

    {IStatus}
    function GetIBErrorCode: Long;
    function Getsqlcode: Long;
    function GetMessage: AnsiString;
    function CheckStatusVector(ErrorCodes: array of TFBStatusCode): Boolean;
    function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
    procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
  end;

  { TFBLibrary }

  TFBLibrary = class(TFBInterfacedObject,IFirebirdLibrary)
  private
    class var FEnvSetupDone: boolean;
    class var FLibraryList: array of IFirebirdLibrary;
  private
    FFirebirdAPI: IFirebirdAPI;
    FRequestedLibName: string;
    function LoadIBLibrary: boolean;
  protected
    FFBLibraryName: string;
    FIBLibrary: TLibHandle;
    procedure FreeFBLibrary;
    function GetOverrideLibName: string;
    class procedure SetupEnvironment;
  protected
    function GetFirebird3API: IFirebirdAPI; virtual; abstract;
    function GetLegacyFirebirdAPI: IFirebirdAPI; virtual; abstract;
  public
    constructor Create(aLibPathName: string='');
    destructor Destroy; override;
    class function GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
    class procedure FreeLibraries;
    function SameLibrary(aLibName: string): boolean;

  public
    {IFirebirdLibrary}
    function GetHandle: TLibHandle;
    function GetLibraryName: string;
    function GetLibraryFilePath: string;
    function GetFirebirdAPI: IFirebirdAPI;
    property IBLibrary: TLibHandle read FIBLibrary;
  end;

  { TFBClientAPI }

  TFBClientAPI = class(TFBInterfacedObject)
  private
    FLocalTimeZoneName: AnsiString; {Informal Time Zone Name from tzname e.g. GMT or BST}
    FTZDataTimeZoneID: AnsiString; {TZData DB ID e.g. Europe/London}
    FLocalTimeOffset: integer;
    FIsDaylightSavingsTime: boolean;
    class var FIBCS: TRTLCriticalSection;
    function FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
    procedure GetTZDataSettings;
  protected
    FFBLibrary: TFBLibrary;
    function GetProcAddr(ProcName: PAnsiChar): Pointer;

  protected type
    Tfb_shutdown = function (timeout: uint;
                                 const reason: int): int;
                   {$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
  protected
    {FB Shutdown API}
    fb_shutdown: Tfb_shutdown;

  public
    {Taken from legacy API}
    isc_sqlcode: Tisc_sqlcode;
    isc_sql_interprete: Tisc_sql_interprete;
    isc_event_counts: Tisc_event_counts;
    isc_event_block: Tisc_event_block;
    isc_free: Tisc_free;

    constructor Create(aFBLibrary: TFBLibrary);
    procedure IBAlloc(var P; OldSize, NewSize: Integer);
    procedure IBDataBaseError;
    function LoadInterface: boolean; virtual;
    procedure FBShutdown; virtual;
    function GetAPI: IFirebirdAPI; virtual; abstract;
    {$IFDEF UNIX}
    function GetFirebirdLibList: string; virtual; abstract;
    {$ENDIF}
    function HasDecFloatSupport: boolean;
    function HasInt128Support: boolean; virtual;
    function HasLocalTZDB: boolean; virtual;
    function HasExtendedTZSupport: boolean; virtual;
    function HasTimeZoneSupport: boolean; virtual;

  public
    property LocalTimeZoneName: AnsiString read FLocalTimeZoneName;
    property TZDataTimeZoneID: AnsiString read FTZDataTimeZoneID;
    property LocalTimeOffset: integer read FLocalTimeOffset;
  public
    {Encode/Decode}
    procedure EncodeInteger(aValue: integer; len: integer; buffer: PByte);
    function DecodeInteger(bufptr: PByte; len: short): integer; virtual; abstract;
    procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte);  virtual; abstract;
    function SQLDecodeDate(byfptr: PByte): TDateTime;  virtual; abstract;
    procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte);  virtual; abstract;
    function SQLDecodeTime(bufptr: PByte): TDateTime;  virtual; abstract;
    procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte); virtual; abstract;
    function  SQLDecodeDateTime(bufptr: PByte): TDateTime; virtual; abstract;
    function FormatStatus(Status: TFBStatus): AnsiString; virtual; abstract;
    function Int128ToStr(bufptr: PByte; scale: integer): AnsiString; virtual;
    procedure StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte);
      virtual;
    procedure SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal; bufptr: PByte); virtual;
    function SQLDecFloatDecode(SQLType: cardinal;  bufptr: PByte): tBCD; virtual;

    {IFirebirdAPI}
    function GetStatus: IStatus; virtual; abstract;
    function IsLibraryLoaded: boolean;
    function IsEmbeddedServer: boolean; virtual; abstract;
    function GetFBLibrary: IFirebirdLibrary;
    function GetImplementationVersion: AnsiString;
    function GetClientMajor: integer;  virtual; abstract;
    function GetClientMinor: integer;  virtual; abstract;
end;

implementation

uses IBUtils, Registry,
  {$IFDEF Unix} unix, initc, dl, {$ENDIF}
{$IFDEF FPC}
{$IFDEF WINDOWS }
WinDirs,
{$ENDIF}
{$ELSE}
 ShlObj,
{$ENDIF}
SysUtils;

{$IFDEF UNIX}
{$I 'include/uloadlibrary.inc'}
{$ELSE}
{$I 'include/wloadlibrary.inc'}
{$ENDIF}


{ TFBLibrary }

function TFBLibrary.GetOverrideLibName: string;
begin
  Result := FFBLibraryName;
  if (Result = '') and AllowUseOfFBLIB then
    Result := GetEnvironmentVariable('FBLIB');
  if Result = '' then
  begin
    if assigned(OnGetLibraryName) then
      OnGetLibraryName(Result)
  end;
end;

procedure TFBLibrary.FreeFBLibrary;
begin
  (FFirebirdAPI as TFBClientAPI).FBShutdown;
  if FIBLibrary <> NilHandle then
    FreeLibrary(FIBLibrary);
  FIBLibrary := NilHandle;
  FFBLibraryName := '';
end;

function TFBLibrary.GetLibraryName: string;
begin
  Result := ExtractFileName(FFBLibraryName);
end;

function TFBLibrary.GetFirebirdAPI: IFirebirdAPI;
begin
  Result := FFirebirdAPI;
end;

constructor TFBLibrary.Create(aLibPathName: string);
begin
  inherited Create;
  SetupEnvironment;
  FFBLibraryName := aLibPathName;
  FIBLibrary := NilHandle;
  FFirebirdAPI := GetFirebird3API;
  FRequestedLibName := aLibPathName;
  if aLibPathName <> '' then
  begin
    SetLength(FLibraryList,Length(FLibraryList)+1);
    FLibraryList[Length(FLibraryList)-1] := self;
  end;
  if FFirebirdAPI <> nil then
  begin
    {First try Firebird 3}
    if not LoadIBLibrary or not (FFirebirdAPI as TFBClientAPI).LoadInterface then
      FFirebirdAPI := nil;
  end;

  if FFirebirdAPI = nil then
  begin
    {now try Firebird 2.5. Under Unix we need to reload the library in case we
     are to use the embedded library}
    FFirebirdAPI := GetLegacyFirebirdAPI;
    if FFirebirdAPI <> nil then
    begin
      {$IFDEF UNIX}
      FreeFBLibrary;
      {$ENDIF}
      if not LoadIBLibrary or not (FFirebirdAPI as TFBClientAPI).LoadInterface then
        FFirebirdAPI := nil;
    end;
  end;
  {Note: FFirebirdAPI will be set to nil if the Firebird API fails to load}
end;

destructor TFBLibrary.Destroy;
begin
  FreeFBLibrary;
  FFirebirdAPI := nil;
  inherited Destroy;
end;

class function TFBLibrary.GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
var i: integer;
begin
  Result := nil;
  if aLibPathName <> '' then
  begin
    for i := 0 to Length(FLibraryList) - 1 do
    begin
      if (FLibraryList[i] as TFBLibrary).SameLibrary(aLibPathName) then
      begin
        Result := FLibraryList[i];
        Exit;
      end;
    end;
    Result := Create(aLibPathName);
  end;

end;

class procedure TFBLibrary.FreeLibraries;
var i: integer;
begin
  for i := 0 to Length(FLibraryList) - 1 do
    FLibraryList[i] := nil;
  SetLength(FLibraryList,0);
end;

function TFBLibrary.SameLibrary(aLibName: string): boolean;
begin
  Result := FRequestedLibName = aLibName;
end;

function TFBLibrary.GetHandle: TLibHandle;
begin
  Result := FIBLibrary;
end;

{ TFBClientAPI }

constructor TFBClientAPI.Create(aFBLibrary: TFBLibrary);
begin
  inherited Create;
  FFBLibrary := aFBLibrary;
  GetTZDataSettings;
end;

procedure TFBClientAPI.IBAlloc(var P; OldSize, NewSize: Integer);
var
  i: Integer;
begin
  ReallocMem(Pointer(P), NewSize);
  for i := OldSize to NewSize - 1 do PAnsiChar(P)[i] := #0;
end;

procedure TFBClientAPI.IBDataBaseError;
begin
  raise EIBInterBaseError.Create(GetStatus);
end;

procedure TFBClientAPI.EncodeInteger(aValue: integer; len: integer; buffer: PByte);
begin
  while len > 0 do
  begin
    buffer^ := aValue and $FF;
    Inc(buffer);
    Dec(len);
    aValue := aValue shr 8;
  end;
end;

function TFBClientAPI.Int128ToStr(bufptr: PByte; scale: integer): AnsiString;
begin
  if not HasInt128Support then
    IBError(ibxeNotSupported,[]);
end;

procedure TFBClientAPI.StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte);
begin
  if not HasInt128Support then
    IBError(ibxeNotSupported,[]);
end;

procedure TFBClientAPI.SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal;
  bufptr: PByte);
begin
  if not HasDecFloatSupport then
    IBError(ibxeNotSupported,[]);
end;

function TFBClientAPI.SQLDecFloatDecode(SQLType: cardinal; bufptr: PByte): tBCD;
begin
  if not HasDecFloatSupport then
    IBError(ibxeNotSupported,[]);
end;

function TFBClientAPI.IsLibraryLoaded: boolean;
begin
  Result := FFBLibrary.IBLibrary <> NilHandle;
end;

function TFBClientAPI.GetFBLibrary: IFirebirdLibrary;
begin
  Result := FFBLibrary;
end;

function TFBClientAPI.FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
begin
  {aDate/aTime are in TTimestamp format but aTime is decimilliseconds}
  aDate := aDate - DateDelta;
  if aDate < 0 then
    Result := trunc(aDate) - abs(frac(aTime / (MSecsPerDay*10)))
  else
    Result := trunc(aDate) + abs(frac(aTime / (MSecsPerDay*10)));
end;

{$IFDEF UNIX}
procedure TFBClientAPI.GetTZDataSettings;
var S: TStringList;
begin
  FLocalTimeOffset := GetLocalTimeOffset;
  FLocalTimeZoneName := strpas(tzname[tzdaylight]);
  FIsDaylightSavingsTime := tzdaylight;
  if FileExists(DefaultTimeZoneFile) then
  begin
    S := TStringList.Create;
    try
      S.LoadFromFile(DefaultTimeZoneFile);
      if S.Count > 0 then
        FTZDataTimeZoneID := S[0];
    finally
      S.Free;
    end;
  end;
end;
{$ENDIF}

{$IFDEF WINDOWS}
procedure TFBClientAPI.GetTZDataSettings;
var TZInfo: TTimeZoneInformation;
begin
  FIsDaylightSavingsTime := false;
  {is there any way of working out the default TZData DB time zone ID under Windows?}
  case GetTimeZoneInformation(TZInfo) of
    TIME_ZONE_ID_UNKNOWN:
      begin
        FLocalTimeZoneName := '';
        FLocalTimeOffset := 0;
      end;
    TIME_ZONE_ID_STANDARD:
      begin
        FLocalTimeZoneName := strpas(PWideChar(@TZInfo.StandardName));
        FLocalTimeOffset := TZInfo.Bias;
      end;
    TIME_ZONE_ID_DAYLIGHT:
      begin
        FLocalTimeZoneName := strpas(PWideChar(@TZInfo.DaylightName));
        FLocalTimeOffset := TZInfo.DayLightBias;
        FIsDaylightSavingsTime := true;
      end;
  end;
end;
{$ENDIF}

function TFBClientAPI.GetProcAddr(ProcName: PAnsiChar): Pointer;
begin
  Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
  if not Assigned(Result) then
    raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
end;

function TFBClientAPI.HasDecFloatSupport: boolean;
begin
  Result := GetClientMajor >= 4;
end;

function TFBClientAPI.HasInt128Support: boolean;
begin
  Result := false;
end;

function TFBClientAPI.HasLocalTZDB: boolean;
begin
  Result := false;
end;

function TFBClientAPI.HasExtendedTZSupport: boolean;
begin
  Result := false;
end;

function TFBClientAPI.HasTimeZoneSupport: boolean;
begin
  Result := false;
end;

function TFBClientAPI.GetImplementationVersion: AnsiString;
begin
  Result := Format('%d.%d',[GetClientMajor,GetClientMinor]);
end;

function TFBClientAPI.LoadInterface: boolean;
begin
  isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
  isc_sql_interprete := GetProcAddr('isc_sql_interprete'); {do not localize}
  isc_event_counts := GetProcAddr('isc_event_counts'); {do not localize}
  isc_event_block := GetProcAddr('isc_event_block'); {do not localize}
  isc_free := GetProcAddr('isc_free'); {do not localize}
  fb_shutdown := GetProcAddr('fb_shutdown'); {do not localize}
  Result := assigned(isc_free);
end;

procedure TFBClientAPI.FBShutdown;
begin
  if assigned(fb_shutdown) then
    fb_shutdown(0,fb_shutrsn_exit_called);
end;

{ TFBStatus }

constructor TFBStatus.Create(aOwner: TFBClientAPI);
begin
  inherited Create;
  FOwner := aOwner;
  FIBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
end;

function TFBStatus.GetIBErrorCode: Long;
begin
  Result := StatusVector^[1];
end;

function TFBStatus.Getsqlcode: Long;
begin
  with FOwner do
    Result := isc_sqlcode(PISC_STATUS(StatusVector));
end;

function TFBStatus.GetMessage: AnsiString;
var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
    IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
    sqlcode: Long;
begin
  Result := '';
  IBDataBaseErrorMessages := FIBDataBaseErrorMessages;
  sqlcode := Getsqlcode;
  if (ShowSQLCode in IBDataBaseErrorMessages) then
    Result := Result + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}

  Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
  if (ShowSQLMessage in IBDataBaseErrorMessages) then
  begin
    with FOwner do
      isc_sql_interprete(sqlcode, local_buffer, sizeof(local_buffer));
    if (ShowSQLCode in FIBDataBaseErrorMessages) then
      Result := Result + CRLF;
    Result := Result + strpas(local_buffer);
  end;

  if (ShowIBMessage in IBDataBaseErrorMessages) then
  begin
    if (ShowSQLCode in IBDataBaseErrorMessages) or
       (ShowSQLMessage in IBDataBaseErrorMessages) then
      Result := Result + LineEnding;
    Result := Result + FOwner.FormatStatus(self);
  end;
  if (Result <> '') and (Result[Length(Result)] = '.') then
    Delete(Result, Length(Result), 1);
end;

function TFBStatus.CheckStatusVector(ErrorCodes: array of TFBStatusCode
  ): Boolean;
var
  p: PISC_STATUS;
  i: Integer;
  procedure NextP(i: Integer);
  begin
    p := PISC_STATUS(PAnsiChar(p) + (i * SizeOf(ISC_STATUS)));
  end;
begin
  p := PISC_STATUS(StatusVector);
  result := False;
  while (p^ <> 0) and (not result) do
    case p^ of
      3: NextP(3);
      1, 4:
      begin
        NextP(1);
        i := 0;
        while (i <= High(ErrorCodes)) and (not result) do
        begin
          result := p^ = ErrorCodes[i];
          Inc(i);
        end;
        NextP(1);
      end;
      else
        NextP(2);
    end;
end;

function TFBStatus.GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
begin
  EnterCriticalSection(TFBClientAPI.FIBCS);
  try
    result := FIBDataBaseErrorMessages;
  finally
    LeaveCriticalSection(TFBClientAPI.FIBCS);
  end;
end;

procedure TFBStatus.SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
begin
  EnterCriticalSection(TFBClientAPI.FIBCS);
  try
    FIBDataBaseErrorMessages := Value;
  finally
    LeaveCriticalSection(TFBClientAPI.FIBCS);
  end;
end;

initialization
  TFBLibrary.FEnvSetupDone := false;
  {$IFNDEF FPC}
  InitializeCriticalSection(TFBClientAPI.FIBCS);
  {$ELSE}
  InitCriticalSection(TFBClientAPI.FIBCS);
  {$ENDIF}

finalization
  TFBLibrary.FreeLibraries;
  {$IFNDEF FPC}
  DeleteCriticalSection(TFBClientAPI.FIBCS);
  {$ELSE}
  DoneCriticalSection(TFBClientAPI.FIBCS);
  {$ENDIF}
end.

Revision:	316
Committed:	Thu Feb 25 11:59:00 2021 UTC (3 years, 8 months ago) by tony
Content type:	text/x-pascal
File size:	20152 byte(s)
Log Message:	Merge Fixes
#	User	Rev	Content
1	tony	45	(*
2			* Firebird Interface (fbintf). The fbintf components provide a set of
3			* Pascal language bindings for the Firebird API. Although predominantly
4			* a new development they include source code taken from IBX and may be
5			* considered a derived product. This software thus also includes the copyright
6			* notice and license conditions from IBX.
7			*
8			* Except for those parts dervied from IBX, contents of this file are subject
9			* to the Initial Developer's Public License Version 1.0 (the "License"); you
10			* may not use this file except in compliance with the License. You may obtain a
11			* copy of the License here:
12			*
13			* http://www.firebirdsql.org/index.php?op=doc&id=idpl
14			*
15			* Software distributed under the License is distributed on an "AS
16			* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
17			* implied. See the License for the specific language governing rights
18			* and limitations under the License.
19			*
20			* The Initial Developer of the Original Code is Tony Whyman.
21			*
22			* The Original Code is (C) 2016 Tony Whyman, MWA Software
23			* (http://www.mwasoftware.co.uk).
24			*
25			* All Rights Reserved.
26			*
27			* Contributor(s): ______________________________________.
28			*
29			*)
30			{************************************************************************}
31			{ }
32			{ Borland Delphi Visual Component Library }
33			{ InterBase Express core components }
34			{ }
35			{ Copyright (c) 1998-2000 Inprise Corporation }
36			{ }
37			{ InterBase Express is based in part on the product }
38			{ Free IB Components, written by Gregory H. Deatz for }
39			{ Hoagland, Longo, Moran, Dunst & Doukas Company. }
40			{ Free IB Components is used under license. }
41			{ }
42			{ The contents of this file are subject to the InterBase }
43			{ Public License Version 1.0 (the "License"); you may not }
44			{ use this file except in compliance with the License. You }
45			{ may obtain a copy of the License at http://www.Inprise.com/IPL.html }
46			{ Software distributed under the License is distributed on }
47			{ an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
48			{ express or implied. See the License for the specific language }
49			{ governing rights and limitations under the License. }
50			{ The Original Code was created by InterBase Software Corporation }
51			{ and its successors. }
52			{ Portions created by Inprise Corporation are Copyright (C) Inprise }
53			{ Corporation. All Rights Reserved. }
54			{ Contributor(s): Jeff Overcash }
55			{ }
56			{ IBX For Lazarus (Firebird Express) }
57			{ Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
58			{ Portions created by MWA Software are copyright McCallum Whyman }
59			{ Associates Ltd 2011 - 2015 }
60			{ }
61			{************************************************************************}
62			unit FBClientAPI;
63	tony	56	{$IFDEF MSWINDOWS}
64			{$DEFINE WINDOWS}
65			{$ENDIF}
66	tony	45
67			{$IFDEF FPC}
68			{$mode delphi}
69			{$codepage UTF8}
70			{$interfaces COM}
71			{$ENDIF}
72
73			interface
74
75			uses
76	tony	56	Classes,
77			{$IFDEF WINDOWS}Windows, {$ENDIF}
78			{$IFDEF FPC} Dynlibs, {$ENDIF}
79	tony	315	IB, IBHeader, FBActivityMonitor, FBMessages, IBExternals, FmtBCD;
80	tony	45
81			{For Linux see result of GetFirebirdLibList method}
82			{$IFDEF DARWIN}
83			const
84			FIREBIRD_SO2 = 'libfbclient.dylib';
85			{$ENDIF}
86			{$IFDEF WINDOWS}
87			const
88			IBASE_DLL = 'gds32.dll';
89			FIREBIRD_CLIENT = 'fbclient.dll'; {do not localize}
90			FIREBIRD_EMBEDDED = 'fbembed.dll';
91			{$ENDIF}
92
93	tony	308	const
94	tony	315	{fb_shutdown reasons}
95			fb_shutrsn_svc_stopped = -1;
96			fb_shutrsn_no_connection = -2;
97			fb_shutrsn_app_stopped = -3;
98			fb_shutrsn_signal = -5;
99			fb_shutrsn_services = -6;
100			fb_shutrsn_exit_called = -7;
101
102			const
103			DefaultTimeZoneFile = '/etc/timezone';
104
105			const
106	tony	308	IBLocalBufferLength = 512;
107			IBBigLocalBufferLength = IBLocalBufferLength * 2;
108			IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;
109
110	tony	45	type
111			TStatusVector = array[0..19] of NativeInt;
112			PStatusVector = ^TStatusVector;
113
114			TFBClientAPI = class;
115
116			{ TFBStatus }
117
118			TFBStatus = class(TFBInterfacedObject)
119			private
120			FIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
121			protected
122			FOwner: TFBClientAPI;
123			public
124			constructor Create(aOwner: TFBClientAPI);
125			function StatusVector: PStatusVector; virtual; abstract;
126
127			{IStatus}
128			function GetIBErrorCode: Long;
129			function Getsqlcode: Long;
130	tony	56	function GetMessage: AnsiString;
131	tony	45	function CheckStatusVector(ErrorCodes: array of TFBStatusCode): Boolean;
132			function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
133			procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
134			end;
135
136	tony	263	{ TFBLibrary }
137
138			TFBLibrary = class(TFBInterfacedObject,IFirebirdLibrary)
139			private
140			class var FEnvSetupDone: boolean;
141			class var FLibraryList: array of IFirebirdLibrary;
142	tony	315	private
143	tony	263	FFirebirdAPI: IFirebirdAPI;
144			FRequestedLibName: string;
145			function LoadIBLibrary: boolean;
146			protected
147			FFBLibraryName: string;
148			FIBLibrary: TLibHandle;
149			procedure FreeFBLibrary;
150			function GetOverrideLibName: string;
151			class procedure SetupEnvironment;
152			protected
153			function GetFirebird3API: IFirebirdAPI; virtual; abstract;
154			function GetLegacyFirebirdAPI: IFirebirdAPI; virtual; abstract;
155			public
156			constructor Create(aLibPathName: string='');
157			destructor Destroy; override;
158			class function GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
159			class procedure FreeLibraries;
160	tony	315	function SameLibrary(aLibName: string): boolean;
161	tony	263
162	tony	315	public
163	tony	263	{IFirebirdLibrary}
164			function GetHandle: TLibHandle;
165			function GetLibraryName: string;
166			function GetLibraryFilePath: string;
167			function GetFirebirdAPI: IFirebirdAPI;
168			property IBLibrary: TLibHandle read FIBLibrary;
169			end;
170
171	tony	45	{ TFBClientAPI }
172
173			TFBClientAPI = class(TFBInterfacedObject)
174			private
175	tony	315	FLocalTimeZoneName: AnsiString; {Informal Time Zone Name from tzname e.g. GMT or BST}
176			FTZDataTimeZoneID: AnsiString; {TZData DB ID e.g. Europe/London}
177			FLocalTimeOffset: integer;
178			FIsDaylightSavingsTime: boolean;
179	tony	56	class var FIBCS: TRTLCriticalSection;
180	tony	315	function FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
181			procedure GetTZDataSettings;
182	tony	45	protected
183	tony	263	FFBLibrary: TFBLibrary;
184	tony	56	function GetProcAddr(ProcName: PAnsiChar): Pointer;
185	tony	315
186			protected type
187			Tfb_shutdown = function (timeout: uint;
188			const reason: int): int;
189			{$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
190			protected
191			{FB Shutdown API}
192			fb_shutdown: Tfb_shutdown;
193
194	tony	45	public
195			{Taken from legacy API}
196			isc_sqlcode: Tisc_sqlcode;
197			isc_sql_interprete: Tisc_sql_interprete;
198			isc_event_counts: Tisc_event_counts;
199			isc_event_block: Tisc_event_block;
200			isc_free: Tisc_free;
201
202	tony	263	constructor Create(aFBLibrary: TFBLibrary);
203	tony	45	procedure IBAlloc(var P; OldSize, NewSize: Integer);
204			procedure IBDataBaseError;
205	tony	263	function LoadInterface: boolean; virtual;
206	tony	315	procedure FBShutdown; virtual;
207	tony	263	function GetAPI: IFirebirdAPI; virtual; abstract;
208			{$IFDEF UNIX}
209			function GetFirebirdLibList: string; virtual; abstract;
210			{$ENDIF}
211	tony	315	function HasDecFloatSupport: boolean;
212			function HasInt128Support: boolean; virtual;
213			function HasLocalTZDB: boolean; virtual;
214			function HasExtendedTZSupport: boolean; virtual;
215			function HasTimeZoneSupport: boolean; virtual;
216	tony	45
217	tony	315	public
218			property LocalTimeZoneName: AnsiString read FLocalTimeZoneName;
219			property TZDataTimeZoneID: AnsiString read FTZDataTimeZoneID;
220			property LocalTimeOffset: integer read FLocalTimeOffset;
221			public
222	tony	45	{Encode/Decode}
223	tony	56	procedure EncodeInteger(aValue: integer; len: integer; buffer: PByte);
224			function DecodeInteger(bufptr: PByte; len: short): integer; virtual; abstract;
225	tony	315	procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte); virtual; abstract;
226			function SQLDecodeDate(byfptr: PByte): TDateTime; virtual; abstract;
227			procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte); virtual; abstract;
228	tony	56	function SQLDecodeTime(bufptr: PByte): TDateTime; virtual; abstract;
229			procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte); virtual; abstract;
230	tony	315	function SQLDecodeDateTime(bufptr: PByte): TDateTime; virtual; abstract;
231	tony	308	function FormatStatus(Status: TFBStatus): AnsiString; virtual; abstract;
232	tony	315	function Int128ToStr(bufptr: PByte; scale: integer): AnsiString; virtual;
233			procedure StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte);
234			virtual;
235			procedure SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal; bufptr: PByte); virtual;
236			function SQLDecFloatDecode(SQLType: cardinal; bufptr: PByte): tBCD; virtual;
237	tony	45
238			{IFirebirdAPI}
239			function GetStatus: IStatus; virtual; abstract;
240			function IsLibraryLoaded: boolean;
241			function IsEmbeddedServer: boolean; virtual; abstract;
242	tony	263	function GetFBLibrary: IFirebirdLibrary;
243	tony	308	function GetImplementationVersion: AnsiString;
244			function GetClientMajor: integer; virtual; abstract;
245			function GetClientMinor: integer; virtual; abstract;
246	tony	60	end;
247	tony	45
248			implementation
249
250	tony	263	uses IBUtils, Registry,
251	tony	315	{$IFDEF Unix} unix, initc, dl, {$ENDIF}
252	tony	56	{$IFDEF FPC}
253	tony	45	{$IFDEF WINDOWS }
254	tony	56	WinDirs,
255	tony	45	{$ENDIF}
256	tony	56	{$ELSE}
257			ShlObj,
258			{$ENDIF}
259	tony	45	SysUtils;
260
261			{$IFDEF UNIX}
262	tony	56	{$I 'include/uloadlibrary.inc'}
263	tony	45	{$ELSE}
264	tony	56	{$I 'include/wloadlibrary.inc'}
265	tony	45	{$ENDIF}
266
267	tony	263
268			{ TFBLibrary }
269
270			function TFBLibrary.GetOverrideLibName: string;
271			begin
272			Result := FFBLibraryName;
273			if (Result = '') and AllowUseOfFBLIB then
274			Result := GetEnvironmentVariable('FBLIB');
275			if Result = '' then
276	tony	45	begin
277	tony	263	if assigned(OnGetLibraryName) then
278			OnGetLibraryName(Result)
279	tony	45	end;
280	tony	263	end;
281	tony	45
282	tony	263	procedure TFBLibrary.FreeFBLibrary;
283			begin
284	tony	315	(FFirebirdAPI as TFBClientAPI).FBShutdown;
285	tony	263	if FIBLibrary <> NilHandle then
286			FreeLibrary(FIBLibrary);
287			FIBLibrary := NilHandle;
288	tony	315	FFBLibraryName := '';
289	tony	263	end;
290	tony	45
291	tony	263	function TFBLibrary.GetLibraryName: string;
292	tony	45	begin
293	tony	263	Result := ExtractFileName(FFBLibraryName);
294			end;
295
296			function TFBLibrary.GetFirebirdAPI: IFirebirdAPI;
297			begin
298			Result := FFirebirdAPI;
299			end;
300
301			constructor TFBLibrary.Create(aLibPathName: string);
302			begin
303	tony	45	inherited Create;
304	tony	263	SetupEnvironment;
305			FFBLibraryName := aLibPathName;
306			FIBLibrary := NilHandle;
307			FFirebirdAPI := GetFirebird3API;
308			FRequestedLibName := aLibPathName;
309			if aLibPathName <> '' then
310	tony	45	begin
311	tony	263	SetLength(FLibraryList,Length(FLibraryList)+1);
312			FLibraryList[Length(FLibraryList)-1] := self;
313	tony	45	end;
314	tony	263	if FFirebirdAPI <> nil then
315			begin
316			{First try Firebird 3}
317			if not LoadIBLibrary or not (FFirebirdAPI as TFBClientAPI).LoadInterface then
318			FFirebirdAPI := nil;
319			end;
320
321			if FFirebirdAPI = nil then
322			begin
323			{now try Firebird 2.5. Under Unix we need to reload the library in case we
324			are to use the embedded library}
325			FFirebirdAPI := GetLegacyFirebirdAPI;
326			if FFirebirdAPI <> nil then
327			begin
328			{$IFDEF UNIX}
329			FreeFBLibrary;
330			{$ENDIF}
331			if not LoadIBLibrary or not (FFirebirdAPI as TFBClientAPI).LoadInterface then
332			FFirebirdAPI := nil;
333			end;
334			end;
335			{Note: FFirebirdAPI will be set to nil if the Firebird API fails to load}
336	tony	45	end;
337
338	tony	263	destructor TFBLibrary.Destroy;
339	tony	45	begin
340	tony	315	FreeFBLibrary;
341	tony	263	FFirebirdAPI := nil;
342	tony	45	inherited Destroy;
343			end;
344
345	tony	263	class function TFBLibrary.GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
346			var i: integer;
347			begin
348			Result := nil;
349			if aLibPathName <> '' then
350			begin
351			for i := 0 to Length(FLibraryList) - 1 do
352	tony	315	begin
353			if (FLibraryList[i] as TFBLibrary).SameLibrary(aLibPathName) then
354	tony	263	begin
355			Result := FLibraryList[i];
356			Exit;
357			end;
358	tony	315	end;
359	tony	263	Result := Create(aLibPathName);
360			end;
361
362			end;
363
364			class procedure TFBLibrary.FreeLibraries;
365			var i: integer;
366			begin
367			for i := 0 to Length(FLibraryList) - 1 do
368			FLibraryList[i] := nil;
369			SetLength(FLibraryList,0);
370			end;
371
372	tony	315	function TFBLibrary.SameLibrary(aLibName: string): boolean;
373			begin
374			Result := FRequestedLibName = aLibName;
375			end;
376
377	tony	263	function TFBLibrary.GetHandle: TLibHandle;
378			begin
379			Result := FIBLibrary;
380			end;
381
382			{ TFBClientAPI }
383
384			constructor TFBClientAPI.Create(aFBLibrary: TFBLibrary);
385			begin
386			inherited Create;
387			FFBLibrary := aFBLibrary;
388	tony	315	GetTZDataSettings;
389	tony	263	end;
390
391	tony	45	procedure TFBClientAPI.IBAlloc(var P; OldSize, NewSize: Integer);
392			var
393			i: Integer;
394			begin
395			ReallocMem(Pointer(P), NewSize);
396	tony	56	for i := OldSize to NewSize - 1 do PAnsiChar(P)[i] := #0;
397	tony	45	end;
398
399			procedure TFBClientAPI.IBDataBaseError;
400			begin
401			raise EIBInterBaseError.Create(GetStatus);
402			end;
403
404	tony	56	procedure TFBClientAPI.EncodeInteger(aValue: integer; len: integer; buffer: PByte);
405	tony	45	begin
406			while len > 0 do
407			begin
408	tony	56	buffer^ := aValue and $FF;
409	tony	45	Inc(buffer);
410			Dec(len);
411			aValue := aValue shr 8;
412			end;
413			end;
414
415	tony	315	function TFBClientAPI.Int128ToStr(bufptr: PByte; scale: integer): AnsiString;
416			begin
417			if not HasInt128Support then
418			IBError(ibxeNotSupported,[]);
419			end;
420
421			procedure TFBClientAPI.StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte);
422			begin
423			if not HasInt128Support then
424			IBError(ibxeNotSupported,[]);
425			end;
426
427			procedure TFBClientAPI.SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal;
428			bufptr: PByte);
429			begin
430			if not HasDecFloatSupport then
431			IBError(ibxeNotSupported,[]);
432			end;
433
434			function TFBClientAPI.SQLDecFloatDecode(SQLType: cardinal; bufptr: PByte): tBCD;
435			begin
436			if not HasDecFloatSupport then
437			IBError(ibxeNotSupported,[]);
438			end;
439
440	tony	45	function TFBClientAPI.IsLibraryLoaded: boolean;
441			begin
442	tony	263	Result := FFBLibrary.IBLibrary <> NilHandle;
443	tony	45	end;
444
445	tony	263	function TFBClientAPI.GetFBLibrary: IFirebirdLibrary;
446			begin
447			Result := FFBLibrary;
448			end;
449
450	tony	315	function TFBClientAPI.FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
451	tony	308	begin
452	tony	315	{aDate/aTime are in TTimestamp format but aTime is decimilliseconds}
453			aDate := aDate - DateDelta;
454			if aDate < 0 then
455			Result := trunc(aDate) - abs(frac(aTime / (MSecsPerDay*10)))
456			else
457			Result := trunc(aDate) + abs(frac(aTime / (MSecsPerDay*10)));
458	tony	308	end;
459
460	tony	315	{$IFDEF UNIX}
461			procedure TFBClientAPI.GetTZDataSettings;
462			var S: TStringList;
463			begin
464			FLocalTimeOffset := GetLocalTimeOffset;
465			FLocalTimeZoneName := strpas(tzname[tzdaylight]);
466			FIsDaylightSavingsTime := tzdaylight;
467			if FileExists(DefaultTimeZoneFile) then
468			begin
469			S := TStringList.Create;
470			try
471			S.LoadFromFile(DefaultTimeZoneFile);
472			if S.Count > 0 then
473			FTZDataTimeZoneID := S[0];
474			finally
475			S.Free;
476			end;
477			end;
478			end;
479			{$ENDIF}
480
481			{$IFDEF WINDOWS}
482			procedure TFBClientAPI.GetTZDataSettings;
483			var TZInfo: TTimeZoneInformation;
484			begin
485			FIsDaylightSavingsTime := false;
486			{is there any way of working out the default TZData DB time zone ID under Windows?}
487			case GetTimeZoneInformation(TZInfo) of
488			TIME_ZONE_ID_UNKNOWN:
489			begin
490			FLocalTimeZoneName := '';
491			FLocalTimeOffset := 0;
492			end;
493			TIME_ZONE_ID_STANDARD:
494			begin
495			FLocalTimeZoneName := strpas(PWideChar(@TZInfo.StandardName));
496			FLocalTimeOffset := TZInfo.Bias;
497			end;
498			TIME_ZONE_ID_DAYLIGHT:
499			begin
500			FLocalTimeZoneName := strpas(PWideChar(@TZInfo.DaylightName));
501			FLocalTimeOffset := TZInfo.DayLightBias;
502			FIsDaylightSavingsTime := true;
503			end;
504			end;
505			end;
506			{$ENDIF}
507
508	tony	56	function TFBClientAPI.GetProcAddr(ProcName: PAnsiChar): Pointer;
509	tony	45	begin
510	tony	263	Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
511	tony	45	if not Assigned(Result) then
512			raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
513			end;
514
515	tony	315	function TFBClientAPI.HasDecFloatSupport: boolean;
516			begin
517			Result := GetClientMajor >= 4;
518			end;
519
520			function TFBClientAPI.HasInt128Support: boolean;
521			begin
522			Result := false;
523			end;
524
525			function TFBClientAPI.HasLocalTZDB: boolean;
526			begin
527			Result := false;
528			end;
529
530			function TFBClientAPI.HasExtendedTZSupport: boolean;
531			begin
532			Result := false;
533			end;
534
535			function TFBClientAPI.HasTimeZoneSupport: boolean;
536			begin
537			Result := false;
538			end;
539
540			function TFBClientAPI.GetImplementationVersion: AnsiString;
541			begin
542			Result := Format('%d.%d',[GetClientMajor,GetClientMinor]);
543			end;
544
545	tony	263	function TFBClientAPI.LoadInterface: boolean;
546	tony	45	begin
547			isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
548			isc_sql_interprete := GetProcAddr('isc_sql_interprete'); {do not localize}
549			isc_event_counts := GetProcAddr('isc_event_counts'); {do not localize}
550			isc_event_block := GetProcAddr('isc_event_block'); {do not localize}
551			isc_free := GetProcAddr('isc_free'); {do not localize}
552	tony	315	fb_shutdown := GetProcAddr('fb_shutdown'); {do not localize}
553	tony	263	Result := assigned(isc_free);
554	tony	45	end;
555
556	tony	315	procedure TFBClientAPI.FBShutdown;
557			begin
558			if assigned(fb_shutdown) then
559			fb_shutdown(0,fb_shutrsn_exit_called);
560			end;
561
562	tony	45	{ TFBStatus }
563
564			constructor TFBStatus.Create(aOwner: TFBClientAPI);
565			begin
566			inherited Create;
567			FOwner := aOwner;
568			FIBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
569			end;
570
571			function TFBStatus.GetIBErrorCode: Long;
572			begin
573			Result := StatusVector^[1];
574			end;
575
576			function TFBStatus.Getsqlcode: Long;
577			begin
578			with FOwner do
579			Result := isc_sqlcode(PISC_STATUS(StatusVector));
580			end;
581
582	tony	56	function TFBStatus.GetMessage: AnsiString;
583			var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
584	tony	45	IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
585			sqlcode: Long;
586			begin
587			Result := '';
588			IBDataBaseErrorMessages := FIBDataBaseErrorMessages;
589			sqlcode := Getsqlcode;
590			if (ShowSQLCode in IBDataBaseErrorMessages) then
591			Result := Result + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
592
593			Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
594			if (ShowSQLMessage in IBDataBaseErrorMessages) then
595			begin
596			with FOwner do
597	tony	308	isc_sql_interprete(sqlcode, local_buffer, sizeof(local_buffer));
598	tony	45	if (ShowSQLCode in FIBDataBaseErrorMessages) then
599			Result := Result + CRLF;
600			Result := Result + strpas(local_buffer);
601			end;
602
603			if (ShowIBMessage in IBDataBaseErrorMessages) then
604			begin
605			if (ShowSQLCode in IBDataBaseErrorMessages) or
606			(ShowSQLMessage in IBDataBaseErrorMessages) then
607	tony	308	Result := Result + LineEnding;
608	tony	315	Result := Result + FOwner.FormatStatus(self);
609	tony	45	end;
610			if (Result <> '') and (Result[Length(Result)] = '.') then
611			Delete(Result, Length(Result), 1);
612			end;
613
614			function TFBStatus.CheckStatusVector(ErrorCodes: array of TFBStatusCode
615			): Boolean;
616			var
617			p: PISC_STATUS;
618			i: Integer;
619			procedure NextP(i: Integer);
620			begin
621	tony	56	p := PISC_STATUS(PAnsiChar(p) + (i * SizeOf(ISC_STATUS)));
622	tony	45	end;
623			begin
624			p := PISC_STATUS(StatusVector);
625			result := False;
626			while (p^ <> 0) and (not result) do
627			case p^ of
628			3: NextP(3);
629			1, 4:
630			begin
631			NextP(1);
632			i := 0;
633			while (i <= High(ErrorCodes)) and (not result) do
634			begin
635			result := p^ = ErrorCodes[i];
636			Inc(i);
637			end;
638			NextP(1);
639			end;
640			else
641			NextP(2);
642			end;
643			end;
644
645			function TFBStatus.GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
646			begin
647	tony	56	EnterCriticalSection(TFBClientAPI.FIBCS);
648	tony	45	try
649			result := FIBDataBaseErrorMessages;
650			finally
651	tony	56	LeaveCriticalSection(TFBClientAPI.FIBCS);
652	tony	45	end;
653			end;
654
655			procedure TFBStatus.SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
656			begin
657	tony	56	EnterCriticalSection(TFBClientAPI.FIBCS);
658	tony	45	try
659			FIBDataBaseErrorMessages := Value;
660			finally
661	tony	56	LeaveCriticalSection(TFBClientAPI.FIBCS);
662	tony	45	end;
663			end;
664	tony	60
665	tony	45	initialization
666	tony	263	TFBLibrary.FEnvSetupDone := false;
667	tony	56	{$IFNDEF FPC}
668			InitializeCriticalSection(TFBClientAPI.FIBCS);
669			{$ELSE}
670			InitCriticalSection(TFBClientAPI.FIBCS);
671			{$ENDIF}
672	tony	45
673			finalization
674	tony	263	TFBLibrary.FreeLibraries;
675	tony	56	{$IFNDEF FPC}
676			DeleteCriticalSection(TFBClientAPI.FIBCS);
677			{$ELSE}
678			DoneCriticalSection(TFBClientAPI.FIBCS);
679			{$ENDIF}
680	tony	45	end.
681