ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/fbintf/client/FBClientAPI.pas
Revision: 363
Committed: Tue Dec 7 13:30:05 2021 UTC (8 months ago) by tony
File size: 21127 byte(s)
Log Message:
add fbintf
Line File contents
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 IJournallingHook = interface
251 ['{7d3e45e0-3628-416a-9e22-c20474825031}']
252 procedure TransactionStart(Tr: ITransaction);
253 function TransactionEnd(TransactionID: integer; Action: TTransactionAction): boolean;
254 procedure TransactionRetained(Tr: ITransaction; OldTransactionID: integer; Action: TTransactionAction);
255 procedure ExecQuery(Stmt: IStatement);
256 end;
257
258 implementation
259
260 uses IBUtils, Registry,
261 {$IFDEF Unix} unix, initc, dl, {$ENDIF}
262 {$IFDEF FPC}
263 {$IFDEF WINDOWS }
264 WinDirs,
265 {$ENDIF}
266 {$ELSE}
267 ShlObj,
268 {$ENDIF}
269 SysUtils;
270
271 {$IFDEF UNIX}
272 {$I 'include/uloadlibrary.inc'}
273 {$ELSE}
274 {$I 'include/wloadlibrary.inc'}
275 {$ENDIF}
276
277
278 { TFBLibrary }
279
280 function TFBLibrary.GetOverrideLibName: string;
281 begin
282 Result := FFBLibraryName;
283 if (Result = '') and AllowUseOfFBLIB then
284 Result := GetEnvironmentVariable('FBLIB');
285 if Result = '' then
286 begin
287 if assigned(OnGetLibraryName) then
288 OnGetLibraryName(Result)
289 end;
290 end;
291
292 procedure TFBLibrary.FreeFBLibrary;
293 begin
294 (FFirebirdAPI as TFBClientAPI).FBShutdown;
295 if FIBLibrary <> NilHandle then
296 FreeLibrary(FIBLibrary);
297 FIBLibrary := NilHandle;
298 FFBLibraryName := '';
299 end;
300
301 function TFBLibrary.GetLibraryName: string;
302 begin
303 Result := ExtractFileName(FFBLibraryName);
304 end;
305
306 function TFBLibrary.GetFirebirdAPI: IFirebirdAPI;
307 begin
308 Result := FFirebirdAPI;
309 end;
310
311 constructor TFBLibrary.Create(aLibPathName: string);
312 begin
313 inherited Create;
314 SetupEnvironment;
315 FFBLibraryName := aLibPathName;
316 FIBLibrary := NilHandle;
317 FFirebirdAPI := GetFirebird3API;
318 FRequestedLibName := aLibPathName;
319 if aLibPathName <> '' then
320 begin
321 SetLength(FLibraryList,Length(FLibraryList)+1);
322 FLibraryList[Length(FLibraryList)-1] := self;
323 end;
324 if FFirebirdAPI <> nil then
325 begin
326 {First try Firebird 3}
327 if not LoadIBLibrary or not (FFirebirdAPI as TFBClientAPI).LoadInterface then
328 FFirebirdAPI := nil;
329 end;
330
331 if FFirebirdAPI = nil then
332 begin
333 {now try Firebird 2.5. Under Unix we need to reload the library in case we
334 are to use the embedded library}
335 FFirebirdAPI := GetLegacyFirebirdAPI;
336 if FFirebirdAPI <> nil then
337 begin
338 {$IFDEF UNIX}
339 FreeFBLibrary;
340 {$ENDIF}
341 if not LoadIBLibrary or not (FFirebirdAPI as TFBClientAPI).LoadInterface then
342 FFirebirdAPI := nil;
343 end;
344 end;
345 {Note: FFirebirdAPI will be set to nil if the Firebird API fails to load}
346 end;
347
348 destructor TFBLibrary.Destroy;
349 begin
350 FreeFBLibrary;
351 FFirebirdAPI := nil;
352 inherited Destroy;
353 end;
354
355 class function TFBLibrary.GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
356 var i: integer;
357 begin
358 Result := nil;
359 if aLibPathName <> '' then
360 begin
361 for i := 0 to Length(FLibraryList) - 1 do
362 begin
363 if (FLibraryList[i] as TFBLibrary).SameLibrary(aLibPathName) then
364 begin
365 Result := FLibraryList[i];
366 Exit;
367 end;
368 end;
369 Result := Create(aLibPathName);
370 end;
371
372 end;
373
374 class procedure TFBLibrary.FreeLibraries;
375 var i: integer;
376 begin
377 for i := 0 to Length(FLibraryList) - 1 do
378 FLibraryList[i] := nil;
379 SetLength(FLibraryList,0);
380 end;
381
382 function TFBLibrary.SameLibrary(aLibName: string): boolean;
383 begin
384 Result := FRequestedLibName = aLibName;
385 end;
386
387 function TFBLibrary.GetHandle: TLibHandle;
388 begin
389 Result := FIBLibrary;
390 end;
391
392 { TFBClientAPI }
393
394 constructor TFBClientAPI.Create(aFBLibrary: TFBLibrary);
395 begin
396 inherited Create;
397 FFBLibrary := aFBLibrary;
398 GetTZDataSettings;
399 end;
400
401 procedure TFBClientAPI.IBAlloc(var P; OldSize, NewSize: Integer);
402 var
403 i: Integer;
404 begin
405 ReallocMem(Pointer(P), NewSize);
406 for i := OldSize to NewSize - 1 do PAnsiChar(P)[i] := #0;
407 end;
408
409 procedure TFBClientAPI.IBDataBaseError;
410 begin
411 raise EIBInterBaseError.Create(GetStatus);
412 end;
413
414 procedure TFBClientAPI.EncodeInteger(aValue: integer; len: integer; buffer: PByte);
415 begin
416 while len > 0 do
417 begin
418 buffer^ := aValue and $FF;
419 Inc(buffer);
420 Dec(len);
421 aValue := aValue shr 8;
422 end;
423 end;
424
425 function TFBClientAPI.DecodeInteger(bufptr: PByte; len: short): int64;
426 begin
427 Result := isc_portable_integer(bufptr,len);
428 end;
429
430 function TFBClientAPI.Int128ToStr(bufptr: PByte; scale: integer): AnsiString;
431 begin
432 if not HasInt128Support then
433 IBError(ibxeNotSupported,[]);
434 end;
435
436 procedure TFBClientAPI.StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte);
437 begin
438 if not HasInt128Support then
439 IBError(ibxeNotSupported,[]);
440 end;
441
442 procedure TFBClientAPI.SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal;
443 bufptr: PByte);
444 begin
445 if not HasDecFloatSupport then
446 IBError(ibxeNotSupported,[]);
447 end;
448
449 function TFBClientAPI.SQLDecFloatDecode(SQLType: cardinal; bufptr: PByte): tBCD;
450 begin
451 if not HasDecFloatSupport then
452 IBError(ibxeNotSupported,[]);
453 end;
454
455 function TFBClientAPI.IsLibraryLoaded: boolean;
456 begin
457 Result := FFBLibrary.IBLibrary <> NilHandle;
458 end;
459
460 function TFBClientAPI.GetFBLibrary: IFirebirdLibrary;
461 begin
462 Result := FFBLibrary;
463 end;
464
465 function TFBClientAPI.FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
466 begin
467 {aDate/aTime are in TTimestamp format but aTime is decimilliseconds}
468 aDate := aDate - DateDelta;
469 if aDate < 0 then
470 Result := trunc(aDate) - abs(frac(aTime / (MSecsPerDay*10)))
471 else
472 Result := trunc(aDate) + abs(frac(aTime / (MSecsPerDay*10)));
473 end;
474
475 {$IFDEF UNIX}
476
477 procedure TFBClientAPI.GetTZDataSettings;
478 var S: TStringList;
479 begin
480 FLocalTimeOffset := GetLocalTimeOffset;
481 {$if declared(Gettzname)}
482 FLocalTimeZoneName := Gettzname(tzdaylight);
483 {$else}
484 FLocalTimeZoneName := tzname[tzdaylight];
485 {$ifend}
486 FIsDaylightSavingsTime := tzdaylight;
487 if FileExists(DefaultTimeZoneFile) then
488 begin
489 S := TStringList.Create;
490 try
491 S.LoadFromFile(DefaultTimeZoneFile);
492 if S.Count > 0 then
493 FTZDataTimeZoneID := S[0];
494 finally
495 S.Free;
496 end;
497 end;
498 end;
499 {$ENDIF}
500
501 {$IFDEF WINDOWS}
502 procedure TFBClientAPI.GetTZDataSettings;
503 var TZInfo: TTimeZoneInformation;
504 begin
505 FIsDaylightSavingsTime := false;
506 {is there any way of working out the default TZData DB time zone ID under Windows?}
507 case GetTimeZoneInformation(TZInfo) of
508 TIME_ZONE_ID_UNKNOWN:
509 begin
510 FLocalTimeZoneName := '';
511 FLocalTimeOffset := 0;
512 end;
513 TIME_ZONE_ID_STANDARD:
514 begin
515 FLocalTimeZoneName := strpas(PWideChar(@TZInfo.StandardName));
516 FLocalTimeOffset := TZInfo.Bias;
517 end;
518 TIME_ZONE_ID_DAYLIGHT:
519 begin
520 FLocalTimeZoneName := strpas(PWideChar(@TZInfo.DaylightName));
521 FLocalTimeOffset := TZInfo.DayLightBias;
522 FIsDaylightSavingsTime := true;
523 end;
524 end;
525 end;
526 {$ENDIF}
527
528 function TFBClientAPI.GetProcAddr(ProcName: PAnsiChar): Pointer;
529 begin
530 Result := nil;
531 if assigned(FFBLibrary) and (FFBLibrary.IBLibrary <> NilHandle) then
532 Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
533 if not Assigned(Result) then
534 raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
535 end;
536
537 function TFBClientAPI.HasDecFloatSupport: boolean;
538 begin
539 Result := GetClientMajor >= 4;
540 end;
541
542 function TFBClientAPI.HasInt128Support: boolean;
543 begin
544 Result := false;
545 end;
546
547 function TFBClientAPI.HasLocalTZDB: boolean;
548 begin
549 Result := false;
550 end;
551
552 function TFBClientAPI.HasExtendedTZSupport: boolean;
553 begin
554 Result := false;
555 end;
556
557 function TFBClientAPI.HasTimeZoneSupport: boolean;
558 begin
559 Result := false;
560 end;
561
562 function TFBClientAPI.GetImplementationVersion: AnsiString;
563 begin
564 Result := Format('%d.%d',[GetClientMajor,GetClientMinor]);
565 end;
566
567 function TFBClientAPI.LoadInterface: boolean;
568 begin
569 isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
570 isc_sql_interprete := GetProcAddr('isc_sql_interprete'); {do not localize}
571 isc_event_counts := GetProcAddr('isc_event_counts'); {do not localize}
572 isc_event_block := GetProcAddr('isc_event_block'); {do not localize}
573 isc_free := GetProcAddr('isc_free'); {do not localize}
574 isc_portable_integer := GetProcAddr('isc_portable_integer'); {do not localize}
575 fb_shutdown := GetProcAddr('fb_shutdown'); {do not localize}
576 Result := assigned(isc_free);
577 end;
578
579 procedure TFBClientAPI.FBShutdown;
580 begin
581 if assigned(fb_shutdown) then
582 fb_shutdown(0,fb_shutrsn_exit_called);
583 end;
584
585 { TFBStatus }
586
587 constructor TFBStatus.Create(aOwner: TFBClientAPI; prefix: AnsiString);
588 begin
589 inherited Create;
590 FOwner := aOwner;
591 FPrefix := prefix;
592 FIBDataBaseErrorMessages := [ShowSQLCode, ShowSQLMessage, ShowIBMessage];
593 end;
594
595 function TFBStatus.GetIBErrorCode: TStatusCode;
596 begin
597 Result := StatusVector^[1];
598 end;
599
600 function TFBStatus.Getsqlcode: TStatusCode;
601 begin
602 with FOwner do
603 Result := isc_sqlcode(PISC_STATUS(StatusVector));
604 end;
605
606 function TFBStatus.GetMessage: AnsiString;
607 var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
608 IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
609 sqlcode: Long;
610 begin
611 Result := FPrefix;
612 IBDataBaseErrorMessages := FIBDataBaseErrorMessages;
613 sqlcode := Getsqlcode;
614 if (ShowSQLCode in IBDataBaseErrorMessages) then
615 Result := Result + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
616
617 if (ShowSQLMessage in IBDataBaseErrorMessages) then
618 begin
619 with FOwner do
620 isc_sql_interprete(sqlcode, local_buffer, sizeof(local_buffer));
621 if (ShowSQLCode in FIBDataBaseErrorMessages) then
622 Result := Result + LineEnding;
623 Result := Result + 'Engine Code: ' + IntToStr(GetIBErrorCode) + ' ' + strpas(local_buffer);
624 end;
625
626 if (ShowIBMessage in IBDataBaseErrorMessages) then
627 begin
628 if (ShowSQLCode in IBDataBaseErrorMessages) or
629 (ShowSQLMessage in IBDataBaseErrorMessages) then
630 Result := Result + LineEnding;
631 Result := Result + FOwner.FormatStatus(self);
632 end;
633 if (Result <> '') and (Result[Length(Result)] = '.') then
634 Delete(Result, Length(Result), 1);
635 end;
636
637 function TFBStatus.CheckStatusVector(ErrorCodes: array of TFBStatusCode
638 ): Boolean;
639 var
640 p: PISC_STATUS;
641 i: Integer;
642 procedure NextP(i: Integer);
643 begin
644 p := PISC_STATUS(PAnsiChar(p) + (i * SizeOf(ISC_STATUS)));
645 end;
646 begin
647 p := PISC_STATUS(StatusVector);
648 result := False;
649 while (p^ <> 0) and (not result) do
650 case p^ of
651 3: NextP(3);
652 1, 4:
653 begin
654 NextP(1);
655 i := 0;
656 while (i <= High(ErrorCodes)) and (not result) do
657 begin
658 result := p^ = ErrorCodes[i];
659 Inc(i);
660 end;
661 NextP(1);
662 end;
663 else
664 NextP(2);
665 end;
666 end;
667
668 function TFBStatus.GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
669 begin
670 EnterCriticalSection(TFBClientAPI.FIBCS);
671 try
672 result := FIBDataBaseErrorMessages;
673 finally
674 LeaveCriticalSection(TFBClientAPI.FIBCS);
675 end;
676 end;
677
678 procedure TFBStatus.SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
679 begin
680 EnterCriticalSection(TFBClientAPI.FIBCS);
681 try
682 FIBDataBaseErrorMessages := Value;
683 finally
684 LeaveCriticalSection(TFBClientAPI.FIBCS);
685 end;
686 end;
687
688 initialization
689 TFBLibrary.FEnvSetupDone := false;
690 {$IFNDEF FPC}
691 InitializeCriticalSection(TFBClientAPI.FIBCS);
692 {$ELSE}
693 InitCriticalSection(TFBClientAPI.FIBCS);
694 {$ENDIF}
695
696 finalization
697 TFBLibrary.FreeLibraries;
698 {$IFNDEF FPC}
699 DeleteCriticalSection(TFBClientAPI.FIBCS);
700 {$ELSE}
701 DoneCriticalSection(TFBClientAPI.FIBCS);
702 {$ENDIF}
703 end.
704