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 263 by tony, Thu Dec 6 15:55:01 2018 UTC vs.
Revision 359 by tony, Tue Dec 7 09:37:32 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}
81 > {For Linux see result of GetFirebirdLibListruntime/nongui/winipc.inc method}
82   {$IFDEF DARWIN}
83   const
84   FIREBIRD_SO2 = 'libfbclient.dylib';
# Line 90 | Line 90 | FIREBIRD_CLIENT = 'fbclient.dll'; {do no
90   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;
109 +
110   type
111    TStatusVector              = array[0..19] of NativeInt;
112    PStatusVector              = ^TStatusVector;
# Line 101 | Line 118 | type
118    TFBStatus = class(TFBInterfacedObject)
119    private
120      FIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
121 +    FPrefix: AnsiString;
122    protected
123      FOwner: TFBClientAPI;
124    public
125 <    constructor Create(aOwner: TFBClientAPI);
125 >    constructor Create(aOwner: TFBClientAPI; prefix: AnsiString='');
126      function StatusVector: PStatusVector; virtual; abstract;
127  
128      {IStatus}
129 <    function GetIBErrorCode: Long;
130 <    function Getsqlcode: Long;
129 >    function GetIBErrorCode: TStatusCode;
130 >    function Getsqlcode: TStatusCode;
131      function GetMessage: AnsiString;
132      function CheckStatusVector(ErrorCodes: array of TFBStatusCode): Boolean;
133      function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
# Line 122 | Line 140 | type
140    private
141      class var FEnvSetupDone: boolean;
142      class var FLibraryList: array of IFirebirdLibrary;
143 +  private
144      FFirebirdAPI: IFirebirdAPI;
145      FRequestedLibName: string;
146      function LoadIBLibrary: boolean;
# Line 139 | Line 158 | type
158      destructor Destroy; override;
159      class function GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
160      class procedure FreeLibraries;
161 +    function SameLibrary(aLibName: string): boolean;
162  
163 +  public
164      {IFirebirdLibrary}
165      function GetHandle: TLibHandle;
166      function GetLibraryName: string;
# Line 152 | Line 173 | type
173  
174    TFBClientAPI = class(TFBInterfacedObject)
175    private
176 +    FLocalTimeZoneName: AnsiString; {Informal Time Zone Name from tzname e.g. GMT or BST}
177 +    FTZDataTimeZoneID: AnsiString; {TZData DB ID e.g. Europe/London}
178 +    FLocalTimeOffset: integer;
179 +    FIsDaylightSavingsTime: boolean;
180      class var FIBCS: TRTLCriticalSection;
181 +    function FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
182 +    procedure GetTZDataSettings;
183    protected
184      FFBLibrary: TFBLibrary;
185      function GetProcAddr(ProcName: PAnsiChar): Pointer;
186 +
187 +  protected type
188 +    Tfb_shutdown = function (timeout: uint;
189 +                                 const reason: int): int;
190 +                   {$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
191 +  protected
192 +    {FB Shutdown API}
193 +    fb_shutdown: Tfb_shutdown;
194 +
195    public
196      {Taken from legacy API}
197      isc_sqlcode: Tisc_sqlcode;
198      isc_sql_interprete: Tisc_sql_interprete;
163 –    isc_interprete: Tisc_interprete;
199      isc_event_counts: Tisc_event_counts;
200      isc_event_block: Tisc_event_block;
201      isc_free: Tisc_free;
202 +    isc_portable_integer: Tisc_portable_integer;
203  
204      constructor Create(aFBLibrary: TFBLibrary);
205      procedure IBAlloc(var P; OldSize, NewSize: Integer);
206      procedure IBDataBaseError;
207      function LoadInterface: boolean; virtual;
208 +    procedure FBShutdown; virtual;
209      function GetAPI: IFirebirdAPI; virtual; abstract;
210      {$IFDEF UNIX}
211      function GetFirebirdLibList: string; virtual; abstract;
212      {$ENDIF}
213 +    function HasDecFloatSupport: boolean;
214 +    function HasInt128Support: boolean; virtual;
215 +    function HasLocalTZDB: boolean; virtual;
216 +    function HasExtendedTZSupport: boolean; virtual;
217 +    function HasTimeZoneSupport: boolean; virtual;
218  
219 +  public
220 +    property LocalTimeZoneName: AnsiString read FLocalTimeZoneName;
221 +    property TZDataTimeZoneID: AnsiString read FTZDataTimeZoneID;
222 +    property LocalTimeOffset: integer read FLocalTimeOffset;
223 +  public
224      {Encode/Decode}
225      procedure EncodeInteger(aValue: integer; len: integer; buffer: PByte);
226 <    function DecodeInteger(bufptr: PByte; len: short): integer; virtual; abstract;
227 <    procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte); virtual; abstract;
228 <    function SQLDecodeDate(byfptr: PByte): TDateTime; virtual; abstract;
229 <    procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte); virtual; abstract;
226 >    function DecodeInteger(bufptr: PByte; len: short): int64;
227 >    procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte);  virtual; abstract;
228 >    function SQLDecodeDate(byfptr: PByte): TDateTime;  virtual; abstract;
229 >    procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte);  virtual; abstract;
230      function SQLDecodeTime(bufptr: PByte): TDateTime;  virtual; abstract;
231      procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte); virtual; abstract;
232 <    function SQLDecodeDateTime(bufptr: PByte): TDateTime; virtual; abstract;
233 <
232 >    function  SQLDecodeDateTime(bufptr: PByte): TDateTime; virtual; abstract;
233 >    function FormatStatus(Status: TFBStatus): AnsiString; virtual; abstract;
234 >    function Int128ToStr(bufptr: PByte; scale: integer): AnsiString; virtual;
235 >    procedure StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte);
236 >      virtual;
237 >    procedure SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal; bufptr: PByte); virtual;
238 >    function SQLDecFloatDecode(SQLType: cardinal;  bufptr: PByte): tBCD; virtual;
239  
240      {IFirebirdAPI}
241      function GetStatus: IStatus; virtual; abstract;
242      function IsLibraryLoaded: boolean;
243      function IsEmbeddedServer: boolean; virtual; abstract;
244      function GetFBLibrary: IFirebirdLibrary;
245 +    function GetImplementationVersion: AnsiString;
246 +    function GetClientMajor: integer;  virtual; abstract;
247 +    function GetClientMinor: integer;  virtual; abstract;
248   end;
249  
250   implementation
251  
252   uses IBUtils, Registry,
253 <  {$IFDEF Unix} initc, dl, {$ENDIF}
253 >  {$IFDEF Unix} unix, initc, dl, {$ENDIF}
254   {$IFDEF FPC}
255   {$IFDEF WINDOWS }
256   WinDirs,
# Line 205 | Line 260 | WinDirs,
260   {$ENDIF}
261   SysUtils;
262  
208 – const
209 –  IBLocalBufferLength = 512;
210 –  IBBigLocalBufferLength = IBLocalBufferLength * 2;
211 –  IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;
212 –
263   {$IFDEF UNIX}
264   {$I 'include/uloadlibrary.inc'}
265   {$ELSE}
# Line 233 | Line 283 | end;
283  
284   procedure TFBLibrary.FreeFBLibrary;
285   begin
286 +  (FFirebirdAPI as TFBClientAPI).FBShutdown;
287    if FIBLibrary <> NilHandle then
288      FreeLibrary(FIBLibrary);
289    FIBLibrary := NilHandle;
290 +  FFBLibraryName := '';
291   end;
292  
293   function TFBLibrary.GetLibraryName: string;
# Line 287 | Line 339 | end;
339  
340   destructor TFBLibrary.Destroy;
341   begin
290 –  FFirebirdAPI := nil;
342    FreeFBLibrary;
343 +  FFirebirdAPI := nil;
344    inherited Destroy;
345   end;
346  
# Line 299 | Line 351 | begin
351    if aLibPathName <> '' then
352    begin
353      for i := 0 to Length(FLibraryList) - 1 do
354 <      if (FLibraryList[i] as TFBLibrary).FRequestedLibName = aLibPathName then
354 >    begin
355 >      if (FLibraryList[i] as TFBLibrary).SameLibrary(aLibPathName) then
356        begin
357          Result := FLibraryList[i];
358          Exit;
359        end;
360 +    end;
361      Result := Create(aLibPathName);
362    end;
363  
# Line 317 | Line 371 | begin
371    SetLength(FLibraryList,0);
372   end;
373  
374 + function TFBLibrary.SameLibrary(aLibName: string): boolean;
375 + begin
376 +  Result := FRequestedLibName = aLibName;
377 + end;
378 +
379   function TFBLibrary.GetHandle: TLibHandle;
380   begin
381    Result := FIBLibrary;
# Line 328 | Line 387 | constructor TFBClientAPI.Create(aFBLibra
387   begin
388    inherited Create;
389    FFBLibrary := aFBLibrary;
390 +  GetTZDataSettings;
391   end;
392  
393   procedure TFBClientAPI.IBAlloc(var P; OldSize, NewSize: Integer);
# Line 343 | Line 403 | begin
403    raise EIBInterBaseError.Create(GetStatus);
404   end;
405  
346 – {Under Unixes, if using an embedded server then set up local TMP and LOCK Directories}
347 –
406   procedure TFBClientAPI.EncodeInteger(aValue: integer; len: integer; buffer: PByte);
407   begin
408    while len > 0 do
# Line 356 | Line 414 | begin
414    end;
415   end;
416  
417 + function TFBClientAPI.DecodeInteger(bufptr: PByte; len: short): int64;
418 + begin
419 +  Result := isc_portable_integer(bufptr,len);
420 + end;
421 +
422 + function TFBClientAPI.Int128ToStr(bufptr: PByte; scale: integer): AnsiString;
423 + begin
424 +  if not HasInt128Support then
425 +    IBError(ibxeNotSupported,[]);
426 + end;
427 +
428 + procedure TFBClientAPI.StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte);
429 + begin
430 +  if not HasInt128Support then
431 +    IBError(ibxeNotSupported,[]);
432 + end;
433 +
434 + procedure TFBClientAPI.SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal;
435 +  bufptr: PByte);
436 + begin
437 +  if not HasDecFloatSupport then
438 +    IBError(ibxeNotSupported,[]);
439 + end;
440 +
441 + function TFBClientAPI.SQLDecFloatDecode(SQLType: cardinal; bufptr: PByte): tBCD;
442 + begin
443 +  if not HasDecFloatSupport then
444 +    IBError(ibxeNotSupported,[]);
445 + end;
446 +
447   function TFBClientAPI.IsLibraryLoaded: boolean;
448   begin
449    Result := FFBLibrary.IBLibrary <> NilHandle;
# Line 366 | Line 454 | begin
454    Result := FFBLibrary;
455   end;
456  
457 + function TFBClientAPI.FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
458 + begin
459 +  {aDate/aTime are in TTimestamp format but aTime is decimilliseconds}
460 +  aDate := aDate - DateDelta;
461 +  if aDate < 0 then
462 +    Result := trunc(aDate) - abs(frac(aTime / (MSecsPerDay*10)))
463 +  else
464 +    Result := trunc(aDate) + abs(frac(aTime / (MSecsPerDay*10)));
465 + end;
466 +
467 + {$IFDEF UNIX}
468 +
469 + procedure TFBClientAPI.GetTZDataSettings;
470 + var S: TStringList;
471 + begin
472 +  FLocalTimeOffset := GetLocalTimeOffset;
473 +  {$if declared(Gettzname)}
474 +  FLocalTimeZoneName := Gettzname(tzdaylight);
475 +  {$else}
476 +  FLocalTimeZoneName := tzname[tzdaylight];
477 +  {$ifend}
478 +  FIsDaylightSavingsTime := tzdaylight;
479 +  if FileExists(DefaultTimeZoneFile) then
480 +  begin
481 +    S := TStringList.Create;
482 +    try
483 +      S.LoadFromFile(DefaultTimeZoneFile);
484 +      if S.Count > 0 then
485 +        FTZDataTimeZoneID := S[0];
486 +    finally
487 +      S.Free;
488 +    end;
489 +  end;
490 + end;
491 + {$ENDIF}
492 +
493 + {$IFDEF WINDOWS}
494 + procedure TFBClientAPI.GetTZDataSettings;
495 + var TZInfo: TTimeZoneInformation;
496 + begin
497 +  FIsDaylightSavingsTime := false;
498 +  {is there any way of working out the default TZData DB time zone ID under Windows?}
499 +  case GetTimeZoneInformation(TZInfo) of
500 +    TIME_ZONE_ID_UNKNOWN:
501 +      begin
502 +        FLocalTimeZoneName := '';
503 +        FLocalTimeOffset := 0;
504 +      end;
505 +    TIME_ZONE_ID_STANDARD:
506 +      begin
507 +        FLocalTimeZoneName := strpas(PWideChar(@TZInfo.StandardName));
508 +        FLocalTimeOffset := TZInfo.Bias;
509 +      end;
510 +    TIME_ZONE_ID_DAYLIGHT:
511 +      begin
512 +        FLocalTimeZoneName := strpas(PWideChar(@TZInfo.DaylightName));
513 +        FLocalTimeOffset := TZInfo.DayLightBias;
514 +        FIsDaylightSavingsTime := true;
515 +      end;
516 +  end;
517 + end;
518 + {$ENDIF}
519 +
520   function TFBClientAPI.GetProcAddr(ProcName: PAnsiChar): Pointer;
521   begin
522 <  Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
522 >  Result := nil;
523 >  if assigned(FFBLibrary) and (FFBLibrary.IBLibrary <> NilHandle) then
524 >    Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
525    if not Assigned(Result) then
526      raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
527   end;
528  
529 + function TFBClientAPI.HasDecFloatSupport: boolean;
530 + begin
531 +  Result := GetClientMajor >= 4;
532 + end;
533 +
534 + function TFBClientAPI.HasInt128Support: boolean;
535 + begin
536 +  Result := false;
537 + end;
538 +
539 + function TFBClientAPI.HasLocalTZDB: boolean;
540 + begin
541 +  Result := false;
542 + end;
543 +
544 + function TFBClientAPI.HasExtendedTZSupport: boolean;
545 + begin
546 +  Result := false;
547 + end;
548 +
549 + function TFBClientAPI.HasTimeZoneSupport: boolean;
550 + begin
551 +  Result := false;
552 + end;
553 +
554 + function TFBClientAPI.GetImplementationVersion: AnsiString;
555 + begin
556 +  Result := Format('%d.%d',[GetClientMajor,GetClientMinor]);
557 + end;
558 +
559   function TFBClientAPI.LoadInterface: boolean;
560   begin
561    isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
562    isc_sql_interprete := GetProcAddr('isc_sql_interprete'); {do not localize}
380 –  isc_interprete := GetProcAddr('isc_interprete'); {do not localize}
563    isc_event_counts := GetProcAddr('isc_event_counts'); {do not localize}
564    isc_event_block := GetProcAddr('isc_event_block'); {do not localize}
565    isc_free := GetProcAddr('isc_free'); {do not localize}
566 +  isc_portable_integer := GetProcAddr('isc_portable_integer'); {do not localize}
567 +  fb_shutdown := GetProcAddr('fb_shutdown'); {do not localize}
568    Result := assigned(isc_free);
569   end;
570  
571 + procedure TFBClientAPI.FBShutdown;
572 + begin
573 +  if assigned(fb_shutdown) then
574 +    fb_shutdown(0,fb_shutrsn_exit_called);
575 + end;
576 +
577   { TFBStatus }
578  
579 < constructor TFBStatus.Create(aOwner: TFBClientAPI);
579 > constructor TFBStatus.Create(aOwner: TFBClientAPI; prefix: AnsiString);
580   begin
581    inherited Create;
582    FOwner := aOwner;
583 <  FIBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
583 >  FPrefix := prefix;
584 >  FIBDataBaseErrorMessages := [ShowSQLCode, ShowSQLMessage, ShowIBMessage];
585   end;
586  
587 < function TFBStatus.GetIBErrorCode: Long;
587 > function TFBStatus.GetIBErrorCode: TStatusCode;
588   begin
589    Result := StatusVector^[1];
590   end;
591  
592 < function TFBStatus.Getsqlcode: Long;
592 > function TFBStatus.Getsqlcode: TStatusCode;
593   begin
594    with FOwner do
595      Result := isc_sqlcode(PISC_STATUS(StatusVector));
# Line 408 | Line 599 | function TFBStatus.GetMessage: AnsiStrin
599   var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
600      IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
601      sqlcode: Long;
411 –    psb: PStatusVector;
602   begin
603 <  Result := '';
603 >  Result := FPrefix;
604    IBDataBaseErrorMessages := FIBDataBaseErrorMessages;
605    sqlcode := Getsqlcode;
606    if (ShowSQLCode in IBDataBaseErrorMessages) then
607      Result := Result + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
608  
419 –  Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
609    if (ShowSQLMessage in IBDataBaseErrorMessages) then
610    begin
611      with FOwner do
612 <      isc_sql_interprete(sqlcode, local_buffer, IBLocalBufferLength);
612 >      isc_sql_interprete(sqlcode, local_buffer, sizeof(local_buffer));
613      if (ShowSQLCode in FIBDataBaseErrorMessages) then
614 <      Result := Result + CRLF;
615 <    Result := Result + strpas(local_buffer);
614 >      Result := Result + LineEnding;
615 >    Result := Result + 'Engine Code: ' + IntToStr(GetIBErrorCode) + ' ' + strpas(local_buffer);
616    end;
617  
618    if (ShowIBMessage in IBDataBaseErrorMessages) then
619    begin
620      if (ShowSQLCode in IBDataBaseErrorMessages) or
621         (ShowSQLMessage in IBDataBaseErrorMessages) then
622 <      Result := Result + CRLF;
623 <    psb := StatusVector;
435 <    with FOwner do
436 <    while (isc_interprete(@local_buffer, @psb) > 0) do
437 <    begin
438 <      if (Result <> '') and (Result[Length(Result)] <> LF) then
439 <        Result := Result + CRLF;
440 <      Result := Result + strpas(local_buffer);
441 <    end;
622 >      Result := Result + LineEnding;
623 >    Result := Result + FOwner.FormatStatus(self);
624    end;
625    if (Result <> '') and (Result[Length(Result)] = '.') then
626      Delete(Result, Length(Result), 1);

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines