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;

{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}

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;
    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;

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

  { TFBClientAPI }

  TFBClientAPI = class(TFBInterfacedObject)
  private
    class var FIBCS: TRTLCriticalSection;
  protected
    FFBLibrary: TFBLibrary;
    function GetProcAddr(ProcName: PAnsiChar): Pointer;
  public
    {Taken from legacy API}
    isc_sqlcode: Tisc_sqlcode;
    isc_sql_interprete: Tisc_sql_interprete;
    isc_interprete: Tisc_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;
    function GetAPI: IFirebirdAPI; virtual; abstract;
    {$IFDEF UNIX}
    function GetFirebirdLibList: string; virtual; abstract;
    {$ENDIF}

    {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;


    {IFirebirdAPI}
    function GetStatus: IStatus; virtual; abstract;
    function IsLibraryLoaded: boolean;
    function IsEmbeddedServer: boolean; virtual; abstract;
    function GetFBLibrary: IFirebirdLibrary;
end;

implementation

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

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

{$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
  if FIBLibrary <> NilHandle then
    FreeLibrary(FIBLibrary);
  FIBLibrary := NilHandle;
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
  FFirebirdAPI := nil;
  FreeFBLibrary;
  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
      if (FLibraryList[i] as TFBLibrary).FRequestedLibName = aLibPathName then
      begin
        Result := FLibraryList[i];
        Exit;
      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.GetHandle: TLibHandle;
begin
  Result := FIBLibrary;
end;

{ TFBClientAPI }

constructor TFBClientAPI.Create(aFBLibrary: TFBLibrary);
begin
  inherited Create;
  FFBLibrary := aFBLibrary;
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;

{Under Unixes, if using an embedded server then set up local TMP and LOCK Directories}

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.IsLibraryLoaded: boolean;
begin
  Result := FFBLibrary.IBLibrary <> NilHandle;
end;

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

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.LoadInterface: boolean;
begin
  isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
  isc_sql_interprete := GetProcAddr('isc_sql_interprete'); {do not localize}
  isc_interprete := GetProcAddr('isc_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}
  Result := assigned(isc_free);
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;
    psb: PStatusVector;
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, IBLocalBufferLength);
    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 + CRLF;
    psb := StatusVector;
    with FOwner do
    while (isc_interprete(@local_buffer, @psb) > 0) do
    begin
      if (Result <> '') and (Result[Length(Result)] <> LF) then
        Result := Result + CRLF;
      Result := Result + strpas(local_buffer);
    end;
  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:	263
Committed:	Thu Dec 6 15:55:01 2018 UTC (5 years, 11 months ago) by tony
Content type:	text/x-pascal
File size:	15359 byte(s)
Log Message:	Release 2.3.2 committed
#	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			IB, IBHeader, FBActivityMonitor, FBMessages, IBExternals;
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			type
94			TStatusVector = array[0..19] of NativeInt;
95			PStatusVector = ^TStatusVector;
96
97			TFBClientAPI = class;
98
99			{ TFBStatus }
100
101			TFBStatus = class(TFBInterfacedObject)
102			private
103			FIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
104			protected
105			FOwner: TFBClientAPI;
106			public
107			constructor Create(aOwner: TFBClientAPI);
108			function StatusVector: PStatusVector; virtual; abstract;
109
110			{IStatus}
111			function GetIBErrorCode: Long;
112			function Getsqlcode: Long;
113	tony	56	function GetMessage: AnsiString;
114	tony	45	function CheckStatusVector(ErrorCodes: array of TFBStatusCode): Boolean;
115			function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
116			procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
117			end;
118
119	tony	263	{ TFBLibrary }
120
121			TFBLibrary = class(TFBInterfacedObject,IFirebirdLibrary)
122			private
123			class var FEnvSetupDone: boolean;
124			class var FLibraryList: array of IFirebirdLibrary;
125			FFirebirdAPI: IFirebirdAPI;
126			FRequestedLibName: string;
127			function LoadIBLibrary: boolean;
128			protected
129			FFBLibraryName: string;
130			FIBLibrary: TLibHandle;
131			procedure FreeFBLibrary;
132			function GetOverrideLibName: string;
133			class procedure SetupEnvironment;
134			protected
135			function GetFirebird3API: IFirebirdAPI; virtual; abstract;
136			function GetLegacyFirebirdAPI: IFirebirdAPI; virtual; abstract;
137			public
138			constructor Create(aLibPathName: string='');
139			destructor Destroy; override;
140			class function GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
141			class procedure FreeLibraries;
142
143			{IFirebirdLibrary}
144			function GetHandle: TLibHandle;
145			function GetLibraryName: string;
146			function GetLibraryFilePath: string;
147			function GetFirebirdAPI: IFirebirdAPI;
148			property IBLibrary: TLibHandle read FIBLibrary;
149			end;
150
151	tony	45	{ TFBClientAPI }
152
153			TFBClientAPI = class(TFBInterfacedObject)
154			private
155	tony	56	class var FIBCS: TRTLCriticalSection;
156	tony	45	protected
157	tony	263	FFBLibrary: TFBLibrary;
158	tony	56	function GetProcAddr(ProcName: PAnsiChar): Pointer;
159	tony	45	public
160			{Taken from legacy API}
161			isc_sqlcode: Tisc_sqlcode;
162			isc_sql_interprete: Tisc_sql_interprete;
163			isc_interprete: Tisc_interprete;
164			isc_event_counts: Tisc_event_counts;
165			isc_event_block: Tisc_event_block;
166			isc_free: Tisc_free;
167
168	tony	263	constructor Create(aFBLibrary: TFBLibrary);
169	tony	45	procedure IBAlloc(var P; OldSize, NewSize: Integer);
170			procedure IBDataBaseError;
171	tony	263	function LoadInterface: boolean; virtual;
172			function GetAPI: IFirebirdAPI; virtual; abstract;
173			{$IFDEF UNIX}
174			function GetFirebirdLibList: string; virtual; abstract;
175			{$ENDIF}
176	tony	45
177			{Encode/Decode}
178	tony	56	procedure EncodeInteger(aValue: integer; len: integer; buffer: PByte);
179			function DecodeInteger(bufptr: PByte; len: short): integer; virtual; abstract;
180			procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte); virtual; abstract;
181			function SQLDecodeDate(byfptr: PByte): TDateTime; virtual; abstract;
182			procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte); virtual; abstract;
183			function SQLDecodeTime(bufptr: PByte): TDateTime; virtual; abstract;
184			procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte); virtual; abstract;
185			function SQLDecodeDateTime(bufptr: PByte): TDateTime; virtual; abstract;
186	tony	45
187
188			{IFirebirdAPI}
189			function GetStatus: IStatus; virtual; abstract;
190			function IsLibraryLoaded: boolean;
191			function IsEmbeddedServer: boolean; virtual; abstract;
192	tony	263	function GetFBLibrary: IFirebirdLibrary;
193	tony	60	end;
194	tony	45
195			implementation
196
197	tony	263	uses IBUtils, Registry,
198			{$IFDEF Unix} initc, dl, {$ENDIF}
199	tony	56	{$IFDEF FPC}
200	tony	45	{$IFDEF WINDOWS }
201	tony	56	WinDirs,
202	tony	45	{$ENDIF}
203	tony	56	{$ELSE}
204			ShlObj,
205			{$ENDIF}
206	tony	45	SysUtils;
207
208	tony	263	const
209			IBLocalBufferLength = 512;
210			IBBigLocalBufferLength = IBLocalBufferLength * 2;
211			IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;
212
213	tony	45	{$IFDEF UNIX}
214	tony	56	{$I 'include/uloadlibrary.inc'}
215	tony	45	{$ELSE}
216	tony	56	{$I 'include/wloadlibrary.inc'}
217	tony	45	{$ENDIF}
218
219	tony	263
220			{ TFBLibrary }
221
222			function TFBLibrary.GetOverrideLibName: string;
223			begin
224			Result := FFBLibraryName;
225			if (Result = '') and AllowUseOfFBLIB then
226			Result := GetEnvironmentVariable('FBLIB');
227			if Result = '' then
228	tony	45	begin
229	tony	263	if assigned(OnGetLibraryName) then
230			OnGetLibraryName(Result)
231	tony	45	end;
232	tony	263	end;
233	tony	45
234	tony	263	procedure TFBLibrary.FreeFBLibrary;
235			begin
236			if FIBLibrary <> NilHandle then
237			FreeLibrary(FIBLibrary);
238			FIBLibrary := NilHandle;
239			end;
240	tony	45
241	tony	263	function TFBLibrary.GetLibraryName: string;
242	tony	45	begin
243	tony	263	Result := ExtractFileName(FFBLibraryName);
244			end;
245
246			function TFBLibrary.GetFirebirdAPI: IFirebirdAPI;
247			begin
248			Result := FFirebirdAPI;
249			end;
250
251			constructor TFBLibrary.Create(aLibPathName: string);
252			begin
253	tony	45	inherited Create;
254	tony	263	SetupEnvironment;
255			FFBLibraryName := aLibPathName;
256			FIBLibrary := NilHandle;
257			FFirebirdAPI := GetFirebird3API;
258			FRequestedLibName := aLibPathName;
259			if aLibPathName <> '' then
260	tony	45	begin
261	tony	263	SetLength(FLibraryList,Length(FLibraryList)+1);
262			FLibraryList[Length(FLibraryList)-1] := self;
263	tony	45	end;
264	tony	263	if FFirebirdAPI <> nil then
265			begin
266			{First try Firebird 3}
267			if not LoadIBLibrary or not (FFirebirdAPI as TFBClientAPI).LoadInterface then
268			FFirebirdAPI := nil;
269			end;
270
271			if FFirebirdAPI = nil then
272			begin
273			{now try Firebird 2.5. Under Unix we need to reload the library in case we
274			are to use the embedded library}
275			FFirebirdAPI := GetLegacyFirebirdAPI;
276			if FFirebirdAPI <> nil then
277			begin
278			{$IFDEF UNIX}
279			FreeFBLibrary;
280			{$ENDIF}
281			if not LoadIBLibrary or not (FFirebirdAPI as TFBClientAPI).LoadInterface then
282			FFirebirdAPI := nil;
283			end;
284			end;
285			{Note: FFirebirdAPI will be set to nil if the Firebird API fails to load}
286	tony	45	end;
287
288	tony	263	destructor TFBLibrary.Destroy;
289	tony	45	begin
290	tony	263	FFirebirdAPI := nil;
291			FreeFBLibrary;
292	tony	45	inherited Destroy;
293			end;
294
295	tony	263	class function TFBLibrary.GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
296			var i: integer;
297			begin
298			Result := nil;
299			if aLibPathName <> '' then
300			begin
301			for i := 0 to Length(FLibraryList) - 1 do
302			if (FLibraryList[i] as TFBLibrary).FRequestedLibName = aLibPathName then
303			begin
304			Result := FLibraryList[i];
305			Exit;
306			end;
307			Result := Create(aLibPathName);
308			end;
309
310			end;
311
312			class procedure TFBLibrary.FreeLibraries;
313			var i: integer;
314			begin
315			for i := 0 to Length(FLibraryList) - 1 do
316			FLibraryList[i] := nil;
317			SetLength(FLibraryList,0);
318			end;
319
320			function TFBLibrary.GetHandle: TLibHandle;
321			begin
322			Result := FIBLibrary;
323			end;
324
325			{ TFBClientAPI }
326
327			constructor TFBClientAPI.Create(aFBLibrary: TFBLibrary);
328			begin
329			inherited Create;
330			FFBLibrary := aFBLibrary;
331			end;
332
333	tony	45	procedure TFBClientAPI.IBAlloc(var P; OldSize, NewSize: Integer);
334			var
335			i: Integer;
336			begin
337			ReallocMem(Pointer(P), NewSize);
338	tony	56	for i := OldSize to NewSize - 1 do PAnsiChar(P)[i] := #0;
339	tony	45	end;
340
341			procedure TFBClientAPI.IBDataBaseError;
342			begin
343			raise EIBInterBaseError.Create(GetStatus);
344			end;
345
346			{Under Unixes, if using an embedded server then set up local TMP and LOCK Directories}
347
348	tony	56	procedure TFBClientAPI.EncodeInteger(aValue: integer; len: integer; buffer: PByte);
349	tony	45	begin
350			while len > 0 do
351			begin
352	tony	56	buffer^ := aValue and $FF;
353	tony	45	Inc(buffer);
354			Dec(len);
355			aValue := aValue shr 8;
356			end;
357			end;
358
359			function TFBClientAPI.IsLibraryLoaded: boolean;
360			begin
361	tony	263	Result := FFBLibrary.IBLibrary <> NilHandle;
362	tony	45	end;
363
364	tony	263	function TFBClientAPI.GetFBLibrary: IFirebirdLibrary;
365			begin
366			Result := FFBLibrary;
367			end;
368
369	tony	56	function TFBClientAPI.GetProcAddr(ProcName: PAnsiChar): Pointer;
370	tony	45	begin
371	tony	263	Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
372	tony	45	if not Assigned(Result) then
373			raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
374			end;
375
376	tony	263	function TFBClientAPI.LoadInterface: boolean;
377	tony	45	begin
378			isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
379			isc_sql_interprete := GetProcAddr('isc_sql_interprete'); {do not localize}
380			isc_interprete := GetProcAddr('isc_interprete'); {do not localize}
381			isc_event_counts := GetProcAddr('isc_event_counts'); {do not localize}
382			isc_event_block := GetProcAddr('isc_event_block'); {do not localize}
383			isc_free := GetProcAddr('isc_free'); {do not localize}
384	tony	263	Result := assigned(isc_free);
385	tony	45	end;
386
387			{ TFBStatus }
388
389			constructor TFBStatus.Create(aOwner: TFBClientAPI);
390			begin
391			inherited Create;
392			FOwner := aOwner;
393			FIBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
394			end;
395
396			function TFBStatus.GetIBErrorCode: Long;
397			begin
398			Result := StatusVector^[1];
399			end;
400
401			function TFBStatus.Getsqlcode: Long;
402			begin
403			with FOwner do
404			Result := isc_sqlcode(PISC_STATUS(StatusVector));
405			end;
406
407	tony	56	function TFBStatus.GetMessage: AnsiString;
408			var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
409	tony	45	IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
410			sqlcode: Long;
411			psb: PStatusVector;
412			begin
413			Result := '';
414			IBDataBaseErrorMessages := FIBDataBaseErrorMessages;
415			sqlcode := Getsqlcode;
416			if (ShowSQLCode in IBDataBaseErrorMessages) then
417			Result := Result + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
418
419			Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
420			if (ShowSQLMessage in IBDataBaseErrorMessages) then
421			begin
422			with FOwner do
423			isc_sql_interprete(sqlcode, local_buffer, IBLocalBufferLength);
424			if (ShowSQLCode in FIBDataBaseErrorMessages) then
425			Result := Result + CRLF;
426			Result := Result + strpas(local_buffer);
427			end;
428
429			if (ShowIBMessage in IBDataBaseErrorMessages) then
430			begin
431			if (ShowSQLCode in IBDataBaseErrorMessages) or
432			(ShowSQLMessage in IBDataBaseErrorMessages) then
433			Result := Result + CRLF;
434			psb := StatusVector;
435			with FOwner do
436			while (isc_interprete(@local_buffer, @psb) > 0) do
437			begin
438			if (Result <> '') and (Result[Length(Result)] <> LF) then
439			Result := Result + CRLF;
440			Result := Result + strpas(local_buffer);
441			end;
442			end;
443			if (Result <> '') and (Result[Length(Result)] = '.') then
444			Delete(Result, Length(Result), 1);
445			end;
446
447			function TFBStatus.CheckStatusVector(ErrorCodes: array of TFBStatusCode
448			): Boolean;
449			var
450			p: PISC_STATUS;
451			i: Integer;
452			procedure NextP(i: Integer);
453			begin
454	tony	56	p := PISC_STATUS(PAnsiChar(p) + (i * SizeOf(ISC_STATUS)));
455	tony	45	end;
456			begin
457			p := PISC_STATUS(StatusVector);
458			result := False;
459			while (p^ <> 0) and (not result) do
460			case p^ of
461			3: NextP(3);
462			1, 4:
463			begin
464			NextP(1);
465			i := 0;
466			while (i <= High(ErrorCodes)) and (not result) do
467			begin
468			result := p^ = ErrorCodes[i];
469			Inc(i);
470			end;
471			NextP(1);
472			end;
473			else
474			NextP(2);
475			end;
476			end;
477
478			function TFBStatus.GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
479			begin
480	tony	56	EnterCriticalSection(TFBClientAPI.FIBCS);
481	tony	45	try
482			result := FIBDataBaseErrorMessages;
483			finally
484	tony	56	LeaveCriticalSection(TFBClientAPI.FIBCS);
485	tony	45	end;
486			end;
487
488			procedure TFBStatus.SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
489			begin
490	tony	56	EnterCriticalSection(TFBClientAPI.FIBCS);
491	tony	45	try
492			FIBDataBaseErrorMessages := Value;
493			finally
494	tony	56	LeaveCriticalSection(TFBClientAPI.FIBCS);
495	tony	45	end;
496			end;
497	tony	60
498	tony	45	initialization
499	tony	263	TFBLibrary.FEnvSetupDone := false;
500	tony	56	{$IFNDEF FPC}
501			InitializeCriticalSection(TFBClientAPI.FIBCS);
502			{$ELSE}
503			InitCriticalSection(TFBClientAPI.FIBCS);
504			{$ENDIF}
505	tony	45
506			finalization
507	tony	263	TFBLibrary.FreeLibraries;
508	tony	56	{$IFNDEF FPC}
509			DeleteCriticalSection(TFBClientAPI.FIBCS);
510			{$ELSE}
511			DoneCriticalSection(TFBClientAPI.FIBCS);
512			{$ENDIF}
513	tony	45	end.
514