client/3.0/FB30ClientAPI.pas

(*
 *  Firebird Interface (fbintf). The fbintf components provide a set of
 *  Pascal language bindings for the Firebird API.
 *
 *  The 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): ______________________________________.
 *
*)
unit FB30ClientAPI;
{$IFDEF MSWINDOWS} 
{$DEFINE WINDOWS} 
{$ENDIF}

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

interface

uses
  Classes, SysUtils, FBClientAPI, Firebird, IB, IBExternals, FmtBCD, FBClientLib;

type

  { TFB30Status }

  TFB30Status = class(TFBStatus,IStatus)
  private
    FStatus: Firebird.IStatus;
  public
    procedure Init;
    function InErrorState: boolean;
    function GetStatus: Firebird.IStatus;
    function StatusVector: PStatusVector; override;
  end;

  { TFB30StatusObject }

  TFB30StatusObject = class(TFB30Status)
  public
    constructor Create(aOwner: TFBClientAPI; status: Firebird.IStatus);
  end;

  Tfb_get_master_interface = function: IMaster;
                              {$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}

  { TFB30ClientAPI }

  TFB30ClientAPI = class(TFBClientAPI,IFirebirdAPI,IFBIMasterProvider)
  private
    FMaster: Firebird.IMaster;
    FUtil: Firebird.IUtil;
    FProvider: Firebird.IProvider;
    FConfigManager: Firebird.IConfigManager;
    FStatus: TFB30Status;
    FIsEmbeddedServer: boolean;
    FStatusIntf: IStatus;   {Keep a reference to the interface - automatic destroy
                             when this class is freed and last reference to IStatus
                             goes out of scope.}
    procedure CheckPlugins;
  public
    constructor Create(aFBLibrary: TFBLibrary);
    destructor Destroy; override;

    function StatusIntf: Firebird.IStatus;
    procedure Check4DataBaseError;
    function InErrorState: boolean;
    function LoadInterface: boolean; override;
    procedure FBShutdown; override;
    function GetAPI: IFirebirdAPI; override;
    {$IFDEF UNIX}
    function GetFirebirdLibList: string; override;
    {$ENDIF}

  public
    {IFirebirdAPI}
    function GetStatus: IStatus; override;
    function AllocateDPB: IDPB;
    function AllocateTPB: ITPB;

    {Database connections}
    function OpenDatabase(DatabaseName: AnsiString; DPB: IDPB; RaiseExceptionOnConnectError: boolean=true): IAttachment;
    function CreateDatabase(DatabaseName: AnsiString; DPB: IDPB; RaiseExceptionOnError: boolean=true): IAttachment; overload;
    function CreateDatabase(sql: AnsiString; aSQLDialect: integer; RaiseExceptionOnError: boolean=true): IAttachment; overload;
    {Start Transaction against multiple databases}
    function StartTransaction(Attachments: array of IAttachment;
             TPB: array of byte; DefaultCompletion: TTransactionCompletion): ITransaction; overload;
    function StartTransaction(Attachments: array of IAttachment;
             TPB: ITPB; DefaultCompletion: TTransactionCompletion): ITransaction; overload;

    {Service Manager}
    function AllocateSPB: ISPB;
    function GetServiceManager(ServerName: AnsiString; Protocol: TProtocol; SPB: ISPB): IServiceManager; overload;
    function GetServiceManager(ServerName: AnsiString; Port: Ansistring; Protocol: TProtocol; SPB: ISPB): IServiceManager; overload;

    {Information}
    function HasServiceAPI: boolean;
    function HasRollbackRetaining: boolean;
    function IsEmbeddedServer: boolean; override;
    function GetClientMajor: integer; override;
    function GetClientMinor: integer; override;
    function HasLocalTZDB: boolean; override;
    function HasTimeZoneSupport: boolean; override;
    function HasExtendedTZSupport: boolean; override;
    function HasInt128Support: boolean; override;

    {Firebird 3 API}
    function HasMasterIntf: boolean;
    function GetIMaster: TObject;

    {IFBIMasterProvider}
    function GetIMasterIntf: Firebird.IMaster;

    {Encode/Decode}
    function DecodeInteger(bufptr: PByte; len: short): integer; override;
    procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte); override;
    function SQLDecodeDate(bufptr: PByte): TDateTime; override;
    procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte); override;
    function SQLDecodeTime(bufptr: PByte): TDateTime;  override;
    procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte); override;
    function SQLDecodeDateTime(bufptr: PByte): TDateTime; override;
    function FormatStatus(Status: TFBStatus): AnsiString; override;

    {Firebird 4 Extensions}
    procedure SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal; bufptr: PByte);
      override;
    function SQLDecFloatDecode(SQLType: cardinal; bufptr: PByte): tBCD; override;
    function Int128ToStr(bufptr: PByte; scale: integer): AnsiString; override;
    procedure StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte); override;

    {Firebird Interfaces}
    property MasterIntf: Firebird.IMaster read FMaster;
    property UtilIntf: Firebird.IUtil read FUtil;
    property ProviderIntf: Firebird.IProvider read FProvider;

  end;

implementation

uses FB30Attachment, {$IFDEF FPC}dynlibs{$ELSE} windows{$ENDIF},
     FBMessages, FB30Services, FB30Transaction, IBUtils, DateUtils,
     FBAttachment, FBTransaction, FBServices;

type
  PISC_DATE = ^ISC_DATE;
  PISC_TIME = ^ISC_TIME;

{ TFB30StatusObject }

constructor TFB30StatusObject.Create(aOwner: TFBClientAPI;
  status: Firebird.IStatus);
begin
  inherited Create(aOwner);
  FStatus := status;
end;

{ TFB30Status }

procedure TFB30Status.Init;
begin
  if assigned(FStatus) then
    FStatus.Init;
end;

function TFB30Status.InErrorState: boolean;
begin
  with GetStatus do
    Result := ((getState and STATE_ERRORS) <> 0);
end;

function TFB30Status.GetStatus: Firebird.IStatus;
begin
  if FStatus = nil then
  with FOwner do
    FStatus := (FOwner as TFB30ClientAPI).MasterIntf.GetStatus;
  Result := FStatus;
end;

function TFB30Status.StatusVector: PStatusVector;
begin
  Result := PStatusVector(GetStatus.getErrors);
end;

{ TFB30ClientAPI }

procedure TFB30ClientAPI.CheckPlugins;
var FBConf: Firebird.IFirebirdConf;
    Plugins: AnsiString;
    PluginsList: TStringList;
begin
  FIsEmbeddedServer := false;
  FBConf := FConfigManager.getFirebirdConf;
  try
    Plugins := FBConf.asString(FBConf.getKey('Providers'));
  finally
    FBConf.release;
  end;
  if Plugins = '' then Exit;

  PluginsList := TStringList.Create;
  try
    PluginsList.CommaText := Plugins;
    FIsEmbeddedServer := (PluginsList.IndexOf('Engine12') <> -1) or {Firebird 3}
                         (PluginsList.IndexOf('Engine13') <> -1); {Firebird 4}
  finally
    PluginsList.Free;
  end;
end;

{$IFDEF UNIX}
function TFB30ClientAPI.GetFirebirdLibList: string;
begin
  Result := 'libfbclient.so:libfbclient.so.2';
end;
{$ENDIF}

function TFB30ClientAPI.LoadInterface: boolean;
var
  fb_get_master_interface: Tfb_get_master_interface;
begin
  Result := inherited LoadInterface;
  fb_get_master_interface := GetProcAddress(GetFBLibrary.GetHandle, 'fb_get_master_interface'); {do not localize}
  if assigned(fb_get_master_interface) then
  begin
    FMaster := fb_get_master_interface;
    FUtil := FMaster.getUtilInterface;
    FProvider := FMaster.getDispatcher;
    FConfigManager := FMaster.getConfigManager;
    CheckPlugins;
  end;
  Result := Result and HasMasterIntf;
end;

procedure TFB30ClientAPI.FBShutdown;
begin
  if assigned(fb_shutdown) and assigned(FProvider) then
  begin
    FProvider.release;
    FProvider := nil;
  end;
  inherited;
end;

function TFB30ClientAPI.GetAPI: IFirebirdAPI;
begin
  Result := self;
end;

constructor TFB30ClientAPI.Create(aFBLibrary: TFBLibrary);
begin
  inherited Create(aFBLibrary);
  FStatus := TFB30Status.Create(self);
  FStatusIntf := FStatus;
end;

destructor TFB30ClientAPI.Destroy;
begin
  if assigned(FProvider) then
    FProvider.release;
  inherited Destroy;
end;

function TFB30ClientAPI.StatusIntf: Firebird.IStatus;
begin
  Result := FStatus.GetStatus;
  Result.Init;
end;

procedure TFB30ClientAPI.Check4DataBaseError;
begin
  if FStatus.InErrorState then
    IBDataBaseError;
end;

function TFB30ClientAPI.InErrorState: boolean;
begin
  Result := FStatus.InErrorState;
end;

function TFB30ClientAPI.GetStatus: IStatus;
begin
  Result := FStatusIntf;
end;

function TFB30ClientAPI.AllocateDPB: IDPB;
begin
  Result := TDPB.Create(self);
end;

function TFB30ClientAPI.AllocateTPB: ITPB;
begin
  Result := TTPB.Create(self);
end;

function TFB30ClientAPI.OpenDatabase(DatabaseName: AnsiString; DPB: IDPB;
  RaiseExceptionOnConnectError: boolean): IAttachment;
begin
  Result := TFB30Attachment.Create(self,DatabaseName, DPB, RaiseExceptionOnConnectError);
  if not Result.IsConnected then
    Result := nil;
end;

function TFB30ClientAPI.CreateDatabase(DatabaseName: AnsiString; DPB: IDPB;
  RaiseExceptionOnError: boolean): IAttachment;
begin
  Result := TFB30Attachment.CreateDatabase(self,DatabaseName,DPB, RaiseExceptionOnError);
  if not Result.IsConnected then
    Result := nil;
end;

function TFB30ClientAPI.CreateDatabase(sql: AnsiString; aSQLDialect: integer;
  RaiseExceptionOnError: boolean): IAttachment;
begin
  Result := TFB30Attachment.CreateDatabase(self,sql,aSQLDialect, RaiseExceptionOnError);
  if not Result.IsConnected then
    Result := nil;
end;

function TFB30ClientAPI.StartTransaction(Attachments: array of IAttachment;
  TPB: array of byte; DefaultCompletion: TTransactionCompletion): ITransaction;
begin
  Result := TFB30Transaction.Create(self,Attachments,TPB,DefaultCompletion);
end;

function TFB30ClientAPI.StartTransaction(Attachments: array of IAttachment;
  TPB: ITPB; DefaultCompletion: TTransactionCompletion): ITransaction;
begin
  Result := TFB30Transaction.Create(self,Attachments,TPB,DefaultCompletion);
end;

function TFB30ClientAPI.AllocateSPB: ISPB;
begin
  Result := TSPB.Create(self);
end;

function TFB30ClientAPI.GetServiceManager(ServerName: AnsiString;
  Protocol: TProtocol; SPB: ISPB): IServiceManager;
begin
  Result := TFB30ServiceManager.Create(self,ServerName,Protocol,SPB);
end;

function TFB30ClientAPI.GetServiceManager(ServerName: AnsiString;
  Port: Ansistring; Protocol: TProtocol; SPB: ISPB): IServiceManager;
begin
  Result := TFB30ServiceManager.Create(self,ServerName,Protocol,SPB,Port);
end;

function TFB30ClientAPI.HasServiceAPI: boolean;
begin
  Result := true;
end;

