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

Diff Legend

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