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