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, 2 months ago) by tony
Content type:	text/x-pascal
File size:	18530 byte(s)
Log Message:	Updated for IBX 4 release
#	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.
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	tony	56	{$IFDEF MSWINDOWS}
29			{$DEFINE WINDOWS}
30			{$ENDIF}
31	tony	45
32			{$IFDEF FPC}
33			{$mode delphi}
34			{$interfaces COM}
35			{$ENDIF}
36
37			interface
38
39			uses
40	tony	315	Classes, SysUtils, FBClientAPI, Firebird, IB, IBExternals, FmtBCD, FBClientLib;
41	tony	45
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	tony	315	{ TFB30StatusObject }
57
58			TFB30StatusObject = class(TFB30Status)
59			public
60			constructor Create(aOwner: TFBClientAPI; status: Firebird.IStatus);
61			end;
62
63	tony	45	Tfb_get_master_interface = function: IMaster;
64			{$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
65
66			{ TFB30ClientAPI }
67
68	tony	315	TFB30ClientAPI = class(TFBClientAPI,IFirebirdAPI,IFBIMasterProvider)
69	tony	45	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	tony	263	constructor Create(aFBLibrary: TFBLibrary);
82	tony	45	destructor Destroy; override;
83
84			function StatusIntf: Firebird.IStatus;
85			procedure Check4DataBaseError;
86			function InErrorState: boolean;
87	tony	263	function LoadInterface: boolean; override;
88	tony	315	procedure FBShutdown; override;
89	tony	263	function GetAPI: IFirebirdAPI; override;
90			{$IFDEF UNIX}
91			function GetFirebirdLibList: string; override;
92			{$ENDIF}
93	tony	45
94			public
95			{IFirebirdAPI}
96			function GetStatus: IStatus; override;
97			function AllocateDPB: IDPB;
98			function AllocateTPB: ITPB;
99
100			{Database connections}
101	tony	56	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	tony	45	{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	tony	143	function GetServiceManager(ServerName: AnsiString; Protocol: TProtocol; SPB: ISPB): IServiceManager; overload;
113			function GetServiceManager(ServerName: AnsiString; Port: Ansistring; Protocol: TProtocol; SPB: ISPB): IServiceManager; overload;
114	tony	45
115			{Information}
116			function HasServiceAPI: boolean;
117			function HasRollbackRetaining: boolean;
118			function IsEmbeddedServer: boolean; override;
119	tony	308	function GetClientMajor: integer; override;
120			function GetClientMinor: integer; override;
121	tony	315	function HasLocalTZDB: boolean; override;
122			function HasTimeZoneSupport: boolean; override;
123			function HasExtendedTZSupport: boolean; override;
124			function HasInt128Support: boolean; override;
125	tony	45
126			{Firebird 3 API}
127			function HasMasterIntf: boolean;
128			function GetIMaster: TObject;
129
130	tony	315	{IFBIMasterProvider}
131			function GetIMasterIntf: Firebird.IMaster;
132
133	tony	45	{Encode/Decode}
134	tony	56	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	tony	308	function FormatStatus(Status: TFBStatus): AnsiString; override;
142	tony	45
143	tony	315	{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	tony	45	{Firebird Interfaces}
151			property MasterIntf: Firebird.IMaster read FMaster;
152			property UtilIntf: Firebird.IUtil read FUtil;
153			property ProviderIntf: Firebird.IProvider read FProvider;
154	tony	315
155	tony	45	end;
156
157			implementation
158
159	tony	315	uses FB30Attachment, {$IFDEF FPC}dynlibs{$ELSE} windows{$ENDIF},
160			FBMessages, FB30Services, FB30Transaction, IBUtils, DateUtils,
161			FBAttachment, FBTransaction, FBServices;
162	tony	45
163			type
164			PISC_DATE = ^ISC_DATE;
165			PISC_TIME = ^ISC_TIME;
166
167	tony	315	{ 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	tony	45	{ 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	tony	56	Plugins: AnsiString;
208	tony	45	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	tony	315	FIsEmbeddedServer := (PluginsList.IndexOf('Engine12') <> -1) or {Firebird 3}
223			(PluginsList.IndexOf('Engine13') <> -1); {Firebird 4}
224	tony	45	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	tony	263	function TFB30ClientAPI.LoadInterface: boolean;
237	tony	45	var
238			fb_get_master_interface: Tfb_get_master_interface;
239			begin
240	tony	263	Result := inherited LoadInterface;
241			fb_get_master_interface := GetProcAddress(GetFBLibrary.GetHandle, 'fb_get_master_interface'); {do not localize}
242	tony	45	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	tony	263	Result := Result and HasMasterIntf;
251	tony	45	end;
252
253	tony	315	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	tony	263	function TFB30ClientAPI.GetAPI: IFirebirdAPI;
264	tony	45	begin
265	tony	263	Result := self;
266			end;
267
268			constructor TFB30ClientAPI.Create(aFBLibrary: TFBLibrary);
269			begin
270			inherited Create(aFBLibrary);
271	tony	45	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	tony	263	Result := TDPB.Create(self);
307	tony	45	end;
308
309			function TFB30ClientAPI.AllocateTPB: ITPB;
310			begin
311	tony	263	Result := TTPB.Create(self);
312	tony	45	end;
313
314	tony	56	function TFB30ClientAPI.OpenDatabase(DatabaseName: AnsiString; DPB: IDPB;
315	tony	45	RaiseExceptionOnConnectError: boolean): IAttachment;
316			begin
317	tony	263	Result := TFB30Attachment.Create(self,DatabaseName, DPB, RaiseExceptionOnConnectError);
318	tony	45	if not Result.IsConnected then
319			Result := nil;
320			end;
321
322	tony	56	function TFB30ClientAPI.CreateDatabase(DatabaseName: AnsiString; DPB: IDPB;
323	tony	45	RaiseExceptionOnError: boolean): IAttachment;
324			begin
325	tony	263	Result := TFB30Attachment.CreateDatabase(self,DatabaseName,DPB, RaiseExceptionOnError);
326	tony	45	if not Result.IsConnected then
327			Result := nil;
328			end;
329
330	tony	56	function TFB30ClientAPI.CreateDatabase(sql: AnsiString; aSQLDialect: integer;
331	tony	47	RaiseExceptionOnError: boolean): IAttachment;
332			begin
333	tony	263	Result := TFB30Attachment.CreateDatabase(self,sql,aSQLDialect, RaiseExceptionOnError);
334	tony	47	if not Result.IsConnected then
335			Result := nil;
336			end;
337
338	tony	45	function TFB30ClientAPI.StartTransaction(Attachments: array of IAttachment;
339			TPB: array of byte; DefaultCompletion: TTransactionCompletion): ITransaction;
340			begin
341	tony	263	Result := TFB30Transaction.Create(self,Attachments,TPB,DefaultCompletion);
342	tony	45	end;
343
344			function TFB30ClientAPI.StartTransaction(Attachments: array of IAttachment;
345			TPB: ITPB; DefaultCompletion: TTransactionCompletion): ITransaction;
346			begin
347	tony	263	Result := TFB30Transaction.Create(self,Attachments,TPB,DefaultCompletion);
348	tony	45	end;
349
350			function TFB30ClientAPI.AllocateSPB: ISPB;
351			begin
352	tony	263	Result := TSPB.Create(self);
353	tony	45	end;
354
355	tony	56	function TFB30ClientAPI.GetServiceManager(ServerName: AnsiString;
356	tony	45	Protocol: TProtocol; SPB: ISPB): IServiceManager;
357			begin
358	tony	263	Result := TFB30ServiceManager.Create(self,ServerName,Protocol,SPB);
359	tony	45	end;
360
361	tony	143	function TFB30ClientAPI.GetServiceManager(ServerName: AnsiString;
362			Port: Ansistring; Protocol: TProtocol; SPB: ISPB): IServiceManager;
363			begin
364	tony	263	Result := TFB30ServiceManager.Create(self,ServerName,Protocol,SPB,Port);
365	tony	143	end;
366
367	tony	45	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	tony	315	function TFB30ClientAPI.GetIMasterIntf: Firebird.IMaster;
383			begin
384			Result := FMaster;
385			end;
386
387	tony	45	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	tony	308	function TFB30ClientAPI.GetClientMajor: integer;
398	tony	45	begin
399	tony	308	Result := UtilIntf.GetClientVersion div 256;
400	tony	45	end;
401
402	tony	308	function TFB30ClientAPI.GetClientMinor: integer;
403			begin
404			Result := UtilIntf.GetClientVersion mod 256;
405			end;
406
407	tony	56	function TFB30ClientAPI.DecodeInteger(bufptr: PByte; len: short): integer;
408			var P: PByte;
409	tony	45	begin
410			Result := 0;
411			P := Bufptr + len - 1;
412			while P >= bufptr do
413			begin
414	tony	56	Result := (Result shl 8 ) or P^;
415	tony	45	Dec(P);
416			end;
417			end;
418
419	tony	56	procedure TFB30ClientAPI.SQLEncodeDate(aDate: TDateTime; bufptr: PByte);
420	tony	45	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	tony	56	function TFB30ClientAPI.SQLDecodeDate(bufptr: PByte): TDateTime;
428	tony	45	var
429	tony	56	Yr, Mn, Dy: cardinal;
430	tony	45	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	tony	56	procedure TFB30ClientAPI.SQLEncodeTime(aTime: TDateTime; bufptr: PByte);
442	tony	45	var
443	tony	315	Hr, Mt, S: word;
444			DMs: cardinal;
445	tony	45	begin
446	tony	315	FBDecodeTime(aTime,Hr, Mt, S, DMs);
447			PISC_TIME(bufptr)^ := UtilIntf.encodeTime(Hr, Mt, S, DMs);
448	tony	45	end;
449
450	tony	56	function TFB30ClientAPI.SQLDecodeTime(bufptr: PByte): TDateTime;
451	tony	45	var
452	tony	315	Hr, Mt, S, DMs: cardinal;
453	tony	45	begin
454	tony	315	UtilIntf.decodeTime(PISC_TIME(bufptr)^,@Hr, @Mt, @S, @DMs);
455	tony	45	try
456	tony	315	Result := FBEncodeTime(Hr, Mt, S, DMs);
457	tony	45	except
458			on E: EConvertError do begin
459			IBError(ibxeInvalidDataConversion, [nil]);
460			end;
461			end;
462			end;
463
464	tony	56	procedure TFB30ClientAPI.SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte);
465	tony	45	begin
466			SQLEncodeDate(aDateTime,bufPtr);
467			Inc(bufptr,sizeof(ISC_DATE));
468			SQLEncodeTime(aDateTime,bufPtr);
469			end;
470
471	tony	56	function TFB30ClientAPI.SQLDecodeDateTime(bufptr: PByte): TDateTime;
472	tony	45	begin
473			Result := SQLDecodeDate(bufPtr);
474			Inc(bufptr,sizeof(ISC_DATE));
475	tony	56	Result := Result + SQLDecodeTime(bufPtr);
476	tony	45	end;
477
478	tony	308	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	tony	315	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	tony	45	end.
670
671	tony	56