ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/3.0/FB30ClientAPI.pas
(Generate patch)

Comparing ibx/trunk/fbintf/client/3.0/FB30ClientAPI.pas (file contents):
Revision 314 by tony, Sat Jul 18 10:26:30 2020 UTC vs.
Revision 315 by tony, Thu Feb 25 11:56:36 2021 UTC

# Line 37 | Line 37 | unit FB30ClientAPI;
37   interface
38  
39   uses
40 <  Classes, SysUtils, FBClientAPI, Firebird, IB, IBExternals;
40 >  Classes, SysUtils, FBClientAPI, Firebird, IB, IBExternals, FmtBCD, FBClientLib;
41  
42   type
43  
# Line 53 | Line 53 | type
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)
68 >  TFB30ClientAPI = class(TFBClientAPI,IFirebirdAPI,IFBIMasterProvider)
69    private
70      FMaster: Firebird.IMaster;
71      FUtil: Firebird.IUtil;
# Line 78 | Line 85 | type
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;
# Line 110 | Line 118 | type
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;
# Line 125 | Line 140 | type
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 FBParamBlock, FB30Attachment, {$IFDEF FPC}dynlibs{$ELSE} windows{$ENDIF},
160 <     FBMessages, FB30Services, FB30Transaction;
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;
# Line 186 | Line 219 | begin
219    PluginsList := TStringList.Create;
220    try
221      PluginsList.CommaText := Plugins;
222 <    FIsEmbeddedServer := PluginsList.IndexOf('Engine12') <> -1;
222 >    FIsEmbeddedServer := (PluginsList.IndexOf('Engine12') <> -1) or {Firebird 3}
223 >                         (PluginsList.IndexOf('Engine13') <> -1); {Firebird 4}
224    finally
225      PluginsList.Free;
226    end;
# Line 216 | Line 250 | begin
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;
# Line 335 | Line 379 | 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;
# Line 391 | Line 440 | end;
440  
441   procedure TFB30ClientAPI.SQLEncodeTime(aTime: TDateTime; bufptr: PByte);
442   var
443 <  Hr, Mt, S, Ms: Word;
443 >  Hr, Mt, S: word;
444 >  DMs: cardinal;
445   begin
446 <  DecodeTime(aTime, Hr, Mt, S, Ms);
447 <  PISC_TIME(bufptr)^ :=  UtilIntf.encodeTime(Hr, Mt, S, Ms*10);
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, Ms: cardinal;
452 >  Hr, Mt, S, DMs: cardinal;
453   begin
454 <  UtilIntf.decodeTime(PISC_TIME(bufptr)^,@Hr, @Mt, @S, @Ms);
454 >  UtilIntf.decodeTime(PISC_TIME(bufptr)^,@Hr, @Mt, @S, @DMs);
455    try
456 <    Result := EncodeTime(Hr, Mt, S, Ms div 10);
456 >    Result := FBEncodeTime(Hr, Mt, S, DMs);
457    except
458      on E: EConvertError do begin
459        IBError(ibxeInvalidDataConversion, [nil]);
# Line 433 | Line 483 | begin
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  

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines