ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/fbintf/client/FBClientAPI.pas
Revision: 362
Committed: Tue Dec 7 13:27:39 2021 UTC (2 years, 3 months ago) by tony
Content type: text/x-pascal
File size: 20734 byte(s)
Log Message:
initiate test release

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, FmtBCD;
80
81 {For Linux see result of GetFirebirdLibListruntime/nongui/winipc.inc 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 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;
113
114 TFBClientAPI = class;
115
116 { TFBStatus }
117
118 TFBStatus = class(TFBInterfacedObject)
119 private
120 FIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
121 FPrefix: AnsiString;
122 protected
123 FOwner: TFBClientAPI;
124 public
125 constructor Create(aOwner: TFBClientAPI; prefix: AnsiString='');
126 function StatusVector: PStatusVector; virtual; abstract;
127
128 {IStatus}
129 function GetIBErrorCode: TStatusCode;
130 function Getsqlcode: TStatusCode;
131 function GetMessage: AnsiString;
132 function CheckStatusVector(ErrorCodes: array of TFBStatusCode): Boolean;
133 function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
134 procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
135 end;
136
137 { TFBLibrary }
138
139 TFBLibrary = class(TFBInterfacedObject,IFirebirdLibrary)
140 private
141 class var FEnvSetupDone: boolean;
142 class var FLibraryList: array of IFirebirdLibrary;
143 private
144 FFirebirdAPI: IFirebirdAPI;
145 FRequestedLibName: string;
146 function LoadIBLibrary: boolean;
147 protected
148 FFBLibraryName: string;
149 FIBLibrary: TLibHandle;
150 procedure FreeFBLibrary;
151 function GetOverrideLibName: string;
152 class procedure SetupEnvironment;
153 protected
154 function GetFirebird3API: IFirebirdAPI; virtual; abstract;
155 function GetLegacyFirebirdAPI: IFirebirdAPI; virtual; abstract;
156 public
157 constructor Create(aLibPathName: string='');
158 destructor Destroy; override;
159 class function GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
160 class procedure FreeLibraries;
161 function SameLibrary(aLibName: string): boolean;
162
163 public
164 {IFirebirdLibrary}
165 function GetHandle: TLibHandle;
166 function GetLibraryName: string;
167 function GetLibraryFilePath: string;
168 function GetFirebirdAPI: IFirebirdAPI;
169 property IBLibrary: TLibHandle read FIBLibrary;
170 end;
171
172 { TFBClientAPI }
173
174 TFBClientAPI = class(TFBInterfacedObject)
175 private
176 FLocalTimeZoneName: AnsiString; {Informal Time Zone Name from tzname e.g. GMT or BST}
177 FTZDataTimeZoneID: AnsiString; {TZData DB ID e.g. Europe/London}
178 FLocalTimeOffset: integer;
179 FIsDaylightSavingsTime: boolean;
180 class var FIBCS: TRTLCriticalSection;
181 function FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
182 procedure GetTZDataSettings;
183 protected
184 FFBLibrary: TFBLibrary;
185 function GetProcAddr(ProcName: PAnsiChar): Pointer;
186
187 protected type
188 Tfb_shutdown = function (timeout: uint;
189 const reason: int): int;
190 {$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
191 protected
192 {FB Shutdown API}
193 fb_shutdown: Tfb_shutdown;
194
195 public
196 {Taken from legacy API}
197 isc_sqlcode: Tisc_sqlcode;
198 isc_sql_interprete: Tisc_sql_interprete;
199 isc_event_counts: Tisc_event_counts;
200 isc_event_block: Tisc_event_block;
201 isc_free: Tisc_free;
202 isc_portable_integer: Tisc_portable_integer;
203
204 constructor Create(aFBLibrary: TFBLibrary);
205 procedure IBAlloc(var P; OldSize, NewSize: Integer);
206 procedure IBDataBaseError;
207 function LoadInterface: boolean; virtual;
208 procedure FBShutdown; virtual;
209 function GetAPI: IFirebirdAPI; virtual; abstract;
210 {$IFDEF UNIX}
211 function GetFirebirdLibList: string; virtual; abstract;
212 {$ENDIF}
213 function HasDecFloatSupport: boolean;
214 function HasInt128Support: boolean; virtual;
215 function HasLocalTZDB: boolean; virtual;
216 function HasExtendedTZSupport: boolean; virtual;
217 function HasTimeZoneSupport: boolean; virtual;
218
219 public
220 property LocalTimeZoneName: AnsiString read FLocalTimeZoneName;
221 property TZDataTimeZoneID: AnsiString read FTZDataTimeZoneID;
222 property LocalTimeOffset: integer read FLocalTimeOffset;
223 public
224 {Encode/Decode}
225 procedure EncodeInteger(aValue: integer; len: integer; buffer: PByte);
226 function DecodeInteger(bufptr: PByte; len: short): int64;
227 procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte); virtual; abstract;
228 function SQLDecodeDate(byfptr: PByte): TDateTime; virtual; abstract;
229 procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte); virtual; abstract;
230 function SQLDecodeTime(bufptr: PByte): TDateTime; virtual; abstract;
231 procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte); virtual; abstract;
232 function SQLDecodeDateTime(bufptr: PByte): TDateTime; virtual; abstract;
233 function FormatStatus(Status: TFBStatus): AnsiString; virtual; abstract;
234 function Int128ToStr(bufptr: PByte; scale: integer): AnsiString; virtual;
235 procedure StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte);
236 virtual;
237 procedure SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal; bufptr: PByte); virtual;
238 function SQLDecFloatDecode(SQLType: cardinal; bufptr: PByte): tBCD; virtual;
239
240 {IFirebirdAPI}
241 function GetStatus: IStatus; virtual; abstract;
242 function IsLibraryLoaded: boolean;
243 function IsEmbeddedServer: boolean; virtual; abstract;
244 function GetFBLibrary: IFirebirdLibrary;
245 function GetImplementationVersion: AnsiString;
246 function GetClientMajor: integer; virtual; abstract;
247 function GetClientMinor: integer; virtual; abstract;
248 end;
249
250 implementation
251
252 uses IBUtils, Registry,
253 {$IFDEF Unix} unix, initc, dl, {$ENDIF}
254 {$IFDEF FPC}
255 {$IFDEF WINDOWS }
256 WinDirs,
257 {$ENDIF}
258 {$ELSE}
259 ShlObj,
260 {$ENDIF}
261 SysUtils;
262
263 {$IFDEF UNIX}
264 {$I 'include/uloadlibrary.inc'}
265 {$ELSE}
266 {$I 'include/wloadlibrary.inc'}
267 {$ENDIF}
268
269
270 { TFBLibrary }
271
272 function TFBLibrary.GetOverrideLibName: string;
273 begin
274 Result := FFBLibraryName;
275 if (Result = '') and AllowUseOfFBLIB then
276 Result := GetEnvironmentVariable('FBLIB');
277 if Result = '' then
278 begin
279 if assigned(OnGetLibraryName) then
280 OnGetLibraryName(Result)
281 end;
282 end;
283
284 procedure TFBLibrary.FreeFBLibrary;
285 begin
286 (FFirebirdAPI as TFBClientAPI).FBShutdown;
287 if FIBLibrary <> NilHandle then
288 FreeLibrary(FIBLibrary);
289 FIBLibrary := NilHandle;
290 FFBLibraryName := '';
291 end;
292
293 function TFBLibrary.GetLibraryName: string;
294 begin
295 Result := ExtractFileName(FFBLibraryName);
296 end;
297
298 function TFBLibrary.GetFirebirdAPI: IFirebirdAPI;
299 begin
300 Result := FFirebirdAPI;
301 end;
302
303 constructor TFBLibrary.Create(aLibPathName: string);
304 begin
305 inherited Create;
306 SetupEnvironment;
307 FFBLibraryName := aLibPathName;
308 FIBLibrary := NilHandle;
309 FFirebirdAPI := GetFirebird3API;
310 FRequestedLibName := aLibPathName;
311 if aLibPathName <> '' then
312 begin
313 SetLength(FLibraryList,Length(FLibraryList)+1);
314 FLibraryList[Length(FLibraryList)-1] := self;
315 end;
316 if FFirebirdAPI <> nil then
317 begin
318 {First try Firebird 3}
319 if not LoadIBLibrary or not (FFirebirdAPI as TFBClientAPI).LoadInterface then
320 FFirebirdAPI := nil;
321 end;
322
323 if FFirebirdAPI = nil then
324 begin
325 {now try Firebird 2.5. Under Unix we need to reload the library in case we
326 are to use the embedded library}
327 FFirebirdAPI := GetLegacyFirebirdAPI;
328 if FFirebirdAPI <> nil then
329 begin
330 {$IFDEF UNIX}
331 FreeFBLibrary;
332 {$ENDIF}
333 if not LoadIBLibrary or not (FFirebirdAPI as TFBClientAPI).LoadInterface then
334 FFirebirdAPI := nil;
335 end;
336 end;
337 {Note: FFirebirdAPI will be set to nil if the Firebird API fails to load}
338 end;
339
340 destructor TFBLibrary.Destroy;
341 begin
342 FreeFBLibrary;
343 FFirebirdAPI := nil;
344 inherited Destroy;
345 end;
346
347 class function TFBLibrary.GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
348 var i: integer;
349 begin
350 Result := nil;
351 if aLibPathName <> '' then
352 begin
353 for i := 0 to Length(FLibraryList) - 1 do
354 begin
355 if (FLibraryList[i] as TFBLibrary).SameLibrary(aLibPathName) then
356 begin
357 Result := FLibraryList[i];
358 Exit;
359 end;
360 end;
361 Result := Create(aLibPathName);
362 end;
363
364 end;
365
366 class procedure TFBLibrary.FreeLibraries;
367 var i: integer;
368 begin
369 for i := 0 to Length(FLibraryList) - 1 do
370 FLibraryList[i] := nil;
371 SetLength(FLibraryList,0);
372 end;
373
374 function TFBLibrary.SameLibrary(aLibName: string): boolean;
375 begin
376 Result := FRequestedLibName = aLibName;
377 end;
378
379 function TFBLibrary.GetHandle: TLibHandle;
380 begin
381 Result := FIBLibrary;
382 end;
383
384 { TFBClientAPI }
385
386 constructor TFBClientAPI.Create(aFBLibrary: TFBLibrary);
387 begin
388 inherited Create;
389 FFBLibrary := aFBLibrary;
390 GetTZDataSettings;
391 end;
392
393 procedure TFBClientAPI.IBAlloc(var P; OldSize, NewSize: Integer);
394 var
395 i: Integer;
396 begin
397 ReallocMem(Pointer(P), NewSize);
398 for i := OldSize to NewSize - 1 do PAnsiChar(P)[i] := #0;
399 end;
400
401 procedure TFBClientAPI.IBDataBaseError;
402 begin
403 raise EIBInterBaseError.Create(GetStatus);
404 end;
405
406 procedure TFBClientAPI.EncodeInteger(aValue: integer; len: integer; buffer: PByte);
407 begin
408 while len > 0 do
409 begin
410 buffer^ := aValue and $FF;
411 Inc(buffer);
412 Dec(len);
413 aValue := aValue shr 8;
414 end;
415 end;
416
417 function TFBClientAPI.DecodeInteger(bufptr: PByte; len: short): int64;
418 begin
419 Result := isc_portable_integer(bufptr,len);
420 end;
421
422 function TFBClientAPI.Int128ToStr(bufptr: PByte; scale: integer): AnsiString;
423 begin
424 if not HasInt128Support then
425 IBError(ibxeNotSupported,[]);
426 end;
427
428 procedure TFBClientAPI.StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte);
429 begin
430 if not HasInt128Support then
431 IBError(ibxeNotSupported,[]);
432 end;
433
434 procedure TFBClientAPI.SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal;
435 bufptr: PByte);
436 begin
437 if not HasDecFloatSupport then
438 IBError(ibxeNotSupported,[]);
439 end;
440
441 function TFBClientAPI.SQLDecFloatDecode(SQLType: cardinal; bufptr: PByte): tBCD;
442 begin
443 if not HasDecFloatSupport then
444 IBError(ibxeNotSupported,[]);
445 end;
446
447 function TFBClientAPI.IsLibraryLoaded: boolean;
448 begin
449 Result := FFBLibrary.IBLibrary <> NilHandle;
450 end;
451
452 function TFBClientAPI.GetFBLibrary: IFirebirdLibrary;
453 begin
454 Result := FFBLibrary;
455 end;
456
457 function TFBClientAPI.FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
458 begin
459 {aDate/aTime are in TTimestamp format but aTime is decimilliseconds}
460 aDate := aDate - DateDelta;
461 if aDate < 0 then
462 Result := trunc(aDate) - abs(frac(aTime / (MSecsPerDay*10)))
463 else
464 Result := trunc(aDate) + abs(frac(aTime / (MSecsPerDay*10)));
465 end;
466
467 {$IFDEF UNIX}
468
469 procedure TFBClientAPI.GetTZDataSettings;
470 var S: TStringList;
471 begin
472 FLocalTimeOffset := GetLocalTimeOffset;
473 {$if declared(Gettzname)}
474 FLocalTimeZoneName := Gettzname(tzdaylight);
475 {$else}
476 FLocalTimeZoneName := tzname[tzdaylight];
477 {$ifend}
478 FIsDaylightSavingsTime := tzdaylight;
479 if FileExists(DefaultTimeZoneFile) then
480 begin
481 S := TStringList.Create;
482 try
483 S.LoadFromFile(DefaultTimeZoneFile);
484 if S.Count > 0 then
485 FTZDataTimeZoneID := S[0];
486 finally
487 S.Free;
488 end;
489 end;
490 end;
491 {$ENDIF}
492
493 {$IFDEF WINDOWS}
494 procedure TFBClientAPI.GetTZDataSettings;
495 var TZInfo: TTimeZoneInformation;
496 begin
497 FIsDaylightSavingsTime := false;
498 {is there any way of working out the default TZData DB time zone ID under Windows?}
499 case GetTimeZoneInformation(TZInfo) of
500 TIME_ZONE_ID_UNKNOWN:
501 begin
502 FLocalTimeZoneName := '';
503 FLocalTimeOffset := 0;
504 end;
505 TIME_ZONE_ID_STANDARD:
506 begin
507 FLocalTimeZoneName := strpas(PWideChar(@TZInfo.StandardName));
508 FLocalTimeOffset := TZInfo.Bias;
509 end;
510 TIME_ZONE_ID_DAYLIGHT:
511 begin
512 FLocalTimeZoneName := strpas(PWideChar(@TZInfo.DaylightName));
513 FLocalTimeOffset := TZInfo.DayLightBias;
514 FIsDaylightSavingsTime := true;
515 end;
516 end;
517 end;
518 {$ENDIF}
519
520 function TFBClientAPI.GetProcAddr(ProcName: PAnsiChar): Pointer;
521 begin
522 Result := nil;
523 if assigned(FFBLibrary) and (FFBLibrary.IBLibrary <> NilHandle) then
524 Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
525 if not Assigned(Result) then
526 raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
527 end;
528
529 function TFBClientAPI.HasDecFloatSupport: boolean;
530 begin
531 Result := GetClientMajor >= 4;
532 end;
533
534 function TFBClientAPI.HasInt128Support: boolean;
535 begin
536 Result := false;
537 end;
538
539 function TFBClientAPI.HasLocalTZDB: boolean;
540 begin
541 Result := false;
542 end;
543
544 function TFBClientAPI.HasExtendedTZSupport: boolean;
545 begin
546 Result := false;
547 end;
548
549 function TFBClientAPI.HasTimeZoneSupport: boolean;
550 begin
551 Result := false;
552 end;
553
554 function TFBClientAPI.GetImplementationVersion: AnsiString;
555 begin
556 Result := Format('%d.%d',[GetClientMajor,GetClientMinor]);
557 end;
558
559 function TFBClientAPI.LoadInterface: boolean;
560 begin
561 isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
562 isc_sql_interprete := GetProcAddr('isc_sql_interprete'); {do not localize}
563 isc_event_counts := GetProcAddr('isc_event_counts'); {do not localize}
564 isc_event_block := GetProcAddr('isc_event_block'); {do not localize}
565 isc_free := GetProcAddr('isc_free'); {do not localize}
566 isc_portable_integer := GetProcAddr('isc_portable_integer'); {do not localize}
567 fb_shutdown := GetProcAddr('fb_shutdown'); {do not localize}
568 Result := assigned(isc_free);
569 end;
570
571 procedure TFBClientAPI.FBShutdown;
572 begin
573 if assigned(fb_shutdown) then
574 fb_shutdown(0,fb_shutrsn_exit_called);
575 end;
576
577 { TFBStatus }
578
579 constructor TFBStatus.Create(aOwner: TFBClientAPI; prefix: AnsiString);
580 begin
581 inherited Create;
582 FOwner := aOwner;
583 FPrefix := prefix;
584 FIBDataBaseErrorMessages := [ShowSQLCode, ShowSQLMessage, ShowIBMessage];
585 end;
586
587 function TFBStatus.GetIBErrorCode: TStatusCode;
588 begin
589 Result := StatusVector^[1];
590 end;
591
592 function TFBStatus.Getsqlcode: TStatusCode;
593 begin
594 with FOwner do
595 Result := isc_sqlcode(PISC_STATUS(StatusVector));
596 end;
597
598 function TFBStatus.GetMessage: AnsiString;
599 var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
600 IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
601 sqlcode: Long;
602 begin
603 Result := FPrefix;
604 IBDataBaseErrorMessages := FIBDataBaseErrorMessages;
605 sqlcode := Getsqlcode;
606 if (ShowSQLCode in IBDataBaseErrorMessages) then
607 Result := Result + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
608
609 if (ShowSQLMessage in IBDataBaseErrorMessages) then
610 begin
611 with FOwner do
612 isc_sql_interprete(sqlcode, local_buffer, sizeof(local_buffer));
613 if (ShowSQLCode in FIBDataBaseErrorMessages) then
614 Result := Result + LineEnding;
615 Result := Result + 'Engine Code: ' + IntToStr(GetIBErrorCode) + ' ' + strpas(local_buffer);
616 end;
617
618 if (ShowIBMessage in IBDataBaseErrorMessages) then
619 begin
620 if (ShowSQLCode in IBDataBaseErrorMessages) or
621 (ShowSQLMessage in IBDataBaseErrorMessages) then
622 Result := Result + LineEnding;
623 Result := Result + FOwner.FormatStatus(self);
624 end;
625 if (Result <> '') and (Result[Length(Result)] = '.') then
626 Delete(Result, Length(Result), 1);
627 end;
628
629 function TFBStatus.CheckStatusVector(ErrorCodes: array of TFBStatusCode
630 ): Boolean;
631 var
632 p: PISC_STATUS;
633 i: Integer;
634 procedure NextP(i: Integer);
635 begin
636 p := PISC_STATUS(PAnsiChar(p) + (i * SizeOf(ISC_STATUS)));
637 end;
638 begin
639 p := PISC_STATUS(StatusVector);
640 result := False;
641 while (p^ <> 0) and (not result) do
642 case p^ of
643 3: NextP(3);
644 1, 4:
645 begin
646 NextP(1);
647 i := 0;
648 while (i <= High(ErrorCodes)) and (not result) do
649 begin
650 result := p^ = ErrorCodes[i];
651 Inc(i);
652 end;
653 NextP(1);
654 end;
655 else
656 NextP(2);
657 end;
658 end;
659
660 function TFBStatus.GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
661 begin
662 EnterCriticalSection(TFBClientAPI.FIBCS);
663 try
664 result := FIBDataBaseErrorMessages;
665 finally
666 LeaveCriticalSection(TFBClientAPI.FIBCS);
667 end;
668 end;
669
670 procedure TFBStatus.SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
671 begin
672 EnterCriticalSection(TFBClientAPI.FIBCS);
673 try
674 FIBDataBaseErrorMessages := Value;
675 finally
676 LeaveCriticalSection(TFBClientAPI.FIBCS);
677 end;
678 end;
679
680 initialization
681 TFBLibrary.FEnvSetupDone := false;
682 {$IFNDEF FPC}
683 InitializeCriticalSection(TFBClientAPI.FIBCS);
684 {$ELSE}
685 InitCriticalSection(TFBClientAPI.FIBCS);
686 {$ENDIF}
687
688 finalization
689 TFBLibrary.FreeLibraries;
690 {$IFNDEF FPC}
691 DeleteCriticalSection(TFBClientAPI.FIBCS);
692 {$ELSE}
693 DoneCriticalSection(TFBClientAPI.FIBCS);
694 {$ENDIF}
695 end.
696