function TFB30ClientAPI.HasMasterIntf: boolean;
begin
  Result := MasterIntf <> nil;
end;

function TFB30ClientAPI.GetIMaster: TObject;
begin
  Result := FMaster;
end;

function TFB30ClientAPI.GetIMasterIntf: Firebird.IMaster;
begin
  Result := FMaster;
end;

function TFB30ClientAPI.HasRollbackRetaining: boolean;
begin
  Result := true;
end;

function TFB30ClientAPI.IsEmbeddedServer: boolean;
begin
  Result := FIsEmbeddedServer;
end;

function TFB30ClientAPI.GetClientMajor: integer;
begin
  Result := UtilIntf.GetClientVersion div 256;
end;

function TFB30ClientAPI.GetClientMinor: integer;
begin
  Result := UtilIntf.GetClientVersion mod 256;
end;

function TFB30ClientAPI.DecodeInteger(bufptr: PByte; len: short): integer;
var P: PByte;
begin
  Result := 0;
  P := Bufptr + len - 1;
  while P >= bufptr do
  begin
    Result := (Result shl 8 ) or P^;
    Dec(P);
  end;
end;

procedure TFB30ClientAPI.SQLEncodeDate(aDate: TDateTime; bufptr: PByte);
var
  Yr, Mn, Dy: Word;
begin
   DecodeDate(aDate, Yr, Mn, Dy);
   PISC_Date(Bufptr)^ := UtilIntf.encodeDate(Yr, Mn, Dy);
end;

function TFB30ClientAPI.SQLDecodeDate(bufptr: PByte): TDateTime;
var
  Yr, Mn, Dy: cardinal;
begin
  UtilIntf.decodeDate(PISC_DATE(bufptr)^,@Yr, @Mn, @Dy);
  try
    result := EncodeDate(Yr, Mn,Dy);
  except
    on E: EConvertError do begin
      IBError(ibxeInvalidDataConversion, [nil]);
    end;
  end;
end;

procedure TFB30ClientAPI.SQLEncodeTime(aTime: TDateTime; bufptr: PByte);
var
  Hr, Mt, S: word;
  DMs: cardinal;
begin
  FBDecodeTime(aTime,Hr, Mt, S, DMs);
  PISC_TIME(bufptr)^ :=  UtilIntf.encodeTime(Hr, Mt, S, DMs);
end;

function TFB30ClientAPI.SQLDecodeTime(bufptr: PByte): TDateTime;
var
  Hr, Mt, S, DMs: cardinal;
begin
  UtilIntf.decodeTime(PISC_TIME(bufptr)^,@Hr, @Mt, @S, @DMs);
  try
    Result := FBEncodeTime(Hr, Mt, S, DMs);
  except
    on E: EConvertError do begin
      IBError(ibxeInvalidDataConversion, [nil]);
    end;
  end;
end;

procedure TFB30ClientAPI.SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte);
begin
  SQLEncodeDate(aDateTime,bufPtr);
  Inc(bufptr,sizeof(ISC_DATE));
  SQLEncodeTime(aDateTime,bufPtr);
end;

function TFB30ClientAPI.SQLDecodeDateTime(bufptr: PByte): TDateTime;
begin
  Result := SQLDecodeDate(bufPtr);
  Inc(bufptr,sizeof(ISC_DATE));
  Result := Result + SQLDecodeTime(bufPtr);
end;

function TFB30ClientAPI.FormatStatus(Status: TFBStatus): AnsiString;
var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
begin
  Result := '';
  if UtilIntf.formatStatus(@local_buffer,sizeof(local_buffer),(Status as TFB30Status).GetStatus) > 0 then
    Result := strpas(local_buffer);
end;

procedure TFB30ClientAPI.SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal;
  bufptr: PByte);
var DecFloat16: IDecFloat16;
    DecFloat34: IDecFloat34;
    sign: integer;
    exp: integer;
    buffer: array [1..34] of byte;

    procedure UnpackBuffer(width: integer);
    var i,j: integer;
    begin
      Fillchar(buffer,sizeof(buffer),0);
      if BCDPrecision(aValue) > width then
        IBError(ibxeBCDTooBig,[BCDPrecision(aValue),width]);
      j := 1 + (width - aValue.Precision);
      for i := 0 to (aValue.Precision - 1) div 2 do
      if j <= width then
      begin
          buffer[j] := (aValue.Fraction[i] and $f0) shr 4;
          Inc(j);
          if j <= width then
          begin
            buffer[j] := (aValue.Fraction[i] and $0f);
            Inc(j);
          end;
      end;
      {writeln('Precision = ',aValue.Precision,' Places = ',aValue.SignSpecialPlaces and $2f);
      write('BCD Buffer = ');
      for i := 1 to 34 do
        write(buffer[i],' ');
      writeln; }
    end;

begin
  inherited SQLDecFloatEncode(aValue, SQLType, bufptr);
  sign := (aValue.SignSpecialPlaces and $80) shr 7;
  exp := -(aValue.SignSpecialPlaces and $2f);

  case SQLType of
  SQL_DEC16:
    begin
      UnPackbuffer(16);
      DecFloat16 := UtilIntf.getDecFloat16(StatusIntf);
      Check4DataBaseError;
      DecFloat16.fromBcd(sign,@buffer,exp,FB_DEC16Ptr(bufptr));
      Check4DataBaseError;
    end;

  SQL_DEC34:
    begin
      UnPackbuffer(34);
      DecFloat34 := UtilIntf.getDecFloat34(StatusIntf);
      Check4DataBaseError;
      DecFloat34.fromBcd(sign,@buffer,exp,FB_DEC34Ptr(bufptr));
      Check4DataBaseError;
    end;

  else
    IBError(ibxeInvalidDataConversion,[]);
  end;
end;

function TFB30ClientAPI.SQLDecFloatDecode(SQLType: cardinal; bufptr: PByte): tBCD;

