ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/client/FBClientAPI.pas
Revision: 379
Committed: Mon Jan 10 10:08:03 2022 UTC (2 years, 10 months ago) by tony
Content type: text/x-pascal
File size: 21588 byte(s)
Log Message:
set line ending property

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 tony 371 function GetIBMessage: Ansistring; virtual; abstract;
125     function GetSQLMessage: Ansistring;
126 tony 45 public
127 tony 345 constructor Create(aOwner: TFBClientAPI; prefix: AnsiString='');
128 tony 45 function StatusVector: PStatusVector; virtual; abstract;
129    
130     {IStatus}
131 tony 345 function GetIBErrorCode: TStatusCode;
132     function Getsqlcode: TStatusCode;
133 tony 56 function GetMessage: AnsiString;
134 tony 45 function CheckStatusVector(ErrorCodes: array of TFBStatusCode): Boolean;
135     function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
136     procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
137     end;
138    
139 tony 263 { TFBLibrary }
140    
141     TFBLibrary = class(TFBInterfacedObject,IFirebirdLibrary)
142     private
143     class var FEnvSetupDone: boolean;
144     class var FLibraryList: array of IFirebirdLibrary;
145 tony 315 private
146 tony 263 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 tony 315 function SameLibrary(aLibName: string): boolean;
164 tony 263
165 tony 315 public
166 tony 263 {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 tony 45 { TFBClientAPI }
175    
176     TFBClientAPI = class(TFBInterfacedObject)
177     private
178 tony 315 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 tony 56 class var FIBCS: TRTLCriticalSection;
183 tony 315 function FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
184     procedure GetTZDataSettings;
185 tony 45 protected
186 tony 263 FFBLibrary: TFBLibrary;
187 tony 56 function GetProcAddr(ProcName: PAnsiChar): Pointer;
188 tony 315
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 tony 45 public
198     {Taken from legacy API}
199 tony 371 isc_sql_interprete: Tisc_sql_interprete;
200 tony 45 isc_sqlcode: Tisc_sqlcode;
201    
202 tony 263 constructor Create(aFBLibrary: TFBLibrary);
203 tony 45 procedure IBAlloc(var P; OldSize, NewSize: Integer);
204     procedure IBDataBaseError;
205 tony 263 function LoadInterface: boolean; virtual;
206 tony 315 procedure FBShutdown; virtual;
207 tony 263 function GetAPI: IFirebirdAPI; virtual; abstract;
208     {$IFDEF UNIX}
209     function GetFirebirdLibList: string; virtual; abstract;
210     {$ENDIF}
211 tony 315 function HasDecFloatSupport: boolean;
212     function HasInt128Support: boolean; virtual;
213     function HasLocalTZDB: boolean; virtual;
214     function HasExtendedTZSupport: boolean; virtual;
215     function HasTimeZoneSupport: boolean; virtual;
216 tony 45
217 tony 315 public
218     property LocalTimeZoneName: AnsiString read FLocalTimeZoneName;
219     property TZDataTimeZoneID: AnsiString read FTZDataTimeZoneID;
220     property LocalTimeOffset: integer read FLocalTimeOffset;
221     public
222 tony 45 {Encode/Decode}
223 tony 371 procedure EncodeInteger(aValue: int64; len: integer; buffer: PByte);
224 tony 345 function DecodeInteger(bufptr: PByte; len: short): int64;
225 tony 315 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 tony 56 function SQLDecodeTime(bufptr: PByte): TDateTime; virtual; abstract;
229     procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte); virtual; abstract;
230 tony 315 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 tony 45
237     {IFirebirdAPI}
238     function GetStatus: IStatus; virtual; abstract;
239     function IsLibraryLoaded: boolean;
240     function IsEmbeddedServer: boolean; virtual; abstract;
241 tony 263 function GetFBLibrary: IFirebirdLibrary;
242 tony 308 function GetImplementationVersion: AnsiString;
243     function GetClientMajor: integer; virtual; abstract;
244     function GetClientMinor: integer; virtual; abstract;
245 tony 363 end;
246 tony 45
247 tony 363 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 tony 45 implementation
256    
257 tony 263 uses IBUtils, Registry,
258 tony 315 {$IFDEF Unix} unix, initc, dl, {$ENDIF}
259 tony 56 {$IFDEF FPC}
260 tony 45 {$IFDEF WINDOWS }
261 tony 56 WinDirs,
262 tony 45 {$ENDIF}
263 tony 56 {$ELSE}
264     ShlObj,
265     {$ENDIF}
266 tony 45 SysUtils;
267    
268     {$IFDEF UNIX}
269 tony 56 {$I 'include/uloadlibrary.inc'}
270 tony 45 {$ELSE}
271 tony 56 {$I 'include/wloadlibrary.inc'}
272 tony 45 {$ENDIF}
273    
274 tony 263
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 tony 45 begin
284 tony 263 if assigned(OnGetLibraryName) then
285     OnGetLibraryName(Result)
286 tony 45 end;
287 tony 263 end;
288 tony 45
289 tony 263 procedure TFBLibrary.FreeFBLibrary;
290     begin
291 tony 315 (FFirebirdAPI as TFBClientAPI).FBShutdown;
292 tony 263 if FIBLibrary <> NilHandle then
293     FreeLibrary(FIBLibrary);
294     FIBLibrary := NilHandle;
295 tony 315 FFBLibraryName := '';
296 tony 263 end;
297 tony 45
298 tony 263 function TFBLibrary.GetLibraryName: string;
299 tony 45 begin
300 tony 263 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 tony 45 inherited Create;
311 tony 263 SetupEnvironment;
312     FFBLibraryName := aLibPathName;
313     FIBLibrary := NilHandle;
314     FFirebirdAPI := GetFirebird3API;
315     FRequestedLibName := aLibPathName;
316     if aLibPathName <> '' then
317 tony 45 begin
318 tony 263 SetLength(FLibraryList,Length(FLibraryList)+1);
319     FLibraryList[Length(FLibraryList)-1] := self;
320 tony 45 end;
321 tony 263 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 tony 45 end;
344    
345 tony 263 destructor TFBLibrary.Destroy;
346 tony 45 begin
347 tony 315 FreeFBLibrary;
348 tony 263 FFirebirdAPI := nil;
349 tony 45 inherited Destroy;
350     end;
351    
352 tony 263 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 tony 315 begin
360     if (FLibraryList[i] as TFBLibrary).SameLibrary(aLibPathName) then
361 tony 263 begin
362     Result := FLibraryList[i];
363     Exit;
364     end;
365 tony 315 end;
366 tony 263 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 tony 315 function TFBLibrary.SameLibrary(aLibName: string): boolean;
380     begin
381     Result := FRequestedLibName = aLibName;
382     end;
383    
384 tony 263 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 tony 315 GetTZDataSettings;
396 tony 263 end;
397    
398 tony 45 procedure TFBClientAPI.IBAlloc(var P; OldSize, NewSize: Integer);
399     var
400     i: Integer;
401     begin
402     ReallocMem(Pointer(P), NewSize);
403 tony 56 for i := OldSize to NewSize - 1 do PAnsiChar(P)[i] := #0;
404 tony 45 end;
405    
406     procedure TFBClientAPI.IBDataBaseError;
407     begin
408     raise EIBInterBaseError.Create(GetStatus);
409     end;
410    
411 tony 371 procedure TFBClientAPI.EncodeInteger(aValue: int64; len: integer; buffer: PByte);
412 tony 45 begin
413     while len > 0 do
414     begin
415 tony 56 buffer^ := aValue and $FF;
416 tony 45 Inc(buffer);
417     Dec(len);
418     aValue := aValue shr 8;
419     end;
420     end;
421    
422 tony 371 (*
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 tony 345 function TFBClientAPI.DecodeInteger(bufptr: PByte; len: short): int64;
444 tony 371 var shift: integer;
445 tony 345 begin
446 tony 371 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 tony 345 end;
461    
462 tony 315 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 tony 45 function TFBClientAPI.IsLibraryLoaded: boolean;
488     begin
489 tony 263 Result := FFBLibrary.IBLibrary <> NilHandle;
490 tony 45 end;
491    
492 tony 263 function TFBClientAPI.GetFBLibrary: IFirebirdLibrary;
493     begin
494     Result := FFBLibrary;
495     end;
496    
497 tony 315 function TFBClientAPI.FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
498 tony 308 begin
499 tony 315 {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 tony 308 end;
506    
507 tony 315 {$IFDEF UNIX}
508 tony 359
509 tony 315 procedure TFBClientAPI.GetTZDataSettings;
510     var S: TStringList;
511     begin
512     FLocalTimeOffset := GetLocalTimeOffset;
513 tony 359 {$if declared(Gettzname)}
514     FLocalTimeZoneName := Gettzname(tzdaylight);
515     {$else}
516     FLocalTimeZoneName := tzname[tzdaylight];
517     {$ifend}
518 tony 315 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 tony 56 function TFBClientAPI.GetProcAddr(ProcName: PAnsiChar): Pointer;
561 tony 45 begin
562 tony 347 Result := nil;
563     if assigned(FFBLibrary) and (FFBLibrary.IBLibrary <> NilHandle) then
564     Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
565 tony 45 if not Assigned(Result) then
566     raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
567     end;
568    
569 tony 315 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 tony 263 function TFBClientAPI.LoadInterface: boolean;
600 tony 45 begin
601     isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
602     isc_sql_interprete := GetProcAddr('isc_sql_interprete'); {do not localize}
603 tony 315 fb_shutdown := GetProcAddr('fb_shutdown'); {do not localize}
604 tony 371 Result := true; {don't case if these fail to load}
605 tony 45 end;
606    
607 tony 315 procedure TFBClientAPI.FBShutdown;
608     begin
609     if assigned(fb_shutdown) then
610     fb_shutdown(0,fb_shutrsn_exit_called);
611     end;
612    
613 tony 45 { TFBStatus }
614    
615 tony 371 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 tony 345 constructor TFBStatus.Create(aOwner: TFBClientAPI; prefix: AnsiString);
627 tony 45 begin
628     inherited Create;
629     FOwner := aOwner;
630 tony 345 FPrefix := prefix;
631     FIBDataBaseErrorMessages := [ShowSQLCode, ShowSQLMessage, ShowIBMessage];
632 tony 45 end;
633    
634 tony 345 function TFBStatus.GetIBErrorCode: TStatusCode;
635 tony 45 begin
636     Result := StatusVector^[1];
637     end;
638    
639 tony 345 function TFBStatus.Getsqlcode: TStatusCode;
640 tony 45 begin
641 tony 371 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 tony 45 end;
646    
647 tony 56 function TFBStatus.GetMessage: AnsiString;
648 tony 371 var IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
649 tony 45 begin
650 tony 345 Result := FPrefix;
651 tony 45 IBDataBaseErrorMessages := FIBDataBaseErrorMessages;
652     if (ShowSQLCode in IBDataBaseErrorMessages) then
653 tony 371 Result := Result + 'SQLCODE: ' + IntToStr(Getsqlcode); {do not localize}
654 tony 45
655 tony 371 if [ShowSQLMessage, ShowIBMessage]*IBDataBaseErrorMessages <> [] then
656 tony 45 begin
657     if (ShowSQLCode in FIBDataBaseErrorMessages) then
658 tony 345 Result := Result + LineEnding;
659 tony 371 Result := Result + 'Engine Code: ' + IntToStr(GetIBErrorCode) + ' ';
660 tony 45 end;
661    
662 tony 371 if (ShowSQLMessage in IBDataBaseErrorMessages) then
663     Result := Result + GetSQLMessage;
664    
665 tony 45 if (ShowIBMessage in IBDataBaseErrorMessages) then
666     begin
667 tony 371 if ShowSQLMessage in IBDataBaseErrorMessages then
668 tony 308 Result := Result + LineEnding;
669 tony 371 Result := Result + GetIBMessage;
670 tony 45 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 tony 56 p := PISC_STATUS(PAnsiChar(p) + (i * SizeOf(ISC_STATUS)));
683 tony 45 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 tony 56 EnterCriticalSection(TFBClientAPI.FIBCS);
709 tony 45 try
710     result := FIBDataBaseErrorMessages;
711     finally
712 tony 56 LeaveCriticalSection(TFBClientAPI.FIBCS);
713 tony 45 end;
714     end;
715    
716     procedure TFBStatus.SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
717     begin
718 tony 56 EnterCriticalSection(TFBClientAPI.FIBCS);
719 tony 45 try
720     FIBDataBaseErrorMessages := Value;
721     finally
722 tony 56 LeaveCriticalSection(TFBClientAPI.FIBCS);
723 tony 45 end;
724     end;
725 tony 60
726 tony 45 initialization
727 tony 263 TFBLibrary.FEnvSetupDone := false;
728 tony 56 {$IFNDEF FPC}
729     InitializeCriticalSection(TFBClientAPI.FIBCS);
730     {$ELSE}
731     InitCriticalSection(TFBClientAPI.FIBCS);
732     {$ENDIF}
733 tony 45
734     finalization
735 tony 263 TFBLibrary.FreeLibraries;
736 tony 56 {$IFNDEF FPC}
737     DeleteCriticalSection(TFBClientAPI.FIBCS);
738     {$ELSE}
739     DoneCriticalSection(TFBClientAPI.FIBCS);
740     {$ENDIF}
741 tony 45 end.
742    

Properties

Name Value
svn:eol-style native