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 47 by tony, Mon Jan 9 15:31:51 2017 UTC vs.
ibx/branches/udr/client/FBClientAPI.pas (file contents), Revision 390 by tony, Sat Jan 22 16:15:12 2022 UTC

# Line 60 | Line 60
60   {                                                                        }
61   {************************************************************************}
62   unit FBClientAPI;
63 + {$IFDEF MSWINDOWS}
64 + {$DEFINE WINDOWS}
65 + {$ENDIF}
66  
67   {$IFDEF FPC}
68   {$mode delphi}
# Line 70 | Line 73 | unit FBClientAPI;
73   interface
74  
75   uses
76 <  Classes,  Dynlibs, IB, IBHeader, FBActivityMonitor, FBMessages, IBExternals;
76 >  Classes,
77 >    {$IFDEF WINDOWS}Windows, {$ENDIF}
78 >    {$IFDEF FPC} Dynlibs, {$ENDIF}
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 84 | 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 92 | Line 115 | type
115  
116    { TFBStatus }
117  
118 <  TFBStatus = class(TFBInterfacedObject)
118 >  TFBStatus = class(TFBInterfacedObject, IStatus)
119    private
97 –    FIBCS: TRTLCriticalSection; static;
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 >    constructor Copy(src: TFBStatus);
130      function StatusVector: PStatusVector; virtual; abstract;
131 +    function Clone: IStatus; virtual; abstract;
132  
133      {IStatus}
134 <    function GetIBErrorCode: Long;
135 <    function Getsqlcode: Long;
136 <    function GetMessage: string;
134 >    function InErrorState: boolean; virtual; abstract;
135 >    function GetIBErrorCode: TStatusCode;
136 >    function Getsqlcode: TStatusCode;
137 >    function GetMessage: AnsiString;
138      function CheckStatusVector(ErrorCodes: array of TFBStatusCode): Boolean;
139      function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
140      procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
141    end;
142  
143 +  { TFBLibrary }
144 +
145 +  TFBLibrary = class(TFBInterfacedObject,IFirebirdLibrary)
146 +  private
147 +    class var FEnvSetupDone: boolean;
148 +    class var FLibraryList: array of IFirebirdLibrary;
149 +  private
150 +    FFirebirdAPI: IFirebirdAPI;
151 +    FRequestedLibName: string;
152 +    function LoadIBLibrary: boolean;
153 +  protected
154 +    FFBLibraryName: string;
155 +    FIBLibrary: TLibHandle;
156 +    procedure FreeFBLibrary;
157 +    function GetOverrideLibName: string;
158 +    class procedure SetupEnvironment;
159 +  protected
160 +    function GetFirebird3API: IFirebirdAPI; virtual; abstract;
161 +    function GetLegacyFirebirdAPI: IFirebirdAPI; virtual; abstract;
162 +  public
163 +    constructor Create(aLibPathName: string='');
164 +    destructor Destroy; override;
165 +    class function GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
166 +    class procedure FreeLibraries;
167 +    function SameLibrary(aLibName: string): boolean;
168 +
169 +  public
170 +    {IFirebirdLibrary}
171 +    function GetHandle: TLibHandle;
172 +    function GetLibraryName: string;
173 +    function GetLibraryFilePath: string;
174 +    function GetFirebirdAPI: IFirebirdAPI;
175 +    property IBLibrary: TLibHandle read FIBLibrary;
176 +  end;
177 +
178    { TFBClientAPI }
179  
180    TFBClientAPI = class(TFBInterfacedObject)
181    private
182 <    FOwnsIBLibrary: boolean;
183 <    procedure LoadIBLibrary;
182 >    FLocalTimeZoneName: AnsiString; {Informal Time Zone Name from tzname e.g. GMT or BST}
183 >    FTZDataTimeZoneID: AnsiString; {TZData DB ID e.g. Europe/London}
184 >    FLocalTimeOffset: integer;
185 >    FIsDaylightSavingsTime: boolean;
186 >    class var FIBCS: TRTLCriticalSection;
187 >    function FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
188 >    procedure GetTZDataSettings;
189    protected
190 <    FFBLibraryName: string; static;
191 <    FFBLibraryPath: string; static;
192 <    IBLibrary: TLibHandle; static;
193 <    function GetProcAddr(ProcName: PChar): Pointer;
194 <    function GetOverrideLibName: string;
195 <    {$IFDEF UNIX}
196 <    function GetFirebirdLibList: string; virtual; abstract;
197 <    {$ENDIF}
198 <    procedure LoadInterface; virtual;
190 >    FFBLibrary: TFBLibrary;
191 >    function GetProcAddr(ProcName: PAnsiChar): Pointer;
192 >
193 >  protected type
194 >    Tfb_shutdown = function (timeout: uint;
195 >                                 const reason: int): int;
196 >                   {$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
197 >  protected
198 >    {FB Shutdown API}
199 >    fb_shutdown: Tfb_shutdown;
200 >
201    public
202      {Taken from legacy API}
132 –    isc_sqlcode: Tisc_sqlcode;
203      isc_sql_interprete: Tisc_sql_interprete;
204 <    isc_interprete: Tisc_interprete;
135 <    isc_event_counts: Tisc_event_counts;
136 <    isc_event_block: Tisc_event_block;
137 <    isc_free: Tisc_free;
204 >    isc_sqlcode: Tisc_sqlcode;
205  
206 <    constructor Create;
140 <    destructor Destroy; override;
206 >    constructor Create(aFBLibrary: TFBLibrary);
207      procedure IBAlloc(var P; OldSize, NewSize: Integer);
208      procedure IBDataBaseError;
209 <    procedure SetupEnvironment;
209 >    function LoadInterface: boolean; virtual;
210 >    procedure FBShutdown; virtual;
211 >    function GetAPI: IFirebirdAPI; virtual; abstract;
212 >    {$IFDEF UNIX}
213 >    function GetFirebirdLibList: string; virtual; abstract;
214 >    {$ENDIF}
215 >    function HasDecFloatSupport: boolean;
216 >    function HasInt128Support: boolean; virtual;
217 >    function HasLocalTZDB: boolean; virtual;
218 >    function HasExtendedTZSupport: boolean; virtual;
219 >    function HasTimeZoneSupport: boolean; virtual;
220  
221 +  public
222 +    property LocalTimeZoneName: AnsiString read FLocalTimeZoneName;
223 +    property TZDataTimeZoneID: AnsiString read FTZDataTimeZoneID;
224 +    property LocalTimeOffset: integer read FLocalTimeOffset;
225 +  public
226      {Encode/Decode}
227 <    procedure EncodeInteger(aValue: integer; len: integer; buffer: PChar);
228 <    function DecodeInteger(bufptr: PChar; len: short): integer; virtual; abstract;
229 <    procedure SQLEncodeDate(aDate: TDateTime; bufptr: PChar); virtual; abstract;
230 <    function SQLDecodeDate(byfptr: PChar): TDateTime; virtual; abstract;
231 <    procedure SQLEncodeTime(aTime: TDateTime; bufptr: PChar); virtual; abstract;
232 <    function SQLDecodeTime(bufptr: PChar): TDateTime;  virtual; abstract;
233 <    procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PChar); virtual; abstract;
234 <    function SQLDecodeDateTime(bufptr: PChar): TDateTime; virtual; abstract;
235 <
227 >    procedure EncodeInteger(aValue: int64; len: integer; buffer: PByte);
228 >    function DecodeInteger(bufptr: PByte; len: short): int64;
229 >    procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte);  virtual; abstract;
230 >    function SQLDecodeDate(byfptr: PByte): TDateTime;  virtual; abstract;
231 >    procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte);  virtual; abstract;
232 >    function SQLDecodeTime(bufptr: PByte): TDateTime;  virtual; abstract;
233 >    procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte); virtual; abstract;
234 >    function  SQLDecodeDateTime(bufptr: PByte): TDateTime; virtual; abstract;
235 >    function Int128ToStr(bufptr: PByte; scale: integer): AnsiString; virtual;
236 >    procedure StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte);
237 >      virtual;
238 >    procedure SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal; bufptr: PByte); virtual;
239 >    function SQLDecFloatDecode(SQLType: cardinal;  bufptr: PByte): tBCD; virtual;
240  
241      {IFirebirdAPI}
242      function GetStatus: IStatus; virtual; abstract;
243      function IsLibraryLoaded: boolean;
244      function IsEmbeddedServer: boolean; virtual; abstract;
245 <    function GetLibraryName: string;
246 <    function GetCharsetName(CharSetID: integer): string;
247 <    function CharSetID2CodePage(CharSetID: integer; var CodePage: TSystemCodePage): boolean;
248 <    function CodePage2CharSetID(CodePage: TSystemCodePage; var CharSetID: integer): boolean;
164 <    function CharSetName2CharSetID(CharSetName: string; var CharSetID: integer): boolean;
165 <    function CharSetWidth(CharSetID: integer; var Width: integer): boolean;
245 >    function GetFBLibrary: IFirebirdLibrary;
246 >    function GetImplementationVersion: AnsiString;
247 >    function GetClientMajor: integer;  virtual; abstract;
248 >    function GetClientMinor: integer;  virtual; abstract;
249    end;
250  
251 < const FirebirdClientAPI: TFBClientAPI = nil;
251 >    IJournallingHook = interface
252 >      ['{7d3e45e0-3628-416a-9e22-c20474825031}']
253 >      procedure TransactionStart(Tr: ITransaction);
254 >      function TransactionEnd(TransactionID: integer; Completion: TTrCompletionState): boolean;
255 >      procedure TransactionRetained(Tr: ITransaction; OldTransactionID: integer; Action: TTransactionAction);
256 >      procedure ExecQuery(Stmt: IStatement);
257 >      procedure ExecImmediateJnl(sql: AnsiString; tr: ITransaction);
258 >    end;
259  
260   implementation
261  
262 < uses IBUtils, {$IFDEF Unix} initc, {$ENDIF}
262 > uses IBUtils, Registry,
263 >  {$IFDEF Unix} unix, initc, dl, {$ENDIF}
264 > {$IFDEF FPC}
265   {$IFDEF WINDOWS }
266 < Windows,Registry, WinDirs,
266 > WinDirs,
267 > {$ENDIF}
268 > {$ELSE}
269 > ShlObj,
270   {$ENDIF}
271   SysUtils;
272  
273   {$IFDEF UNIX}
274 < {$I uloadlibrary.inc}
274 > {$I 'include/uloadlibrary.inc'}
275   {$ELSE}
276 < {$I wloadlibrary.inc}
276 > {$I 'include/wloadlibrary.inc'}
277   {$ENDIF}
278  
279 < type
280 <  TCharsetMap = record
281 <    CharsetID: integer;
282 <    CharSetName: string;
283 <    CharSetWidth: integer;
284 <    CodePage: TSystemCodePage;
279 >
280 > { TFBLibrary }
281 >
282 > function TFBLibrary.GetOverrideLibName: string;
283 > begin
284 >  Result := FFBLibraryName;
285 >  if (Result = '') and AllowUseOfFBLIB then
286 >    Result := GetEnvironmentVariable('FBLIB');
287 >  if Result = '' then
288 >  begin
289 >    if assigned(OnGetLibraryName) then
290 >      OnGetLibraryName(Result)
291    end;
292 + end;
293  
294 < const
295 <  CharSetMap: array [0..69] of TCharsetMap = (
296 <  (CharsetID: 0; CharSetName: 'NONE'; CharSetWidth: 1; CodePage: CP_ACP),
297 <  (CharsetID: 1; CharSetName: 'OCTETS'; CharSetWidth: 1; CodePage: CP_NONE),
298 <  (CharsetID: 2; CharSetName: 'ASCII'; CharSetWidth: 1; CodePage: CP_ASCII),
299 <  (CharsetID: 3; CharSetName: 'UNICODE_FSS'; CharSetWidth: 3; CodePage: CP_UTF8),
300 <  (CharsetID: 4; CharSetName: 'UTF8'; CharSetWidth: 4; CodePage: CP_UTF8),
301 <  (CharsetID: 5; CharSetName: 'SJIS_0208'; CharSetWidth: 2; CodePage: 20932),
302 <  (CharsetID: 6; CharSetName: 'EUCJ_0208'; CharSetWidth: 2; CodePage: 20932),
303 <  (CharsetID: 7; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
304 <  (CharsetID: 8; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
305 <  (CharsetID: 9; CharSetName: 'DOS737'; CharSetWidth: 1; CodePage: 737),
306 <  (CharsetID: 10; CharSetName: 'DOS437'; CharSetWidth: 1; CodePage: 437),
307 <  (CharsetID: 11; CharSetName: 'DOS850'; CharSetWidth: 1; CodePage: 850),
308 <  (CharsetID: 12; CharSetName: 'DOS865'; CharSetWidth: 1; CodePage: 865),
309 <  (CharsetID: 13; CharSetName: 'DOS860'; CharSetWidth: 1; CodePage: 860),
310 <  (CharsetID: 14; CharSetName: 'DOS863'; CharSetWidth: 1; CodePage: 863),
311 <  (CharsetID: 15; CharSetName: 'DOS775'; CharSetWidth: 1; CodePage: 775),
312 <  (CharsetID: 16; CharSetName: 'DOS858'; CharSetWidth: 1; CodePage: 858),
313 <  (CharsetID: 17; CharSetName: 'DOS862'; CharSetWidth: 1; CodePage: 862),
314 <  (CharsetID: 18; CharSetName: 'DOS864'; CharSetWidth: 1; CodePage: 864),
315 <  (CharsetID: 19; CharSetName: 'NEXT'; CharSetWidth: 1; CodePage: CP_NONE),
316 <  (CharsetID: 20; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
317 <  (CharsetID: 21; CharSetName: 'ISO8859_1'; CharSetWidth: 1; CodePage: 28591),
318 <  (CharsetID: 22; CharSetName: 'ISO8859_2'; CharSetWidth: 1; CodePage: 28592),
319 <  (CharsetID: 23; CharSetName: 'ISO8859_3'; CharSetWidth: 1; CodePage: 28593),
320 <  (CharsetID: 24; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
321 <  (CharsetID: 25; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
220 <  (CharsetID: 26; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
221 <  (CharsetID: 27; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
222 <  (CharsetID: 28; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
223 <  (CharsetID: 29; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
224 <  (CharsetID: 30; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
225 <  (CharsetID: 31; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
226 <  (CharsetID: 32; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
227 <  (CharsetID: 33; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
228 <  (CharsetID: 34; CharSetName: 'ISO8859_4'; CharSetWidth: 1; CodePage: 28594),
229 <  (CharsetID: 35; CharSetName: 'ISO8859_5'; CharSetWidth: 1; CodePage: 28595),
230 <  (CharsetID: 36; CharSetName: 'ISO8859_6'; CharSetWidth: 1; CodePage: 28596),
231 <  (CharsetID: 37; CharSetName: 'ISO8859_7'; CharSetWidth: 1; CodePage: 28597),
232 <  (CharsetID: 38; CharSetName: 'ISO8859_8'; CharSetWidth: 1; CodePage: 28598),
233 <  (CharsetID: 39; CharSetName: 'ISO8859_9'; CharSetWidth: 1; CodePage: 28599),
234 <  (CharsetID: 40; CharSetName: 'ISO8859_13'; CharSetWidth: 1; CodePage: 28603),
235 <  (CharsetID: 41; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
236 <  (CharsetID: 42; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
237 <  (CharsetID: 43; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
238 <  (CharsetID: 44; CharSetName: 'KSC_5601'; CharSetWidth: 2; CodePage: 949),
239 <  (CharsetID: 45; CharSetName: 'DOS852'; CharSetWidth: 1; CodePage: 852),
240 <  (CharsetID: 46; CharSetName: 'DOS857'; CharSetWidth: 1; CodePage: 857),
241 <  (CharsetID: 47; CharSetName: 'DOS861'; CharSetWidth: 1; CodePage: 861),
242 <  (CharsetID: 48; CharSetName: 'DOS866'; CharSetWidth: 1; CodePage: 866),
243 <  (CharsetID: 49; CharSetName: 'DOS869'; CharSetWidth: 1; CodePage: 869),
244 <  (CharsetID: 50; CharSetName: 'CYRL'; CharSetWidth: 1; CodePage: 1251),
245 <  (CharsetID: 51; CharSetName: 'WIN1250'; CharSetWidth: 1; CodePage: 1250),
246 <  (CharsetID: 52; CharSetName: 'WIN1251'; CharSetWidth: 1; CodePage: 1251),
247 <  (CharsetID: 53; CharSetName: 'WIN1252'; CharSetWidth: 1; CodePage: 1252),
248 <  (CharsetID: 54; CharSetName: 'WIN1253'; CharSetWidth: 1; CodePage: 1253),
249 <  (CharsetID: 55; CharSetName: 'WIN1254'; CharSetWidth: 1; CodePage: 1254),
250 <  (CharsetID: 56; CharSetName: 'BIG_5'; CharSetWidth: 2; CodePage: 950),
251 <  (CharsetID: 57; CharSetName: 'GB_2312'; CharSetWidth: 2; CodePage: 936),
252 <  (CharsetID: 58; CharSetName: 'WIN1255'; CharSetWidth: 1; CodePage: 1255),
253 <  (CharsetID: 59; CharSetName: 'WIN1256'; CharSetWidth: 1; CodePage: 1256),
254 <  (CharsetID: 60; CharSetName: 'WIN1257'; CharSetWidth: 1; CodePage: 1257),
255 <  (CharsetID: 61; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
256 <  (CharsetID: 62; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
257 <  (CharsetID: 63; CharSetName: 'KOI8R'; CharSetWidth: 1; CodePage: 20866),
258 <  (CharsetID: 64; CharSetName: 'KOI8U'; CharSetWidth: 1; CodePage: 21866),
259 <  (CharsetID: 65; CharSetName: 'WIN1258'; CharSetWidth: 1; CodePage: 1258),
260 <  (CharsetID: 66; CharSetName: 'TIS620'; CharSetWidth: 1; CodePage: 874),
261 <  (CharsetID: 67; CharSetName: 'GBK'; CharSetWidth: 2; CodePage: 936),
262 <  (CharsetID: 68; CharSetName: 'CP943C'; CharSetWidth: 2; CodePage: 943),
263 <  (CharsetID: 69; CharSetName: 'GB18030'; CharSetWidth: 4; CodePage: 54936)
264 < );
265 <
266 <  {$IFDEF Unix}
267 <  {SetEnvironmentVariable doesn't exist so we have to use C Library}
268 <  function setenv(name:Pchar; value:Pchar; replace:integer):integer;cdecl;external clib name 'setenv';
269 <  function unsetenv(name:Pchar):integer;cdecl;external clib name 'unsetenv';
270 <  function SetEnvironmentVariable(name:PChar; value:PChar):boolean;
271 <  // Set environment variable; if empty string given, remove it.
294 > procedure TFBLibrary.FreeFBLibrary;
295 > begin
296 >  (FFirebirdAPI as TFBClientAPI).FBShutdown;
297 >  if FIBLibrary <> NilHandle then
298 >    FreeLibrary(FIBLibrary);
299 >  FIBLibrary := NilHandle;
300 >  FFBLibraryName := '';
301 > end;
302 >
303 > function TFBLibrary.GetLibraryName: string;
304 > begin
305 >  Result := ExtractFileName(FFBLibraryName);
306 > end;
307 >
308 > function TFBLibrary.GetFirebirdAPI: IFirebirdAPI;
309 > begin
310 >  Result := FFirebirdAPI;
311 > end;
312 >
313 > constructor TFBLibrary.Create(aLibPathName: string);
314 > begin
315 >  inherited Create;
316 >  SetupEnvironment;
317 >  FFBLibraryName := aLibPathName;
318 >  FIBLibrary := NilHandle;
319 >  FFirebirdAPI := GetFirebird3API;
320 >  FRequestedLibName := aLibPathName;
321 >  if aLibPathName <> '' then
322    begin
323 <    result:=false; //assume failure
324 <    if value = '' then
325 <    begin
326 <      // Assume user wants to remove variable.
327 <      if unsetenv(name)=0 then result:=true;
328 <    end
329 <    else
323 >    SetLength(FLibraryList,Length(FLibraryList)+1);
324 >    FLibraryList[Length(FLibraryList)-1] := self;
325 >  end;
326 >  if FFirebirdAPI <> nil then
327 >  begin
328 >    {First try Firebird 3}
329 >    if not LoadIBLibrary or not (FFirebirdAPI as TFBClientAPI).LoadInterface then
330 >      FFirebirdAPI := nil;
331 >  end;
332 >
333 >  if FFirebirdAPI = nil then
334 >  begin
335 >    {now try Firebird 2.5. Under Unix we need to reload the library in case we
336 >     are to use the embedded library}
337 >    FFirebirdAPI := GetLegacyFirebirdAPI;
338 >    if FFirebirdAPI <> nil then
339      begin
340 <      // Non empty so set the variable
341 <      if setenv(name, value, 1)=0 then result:=true;
340 >      {$IFDEF UNIX}
341 >      FreeFBLibrary;
342 >      {$ENDIF}
343 >      if not LoadIBLibrary or not (FFirebirdAPI as TFBClientAPI).LoadInterface then
344 >        FFirebirdAPI := nil;
345      end;
346    end;
347 <  {$ENDIF}
347 >  {Note: FFirebirdAPI will be set to nil if the Firebird API fails to load}
348 > end;
349  
350 < { TFBClientAPI }
350 > destructor TFBLibrary.Destroy;
351 > begin
352 >  FreeFBLibrary;
353 >  FFirebirdAPI := nil;
354 >  inherited Destroy;
355 > end;
356  
357 < constructor TFBClientAPI.Create;
357 > class function TFBLibrary.GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
358 > var i: integer;
359   begin
360 <  inherited Create;
361 <  LoadIBLibrary;
293 <  if (IBLibrary <> NilHandle) then
360 >  Result := nil;
361 >  if aLibPathName <> '' then
362    begin
363 <    SetupEnvironment;
364 <    LoadInterface;
363 >    for i := 0 to Length(FLibraryList) - 1 do
364 >    begin
365 >      if (FLibraryList[i] as TFBLibrary).SameLibrary(aLibPathName) then
366 >      begin
367 >        Result := FLibraryList[i];
368 >        Exit;
369 >      end;
370 >    end;
371 >    Result := Create(aLibPathName);
372    end;
373 <  FirebirdClientAPI := self;
373 >
374   end;
375  
376 < destructor TFBClientAPI.Destroy;
376 > class procedure TFBLibrary.FreeLibraries;
377 > var i: integer;
378   begin
379 <  FirebirdClientAPI := nil;
380 <  if FOwnsIBLibrary and (IBLibrary <> NilHandle) then
381 <    UnloadLibrary(IBLibrary);
382 <  IBLibrary := NilHandle;
383 <  inherited Destroy;
379 >  for i := 0 to Length(FLibraryList) - 1 do
380 >    FLibraryList[i] := nil;
381 >  SetLength(FLibraryList,0);
382 > end;
383 >
384 > function TFBLibrary.SameLibrary(aLibName: string): boolean;
385 > begin
386 >  Result := FRequestedLibName = aLibName;
387 > end;
388 >
389 > function TFBLibrary.GetHandle: TLibHandle;
390 > begin
391 >  Result := FIBLibrary;
392 > end;
393 >
394 > { TFBClientAPI }
395 >
396 > constructor TFBClientAPI.Create(aFBLibrary: TFBLibrary);
397 > begin
398 >  inherited Create;
399 >  FFBLibrary := aFBLibrary;
400 >  GetTZDataSettings;
401   end;
402  
403   procedure TFBClientAPI.IBAlloc(var P; OldSize, NewSize: Integer);
# Line 312 | Line 405 | var
405    i: Integer;
406   begin
407    ReallocMem(Pointer(P), NewSize);
408 <  for i := OldSize to NewSize - 1 do PChar(P)[i] := #0;
408 >  for i := OldSize to NewSize - 1 do PAnsiChar(P)[i] := #0;
409   end;
410  
411   procedure TFBClientAPI.IBDataBaseError;
# Line 320 | Line 413 | begin
413    raise EIBInterBaseError.Create(GetStatus);
414   end;
415  
416 < {Under Unixes, if using an embedded server then set up local TMP and LOCK Directories}
324 <
325 < procedure TFBClientAPI.SetupEnvironment;
326 < var TmpDir: string;
327 < begin
328 <  {$IFDEF UNIX}
329 <    TmpDir := GetTempDir +
330 <        DirectorySeparator + 'firebird_' + sysutils.GetEnvironmentVariable('USER');
331 <    if sysutils.GetEnvironmentVariable('FIREBIRD_TMP') = '' then
332 <    begin
333 <      if not DirectoryExists(tmpDir) then
334 <        mkdir(tmpDir);
335 <      SetEnvironmentVariable('FIREBIRD_TMP',PChar(TmpDir));
336 <    end;
337 <    if sysutils.GetEnvironmentVariable('FIREBIRD_LOCK') = '' then
338 <    begin
339 <      if not DirectoryExists(tmpDir) then
340 <        mkdir(tmpDir);
341 <      SetEnvironmentVariable('FIREBIRD_LOCK',PChar(TmpDir));
342 <    end;
343 <  {$ENDIF}
344 < end;
345 <
346 < procedure TFBClientAPI.EncodeInteger(aValue: integer; len: integer; buffer: PChar);
416 > procedure TFBClientAPI.EncodeInteger(aValue: int64; len: integer; buffer: PByte);
417   begin
418    while len > 0 do
419    begin
420 <    buffer^ := char(aValue and $FF);
420 >    buffer^ := aValue and $FF;
421      Inc(buffer);
422      Dec(len);
423      aValue := aValue shr 8;
424    end;
425   end;
426  
427 + (*
428 +  DecodeInteger is Translated from
429 +
430 + SINT64 API_ROUTINE isc_portable_integer(const UCHAR* ptr, SSHORT length)
431 + if (!ptr || length <= 0 || length > 8)
432 +        return 0;
433 +
434 + SINT64 value = 0;
435 + int shift = 0;
436 +
437 + while (--length > 0)
438 + {
439 +        value += ((SINT64) *ptr++) << shift;
440 +        shift += 8;
441 + }
442 +
443 + value += ((SINT64)(SCHAR) *ptr) << shift;
444 +
445 + return value;
446 + *)
447 +
448 + function TFBClientAPI.DecodeInteger(bufptr: PByte; len: short): int64;
449 + var shift: integer;
450 + begin
451 +  Result := 0;
452 +  if (BufPtr = nil) or (len <= 0) or (len > 8) then
453 +    Exit;
454 +
455 +  shift := 0;
456 +  dec(len);
457 +  while len > 0 do
458 +  begin
459 +    Result := Result + (int64(bufptr^) shl shift);
460 +    Inc(bufptr);
461 +    shift := shift + 8;
462 +    dec(len);
463 +  end;
464 +  Result := Result + (int64(bufptr^) shl shift);
465 + end;
466 +
467 + function TFBClientAPI.Int128ToStr(bufptr: PByte; scale: integer): AnsiString;
468 + begin
469 +  if not HasInt128Support then
470 +    IBError(ibxeNotSupported,[]);
471 + end;
472 +
473 + procedure TFBClientAPI.StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte);
474 + begin
475 +  if not HasInt128Support then
476 +    IBError(ibxeNotSupported,[]);
477 + end;
478 +
479 + procedure TFBClientAPI.SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal;
480 +  bufptr: PByte);
481 + begin
482 +  if not HasDecFloatSupport then
483 +    IBError(ibxeNotSupported,[]);
484 + end;
485 +
486 + function TFBClientAPI.SQLDecFloatDecode(SQLType: cardinal; bufptr: PByte): tBCD;
487 + begin
488 +  if not HasDecFloatSupport then
489 +    IBError(ibxeNotSupported,[]);
490 + end;
491 +
492   function TFBClientAPI.IsLibraryLoaded: boolean;
493   begin
494 <  Result := IBLibrary <> NilHandle;
494 >  Result := FFBLibrary.IBLibrary <> NilHandle;
495   end;
496  
497 < function TFBClientAPI.GetProcAddr(ProcName: PChar): Pointer;
497 > function TFBClientAPI.GetFBLibrary: IFirebirdLibrary;
498   begin
499 <  Result := GetProcAddress(IBLibrary, ProcName);
365 <  if not Assigned(Result) then
366 <    raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
499 >  Result := FFBLibrary;
500   end;
501  
502 < function TFBClientAPI.GetOverrideLibName: string;
502 > function TFBClientAPI.FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
503   begin
504 <  Result := '';
505 <  if AllowUseOfFBLIB then
506 <    Result := GetEnvironmentVariable('FBLIB');
507 <  if Result = '' then
504 >  {aDate/aTime are in TTimestamp format but aTime is decimilliseconds}
505 >  aDate := aDate - DateDelta;
506 >  if aDate < 0 then
507 >    Result := trunc(aDate) - abs(frac(aTime / (MSecsPerDay*10)))
508 >  else
509 >    Result := trunc(aDate) + abs(frac(aTime / (MSecsPerDay*10)));
510 > end;
511 >
512 > {$IFDEF UNIX}
513 >
514 > procedure TFBClientAPI.GetTZDataSettings;
515 > var S: TStringList;
516 > begin
517 >  FLocalTimeOffset := GetLocalTimeOffset;
518 >  {$if declared(Gettzname)}
519 >  FLocalTimeZoneName := Gettzname(tzdaylight);
520 >  {$else}
521 >  FLocalTimeZoneName := tzname[tzdaylight];
522 >  {$ifend}
523 >  FIsDaylightSavingsTime := tzdaylight;
524 >  if FileExists(DefaultTimeZoneFile) then
525    begin
526 <    if assigned(OnGetLibraryName) then
527 <      OnGetLibraryName(Result)
526 >    S := TStringList.Create;
527 >    try
528 >      S.LoadFromFile(DefaultTimeZoneFile);
529 >      if S.Count > 0 then
530 >        FTZDataTimeZoneID := S[0];
531 >    finally
532 >      S.Free;
533 >    end;
534    end;
535   end;
536 + {$ENDIF}
537  
538 < procedure TFBClientAPI.LoadInterface;
538 > {$IFDEF WINDOWS}
539 > procedure TFBClientAPI.GetTZDataSettings;
540 > var TZInfo: TTimeZoneInformation;
541   begin
542 <  isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
543 <  isc_sql_interprete := GetProcAddr('isc_sql_interprete'); {do not localize}
544 <  isc_interprete := GetProcAddr('isc_interprete'); {do not localize}
545 <  isc_event_counts := GetProcAddr('isc_event_counts'); {do not localize}
546 <  isc_event_block := GetProcAddr('isc_event_block'); {do not localize}
547 <  isc_free := GetProcAddr('isc_free'); {do not localize}
542 >  FIsDaylightSavingsTime := false;
543 >  {is there any way of working out the default TZData DB time zone ID under Windows?}
544 >  case GetTimeZoneInformation(TZInfo) of
545 >    TIME_ZONE_ID_UNKNOWN:
546 >      begin
547 >        FLocalTimeZoneName := '';
548 >        FLocalTimeOffset := 0;
549 >      end;
550 >    TIME_ZONE_ID_STANDARD:
551 >      begin
552 >        FLocalTimeZoneName := strpas(PWideChar(@TZInfo.StandardName));
553 >        FLocalTimeOffset := TZInfo.Bias;
554 >      end;
555 >    TIME_ZONE_ID_DAYLIGHT:
556 >      begin
557 >        FLocalTimeZoneName := strpas(PWideChar(@TZInfo.DaylightName));
558 >        FLocalTimeOffset := TZInfo.DayLightBias;
559 >        FIsDaylightSavingsTime := true;
560 >      end;
561 >  end;
562   end;
563 + {$ENDIF}
564  
565 < function TFBClientAPI.GetLibraryName: string;
565 > function TFBClientAPI.GetProcAddr(ProcName: PAnsiChar): Pointer;
566   begin
567 <  Result := FFBLibraryName;
567 >  Result := nil;
568 >  if assigned(FFBLibrary) and (FFBLibrary.IBLibrary <> NilHandle) then
569 >    Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
570 >  if not Assigned(Result) then
571 >    raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
572   end;
573  
574 < function TFBClientAPI.GetCharsetName(CharSetID: integer): string;
574 > function TFBClientAPI.HasDecFloatSupport: boolean;
575   begin
576 <  Result := '';
399 <  if (CharSetID >= Low(CharSetMap)) and (CharSetID <= High(CharSetMap)) and
400 <                                  (CharSetMap[CharSetID].CharSetID = CharSetID) then
401 <    begin
402 <      Result := CharSetMap[CharSetID].CharSetName;
403 <      Exit;
404 <    end;
576 >  Result := GetClientMajor >= 4;
577   end;
578  
579 < function TFBClientAPI.CharSetID2CodePage(CharSetID: integer;
408 <  var CodePage: TSystemCodePage): boolean;
579 > function TFBClientAPI.HasInt128Support: boolean;
580   begin
581 <  Result := (CharSetID >= Low(CharSetMap)) and (CharSetID <= High(CharSetMap))
411 <               and (CharSetMap[CharSetID].CharSetID = CharSetID);
412 <  if Result then
413 <    begin
414 <      CodePage := CharSetMap[CharSetID].CodePage;
415 <      Result := true;
416 <      Exit;
417 <    end;
581 >  Result := false;
582   end;
583  
584 < function TFBClientAPI.CodePage2CharSetID(CodePage: TSystemCodePage;
421 <  var CharSetID: integer): boolean;
422 < var i: integer;
584 > function TFBClientAPI.HasLocalTZDB: boolean;
585   begin
586    Result := false;
425 –  for i := Low(CharSetMap) to High(CharSetMap) do
426 –    if CharSetMap[i].CodePage = CodePage then
427 –    begin
428 –      CharSetID := CharSetMap[i].CharSetID;
429 –      Result := true;
430 –      Exit;
431 –    end;
587   end;
588  
589 < function TFBClientAPI.CharSetName2CharSetID(CharSetName: string;
435 <  var CharSetID: integer): boolean;
436 < var i: integer;
589 > function TFBClientAPI.HasExtendedTZSupport: boolean;
590   begin
591    Result := false;
439 –  for i := Low(CharSetMap) to High(CharSetMap) do
440 –    if CompareStr(CharSetMap[i].CharSetName, CharSetName) = 0 then
441 –    begin
442 –      CharSetID := CharSetMap[i].CharSetID;
443 –      Result := true;
444 –      Exit;
445 –    end;
592   end;
593  
594 < function TFBClientAPI.CharSetWidth(CharSetID: integer; var Width: integer
449 <  ): boolean;
594 > function TFBClientAPI.HasTimeZoneSupport: boolean;
595   begin
596 <  Result := (CharSetID >= Low(CharSetMap)) and (CharSetID <= High(CharSetMap))
452 <               and (CharSetMap[CharSetID].CharSetID = CharSetID);
453 <  if Result then
454 <    begin
455 <      Width := CharSetMap[CharSetID].CharSetWidth;
456 <      Result := true;
457 <      Exit;
458 <    end;
596 >  Result := false;
597   end;
598  
599 < const
600 <  IBLocalBufferLength = 512;
601 <  IBBigLocalBufferLength = IBLocalBufferLength * 2;
602 <  IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;
599 > function TFBClientAPI.GetImplementationVersion: AnsiString;
600 > begin
601 >  Result := Format('%d.%d',[GetClientMajor,GetClientMinor]);
602 > end;
603 >
604 > function TFBClientAPI.LoadInterface: boolean;
605 > begin
606 >  isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
607 >  isc_sql_interprete := GetProcAddr('isc_sql_interprete'); {do not localize}
608 >  fb_shutdown := GetProcAddr('fb_shutdown'); {do not localize}
609 >  Result := true; {don't case if these fail to load}
610 > end;
611 >
612 > procedure TFBClientAPI.FBShutdown;
613 > begin
614 >  if assigned(fb_shutdown) then
615 >    fb_shutdown(0,fb_shutrsn_exit_called);
616 > end;
617  
618   { TFBStatus }
619  
620 < constructor TFBStatus.Create(aOwner: TFBClientAPI);
620 > function TFBStatus.SQLCodeSupported: boolean;
621 > begin
622 >  Result:= (FOwner <> nil) and assigned(FOwner.isc_sqlcode) and  assigned(FOwner.isc_sql_interprete);
623 > end;
624 >
625 > function TFBStatus.GetSQLMessage: Ansistring;
626 > var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
627 > begin
628 >  Result := '';
629 >  if (FOwner <> nil) and assigned(FOwner.isc_sql_interprete) then
630 >  begin
631 >     FOwner.isc_sql_interprete(Getsqlcode, local_buffer, sizeof(local_buffer));
632 >     Result := strpas(local_buffer);
633 >  end;
634 > end;
635 >
636 > constructor TFBStatus.Create(aOwner: TFBClientAPI; prefix: AnsiString);
637   begin
638    inherited Create;
639    FOwner := aOwner;
640 <  FIBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
640 >  FPrefix := prefix;
641 >  FIBDataBaseErrorMessages := [ShowIBMessage];
642 > end;
643 >
644 > constructor TFBStatus.Copy(src: TFBStatus);
645 > begin
646 >  inherited Create;
647 >  FOwner := src.FOwner;
648 >  FPrefix := src.FPrefix;
649 >  SetIBDataBaseErrorMessages(src.GetIBDataBaseErrorMessages);
650   end;
651  
652 < function TFBStatus.GetIBErrorCode: Long;
652 > function TFBStatus.GetIBErrorCode: TStatusCode;
653   begin
654    Result := StatusVector^[1];
655   end;
656  
657 < function TFBStatus.Getsqlcode: Long;
657 > function TFBStatus.Getsqlcode: TStatusCode;
658   begin
659 <  with FOwner do
660 <    Result := isc_sqlcode(PISC_STATUS(StatusVector));
659 >  if (FOwner <> nil) and assigned(FOwner.isc_sqlcode) then
660 >    Result := FOwner.isc_sqlcode(PISC_STATUS(StatusVector))
661 >  else
662 >    Result := -999; {generic SQL Code}
663   end;
664  
665 < function TFBStatus.GetMessage: string;
666 < var local_buffer: array[0..IBHugeLocalBufferLength - 1] of char;
488 <    IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
489 <    sqlcode: Long;
490 <    psb: PStatusVector;
665 > function TFBStatus.GetMessage: AnsiString;
666 > var IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
667   begin
668 <  Result := '';
668 >  Result := FPrefix;
669    IBDataBaseErrorMessages := FIBDataBaseErrorMessages;
670 <  sqlcode := Getsqlcode;
671 <  if (ShowSQLCode in IBDataBaseErrorMessages) then
672 <    Result := Result + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
673 <
674 <  Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
675 <  if (ShowSQLMessage in IBDataBaseErrorMessages) then
676 <  begin
677 <    with FOwner do
678 <      isc_sql_interprete(sqlcode, local_buffer, IBLocalBufferLength);
679 <    if (ShowSQLCode in FIBDataBaseErrorMessages) then
680 <      Result := Result + CRLF;
505 <    Result := Result + strpas(local_buffer);
670 >  if SQLCodeSupported then
671 >  begin
672 >    if (ShowSQLCode in IBDataBaseErrorMessages) then
673 >      Result := Result + 'SQLCODE: ' + IntToStr(Getsqlcode); {do not localize}
674 >
675 >    if (ShowSQLMessage in IBDataBaseErrorMessages) then
676 >    begin
677 >      if ShowSQLCode in IBDataBaseErrorMessages then
678 >        Result := Result + LineEnding;
679 >      Result := Result + GetSQLMessage;
680 >    end;
681    end;
682  
683    if (ShowIBMessage in IBDataBaseErrorMessages) then
684    begin
685 <    if (ShowSQLCode in IBDataBaseErrorMessages) or
686 <       (ShowSQLMessage in IBDataBaseErrorMessages) then
687 <      Result := Result + CRLF;
513 <    psb := StatusVector;
514 <    with FOwner do
515 <    while (isc_interprete(@local_buffer, @psb) > 0) do
516 <    begin
517 <      if (Result <> '') and (Result[Length(Result)] <> LF) then
518 <        Result := Result + CRLF;
519 <      Result := Result + strpas(local_buffer);
520 <    end;
685 >    if Result <> FPrefix then
686 >      Result := Result + LineEnding;
687 >    Result := Result + 'Engine Code: ' + IntToStr(GetIBErrorCode) + LineEnding + GetIBMessage;
688    end;
689    if (Result <> '') and (Result[Length(Result)] = '.') then
690      Delete(Result, Length(Result), 1);
# Line 530 | Line 697 | var
697    i: Integer;
698    procedure NextP(i: Integer);
699    begin
700 <    p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
700 >    p := PISC_STATUS(PAnsiChar(p) + (i * SizeOf(ISC_STATUS)));
701    end;
702   begin
703    p := PISC_STATUS(StatusVector);
# Line 556 | Line 723 | end;
723  
724   function TFBStatus.GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
725   begin
726 <  EnterCriticalSection(FIBCS);
726 >  EnterCriticalSection(TFBClientAPI.FIBCS);
727    try
728      result := FIBDataBaseErrorMessages;
729    finally
730 <    LeaveCriticalSection(FIBCS);
730 >    LeaveCriticalSection(TFBClientAPI.FIBCS);
731    end;
732   end;
733  
734   procedure TFBStatus.SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
735   begin
736 <  EnterCriticalSection(FIBCS);
736 >  EnterCriticalSection(TFBClientAPI.FIBCS);
737    try
738      FIBDataBaseErrorMessages := Value;
739    finally
740 <    LeaveCriticalSection(FIBCS);
740 >    LeaveCriticalSection(TFBClientAPI.FIBCS);
741    end;
742   end;
743 +
744   initialization
745 <  TFBClientAPI.IBLibrary := NilHandle;
746 <  InitCriticalSection(TFBStatus.FIBCS);
745 >  TFBLibrary.FEnvSetupDone := false;
746 >  {$IFNDEF FPC}
747 >  InitializeCriticalSection(TFBClientAPI.FIBCS);
748 >  {$ELSE}
749 >  InitCriticalSection(TFBClientAPI.FIBCS);
750 >  {$ENDIF}
751  
752   finalization
753 <  DoneCriticalSection(TFBStatus.FIBCS);
754 <  if TFBClientAPI.IBLibrary <> NilHandle then
755 <  begin
756 <    FreeLibrary(TFBClientAPI.IBLibrary);
757 <    TFBClientAPI.IBLibrary := NilHandle;
758 <    TFBClientAPI.FFBLibraryName := '';
587 <  end;
588 <
753 >  TFBLibrary.FreeLibraries;
754 >  {$IFNDEF FPC}
755 >  DeleteCriticalSection(TFBClientAPI.FIBCS);
756 >  {$ELSE}
757 >  DoneCriticalSection(TFBClientAPI.FIBCS);
758 >  {$ENDIF}
759   end.
760  

Comparing:
ibx/trunk/fbintf/client/FBClientAPI.pas (property svn:eol-style), Revision 47 by tony, Mon Jan 9 15:31:51 2017 UTC vs.
ibx/branches/udr/client/FBClientAPI.pas (property svn:eol-style), Revision 390 by tony, Sat Jan 22 16:15:12 2022 UTC

# Line 0 | Line 1
1 + native

Diff Legend

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