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 GetFirebirdLibListruntime/nongui/winipc.inc 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;
    FPrefix: AnsiString;
  protected
    FOwner: TFBClientAPI;
  public
    constructor Create(aOwner: TFBClientAPI; prefix: AnsiString='');
    function StatusVector: PStatusVector; virtual; abstract;

    {IStatus}
    function GetIBErrorCode: TStatusCode;
    function Getsqlcode: TStatusCode;
    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;
    isc_portable_integer: Tisc_portable_integer;

    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): int64;
    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;

    IJournallingHook = interface
      ['{7d3e45e0-3628-416a-9e22-c20474825031}']
      procedure TransactionStart(Tr: ITransaction);
      function TransactionEnd(TransactionID: integer; Action: TTransactionAction): boolean;
      procedure TransactionRetained(Tr: ITransaction; OldTransactionID: integer; Action: TTransactionAction);
      procedure ExecQuery(Stmt: IStatement);
    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.DecodeInteger(bufptr: PByte; len: short): int64;
begin
  Result := isc_portable_integer(bufptr,len);
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;
  {$if declared(Gettzname)}
  FLocalTimeZoneName := Gettzname(tzdaylight);
  {$else}
  FLocalTimeZoneName := tzname[tzdaylight];
  {$ifend}
  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 := nil;
  if assigned(FFBLibrary) and (FFBLibrary.IBLibrary <> NilHandle) then
    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}
  isc_portable_integer := GetProcAddr('isc_portable_integer'); {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; prefix: AnsiString);
begin
  inherited Create;
  FOwner := aOwner;
  FPrefix := prefix;
  FIBDataBaseErrorMessages := [ShowSQLCode, ShowSQLMessage, ShowIBMessage];
end;

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

function TFBStatus.Getsqlcode: TStatusCode;
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 := FPrefix;
  IBDataBaseErrorMessages := FIBDataBaseErrorMessages;
  sqlcode := Getsqlcode;
  if (ShowSQLCode in IBDataBaseErrorMessages) then
    Result := Result + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}

  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 + LineEnding;
    Result := Result + 'Engine Code: ' + IntToStr(GetIBErrorCode) + ' ' + 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:	363
Committed:	Tue Dec 7 13:30:05 2021 UTC (2 years, 4 months ago) by tony
Content type:	text/x-pascal
File size:	21127 byte(s)
Log Message:	add fbintf
#	Content
1	(*
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	{$IFDEF MSWINDOWS}
64	{$DEFINE WINDOWS}
65	{$ENDIF}
66
67	{$IFDEF FPC}
68	{$mode delphi}
69	{$codepage UTF8}
70	{$interfaces COM}
71	{$ENDIF}
72
73	interface
74
75	uses
76	Classes,
77	{$IFDEF WINDOWS}Windows, {$ENDIF}
78	{$IFDEF FPC} Dynlibs, {$ENDIF}
79	IB, IBHeader, FBActivityMonitor, FBMessages, IBExternals, FmtBCD;
80
81	{For Linux see result of GetFirebirdLibListruntime/nongui/winipc.inc 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	const
94	{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	IBLocalBufferLength = 512;
107	IBBigLocalBufferLength = IBLocalBufferLength * 2;
108	IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;
109
110	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	FPrefix: AnsiString;
122	protected
123	FOwner: TFBClientAPI;
124	public
125	constructor Create(aOwner: TFBClientAPI; prefix: AnsiString='');
126	function StatusVector: PStatusVector; virtual; abstract;
127
128	{IStatus}
129	function GetIBErrorCode: TStatusCode;
130	function Getsqlcode: TStatusCode;
131	function GetMessage: AnsiString;
132	function CheckStatusVector(ErrorCodes: array of TFBStatusCode): Boolean;
133	function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
134	procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
135	end;
136
137	{ TFBLibrary }
138
139	TFBLibrary = class(TFBInterfacedObject,IFirebirdLibrary)
140	private
141	class var FEnvSetupDone: boolean;
142	class var FLibraryList: array of IFirebirdLibrary;
143	private
144	FFirebirdAPI: IFirebirdAPI;
145	FRequestedLibName: string;
146	function LoadIBLibrary: boolean;
147	protected
148	FFBLibraryName: string;
149	FIBLibrary: TLibHandle;
150	procedure FreeFBLibrary;
151	function GetOverrideLibName: string;
152	class procedure SetupEnvironment;
153	protected
154	function GetFirebird3API: IFirebirdAPI; virtual; abstract;
155	function GetLegacyFirebirdAPI: IFirebirdAPI; virtual; abstract;
156	public
157	constructor Create(aLibPathName: string='');
158	destructor Destroy; override;
159	class function GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
160	class procedure FreeLibraries;
161	function SameLibrary(aLibName: string): boolean;
162
163	public
164	{IFirebirdLibrary}
165	function GetHandle: TLibHandle;
166	function GetLibraryName: string;
167	function GetLibraryFilePath: string;
168	function GetFirebirdAPI: IFirebirdAPI;
169	property IBLibrary: TLibHandle read FIBLibrary;
170	end;
171
172	{ TFBClientAPI }
173
174	TFBClientAPI = class(TFBInterfacedObject)
175	private
176	FLocalTimeZoneName: AnsiString; {Informal Time Zone Name from tzname e.g. GMT or BST}
177	FTZDataTimeZoneID: AnsiString; {TZData DB ID e.g. Europe/London}
178	FLocalTimeOffset: integer;
179	FIsDaylightSavingsTime: boolean;
180	class var FIBCS: TRTLCriticalSection;
181	function FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
182	procedure GetTZDataSettings;
183	protected
184	FFBLibrary: TFBLibrary;
185	function GetProcAddr(ProcName: PAnsiChar): Pointer;
186
187	protected type
188	Tfb_shutdown = function (timeout: uint;
189	const reason: int): int;
190	{$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
191	protected
192	{FB Shutdown API}
193	fb_shutdown: Tfb_shutdown;
194
195	public
196	{Taken from legacy API}
197	isc_sqlcode: Tisc_sqlcode;
198	isc_sql_interprete: Tisc_sql_interprete;
199	isc_event_counts: Tisc_event_counts;
200	isc_event_block: Tisc_event_block;
201	isc_free: Tisc_free;
202	isc_portable_integer: Tisc_portable_integer;
203
204	constructor Create(aFBLibrary: TFBLibrary);
205	procedure IBAlloc(var P; OldSize, NewSize: Integer);
206	procedure IBDataBaseError;
207	function LoadInterface: boolean; virtual;
208	procedure FBShutdown; virtual;
209	function GetAPI: IFirebirdAPI; virtual; abstract;
210	{$IFDEF UNIX}
211	function GetFirebirdLibList: string; virtual; abstract;
212	{$ENDIF}
213	function HasDecFloatSupport: boolean;
214	function HasInt128Support: boolean; virtual;
215	function HasLocalTZDB: boolean; virtual;
216	function HasExtendedTZSupport: boolean; virtual;
217	function HasTimeZoneSupport: boolean; virtual;
218
219	public
220	property LocalTimeZoneName: AnsiString read FLocalTimeZoneName;
221	property TZDataTimeZoneID: AnsiString read FTZDataTimeZoneID;
222	property LocalTimeOffset: integer read FLocalTimeOffset;
223	public
224	{Encode/Decode}
225	procedure EncodeInteger(aValue: integer; len: integer; buffer: PByte);
226	function DecodeInteger(bufptr: PByte; len: short): int64;
227	procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte); virtual; abstract;
228	function SQLDecodeDate(byfptr: PByte): TDateTime; virtual; abstract;
229	procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte); virtual; abstract;
230	function SQLDecodeTime(bufptr: PByte): TDateTime; virtual; abstract;
231	procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte); virtual; abstract;
232	function SQLDecodeDateTime(bufptr: PByte): TDateTime; virtual; abstract;
233	function FormatStatus(Status: TFBStatus): AnsiString; virtual; abstract;
234	function Int128ToStr(bufptr: PByte; scale: integer): AnsiString; virtual;
235	procedure StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte);
236	virtual;
237	procedure SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal; bufptr: PByte); virtual;
238	function SQLDecFloatDecode(SQLType: cardinal; bufptr: PByte): tBCD; virtual;
239
240	{IFirebirdAPI}
241	function GetStatus: IStatus; virtual; abstract;
242	function IsLibraryLoaded: boolean;
243	function IsEmbeddedServer: boolean; virtual; abstract;
244	function GetFBLibrary: IFirebirdLibrary;
245	function GetImplementationVersion: AnsiString;
246	function GetClientMajor: integer; virtual; abstract;
247	function GetClientMinor: integer; virtual; abstract;
248	end;
249
250	IJournallingHook = interface
251	['{7d3e45e0-3628-416a-9e22-c20474825031}']
252	procedure TransactionStart(Tr: ITransaction);
253	function TransactionEnd(TransactionID: integer; Action: TTransactionAction): boolean;
254	procedure TransactionRetained(Tr: ITransaction; OldTransactionID: integer; Action: TTransactionAction);
255	procedure ExecQuery(Stmt: IStatement);
256	end;
257
258	implementation
259
260	uses IBUtils, Registry,
261	{$IFDEF Unix} unix, initc, dl, {$ENDIF}
262	{$IFDEF FPC}
263	{$IFDEF WINDOWS }
264	WinDirs,
265	{$ENDIF}
266	{$ELSE}
267	ShlObj,
268	{$ENDIF}
269	SysUtils;
270
271	{$IFDEF UNIX}
272	{$I 'include/uloadlibrary.inc'}
273	{$ELSE}
274	{$I 'include/wloadlibrary.inc'}
275	{$ENDIF}
276
277
278	{ TFBLibrary }
279
280	function TFBLibrary.GetOverrideLibName: string;
281	begin
282	Result := FFBLibraryName;
283	if (Result = '') and AllowUseOfFBLIB then
284	Result := GetEnvironmentVariable('FBLIB');
285	if Result = '' then
286	begin
287	if assigned(OnGetLibraryName) then
288	OnGetLibraryName(Result)
289	end;
290	end;
291
292	procedure TFBLibrary.FreeFBLibrary;
293	begin
294	(FFirebirdAPI as TFBClientAPI).FBShutdown;
295	if FIBLibrary <> NilHandle then
296	FreeLibrary(FIBLibrary);
297	FIBLibrary := NilHandle;
298	FFBLibraryName := '';
299	end;
300
301	function TFBLibrary.GetLibraryName: string;
302	begin
303	Result := ExtractFileName(FFBLibraryName);
304	end;
305
306	function TFBLibrary.GetFirebirdAPI: IFirebirdAPI;
307	begin
308	Result := FFirebirdAPI;
309	end;
310
311	constructor TFBLibrary.Create(aLibPathName: string);
312	begin
313	inherited Create;
314	SetupEnvironment;
315	FFBLibraryName := aLibPathName;
316	FIBLibrary := NilHandle;
317	FFirebirdAPI := GetFirebird3API;
318	FRequestedLibName := aLibPathName;
319	if aLibPathName <> '' then
320	begin
321	SetLength(FLibraryList,Length(FLibraryList)+1);
322	FLibraryList[Length(FLibraryList)-1] := self;
323	end;
324	if FFirebirdAPI <> nil then
325	begin
326	{First try Firebird 3}
327	if not LoadIBLibrary or not (FFirebirdAPI as TFBClientAPI).LoadInterface then
328	FFirebirdAPI := nil;
329	end;
330
331	if FFirebirdAPI = nil then
332	begin
333	{now try Firebird 2.5. Under Unix we need to reload the library in case we
334	are to use the embedded library}
335	FFirebirdAPI := GetLegacyFirebirdAPI;
336	if FFirebirdAPI <> nil then
337	begin
338	{$IFDEF UNIX}
339	FreeFBLibrary;
340	{$ENDIF}
341	if not LoadIBLibrary or not (FFirebirdAPI as TFBClientAPI).LoadInterface then
342	FFirebirdAPI := nil;
343	end;
344	end;
345	{Note: FFirebirdAPI will be set to nil if the Firebird API fails to load}
346	end;
347
348	destructor TFBLibrary.Destroy;
349	begin
350	FreeFBLibrary;
351	FFirebirdAPI := nil;
352	inherited Destroy;
353	end;
354
355	class function TFBLibrary.GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
356	var i: integer;
357	begin
358	Result := nil;
359	if aLibPathName <> '' then
360	begin
361	for i := 0 to Length(FLibraryList) - 1 do
362	begin
363	if (FLibraryList[i] as TFBLibrary).SameLibrary(aLibPathName) then
364	begin
365	Result := FLibraryList[i];
366	Exit;
367	end;
368	end;
369	Result := Create(aLibPathName);
370	end;
371
372	end;
373
374	class procedure TFBLibrary.FreeLibraries;
375	var i: integer;
376	begin
377	for i := 0 to Length(FLibraryList) - 1 do
378	FLibraryList[i] := nil;
379	SetLength(FLibraryList,0);
380	end;
381
382	function TFBLibrary.SameLibrary(aLibName: string): boolean;
383	begin
384	Result := FRequestedLibName = aLibName;
385	end;
386
387	function TFBLibrary.GetHandle: TLibHandle;
388	begin
389	Result := FIBLibrary;
390	end;
391
392	{ TFBClientAPI }
393
394	constructor TFBClientAPI.Create(aFBLibrary: TFBLibrary);
395	begin
396	inherited Create;
397	FFBLibrary := aFBLibrary;
398	GetTZDataSettings;
399	end;
400
401	procedure TFBClientAPI.IBAlloc(var P; OldSize, NewSize: Integer);
402	var
403	i: Integer;
404	begin
405	ReallocMem(Pointer(P), NewSize);
406	for i := OldSize to NewSize - 1 do PAnsiChar(P)[i] := #0;
407	end;
408
409	procedure TFBClientAPI.IBDataBaseError;
410	begin
411	raise EIBInterBaseError.Create(GetStatus);
412	end;
413
414	procedure TFBClientAPI.EncodeInteger(aValue: integer; len: integer; buffer: PByte);
415	begin
416	while len > 0 do
417	begin
418	buffer^ := aValue and $FF;
419	Inc(buffer);
420	Dec(len);
421	aValue := aValue shr 8;
422	end;
423	end;
424
425	function TFBClientAPI.DecodeInteger(bufptr: PByte; len: short): int64;
426	begin
427	Result := isc_portable_integer(bufptr,len);
428	end;
429
430	function TFBClientAPI.Int128ToStr(bufptr: PByte; scale: integer): AnsiString;
431	begin
432	if not HasInt128Support then
433	IBError(ibxeNotSupported,[]);
434	end;
435
436	procedure TFBClientAPI.StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte);
437	begin
438	if not HasInt128Support then
439	IBError(ibxeNotSupported,[]);
440	end;
441
442	procedure TFBClientAPI.SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal;
443	bufptr: PByte);
444	begin
445	if not HasDecFloatSupport then
446	IBError(ibxeNotSupported,[]);
447	end;
448
449	function TFBClientAPI.SQLDecFloatDecode(SQLType: cardinal; bufptr: PByte): tBCD;
450	begin
451	if not HasDecFloatSupport then
452	IBError(ibxeNotSupported,[]);
453	end;
454
455	function TFBClientAPI.IsLibraryLoaded: boolean;
456	begin
457	Result := FFBLibrary.IBLibrary <> NilHandle;
458	end;
459
460	function TFBClientAPI.GetFBLibrary: IFirebirdLibrary;
461	begin
462	Result := FFBLibrary;
463	end;
464
465	function TFBClientAPI.FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
466	begin
467	{aDate/aTime are in TTimestamp format but aTime is decimilliseconds}
468	aDate := aDate - DateDelta;
469	if aDate < 0 then
470	Result := trunc(aDate) - abs(frac(aTime / (MSecsPerDay*10)))
471	else
472	Result := trunc(aDate) + abs(frac(aTime / (MSecsPerDay*10)));
473	end;
474
475	{$IFDEF UNIX}
476
477	procedure TFBClientAPI.GetTZDataSettings;
478	var S: TStringList;
479	begin
480	FLocalTimeOffset := GetLocalTimeOffset;
481	{$if declared(Gettzname)}
482	FLocalTimeZoneName := Gettzname(tzdaylight);
483	{$else}
484	FLocalTimeZoneName := tzname[tzdaylight];
485	{$ifend}
486	FIsDaylightSavingsTime := tzdaylight;
487	if FileExists(DefaultTimeZoneFile) then
488	begin
489	S := TStringList.Create;
490	try
491	S.LoadFromFile(DefaultTimeZoneFile);
492	if S.Count > 0 then
493	FTZDataTimeZoneID := S[0];
494	finally
495	S.Free;
496	end;
497	end;
498	end;
499	{$ENDIF}
500
501	{$IFDEF WINDOWS}
502	procedure TFBClientAPI.GetTZDataSettings;
503	var TZInfo: TTimeZoneInformation;
504	begin
505	FIsDaylightSavingsTime := false;
506	{is there any way of working out the default TZData DB time zone ID under Windows?}
507	case GetTimeZoneInformation(TZInfo) of
508	TIME_ZONE_ID_UNKNOWN:
509	begin
510	FLocalTimeZoneName := '';
511	FLocalTimeOffset := 0;
512	end;
513	TIME_ZONE_ID_STANDARD:
514	begin
515	FLocalTimeZoneName := strpas(PWideChar(@TZInfo.StandardName));
516	FLocalTimeOffset := TZInfo.Bias;
517	end;
518	TIME_ZONE_ID_DAYLIGHT:
519	begin
520	FLocalTimeZoneName := strpas(PWideChar(@TZInfo.DaylightName));
521	FLocalTimeOffset := TZInfo.DayLightBias;
522	FIsDaylightSavingsTime := true;
523	end;
524	end;
525	end;
526	{$ENDIF}
527
528	function TFBClientAPI.GetProcAddr(ProcName: PAnsiChar): Pointer;
529	begin
530	Result := nil;
531	if assigned(FFBLibrary) and (FFBLibrary.IBLibrary <> NilHandle) then
532	Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
533	if not Assigned(Result) then
534	raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
535	end;
536
537	function TFBClientAPI.HasDecFloatSupport: boolean;
538	begin
539	Result := GetClientMajor >= 4;
540	end;
541
542	function TFBClientAPI.HasInt128Support: boolean;
543	begin
544	Result := false;
545	end;
546
547	function TFBClientAPI.HasLocalTZDB: boolean;
548	begin
549	Result := false;
550	end;
551
552	function TFBClientAPI.HasExtendedTZSupport: boolean;
553	begin
554	Result := false;
555	end;
556
557	function TFBClientAPI.HasTimeZoneSupport: boolean;
558	begin
559	Result := false;
560	end;
561
562	function TFBClientAPI.GetImplementationVersion: AnsiString;
563	begin
564	Result := Format('%d.%d',[GetClientMajor,GetClientMinor]);
565	end;
566
567	function TFBClientAPI.LoadInterface: boolean;
568	begin
569	isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
570	isc_sql_interprete := GetProcAddr('isc_sql_interprete'); {do not localize}
571	isc_event_counts := GetProcAddr('isc_event_counts'); {do not localize}
572	isc_event_block := GetProcAddr('isc_event_block'); {do not localize}
573	isc_free := GetProcAddr('isc_free'); {do not localize}
574	isc_portable_integer := GetProcAddr('isc_portable_integer'); {do not localize}
575	fb_shutdown := GetProcAddr('fb_shutdown'); {do not localize}
576	Result := assigned(isc_free);
577	end;
578
579	procedure TFBClientAPI.FBShutdown;
580	begin
581	if assigned(fb_shutdown) then
582	fb_shutdown(0,fb_shutrsn_exit_called);
583	end;
584
585	{ TFBStatus }
586
587	constructor TFBStatus.Create(aOwner: TFBClientAPI; prefix: AnsiString);
588	begin
589	inherited Create;
590	FOwner := aOwner;
591	FPrefix := prefix;
592	FIBDataBaseErrorMessages := [ShowSQLCode, ShowSQLMessage, ShowIBMessage];
593	end;
594
595	function TFBStatus.GetIBErrorCode: TStatusCode;
596	begin
597	Result := StatusVector^[1];
598	end;
599
600	function TFBStatus.Getsqlcode: TStatusCode;
601	begin
602	with FOwner do
603	Result := isc_sqlcode(PISC_STATUS(StatusVector));
604	end;
605
606	function TFBStatus.GetMessage: AnsiString;
607	var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
608	IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
609	sqlcode: Long;
610	begin
611	Result := FPrefix;
612	IBDataBaseErrorMessages := FIBDataBaseErrorMessages;
613	sqlcode := Getsqlcode;
614	if (ShowSQLCode in IBDataBaseErrorMessages) then
615	Result := Result + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
616
617	if (ShowSQLMessage in IBDataBaseErrorMessages) then
618	begin
619	with FOwner do
620	isc_sql_interprete(sqlcode, local_buffer, sizeof(local_buffer));
621	if (ShowSQLCode in FIBDataBaseErrorMessages) then
622	Result := Result + LineEnding;
623	Result := Result + 'Engine Code: ' + IntToStr(GetIBErrorCode) + ' ' + strpas(local_buffer);
624	end;
625
626	if (ShowIBMessage in IBDataBaseErrorMessages) then
627	begin
628	if (ShowSQLCode in IBDataBaseErrorMessages) or
629	(ShowSQLMessage in IBDataBaseErrorMessages) then
630	Result := Result + LineEnding;
631	Result := Result + FOwner.FormatStatus(self);
632	end;
633	if (Result <> '') and (Result[Length(Result)] = '.') then
634	Delete(Result, Length(Result), 1);
635	end;
636
637	function TFBStatus.CheckStatusVector(ErrorCodes: array of TFBStatusCode
638	): Boolean;
639	var
640	p: PISC_STATUS;
641	i: Integer;
642	procedure NextP(i: Integer);
643	begin
644	p := PISC_STATUS(PAnsiChar(p) + (i * SizeOf(ISC_STATUS)));
645	end;
646	begin
647	p := PISC_STATUS(StatusVector);
648	result := False;
649	while (p^ <> 0) and (not result) do
650	case p^ of
651	3: NextP(3);
652	1, 4:
653	begin
654	NextP(1);
655	i := 0;
656	while (i <= High(ErrorCodes)) and (not result) do
657	begin
658	result := p^ = ErrorCodes[i];
659	Inc(i);
660	end;
661	NextP(1);
662	end;
663	else
664	NextP(2);
665	end;
666	end;
667
668	function TFBStatus.GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
669	begin
670	EnterCriticalSection(TFBClientAPI.FIBCS);
671	try
672	result := FIBDataBaseErrorMessages;
673	finally
674	LeaveCriticalSection(TFBClientAPI.FIBCS);
675	end;
676	end;
677
678	procedure TFBStatus.SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
679	begin
680	EnterCriticalSection(TFBClientAPI.FIBCS);
681	try
682	FIBDataBaseErrorMessages := Value;
683	finally
684	LeaveCriticalSection(TFBClientAPI.FIBCS);
685	end;
686	end;
687
688	initialization
689	TFBLibrary.FEnvSetupDone := false;
690	{$IFNDEF FPC}
691	InitializeCriticalSection(TFBClientAPI.FIBCS);
692	{$ELSE}
693	InitCriticalSection(TFBClientAPI.FIBCS);
694	{$ENDIF}
695
696	finalization
697	TFBLibrary.FreeLibraries;
698	{$IFNDEF FPC}
699	DeleteCriticalSection(TFBClientAPI.FIBCS);
700	{$ELSE}
701	DoneCriticalSection(TFBClientAPI.FIBCS);
702	{$ENDIF}
703	end.
704