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}

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;
    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_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;
    function FormatStatus(Status: TFBStatus): AnsiString; virtual; abstract;

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