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

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

# Line 76 | Line 76 | uses
76    Classes,
77      {$IFDEF WINDOWS}Windows, {$ENDIF}
78      {$IFDEF FPC} Dynlibs, {$ENDIF}
79 <   IB, IBHeader, FBActivityMonitor, FBMessages, IBExternals;
79 >   IB, IBHeader, FBActivityMonitor, FBMessages, IBExternals, FmtBCD;
80  
81   {For Linux see result of GetFirebirdLibList method}
82   {$IFDEF DARWIN}
# Line 91 | Line 91 | FIREBIRD_EMBEDDED = 'fbembed.dll';
91   {$ENDIF}
92  
93   const
94 +  {fb_shutdown reasons}
95 +  fb_shutrsn_svc_stopped          = -1;
96 +  fb_shutrsn_no_connection        = -2;
97 +  fb_shutrsn_app_stopped          = -3;
98 +  fb_shutrsn_signal               = -5;
99 +  fb_shutrsn_services             = -6;
100 +  fb_shutrsn_exit_called          = -7;
101 +
102 + const
103 +    DefaultTimeZoneFile = '/etc/timezone';
104 +
105 + const
106    IBLocalBufferLength = 512;
107    IBBigLocalBufferLength = IBLocalBufferLength * 2;
108    IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;
# Line 127 | Line 139 | type
139    private
140      class var FEnvSetupDone: boolean;
141      class var FLibraryList: array of IFirebirdLibrary;
142 +  private
143      FFirebirdAPI: IFirebirdAPI;
144      FRequestedLibName: string;
145      function LoadIBLibrary: boolean;
# Line 144 | Line 157 | type
157      destructor Destroy; override;
158      class function GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
159      class procedure FreeLibraries;
160 +    function SameLibrary(aLibName: string): boolean;
161  
162 +  public
163      {IFirebirdLibrary}
164      function GetHandle: TLibHandle;
165      function GetLibraryName: string;
# Line 157 | Line 172 | type
172  
173    TFBClientAPI = class(TFBInterfacedObject)
174    private
175 +    FLocalTimeZoneName: AnsiString; {Informal Time Zone Name from tzname e.g. GMT or BST}
176 +    FTZDataTimeZoneID: AnsiString; {TZData DB ID e.g. Europe/London}
177 +    FLocalTimeOffset: integer;
178 +    FIsDaylightSavingsTime: boolean;
179      class var FIBCS: TRTLCriticalSection;
180 +    function FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
181 +    procedure GetTZDataSettings;
182    protected
183      FFBLibrary: TFBLibrary;
184      function GetProcAddr(ProcName: PAnsiChar): Pointer;
185 +
186 +  protected type
187 +    Tfb_shutdown = function (timeout: uint;
188 +                                 const reason: int): int;
189 +                   {$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
190 +  protected
191 +    {FB Shutdown API}
192 +    fb_shutdown: Tfb_shutdown;
193 +
194    public
195      {Taken from legacy API}
196      isc_sqlcode: Tisc_sqlcode;
# Line 173 | Line 203 | type
203      procedure IBAlloc(var P; OldSize, NewSize: Integer);
204      procedure IBDataBaseError;
205      function LoadInterface: boolean; virtual;
206 +    procedure FBShutdown; virtual;
207      function GetAPI: IFirebirdAPI; virtual; abstract;
208      {$IFDEF UNIX}
209      function GetFirebirdLibList: string; virtual; abstract;
210      {$ENDIF}
211 +    function HasDecFloatSupport: boolean;
212 +    function HasInt128Support: boolean; virtual;
213 +    function HasLocalTZDB: boolean; virtual;
214 +    function HasExtendedTZSupport: boolean; virtual;
215 +    function HasTimeZoneSupport: boolean; virtual;
216  
217 +  public
218 +    property LocalTimeZoneName: AnsiString read FLocalTimeZoneName;
219 +    property TZDataTimeZoneID: AnsiString read FTZDataTimeZoneID;
220 +    property LocalTimeOffset: integer read FLocalTimeOffset;
221 +  public
222      {Encode/Decode}
223      procedure EncodeInteger(aValue: integer; len: integer; buffer: PByte);
224      function DecodeInteger(bufptr: PByte; len: short): integer; virtual; abstract;
225 <    procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte); virtual; abstract;
226 <    function SQLDecodeDate(byfptr: PByte): TDateTime; virtual; abstract;
227 <    procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte); virtual; abstract;
225 >    procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte);  virtual; abstract;
226 >    function SQLDecodeDate(byfptr: PByte): TDateTime;  virtual; abstract;
227 >    procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte);  virtual; abstract;
228      function SQLDecodeTime(bufptr: PByte): TDateTime;  virtual; abstract;
229      procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte); virtual; abstract;
230 <    function SQLDecodeDateTime(bufptr: PByte): TDateTime; virtual; abstract;
230 >    function  SQLDecodeDateTime(bufptr: PByte): TDateTime; virtual; abstract;
231 >    function FormatStatus(Status: TFBStatus): AnsiString; virtual; abstract;
232 >    function Int128ToStr(bufptr: PByte; scale: integer): AnsiString; virtual;
233 >    procedure StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte);
234 >      virtual;
235 >    procedure SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal; bufptr: PByte); virtual;
236 >    function SQLDecFloatDecode(SQLType: cardinal;  bufptr: PByte): tBCD; virtual;
237      function FormatStatus(Status: TFBStatus): AnsiString; virtual; abstract;
238  
239      {IFirebirdAPI}
# Line 202 | Line 249 | end;
249   implementation
250  
251   uses IBUtils, Registry,
252 <  {$IFDEF Unix} initc, dl, {$ENDIF}
252 >  {$IFDEF Unix} unix, initc, dl, {$ENDIF}
253   {$IFDEF FPC}
254   {$IFDEF WINDOWS }
255   WinDirs,
# Line 235 | Line 282 | end;
282  
283   procedure TFBLibrary.FreeFBLibrary;
284   begin
285 +  (FFirebirdAPI as TFBClientAPI).FBShutdown;
286    if FIBLibrary <> NilHandle then
287      FreeLibrary(FIBLibrary);
288    FIBLibrary := NilHandle;
289 +  FFBLibraryName := '';
290   end;
291  
292   function TFBLibrary.GetLibraryName: string;
# Line 289 | Line 338 | end;
338  
339   destructor TFBLibrary.Destroy;
340   begin
292  FFirebirdAPI := nil;
341    FreeFBLibrary;
342 +  FFirebirdAPI := nil;
343    inherited Destroy;
344   end;
345  
# Line 301 | Line 350 | begin
350    if aLibPathName <> '' then
351    begin
352      for i := 0 to Length(FLibraryList) - 1 do
353 <      if (FLibraryList[i] as TFBLibrary).FRequestedLibName = aLibPathName then
353 >    begin
354 >      if (FLibraryList[i] as TFBLibrary).SameLibrary(aLibPathName) then
355        begin
356          Result := FLibraryList[i];
357          Exit;
358        end;
359 +    end;
360      Result := Create(aLibPathName);
361    end;
362  
# Line 319 | Line 370 | begin
370    SetLength(FLibraryList,0);
371   end;
372  
373 + function TFBLibrary.SameLibrary(aLibName: string): boolean;
374 + begin
375 +  Result := FRequestedLibName = aLibName;
376 + end;
377 +
378   function TFBLibrary.GetHandle: TLibHandle;
379   begin
380    Result := FIBLibrary;
# Line 330 | Line 386 | constructor TFBClientAPI.Create(aFBLibra
386   begin
387    inherited Create;
388    FFBLibrary := aFBLibrary;
389 +  GetTZDataSettings;
390   end;
391  
392   procedure TFBClientAPI.IBAlloc(var P; OldSize, NewSize: Integer);
# Line 345 | Line 402 | begin
402    raise EIBInterBaseError.Create(GetStatus);
403   end;
404  
348 {Under Unixes, if using an embedded server then set up local TMP and LOCK Directories}
349
405   procedure TFBClientAPI.EncodeInteger(aValue: integer; len: integer; buffer: PByte);
406   begin
407    while len > 0 do
# Line 358 | Line 413 | begin
413    end;
414   end;
415  
416 + function TFBClientAPI.Int128ToStr(bufptr: PByte; scale: integer): AnsiString;
417 + begin
418 +  if not HasInt128Support then
419 +    IBError(ibxeNotSupported,[]);
420 + end;
421 +
422 + procedure TFBClientAPI.StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte);
423 + begin
424 +  if not HasInt128Support then
425 +    IBError(ibxeNotSupported,[]);
426 + end;
427 +
428 + procedure TFBClientAPI.SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal;
429 +  bufptr: PByte);
430 + begin
431 +  if not HasDecFloatSupport then
432 +    IBError(ibxeNotSupported,[]);
433 + end;
434 +
435 + function TFBClientAPI.SQLDecFloatDecode(SQLType: cardinal; bufptr: PByte): tBCD;
436 + begin
437 +  if not HasDecFloatSupport then
438 +    IBError(ibxeNotSupported,[]);
439 + end;
440 +
441   function TFBClientAPI.IsLibraryLoaded: boolean;
442   begin
443    Result := FFBLibrary.IBLibrary <> NilHandle;
# Line 368 | Line 448 | begin
448    Result := FFBLibrary;
449   end;
450  
451 < function TFBClientAPI.GetImplementationVersion: AnsiString;
451 > function TFBClientAPI.FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
452   begin
453 <  Result := Format('%d.%d',[GetClientMajor,GetClientMinor]);
453 >  {aDate/aTime are in TTimestamp format but aTime is decimilliseconds}
454 >  aDate := aDate - DateDelta;
455 >  if aDate < 0 then
456 >    Result := trunc(aDate) - abs(frac(aTime / (MSecsPerDay*10)))
457 >  else
458 >    Result := trunc(aDate) + abs(frac(aTime / (MSecsPerDay*10)));
459   end;
460  
461 + {$IFDEF UNIX}
462 + procedure TFBClientAPI.GetTZDataSettings;
463 + var S: TStringList;
464 + begin
465 +  FLocalTimeOffset := GetLocalTimeOffset;
466 +  FLocalTimeZoneName := strpas(tzname[tzdaylight]);
467 +  FIsDaylightSavingsTime := tzdaylight;
468 +  if FileExists(DefaultTimeZoneFile) then
469 +  begin
470 +    S := TStringList.Create;
471 +    try
472 +      S.LoadFromFile(DefaultTimeZoneFile);
473 +      if S.Count > 0 then
474 +        FTZDataTimeZoneID := S[0];
475 +    finally
476 +      S.Free;
477 +    end;
478 +  end;
479 + end;
480 + {$ENDIF}
481 +
482 + {$IFDEF WINDOWS}
483 + procedure TFBClientAPI.GetTZDataSettings;
484 + var TZInfo: TTimeZoneInformation;
485 + begin
486 +  FIsDaylightSavingsTime := false;
487 +  {is there any way of working out the default TZData DB time zone ID under Windows?}
488 +  case GetTimeZoneInformation(TZInfo) of
489 +    TIME_ZONE_ID_UNKNOWN:
490 +      begin
491 +        FLocalTimeZoneName := '';
492 +        FLocalTimeOffset := 0;
493 +      end;
494 +    TIME_ZONE_ID_STANDARD:
495 +      begin
496 +        FLocalTimeZoneName := strpas(PWideChar(@TZInfo.StandardName));
497 +        FLocalTimeOffset := TZInfo.Bias;
498 +      end;
499 +    TIME_ZONE_ID_DAYLIGHT:
500 +      begin
501 +        FLocalTimeZoneName := strpas(PWideChar(@TZInfo.DaylightName));
502 +        FLocalTimeOffset := TZInfo.DayLightBias;
503 +        FIsDaylightSavingsTime := true;
504 +      end;
505 +  end;
506 + end;
507 + {$ENDIF}
508 +
509   function TFBClientAPI.GetProcAddr(ProcName: PAnsiChar): Pointer;
510   begin
511    Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
# Line 380 | Line 513 | begin
513      raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
514   end;
515  
516 + function TFBClientAPI.HasDecFloatSupport: boolean;
517 + begin
518 +  Result := GetClientMajor >= 4;
519 + end;
520 +
521 + function TFBClientAPI.HasInt128Support: boolean;
522 + begin
523 +  Result := false;
524 + end;
525 +
526 + function TFBClientAPI.HasLocalTZDB: boolean;
527 + begin
528 +  Result := false;
529 + end;
530 +
531 + function TFBClientAPI.HasExtendedTZSupport: boolean;
532 + begin
533 +  Result := false;
534 + end;
535 +
536 + function TFBClientAPI.HasTimeZoneSupport: boolean;
537 + begin
538 +  Result := false;
539 + end;
540 +
541 + function TFBClientAPI.GetImplementationVersion: AnsiString;
542 + begin
543 +  Result := Format('%d.%d',[GetClientMajor,GetClientMinor]);
544 + end;
545 +
546   function TFBClientAPI.LoadInterface: boolean;
547   begin
548    isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
# Line 387 | Line 550 | begin
550    isc_event_counts := GetProcAddr('isc_event_counts'); {do not localize}
551    isc_event_block := GetProcAddr('isc_event_block'); {do not localize}
552    isc_free := GetProcAddr('isc_free'); {do not localize}
553 +  fb_shutdown := GetProcAddr('fb_shutdown'); {do not localize}
554    Result := assigned(isc_free);
555   end;
556  
557 + procedure TFBClientAPI.FBShutdown;
558 + begin
559 +  if assigned(fb_shutdown) then
560 +    fb_shutdown(0,fb_shutrsn_exit_called);
561 + end;
562 +
563   { TFBStatus }
564  
565   constructor TFBStatus.Create(aOwner: TFBClientAPI);
# Line 436 | Line 606 | begin
606      if (ShowSQLCode in IBDataBaseErrorMessages) or
607         (ShowSQLMessage in IBDataBaseErrorMessages) then
608        Result := Result + LineEnding;
609 <    Result := Result + LineEnding + FOwner.FormatStatus(self);
609 >    Result := Result + FOwner.FormatStatus(self);
610    end;
611    if (Result <> '') and (Result[Length(Result)] = '.') then
612      Delete(Result, Length(Result), 1);

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines