ViewVC Help

View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing

root/public/ibx/branches/udr/client/FBClientAPI.pas

Comparing:
ibx/trunk/fbintf/client/FBClientAPI.pas (file contents), Revision 60 by tony, Mon Mar 27 15:21:02 2017 UTC vs.
ibx/branches/udr/client/FBClientAPI.pas (file contents), Revision 387 by tony, Wed Jan 19 13:34:42 2022 UTC

#	Line 76 | Line 76 | uses
76		Classes,
77		{$IFDEF WINDOWS}Windows, {$ENDIF}
78		{$IFDEF FPC} Dynlibs, {$ENDIF}
79	<	IB, IBHeader, FBActivityMonitor, FBMessages, IBExternals;
79	>	IB, IBHeader, FBActivityMonitor, FBMessages, IBExternals, FmtBCD;
80
81	<	{For Linux see result of GetFirebirdLibList method}
81	>	{For Linux see result of GetFirebirdLibListruntime/nongui/winipc.inc method}
82		{$IFDEF DARWIN}
83		const
84		FIREBIRD_SO2 = 'libfbclient.dylib';
#	Line 90 | Line 90 | FIREBIRD_CLIENT = 'fbclient.dll'; {do no
90		FIREBIRD_EMBEDDED = 'fbembed.dll';
91		{$ENDIF}
92
93	<	{$IFNDEF FPC}
94	<	type
95	<	TLibHandle = THandle;
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	<	NilHandle = 0;
104	<	DirectorySeparator = '\';
105	<	{$ENDIF}
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;
#	Line 107 | Line 115 | type
115
116		{ TFBStatus }
117
118	<	TFBStatus = class(TFBInterfacedObject)
118	>	TFBStatus = class(TFBInterfacedObject, IStatus)
119		private
120		FIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
121	+	FPrefix: AnsiString;
122	+	function SQLCodeSupported: boolean;
123		protected
124		FOwner: TFBClientAPI;
125	+	function GetIBMessage: Ansistring; virtual; abstract;
126	+	function GetSQLMessage: Ansistring;
127		public
128	<	constructor Create(aOwner: TFBClientAPI);
128	>	constructor Create(aOwner: TFBClientAPI; prefix: AnsiString='');
129		function StatusVector: PStatusVector; virtual; abstract;
130	+	procedure Assign(src: TFBStatus); virtual;
131	+	function Clone: IStatus; virtual; abstract;
132
133		{IStatus}
134	<	function GetIBErrorCode: Long;
135	<	function Getsqlcode: Long;
134	>	function GetIBErrorCode: TStatusCode;
135	>	function Getsqlcode: TStatusCode;
136		function GetMessage: AnsiString;
137		function CheckStatusVector(ErrorCodes: array of TFBStatusCode): Boolean;
138		function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
139		procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
140		end;
141
142	+	{ TFBLibrary }
143	+
144	+	TFBLibrary = class(TFBInterfacedObject,IFirebirdLibrary)
145	+	private
146	+	class var FEnvSetupDone: boolean;
147	+	class var FLibraryList: array of IFirebirdLibrary;
148	+	private
149	+	FFirebirdAPI: IFirebirdAPI;
150	+	FRequestedLibName: string;
151	+	function LoadIBLibrary: boolean;
152	+	protected
153	+	FFBLibraryName: string;
154	+	FIBLibrary: TLibHandle;
155	+	procedure FreeFBLibrary;
156	+	function GetOverrideLibName: string;
157	+	class procedure SetupEnvironment;
158	+	protected
159	+	function GetFirebird3API: IFirebirdAPI; virtual; abstract;
160	+	function GetLegacyFirebirdAPI: IFirebirdAPI; virtual; abstract;
161	+	public
162	+	constructor Create(aLibPathName: string='');
163	+	destructor Destroy; override;
164	+	class function GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
165	+	class procedure FreeLibraries;
166	+	function SameLibrary(aLibName: string): boolean;
167	+
168	+	public
169	+	{IFirebirdLibrary}
170	+	function GetHandle: TLibHandle;
171	+	function GetLibraryName: string;
172	+	function GetLibraryFilePath: string;
173	+	function GetFirebirdAPI: IFirebirdAPI;
174	+	property IBLibrary: TLibHandle read FIBLibrary;
175	+	end;
176	+
177		{ TFBClientAPI }
178
179		TFBClientAPI = class(TFBInterfacedObject)
180		private
181	<	FOwnsIBLibrary: boolean;
181	>	FLocalTimeZoneName: AnsiString; {Informal Time Zone Name from tzname e.g. GMT or BST}
182	>	FTZDataTimeZoneID: AnsiString; {TZData DB ID e.g. Europe/London}
183	>	FLocalTimeOffset: integer;
184	>	FIsDaylightSavingsTime: boolean;
185		class var FIBCS: TRTLCriticalSection;
186	<	procedure LoadIBLibrary;
186	>	function FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
187	>	procedure GetTZDataSettings;
188		protected
189	<	class var FFBLibraryName: string;
137	<	class var IBLibrary: TLibHandle;
138	<	{$IFDEF WINDOWS}
139	<	class var FFBLibraryPath: string;
140	<	{$ENDIF}
189	>	FFBLibrary: TFBLibrary;
190		function GetProcAddr(ProcName: PAnsiChar): Pointer;
191	<	function GetOverrideLibName: string;
192	<	{$IFDEF UNIX}
193	<	function GetFirebirdLibList: string; virtual; abstract;
194	<	{$ENDIF}
195	<	procedure LoadInterface; virtual;
191	>
192	>	protected type
193	>	Tfb_shutdown = function (timeout: uint;
194	>	const reason: int): int;
195	>	{$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
196	>	protected
197	>	{FB Shutdown API}
198	>	fb_shutdown: Tfb_shutdown;
199	>
200		public
201		{Taken from legacy API}
149	–	isc_sqlcode: Tisc_sqlcode;
202		isc_sql_interprete: Tisc_sql_interprete;
203	<	isc_interprete: Tisc_interprete;
152	<	isc_event_counts: Tisc_event_counts;
153	<	isc_event_block: Tisc_event_block;
154	<	isc_free: Tisc_free;
203	>	isc_sqlcode: Tisc_sqlcode;
204
205	<	constructor Create;
157	<	destructor Destroy; override;
205	>	constructor Create(aFBLibrary: TFBLibrary);
206		procedure IBAlloc(var P; OldSize, NewSize: Integer);
207		procedure IBDataBaseError;
208	<	procedure SetupEnvironment;
208	>	function LoadInterface: boolean; virtual;
209	>	procedure FBShutdown; virtual;
210	>	function GetAPI: IFirebirdAPI; virtual; abstract;
211	>	{$IFDEF UNIX}
212	>	function GetFirebirdLibList: string; virtual; abstract;
213	>	{$ENDIF}
214	>	function HasDecFloatSupport: boolean;
215	>	function HasInt128Support: boolean; virtual;
216	>	function HasLocalTZDB: boolean; virtual;
217	>	function HasExtendedTZSupport: boolean; virtual;
218	>	function HasTimeZoneSupport: boolean; virtual;
219
220	+	public
221	+	property LocalTimeZoneName: AnsiString read FLocalTimeZoneName;
222	+	property TZDataTimeZoneID: AnsiString read FTZDataTimeZoneID;
223	+	property LocalTimeOffset: integer read FLocalTimeOffset;
224	+	public
225		{Encode/Decode}
226	<	procedure EncodeInteger(aValue: integer; len: integer; buffer: PByte);
227	<	function DecodeInteger(bufptr: PByte; len: short): integer; virtual; abstract;
228	<	procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte); virtual; abstract;
229	<	function SQLDecodeDate(byfptr: PByte): TDateTime; virtual; abstract;
230	<	procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte); virtual; abstract;
226	>	procedure EncodeInteger(aValue: int64; len: integer; buffer: PByte);
227	>	function DecodeInteger(bufptr: PByte; len: short): int64;
228	>	procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte);  virtual; abstract;
229	>	function SQLDecodeDate(byfptr: PByte): TDateTime;  virtual; abstract;
230	>	procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte);  virtual; abstract;
231		function SQLDecodeTime(bufptr: PByte): TDateTime;  virtual; abstract;
232		procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte); virtual; abstract;
233	<	function SQLDecodeDateTime(bufptr: PByte): TDateTime; virtual; abstract;
234	<
233	>	function  SQLDecodeDateTime(bufptr: PByte): TDateTime; virtual; abstract;
234	>	function Int128ToStr(bufptr: PByte; scale: integer): AnsiString; virtual;
235	>	procedure StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte);
236	>	virtual;
237	>	procedure SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal; bufptr: PByte); virtual;
238	>	function SQLDecFloatDecode(SQLType: cardinal;  bufptr: PByte): tBCD; virtual;
239
240		{IFirebirdAPI}
241		function GetStatus: IStatus; virtual; abstract;
242		function IsLibraryLoaded: boolean;
243		function IsEmbeddedServer: boolean; virtual; abstract;
244	<	function GetLibraryName: string;
245	<	end;
244	>	function GetFBLibrary: IFirebirdLibrary;
245	>	function GetImplementationVersion: AnsiString;
246	>	function GetClientMajor: integer;  virtual; abstract;
247	>	function GetClientMinor: integer;  virtual; abstract;
248	>	end;
249
250	<	var FirebirdClientAPI: TFBClientAPI = nil;
250	>	IJournallingHook = interface
251	>	['{7d3e45e0-3628-416a-9e22-c20474825031}']
252	>	procedure TransactionStart(Tr: ITransaction);
253	>	function TransactionEnd(TransactionID: integer; Completion: TTrCompletionState): boolean;
254	>	procedure TransactionRetained(Tr: ITransaction; OldTransactionID: integer; Action: TTransactionAction);
255	>	procedure ExecQuery(Stmt: IStatement);
256	>	procedure ExecImmediateJnl(sql: AnsiString; tr: ITransaction);
257	>	end;
258
259		implementation
260
261	<	uses IBUtils, Registry, {$IFDEF Unix} initc, {$ENDIF}
261	>	uses IBUtils, Registry,
262	>	{$IFDEF Unix} unix, initc, dl, {$ENDIF}
263		{$IFDEF FPC}
264		{$IFDEF WINDOWS }
265		WinDirs,
#	Line 197 | Line 275 | SysUtils;
275		{$I 'include/wloadlibrary.inc'}
276		{$ENDIF}
277
278	<	{$IFDEF Unix}
279	<	{SetEnvironmentVariable doesn't exist so we have to use C Library}
280	<	function setenv(name:Pchar; value:Pchar; replace:integer):integer;cdecl;external clib name 'setenv';
281	<	function unsetenv(name:Pchar):integer;cdecl;external clib name 'unsetenv';
282	<	function SetEnvironmentVariable(name:PAnsiChar; value:PAnsiChar):boolean;
283	<	// Set environment variable; if empty string given, remove it.
278	>
279	>	{ TFBLibrary }
280	>
281	>	function TFBLibrary.GetOverrideLibName: string;
282	>	begin
283	>	Result := FFBLibraryName;
284	>	if (Result = '') and AllowUseOfFBLIB then
285	>	Result := GetEnvironmentVariable('FBLIB');
286	>	if Result = '' then
287		begin
288	<	result:=false; //assume failure
289	<	if value = '' then
209	<	begin
210	<	// Assume user wants to remove variable.
211	<	if unsetenv(name)=0 then result:=true;
212	<	end
213	<	else
214	<	begin
215	<	// Non empty so set the variable
216	<	if setenv(name, value, 1)=0 then result:=true;
217	<	end;
288	>	if assigned(OnGetLibraryName) then
289	>	OnGetLibraryName(Result)
290		end;
291	<	{$ENDIF}
291	>	end;
292
293	<	{ TFBClientAPI }
293	>	procedure TFBLibrary.FreeFBLibrary;
294	>	begin
295	>	(FFirebirdAPI as TFBClientAPI).FBShutdown;
296	>	if FIBLibrary <> NilHandle then
297	>	FreeLibrary(FIBLibrary);
298	>	FIBLibrary := NilHandle;
299	>	FFBLibraryName := '';
300	>	end;
301
302	<	constructor TFBClientAPI.Create;
302	>	function TFBLibrary.GetLibraryName: string;
303	>	begin
304	>	Result := ExtractFileName(FFBLibraryName);
305	>	end;
306	>
307	>	function TFBLibrary.GetFirebirdAPI: IFirebirdAPI;
308	>	begin
309	>	Result := FFirebirdAPI;
310	>	end;
311	>
312	>	constructor TFBLibrary.Create(aLibPathName: string);
313		begin
314		inherited Create;
315	<	LoadIBLibrary;
316	<	if (IBLibrary <> NilHandle) then
315	>	SetupEnvironment;
316	>	FFBLibraryName := aLibPathName;
317	>	FIBLibrary := NilHandle;
318	>	FFirebirdAPI := GetFirebird3API;
319	>	FRequestedLibName := aLibPathName;
320	>	if aLibPathName <> '' then
321	>	begin
322	>	SetLength(FLibraryList,Length(FLibraryList)+1);
323	>	FLibraryList[Length(FLibraryList)-1] := self;
324	>	end;
325	>	if FFirebirdAPI <> nil then
326		begin
327	<	SetupEnvironment;
328	<	LoadInterface;
327	>	{First try Firebird 3}
328	>	if not LoadIBLibrary or not (FFirebirdAPI as TFBClientAPI).LoadInterface then
329	>	FFirebirdAPI := nil;
330		end;
331	<	FirebirdClientAPI := self;
331	>
332	>	if FFirebirdAPI = nil then
333	>	begin
334	>	{now try Firebird 2.5. Under Unix we need to reload the library in case we
335	>	are to use the embedded library}
336	>	FFirebirdAPI := GetLegacyFirebirdAPI;
337	>	if FFirebirdAPI <> nil then
338	>	begin
339	>	{$IFDEF UNIX}
340	>	FreeFBLibrary;
341	>	{$ENDIF}
342	>	if not LoadIBLibrary or not (FFirebirdAPI as TFBClientAPI).LoadInterface then
343	>	FFirebirdAPI := nil;
344	>	end;
345	>	end;
346	>	{Note: FFirebirdAPI will be set to nil if the Firebird API fails to load}
347		end;
348
349	<	destructor TFBClientAPI.Destroy;
349	>	destructor TFBLibrary.Destroy;
350		begin
351	<	FirebirdClientAPI := nil;
352	<	if FOwnsIBLibrary and (IBLibrary <> NilHandle) then
239	<	FreeLibrary(IBLibrary);
240	<	IBLibrary := NilHandle;
351	>	FreeFBLibrary;
352	>	FFirebirdAPI := nil;
353		inherited Destroy;
354		end;
355
356	+	class function TFBLibrary.GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
357	+	var i: integer;
358	+	begin
359	+	Result := nil;
360	+	if aLibPathName <> '' then
361	+	begin
362	+	for i := 0 to Length(FLibraryList) - 1 do
363	+	begin
364	+	if (FLibraryList[i] as TFBLibrary).SameLibrary(aLibPathName) then
365	+	begin
366	+	Result := FLibraryList[i];
367	+	Exit;
368	+	end;
369	+	end;
370	+	Result := Create(aLibPathName);
371	+	end;
372	+
373	+	end;
374	+
375	+	class procedure TFBLibrary.FreeLibraries;
376	+	var i: integer;
377	+	begin
378	+	for i := 0 to Length(FLibraryList) - 1 do
379	+	FLibraryList[i] := nil;
380	+	SetLength(FLibraryList,0);
381	+	end;
382	+
383	+	function TFBLibrary.SameLibrary(aLibName: string): boolean;
384	+	begin
385	+	Result := FRequestedLibName = aLibName;
386	+	end;
387	+
388	+	function TFBLibrary.GetHandle: TLibHandle;
389	+	begin
390	+	Result := FIBLibrary;
391	+	end;
392	+
393	+	{ TFBClientAPI }
394	+
395	+	constructor TFBClientAPI.Create(aFBLibrary: TFBLibrary);
396	+	begin
397	+	inherited Create;
398	+	FFBLibrary := aFBLibrary;
399	+	GetTZDataSettings;
400	+	end;
401	+
402		procedure TFBClientAPI.IBAlloc(var P; OldSize, NewSize: Integer);
403		var
404		i: Integer;
#	Line 254 | Line 412 | begin
412		raise EIBInterBaseError.Create(GetStatus);
413		end;
414
415	<	{Under Unixes, if using an embedded server then set up local TMP and LOCK Directories}
258	<
259	<	procedure TFBClientAPI.SetupEnvironment;
260	<	var TmpDir: AnsiString;
261	<	begin
262	<	{$IFDEF UNIX}
263	<	TmpDir := GetTempDir +
264	<	DirectorySeparator + 'firebird_' + sysutils.GetEnvironmentVariable('USER');
265	<	if sysutils.GetEnvironmentVariable('FIREBIRD_TMP') = '' then
266	<	begin
267	<	if not DirectoryExists(tmpDir) then
268	<	mkdir(tmpDir);
269	<	SetEnvironmentVariable('FIREBIRD_TMP',PAnsiChar(TmpDir));
270	<	end;
271	<	if sysutils.GetEnvironmentVariable('FIREBIRD_LOCK') = '' then
272	<	begin
273	<	if not DirectoryExists(tmpDir) then
274	<	mkdir(tmpDir);
275	<	SetEnvironmentVariable('FIREBIRD_LOCK',PAnsiChar(TmpDir));
276	<	end;
277	<	{$ENDIF}
278	<	end;
279	<
280	<	procedure TFBClientAPI.EncodeInteger(aValue: integer; len: integer; buffer: PByte);
415	>	procedure TFBClientAPI.EncodeInteger(aValue: int64; len: integer; buffer: PByte);
416		begin
417		while len > 0 do
418		begin
#	Line 288 | Line 423 | begin
423		end;
424		end;
425
426	+	(*
427	+	DecodeInteger is Translated from
428	+
429	+	SINT64 API_ROUTINE isc_portable_integer(const UCHAR* ptr, SSHORT length)
430	+	if (!ptr || length <= 0 || length > 8)
431	+	return 0;
432	+
433	+	SINT64 value = 0;
434	+	int shift = 0;
435	+
436	+	while (--length > 0)
437	+	{
438	+	value += ((SINT64) *ptr++) << shift;
439	+	shift += 8;
440	+	}
441	+
442	+	value += ((SINT64)(SCHAR) *ptr) << shift;
443	+
444	+	return value;
445	+	*)
446	+
447	+	function TFBClientAPI.DecodeInteger(bufptr: PByte; len: short): int64;
448	+	var shift: integer;
449	+	begin
450	+	Result := 0;
451	+	if (BufPtr = nil) or (len <= 0) or (len > 8) then
452	+	Exit;
453	+
454	+	shift := 0;
455	+	dec(len);
456	+	while len > 0 do
457	+	begin
458	+	Result := Result + (int64(bufptr^) shl shift);
459	+	Inc(bufptr);
460	+	shift := shift + 8;
461	+	dec(len);
462	+	end;
463	+	Result := Result + (int64(bufptr^) shl shift);
464	+	end;
465	+
466	+	function TFBClientAPI.Int128ToStr(bufptr: PByte; scale: integer): AnsiString;
467	+	begin
468	+	if not HasInt128Support then
469	+	IBError(ibxeNotSupported,[]);
470	+	end;
471	+
472	+	procedure TFBClientAPI.StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte);
473	+	begin
474	+	if not HasInt128Support then
475	+	IBError(ibxeNotSupported,[]);
476	+	end;
477	+
478	+	procedure TFBClientAPI.SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal;
479	+	bufptr: PByte);
480	+	begin
481	+	if not HasDecFloatSupport then
482	+	IBError(ibxeNotSupported,[]);
483	+	end;
484	+
485	+	function TFBClientAPI.SQLDecFloatDecode(SQLType: cardinal; bufptr: PByte): tBCD;
486	+	begin
487	+	if not HasDecFloatSupport then
488	+	IBError(ibxeNotSupported,[]);
489	+	end;
490	+
491		function TFBClientAPI.IsLibraryLoaded: boolean;
492		begin
493	<	Result := IBLibrary <> NilHandle;
493	>	Result := FFBLibrary.IBLibrary <> NilHandle;
494	>	end;
495	>
496	>	function TFBClientAPI.GetFBLibrary: IFirebirdLibrary;
497	>	begin
498	>	Result := FFBLibrary;
499	>	end;
500	>
501	>	function TFBClientAPI.FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
502	>	begin
503	>	{aDate/aTime are in TTimestamp format but aTime is decimilliseconds}
504	>	aDate := aDate - DateDelta;
505	>	if aDate < 0 then
506	>	Result := trunc(aDate) - abs(frac(aTime / (MSecsPerDay*10)))
507	>	else
508	>	Result := trunc(aDate) + abs(frac(aTime / (MSecsPerDay*10)));
509	>	end;
510	>
511	>	{$IFDEF UNIX}
512	>
513	>	procedure TFBClientAPI.GetTZDataSettings;
514	>	var S: TStringList;
515	>	begin
516	>	FLocalTimeOffset := GetLocalTimeOffset;
517	>	{$if declared(Gettzname)}
518	>	FLocalTimeZoneName := Gettzname(tzdaylight);
519	>	{$else}
520	>	FLocalTimeZoneName := tzname[tzdaylight];
521	>	{$ifend}
522	>	FIsDaylightSavingsTime := tzdaylight;
523	>	if FileExists(DefaultTimeZoneFile) then
524	>	begin
525	>	S := TStringList.Create;
526	>	try
527	>	S.LoadFromFile(DefaultTimeZoneFile);
528	>	if S.Count > 0 then
529	>	FTZDataTimeZoneID := S[0];
530	>	finally
531	>	S.Free;
532	>	end;
533	>	end;
534	>	end;
535	>	{$ENDIF}
536	>
537	>	{$IFDEF WINDOWS}
538	>	procedure TFBClientAPI.GetTZDataSettings;
539	>	var TZInfo: TTimeZoneInformation;
540	>	begin
541	>	FIsDaylightSavingsTime := false;
542	>	{is there any way of working out the default TZData DB time zone ID under Windows?}
543	>	case GetTimeZoneInformation(TZInfo) of
544	>	TIME_ZONE_ID_UNKNOWN:
545	>	begin
546	>	FLocalTimeZoneName := '';
547	>	FLocalTimeOffset := 0;
548	>	end;
549	>	TIME_ZONE_ID_STANDARD:
550	>	begin
551	>	FLocalTimeZoneName := strpas(PWideChar(@TZInfo.StandardName));
552	>	FLocalTimeOffset := TZInfo.Bias;
553	>	end;
554	>	TIME_ZONE_ID_DAYLIGHT:
555	>	begin
556	>	FLocalTimeZoneName := strpas(PWideChar(@TZInfo.DaylightName));
557	>	FLocalTimeOffset := TZInfo.DayLightBias;
558	>	FIsDaylightSavingsTime := true;
559	>	end;
560	>	end;
561		end;
562	+	{$ENDIF}
563
564		function TFBClientAPI.GetProcAddr(ProcName: PAnsiChar): Pointer;
565		begin
566	<	Result := GetProcAddress(IBLibrary, ProcName);
566	>	Result := nil;
567	>	if assigned(FFBLibrary) and (FFBLibrary.IBLibrary <> NilHandle) then
568	>	Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
569		if not Assigned(Result) then
570		raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
571		end;
572
573	<	function TFBClientAPI.GetOverrideLibName: string;
573	>	function TFBClientAPI.HasDecFloatSupport: boolean;
574		begin
575	<	Result := '';
576	<	if AllowUseOfFBLIB then
577	<	Result := GetEnvironmentVariable('FBLIB');
578	<	if Result = '' then
579	<	begin
580	<	if assigned(OnGetLibraryName) then
581	<	OnGetLibraryName(Result)
582	<	end;
575	>	Result := GetClientMajor >= 4;
576	>	end;
577	>
578	>	function TFBClientAPI.HasInt128Support: boolean;
579	>	begin
580	>	Result := false;
581	>	end;
582	>
583	>	function TFBClientAPI.HasLocalTZDB: boolean;
584	>	begin
585	>	Result := false;
586		end;
587
588	<	procedure TFBClientAPI.LoadInterface;
588	>	function TFBClientAPI.HasExtendedTZSupport: boolean;
589	>	begin
590	>	Result := false;
591	>	end;
592	>
593	>	function TFBClientAPI.HasTimeZoneSupport: boolean;
594	>	begin
595	>	Result := false;
596	>	end;
597	>
598	>	function TFBClientAPI.GetImplementationVersion: AnsiString;
599	>	begin
600	>	Result := Format('%d.%d',[GetClientMajor,GetClientMinor]);
601	>	end;
602	>
603	>	function TFBClientAPI.LoadInterface: boolean;
604		begin
605		isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
606		isc_sql_interprete := GetProcAddr('isc_sql_interprete'); {do not localize}
607	<	isc_interprete := GetProcAddr('isc_interprete'); {do not localize}
608	<	isc_event_counts := GetProcAddr('isc_event_counts'); {do not localize}
321	<	isc_event_block := GetProcAddr('isc_event_block'); {do not localize}
322	<	isc_free := GetProcAddr('isc_free'); {do not localize}
607	>	fb_shutdown := GetProcAddr('fb_shutdown'); {do not localize}
608	>	Result := true; {don't case if these fail to load}
609		end;
610
611	<	function TFBClientAPI.GetLibraryName: string;
611	>	procedure TFBClientAPI.FBShutdown;
612		begin
613	<	Result := FFBLibraryName;
613	>	if assigned(fb_shutdown) then
614	>	fb_shutdown(0,fb_shutrsn_exit_called);
615		end;
616
330	–	const
331	–	IBLocalBufferLength = 512;
332	–	IBBigLocalBufferLength = IBLocalBufferLength * 2;
333	–	IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;
334	–
617		{ TFBStatus }
618
619	<	constructor TFBStatus.Create(aOwner: TFBClientAPI);
619	>	function TFBStatus.SQLCodeSupported: boolean;
620	>	begin
621	>	Result:= (FOwner <> nil) and assigned(FOwner.isc_sqlcode) and  assigned(FOwner.isc_sql_interprete);
622	>	end;
623	>
624	>	function TFBStatus.GetSQLMessage: Ansistring;
625	>	var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
626	>	begin
627	>	Result := '';
628	>	if (FOwner <> nil) and assigned(FOwner.isc_sql_interprete) then
629	>	begin
630	>	FOwner.isc_sql_interprete(Getsqlcode, local_buffer, sizeof(local_buffer));
631	>	Result := strpas(local_buffer);
632	>	end;
633	>	end;
634	>
635	>	constructor TFBStatus.Create(aOwner: TFBClientAPI; prefix: AnsiString);
636		begin
637		inherited Create;
638		FOwner := aOwner;
639	<	FIBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
639	>	FPrefix := prefix;
640	>	FIBDataBaseErrorMessages := [ShowIBMessage];
641	>	end;
642	>
643	>	procedure TFBStatus.Assign(src: TFBStatus);
644	>	begin
645	>	FOwner := src.FOwner;
646	>	FPrefix := src.FPrefix;
647	>	SetIBDataBaseErrorMessages(src.GetIBDataBaseErrorMessages);
648		end;
649
650	<	function TFBStatus.GetIBErrorCode: Long;
650	>	function TFBStatus.GetIBErrorCode: TStatusCode;
651		begin
652		Result := StatusVector^[1];
653		end;
654
655	<	function TFBStatus.Getsqlcode: Long;
655	>	function TFBStatus.Getsqlcode: TStatusCode;
656		begin
657	<	with FOwner do
658	<	Result := isc_sqlcode(PISC_STATUS(StatusVector));
657	>	if (FOwner <> nil) and assigned(FOwner.isc_sqlcode) then
658	>	Result := FOwner.isc_sqlcode(PISC_STATUS(StatusVector))
659	>	else
660	>	Result := -999; {generic SQL Code}
661		end;
662
663		function TFBStatus.GetMessage: AnsiString;
664	<	var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
357	<	IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
358	<	sqlcode: Long;
359	<	psb: PStatusVector;
664	>	var IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
665		begin
666	<	Result := '';
666	>	Result := FPrefix;
667		IBDataBaseErrorMessages := FIBDataBaseErrorMessages;
668	<	sqlcode := Getsqlcode;
669	<	if (ShowSQLCode in IBDataBaseErrorMessages) then
670	<	Result := Result + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
671	<
672	<	Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
673	<	if (ShowSQLMessage in IBDataBaseErrorMessages) then
674	<	begin
675	<	with FOwner do
676	<	isc_sql_interprete(sqlcode, local_buffer, IBLocalBufferLength);
677	<	if (ShowSQLCode in FIBDataBaseErrorMessages) then
678	<	Result := Result + CRLF;
374	<	Result := Result + strpas(local_buffer);
668	>	if SQLCodeSupported then
669	>	begin
670	>	if (ShowSQLCode in IBDataBaseErrorMessages) then
671	>	Result := Result + 'SQLCODE: ' + IntToStr(Getsqlcode); {do not localize}
672	>
673	>	if (ShowSQLMessage in IBDataBaseErrorMessages) then
674	>	begin
675	>	if ShowSQLCode in IBDataBaseErrorMessages then
676	>	Result := Result + LineEnding;
677	>	Result := Result + GetSQLMessage;
678	>	end;
679		end;
680
681		if (ShowIBMessage in IBDataBaseErrorMessages) then
682		begin
683	<	if (ShowSQLCode in IBDataBaseErrorMessages) or
684	<	(ShowSQLMessage in IBDataBaseErrorMessages) then
685	<	Result := Result + CRLF;
382	<	psb := StatusVector;
383	<	with FOwner do
384	<	while (isc_interprete(@local_buffer, @psb) > 0) do
385	<	begin
386	<	if (Result <> '') and (Result[Length(Result)] <> LF) then
387	<	Result := Result + CRLF;
388	<	Result := Result + strpas(local_buffer);
389	<	end;
683	>	if Result <> FPrefix then
684	>	Result := Result + LineEnding;
685	>	Result := Result + 'Engine Code: ' + IntToStr(GetIBErrorCode) + LineEnding + GetIBMessage;
686		end;
687		if (Result <> '') and (Result[Length(Result)] = '.') then
688		Delete(Result, Length(Result), 1);
#	Line 444 | Line 740 | begin
740		end;
741
742		initialization
743	<	TFBClientAPI.IBLibrary := NilHandle;
743	>	TFBLibrary.FEnvSetupDone := false;
744		{$IFNDEF FPC}
745		InitializeCriticalSection(TFBClientAPI.FIBCS);
746		{$ELSE}
#	Line 452 | Line 748 | initialization
748		{$ENDIF}
749
750		finalization
751	+	TFBLibrary.FreeLibraries;
752		{$IFNDEF FPC}
753		DeleteCriticalSection(TFBClientAPI.FIBCS);
754		{$ELSE}
755		DoneCriticalSection(TFBClientAPI.FIBCS);
756		{$ENDIF}
460	–	if TFBClientAPI.IBLibrary <> NilHandle then
461	–	begin
462	–	FreeLibrary(TFBClientAPI.IBLibrary);
463	–	TFBClientAPI.IBLibrary := NilHandle;
464	–	TFBClientAPI.FFBLibraryName := '';
465	–	end;
466	–
757		end.
758

Comparing:
ibx/trunk/fbintf/client/FBClientAPI.pas (property svn:eol-style), Revision 60 by tony, Mon Mar 27 15:21:02 2017 UTC vs.
ibx/branches/udr/client/FBClientAPI.pas (property svn:eol-style), Revision 387 by tony, Wed Jan 19 13:34:42 2022 UTC

#	Line 0 | Line 1
1	+	native

Diff Legend

–	Removed lines
+	Added lines
<	Changed lines
>	Changed lines