ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/fbintf/client/3.0/FB30ClientAPI.pas
Revision: 363
Committed: Tue Dec 7 13:30:05 2021 UTC (8 months, 1 week ago) by tony
File size: 21658 byte(s)
Log Message:
add fbintf
Line File contents
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 FBActivityMonitor;
42
43 type
44
45 { TFB30Status }
46
47 TFB30Status = class(TFBStatus,IStatus)
48 protected
49 FStatus: Firebird.IStatus;
50 FDirty: boolean;
51 public
52 destructor Destroy; override;
53 procedure Init;
54 procedure FreeHandle;
55 function InErrorState: boolean;
56 function Warning: boolean;
57 function GetStatus: Firebird.IStatus;
58 function StatusVector: PStatusVector; override;
59 property Dirty: boolean read FDirty;
60 end;
61
62 { TFB30StatusObject }
63
64 TFB30StatusObject = class(TFB30Status)
65 public
66 constructor Create(aOwner: TFBClientAPI; status: Firebird.IStatus; prefix: Ansistring='');
67 end;
68
69 Tfb_get_master_interface = function: IMaster;
70 {$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
71
72 { TFB30ClientAPI }
73
74 TFB30ClientAPI = class(TFBClientAPI,IFirebirdAPI,IFBIMasterProvider)
75 private
76 FMaster: Firebird.IMaster;
77 FUtil: Firebird.IUtil;
78 FProvider: Firebird.IProvider;
79 FConfigManager: Firebird.IConfigManager;
80 FStatus: TFB30Status;
81 FIsEmbeddedServer: boolean;
82 FStatusIntf: IStatus; {Keep a reference to the interface - automatic destroy
83 when this class is freed and last reference to IStatus
84 goes out of scope.}
85 procedure CheckPlugins;
86 public
87 constructor Create(aFBLibrary: TFBLibrary);
88 destructor Destroy; override;
89
90 function StatusIntf: Firebird.IStatus;
91 procedure Check4DataBaseError; overload;
92 procedure Check4DataBaseError(st: Firebird.IStatus); overload;
93 function InErrorState: boolean;
94 function LoadInterface: boolean; override;
95 procedure FBShutdown; override;
96 function GetAPI: IFirebirdAPI; override;
97 function Firebird4orLater: boolean;
98 {$IFDEF UNIX}
99 function GetFirebirdLibList: string; override;
100 {$ENDIF}
101
102 public
103 {IFirebirdAPI}
104 function GetStatus: IStatus; override;
105 function AllocateDPB: IDPB;
106 function AllocateTPB: ITPB;
107
108 {Database connections}
109 function OpenDatabase(DatabaseName: AnsiString; DPB: IDPB; RaiseExceptionOnConnectError: boolean=true): IAttachment;
110 function CreateDatabase(DatabaseName: AnsiString; DPB: IDPB; RaiseExceptionOnError: boolean=true): IAttachment; overload;
111 function CreateDatabase(sql: AnsiString; aSQLDialect: integer; RaiseExceptionOnError: boolean=true): IAttachment; overload;
112 {Start Transaction against multiple databases}
113 function StartTransaction(Attachments: array of IAttachment;
114 TPB: array of byte; DefaultCompletion: TTransactionCompletion; aName: AnsiString=''): ITransaction; overload;
115 function StartTransaction(Attachments: array of IAttachment;
116 TPB: ITPB; DefaultCompletion: TTransactionCompletion; aName: AnsiString=''): ITransaction; overload;
117
118 {Service Manager}
119 function AllocateSPB: ISPB;
120 function GetServiceManager(ServerName: AnsiString; Protocol: TProtocol; SPB: ISPB): IServiceManager; overload;
121 function GetServiceManager(ServerName: AnsiString; Port: Ansistring; Protocol: TProtocol; SPB: ISPB): IServiceManager; overload;
122
123 {Information}
124 function HasServiceAPI: boolean;
125 function HasRollbackRetaining: boolean;
126 function IsEmbeddedServer: boolean; override;
127 function GetClientMajor: integer; override;
128 function GetClientMinor: integer; override;
129 function HasLocalTZDB: boolean; override;
130 function HasTimeZoneSupport: boolean; override;
131 function HasExtendedTZSupport: boolean; override;
132 function HasInt128Support: boolean; override;
133 function HasScollableCursors: boolean;
134
135 {Firebird 3 API}
136 function HasMasterIntf: boolean;
137 function GetIMaster: TObject;
138
139 {IFBIMasterProvider}
140 function GetIMasterIntf: Firebird.IMaster;
141
142 {Encode/Decode}
143 procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte); override;
144 function SQLDecodeDate(bufptr: PByte): TDateTime; override;
145 procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte); override;
146 function SQLDecodeTime(bufptr: PByte): TDateTime; override;
147 procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte); override;
148 function SQLDecodeDateTime(bufptr: PByte): TDateTime; override;
149 function FormatStatus(Status: TFBStatus): AnsiString; override;
150 function FormatFBStatus(Status: Firebird.IStatus): AnsiString;
151
152 {Firebird 4 Extensions}
153 procedure SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal; bufptr: PByte);
154 override;
155 function SQLDecFloatDecode(SQLType: cardinal; bufptr: PByte): tBCD; override;
156 function Int128ToStr(bufptr: PByte; scale: integer): AnsiString; override;
157 procedure StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte); override;
158
159 {Firebird Interfaces}
160 property MasterIntf: Firebird.IMaster read FMaster;
161 property UtilIntf: Firebird.IUtil read FUtil;
162 property ProviderIntf: Firebird.IProvider read FProvider;
163
164 end;
165
166 { TXPBParameterBlock }
167
168 TXPBParameterBlock = class(TFBInterfacedObject)
169 private
170 FBuilder: Firebird.IXpbBuilder;
171 FFirebird30ClientAPI: TFB30ClientAPI;
172 public
173 constructor Create(api: TFB30ClientAPI; kind: cardinal);
174 destructor Destroy; override;
175 function getBuffer: PByte;
176 function getDataLength: cardinal;
177 procedure insertInt(tag: Byte; value: Integer);
178 property Builder: Firebird.IXpbBuilder read FBuilder;
179 public
180 procedure PrintBuf;
181 end;
182
183 implementation
184
185 uses FB30Attachment, {$IFDEF FPC}dynlibs{$ELSE} windows{$ENDIF},
186 FBMessages, FB30Services, FB30Transaction, IBUtils, DateUtils,
187 FBAttachment, FBTransaction, FBServices;
188
189 type
190 PISC_DATE = ^ISC_DATE;
191 PISC_TIME = ^ISC_TIME;
192
193 { TXPBParameterBlock }
194
195 constructor TXPBParameterBlock.Create(api: TFB30ClientAPI; kind: cardinal);
196 begin
197 inherited Create;
198 FFirebird30ClientAPI := api;
199 with FFirebird30ClientAPI do
200 begin
201 FBuilder := UtilIntf.getXpbBuilder(StatusIntf,kind,nil,0);
202 Check4DataBaseError;
203 end;
204 end;
205
206 destructor TXPBParameterBlock.Destroy;
207 begin
208 if FBuilder <> nil then
209 begin
210 FBuilder.dispose;
211 FBuilder := nil;
212 end;
213 inherited Destroy;
214 end;
215
216 function TXPBParameterBlock.getBuffer: PByte;
217 begin
218 with FFirebird30ClientAPI do
219 begin
220 Result := PByte(FBuilder.getBuffer(StatusIntf));
221 Check4DataBaseError;
222 end;
223 end;
224
225 function TXPBParameterBlock.getDataLength: cardinal;
226 begin
227 with FFirebird30ClientAPI do
228 begin
229 Result := FBuilder.getBufferLength(StatusIntf);
230 Check4DataBaseError;
231 end;
232 end;
233
234 procedure TXPBParameterBlock.insertInt(tag: Byte; value: Integer);
235 begin
236 with FFirebird30ClientAPI do
237 begin
238 Builder.insertInt(StatusIntf,tag,value);
239 Check4DataBaseError;
240 end;
241 end;
242
243 procedure TXPBParameterBlock.PrintBuf;
244 var i: integer;
245 buffer: PByte;
246 begin
247 write(ClassName,': (',getDataLength,') ');
248 buffer := getBuffer;
249 for i := 0 to getDataLength - 1 do
250 begin
251 write(Format('%x ',[buffer^]));
252 Inc(buffer);
253 end;
254 writeln
255 end;
256
257 { TFB30StatusObject }
258
259 constructor TFB30StatusObject.Create(aOwner: TFBClientAPI;
260 status: Firebird.IStatus; prefix: Ansistring);
261 begin
262 inherited Create(aOwner,prefix);
263 FStatus := status;
264 end;
265
266 { TFB30Status }
267
268 destructor TFB30Status.Destroy;
269 begin
270 FreeHandle;
271 inherited Destroy;
272 end;
273
274 procedure TFB30Status.Init;
275 begin
276 if assigned(FStatus) and Dirty then
277 begin
278 FStatus.Init;
279 FDirty := false;
280 end;
281 end;
282
283 procedure TFB30Status.FreeHandle;
284 begin
285 if FStatus <> nil then
286 begin
287 FStatus.dispose;
288 FStatus := nil;
289 end;
290 end;
291
292 function TFB30Status.InErrorState: boolean;
293 begin
294 with GetStatus do
295 Result := ((getState and STATE_ERRORS) <> 0);
296 if Result then
297 FDirty := true;
298 end;
299
300 function TFB30Status.Warning: boolean;
301 begin
302 with GetStatus do
303 Result := ((getState and STATE_WARNINGS) <> 0);
304 if Result then
305 FDirty := true;
306 end;
307
308 function TFB30Status.GetStatus: Firebird.IStatus;
309 begin
310 if FStatus = nil then
311 with FOwner do
312 FStatus := (FOwner as TFB30ClientAPI).MasterIntf.GetStatus;
313 Result := FStatus;
314 end;
315
316 function TFB30Status.StatusVector: PStatusVector;
317 begin
318 Result := PStatusVector(GetStatus.getErrors);
319 end;
320
321 { TFB30ClientAPI }
322
323 procedure TFB30ClientAPI.CheckPlugins;
324 var FBConf: Firebird.IFirebirdConf;
325 Plugins: AnsiString;
326 PluginsList: TStringList;
327 begin
328 FIsEmbeddedServer := false;
329 FBConf := FConfigManager.getFirebirdConf;
330 try
331 Plugins := FBConf.asString(FBConf.getKey('Providers'));
332 finally
333 FBConf.release;
334 end;
335 if Plugins = '' then Exit;
336
337 PluginsList := TStringList.Create;
338 try
339 PluginsList.CommaText := Plugins;
340 FIsEmbeddedServer := (PluginsList.IndexOf('Engine12') <> -1) or {Firebird 3}
341 (PluginsList.IndexOf('Engine13') <> -1); {Firebird 4}
342 finally
343 PluginsList.Free;
344 end;
345 end;
346
347 function TFB30ClientAPI.Firebird4orLater: boolean;
348 begin
349 Result := (GetClientMajor > 4) or (
350 (GetClientMajor = 4) and (UtilIntf.vtable.version >= 4)
351 and (UtilIntf.vtable.version <> 21) {ignore FB4 Beta1}
352 and (UtilIntf.vtable.version <> 24)) {ignore FB4 Beta2}
353 end;
354
355 {$IFDEF UNIX}
356 function TFB30ClientAPI.GetFirebirdLibList: string;
357 begin
358 Result := 'libfbclient.so:libfbclient.so.2';
359 end;
360 {$ENDIF}
361
362 function TFB30ClientAPI.LoadInterface: boolean;
363 var
364 fb_get_master_interface: Tfb_get_master_interface;
365 begin
366 Result := inherited LoadInterface;
367 fb_get_master_interface := GetProcAddress(GetFBLibrary.GetHandle, 'fb_get_master_interface'); {do not localize}
368 if assigned(fb_get_master_interface) then
369 begin
370 FMaster := fb_get_master_interface;
371 FUtil := FMaster.getUtilInterface;
372 FProvider := FMaster.getDispatcher;
373 FConfigManager := FMaster.getConfigManager;
374 CheckPlugins;
375 end;
376 Result := Result and HasMasterIntf;
377 end;
378
379 procedure TFB30ClientAPI.FBShutdown;
380 begin
381 if assigned(fb_shutdown) then
382 begin
383 FStatus.FreeHandle;
384 if assigned(FProvider) then
385 begin
386 FProvider.release;
387 FProvider := nil;
388 end;
389 end;
390 inherited;
391 end;
392
393 function TFB30ClientAPI.GetAPI: IFirebirdAPI;
394 begin
395 Result := self;
396 end;
397
398 constructor TFB30ClientAPI.Create(aFBLibrary: TFBLibrary);
399 begin
400 inherited Create(aFBLibrary);
401 FStatus := TFB30Status.Create(self);
402 FStatusIntf := FStatus;
403 end;
404
405 destructor TFB30ClientAPI.Destroy;
406 begin
407 FStatus.FreeHandle;
408 if assigned(FProvider) then
409 FProvider.release;
410 inherited Destroy;
411 end;
412
413 function TFB30ClientAPI.StatusIntf: Firebird.IStatus;
414 begin
415 Result := FStatus.GetStatus;
416 Result.Init;
417 end;
418
419 procedure TFB30ClientAPI.Check4DataBaseError;
420 begin
421 if FStatus.InErrorState then
422 IBDataBaseError;
423 end;
424
425 procedure TFB30ClientAPI.Check4DataBaseError(st: Firebird.IStatus);
426 begin
427 if ((st.getState and st.STATE_ERRORS) <> 0) then
428 raise EIBInterBaseError.Create(TFB30StatusObject.Create(self,st));
429 end;
430
431 function TFB30ClientAPI.InErrorState: boolean;
432 begin
433 Result := FStatus.InErrorState;
434 end;
435
436 function TFB30ClientAPI.GetStatus: IStatus;
437 begin
438 Result := FStatusIntf;
439 end;
440
441 function TFB30ClientAPI.AllocateDPB: IDPB;
442 begin
443 Result := TDPB.Create(self);
444 end;
445
446 function TFB30ClientAPI.AllocateTPB: ITPB;
447 begin
448 Result := TTPB.Create(self);
449 end;
450
451 function TFB30ClientAPI.OpenDatabase(DatabaseName: AnsiString; DPB: IDPB;
452 RaiseExceptionOnConnectError: boolean): IAttachment;
453 begin
454 Result := TFB30Attachment.Create(self,DatabaseName, DPB, RaiseExceptionOnConnectError);
455 if not Result.IsConnected then
456 Result := nil;
457 end;
458
459 function TFB30ClientAPI.CreateDatabase(DatabaseName: AnsiString; DPB: IDPB;
460 RaiseExceptionOnError: boolean): IAttachment;
461 begin
462 Result := TFB30Attachment.CreateDatabase(self,DatabaseName,DPB, RaiseExceptionOnError);
463 if not Result.IsConnected then
464 Result := nil;
465 end;
466
467 function TFB30ClientAPI.CreateDatabase(sql: AnsiString; aSQLDialect: integer;
468 RaiseExceptionOnError: boolean): IAttachment;
469 begin
470 Result := TFB30Attachment.CreateDatabase(self,sql,aSQLDialect, RaiseExceptionOnError);
471 if not Result.IsConnected then
472 Result := nil;
473 end;
474
475 function TFB30ClientAPI.StartTransaction(Attachments: array of IAttachment;
476 TPB: array of byte; DefaultCompletion: TTransactionCompletion; aName: AnsiString): ITransaction;
477 begin
478 Result := TFB30Transaction.Create(self,Attachments,TPB,DefaultCompletion,aName);
479 end;
480
481 function TFB30ClientAPI.StartTransaction(Attachments: array of IAttachment;
482 TPB: ITPB; DefaultCompletion: TTransactionCompletion; aName: AnsiString): ITransaction;
483 begin
484 Result := TFB30Transaction.Create(self,Attachments,TPB,DefaultCompletion,aName);
485 end;
486
487 function TFB30ClientAPI.AllocateSPB: ISPB;
488 begin
489 Result := TSPB.Create(self);
490 end;
491
492 function TFB30ClientAPI.GetServiceManager(ServerName: AnsiString;
493 Protocol: TProtocol; SPB: ISPB): IServiceManager;
494 begin
495 Result := TFB30ServiceManager.Create(self,ServerName,Protocol,SPB);
496 end;
497
498 function TFB30ClientAPI.GetServiceManager(ServerName: AnsiString;
499 Port: Ansistring; Protocol: TProtocol; SPB: ISPB): IServiceManager;
500 begin
501 Result := TFB30ServiceManager.Create(self,ServerName,Protocol,SPB,Port);
502 end;
503
504 function TFB30ClientAPI.HasServiceAPI: boolean;
505 begin
506 Result := true;
507 end;
508
509 function TFB30ClientAPI.HasMasterIntf: boolean;
510 begin
511 Result := MasterIntf <> nil;
512 end;
513
514 function TFB30ClientAPI.GetIMaster: TObject;
515 begin
516 Result := FMaster;
517 end;
518
519 function TFB30ClientAPI.GetIMasterIntf: Firebird.IMaster;
520 begin
521 Result := FMaster;
522 end;
523
524 function TFB30ClientAPI.HasRollbackRetaining: boolean;
525 begin
526 Result := true;
527 end;
528
529 function TFB30ClientAPI.IsEmbeddedServer: boolean;
530 begin
531 Result := FIsEmbeddedServer;
532 end;
533
534 function TFB30ClientAPI.GetClientMajor: integer;
535 begin
536 Result := UtilIntf.GetClientVersion div 256;
537 end;
538
539 function TFB30ClientAPI.GetClientMinor: integer;
540 begin
541 Result := UtilIntf.GetClientVersion mod 256;
542 end;
543
544 procedure TFB30ClientAPI.SQLEncodeDate(aDate: TDateTime; bufptr: PByte);
545 var
546 Yr, Mn, Dy: Word;
547 begin
548 DecodeDate(aDate, Yr, Mn, Dy);
549 PISC_Date(Bufptr)^ := UtilIntf.encodeDate(Yr, Mn, Dy);
550 end;
551
552 function TFB30ClientAPI.SQLDecodeDate(bufptr: PByte): TDateTime;
553 var
554 Yr, Mn, Dy: cardinal;
555 begin
556 UtilIntf.decodeDate(PISC_DATE(bufptr)^,@Yr, @Mn, @Dy);
557 try
558 result := EncodeDate(Yr, Mn,Dy);
559 except
560 on E: EConvertError do begin
561 IBError(ibxeInvalidDataConversion, [nil]);
562 end;
563 end;
564 end;
565
566 procedure TFB30ClientAPI.SQLEncodeTime(aTime: TDateTime; bufptr: PByte);
567 var
568 Hr, Mt, S: word;
569 DMs: cardinal;
570 begin
571 FBDecodeTime(aTime,Hr, Mt, S, DMs);
572 PISC_TIME(bufptr)^ := UtilIntf.encodeTime(Hr, Mt, S, DMs);
573 end;
574
575 function TFB30ClientAPI.SQLDecodeTime(bufptr: PByte): TDateTime;
576 var
577 Hr, Mt, S, DMs: cardinal;
578 begin
579 UtilIntf.decodeTime(PISC_TIME(bufptr)^,@Hr, @Mt, @S, @DMs);
580 try
581 Result := FBEncodeTime(Hr, Mt, S, DMs);
582 except
583 on E: EConvertError do begin
584 IBError(ibxeInvalidDataConversion, [nil]);
585 end;
586 end;
587 end;
588
589 procedure TFB30ClientAPI.SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte);
590 begin
591 SQLEncodeDate(aDateTime,bufPtr);
592 Inc(bufptr,sizeof(ISC_DATE));
593 SQLEncodeTime(aDateTime,bufPtr);
594 end;
595
596 function TFB30ClientAPI.SQLDecodeDateTime(bufptr: PByte): TDateTime;
597 begin
598 Result := SQLDecodeDate(bufPtr);
599 Inc(bufptr,sizeof(ISC_DATE));
600 Result := Result + SQLDecodeTime(bufPtr);
601 end;
602
603 function TFB30ClientAPI.FormatStatus(Status: TFBStatus): AnsiString;
604 begin
605 Result := FormatFBStatus((Status as TFB30Status).GetStatus);
606 end;
607
608 function TFB30ClientAPI.FormatFBStatus(Status: Firebird.IStatus): AnsiString;
609 var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
610 begin
611 Result := '';
612 if UtilIntf.formatStatus(@local_buffer,sizeof(local_buffer) - 1,Status) > 0 then
613 Result := strpas(local_buffer);
614 end;
615
616 procedure TFB30ClientAPI.SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal;
617 bufptr: PByte);
618 var DecFloat16: IDecFloat16;
619 DecFloat34: IDecFloat34;
620 sign: integer;
621 exp: integer;
622 buffer: array [1..34] of byte;
623
624 procedure UnpackBuffer(width: integer);
625 var i,j: integer;
626 begin
627 Fillchar(buffer,sizeof(buffer),0);
628 if BCDPrecision(aValue) > width then
629 IBError(ibxeBCDTooBig,[BCDPrecision(aValue),width]);
630 j := 1 + (width - aValue.Precision);
631 for i := 0 to (aValue.Precision - 1) div 2 do
632 if j <= width then
633 begin
634 buffer[j] := (aValue.Fraction[i] and $f0) shr 4;
635 Inc(j);
636 if j <= width then
637 begin
638 buffer[j] := (aValue.Fraction[i] and $0f);
639 Inc(j);
640 end;
641 end;
642 {writeln('Precision = ',aValue.Precision,' Places = ',aValue.SignSpecialPlaces and $2f);
643 write('BCD Buffer = ');
644 for i := 1 to 34 do
645 write(buffer[i],' ');
646 writeln; }
647 end;
648
649 begin
650 inherited SQLDecFloatEncode(aValue, SQLType, bufptr);
651 sign := (aValue.SignSpecialPlaces and $80) shr 7;
652 exp := -(aValue.SignSpecialPlaces and $2f);
653
654 case SQLType of
655 SQL_DEC16:
656 begin
657 UnPackbuffer(16);
658 DecFloat16 := UtilIntf.getDecFloat16(StatusIntf);
659 Check4DataBaseError;
660 DecFloat16.fromBcd(sign,@buffer,exp,FB_DEC16Ptr(bufptr));
661 Check4DataBaseError;
662 end;
663
664 SQL_DEC34:
665 begin
666 UnPackbuffer(34);
667 DecFloat34 := UtilIntf.getDecFloat34(StatusIntf);
668 Check4DataBaseError;
669 DecFloat34.fromBcd(sign,@buffer,exp,FB_DEC34Ptr(bufptr));
670 Check4DataBaseError;
671 end;
672
673 else
674 IBError(ibxeInvalidDataConversion,[]);
675 end;
676 end;
677
678 function TFB30ClientAPI.SQLDecFloatDecode(SQLType: cardinal; bufptr: PByte): tBCD;
679
680 var DecFloat16: IDecFloat16;
681 DecFloat34: IDecFloat34;
682 sign: integer;
683 exp: integer;
684 buffer: array [1..38] of byte;
685
686 procedure packbuffer(buflen: integer);
687 var i,j: integer;
688 begin
689 { write('Decode: BCD Buffer = ');
690 for i := 1 to 34 do
691 write(buffer[i],' ');
692 writeln; }
693 {pack buffer}
694 i := 1;
695 while (i <= buflen) and (buffer[i] = 0) do {skip leading zeroes}
696 inc(i);
697
698 j := 0;
699 Result.Precision := 0;
700 while i <= buflen do
701 begin
702 inc(Result.Precision);
703 if odd(Result.Precision) then
704 Result.Fraction[j] := (buffer[i] and $0f) shl 4
705 else
706 begin
707 Result.Fraction[j] := Result.Fraction[j] or (buffer[i] and $0f);
708 Inc(j);
709 end;
710 inc(i);
711 end;
712 end;
713
714 begin
715 Result := inherited SQLDecFloatDecode(SQLType, bufptr);
716 FillChar(Result, sizeof(tBCD),0);
717 case SQLType of
718 SQL_DEC16:
719 begin
720 DecFloat16 := UtilIntf.getDecFloat16(StatusIntf);
721 Check4DataBaseError;
722 DecFloat16.toBcd(FB_DEC16Ptr(bufptr),@sign,@buffer,@exp);
723 Check4DataBaseError;
724 packbuffer(16);
725 end;
726
727 SQL_DEC34:
728 begin
729 DecFloat34 := UtilIntf.getDecFloat34(StatusIntf);
730 Check4DataBaseError;
731 DecFloat34.toBcd(FB_DEC34Ptr(bufptr),@sign,@buffer,@exp);
732 Check4DataBaseError;
733 packbuffer(34);
734 end;
735
736 else
737 IBError(ibxeInvalidDataConversion,[]);
738 end;
739 Result.SignSpecialPlaces := (-exp and $2f);
740 if sign <> 0 then
741 Result.SignSpecialPlaces := Result.SignSpecialPlaces or $80;
742 end;
743
744 procedure TFB30ClientAPI.StrToInt128(scale: integer; aValue: AnsiString;
745 bufptr: PByte);
746 begin
747 inherited StrToInt128(scale,aValue,bufPtr);
748
749 UtilIntf.getInt128(StatusIntf).fromString(StatusIntf,scale,PAnsiChar(aValue),FB_I128Ptr(bufptr));
750 Check4DatabaseError;
751 end;
752
753 function TFB30ClientAPI.Int128ToStr(bufptr: PByte; scale: integer
754 ): AnsiString;
755 const
756 bufLength = 64;
757 var Buffer: array[ 0.. bufLength] of AnsiChar;
758 begin
759 Result := inherited Int128ToStr(bufPtr,scale);
760
761 UtilIntf.getInt128(StatusIntf).toString(StatusIntf,FB_I128Ptr(bufptr),scale,buflength,PAnsiChar(@Buffer));
762 Check4DatabaseError;
763 Result := strpas(PAnsiChar(@Buffer));
764 end;
765
766 function TFB30ClientAPI.HasLocalTZDB: boolean;
767 const
768 bufLength = 128;
769 var Buffer: ISC_TIME_TZ;
770 Hr, Mt, S, DMs: cardinal;
771 tzBuffer: array[ 0.. bufLength] of AnsiChar;
772 begin
773 Result := HasTimeZoneSupport;
774 if Result then
775 begin
776 Buffer.utc_time := 0;
777 Buffer.time_zone := TimeZoneID_GMT;
778 UtilIntf.decodeTimeTz(StatusIntf, ISC_TIME_TZPtr(@Buffer),@Hr, @Mt, @S, @DMs,bufLength,PAnsiChar(@tzBuffer));
779 Check4DataBaseError;
780 Result := strpas(PAnsiChar(@tzBuffer)) <> 'GMT*';
781 end;
782 end;
783
784 function TFB30ClientAPI.HasTimeZoneSupport: boolean;
785 begin
786 Result := Firebird4orLater;
787 end;
788
789 function TFB30ClientAPI.HasExtendedTZSupport: boolean;
790 begin
791 Result := Firebird4orLater;
792 end;
793
794 function TFB30ClientAPI.HasInt128Support: boolean;
795 begin
796 Result := Firebird4orLater;
797 end;
798
799 function TFB30ClientAPI.HasScollableCursors: boolean;
800 begin
801 Result := true;
802 end;
803
804 end.
805
806