ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/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.
ibx/branches/udr/client/FBClientAPI.pas (file contents), Revision 386 by tony, Tue Jan 18 12:05:35 2022 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 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 103 | Line 115 | type
115  
116    { TFBStatus }
117  
118 <  TFBStatus = class(TFBInterfacedObject)
118 >  TFBStatus = class(TFBInterfacedObject, IStatus)
119    private
120      FIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
121 +    FPrefix: AnsiString;
122 +    function SQLCodeSupported: boolean;
123    protected
124      FOwner: TFBClientAPI;
125 +    function GetIBMessage: Ansistring; virtual; abstract;
126 +    function GetSQLMessage: Ansistring;
127    public
128 <    constructor Create(aOwner: TFBClientAPI);
128 >    constructor Create(aOwner: TFBClientAPI; prefix: AnsiString='');
129      function StatusVector: PStatusVector; virtual; abstract;
130 +    procedure Assign(src: TFBStatus); virtual;
131 +    function Clone: IStatus; virtual; abstract;
132  
133      {IStatus}
134 <    function GetIBErrorCode: Long;
135 <    function Getsqlcode: Long;
134 >    function GetIBErrorCode: TStatusCode;
135 >    function Getsqlcode: TStatusCode;
136      function GetMessage: AnsiString;
137      function CheckStatusVector(ErrorCodes: array of TFBStatusCode): Boolean;
138      function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
# Line 127 | Line 145 | type
145    private
146      class var FEnvSetupDone: boolean;
147      class var FLibraryList: array of IFirebirdLibrary;
148 +  private
149      FFirebirdAPI: IFirebirdAPI;
150      FRequestedLibName: string;
151      function LoadIBLibrary: boolean;
# Line 144 | Line 163 | type
163      destructor Destroy; override;
164      class function GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
165      class procedure FreeLibraries;
166 +    function SameLibrary(aLibName: string): boolean;
167  
168 +  public
169      {IFirebirdLibrary}
170      function GetHandle: TLibHandle;
171      function GetLibraryName: string;
# Line 157 | Line 178 | type
178  
179    TFBClientAPI = class(TFBInterfacedObject)
180    private
181 +    FLocalTimeZoneName: AnsiString; {Informal Time Zone Name from tzname e.g. GMT or BST}
182 +    FTZDataTimeZoneID: AnsiString; {TZData DB ID e.g. Europe/London}
183 +    FLocalTimeOffset: integer;
184 +    FIsDaylightSavingsTime: boolean;
185      class var FIBCS: TRTLCriticalSection;
186 +    function FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
187 +    procedure GetTZDataSettings;
188    protected
189      FFBLibrary: TFBLibrary;
190      function GetProcAddr(ProcName: PAnsiChar): Pointer;
191 +
192 +  protected type
193 +    Tfb_shutdown = function (timeout: uint;
194 +                                 const reason: int): int;
195 +                   {$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
196 +  protected
197 +    {FB Shutdown API}
198 +    fb_shutdown: Tfb_shutdown;
199 +
200    public
201      {Taken from legacy API}
166    isc_sqlcode: Tisc_sqlcode;
202      isc_sql_interprete: Tisc_sql_interprete;
203 <    isc_event_counts: Tisc_event_counts;
169 <    isc_event_block: Tisc_event_block;
170 <    isc_free: Tisc_free;
203 >    isc_sqlcode: Tisc_sqlcode;
204  
205      constructor Create(aFBLibrary: TFBLibrary);
206      procedure IBAlloc(var P; OldSize, NewSize: Integer);
207      procedure IBDataBaseError;
208      function LoadInterface: boolean; virtual;
209 +    procedure FBShutdown; virtual;
210      function GetAPI: IFirebirdAPI; virtual; abstract;
211      {$IFDEF UNIX}
212      function GetFirebirdLibList: string; virtual; abstract;
213      {$ENDIF}
214 +    function HasDecFloatSupport: boolean;
215 +    function HasInt128Support: boolean; virtual;
216 +    function HasLocalTZDB: boolean; virtual;
217 +    function HasExtendedTZSupport: boolean; virtual;
218 +    function HasTimeZoneSupport: boolean; virtual;
219  
220 +  public
221 +    property LocalTimeZoneName: AnsiString read FLocalTimeZoneName;
222 +    property TZDataTimeZoneID: AnsiString read FTZDataTimeZoneID;
223 +    property LocalTimeOffset: integer read FLocalTimeOffset;
224 +  public
225      {Encode/Decode}
226 <    procedure EncodeInteger(aValue: integer; len: integer; buffer: PByte);
227 <    function DecodeInteger(bufptr: PByte; len: short): integer; virtual; abstract;
228 <    procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte); virtual; abstract;
229 <    function SQLDecodeDate(byfptr: PByte): TDateTime; virtual; abstract;
230 <    procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte); virtual; abstract;
226 >    procedure EncodeInteger(aValue: int64; len: integer; buffer: PByte);
227 >    function DecodeInteger(bufptr: PByte; len: short): int64;
228 >    procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte);  virtual; abstract;
229 >    function SQLDecodeDate(byfptr: PByte): TDateTime;  virtual; abstract;
230 >    procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte);  virtual; abstract;
231      function SQLDecodeTime(bufptr: PByte): TDateTime;  virtual; abstract;
232      procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte); virtual; abstract;
233 <    function SQLDecodeDateTime(bufptr: PByte): TDateTime; virtual; abstract;
234 <    function FormatStatus(Status: TFBStatus): AnsiString; virtual; abstract;
233 >    function  SQLDecodeDateTime(bufptr: PByte): TDateTime; 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;
# Line 197 | Line 245 | type
245      function GetImplementationVersion: AnsiString;
246      function GetClientMajor: integer;  virtual; abstract;
247      function GetClientMinor: integer;  virtual; abstract;
248 < end;
248 >  end;
249 >
250 >    IJournallingHook = interface
251 >      ['{7d3e45e0-3628-416a-9e22-c20474825031}']
252 >      procedure TransactionStart(Tr: ITransaction);
253 >      function TransactionEnd(TransactionID: integer; Action: TTransactionAction): boolean;
254 >      procedure TransactionRetained(Tr: ITransaction; OldTransactionID: integer; Action: TTransactionAction);
255 >      procedure ExecQuery(Stmt: IStatement);
256 >    end;
257  
258   implementation
259  
260   uses IBUtils, Registry,
261 <  {$IFDEF Unix} initc, dl, {$ENDIF}
261 >  {$IFDEF Unix} unix, initc, dl, {$ENDIF}
262   {$IFDEF FPC}
263   {$IFDEF WINDOWS }
264   WinDirs,
# Line 235 | Line 291 | end;
291  
292   procedure TFBLibrary.FreeFBLibrary;
293   begin
294 +  (FFirebirdAPI as TFBClientAPI).FBShutdown;
295    if FIBLibrary <> NilHandle then
296      FreeLibrary(FIBLibrary);
297    FIBLibrary := NilHandle;
298 +  FFBLibraryName := '';
299   end;
300  
301   function TFBLibrary.GetLibraryName: string;
# Line 289 | Line 347 | end;
347  
348   destructor TFBLibrary.Destroy;
349   begin
292  FFirebirdAPI := nil;
350    FreeFBLibrary;
351 +  FFirebirdAPI := nil;
352    inherited Destroy;
353   end;
354  
# Line 301 | Line 359 | begin
359    if aLibPathName <> '' then
360    begin
361      for i := 0 to Length(FLibraryList) - 1 do
362 <      if (FLibraryList[i] as TFBLibrary).FRequestedLibName = aLibPathName then
362 >    begin
363 >      if (FLibraryList[i] as TFBLibrary).SameLibrary(aLibPathName) then
364        begin
365          Result := FLibraryList[i];
366          Exit;
367        end;
368 +    end;
369      Result := Create(aLibPathName);
370    end;
371  
# Line 319 | Line 379 | begin
379    SetLength(FLibraryList,0);
380   end;
381  
382 + function TFBLibrary.SameLibrary(aLibName: string): boolean;
383 + begin
384 +  Result := FRequestedLibName = aLibName;
385 + end;
386 +
387   function TFBLibrary.GetHandle: TLibHandle;
388   begin
389    Result := FIBLibrary;
# Line 330 | Line 395 | constructor TFBClientAPI.Create(aFBLibra
395   begin
396    inherited Create;
397    FFBLibrary := aFBLibrary;
398 +  GetTZDataSettings;
399   end;
400  
401   procedure TFBClientAPI.IBAlloc(var P; OldSize, NewSize: Integer);
# Line 345 | Line 411 | begin
411    raise EIBInterBaseError.Create(GetStatus);
412   end;
413  
414 < {Under Unixes, if using an embedded server then set up local TMP and LOCK Directories}
349 <
350 < procedure TFBClientAPI.EncodeInteger(aValue: integer; len: integer; buffer: PByte);
414 > procedure TFBClientAPI.EncodeInteger(aValue: int64; len: integer; buffer: PByte);
415   begin
416    while len > 0 do
417    begin
# Line 358 | Line 422 | begin
422    end;
423   end;
424  
425 + (*
426 +  DecodeInteger is Translated from
427 +
428 + SINT64 API_ROUTINE isc_portable_integer(const UCHAR* ptr, SSHORT length)
429 + if (!ptr || length <= 0 || length > 8)
430 +        return 0;
431 +
432 + SINT64 value = 0;
433 + int shift = 0;
434 +
435 + while (--length > 0)
436 + {
437 +        value += ((SINT64) *ptr++) << shift;
438 +        shift += 8;
439 + }
440 +
441 + value += ((SINT64)(SCHAR) *ptr) << shift;
442 +
443 + return value;
444 + *)
445 +
446 + function TFBClientAPI.DecodeInteger(bufptr: PByte; len: short): int64;
447 + var shift: integer;
448 + begin
449 +  Result := 0;
450 +  if (BufPtr = nil) or (len <= 0) or (len > 8) then
451 +    Exit;
452 +
453 +  shift := 0;
454 +  dec(len);
455 +  while len > 0 do
456 +  begin
457 +    Result := Result + (int64(bufptr^) shl shift);
458 +    Inc(bufptr);
459 +    shift := shift + 8;
460 +    dec(len);
461 +  end;
462 +  Result := Result + (int64(bufptr^) shl shift);
463 + end;
464 +
465 + function TFBClientAPI.Int128ToStr(bufptr: PByte; scale: integer): AnsiString;
466 + begin
467 +  if not HasInt128Support then
468 +    IBError(ibxeNotSupported,[]);
469 + end;
470 +
471 + procedure TFBClientAPI.StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte);
472 + begin
473 +  if not HasInt128Support then
474 +    IBError(ibxeNotSupported,[]);
475 + end;
476 +
477 + procedure TFBClientAPI.SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal;
478 +  bufptr: PByte);
479 + begin
480 +  if not HasDecFloatSupport then
481 +    IBError(ibxeNotSupported,[]);
482 + end;
483 +
484 + function TFBClientAPI.SQLDecFloatDecode(SQLType: cardinal; bufptr: PByte): tBCD;
485 + begin
486 +  if not HasDecFloatSupport then
487 +    IBError(ibxeNotSupported,[]);
488 + end;
489 +
490   function TFBClientAPI.IsLibraryLoaded: boolean;
491   begin
492    Result := FFBLibrary.IBLibrary <> NilHandle;
# Line 368 | Line 497 | begin
497    Result := FFBLibrary;
498   end;
499  
500 < function TFBClientAPI.GetImplementationVersion: AnsiString;
500 > function TFBClientAPI.FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
501   begin
502 <  Result := Format('%d.%d',[GetClientMajor,GetClientMinor]);
502 >  {aDate/aTime are in TTimestamp format but aTime is decimilliseconds}
503 >  aDate := aDate - DateDelta;
504 >  if aDate < 0 then
505 >    Result := trunc(aDate) - abs(frac(aTime / (MSecsPerDay*10)))
506 >  else
507 >    Result := trunc(aDate) + abs(frac(aTime / (MSecsPerDay*10)));
508 > end;
509 >
510 > {$IFDEF UNIX}
511 >
512 > procedure TFBClientAPI.GetTZDataSettings;
513 > var S: TStringList;
514 > begin
515 >  FLocalTimeOffset := GetLocalTimeOffset;
516 >  {$if declared(Gettzname)}
517 >  FLocalTimeZoneName := Gettzname(tzdaylight);
518 >  {$else}
519 >  FLocalTimeZoneName := tzname[tzdaylight];
520 >  {$ifend}
521 >  FIsDaylightSavingsTime := tzdaylight;
522 >  if FileExists(DefaultTimeZoneFile) then
523 >  begin
524 >    S := TStringList.Create;
525 >    try
526 >      S.LoadFromFile(DefaultTimeZoneFile);
527 >      if S.Count > 0 then
528 >        FTZDataTimeZoneID := S[0];
529 >    finally
530 >      S.Free;
531 >    end;
532 >  end;
533   end;
534 + {$ENDIF}
535 +
536 + {$IFDEF WINDOWS}
537 + procedure TFBClientAPI.GetTZDataSettings;
538 + var TZInfo: TTimeZoneInformation;
539 + begin
540 +  FIsDaylightSavingsTime := false;
541 +  {is there any way of working out the default TZData DB time zone ID under Windows?}
542 +  case GetTimeZoneInformation(TZInfo) of
543 +    TIME_ZONE_ID_UNKNOWN:
544 +      begin
545 +        FLocalTimeZoneName := '';
546 +        FLocalTimeOffset := 0;
547 +      end;
548 +    TIME_ZONE_ID_STANDARD:
549 +      begin
550 +        FLocalTimeZoneName := strpas(PWideChar(@TZInfo.StandardName));
551 +        FLocalTimeOffset := TZInfo.Bias;
552 +      end;
553 +    TIME_ZONE_ID_DAYLIGHT:
554 +      begin
555 +        FLocalTimeZoneName := strpas(PWideChar(@TZInfo.DaylightName));
556 +        FLocalTimeOffset := TZInfo.DayLightBias;
557 +        FIsDaylightSavingsTime := true;
558 +      end;
559 +  end;
560 + end;
561 + {$ENDIF}
562  
563   function TFBClientAPI.GetProcAddr(ProcName: PAnsiChar): Pointer;
564   begin
565 <  Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
565 >  Result := nil;
566 >  if assigned(FFBLibrary) and (FFBLibrary.IBLibrary <> NilHandle) then
567 >    Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
568    if not Assigned(Result) then
569      raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
570   end;
571  
572 + function TFBClientAPI.HasDecFloatSupport: boolean;
573 + begin
574 +  Result := GetClientMajor >= 4;
575 + end;
576 +
577 + function TFBClientAPI.HasInt128Support: boolean;
578 + begin
579 +  Result := false;
580 + end;
581 +
582 + function TFBClientAPI.HasLocalTZDB: boolean;
583 + begin
584 +  Result := false;
585 + end;
586 +
587 + function TFBClientAPI.HasExtendedTZSupport: boolean;
588 + begin
589 +  Result := false;
590 + end;
591 +
592 + function TFBClientAPI.HasTimeZoneSupport: boolean;
593 + begin
594 +  Result := false;
595 + end;
596 +
597 + function TFBClientAPI.GetImplementationVersion: AnsiString;
598 + begin
599 +  Result := Format('%d.%d',[GetClientMajor,GetClientMinor]);
600 + end;
601 +
602   function TFBClientAPI.LoadInterface: boolean;
603   begin
604    isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
605    isc_sql_interprete := GetProcAddr('isc_sql_interprete'); {do not localize}
606 <  isc_event_counts := GetProcAddr('isc_event_counts'); {do not localize}
607 <  isc_event_block := GetProcAddr('isc_event_block'); {do not localize}
608 <  isc_free := GetProcAddr('isc_free'); {do not localize}
609 <  Result := assigned(isc_free);
606 >  fb_shutdown := GetProcAddr('fb_shutdown'); {do not localize}
607 >  Result := true; {don't case if these fail to load}
608 > end;
609 >
610 > procedure TFBClientAPI.FBShutdown;
611 > begin
612 >  if assigned(fb_shutdown) then
613 >    fb_shutdown(0,fb_shutrsn_exit_called);
614   end;
615  
616   { TFBStatus }
617  
618 < constructor TFBStatus.Create(aOwner: TFBClientAPI);
618 > function TFBStatus.SQLCodeSupported: boolean;
619 > begin
620 >  Result:= (FOwner <> nil) and assigned(FOwner.isc_sqlcode) and  assigned(FOwner.isc_sql_interprete);
621 > end;
622 >
623 > function TFBStatus.GetSQLMessage: Ansistring;
624 > var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
625 > begin
626 >  Result := '';
627 >  if (FOwner <> nil) and assigned(FOwner.isc_sql_interprete) then
628 >  begin
629 >     FOwner.isc_sql_interprete(Getsqlcode, local_buffer, sizeof(local_buffer));
630 >     Result := strpas(local_buffer);
631 >  end;
632 > end;
633 >
634 > constructor TFBStatus.Create(aOwner: TFBClientAPI; prefix: AnsiString);
635   begin
636    inherited Create;
637    FOwner := aOwner;
638 <  FIBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
638 >  FPrefix := prefix;
639 >  FIBDataBaseErrorMessages := [ShowIBMessage];
640 > end;
641 >
642 > procedure TFBStatus.Assign(src: TFBStatus);
643 > begin
644 >  FOwner := src.FOwner;
645 >  FPrefix := src.FPrefix;
646 >  SetIBDataBaseErrorMessages(src.GetIBDataBaseErrorMessages);
647   end;
648  
649 < function TFBStatus.GetIBErrorCode: Long;
649 > function TFBStatus.GetIBErrorCode: TStatusCode;
650   begin
651    Result := StatusVector^[1];
652   end;
653  
654 < function TFBStatus.Getsqlcode: Long;
654 > function TFBStatus.Getsqlcode: TStatusCode;
655   begin
656 <  with FOwner do
657 <    Result := isc_sqlcode(PISC_STATUS(StatusVector));
656 >  if (FOwner <> nil) and assigned(FOwner.isc_sqlcode) then
657 >    Result := FOwner.isc_sqlcode(PISC_STATUS(StatusVector))
658 >  else
659 >    Result := -999; {generic SQL Code}
660   end;
661  
662   function TFBStatus.GetMessage: AnsiString;
663 < var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
415 <    IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
416 <    sqlcode: Long;
663 > var IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
664   begin
665 <  Result := '';
665 >  Result := FPrefix;
666    IBDataBaseErrorMessages := FIBDataBaseErrorMessages;
667 <  sqlcode := Getsqlcode;
668 <  if (ShowSQLCode in IBDataBaseErrorMessages) then
669 <    Result := Result + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
670 <
671 <  Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
672 <  if (ShowSQLMessage in IBDataBaseErrorMessages) then
673 <  begin
674 <    with FOwner do
675 <      isc_sql_interprete(sqlcode, local_buffer, sizeof(local_buffer));
676 <    if (ShowSQLCode in FIBDataBaseErrorMessages) then
677 <      Result := Result + CRLF;
431 <    Result := Result + strpas(local_buffer);
667 >  if SQLCodeSupported then
668 >  begin
669 >    if (ShowSQLCode in IBDataBaseErrorMessages) then
670 >      Result := Result + 'SQLCODE: ' + IntToStr(Getsqlcode); {do not localize}
671 >
672 >    if (ShowSQLMessage in IBDataBaseErrorMessages) then
673 >    begin
674 >      if ShowSQLCode in IBDataBaseErrorMessages then
675 >        Result := Result + LineEnding;
676 >      Result := Result + GetSQLMessage;
677 >    end;
678    end;
679  
680    if (ShowIBMessage in IBDataBaseErrorMessages) then
681    begin
682 <    if (ShowSQLCode in IBDataBaseErrorMessages) or
437 <       (ShowSQLMessage in IBDataBaseErrorMessages) then
682 >    if Result <> FPrefix then
683        Result := Result + LineEnding;
684 <    Result := Result + LineEnding + FOwner.FormatStatus(self);
684 >    Result := Result + 'Engine Code: ' + IntToStr(GetIBErrorCode) + LineEnding + GetIBMessage;
685    end;
686    if (Result <> '') and (Result[Length(Result)] = '.') then
687      Delete(Result, Length(Result), 1);

Comparing:
ibx/trunk/fbintf/client/FBClientAPI.pas (property svn:eol-style), Revision 308 by tony, Sat Jul 18 10:26:30 2020 UTC vs.
ibx/branches/udr/client/FBClientAPI.pas (property svn:eol-style), Revision 386 by tony, Tue Jan 18 12:05:35 2022 UTC

# Line 0 | Line 1
1 + native

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines