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 308 by tony, Sat Jul 18 10:26:30 2020 UTC vs.
ibx/branches/udr/client/FBClientAPI.pas (file contents), Revision 370 by tony, Wed Jan 5 14:59:15 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 91 | Line 91 | FIREBIRD_EMBEDDED = 'fbembed.dll';
91		{$ENDIF}
92
93		const
94	+	{fb_shutdown reasons}
95	+	fb_shutrsn_svc_stopped          = -1;
96	+	fb_shutrsn_no_connection        = -2;
97	+	fb_shutrsn_app_stopped          = -3;
98	+	fb_shutrsn_signal               = -5;
99	+	fb_shutrsn_services             = -6;
100	+	fb_shutrsn_exit_called          = -7;
101	+
102	+	const
103	+	DefaultTimeZoneFile = '/etc/timezone';
104	+
105	+	const
106		IBLocalBufferLength = 512;
107		IBBigLocalBufferLength = IBLocalBufferLength * 2;
108		IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;
#	Line 106 | Line 118 | type
118		TFBStatus = class(TFBInterfacedObject)
119		private
120		FIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
121	+	FPrefix: AnsiString;
122		protected
123		FOwner: TFBClientAPI;
124		public
125	<	constructor Create(aOwner: TFBClientAPI);
125	>	constructor Create(aOwner: TFBClientAPI; prefix: AnsiString='');
126		function StatusVector: PStatusVector; virtual; abstract;
127
128		{IStatus}
129	<	function GetIBErrorCode: Long;
130	<	function Getsqlcode: Long;
129	>	function GetIBErrorCode: TStatusCode;
130	>	function Getsqlcode: TStatusCode;
131		function GetMessage: AnsiString;
132		function CheckStatusVector(ErrorCodes: array of TFBStatusCode): Boolean;
133		function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
#	Line 127 | Line 140 | type
140		private
141		class var FEnvSetupDone: boolean;
142		class var FLibraryList: array of IFirebirdLibrary;
143	+	private
144		FFirebirdAPI: IFirebirdAPI;
145		FRequestedLibName: string;
146		function LoadIBLibrary: boolean;
#	Line 144 | Line 158 | type
158		destructor Destroy; override;
159		class function GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
160		class procedure FreeLibraries;
161	+	function SameLibrary(aLibName: string): boolean;
162
163	+	public
164		{IFirebirdLibrary}
165		function GetHandle: TLibHandle;
166		function GetLibraryName: string;
#	Line 157 | Line 173 | type
173
174		TFBClientAPI = class(TFBInterfacedObject)
175		private
176	+	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		class var FIBCS: TRTLCriticalSection;
181	+	function FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
182	+	procedure GetTZDataSettings;
183		protected
184		FFBLibrary: TFBLibrary;
185		function GetProcAddr(ProcName: PAnsiChar): Pointer;
186	+
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		public
196		{Taken from legacy API}
197		isc_sqlcode: Tisc_sqlcode;
#	Line 168 | Line 199 | type
199		isc_event_counts: Tisc_event_counts;
200		isc_event_block: Tisc_event_block;
201		isc_free: Tisc_free;
202	+	isc_portable_integer: Tisc_portable_integer;
203
204		constructor Create(aFBLibrary: TFBLibrary);
205		procedure IBAlloc(var P; OldSize, NewSize: Integer);
206		procedure IBDataBaseError;
207		function LoadInterface: boolean; virtual;
208	+	procedure FBShutdown; virtual;
209		function GetAPI: IFirebirdAPI; virtual; abstract;
210		{$IFDEF UNIX}
211		function GetFirebirdLibList: string; virtual; abstract;
212		{$ENDIF}
213	+	function HasDecFloatSupport: boolean;
214	+	function HasInt128Support: boolean; virtual;
215	+	function HasLocalTZDB: boolean; virtual;
216	+	function HasExtendedTZSupport: boolean; virtual;
217	+	function HasTimeZoneSupport: boolean; virtual;
218
219	+	public
220	+	property LocalTimeZoneName: AnsiString read FLocalTimeZoneName;
221	+	property TZDataTimeZoneID: AnsiString read FTZDataTimeZoneID;
222	+	property LocalTimeOffset: integer read FLocalTimeOffset;
223	+	public
224		{Encode/Decode}
225		procedure EncodeInteger(aValue: integer; len: integer; buffer: PByte);
226	<	function DecodeInteger(bufptr: PByte; len: short): integer; virtual; abstract;
227	<	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;
226	>	function DecodeInteger(bufptr: PByte; len: short): int64;
227	>	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		function SQLDecodeTime(bufptr: PByte): TDateTime;  virtual; abstract;
231		procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte); virtual; abstract;
232	<	function SQLDecodeDateTime(bufptr: PByte): TDateTime; virtual; abstract;
232	>	function  SQLDecodeDateTime(bufptr: PByte): TDateTime; virtual; abstract;
233		function FormatStatus(Status: TFBStatus): AnsiString; 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;
#	Line 197 | Line 245 | type
245		function GetImplementationVersion: AnsiString;
246		function GetClientMajor: integer;  virtual; abstract;
247		function GetClientMinor: integer;  virtual; abstract;
248	<	end;
248	>	end;
249	>
250	>	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		implementation
259
260		uses IBUtils, Registry,
261	<	{$IFDEF Unix} initc, dl, {$ENDIF}
261	>	{$IFDEF Unix} unix, initc, dl, {$ENDIF}
262		{$IFDEF FPC}
263		{$IFDEF WINDOWS }
264		WinDirs,
#	Line 235 | Line 291 | end;
291
292		procedure TFBLibrary.FreeFBLibrary;
293		begin
294	+	(FFirebirdAPI as TFBClientAPI).FBShutdown;
295		if FIBLibrary <> NilHandle then
296		FreeLibrary(FIBLibrary);
297		FIBLibrary := NilHandle;
298	+	FFBLibraryName := '';
299		end;
300
301		function TFBLibrary.GetLibraryName: string;
#	Line 289 | Line 347 | end;
347
348		destructor TFBLibrary.Destroy;
349		begin
292	–	FFirebirdAPI := nil;
350		FreeFBLibrary;
351	+	FFirebirdAPI := nil;
352		inherited Destroy;
353		end;
354
#	Line 301 | Line 359 | begin
359		if aLibPathName <> '' then
360		begin
361		for i := 0 to Length(FLibraryList) - 1 do
362	<	if (FLibraryList[i] as TFBLibrary).FRequestedLibName = aLibPathName then
362	>	begin
363	>	if (FLibraryList[i] as TFBLibrary).SameLibrary(aLibPathName) then
364		begin
365		Result := FLibraryList[i];
366		Exit;
367		end;
368	+	end;
369		Result := Create(aLibPathName);
370		end;
371
#	Line 319 | Line 379 | begin
379		SetLength(FLibraryList,0);
380		end;
381
382	+	function TFBLibrary.SameLibrary(aLibName: string): boolean;
383	+	begin
384	+	Result := FRequestedLibName = aLibName;
385	+	end;
386	+
387		function TFBLibrary.GetHandle: TLibHandle;
388		begin
389		Result := FIBLibrary;
#	Line 330 | Line 395 | constructor TFBClientAPI.Create(aFBLibra
395		begin
396		inherited Create;
397		FFBLibrary := aFBLibrary;
398	+	GetTZDataSettings;
399		end;
400
401		procedure TFBClientAPI.IBAlloc(var P; OldSize, NewSize: Integer);
#	Line 345 | Line 411 | begin
411		raise EIBInterBaseError.Create(GetStatus);
412		end;
413
348	–	{Under Unixes, if using an embedded server then set up local TMP and LOCK Directories}
349	–
414		procedure TFBClientAPI.EncodeInteger(aValue: integer; len: integer; buffer: PByte);
415		begin
416		while len > 0 do
#	Line 358 | Line 422 | begin
422		end;
423		end;
424
425	+	function TFBClientAPI.DecodeInteger(bufptr: PByte; len: short): int64;
426	+	begin
427	+	Result := isc_portable_integer(bufptr,len);
428	+	end;
429	+
430	+	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		function TFBClientAPI.IsLibraryLoaded: boolean;
456		begin
457		Result := FFBLibrary.IBLibrary <> NilHandle;
#	Line 368 | Line 462 | begin
462		Result := FFBLibrary;
463		end;
464
465	<	function TFBClientAPI.GetImplementationVersion: AnsiString;
465	>	function TFBClientAPI.FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
466		begin
467	<	Result := Format('%d.%d',[GetClientMajor,GetClientMinor]);
467	>	{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	>	end;
474	>
475	>	{$IFDEF UNIX}
476	>
477	>	procedure TFBClientAPI.GetTZDataSettings;
478	>	var S: TStringList;
479	>	begin
480	>	FLocalTimeOffset := GetLocalTimeOffset;
481	>	{$if declared(Gettzname)}
482	>	FLocalTimeZoneName := Gettzname(tzdaylight);
483	>	{$else}
484	>	FLocalTimeZoneName := tzname[tzdaylight];
485	>	{$ifend}
486	>	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		function TFBClientAPI.GetProcAddr(ProcName: PAnsiChar): Pointer;
529		begin
530	<	Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
530	>	Result := nil;
531	>	if assigned(FFBLibrary) and (FFBLibrary.IBLibrary <> NilHandle) then
532	>	Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
533		if not Assigned(Result) then
534		raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
535		end;
536
537	+	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		function TFBClientAPI.LoadInterface: boolean;
568		begin
569		isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
#	Line 387 | Line 571 | begin
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	+	isc_portable_integer := GetProcAddr('isc_portable_integer'); {do not localize}
575	+	fb_shutdown := GetProcAddr('fb_shutdown'); {do not localize}
576		Result := assigned(isc_free);
577		end;
578
579	+	procedure TFBClientAPI.FBShutdown;
580	+	begin
581	+	if assigned(fb_shutdown) then
582	+	fb_shutdown(0,fb_shutrsn_exit_called);
583	+	end;
584	+
585		{ TFBStatus }
586
587	<	constructor TFBStatus.Create(aOwner: TFBClientAPI);
587	>	constructor TFBStatus.Create(aOwner: TFBClientAPI; prefix: AnsiString);
588		begin
589		inherited Create;
590		FOwner := aOwner;
591	<	FIBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
591	>	FPrefix := prefix;
592	>	FIBDataBaseErrorMessages := [ShowSQLCode, ShowSQLMessage, ShowIBMessage];
593		end;
594
595	<	function TFBStatus.GetIBErrorCode: Long;
595	>	function TFBStatus.GetIBErrorCode: TStatusCode;
596		begin
597		Result := StatusVector^[1];
598		end;
599
600	<	function TFBStatus.Getsqlcode: Long;
600	>	function TFBStatus.Getsqlcode: TStatusCode;
601		begin
602		with FOwner do
603		Result := isc_sqlcode(PISC_STATUS(StatusVector));
#	Line 415 | Line 608 | var local_buffer: array[0..IBHugeLocalBu
608		IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
609		sqlcode: Long;
610		begin
611	<	Result := '';
611	>	Result := FPrefix;
612		IBDataBaseErrorMessages := FIBDataBaseErrorMessages;
613		sqlcode := Getsqlcode;
614		if (ShowSQLCode in IBDataBaseErrorMessages) then
615		Result := Result + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
616
424	–	Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
617		if (ShowSQLMessage in IBDataBaseErrorMessages) then
618		begin
619		with FOwner do
620		isc_sql_interprete(sqlcode, local_buffer, sizeof(local_buffer));
621		if (ShowSQLCode in FIBDataBaseErrorMessages) then
622	<	Result := Result + CRLF;
623	<	Result := Result + strpas(local_buffer);
622	>	Result := Result + LineEnding;
623	>	Result := Result + 'Engine Code: ' + IntToStr(GetIBErrorCode) + ' ' + strpas(local_buffer);
624		end;
625
626		if (ShowIBMessage in IBDataBaseErrorMessages) then
#	Line 436 | Line 628 | begin
628		if (ShowSQLCode in IBDataBaseErrorMessages) or
629		(ShowSQLMessage in IBDataBaseErrorMessages) then
630		Result := Result + LineEnding;
631	<	Result := Result + LineEnding + FOwner.FormatStatus(self);
631	>	Result := Result + FOwner.FormatStatus(self);
632		end;
633		if (Result <> '') and (Result[Length(Result)] = '.') then
634		Delete(Result, Length(Result), 1);

Diff Legend

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