--- ibx/trunk/fbintf/client/3.0/FB30ClientAPI.pas	2021/02/25 11:27:14	314
+++ ibx/trunk/fbintf/client/3.0/FB30ClientAPI.pas	2021/02/25 11:56:36	315
@@ -37,7 +37,7 @@ unit FB30ClientAPI;
 interface
 
 uses
-  Classes, SysUtils, FBClientAPI, Firebird, IB, IBExternals;
+  Classes, SysUtils, FBClientAPI, Firebird, IB, IBExternals, FmtBCD, FBClientLib;
 
 type
 
@@ -53,12 +53,19 @@ type
     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)
+  TFB30ClientAPI = class(TFBClientAPI,IFirebirdAPI,IFBIMasterProvider)
   private
     FMaster: Firebird.IMaster;
     FUtil: Firebird.IUtil;
@@ -78,6 +85,7 @@ type
     procedure Check4DataBaseError;
     function InErrorState: boolean;
     function LoadInterface: boolean; override;
+    procedure FBShutdown; override;
     function GetAPI: IFirebirdAPI; override;
     {$IFDEF UNIX}
     function GetFirebirdLibList: string; override;
@@ -110,11 +118,18 @@ type
     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;
@@ -125,21 +140,39 @@ type
     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 FBParamBlock, FB30Attachment, {$IFDEF FPC}dynlibs{$ELSE} windows{$ENDIF},
-     FBMessages, FB30Services, FB30Transaction;
+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;
@@ -186,7 +219,8 @@ begin
   PluginsList := TStringList.Create;
   try
     PluginsList.CommaText := Plugins;
-    FIsEmbeddedServer := PluginsList.IndexOf('Engine12') <> -1;
+    FIsEmbeddedServer := (PluginsList.IndexOf('Engine12') <> -1) or {Firebird 3}
+                         (PluginsList.IndexOf('Engine13') <> -1); {Firebird 4}
   finally
     PluginsList.Free;
   end;
@@ -216,6 +250,16 @@ begin
   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;
@@ -335,6 +379,11 @@ begin
   Result := FMaster;
 end;
 
+function TFB30ClientAPI.GetIMasterIntf: Firebird.IMaster;
+begin
+  Result := FMaster;
+end;
+
 function TFB30ClientAPI.HasRollbackRetaining: boolean;
 begin
   Result := true;
@@ -391,19 +440,20 @@ end;
 
 procedure TFB30ClientAPI.SQLEncodeTime(aTime: TDateTime; bufptr: PByte);
 var
-  Hr, Mt, S, Ms: Word;
+  Hr, Mt, S: word;
+  DMs: cardinal;
 begin
-  DecodeTime(aTime, Hr, Mt, S, Ms);
-  PISC_TIME(bufptr)^ :=  UtilIntf.encodeTime(Hr, Mt, S, Ms*10);
+  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, Ms: cardinal;
+  Hr, Mt, S, DMs: cardinal;
 begin
-  UtilIntf.decodeTime(PISC_TIME(bufptr)^,@Hr, @Mt, @S, @Ms);
+  UtilIntf.decodeTime(PISC_TIME(bufptr)^,@Hr, @Mt, @S, @DMs);
   try
-    Result := EncodeTime(Hr, Mt, S, Ms div 10);
+    Result := FBEncodeTime(Hr, Mt, S, DMs);
   except
     on E: EConvertError do begin
       IBError(ibxeInvalidDataConversion, [nil]);
@@ -433,6 +483,189 @@ begin
     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.