var DecFloat16: IDecFloat16;
    DecFloat34: IDecFloat34;
    sign: integer;
    exp: integer;
    buffer: array [1..38] of byte;

  procedure packbuffer(buflen: integer);
  var i,j: integer;
  begin
{    write('Decode: BCD Buffer = ');
    for i := 1 to 34 do
      write(buffer[i],' ');
    writeln; }
    {pack buffer}
    i := 1;
    while (i <= buflen) and (buffer[i] = 0) do  {skip leading zeroes}
      inc(i);

    j := 0;
    Result.Precision := 0;
    while i <= buflen do
    begin
      inc(Result.Precision);
      if odd(Result.Precision) then
        Result.Fraction[j] := (buffer[i] and $0f) shl 4
      else
      begin
        Result.Fraction[j] := Result.Fraction[j] or (buffer[i] and $0f);
        Inc(j);
      end;
      inc(i);
    end;
  end;

begin
  Result := inherited SQLDecFloatDecode(SQLType, bufptr);
  FillChar(Result, sizeof(tBCD),0);
  case SQLType of
  SQL_DEC16:
    begin
      DecFloat16 := UtilIntf.getDecFloat16(StatusIntf);
      Check4DataBaseError;
      DecFloat16.toBcd(FB_DEC16Ptr(bufptr),@sign,@buffer,@exp);
      Check4DataBaseError;
      packbuffer(16);
    end;

  SQL_DEC34:
    begin
      DecFloat34 := UtilIntf.getDecFloat34(StatusIntf);
      Check4DataBaseError;
      DecFloat34.toBcd(FB_DEC34Ptr(bufptr),@sign,@buffer,@exp);
      Check4DataBaseError;
      packbuffer(34);
    end;

  else
    IBError(ibxeInvalidDataConversion,[]);
  end;
  Result.SignSpecialPlaces :=  (-exp and $2f);
  if sign <> 0 then
    Result.SignSpecialPlaces := Result.SignSpecialPlaces or $80;
end;

procedure TFB30ClientAPI.StrToInt128(scale: integer; aValue: AnsiString;
  bufptr: PByte);
begin
  inherited StrToInt128(scale,aValue,bufPtr);

  UtilIntf.getInt128(StatusIntf).fromString(StatusIntf,scale,PAnsiChar(aValue),FB_I128Ptr(bufptr));
  Check4DatabaseError;
end;

function TFB30ClientAPI.Int128ToStr(bufptr: PByte; scale: integer
  ): AnsiString;
const
  bufLength = 64;
var Buffer: array[ 0.. bufLength] of AnsiChar;
begin
  Result := inherited Int128ToStr(bufPtr,scale);

  UtilIntf.getInt128(StatusIntf).toString(StatusIntf,FB_I128Ptr(bufptr),scale,buflength,PAnsiChar(@Buffer));
  Check4DatabaseError;
  Result := strpas(PAnsiChar(@Buffer));
end;

function TFB30ClientAPI.HasLocalTZDB: boolean;
const
  bufLength = 128;
var Buffer: ISC_TIME_TZ;
    Hr, Mt, S, DMs: cardinal;
    tzBuffer: array[ 0.. bufLength] of AnsiChar;
begin
  Result := HasTimeZoneSupport;
  if Result then
  begin
    Buffer.utc_time := 0;
    Buffer.time_zone := TimeZoneID_GMT;
    UtilIntf.decodeTimeTz(StatusIntf, ISC_TIME_TZPtr(@Buffer),@Hr, @Mt, @S, @DMs,bufLength,PAnsiChar(@tzBuffer));
    Check4DataBaseError;
    Result := strpas(PAnsiChar(@tzBuffer)) <> 'GMT*';
  end;
end;

function TFB30ClientAPI.HasTimeZoneSupport: boolean;
begin
  Result := GetClientMajor >=4;
end;

function TFB30ClientAPI.HasExtendedTZSupport: boolean;
begin
  Result :=  (GetClientMajor >=4) and (UtilIntf.vtable.version >= 4) {ignore FB4 Beta1}
end;

function TFB30ClientAPI.HasInt128Support: boolean;
begin
  Result := (GetClientMajor >=4) and (UtilIntf.vtable.version >= 4) {ignore FB4 Beta1} ;
end;

end.


