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}

{$IFNDEF FPC}
type
  TLibHandle = THandle;

const
  NilHandle = 0;
  DirectorySeparator = '\';
{$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;

  { TFBClientAPI }

  TFBClientAPI = class(TFBInterfacedObject)
  private
    FOwnsIBLibrary: boolean;
    class var FIBCS: TRTLCriticalSection;
    procedure LoadIBLibrary;
  protected
    class var FFBLibraryName: string;
    class var IBLibrary: TLibHandle;
    {$IFDEF WINDOWS}
    class var FFBLibraryPath: string;
    {$ENDIF}
    function GetProcAddr(ProcName: PAnsiChar): Pointer;
    function GetOverrideLibName: string;
    {$IFDEF UNIX}
    function GetFirebirdLibList: string; virtual; abstract;
    {$ENDIF}
    procedure LoadInterface; virtual;
  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;
    destructor Destroy; override;
    procedure IBAlloc(var P; OldSize, NewSize: Integer);
    procedure IBDataBaseError;
    procedure SetupEnvironment;

    {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 GetLibraryName: string;
end;

var FirebirdClientAPI: TFBClientAPI = nil;

implementation

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

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

  {$IFDEF Unix}
  {SetEnvironmentVariable doesn't exist so we have to use C Library}
  function setenv(name:Pchar; value:Pchar; replace:integer):integer;cdecl;external clib name 'setenv';
  function unsetenv(name:Pchar):integer;cdecl;external clib name 'unsetenv';
  function SetEnvironmentVariable(name:PAnsiChar; value:PAnsiChar):boolean;
  // Set environment variable; if empty string given, remove it.
  begin
    result:=false; //assume failure
    if value = '' then
    begin
      // Assume user wants to remove variable.
      if unsetenv(name)=0 then result:=true;
    end
    else
    begin
      // Non empty so set the variable
      if setenv(name, value, 1)=0 then result:=true;
    end;
  end;
  {$ENDIF}

{ TFBClientAPI }

constructor TFBClientAPI.Create;
begin
  inherited Create;
  LoadIBLibrary;
  if (IBLibrary <> NilHandle) then
  begin
    SetupEnvironment;
    LoadInterface;
  end;
  FirebirdClientAPI := self;
end;

destructor TFBClientAPI.Destroy;
begin
  FirebirdClientAPI := nil;
  if FOwnsIBLibrary and (IBLibrary <> NilHandle) then
    FreeLibrary(IBLibrary);
  IBLibrary := NilHandle;
  inherited Destroy;
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.SetupEnvironment;
var TmpDir: AnsiString;
begin
  {$IFDEF UNIX}
    TmpDir := GetTempDir +
        DirectorySeparator + 'firebird_' + sysutils.GetEnvironmentVariable('USER');
    if sysutils.GetEnvironmentVariable('FIREBIRD_TMP') = '' then
    begin
      if not DirectoryExists(tmpDir) then
        mkdir(tmpDir);
      SetEnvironmentVariable('FIREBIRD_TMP',PAnsiChar(TmpDir));
    end;
    if sysutils.GetEnvironmentVariable('FIREBIRD_LOCK') = '' then
    begin
      if not DirectoryExists(tmpDir) then
        mkdir(tmpDir);
      SetEnvironmentVariable('FIREBIRD_LOCK',PAnsiChar(TmpDir));
    end;
  {$ENDIF}
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.IsLibraryLoaded: boolean;
begin
  Result := IBLibrary <> NilHandle;
end;

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

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

procedure TFBClientAPI.LoadInterface;
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}
end;

function TFBClientAPI.GetLibraryName: string;
begin
  Result := FFBLibraryName;
end;

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

{ 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
  TFBClientAPI.IBLibrary := NilHandle;
  {$IFNDEF FPC}
  InitializeCriticalSection(TFBClientAPI.FIBCS);
  {$ELSE}
  InitCriticalSection(TFBClientAPI.FIBCS);
  {$ENDIF}

finalization
  {$IFNDEF FPC}
  DeleteCriticalSection(TFBClientAPI.FIBCS);
  {$ELSE}
  DoneCriticalSection(TFBClientAPI.FIBCS);
  {$ENDIF}
  if TFBClientAPI.IBLibrary <> NilHandle then
  begin
    FreeLibrary(TFBClientAPI.IBLibrary);
    TFBClientAPI.IBLibrary := NilHandle;
    TFBClientAPI.FFBLibraryName := '';
  end;

end.

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