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 |
|
|
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; |
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; |
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; |
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; |
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; |
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; |
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; |
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]); |
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 |
|
|