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 387 by tony, Wed Jan 19 13:34:42 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; Completion: TTrCompletionState): boolean;
254 >      procedure TransactionRetained(Tr: ITransaction; OldTransactionID: integer; Action: TTransactionAction);
255 >      procedure ExecQuery(Stmt: IStatement);
256 >      procedure ExecImmediateJnl(sql: AnsiString; tr: ITransaction);
257 >    end;
258  
259   implementation
260  
261   uses IBUtils, Registry,
262 <  {$IFDEF Unix} initc, dl, {$ENDIF}
262 >  {$IFDEF Unix} unix, initc, dl, {$ENDIF}
263   {$IFDEF FPC}
264   {$IFDEF WINDOWS }
265   WinDirs,
# Line 235 | Line 292 | end;
292  
293   procedure TFBLibrary.FreeFBLibrary;
294   begin
295 +  (FFirebirdAPI as TFBClientAPI).FBShutdown;
296    if FIBLibrary <> NilHandle then
297      FreeLibrary(FIBLibrary);
298    FIBLibrary := NilHandle;
299 +  FFBLibraryName := '';
300   end;
301  
302   function TFBLibrary.GetLibraryName: string;
# Line 289 | Line 348 | end;
348  
349   destructor TFBLibrary.Destroy;
350   begin
292  FFirebirdAPI := nil;
351    FreeFBLibrary;
352 +  FFirebirdAPI := nil;
353    inherited Destroy;
354   end;
355  
# Line 301 | Line 360 | begin
360    if aLibPathName <> '' then
361    begin
362      for i := 0 to Length(FLibraryList) - 1 do
363 <      if (FLibraryList[i] as TFBLibrary).FRequestedLibName = aLibPathName then
363 >    begin
364 >      if (FLibraryList[i] as TFBLibrary).SameLibrary(aLibPathName) then
365        begin
366          Result := FLibraryList[i];
367          Exit;
368        end;
369 +    end;
370      Result := Create(aLibPathName);
371    end;
372  
# Line 319 | Line 380 | begin
380    SetLength(FLibraryList,0);
381   end;
382  
383 + function TFBLibrary.SameLibrary(aLibName: string): boolean;
384 + begin
385 +  Result := FRequestedLibName = aLibName;
386 + end;
387 +
388   function TFBLibrary.GetHandle: TLibHandle;
389   begin
390    Result := FIBLibrary;
# Line 330 | Line 396 | constructor TFBClientAPI.Create(aFBLibra
396   begin
397    inherited Create;
398    FFBLibrary := aFBLibrary;
399 +  GetTZDataSettings;
400   end;
401  
402   procedure TFBClientAPI.IBAlloc(var P; OldSize, NewSize: Integer);
# Line 345 | Line 412 | begin
412    raise EIBInterBaseError.Create(GetStatus);
413   end;
414  
415 < {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);
415 > procedure TFBClientAPI.EncodeInteger(aValue: int64; len: integer; buffer: PByte);
416   begin
417    while len > 0 do
418    begin
# Line 358 | Line 423 | begin
423    end;
424   end;
425  
426 + (*
427 +  DecodeInteger is Translated from
428 +
429 + SINT64 API_ROUTINE isc_portable_integer(const UCHAR* ptr, SSHORT length)
430 + if (!ptr || length <= 0 || length > 8)
431 +        return 0;
432 +
433 + SINT64 value = 0;
434 + int shift = 0;
435 +
436 + while (--length > 0)
437 + {
438 +        value += ((SINT64) *ptr++) << shift;
439 +        shift += 8;
440 + }
441 +
442 + value += ((SINT64)(SCHAR) *ptr) << shift;
443 +
444 + return value;
445 + *)
446 +
447 + function TFBClientAPI.DecodeInteger(bufptr: PByte; len: short): int64;
448 + var shift: integer;
449 + begin
450 +  Result := 0;
451 +  if (BufPtr = nil) or (len <= 0) or (len > 8) then
452 +    Exit;
453 +
454 +  shift := 0;
455 +  dec(len);
456 +  while len > 0 do
457 +  begin
458 +    Result := Result + (int64(bufptr^) shl shift);
459 +    Inc(bufptr);
460 +    shift := shift + 8;
461 +    dec(len);
462 +  end;
463 +  Result := Result + (int64(bufptr^) shl shift);
464 + end;
465 +
466 + function TFBClientAPI.Int128ToStr(bufptr: PByte; scale: integer): AnsiString;
467 + begin
468 +  if not HasInt128Support then
469 +    IBError(ibxeNotSupported,[]);
470 + end;
471 +
472 + procedure TFBClientAPI.StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte);
473 + begin
474 +  if not HasInt128Support then
475 +    IBError(ibxeNotSupported,[]);
476 + end;
477 +
478 + procedure TFBClientAPI.SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal;
479 +  bufptr: PByte);
480 + begin
481 +  if not HasDecFloatSupport then
482 +    IBError(ibxeNotSupported,[]);
483 + end;
484 +
485 + function TFBClientAPI.SQLDecFloatDecode(SQLType: cardinal; bufptr: PByte): tBCD;
486 + begin
487 +  if not HasDecFloatSupport then
488 +    IBError(ibxeNotSupported,[]);
489 + end;
490 +
491   function TFBClientAPI.IsLibraryLoaded: boolean;
492   begin
493    Result := FFBLibrary.IBLibrary <> NilHandle;
# Line 368 | Line 498 | begin
498    Result := FFBLibrary;
499   end;
500  
501 < function TFBClientAPI.GetImplementationVersion: AnsiString;
501 > function TFBClientAPI.FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
502   begin
503 <  Result := Format('%d.%d',[GetClientMajor,GetClientMinor]);
503 >  {aDate/aTime are in TTimestamp format but aTime is decimilliseconds}
504 >  aDate := aDate - DateDelta;
505 >  if aDate < 0 then
506 >    Result := trunc(aDate) - abs(frac(aTime / (MSecsPerDay*10)))
507 >  else
508 >    Result := trunc(aDate) + abs(frac(aTime / (MSecsPerDay*10)));
509 > end;
510 >
511 > {$IFDEF UNIX}
512 >
513 > procedure TFBClientAPI.GetTZDataSettings;
514 > var S: TStringList;
515 > begin
516 >  FLocalTimeOffset := GetLocalTimeOffset;
517 >  {$if declared(Gettzname)}
518 >  FLocalTimeZoneName := Gettzname(tzdaylight);
519 >  {$else}
520 >  FLocalTimeZoneName := tzname[tzdaylight];
521 >  {$ifend}
522 >  FIsDaylightSavingsTime := tzdaylight;
523 >  if FileExists(DefaultTimeZoneFile) then
524 >  begin
525 >    S := TStringList.Create;
526 >    try
527 >      S.LoadFromFile(DefaultTimeZoneFile);
528 >      if S.Count > 0 then
529 >        FTZDataTimeZoneID := S[0];
530 >    finally
531 >      S.Free;
532 >    end;
533 >  end;
534   end;
535 + {$ENDIF}
536 +
537 + {$IFDEF WINDOWS}
538 + procedure TFBClientAPI.GetTZDataSettings;
539 + var TZInfo: TTimeZoneInformation;
540 + begin
541 +  FIsDaylightSavingsTime := false;
542 +  {is there any way of working out the default TZData DB time zone ID under Windows?}
543 +  case GetTimeZoneInformation(TZInfo) of
544 +    TIME_ZONE_ID_UNKNOWN:
545 +      begin
546 +        FLocalTimeZoneName := '';
547 +        FLocalTimeOffset := 0;
548 +      end;
549 +    TIME_ZONE_ID_STANDARD:
550 +      begin
551 +        FLocalTimeZoneName := strpas(PWideChar(@TZInfo.StandardName));
552 +        FLocalTimeOffset := TZInfo.Bias;
553 +      end;
554 +    TIME_ZONE_ID_DAYLIGHT:
555 +      begin
556 +        FLocalTimeZoneName := strpas(PWideChar(@TZInfo.DaylightName));
557 +        FLocalTimeOffset := TZInfo.DayLightBias;
558 +        FIsDaylightSavingsTime := true;
559 +      end;
560 +  end;
561 + end;
562 + {$ENDIF}
563  
564   function TFBClientAPI.GetProcAddr(ProcName: PAnsiChar): Pointer;
565   begin
566 <  Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
566 >  Result := nil;
567 >  if assigned(FFBLibrary) and (FFBLibrary.IBLibrary <> NilHandle) then
568 >    Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
569    if not Assigned(Result) then
570      raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
571   end;
572  
573 + function TFBClientAPI.HasDecFloatSupport: boolean;
574 + begin
575 +  Result := GetClientMajor >= 4;
576 + end;
577 +
578 + function TFBClientAPI.HasInt128Support: boolean;
579 + begin
580 +  Result := false;
581 + end;
582 +
583 + function TFBClientAPI.HasLocalTZDB: boolean;
584 + begin
585 +  Result := false;
586 + end;
587 +
588 + function TFBClientAPI.HasExtendedTZSupport: boolean;
589 + begin
590 +  Result := false;
591 + end;
592 +
593 + function TFBClientAPI.HasTimeZoneSupport: boolean;
594 + begin
595 +  Result := false;
596 + end;
597 +
598 + function TFBClientAPI.GetImplementationVersion: AnsiString;
599 + begin
600 +  Result := Format('%d.%d',[GetClientMajor,GetClientMinor]);
601 + end;
602 +
603   function TFBClientAPI.LoadInterface: boolean;
604   begin
605    isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
606    isc_sql_interprete := GetProcAddr('isc_sql_interprete'); {do not localize}
607 <  isc_event_counts := GetProcAddr('isc_event_counts'); {do not localize}
608 <  isc_event_block := GetProcAddr('isc_event_block'); {do not localize}
609 <  isc_free := GetProcAddr('isc_free'); {do not localize}
610 <  Result := assigned(isc_free);
607 >  fb_shutdown := GetProcAddr('fb_shutdown'); {do not localize}
608 >  Result := true; {don't case if these fail to load}
609 > end;
610 >
611 > procedure TFBClientAPI.FBShutdown;
612 > begin
613 >  if assigned(fb_shutdown) then
614 >    fb_shutdown(0,fb_shutrsn_exit_called);
615   end;
616  
617   { TFBStatus }
618  
619 < constructor TFBStatus.Create(aOwner: TFBClientAPI);
619 > function TFBStatus.SQLCodeSupported: boolean;
620 > begin
621 >  Result:= (FOwner <> nil) and assigned(FOwner.isc_sqlcode) and  assigned(FOwner.isc_sql_interprete);
622 > end;
623 >
624 > function TFBStatus.GetSQLMessage: Ansistring;
625 > var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
626 > begin
627 >  Result := '';
628 >  if (FOwner <> nil) and assigned(FOwner.isc_sql_interprete) then
629 >  begin
630 >     FOwner.isc_sql_interprete(Getsqlcode, local_buffer, sizeof(local_buffer));
631 >     Result := strpas(local_buffer);
632 >  end;
633 > end;
634 >
635 > constructor TFBStatus.Create(aOwner: TFBClientAPI; prefix: AnsiString);
636   begin
637    inherited Create;
638    FOwner := aOwner;
639 <  FIBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
639 >  FPrefix := prefix;
640 >  FIBDataBaseErrorMessages := [ShowIBMessage];
641 > end;
642 >
643 > procedure TFBStatus.Assign(src: TFBStatus);
644 > begin
645 >  FOwner := src.FOwner;
646 >  FPrefix := src.FPrefix;
647 >  SetIBDataBaseErrorMessages(src.GetIBDataBaseErrorMessages);
648   end;
649  
650 < function TFBStatus.GetIBErrorCode: Long;
650 > function TFBStatus.GetIBErrorCode: TStatusCode;
651   begin
652    Result := StatusVector^[1];
653   end;
654  
655 < function TFBStatus.Getsqlcode: Long;
655 > function TFBStatus.Getsqlcode: TStatusCode;
656   begin
657 <  with FOwner do
658 <    Result := isc_sqlcode(PISC_STATUS(StatusVector));
657 >  if (FOwner <> nil) and assigned(FOwner.isc_sqlcode) then
658 >    Result := FOwner.isc_sqlcode(PISC_STATUS(StatusVector))
659 >  else
660 >    Result := -999; {generic SQL Code}
661   end;
662  
663   function TFBStatus.GetMessage: AnsiString;
664 < var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
415 <    IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
416 <    sqlcode: Long;
664 > var IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
665   begin
666 <  Result := '';
666 >  Result := FPrefix;
667    IBDataBaseErrorMessages := FIBDataBaseErrorMessages;
668 <  sqlcode := Getsqlcode;
669 <  if (ShowSQLCode in IBDataBaseErrorMessages) then
670 <    Result := Result + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
671 <
672 <  Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
673 <  if (ShowSQLMessage in IBDataBaseErrorMessages) then
674 <  begin
675 <    with FOwner do
676 <      isc_sql_interprete(sqlcode, local_buffer, sizeof(local_buffer));
677 <    if (ShowSQLCode in FIBDataBaseErrorMessages) then
678 <      Result := Result + CRLF;
431 <    Result := Result + strpas(local_buffer);
668 >  if SQLCodeSupported then
669 >  begin
670 >    if (ShowSQLCode in IBDataBaseErrorMessages) then
671 >      Result := Result + 'SQLCODE: ' + IntToStr(Getsqlcode); {do not localize}
672 >
673 >    if (ShowSQLMessage in IBDataBaseErrorMessages) then
674 >    begin
675 >      if ShowSQLCode in IBDataBaseErrorMessages then
676 >        Result := Result + LineEnding;
677 >      Result := Result + GetSQLMessage;
678 >    end;
679    end;
680  
681    if (ShowIBMessage in IBDataBaseErrorMessages) then
682    begin
683 <    if (ShowSQLCode in IBDataBaseErrorMessages) or
437 <       (ShowSQLMessage in IBDataBaseErrorMessages) then
683 >    if Result <> FPrefix then
684        Result := Result + LineEnding;
685 <    Result := Result + LineEnding + FOwner.FormatStatus(self);
685 >    Result := Result + 'Engine Code: ' + IntToStr(GetIBErrorCode) + LineEnding + GetIBMessage;
686    end;
687    if (Result <> '') and (Result[Length(Result)] = '.') then
688      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 387 by tony, Wed Jan 19 13:34:42 2022 UTC

# Line 0 | Line 1
1 + native

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines