ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/fbintf/client/FBClientAPI.pas
Revision: 308
Committed: Sat Jul 18 10:26:30 2020 UTC (3 years, 8 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/FBClientAPI.pas
File size: 15413 byte(s)
Log Message:
Fixes Merged

File Contents

# User Rev Content
1 tony 45 (*
2     * Firebird Interface (fbintf). The fbintf components provide a set of
3     * Pascal language bindings for the Firebird API. Although predominantly
4     * a new development they include source code taken from IBX and may be
5     * considered a derived product. This software thus also includes the copyright
6     * notice and license conditions from IBX.
7     *
8     * Except for those parts dervied from IBX, contents of this file are subject
9     * to the Initial Developer's Public License Version 1.0 (the "License"); you
10     * may not use this file except in compliance with the License. You may obtain a
11     * copy of the License here:
12     *
13     * http://www.firebirdsql.org/index.php?op=doc&id=idpl
14     *
15     * Software distributed under the License is distributed on an "AS
16     * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
17     * implied. See the License for the specific language governing rights
18     * and limitations under the License.
19     *
20     * The Initial Developer of the Original Code is Tony Whyman.
21     *
22     * The Original Code is (C) 2016 Tony Whyman, MWA Software
23     * (http://www.mwasoftware.co.uk).
24     *
25     * All Rights Reserved.
26     *
27     * Contributor(s): ______________________________________.
28     *
29     *)
30     {************************************************************************}
31     { }
32     { Borland Delphi Visual Component Library }
33     { InterBase Express core components }
34     { }
35     { Copyright (c) 1998-2000 Inprise Corporation }
36     { }
37     { InterBase Express is based in part on the product }
38     { Free IB Components, written by Gregory H. Deatz for }
39     { Hoagland, Longo, Moran, Dunst & Doukas Company. }
40     { Free IB Components is used under license. }
41     { }
42     { The contents of this file are subject to the InterBase }
43     { Public License Version 1.0 (the "License"); you may not }
44     { use this file except in compliance with the License. You }
45     { may obtain a copy of the License at http://www.Inprise.com/IPL.html }
46     { Software distributed under the License is distributed on }
47     { an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
48     { express or implied. See the License for the specific language }
49     { governing rights and limitations under the License. }
50     { The Original Code was created by InterBase Software Corporation }
51     { and its successors. }
52     { Portions created by Inprise Corporation are Copyright (C) Inprise }
53     { Corporation. All Rights Reserved. }
54     { Contributor(s): Jeff Overcash }
55     { }
56     { IBX For Lazarus (Firebird Express) }
57     { Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
58     { Portions created by MWA Software are copyright McCallum Whyman }
59     { Associates Ltd 2011 - 2015 }
60     { }
61     {************************************************************************}
62     unit FBClientAPI;
63 tony 56 {$IFDEF MSWINDOWS}
64     {$DEFINE WINDOWS}
65     {$ENDIF}
66 tony 45
67     {$IFDEF FPC}
68     {$mode delphi}
69     {$codepage UTF8}
70     {$interfaces COM}
71     {$ENDIF}
72    
73     interface
74    
75     uses
76 tony 56 Classes,
77     {$IFDEF WINDOWS}Windows, {$ENDIF}
78     {$IFDEF FPC} Dynlibs, {$ENDIF}
79     IB, IBHeader, FBActivityMonitor, FBMessages, IBExternals;
80 tony 45
81     {For Linux see result of GetFirebirdLibList method}
82     {$IFDEF DARWIN}
83     const
84     FIREBIRD_SO2 = 'libfbclient.dylib';
85     {$ENDIF}
86     {$IFDEF WINDOWS}
87     const
88     IBASE_DLL = 'gds32.dll';
89     FIREBIRD_CLIENT = 'fbclient.dll'; {do not localize}
90     FIREBIRD_EMBEDDED = 'fbembed.dll';
91     {$ENDIF}
92    
93 tony 308 const
94     IBLocalBufferLength = 512;
95     IBBigLocalBufferLength = IBLocalBufferLength * 2;
96     IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;
97    
98 tony 45 type
99     TStatusVector = array[0..19] of NativeInt;
100     PStatusVector = ^TStatusVector;
101    
102     TFBClientAPI = class;
103    
104     { TFBStatus }
105    
106     TFBStatus = class(TFBInterfacedObject)
107     private
108     FIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
109     protected
110     FOwner: TFBClientAPI;
111     public
112     constructor Create(aOwner: TFBClientAPI);
113     function StatusVector: PStatusVector; virtual; abstract;
114    
115     {IStatus}
116     function GetIBErrorCode: Long;
117     function Getsqlcode: Long;
118 tony 56 function GetMessage: AnsiString;
119 tony 45 function CheckStatusVector(ErrorCodes: array of TFBStatusCode): Boolean;
120     function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
121     procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
122     end;
123    
124 tony 263 { TFBLibrary }
125    
126     TFBLibrary = class(TFBInterfacedObject,IFirebirdLibrary)
127     private
128     class var FEnvSetupDone: boolean;
129     class var FLibraryList: array of IFirebirdLibrary;
130     FFirebirdAPI: IFirebirdAPI;
131     FRequestedLibName: string;
132     function LoadIBLibrary: boolean;
133     protected
134     FFBLibraryName: string;
135     FIBLibrary: TLibHandle;
136     procedure FreeFBLibrary;
137     function GetOverrideLibName: string;
138     class procedure SetupEnvironment;
139     protected
140     function GetFirebird3API: IFirebirdAPI; virtual; abstract;
141     function GetLegacyFirebirdAPI: IFirebirdAPI; virtual; abstract;
142     public
143     constructor Create(aLibPathName: string='');
144     destructor Destroy; override;
145     class function GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
146     class procedure FreeLibraries;
147    
148     {IFirebirdLibrary}
149     function GetHandle: TLibHandle;
150     function GetLibraryName: string;
151     function GetLibraryFilePath: string;
152     function GetFirebirdAPI: IFirebirdAPI;
153     property IBLibrary: TLibHandle read FIBLibrary;
154     end;
155    
156 tony 45 { TFBClientAPI }
157    
158     TFBClientAPI = class(TFBInterfacedObject)
159     private
160 tony 56 class var FIBCS: TRTLCriticalSection;
161 tony 45 protected
162 tony 263 FFBLibrary: TFBLibrary;
163 tony 56 function GetProcAddr(ProcName: PAnsiChar): Pointer;
164 tony 45 public
165     {Taken from legacy API}
166     isc_sqlcode: Tisc_sqlcode;
167     isc_sql_interprete: Tisc_sql_interprete;
168     isc_event_counts: Tisc_event_counts;
169     isc_event_block: Tisc_event_block;
170     isc_free: Tisc_free;
171    
172 tony 263 constructor Create(aFBLibrary: TFBLibrary);
173 tony 45 procedure IBAlloc(var P; OldSize, NewSize: Integer);
174     procedure IBDataBaseError;
175 tony 263 function LoadInterface: boolean; virtual;
176     function GetAPI: IFirebirdAPI; virtual; abstract;
177     {$IFDEF UNIX}
178     function GetFirebirdLibList: string; virtual; abstract;
179     {$ENDIF}
180 tony 45
181     {Encode/Decode}
182 tony 56 procedure EncodeInteger(aValue: integer; len: integer; buffer: PByte);
183     function DecodeInteger(bufptr: PByte; len: short): integer; virtual; abstract;
184     procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte); virtual; abstract;
185     function SQLDecodeDate(byfptr: PByte): TDateTime; virtual; abstract;
186     procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte); virtual; abstract;
187     function SQLDecodeTime(bufptr: PByte): TDateTime; virtual; abstract;
188     procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte); virtual; abstract;
189     function SQLDecodeDateTime(bufptr: PByte): TDateTime; virtual; abstract;
190 tony 308 function FormatStatus(Status: TFBStatus): AnsiString; virtual; abstract;
191 tony 45
192     {IFirebirdAPI}
193     function GetStatus: IStatus; virtual; abstract;
194     function IsLibraryLoaded: boolean;
195     function IsEmbeddedServer: boolean; virtual; abstract;
196 tony 263 function GetFBLibrary: IFirebirdLibrary;
197 tony 308 function GetImplementationVersion: AnsiString;
198     function GetClientMajor: integer; virtual; abstract;
199     function GetClientMinor: integer; virtual; abstract;
200 tony 60 end;
201 tony 45
202     implementation
203    
204 tony 263 uses IBUtils, Registry,
205     {$IFDEF Unix} initc, dl, {$ENDIF}
206 tony 56 {$IFDEF FPC}
207 tony 45 {$IFDEF WINDOWS }
208 tony 56 WinDirs,
209 tony 45 {$ENDIF}
210 tony 56 {$ELSE}
211     ShlObj,
212     {$ENDIF}
213 tony 45 SysUtils;
214    
215     {$IFDEF UNIX}
216 tony 56 {$I 'include/uloadlibrary.inc'}
217 tony 45 {$ELSE}
218 tony 56 {$I 'include/wloadlibrary.inc'}
219 tony 45 {$ENDIF}
220    
221 tony 263
222     { TFBLibrary }
223    
224     function TFBLibrary.GetOverrideLibName: string;
225     begin
226     Result := FFBLibraryName;
227     if (Result = '') and AllowUseOfFBLIB then
228     Result := GetEnvironmentVariable('FBLIB');
229     if Result = '' then
230 tony 45 begin
231 tony 263 if assigned(OnGetLibraryName) then
232     OnGetLibraryName(Result)
233 tony 45 end;
234 tony 263 end;
235 tony 45
236 tony 263 procedure TFBLibrary.FreeFBLibrary;
237     begin
238     if FIBLibrary <> NilHandle then
239     FreeLibrary(FIBLibrary);
240     FIBLibrary := NilHandle;
241     end;
242 tony 45
243 tony 263 function TFBLibrary.GetLibraryName: string;
244 tony 45 begin
245 tony 263 Result := ExtractFileName(FFBLibraryName);
246     end;
247    
248     function TFBLibrary.GetFirebirdAPI: IFirebirdAPI;
249     begin
250     Result := FFirebirdAPI;
251     end;
252    
253     constructor TFBLibrary.Create(aLibPathName: string);
254     begin
255 tony 45 inherited Create;
256 tony 263 SetupEnvironment;
257     FFBLibraryName := aLibPathName;
258     FIBLibrary := NilHandle;
259     FFirebirdAPI := GetFirebird3API;
260     FRequestedLibName := aLibPathName;
261     if aLibPathName <> '' then
262 tony 45 begin
263 tony 263 SetLength(FLibraryList,Length(FLibraryList)+1);
264     FLibraryList[Length(FLibraryList)-1] := self;
265 tony 45 end;
266 tony 263 if FFirebirdAPI <> nil then
267     begin
268     {First try Firebird 3}
269     if not LoadIBLibrary or not (FFirebirdAPI as TFBClientAPI).LoadInterface then
270     FFirebirdAPI := nil;
271     end;
272    
273     if FFirebirdAPI = nil then
274     begin
275     {now try Firebird 2.5. Under Unix we need to reload the library in case we
276     are to use the embedded library}
277     FFirebirdAPI := GetLegacyFirebirdAPI;
278     if FFirebirdAPI <> nil then
279     begin
280     {$IFDEF UNIX}
281     FreeFBLibrary;
282     {$ENDIF}
283     if not LoadIBLibrary or not (FFirebirdAPI as TFBClientAPI).LoadInterface then
284     FFirebirdAPI := nil;
285     end;
286     end;
287     {Note: FFirebirdAPI will be set to nil if the Firebird API fails to load}
288 tony 45 end;
289    
290 tony 263 destructor TFBLibrary.Destroy;
291 tony 45 begin
292 tony 263 FFirebirdAPI := nil;
293     FreeFBLibrary;
294 tony 45 inherited Destroy;
295     end;
296    
297 tony 263 class function TFBLibrary.GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
298     var i: integer;
299     begin
300     Result := nil;
301     if aLibPathName <> '' then
302     begin
303     for i := 0 to Length(FLibraryList) - 1 do
304     if (FLibraryList[i] as TFBLibrary).FRequestedLibName = aLibPathName then
305     begin
306     Result := FLibraryList[i];
307     Exit;
308     end;
309     Result := Create(aLibPathName);
310     end;
311    
312     end;
313    
314     class procedure TFBLibrary.FreeLibraries;
315     var i: integer;
316     begin
317     for i := 0 to Length(FLibraryList) - 1 do
318     FLibraryList[i] := nil;
319     SetLength(FLibraryList,0);
320     end;
321    
322     function TFBLibrary.GetHandle: TLibHandle;
323     begin
324     Result := FIBLibrary;
325     end;
326    
327     { TFBClientAPI }
328    
329     constructor TFBClientAPI.Create(aFBLibrary: TFBLibrary);
330     begin
331     inherited Create;
332     FFBLibrary := aFBLibrary;
333     end;
334    
335 tony 45 procedure TFBClientAPI.IBAlloc(var P; OldSize, NewSize: Integer);
336     var
337     i: Integer;
338     begin
339     ReallocMem(Pointer(P), NewSize);
340 tony 56 for i := OldSize to NewSize - 1 do PAnsiChar(P)[i] := #0;
341 tony 45 end;
342    
343     procedure TFBClientAPI.IBDataBaseError;
344     begin
345     raise EIBInterBaseError.Create(GetStatus);
346     end;
347    
348     {Under Unixes, if using an embedded server then set up local TMP and LOCK Directories}
349    
350 tony 56 procedure TFBClientAPI.EncodeInteger(aValue: integer; len: integer; buffer: PByte);
351 tony 45 begin
352     while len > 0 do
353     begin
354 tony 56 buffer^ := aValue and $FF;
355 tony 45 Inc(buffer);
356     Dec(len);
357     aValue := aValue shr 8;
358     end;
359     end;
360    
361     function TFBClientAPI.IsLibraryLoaded: boolean;
362     begin
363 tony 263 Result := FFBLibrary.IBLibrary <> NilHandle;
364 tony 45 end;
365    
366 tony 263 function TFBClientAPI.GetFBLibrary: IFirebirdLibrary;
367     begin
368     Result := FFBLibrary;
369     end;
370    
371 tony 308 function TFBClientAPI.GetImplementationVersion: AnsiString;
372     begin
373     Result := Format('%d.%d',[GetClientMajor,GetClientMinor]);
374     end;
375    
376 tony 56 function TFBClientAPI.GetProcAddr(ProcName: PAnsiChar): Pointer;
377 tony 45 begin
378 tony 263 Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
379 tony 45 if not Assigned(Result) then
380     raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
381     end;
382    
383 tony 263 function TFBClientAPI.LoadInterface: boolean;
384 tony 45 begin
385     isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
386     isc_sql_interprete := GetProcAddr('isc_sql_interprete'); {do not localize}
387     isc_event_counts := GetProcAddr('isc_event_counts'); {do not localize}
388     isc_event_block := GetProcAddr('isc_event_block'); {do not localize}
389     isc_free := GetProcAddr('isc_free'); {do not localize}
390 tony 263 Result := assigned(isc_free);
391 tony 45 end;
392    
393     { TFBStatus }
394    
395     constructor TFBStatus.Create(aOwner: TFBClientAPI);
396     begin
397     inherited Create;
398     FOwner := aOwner;
399     FIBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
400     end;
401    
402     function TFBStatus.GetIBErrorCode: Long;
403     begin
404     Result := StatusVector^[1];
405     end;
406    
407     function TFBStatus.Getsqlcode: Long;
408     begin
409     with FOwner do
410     Result := isc_sqlcode(PISC_STATUS(StatusVector));
411     end;
412    
413 tony 56 function TFBStatus.GetMessage: AnsiString;
414     var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
415 tony 45 IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
416     sqlcode: Long;
417     begin
418     Result := '';
419     IBDataBaseErrorMessages := FIBDataBaseErrorMessages;
420     sqlcode := Getsqlcode;
421     if (ShowSQLCode in IBDataBaseErrorMessages) then
422     Result := Result + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
423    
424     Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
425     if (ShowSQLMessage in IBDataBaseErrorMessages) then
426     begin
427     with FOwner do
428 tony 308 isc_sql_interprete(sqlcode, local_buffer, sizeof(local_buffer));
429 tony 45 if (ShowSQLCode in FIBDataBaseErrorMessages) then
430     Result := Result + CRLF;
431     Result := Result + strpas(local_buffer);
432     end;
433    
434     if (ShowIBMessage in IBDataBaseErrorMessages) then
435     begin
436     if (ShowSQLCode in IBDataBaseErrorMessages) or
437     (ShowSQLMessage in IBDataBaseErrorMessages) then
438 tony 308 Result := Result + LineEnding;
439     Result := Result + LineEnding + FOwner.FormatStatus(self);
440 tony 45 end;
441     if (Result <> '') and (Result[Length(Result)] = '.') then
442     Delete(Result, Length(Result), 1);
443     end;
444    
445     function TFBStatus.CheckStatusVector(ErrorCodes: array of TFBStatusCode
446     ): Boolean;
447     var
448     p: PISC_STATUS;
449     i: Integer;
450     procedure NextP(i: Integer);
451     begin
452 tony 56 p := PISC_STATUS(PAnsiChar(p) + (i * SizeOf(ISC_STATUS)));
453 tony 45 end;
454     begin
455     p := PISC_STATUS(StatusVector);
456     result := False;
457     while (p^ <> 0) and (not result) do
458     case p^ of
459     3: NextP(3);
460     1, 4:
461     begin
462     NextP(1);
463     i := 0;
464     while (i <= High(ErrorCodes)) and (not result) do
465     begin
466     result := p^ = ErrorCodes[i];
467     Inc(i);
468     end;
469     NextP(1);
470     end;
471     else
472     NextP(2);
473     end;
474     end;
475    
476     function TFBStatus.GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
477     begin
478 tony 56 EnterCriticalSection(TFBClientAPI.FIBCS);
479 tony 45 try
480     result := FIBDataBaseErrorMessages;
481     finally
482 tony 56 LeaveCriticalSection(TFBClientAPI.FIBCS);
483 tony 45 end;
484     end;
485    
486     procedure TFBStatus.SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
487     begin
488 tony 56 EnterCriticalSection(TFBClientAPI.FIBCS);
489 tony 45 try
490     FIBDataBaseErrorMessages := Value;
491     finally
492 tony 56 LeaveCriticalSection(TFBClientAPI.FIBCS);
493 tony 45 end;
494     end;
495 tony 60
496 tony 45 initialization
497 tony 263 TFBLibrary.FEnvSetupDone := false;
498 tony 56 {$IFNDEF FPC}
499     InitializeCriticalSection(TFBClientAPI.FIBCS);
500     {$ELSE}
501     InitCriticalSection(TFBClientAPI.FIBCS);
502     {$ENDIF}
503 tony 45
504     finalization
505 tony 263 TFBLibrary.FreeLibraries;
506 tony 56 {$IFNDEF FPC}
507     DeleteCriticalSection(TFBClientAPI.FIBCS);
508     {$ELSE}
509     DoneCriticalSection(TFBClientAPI.FIBCS);
510     {$ENDIF}
511 tony 45 end.
512