ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/fbintf/client/FBClientAPI.pas
Revision: 47
Committed: Mon Jan 9 15:31:51 2017 UTC (7 years, 2 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/FBClientAPI.pas
File size: 21388 byte(s)
Log Message:
Committing updates for Release R2-0-1

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
64 {$IFDEF FPC}
65 {$mode delphi}
66 {$codepage UTF8}
67 {$interfaces COM}
68 {$ENDIF}
69
70 interface
71
72 uses
73 Classes, Dynlibs, IB, IBHeader, FBActivityMonitor, FBMessages, IBExternals;
74
75 {For Linux see result of GetFirebirdLibList method}
76 {$IFDEF DARWIN}
77 const
78 FIREBIRD_SO2 = 'libfbclient.dylib';
79 {$ENDIF}
80 {$IFDEF WINDOWS}
81 const
82 IBASE_DLL = 'gds32.dll';
83 FIREBIRD_CLIENT = 'fbclient.dll'; {do not localize}
84 FIREBIRD_EMBEDDED = 'fbembed.dll';
85 {$ENDIF}
86
87 type
88 TStatusVector = array[0..19] of NativeInt;
89 PStatusVector = ^TStatusVector;
90
91 TFBClientAPI = class;
92
93 { TFBStatus }
94
95 TFBStatus = class(TFBInterfacedObject)
96 private
97 FIBCS: TRTLCriticalSection; static;
98 FIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
99 protected
100 FOwner: TFBClientAPI;
101 public
102 constructor Create(aOwner: TFBClientAPI);
103 function StatusVector: PStatusVector; virtual; abstract;
104
105 {IStatus}
106 function GetIBErrorCode: Long;
107 function Getsqlcode: Long;
108 function GetMessage: string;
109 function CheckStatusVector(ErrorCodes: array of TFBStatusCode): Boolean;
110 function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
111 procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
112 end;
113
114 { TFBClientAPI }
115
116 TFBClientAPI = class(TFBInterfacedObject)
117 private
118 FOwnsIBLibrary: boolean;
119 procedure LoadIBLibrary;
120 protected
121 FFBLibraryName: string; static;
122 FFBLibraryPath: string; static;
123 IBLibrary: TLibHandle; static;
124 function GetProcAddr(ProcName: PChar): Pointer;
125 function GetOverrideLibName: string;
126 {$IFDEF UNIX}
127 function GetFirebirdLibList: string; virtual; abstract;
128 {$ENDIF}
129 procedure LoadInterface; virtual;
130 public
131 {Taken from legacy API}
132 isc_sqlcode: Tisc_sqlcode;
133 isc_sql_interprete: Tisc_sql_interprete;
134 isc_interprete: Tisc_interprete;
135 isc_event_counts: Tisc_event_counts;
136 isc_event_block: Tisc_event_block;
137 isc_free: Tisc_free;
138
139 constructor Create;
140 destructor Destroy; override;
141 procedure IBAlloc(var P; OldSize, NewSize: Integer);
142 procedure IBDataBaseError;
143 procedure SetupEnvironment;
144
145 {Encode/Decode}
146 procedure EncodeInteger(aValue: integer; len: integer; buffer: PChar);
147 function DecodeInteger(bufptr: PChar; len: short): integer; virtual; abstract;
148 procedure SQLEncodeDate(aDate: TDateTime; bufptr: PChar); virtual; abstract;
149 function SQLDecodeDate(byfptr: PChar): TDateTime; virtual; abstract;
150 procedure SQLEncodeTime(aTime: TDateTime; bufptr: PChar); virtual; abstract;
151 function SQLDecodeTime(bufptr: PChar): TDateTime; virtual; abstract;
152 procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PChar); virtual; abstract;
153 function SQLDecodeDateTime(bufptr: PChar): TDateTime; virtual; abstract;
154
155
156 {IFirebirdAPI}
157 function GetStatus: IStatus; virtual; abstract;
158 function IsLibraryLoaded: boolean;
159 function IsEmbeddedServer: boolean; virtual; abstract;
160 function GetLibraryName: string;
161 function GetCharsetName(CharSetID: integer): string;
162 function CharSetID2CodePage(CharSetID: integer; var CodePage: TSystemCodePage): boolean;
163 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;
166 end;
167
168 const FirebirdClientAPI: TFBClientAPI = nil;
169
170 implementation
171
172 uses IBUtils, {$IFDEF Unix} initc, {$ENDIF}
173 {$IFDEF WINDOWS }
174 Windows,Registry, WinDirs,
175 {$ENDIF}
176 SysUtils;
177
178 {$IFDEF UNIX}
179 {$I uloadlibrary.inc}
180 {$ELSE}
181 {$I wloadlibrary.inc}
182 {$ENDIF}
183
184 type
185 TCharsetMap = record
186 CharsetID: integer;
187 CharSetName: string;
188 CharSetWidth: integer;
189 CodePage: TSystemCodePage;
190 end;
191
192 const
193 CharSetMap: array [0..69] of TCharsetMap = (
194 (CharsetID: 0; CharSetName: 'NONE'; CharSetWidth: 1; CodePage: CP_ACP),
195 (CharsetID: 1; CharSetName: 'OCTETS'; CharSetWidth: 1; CodePage: CP_NONE),
196 (CharsetID: 2; CharSetName: 'ASCII'; CharSetWidth: 1; CodePage: CP_ASCII),
197 (CharsetID: 3; CharSetName: 'UNICODE_FSS'; CharSetWidth: 3; CodePage: CP_UTF8),
198 (CharsetID: 4; CharSetName: 'UTF8'; CharSetWidth: 4; CodePage: CP_UTF8),
199 (CharsetID: 5; CharSetName: 'SJIS_0208'; CharSetWidth: 2; CodePage: 20932),
200 (CharsetID: 6; CharSetName: 'EUCJ_0208'; CharSetWidth: 2; CodePage: 20932),
201 (CharsetID: 7; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
202 (CharsetID: 8; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
203 (CharsetID: 9; CharSetName: 'DOS737'; CharSetWidth: 1; CodePage: 737),
204 (CharsetID: 10; CharSetName: 'DOS437'; CharSetWidth: 1; CodePage: 437),
205 (CharsetID: 11; CharSetName: 'DOS850'; CharSetWidth: 1; CodePage: 850),
206 (CharsetID: 12; CharSetName: 'DOS865'; CharSetWidth: 1; CodePage: 865),
207 (CharsetID: 13; CharSetName: 'DOS860'; CharSetWidth: 1; CodePage: 860),
208 (CharsetID: 14; CharSetName: 'DOS863'; CharSetWidth: 1; CodePage: 863),
209 (CharsetID: 15; CharSetName: 'DOS775'; CharSetWidth: 1; CodePage: 775),
210 (CharsetID: 16; CharSetName: 'DOS858'; CharSetWidth: 1; CodePage: 858),
211 (CharsetID: 17; CharSetName: 'DOS862'; CharSetWidth: 1; CodePage: 862),
212 (CharsetID: 18; CharSetName: 'DOS864'; CharSetWidth: 1; CodePage: 864),
213 (CharsetID: 19; CharSetName: 'NEXT'; CharSetWidth: 1; CodePage: CP_NONE),
214 (CharsetID: 20; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
215 (CharsetID: 21; CharSetName: 'ISO8859_1'; CharSetWidth: 1; CodePage: 28591),
216 (CharsetID: 22; CharSetName: 'ISO8859_2'; CharSetWidth: 1; CodePage: 28592),
217 (CharsetID: 23; CharSetName: 'ISO8859_3'; CharSetWidth: 1; CodePage: 28593),
218 (CharsetID: 24; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
219 (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.
272 begin
273 result:=false; //assume failure
274 if value = '' then
275 begin
276 // Assume user wants to remove variable.
277 if unsetenv(name)=0 then result:=true;
278 end
279 else
280 begin
281 // Non empty so set the variable
282 if setenv(name, value, 1)=0 then result:=true;
283 end;
284 end;
285 {$ENDIF}
286
287 { TFBClientAPI }
288
289 constructor TFBClientAPI.Create;
290 begin
291 inherited Create;
292 LoadIBLibrary;
293 if (IBLibrary <> NilHandle) then
294 begin
295 SetupEnvironment;
296 LoadInterface;
297 end;
298 FirebirdClientAPI := self;
299 end;
300
301 destructor TFBClientAPI.Destroy;
302 begin
303 FirebirdClientAPI := nil;
304 if FOwnsIBLibrary and (IBLibrary <> NilHandle) then
305 UnloadLibrary(IBLibrary);
306 IBLibrary := NilHandle;
307 inherited Destroy;
308 end;
309
310 procedure TFBClientAPI.IBAlloc(var P; OldSize, NewSize: Integer);
311 var
312 i: Integer;
313 begin
314 ReallocMem(Pointer(P), NewSize);
315 for i := OldSize to NewSize - 1 do PChar(P)[i] := #0;
316 end;
317
318 procedure TFBClientAPI.IBDataBaseError;
319 begin
320 raise EIBInterBaseError.Create(GetStatus);
321 end;
322
323 {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);
347 begin
348 while len > 0 do
349 begin
350 buffer^ := char(aValue and $FF);
351 Inc(buffer);
352 Dec(len);
353 aValue := aValue shr 8;
354 end;
355 end;
356
357 function TFBClientAPI.IsLibraryLoaded: boolean;
358 begin
359 Result := IBLibrary <> NilHandle;
360 end;
361
362 function TFBClientAPI.GetProcAddr(ProcName: PChar): Pointer;
363 begin
364 Result := GetProcAddress(IBLibrary, ProcName);
365 if not Assigned(Result) then
366 raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
367 end;
368
369 function TFBClientAPI.GetOverrideLibName: string;
370 begin
371 Result := '';
372 if AllowUseOfFBLIB then
373 Result := GetEnvironmentVariable('FBLIB');
374 if Result = '' then
375 begin
376 if assigned(OnGetLibraryName) then
377 OnGetLibraryName(Result)
378 end;
379 end;
380
381 procedure TFBClientAPI.LoadInterface;
382 begin
383 isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
384 isc_sql_interprete := GetProcAddr('isc_sql_interprete'); {do not localize}
385 isc_interprete := GetProcAddr('isc_interprete'); {do not localize}
386 isc_event_counts := GetProcAddr('isc_event_counts'); {do not localize}
387 isc_event_block := GetProcAddr('isc_event_block'); {do not localize}
388 isc_free := GetProcAddr('isc_free'); {do not localize}
389 end;
390
391 function TFBClientAPI.GetLibraryName: string;
392 begin
393 Result := FFBLibraryName;
394 end;
395
396 function TFBClientAPI.GetCharsetName(CharSetID: integer): string;
397 begin
398 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;
405 end;
406
407 function TFBClientAPI.CharSetID2CodePage(CharSetID: integer;
408 var CodePage: TSystemCodePage): boolean;
409 begin
410 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;
418 end;
419
420 function TFBClientAPI.CodePage2CharSetID(CodePage: TSystemCodePage;
421 var CharSetID: integer): boolean;
422 var i: integer;
423 begin
424 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;
432 end;
433
434 function TFBClientAPI.CharSetName2CharSetID(CharSetName: string;
435 var CharSetID: integer): boolean;
436 var i: integer;
437 begin
438 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;
446 end;
447
448 function TFBClientAPI.CharSetWidth(CharSetID: integer; var Width: integer
449 ): boolean;
450 begin
451 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;
459 end;
460
461 const
462 IBLocalBufferLength = 512;
463 IBBigLocalBufferLength = IBLocalBufferLength * 2;
464 IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;
465
466 { TFBStatus }
467
468 constructor TFBStatus.Create(aOwner: TFBClientAPI);
469 begin
470 inherited Create;
471 FOwner := aOwner;
472 FIBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
473 end;
474
475 function TFBStatus.GetIBErrorCode: Long;
476 begin
477 Result := StatusVector^[1];
478 end;
479
480 function TFBStatus.Getsqlcode: Long;
481 begin
482 with FOwner do
483 Result := isc_sqlcode(PISC_STATUS(StatusVector));
484 end;
485
486 function TFBStatus.GetMessage: string;
487 var local_buffer: array[0..IBHugeLocalBufferLength - 1] of char;
488 IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
489 sqlcode: Long;
490 psb: PStatusVector;
491 begin
492 Result := '';
493 IBDataBaseErrorMessages := FIBDataBaseErrorMessages;
494 sqlcode := Getsqlcode;
495 if (ShowSQLCode in IBDataBaseErrorMessages) then
496 Result := Result + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
497
498 Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
499 if (ShowSQLMessage in IBDataBaseErrorMessages) then
500 begin
501 with FOwner do
502 isc_sql_interprete(sqlcode, local_buffer, IBLocalBufferLength);
503 if (ShowSQLCode in FIBDataBaseErrorMessages) then
504 Result := Result + CRLF;
505 Result := Result + strpas(local_buffer);
506 end;
507
508 if (ShowIBMessage in IBDataBaseErrorMessages) then
509 begin
510 if (ShowSQLCode in IBDataBaseErrorMessages) or
511 (ShowSQLMessage in IBDataBaseErrorMessages) then
512 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;
521 end;
522 if (Result <> '') and (Result[Length(Result)] = '.') then
523 Delete(Result, Length(Result), 1);
524 end;
525
526 function TFBStatus.CheckStatusVector(ErrorCodes: array of TFBStatusCode
527 ): Boolean;
528 var
529 p: PISC_STATUS;
530 i: Integer;
531 procedure NextP(i: Integer);
532 begin
533 p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
534 end;
535 begin
536 p := PISC_STATUS(StatusVector);
537 result := False;
538 while (p^ <> 0) and (not result) do
539 case p^ of
540 3: NextP(3);
541 1, 4:
542 begin
543 NextP(1);
544 i := 0;
545 while (i <= High(ErrorCodes)) and (not result) do
546 begin
547 result := p^ = ErrorCodes[i];
548 Inc(i);
549 end;
550 NextP(1);
551 end;
552 else
553 NextP(2);
554 end;
555 end;
556
557 function TFBStatus.GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
558 begin
559 EnterCriticalSection(FIBCS);
560 try
561 result := FIBDataBaseErrorMessages;
562 finally
563 LeaveCriticalSection(FIBCS);
564 end;
565 end;
566
567 procedure TFBStatus.SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
568 begin
569 EnterCriticalSection(FIBCS);
570 try
571 FIBDataBaseErrorMessages := Value;
572 finally
573 LeaveCriticalSection(FIBCS);
574 end;
575 end;
576 initialization
577 TFBClientAPI.IBLibrary := NilHandle;
578 InitCriticalSection(TFBStatus.FIBCS);
579
580 finalization
581 DoneCriticalSection(TFBStatus.FIBCS);
582 if TFBClientAPI.IBLibrary <> NilHandle then
583 begin
584 FreeLibrary(TFBClientAPI.IBLibrary);
585 TFBClientAPI.IBLibrary := NilHandle;
586 TFBClientAPI.FFBLibraryName := '';
587 end;
588
589 end.
590