ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/FBClientAPI.pas
Revision: 60
Committed: Mon Mar 27 15:21:02 2017 UTC (7 years ago) by tony
Content type: text/x-pascal
File size: 14201 byte(s)
Log Message:

File Contents

# Content
1 (*
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 {$IFDEF MSWINDOWS}
64 {$DEFINE WINDOWS}
65 {$ENDIF}
66
67 {$IFDEF FPC}
68 {$mode delphi}
69 {$codepage UTF8}
70 {$interfaces COM}
71 {$ENDIF}
72
73 interface
74
75 uses
76 Classes,
77 {$IFDEF WINDOWS}Windows, {$ENDIF}
78 {$IFDEF FPC} Dynlibs, {$ENDIF}
79 IB, IBHeader, FBActivityMonitor, FBMessages, IBExternals;
80
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 {$IFNDEF FPC}
94 type
95 TLibHandle = THandle;
96
97 const
98 NilHandle = 0;
99 DirectorySeparator = '\';
100 {$ENDIF}
101
102 type
103 TStatusVector = array[0..19] of NativeInt;
104 PStatusVector = ^TStatusVector;
105
106 TFBClientAPI = class;
107
108 { TFBStatus }
109
110 TFBStatus = class(TFBInterfacedObject)
111 private
112 FIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
113 protected
114 FOwner: TFBClientAPI;
115 public
116 constructor Create(aOwner: TFBClientAPI);
117 function StatusVector: PStatusVector; virtual; abstract;
118
119 {IStatus}
120 function GetIBErrorCode: Long;
121 function Getsqlcode: Long;
122 function GetMessage: AnsiString;
123 function CheckStatusVector(ErrorCodes: array of TFBStatusCode): Boolean;
124 function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
125 procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
126 end;
127
128 { TFBClientAPI }
129
130 TFBClientAPI = class(TFBInterfacedObject)
131 private
132 FOwnsIBLibrary: boolean;
133 class var FIBCS: TRTLCriticalSection;
134 procedure LoadIBLibrary;
135 protected
136 class var FFBLibraryName: string;
137 class var IBLibrary: TLibHandle;
138 {$IFDEF WINDOWS}
139 class var FFBLibraryPath: string;
140 {$ENDIF}
141 function GetProcAddr(ProcName: PAnsiChar): Pointer;
142 function GetOverrideLibName: string;
143 {$IFDEF UNIX}
144 function GetFirebirdLibList: string; virtual; abstract;
145 {$ENDIF}
146 procedure LoadInterface; virtual;
147 public
148 {Taken from legacy API}
149 isc_sqlcode: Tisc_sqlcode;
150 isc_sql_interprete: Tisc_sql_interprete;
151 isc_interprete: Tisc_interprete;
152 isc_event_counts: Tisc_event_counts;
153 isc_event_block: Tisc_event_block;
154 isc_free: Tisc_free;
155
156 constructor Create;
157 destructor Destroy; override;
158 procedure IBAlloc(var P; OldSize, NewSize: Integer);
159 procedure IBDataBaseError;
160 procedure SetupEnvironment;
161
162 {Encode/Decode}
163 procedure EncodeInteger(aValue: integer; len: integer; buffer: PByte);
164 function DecodeInteger(bufptr: PByte; len: short): integer; virtual; abstract;
165 procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte); virtual; abstract;
166 function SQLDecodeDate(byfptr: PByte): TDateTime; virtual; abstract;
167 procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte); virtual; abstract;
168 function SQLDecodeTime(bufptr: PByte): TDateTime; virtual; abstract;
169 procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte); virtual; abstract;
170 function SQLDecodeDateTime(bufptr: PByte): TDateTime; virtual; abstract;
171
172
173 {IFirebirdAPI}
174 function GetStatus: IStatus; virtual; abstract;
175 function IsLibraryLoaded: boolean;
176 function IsEmbeddedServer: boolean; virtual; abstract;
177 function GetLibraryName: string;
178 end;
179
180 var FirebirdClientAPI: TFBClientAPI = nil;
181
182 implementation
183
184 uses IBUtils, Registry, {$IFDEF Unix} initc, {$ENDIF}
185 {$IFDEF FPC}
186 {$IFDEF WINDOWS }
187 WinDirs,
188 {$ENDIF}
189 {$ELSE}
190 ShlObj,
191 {$ENDIF}
192 SysUtils;
193
194 {$IFDEF UNIX}
195 {$I 'include/uloadlibrary.inc'}
196 {$ELSE}
197 {$I 'include/wloadlibrary.inc'}
198 {$ENDIF}
199
200 {$IFDEF Unix}
201 {SetEnvironmentVariable doesn't exist so we have to use C Library}
202 function setenv(name:Pchar; value:Pchar; replace:integer):integer;cdecl;external clib name 'setenv';
203 function unsetenv(name:Pchar):integer;cdecl;external clib name 'unsetenv';
204 function SetEnvironmentVariable(name:PAnsiChar; value:PAnsiChar):boolean;
205 // Set environment variable; if empty string given, remove it.
206 begin
207 result:=false; //assume failure
208 if value = '' then
209 begin
210 // Assume user wants to remove variable.
211 if unsetenv(name)=0 then result:=true;
212 end
213 else
214 begin
215 // Non empty so set the variable
216 if setenv(name, value, 1)=0 then result:=true;
217 end;
218 end;
219 {$ENDIF}
220
221 { TFBClientAPI }
222
223 constructor TFBClientAPI.Create;
224 begin
225 inherited Create;
226 LoadIBLibrary;
227 if (IBLibrary <> NilHandle) then
228 begin
229 SetupEnvironment;
230 LoadInterface;
231 end;
232 FirebirdClientAPI := self;
233 end;
234
235 destructor TFBClientAPI.Destroy;
236 begin
237 FirebirdClientAPI := nil;
238 if FOwnsIBLibrary and (IBLibrary <> NilHandle) then
239 FreeLibrary(IBLibrary);
240 IBLibrary := NilHandle;
241 inherited Destroy;
242 end;
243
244 procedure TFBClientAPI.IBAlloc(var P; OldSize, NewSize: Integer);
245 var
246 i: Integer;
247 begin
248 ReallocMem(Pointer(P), NewSize);
249 for i := OldSize to NewSize - 1 do PAnsiChar(P)[i] := #0;
250 end;
251
252 procedure TFBClientAPI.IBDataBaseError;
253 begin
254 raise EIBInterBaseError.Create(GetStatus);
255 end;
256
257 {Under Unixes, if using an embedded server then set up local TMP and LOCK Directories}
258
259 procedure TFBClientAPI.SetupEnvironment;
260 var TmpDir: AnsiString;
261 begin
262 {$IFDEF UNIX}
263 TmpDir := GetTempDir +
264 DirectorySeparator + 'firebird_' + sysutils.GetEnvironmentVariable('USER');
265 if sysutils.GetEnvironmentVariable('FIREBIRD_TMP') = '' then
266 begin
267 if not DirectoryExists(tmpDir) then
268 mkdir(tmpDir);
269 SetEnvironmentVariable('FIREBIRD_TMP',PAnsiChar(TmpDir));
270 end;
271 if sysutils.GetEnvironmentVariable('FIREBIRD_LOCK') = '' then
272 begin
273 if not DirectoryExists(tmpDir) then
274 mkdir(tmpDir);
275 SetEnvironmentVariable('FIREBIRD_LOCK',PAnsiChar(TmpDir));
276 end;
277 {$ENDIF}
278 end;
279
280 procedure TFBClientAPI.EncodeInteger(aValue: integer; len: integer; buffer: PByte);
281 begin
282 while len > 0 do
283 begin
284 buffer^ := aValue and $FF;
285 Inc(buffer);
286 Dec(len);
287 aValue := aValue shr 8;
288 end;
289 end;
290
291 function TFBClientAPI.IsLibraryLoaded: boolean;
292 begin
293 Result := IBLibrary <> NilHandle;
294 end;
295
296 function TFBClientAPI.GetProcAddr(ProcName: PAnsiChar): Pointer;
297 begin
298 Result := GetProcAddress(IBLibrary, ProcName);
299 if not Assigned(Result) then
300 raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
301 end;
302
303 function TFBClientAPI.GetOverrideLibName: string;
304 begin
305 Result := '';
306 if AllowUseOfFBLIB then
307 Result := GetEnvironmentVariable('FBLIB');
308 if Result = '' then
309 begin
310 if assigned(OnGetLibraryName) then
311 OnGetLibraryName(Result)
312 end;
313 end;
314
315 procedure TFBClientAPI.LoadInterface;
316 begin
317 isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
318 isc_sql_interprete := GetProcAddr('isc_sql_interprete'); {do not localize}
319 isc_interprete := GetProcAddr('isc_interprete'); {do not localize}
320 isc_event_counts := GetProcAddr('isc_event_counts'); {do not localize}
321 isc_event_block := GetProcAddr('isc_event_block'); {do not localize}
322 isc_free := GetProcAddr('isc_free'); {do not localize}
323 end;
324
325 function TFBClientAPI.GetLibraryName: string;
326 begin
327 Result := FFBLibraryName;
328 end;
329
330 const
331 IBLocalBufferLength = 512;
332 IBBigLocalBufferLength = IBLocalBufferLength * 2;
333 IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;
334
335 { TFBStatus }
336
337 constructor TFBStatus.Create(aOwner: TFBClientAPI);
338 begin
339 inherited Create;
340 FOwner := aOwner;
341 FIBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
342 end;
343
344 function TFBStatus.GetIBErrorCode: Long;
345 begin
346 Result := StatusVector^[1];
347 end;
348
349 function TFBStatus.Getsqlcode: Long;
350 begin
351 with FOwner do
352 Result := isc_sqlcode(PISC_STATUS(StatusVector));
353 end;
354
355 function TFBStatus.GetMessage: AnsiString;
356 var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
357 IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
358 sqlcode: Long;
359 psb: PStatusVector;
360 begin
361 Result := '';
362 IBDataBaseErrorMessages := FIBDataBaseErrorMessages;
363 sqlcode := Getsqlcode;
364 if (ShowSQLCode in IBDataBaseErrorMessages) then
365 Result := Result + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
366
367 Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
368 if (ShowSQLMessage in IBDataBaseErrorMessages) then
369 begin
370 with FOwner do
371 isc_sql_interprete(sqlcode, local_buffer, IBLocalBufferLength);
372 if (ShowSQLCode in FIBDataBaseErrorMessages) then
373 Result := Result + CRLF;
374 Result := Result + strpas(local_buffer);
375 end;
376
377 if (ShowIBMessage in IBDataBaseErrorMessages) then
378 begin
379 if (ShowSQLCode in IBDataBaseErrorMessages) or
380 (ShowSQLMessage in IBDataBaseErrorMessages) then
381 Result := Result + CRLF;
382 psb := StatusVector;
383 with FOwner do
384 while (isc_interprete(@local_buffer, @psb) > 0) do
385 begin
386 if (Result <> '') and (Result[Length(Result)] <> LF) then
387 Result := Result + CRLF;
388 Result := Result + strpas(local_buffer);
389 end;
390 end;
391 if (Result <> '') and (Result[Length(Result)] = '.') then
392 Delete(Result, Length(Result), 1);
393 end;
394
395 function TFBStatus.CheckStatusVector(ErrorCodes: array of TFBStatusCode
396 ): Boolean;
397 var
398 p: PISC_STATUS;
399 i: Integer;
400 procedure NextP(i: Integer);
401 begin
402 p := PISC_STATUS(PAnsiChar(p) + (i * SizeOf(ISC_STATUS)));
403 end;
404 begin
405 p := PISC_STATUS(StatusVector);
406 result := False;
407 while (p^ <> 0) and (not result) do
408 case p^ of
409 3: NextP(3);
410 1, 4:
411 begin
412 NextP(1);
413 i := 0;
414 while (i <= High(ErrorCodes)) and (not result) do
415 begin
416 result := p^ = ErrorCodes[i];
417 Inc(i);
418 end;
419 NextP(1);
420 end;
421 else
422 NextP(2);
423 end;
424 end;
425
426 function TFBStatus.GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
427 begin
428 EnterCriticalSection(TFBClientAPI.FIBCS);
429 try
430 result := FIBDataBaseErrorMessages;
431 finally
432 LeaveCriticalSection(TFBClientAPI.FIBCS);
433 end;
434 end;
435
436 procedure TFBStatus.SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
437 begin
438 EnterCriticalSection(TFBClientAPI.FIBCS);
439 try
440 FIBDataBaseErrorMessages := Value;
441 finally
442 LeaveCriticalSection(TFBClientAPI.FIBCS);
443 end;
444 end;
445
446 initialization
447 TFBClientAPI.IBLibrary := NilHandle;
448 {$IFNDEF FPC}
449 InitializeCriticalSection(TFBClientAPI.FIBCS);
450 {$ELSE}
451 InitCriticalSection(TFBClientAPI.FIBCS);
452 {$ENDIF}
453
454 finalization
455 {$IFNDEF FPC}
456 DeleteCriticalSection(TFBClientAPI.FIBCS);
457 {$ELSE}
458 DoneCriticalSection(TFBClientAPI.FIBCS);
459 {$ENDIF}
460 if TFBClientAPI.IBLibrary <> NilHandle then
461 begin
462 FreeLibrary(TFBClientAPI.IBLibrary);
463 TFBClientAPI.IBLibrary := NilHandle;
464 TFBClientAPI.FFBLibraryName := '';
465 end;
466
467 end.
468