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 (2 years, 3 months ago) by tony
Content type: text/x-pascal
File size: 21127 byte(s)
Log Message:
add fbintf

File Contents

# User Rev Content
1 tony 45 (*
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 tony 56 {$IFDEF MSWINDOWS}
64     {$DEFINE WINDOWS}
65     {$ENDIF}
66 tony 45
67     {$IFDEF FPC}
68     {$mode delphi}
69     {$codepage UTF8}
70     {$interfaces COM}
71     {$ENDIF}
72    
73     interface
74    
75     uses
76 tony 56 Classes,
77     {$IFDEF WINDOWS}Windows, {$ENDIF}
78     {$IFDEF FPC} Dynlibs, {$ENDIF}
79 tony 315 IB, IBHeader, FBActivityMonitor, FBMessages, IBExternals, FmtBCD;
80 tony 45
81 tony 319 {For Linux see result of GetFirebirdLibListruntime/nongui/winipc.inc method}
82 tony 45 {$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 tony 308 const
94 tony 315 {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 tony 308 IBLocalBufferLength = 512;
107     IBBigLocalBufferLength = IBLocalBufferLength * 2;
108     IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;
109    
110 tony 45 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 tony 345 FPrefix: AnsiString;
122 tony 45 protected
123     FOwner: TFBClientAPI;
124     public
125 tony 345 constructor Create(aOwner: TFBClientAPI; prefix: AnsiString='');
126 tony 45 function StatusVector: PStatusVector; virtual; abstract;
127    
128     {IStatus}
129 tony 345 function GetIBErrorCode: TStatusCode;
130     function Getsqlcode: TStatusCode;
131 tony 56 function GetMessage: AnsiString;
132 tony 45 function CheckStatusVector(ErrorCodes: array of TFBStatusCode): Boolean;
133     function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
134     procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
135     end;
136    
137 tony 263 { TFBLibrary }
138    
139     TFBLibrary = class(TFBInterfacedObject,IFirebirdLibrary)
140     private
141     class var FEnvSetupDone: boolean;
142     class var FLibraryList: array of IFirebirdLibrary;
143 tony 315 private
144 tony 263 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 tony 315 function SameLibrary(aLibName: string): boolean;
162 tony 263
163 tony 315 public
164 tony 263 {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 tony 45 { TFBClientAPI }
173    
174     TFBClientAPI = class(TFBInterfacedObject)
175     private
176 tony 315 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 tony 56 class var FIBCS: TRTLCriticalSection;
181 tony 315 function FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
182     procedure GetTZDataSettings;
183 tony 45 protected
184 tony 263 FFBLibrary: TFBLibrary;
185 tony 56 function GetProcAddr(ProcName: PAnsiChar): Pointer;
186 tony 315
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 tony 45 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 tony 345 isc_portable_integer: Tisc_portable_integer;
203 tony 45
204 tony 263 constructor Create(aFBLibrary: TFBLibrary);
205 tony 45 procedure IBAlloc(var P; OldSize, NewSize: Integer);
206     procedure IBDataBaseError;
207 tony 263 function LoadInterface: boolean; virtual;
208 tony 315 procedure FBShutdown; virtual;
209 tony 263 function GetAPI: IFirebirdAPI; virtual; abstract;
210     {$IFDEF UNIX}
211     function GetFirebirdLibList: string; virtual; abstract;
212     {$ENDIF}
213 tony 315 function HasDecFloatSupport: boolean;
214     function HasInt128Support: boolean; virtual;
215     function HasLocalTZDB: boolean; virtual;
216     function HasExtendedTZSupport: boolean; virtual;
217     function HasTimeZoneSupport: boolean; virtual;
218 tony 45
219 tony 315 public
220     property LocalTimeZoneName: AnsiString read FLocalTimeZoneName;
221     property TZDataTimeZoneID: AnsiString read FTZDataTimeZoneID;
222     property LocalTimeOffset: integer read FLocalTimeOffset;
223     public
224 tony 45 {Encode/Decode}
225 tony 56 procedure EncodeInteger(aValue: integer; len: integer; buffer: PByte);
226 tony 345 function DecodeInteger(bufptr: PByte; len: short): int64;
227 tony 315 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 tony 56 function SQLDecodeTime(bufptr: PByte): TDateTime; virtual; abstract;
231     procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte); virtual; abstract;
232 tony 315 function SQLDecodeDateTime(bufptr: PByte): TDateTime; virtual; abstract;
233 tony 308 function FormatStatus(Status: TFBStatus): AnsiString; virtual; abstract;
234 tony 315 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 tony 45
240     {IFirebirdAPI}
241     function GetStatus: IStatus; virtual; abstract;
242     function IsLibraryLoaded: boolean;
243     function IsEmbeddedServer: boolean; virtual; abstract;
244 tony 263 function GetFBLibrary: IFirebirdLibrary;
245 tony 308 function GetImplementationVersion: AnsiString;
246     function GetClientMajor: integer; virtual; abstract;
247     function GetClientMinor: integer; virtual; abstract;
248 tony 363 end;
249 tony 45
250 tony 363 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 tony 45 implementation
259    
260 tony 263 uses IBUtils, Registry,
261 tony 315 {$IFDEF Unix} unix, initc, dl, {$ENDIF}
262 tony 56 {$IFDEF FPC}
263 tony 45 {$IFDEF WINDOWS }
264 tony 56 WinDirs,
265 tony 45 {$ENDIF}
266 tony 56 {$ELSE}
267     ShlObj,
268     {$ENDIF}
269 tony 45 SysUtils;
270    
271     {$IFDEF UNIX}
272 tony 56 {$I 'include/uloadlibrary.inc'}
273 tony 45 {$ELSE}
274 tony 56 {$I 'include/wloadlibrary.inc'}
275 tony 45 {$ENDIF}
276    
277 tony 263
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 tony 45 begin
287 tony 263 if assigned(OnGetLibraryName) then
288     OnGetLibraryName(Result)
289 tony 45 end;
290 tony 263 end;
291 tony 45
292 tony 263 procedure TFBLibrary.FreeFBLibrary;
293     begin
294 tony 315 (FFirebirdAPI as TFBClientAPI).FBShutdown;
295 tony 263 if FIBLibrary <> NilHandle then
296     FreeLibrary(FIBLibrary);
297     FIBLibrary := NilHandle;
298 tony 315 FFBLibraryName := '';
299 tony 263 end;
300 tony 45
301 tony 263 function TFBLibrary.GetLibraryName: string;
302 tony 45 begin
303 tony 263 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 tony 45 inherited Create;
314 tony 263 SetupEnvironment;
315     FFBLibraryName := aLibPathName;
316     FIBLibrary := NilHandle;
317     FFirebirdAPI := GetFirebird3API;
318     FRequestedLibName := aLibPathName;
319     if aLibPathName <> '' then
320 tony 45 begin
321 tony 263 SetLength(FLibraryList,Length(FLibraryList)+1);
322     FLibraryList[Length(FLibraryList)-1] := self;
323 tony 45 end;
324 tony 263 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 tony 45 end;
347    
348 tony 263 destructor TFBLibrary.Destroy;
349 tony 45 begin
350 tony 315 FreeFBLibrary;
351 tony 263 FFirebirdAPI := nil;
352 tony 45 inherited Destroy;
353     end;
354    
355 tony 263 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 tony 315 begin
363     if (FLibraryList[i] as TFBLibrary).SameLibrary(aLibPathName) then
364 tony 263 begin
365     Result := FLibraryList[i];
366     Exit;
367     end;
368 tony 315 end;
369 tony 263 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 tony 315 function TFBLibrary.SameLibrary(aLibName: string): boolean;
383     begin
384     Result := FRequestedLibName = aLibName;
385     end;
386    
387 tony 263 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 tony 315 GetTZDataSettings;
399 tony 263 end;
400    
401 tony 45 procedure TFBClientAPI.IBAlloc(var P; OldSize, NewSize: Integer);
402     var
403     i: Integer;
404     begin
405     ReallocMem(Pointer(P), NewSize);
406 tony 56 for i := OldSize to NewSize - 1 do PAnsiChar(P)[i] := #0;
407 tony 45 end;
408    
409     procedure TFBClientAPI.IBDataBaseError;
410     begin
411     raise EIBInterBaseError.Create(GetStatus);
412     end;
413    
414 tony 56 procedure TFBClientAPI.EncodeInteger(aValue: integer; len: integer; buffer: PByte);
415 tony 45 begin
416     while len > 0 do
417     begin
418 tony 56 buffer^ := aValue and $FF;
419 tony 45 Inc(buffer);
420     Dec(len);
421     aValue := aValue shr 8;
422     end;
423     end;
424    
425 tony 345 function TFBClientAPI.DecodeInteger(bufptr: PByte; len: short): int64;
426     begin
427     Result := isc_portable_integer(bufptr,len);
428     end;
429    
430 tony 315 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 tony 45 function TFBClientAPI.IsLibraryLoaded: boolean;
456     begin
457 tony 263 Result := FFBLibrary.IBLibrary <> NilHandle;
458 tony 45 end;
459    
460 tony 263 function TFBClientAPI.GetFBLibrary: IFirebirdLibrary;
461     begin
462     Result := FFBLibrary;
463     end;
464    
465 tony 315 function TFBClientAPI.FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
466 tony 308 begin
467 tony 315 {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 tony 308 end;
474    
475 tony 315 {$IFDEF UNIX}
476 tony 359
477 tony 315 procedure TFBClientAPI.GetTZDataSettings;
478     var S: TStringList;
479     begin
480     FLocalTimeOffset := GetLocalTimeOffset;
481 tony 359 {$if declared(Gettzname)}
482     FLocalTimeZoneName := Gettzname(tzdaylight);
483     {$else}
484     FLocalTimeZoneName := tzname[tzdaylight];
485     {$ifend}
486 tony 315 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 tony 56 function TFBClientAPI.GetProcAddr(ProcName: PAnsiChar): Pointer;
529 tony 45 begin
530 tony 347 Result := nil;
531     if assigned(FFBLibrary) and (FFBLibrary.IBLibrary <> NilHandle) then
532     Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
533 tony 45 if not Assigned(Result) then
534     raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
535     end;
536    
537 tony 315 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 tony 263 function TFBClientAPI.LoadInterface: boolean;
568 tony 45 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 tony 345 isc_portable_integer := GetProcAddr('isc_portable_integer'); {do not localize}
575 tony 315 fb_shutdown := GetProcAddr('fb_shutdown'); {do not localize}
576 tony 263 Result := assigned(isc_free);
577 tony 45 end;
578    
579 tony 315 procedure TFBClientAPI.FBShutdown;
580     begin
581     if assigned(fb_shutdown) then
582     fb_shutdown(0,fb_shutrsn_exit_called);
583     end;
584    
585 tony 45 { TFBStatus }
586    
587 tony 345 constructor TFBStatus.Create(aOwner: TFBClientAPI; prefix: AnsiString);
588 tony 45 begin
589     inherited Create;
590     FOwner := aOwner;
591 tony 345 FPrefix := prefix;
592     FIBDataBaseErrorMessages := [ShowSQLCode, ShowSQLMessage, ShowIBMessage];
593 tony 45 end;
594    
595 tony 345 function TFBStatus.GetIBErrorCode: TStatusCode;
596 tony 45 begin
597     Result := StatusVector^[1];
598     end;
599    
600 tony 345 function TFBStatus.Getsqlcode: TStatusCode;
601 tony 45 begin
602     with FOwner do
603     Result := isc_sqlcode(PISC_STATUS(StatusVector));
604     end;
605    
606 tony 56 function TFBStatus.GetMessage: AnsiString;
607     var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
608 tony 45 IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
609     sqlcode: Long;
610     begin
611 tony 345 Result := FPrefix;
612 tony 45 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 tony 308 isc_sql_interprete(sqlcode, local_buffer, sizeof(local_buffer));
621 tony 45 if (ShowSQLCode in FIBDataBaseErrorMessages) then
622 tony 345 Result := Result + LineEnding;
623     Result := Result + 'Engine Code: ' + IntToStr(GetIBErrorCode) + ' ' + strpas(local_buffer);
624 tony 45 end;
625    
626     if (ShowIBMessage in IBDataBaseErrorMessages) then
627     begin
628     if (ShowSQLCode in IBDataBaseErrorMessages) or
629     (ShowSQLMessage in IBDataBaseErrorMessages) then
630 tony 308 Result := Result + LineEnding;
631 tony 315 Result := Result + FOwner.FormatStatus(self);
632 tony 45 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 tony 56 p := PISC_STATUS(PAnsiChar(p) + (i * SizeOf(ISC_STATUS)));
645 tony 45 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 tony 56 EnterCriticalSection(TFBClientAPI.FIBCS);
671 tony 45 try
672     result := FIBDataBaseErrorMessages;
673     finally
674 tony 56 LeaveCriticalSection(TFBClientAPI.FIBCS);
675 tony 45 end;
676     end;
677    
678     procedure TFBStatus.SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
679     begin
680 tony 56 EnterCriticalSection(TFBClientAPI.FIBCS);
681 tony 45 try
682     FIBDataBaseErrorMessages := Value;
683     finally
684 tony 56 LeaveCriticalSection(TFBClientAPI.FIBCS);
685 tony 45 end;
686     end;
687 tony 60
688 tony 45 initialization
689 tony 263 TFBLibrary.FEnvSetupDone := false;
690 tony 56 {$IFNDEF FPC}
691     InitializeCriticalSection(TFBClientAPI.FIBCS);
692     {$ELSE}
693     InitCriticalSection(TFBClientAPI.FIBCS);
694     {$ENDIF}
695 tony 45
696     finalization
697 tony 263 TFBLibrary.FreeLibraries;
698 tony 56 {$IFNDEF FPC}
699     DeleteCriticalSection(TFBClientAPI.FIBCS);
700     {$ELSE}
701     DoneCriticalSection(TFBClientAPI.FIBCS);
702     {$ENDIF}
703 tony 45 end.
704