Revision:	315
Committed:	Thu Feb 25 11:56:36 2021 UTC (3 years, 1 month ago) by tony
Content type:	text/x-pascal
File size:	18530 byte(s)
Log Message:	Updated for IBX 4 release
#	Content
1	(*
2	* Firebird Interface (fbintf). The fbintf components provide a set of
3	* Pascal language bindings for the Firebird API.
4	*
5	* The contents of this file are subject to the Initial Developer's
6	* Public License Version 1.0 (the "License"); you may not use this
7	* file except in compliance with the License. You may obtain a copy
8	* of the License here:
9	*
10	* http://www.firebirdsql.org/index.php?op=doc&id=idpl
11	*
12	* Software distributed under the License is distributed on an "AS
13	* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
14	* implied. See the License for the specific language governing rights
15	* and limitations under the License.
16	*
17	* The Initial Developer of the Original Code is Tony Whyman.
18	*
19	* The Original Code is (C) 2016 Tony Whyman, MWA Software
20	* (http://www.mwasoftware.co.uk).
21	*
22	* All Rights Reserved.
23	*
24	* Contributor(s): ______________________________________.
25	*
26	*)
27	unit FB30ClientAPI;
28	{$IFDEF MSWINDOWS}
29	{$DEFINE WINDOWS}
30	{$ENDIF}
31
32	{$IFDEF FPC}
33	{$mode delphi}
34	{$interfaces COM}
35	{$ENDIF}
36
37	interface
38
39	uses
40	Classes, SysUtils, FBClientAPI, Firebird, IB, IBExternals, FmtBCD, FBClientLib;
41
42	type
43
44	{ TFB30Status }
45
46	TFB30Status = class(TFBStatus,IStatus)
47	private
48	FStatus: Firebird.IStatus;
49	public
50	procedure Init;
51	function InErrorState: boolean;
52	function GetStatus: Firebird.IStatus;
53	function StatusVector: PStatusVector; override;
54	end;
55
56	{ TFB30StatusObject }
57
58	TFB30StatusObject = class(TFB30Status)
59	public
60	constructor Create(aOwner: TFBClientAPI; status: Firebird.IStatus);
61	end;
62
63	Tfb_get_master_interface = function: IMaster;
64	{$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
65
66	{ TFB30ClientAPI }
67
68	TFB30ClientAPI = class(TFBClientAPI,IFirebirdAPI,IFBIMasterProvider)
69	private
70	FMaster: Firebird.IMaster;
71	FUtil: Firebird.IUtil;
72	FProvider: Firebird.IProvider;
73	FConfigManager: Firebird.IConfigManager;
74	FStatus: TFB30Status;
75	FIsEmbeddedServer: boolean;
76	FStatusIntf: IStatus; {Keep a reference to the interface - automatic destroy
77	when this class is freed and last reference to IStatus
78	goes out of scope.}
79	procedure CheckPlugins;
80	public
81	constructor Create(aFBLibrary: TFBLibrary);
82	destructor Destroy; override;
83
84	function StatusIntf: Firebird.IStatus;
85	procedure Check4DataBaseError;
86	function InErrorState: boolean;
87	function LoadInterface: boolean; override;
88	procedure FBShutdown; override;
89	function GetAPI: IFirebirdAPI; override;
90	{$IFDEF UNIX}
91	function GetFirebirdLibList: string; override;
92	{$ENDIF}
93
94	public
95	{IFirebirdAPI}
96	function GetStatus: IStatus; override;
97	function AllocateDPB: IDPB;
98	function AllocateTPB: ITPB;
99
100	{Database connections}
101	function OpenDatabase(DatabaseName: AnsiString; DPB: IDPB; RaiseExceptionOnConnectError: boolean=true): IAttachment;
102	function CreateDatabase(DatabaseName: AnsiString; DPB: IDPB; RaiseExceptionOnError: boolean=true): IAttachment; overload;
103	function CreateDatabase(sql: AnsiString; aSQLDialect: integer; RaiseExceptionOnError: boolean=true): IAttachment; overload;
104	{Start Transaction against multiple databases}
105	function StartTransaction(Attachments: array of IAttachment;
106	TPB: array of byte; DefaultCompletion: TTransactionCompletion): ITransaction; overload;
107	function StartTransaction(Attachments: array of IAttachment;
108	TPB: ITPB; DefaultCompletion: TTransactionCompletion): ITransaction; overload;
109
110	{Service Manager}
111	function AllocateSPB: ISPB;
112	function GetServiceManager(ServerName: AnsiString; Protocol: TProtocol; SPB: ISPB): IServiceManager; overload;
113	function GetServiceManager(ServerName: AnsiString; Port: Ansistring; Protocol: TProtocol; SPB: ISPB): IServiceManager; overload;
114
115	{Information}
116	function HasServiceAPI: boolean;
117	function HasRollbackRetaining: boolean;
118	function IsEmbeddedServer: boolean; override;
119	function GetClientMajor: integer; override;
120	function GetClientMinor: integer; override;
121	function HasLocalTZDB: boolean; override;
122	function HasTimeZoneSupport: boolean; override;
123	function HasExtendedTZSupport: boolean; override;
124	function HasInt128Support: boolean; override;
125
126	{Firebird 3 API}
127	function HasMasterIntf: boolean;
128	function GetIMaster: TObject;
129
130	{IFBIMasterProvider}
131	function GetIMasterIntf: Firebird.IMaster;
132
133	{Encode/Decode}
134	function DecodeInteger(bufptr: PByte; len: short): integer; override;
135	procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte); override;
136	function SQLDecodeDate(bufptr: PByte): TDateTime; override;
137	procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte); override;
138	function SQLDecodeTime(bufptr: PByte): TDateTime; override;
139	procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte); override;
140	function SQLDecodeDateTime(bufptr: PByte): TDateTime; override;
141	function FormatStatus(Status: TFBStatus): AnsiString; override;
142
143	{Firebird 4 Extensions}
144	procedure SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal; bufptr: PByte);
145	override;
146	function SQLDecFloatDecode(SQLType: cardinal; bufptr: PByte): tBCD; override;
147	function Int128ToStr(bufptr: PByte; scale: integer): AnsiString; override;
148	procedure StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte); override;
149
150	{Firebird Interfaces}
151	property MasterIntf: Firebird.IMaster read FMaster;
152	property UtilIntf: Firebird.IUtil read FUtil;
153	property ProviderIntf: Firebird.IProvider read FProvider;
154
155	end;
156
157	implementation
158
159	uses FB30Attachment, {$IFDEF FPC}dynlibs{$ELSE} windows{$ENDIF},
160	FBMessages, FB30Services, FB30Transaction, IBUtils, DateUtils,
161	FBAttachment, FBTransaction, FBServices;
162
163	type
164	PISC_DATE = ^ISC_DATE;
165	PISC_TIME = ^ISC_TIME;
166
167	{ TFB30StatusObject }
168
169	constructor TFB30StatusObject.Create(aOwner: TFBClientAPI;
170	status: Firebird.IStatus);
171	begin
172	inherited Create(aOwner);
173	FStatus := status;
174	end;
175
176	{ TFB30Status }
177
178	procedure TFB30Status.Init;
179	begin
180	if assigned(FStatus) then
181	FStatus.Init;
182	end;
183
184	function TFB30Status.InErrorState: boolean;
185	begin
186	with GetStatus do
187	Result := ((getState and STATE_ERRORS) <> 0);
188	end;
189
190	function TFB30Status.GetStatus: Firebird.IStatus;
191	begin
192	if FStatus = nil then
193	with FOwner do
194	FStatus := (FOwner as TFB30ClientAPI).MasterIntf.GetStatus;
195	Result := FStatus;
196	end;
197
198	function TFB30Status.StatusVector: PStatusVector;
199	begin
200	Result := PStatusVector(GetStatus.getErrors);
201	end;
202
203	{ TFB30ClientAPI }
204
205	procedure TFB30ClientAPI.CheckPlugins;
206	var FBConf: Firebird.IFirebirdConf;
207	Plugins: AnsiString;
208	PluginsList: TStringList;
209	begin
210	FIsEmbeddedServer := false;
211	FBConf := FConfigManager.getFirebirdConf;
212	try
213	Plugins := FBConf.asString(FBConf.getKey('Providers'));
214	finally
215	FBConf.release;
216	end;
217	if Plugins = '' then Exit;
218
219	PluginsList := TStringList.Create;
220	try
221	PluginsList.CommaText := Plugins;
222	FIsEmbeddedServer := (PluginsList.IndexOf('Engine12') <> -1) or {Firebird 3}
223	(PluginsList.IndexOf('Engine13') <> -1); {Firebird 4}
224	finally
225	PluginsList.Free;
226	end;
227	end;
228
229	{$IFDEF UNIX}
230	function TFB30ClientAPI.GetFirebirdLibList: string;
231	begin
232	Result := 'libfbclient.so:libfbclient.so.2';
233	end;
234	{$ENDIF}
235
236	function TFB30ClientAPI.LoadInterface: boolean;
237	var
238	fb_get_master_interface: Tfb_get_master_interface;
239	begin
240	Result := inherited LoadInterface;
241	fb_get_master_interface := GetProcAddress(GetFBLibrary.GetHandle, 'fb_get_master_interface'); {do not localize}
242	if assigned(fb_get_master_interface) then
243	begin
244	FMaster := fb_get_master_interface;
245	FUtil := FMaster.getUtilInterface;
246	FProvider := FMaster.getDispatcher;
247	FConfigManager := FMaster.getConfigManager;
248	CheckPlugins;
249	end;
250	Result := Result and HasMasterIntf;
251	end;
252
253	procedure TFB30ClientAPI.FBShutdown;
254	begin
255	if assigned(fb_shutdown) and assigned(FProvider) then
256	begin
257	FProvider.release;
258	FProvider := nil;
259	end;
260	inherited;
261	end;
262
263	function TFB30ClientAPI.GetAPI: IFirebirdAPI;
264	begin
265	Result := self;
266	end;
267
268	constructor TFB30ClientAPI.Create(aFBLibrary: TFBLibrary);
269	begin
270	inherited Create(aFBLibrary);
271	FStatus := TFB30Status.Create(self);
272	FStatusIntf := FStatus;
273	end;
274
275	destructor TFB30ClientAPI.Destroy;
276	begin
277	if assigned(FProvider) then
278	FProvider.release;
279	inherited Destroy;
280	end;
281
282	function TFB30ClientAPI.StatusIntf: Firebird.IStatus;
283	begin
284	Result := FStatus.GetStatus;
285	Result.Init;
286	end;
287
288	procedure TFB30ClientAPI.Check4DataBaseError;
289	begin
290	if FStatus.InErrorState then
291	IBDataBaseError;
292	end;
293
294	function TFB30ClientAPI.InErrorState: boolean;
295	begin
296	Result := FStatus.InErrorState;
297	end;
298
299	function TFB30ClientAPI.GetStatus: IStatus;
300	begin
301	Result := FStatusIntf;
302	end;
303
304	function TFB30ClientAPI.AllocateDPB: IDPB;
305	begin
306	Result := TDPB.Create(self);
307	end;
308
309	function TFB30ClientAPI.AllocateTPB: ITPB;
310	begin
311	Result := TTPB.Create(self);
312	end;
313
314	function TFB30ClientAPI.OpenDatabase(DatabaseName: AnsiString; DPB: IDPB;
315	RaiseExceptionOnConnectError: boolean): IAttachment;
316	begin
317	Result := TFB30Attachment.Create(self,DatabaseName, DPB, RaiseExceptionOnConnectError);
318	if not Result.IsConnected then
319	Result := nil;
320	end;
321
322	function TFB30ClientAPI.CreateDatabase(DatabaseName: AnsiString; DPB: IDPB;
323	RaiseExceptionOnError: boolean): IAttachment;
324	begin
325	Result := TFB30Attachment.CreateDatabase(self,DatabaseName,DPB, RaiseExceptionOnError);
326	if not Result.IsConnected then
327	Result := nil;
328	end;
329
330	function TFB30ClientAPI.CreateDatabase(sql: AnsiString; aSQLDialect: integer;
331	RaiseExceptionOnError: boolean): IAttachment;
332	begin
333	Result := TFB30Attachment.CreateDatabase(self,sql,aSQLDialect, RaiseExceptionOnError);
334	if not Result.IsConnected then
335	Result := nil;
336	end;
337
338	function TFB30ClientAPI.StartTransaction(Attachments: array of IAttachment;
339	TPB: array of byte; DefaultCompletion: TTransactionCompletion): ITransaction;
340	begin
341	Result := TFB30Transaction.Create(self,Attachments,TPB,DefaultCompletion);
342	end;
343
344	function TFB30ClientAPI.StartTransaction(Attachments: array of IAttachment;
345	TPB: ITPB; DefaultCompletion: TTransactionCompletion): ITransaction;
346	begin
347	Result := TFB30Transaction.Create(self,Attachments,TPB,DefaultCompletion);
348	end;
349
350	function TFB30ClientAPI.AllocateSPB: ISPB;
351	begin
352	Result := TSPB.Create(self);
353	end;
354
355	function TFB30ClientAPI.GetServiceManager(ServerName: AnsiString;
356	Protocol: TProtocol; SPB: ISPB): IServiceManager;
357	begin
358	Result := TFB30ServiceManager.Create(self,ServerName,Protocol,SPB);
359	end;
360
361	function TFB30ClientAPI.GetServiceManager(ServerName: AnsiString;
362	Port: Ansistring; Protocol: TProtocol; SPB: ISPB): IServiceManager;
363	begin
364	Result := TFB30ServiceManager.Create(self,ServerName,Protocol,SPB,Port);
365	end;
366
367	function TFB30ClientAPI.HasServiceAPI: boolean;
368	begin
369	Result := true;
370	end;
371
372	function TFB30ClientAPI.HasMasterIntf: boolean;
373	begin
374	Result := MasterIntf <> nil;
375	end;
376
377	function TFB30ClientAPI.GetIMaster: TObject;
378	begin
379	Result := FMaster;
380	end;
381
382	function TFB30ClientAPI.GetIMasterIntf: Firebird.IMaster;
383	begin
384	Result := FMaster;
385	end;
386
387	function TFB30ClientAPI.HasRollbackRetaining: boolean;
388	begin
389	Result := true;
390	end;
391
392	function TFB30ClientAPI.IsEmbeddedServer: boolean;
393	begin
394	Result := FIsEmbeddedServer;
395	end;
396
397	function TFB30ClientAPI.GetClientMajor: integer;
398	begin
399	Result := UtilIntf.GetClientVersion div 256;
400	end;
401
402	function TFB30ClientAPI.GetClientMinor: integer;
403	begin
404	Result := UtilIntf.GetClientVersion mod 256;
405	end;
406
407	function TFB30ClientAPI.DecodeInteger(bufptr: PByte; len: short): integer;
408	var P: PByte;
409	begin
410	Result := 0;
411	P := Bufptr + len - 1;
412	while P >= bufptr do
413	begin
414	Result := (Result shl 8 ) or P^;
415	Dec(P);
416	end;
417	end;
418
419	procedure TFB30ClientAPI.SQLEncodeDate(aDate: TDateTime; bufptr: PByte);
420	var
421	Yr, Mn, Dy: Word;
422	begin
423	DecodeDate(aDate, Yr, Mn, Dy);
424	PISC_Date(Bufptr)^ := UtilIntf.encodeDate(Yr, Mn, Dy);
425	end;
426
427	function TFB30ClientAPI.SQLDecodeDate(bufptr: PByte): TDateTime;
428	var
429	Yr, Mn, Dy: cardinal;
430	begin
431	UtilIntf.decodeDate(PISC_DATE(bufptr)^,@Yr, @Mn, @Dy);
432	try
433	result := EncodeDate(Yr, Mn,Dy);
434	except
435	on E: EConvertError do begin
436	IBError(ibxeInvalidDataConversion, [nil]);
437	end;
438	end;
439	end;
440
441	procedure TFB30ClientAPI.SQLEncodeTime(aTime: TDateTime; bufptr: PByte);
442	var
443	Hr, Mt, S: word;
444	DMs: cardinal;
445	begin
446	FBDecodeTime(aTime,Hr, Mt, S, DMs);
447	PISC_TIME(bufptr)^ := UtilIntf.encodeTime(Hr, Mt, S, DMs);
448	end;
449
450	function TFB30ClientAPI.SQLDecodeTime(bufptr: PByte): TDateTime;
451	var
452	Hr, Mt, S, DMs: cardinal;
453	begin
454	UtilIntf.decodeTime(PISC_TIME(bufptr)^,@Hr, @Mt, @S, @DMs);
455	try
456	Result := FBEncodeTime(Hr, Mt, S, DMs);
457	except
458	on E: EConvertError do begin
459	IBError(ibxeInvalidDataConversion, [nil]);
460	end;
461	end;
462	end;
463
464	procedure TFB30ClientAPI.SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte);
465	begin
466	SQLEncodeDate(aDateTime,bufPtr);
467	Inc(bufptr,sizeof(ISC_DATE));
468	SQLEncodeTime(aDateTime,bufPtr);
469	end;
470
471	function TFB30ClientAPI.SQLDecodeDateTime(bufptr: PByte): TDateTime;
472	begin
473	Result := SQLDecodeDate(bufPtr);
474	Inc(bufptr,sizeof(ISC_DATE));
475	Result := Result + SQLDecodeTime(bufPtr);
476	end;
477
478	function TFB30ClientAPI.FormatStatus(Status: TFBStatus): AnsiString;
479	var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
480	begin
481	Result := '';
482	if UtilIntf.formatStatus(@local_buffer,sizeof(local_buffer),(Status as TFB30Status).GetStatus) > 0 then
483	Result := strpas(local_buffer);
484	end;
485
486	procedure TFB30ClientAPI.SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal;
487	bufptr: PByte);
488	var DecFloat16: IDecFloat16;
489	DecFloat34: IDecFloat34;
490	sign: integer;
491	exp: integer;
492	buffer: array [1..34] of byte;
493
494	procedure UnpackBuffer(width: integer);
495	var i,j: integer;
496	begin
497	Fillchar(buffer,sizeof(buffer),0);
498	if BCDPrecision(aValue) > width then
499	IBError(ibxeBCDTooBig,[BCDPrecision(aValue),width]);
500	j := 1 + (width - aValue.Precision);
501	for i := 0 to (aValue.Precision - 1) div 2 do
502	if j <= width then
503	begin
504	buffer[j] := (aValue.Fraction[i] and $f0) shr 4;
505	Inc(j);
506	if j <= width then
507	begin
508	buffer[j] := (aValue.Fraction[i] and $0f);
509	Inc(j);
510	end;
511	end;
512	{writeln('Precision = ',aValue.Precision,' Places = ',aValue.SignSpecialPlaces and $2f);
513	write('BCD Buffer = ');
514	for i := 1 to 34 do
515	write(buffer[i],' ');
516	writeln; }
517	end;
518
519	begin
520	inherited SQLDecFloatEncode(aValue, SQLType, bufptr);
521	sign := (aValue.SignSpecialPlaces and $80) shr 7;
522	exp := -(aValue.SignSpecialPlaces and $2f);
523
524	case SQLType of
525	SQL_DEC16:
526	begin
527	UnPackbuffer(16);
528	DecFloat16 := UtilIntf.getDecFloat16(StatusIntf);
529	Check4DataBaseError;
530	DecFloat16.fromBcd(sign,@buffer,exp,FB_DEC16Ptr(bufptr));
531	Check4DataBaseError;
532	end;
533
534	SQL_DEC34:
535	begin
536	UnPackbuffer(34);
537	DecFloat34 := UtilIntf.getDecFloat34(StatusIntf);
538	Check4DataBaseError;
539	DecFloat34.fromBcd(sign,@buffer,exp,FB_DEC34Ptr(bufptr));
540	Check4DataBaseError;
541	end;
542
543	else
544	IBError(ibxeInvalidDataConversion,[]);
545	end;
546	end;
547
548	function TFB30ClientAPI.SQLDecFloatDecode(SQLType: cardinal; bufptr: PByte): tBCD;
549
550	var DecFloat16: IDecFloat16;
551	DecFloat34: IDecFloat34;
552	sign: integer;
553	exp: integer;
554	buffer: array [1..38] of byte;
555
556	procedure packbuffer(buflen: integer);
557	var i,j: integer;
558	begin
559	{ write('Decode: BCD Buffer = ');
560	for i := 1 to 34 do
561	write(buffer[i],' ');
562	writeln; }
563	{pack buffer}
564	i := 1;
565	while (i <= buflen) and (buffer[i] = 0) do {skip leading zeroes}
566	inc(i);
567
568	j := 0;
569	Result.Precision := 0;
570	while i <= buflen do
571	begin
572	inc(Result.Precision);
573	if odd(Result.Precision) then
574	Result.Fraction[j] := (buffer[i] and $0f) shl 4
575	else
576	begin
577	Result.Fraction[j] := Result.Fraction[j] or (buffer[i] and $0f);
578	Inc(j);
579	end;
580	inc(i);
581	end;
582	end;
583
584	begin
585	Result := inherited SQLDecFloatDecode(SQLType, bufptr);
586	FillChar(Result, sizeof(tBCD),0);
587	case SQLType of
588	SQL_DEC16:
589	begin
590	DecFloat16 := UtilIntf.getDecFloat16(StatusIntf);
591	Check4DataBaseError;
592	DecFloat16.toBcd(FB_DEC16Ptr(bufptr),@sign,@buffer,@exp);
593	Check4DataBaseError;
594	packbuffer(16);
595	end;
596
597	SQL_DEC34:
598	begin
599	DecFloat34 := UtilIntf.getDecFloat34(StatusIntf);
600	Check4DataBaseError;
601	DecFloat34.toBcd(FB_DEC34Ptr(bufptr),@sign,@buffer,@exp);
602	Check4DataBaseError;
603	packbuffer(34);
604	end;
605
606	else
607	IBError(ibxeInvalidDataConversion,[]);
608	end;
609	Result.SignSpecialPlaces := (-exp and $2f);
610	if sign <> 0 then
611	Result.SignSpecialPlaces := Result.SignSpecialPlaces or $80;
612	end;
613
614	procedure TFB30ClientAPI.StrToInt128(scale: integer; aValue: AnsiString;
615	bufptr: PByte);
616	begin
617	inherited StrToInt128(scale,aValue,bufPtr);
618
619	UtilIntf.getInt128(StatusIntf).fromString(StatusIntf,scale,PAnsiChar(aValue),FB_I128Ptr(bufptr));
620	Check4DatabaseError;
621	end;
622
623	function TFB30ClientAPI.Int128ToStr(bufptr: PByte; scale: integer
624	): AnsiString;
625	const
626	bufLength = 64;
627	var Buffer: array[ 0.. bufLength] of AnsiChar;
628	begin
629	Result := inherited Int128ToStr(bufPtr,scale);
630
631	UtilIntf.getInt128(StatusIntf).toString(StatusIntf,FB_I128Ptr(bufptr),scale,buflength,PAnsiChar(@Buffer));
632	Check4DatabaseError;
633	Result := strpas(PAnsiChar(@Buffer));
634	end;
635
636	function TFB30ClientAPI.HasLocalTZDB: boolean;
637	const
638	bufLength = 128;
639	var Buffer: ISC_TIME_TZ;
640	Hr, Mt, S, DMs: cardinal;
641	tzBuffer: array[ 0.. bufLength] of AnsiChar;
642	begin
643	Result := HasTimeZoneSupport;
644	if Result then
645	begin
646	Buffer.utc_time := 0;
647	Buffer.time_zone := TimeZoneID_GMT;
648	UtilIntf.decodeTimeTz(StatusIntf, ISC_TIME_TZPtr(@Buffer),@Hr, @Mt, @S, @DMs,bufLength,PAnsiChar(@tzBuffer));
649	Check4DataBaseError;
650	Result := strpas(PAnsiChar(@tzBuffer)) <> 'GMT*';
651	end;
652	end;
653
654	function TFB30ClientAPI.HasTimeZoneSupport: boolean;
655	begin
656	Result := GetClientMajor >=4;
657	end;
658
659	function TFB30ClientAPI.HasExtendedTZSupport: boolean;
660	begin
661	Result := (GetClientMajor >=4) and (UtilIntf.vtable.version >= 4) {ignore FB4 Beta1}
662	end;
663
664	function TFB30ClientAPI.HasInt128Support: boolean;
665	begin
666	Result := (GetClientMajor >=4) and (UtilIntf.vtable.version >= 4) {ignore FB4 Beta1} ;
667	end;
668
669	end.
670
671