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 |
|
|
|