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 385 by tony, Mon Jan 17 15:56:35 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	+	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
131		{IStatus}
132	<	function GetIBErrorCode: Long;
133	<	function Getsqlcode: Long;
132	>	function GetIBErrorCode: TStatusCode;
133	>	function Getsqlcode: TStatusCode;
134		function GetMessage: AnsiString;
135		function CheckStatusVector(ErrorCodes: array of TFBStatusCode): Boolean;
136		function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
#	Line 127 | Line 143 | type
143		private
144		class var FEnvSetupDone: boolean;
145		class var FLibraryList: array of IFirebirdLibrary;
146	+	private
147		FFirebirdAPI: IFirebirdAPI;
148		FRequestedLibName: string;
149		function LoadIBLibrary: boolean;
#	Line 144 | Line 161 | type
161		destructor Destroy; override;
162		class function GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
163		class procedure FreeLibraries;
164	+	function SameLibrary(aLibName: string): boolean;
165
166	+	public
167		{IFirebirdLibrary}
168		function GetHandle: TLibHandle;
169		function GetLibraryName: string;
#	Line 157 | Line 176 | type
176
177		TFBClientAPI = class(TFBInterfacedObject)
178		private
179	+	FLocalTimeZoneName: AnsiString; {Informal Time Zone Name from tzname e.g. GMT or BST}
180	+	FTZDataTimeZoneID: AnsiString; {TZData DB ID e.g. Europe/London}
181	+	FLocalTimeOffset: integer;
182	+	FIsDaylightSavingsTime: boolean;
183		class var FIBCS: TRTLCriticalSection;
184	+	function FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
185	+	procedure GetTZDataSettings;
186		protected
187		FFBLibrary: TFBLibrary;
188		function GetProcAddr(ProcName: PAnsiChar): Pointer;
189	+
190	+	protected type
191	+	Tfb_shutdown = function (timeout: uint;
192	+	const reason: int): int;
193	+	{$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
194	+	protected
195	+	{FB Shutdown API}
196	+	fb_shutdown: Tfb_shutdown;
197	+
198		public
199		{Taken from legacy API}
166	–	isc_sqlcode: Tisc_sqlcode;
200		isc_sql_interprete: Tisc_sql_interprete;
201	<	isc_event_counts: Tisc_event_counts;
169	<	isc_event_block: Tisc_event_block;
170	<	isc_free: Tisc_free;
201	>	isc_sqlcode: Tisc_sqlcode;
202
203		constructor Create(aFBLibrary: TFBLibrary);
204		procedure IBAlloc(var P; OldSize, NewSize: Integer);
205		procedure IBDataBaseError;
206		function LoadInterface: boolean; virtual;
207	+	procedure FBShutdown; virtual;
208		function GetAPI: IFirebirdAPI; virtual; abstract;
209		{$IFDEF UNIX}
210		function GetFirebirdLibList: string; virtual; abstract;
211		{$ENDIF}
212	+	function HasDecFloatSupport: boolean;
213	+	function HasInt128Support: boolean; virtual;
214	+	function HasLocalTZDB: boolean; virtual;
215	+	function HasExtendedTZSupport: boolean; virtual;
216	+	function HasTimeZoneSupport: boolean; virtual;
217
218	+	public
219	+	property LocalTimeZoneName: AnsiString read FLocalTimeZoneName;
220	+	property TZDataTimeZoneID: AnsiString read FTZDataTimeZoneID;
221	+	property LocalTimeOffset: integer read FLocalTimeOffset;
222	+	public
223		{Encode/Decode}
224	<	procedure EncodeInteger(aValue: integer; len: integer; buffer: PByte);
225	<	function DecodeInteger(bufptr: PByte; len: short): integer; virtual; abstract;
226	<	procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte); virtual; abstract;
227	<	function SQLDecodeDate(byfptr: PByte): TDateTime; virtual; abstract;
228	<	procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte); virtual; abstract;
224	>	procedure EncodeInteger(aValue: int64; len: integer; buffer: PByte);
225	>	function DecodeInteger(bufptr: PByte; len: short): int64;
226	>	procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte);  virtual; abstract;
227	>	function SQLDecodeDate(byfptr: PByte): TDateTime;  virtual; abstract;
228	>	procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte);  virtual; abstract;
229		function SQLDecodeTime(bufptr: PByte): TDateTime;  virtual; abstract;
230		procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte); virtual; abstract;
231	<	function SQLDecodeDateTime(bufptr: PByte): TDateTime; virtual; abstract;
232	<	function FormatStatus(Status: TFBStatus): AnsiString; virtual; abstract;
231	>	function  SQLDecodeDateTime(bufptr: PByte): TDateTime; virtual; abstract;
232	>	function Int128ToStr(bufptr: PByte; scale: integer): AnsiString; virtual;
233	>	procedure StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte);
234	>	virtual;
235	>	procedure SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal; bufptr: PByte); virtual;
236	>	function SQLDecFloatDecode(SQLType: cardinal;  bufptr: PByte): tBCD; virtual;
237
238		{IFirebirdAPI}
239		function GetStatus: IStatus; virtual; abstract;
#	Line 197 | Line 243 | type
243		function GetImplementationVersion: AnsiString;
244		function GetClientMajor: integer;  virtual; abstract;
245		function GetClientMinor: integer;  virtual; abstract;
246	<	end;
246	>	end;
247	>
248	>	IJournallingHook = interface
249	>	['{7d3e45e0-3628-416a-9e22-c20474825031}']
250	>	procedure TransactionStart(Tr: ITransaction);
251	>	function TransactionEnd(TransactionID: integer; Action: TTransactionAction): boolean;
252	>	procedure TransactionRetained(Tr: ITransaction; OldTransactionID: integer; Action: TTransactionAction);
253	>	procedure ExecQuery(Stmt: IStatement);
254	>	end;
255
256		implementation
257
258		uses IBUtils, Registry,
259	<	{$IFDEF Unix} initc, dl, {$ENDIF}
259	>	{$IFDEF Unix} unix, initc, dl, {$ENDIF}
260		{$IFDEF FPC}
261		{$IFDEF WINDOWS }
262		WinDirs,
#	Line 235 | Line 289 | end;
289
290		procedure TFBLibrary.FreeFBLibrary;
291		begin
292	+	(FFirebirdAPI as TFBClientAPI).FBShutdown;
293		if FIBLibrary <> NilHandle then
294		FreeLibrary(FIBLibrary);
295		FIBLibrary := NilHandle;
296	+	FFBLibraryName := '';
297		end;
298
299		function TFBLibrary.GetLibraryName: string;
#	Line 289 | Line 345 | end;
345
346		destructor TFBLibrary.Destroy;
347		begin
292	–	FFirebirdAPI := nil;
348		FreeFBLibrary;
349	+	FFirebirdAPI := nil;
350		inherited Destroy;
351		end;
352
#	Line 301 | Line 357 | begin
357		if aLibPathName <> '' then
358		begin
359		for i := 0 to Length(FLibraryList) - 1 do
360	<	if (FLibraryList[i] as TFBLibrary).FRequestedLibName = aLibPathName then
360	>	begin
361	>	if (FLibraryList[i] as TFBLibrary).SameLibrary(aLibPathName) then
362		begin
363		Result := FLibraryList[i];
364		Exit;
365		end;
366	+	end;
367		Result := Create(aLibPathName);
368		end;
369
#	Line 319 | Line 377 | begin
377		SetLength(FLibraryList,0);
378		end;
379
380	+	function TFBLibrary.SameLibrary(aLibName: string): boolean;
381	+	begin
382	+	Result := FRequestedLibName = aLibName;
383	+	end;
384	+
385		function TFBLibrary.GetHandle: TLibHandle;
386		begin
387		Result := FIBLibrary;
#	Line 330 | Line 393 | constructor TFBClientAPI.Create(aFBLibra
393		begin
394		inherited Create;
395		FFBLibrary := aFBLibrary;
396	+	GetTZDataSettings;
397		end;
398
399		procedure TFBClientAPI.IBAlloc(var P; OldSize, NewSize: Integer);
#	Line 345 | Line 409 | begin
409		raise EIBInterBaseError.Create(GetStatus);
410		end;
411
412	<	{Under Unixes, if using an embedded server then set up local TMP and LOCK Directories}
349	<
350	<	procedure TFBClientAPI.EncodeInteger(aValue: integer; len: integer; buffer: PByte);
412	>	procedure TFBClientAPI.EncodeInteger(aValue: int64; len: integer; buffer: PByte);
413		begin
414		while len > 0 do
415		begin
#	Line 358 | Line 420 | begin
420		end;
421		end;
422
423	+	(*
424	+	DecodeInteger is Translated from
425	+
426	+	SINT64 API_ROUTINE isc_portable_integer(const UCHAR* ptr, SSHORT length)
427	+	if (!ptr || length <= 0 || length > 8)
428	+	return 0;
429	+
430	+	SINT64 value = 0;
431	+	int shift = 0;
432	+
433	+	while (--length > 0)
434	+	{
435	+	value += ((SINT64) *ptr++) << shift;
436	+	shift += 8;
437	+	}
438	+
439	+	value += ((SINT64)(SCHAR) *ptr) << shift;
440	+
441	+	return value;
442	+	*)
443	+
444	+	function TFBClientAPI.DecodeInteger(bufptr: PByte; len: short): int64;
445	+	var shift: integer;
446	+	begin
447	+	Result := 0;
448	+	if (BufPtr = nil) or (len <= 0) or (len > 8) then
449	+	Exit;
450	+
451	+	shift := 0;
452	+	dec(len);
453	+	while len > 0 do
454	+	begin
455	+	Result := Result + (int64(bufptr^) shl shift);
456	+	Inc(bufptr);
457	+	shift := shift + 8;
458	+	dec(len);
459	+	end;
460	+	Result := Result + (int64(bufptr^) shl shift);
461	+	end;
462	+
463	+	function TFBClientAPI.Int128ToStr(bufptr: PByte; scale: integer): AnsiString;
464	+	begin
465	+	if not HasInt128Support then
466	+	IBError(ibxeNotSupported,[]);
467	+	end;
468	+
469	+	procedure TFBClientAPI.StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte);
470	+	begin
471	+	if not HasInt128Support then
472	+	IBError(ibxeNotSupported,[]);
473	+	end;
474	+
475	+	procedure TFBClientAPI.SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal;
476	+	bufptr: PByte);
477	+	begin
478	+	if not HasDecFloatSupport then
479	+	IBError(ibxeNotSupported,[]);
480	+	end;
481	+
482	+	function TFBClientAPI.SQLDecFloatDecode(SQLType: cardinal; bufptr: PByte): tBCD;
483	+	begin
484	+	if not HasDecFloatSupport then
485	+	IBError(ibxeNotSupported,[]);
486	+	end;
487	+
488		function TFBClientAPI.IsLibraryLoaded: boolean;
489		begin
490		Result := FFBLibrary.IBLibrary <> NilHandle;
#	Line 368 | Line 495 | begin
495		Result := FFBLibrary;
496		end;
497
498	<	function TFBClientAPI.GetImplementationVersion: AnsiString;
498	>	function TFBClientAPI.FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
499		begin
500	<	Result := Format('%d.%d',[GetClientMajor,GetClientMinor]);
500	>	{aDate/aTime are in TTimestamp format but aTime is decimilliseconds}
501	>	aDate := aDate - DateDelta;
502	>	if aDate < 0 then
503	>	Result := trunc(aDate) - abs(frac(aTime / (MSecsPerDay*10)))
504	>	else
505	>	Result := trunc(aDate) + abs(frac(aTime / (MSecsPerDay*10)));
506		end;
507
508	+	{$IFDEF UNIX}
509	+
510	+	procedure TFBClientAPI.GetTZDataSettings;
511	+	var S: TStringList;
512	+	begin
513	+	FLocalTimeOffset := GetLocalTimeOffset;
514	+	{$if declared(Gettzname)}
515	+	FLocalTimeZoneName := Gettzname(tzdaylight);
516	+	{$else}
517	+	FLocalTimeZoneName := tzname[tzdaylight];
518	+	{$ifend}
519	+	FIsDaylightSavingsTime := tzdaylight;
520	+	if FileExists(DefaultTimeZoneFile) then
521	+	begin
522	+	S := TStringList.Create;
523	+	try
524	+	S.LoadFromFile(DefaultTimeZoneFile);
525	+	if S.Count > 0 then
526	+	FTZDataTimeZoneID := S[0];
527	+	finally
528	+	S.Free;
529	+	end;
530	+	end;
531	+	end;
532	+	{$ENDIF}
533	+
534	+	{$IFDEF WINDOWS}
535	+	procedure TFBClientAPI.GetTZDataSettings;
536	+	var TZInfo: TTimeZoneInformation;
537	+	begin
538	+	FIsDaylightSavingsTime := false;
539	+	{is there any way of working out the default TZData DB time zone ID under Windows?}
540	+	case GetTimeZoneInformation(TZInfo) of
541	+	TIME_ZONE_ID_UNKNOWN:
542	+	begin
543	+	FLocalTimeZoneName := '';
544	+	FLocalTimeOffset := 0;
545	+	end;
546	+	TIME_ZONE_ID_STANDARD:
547	+	begin
548	+	FLocalTimeZoneName := strpas(PWideChar(@TZInfo.StandardName));
549	+	FLocalTimeOffset := TZInfo.Bias;
550	+	end;
551	+	TIME_ZONE_ID_DAYLIGHT:
552	+	begin
553	+	FLocalTimeZoneName := strpas(PWideChar(@TZInfo.DaylightName));
554	+	FLocalTimeOffset := TZInfo.DayLightBias;
555	+	FIsDaylightSavingsTime := true;
556	+	end;
557	+	end;
558	+	end;
559	+	{$ENDIF}
560	+
561		function TFBClientAPI.GetProcAddr(ProcName: PAnsiChar): Pointer;
562		begin
563	<	Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
563	>	Result := nil;
564	>	if assigned(FFBLibrary) and (FFBLibrary.IBLibrary <> NilHandle) then
565	>	Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
566		if not Assigned(Result) then
567		raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
568		end;
569
570	+	function TFBClientAPI.HasDecFloatSupport: boolean;
571	+	begin
572	+	Result := GetClientMajor >= 4;
573	+	end;
574	+
575	+	function TFBClientAPI.HasInt128Support: boolean;
576	+	begin
577	+	Result := false;
578	+	end;
579	+
580	+	function TFBClientAPI.HasLocalTZDB: boolean;
581	+	begin
582	+	Result := false;
583	+	end;
584	+
585	+	function TFBClientAPI.HasExtendedTZSupport: boolean;
586	+	begin
587	+	Result := false;
588	+	end;
589	+
590	+	function TFBClientAPI.HasTimeZoneSupport: boolean;
591	+	begin
592	+	Result := false;
593	+	end;
594	+
595	+	function TFBClientAPI.GetImplementationVersion: AnsiString;
596	+	begin
597	+	Result := Format('%d.%d',[GetClientMajor,GetClientMinor]);
598	+	end;
599	+
600		function TFBClientAPI.LoadInterface: boolean;
601		begin
602		isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
603		isc_sql_interprete := GetProcAddr('isc_sql_interprete'); {do not localize}
604	<	isc_event_counts := GetProcAddr('isc_event_counts'); {do not localize}
605	<	isc_event_block := GetProcAddr('isc_event_block'); {do not localize}
606	<	isc_free := GetProcAddr('isc_free'); {do not localize}
607	<	Result := assigned(isc_free);
604	>	fb_shutdown := GetProcAddr('fb_shutdown'); {do not localize}
605	>	Result := true; {don't case if these fail to load}
606	>	end;
607	>
608	>	procedure TFBClientAPI.FBShutdown;
609	>	begin
610	>	if assigned(fb_shutdown) then
611	>	fb_shutdown(0,fb_shutrsn_exit_called);
612		end;
613
614		{ TFBStatus }
615
616	<	constructor TFBStatus.Create(aOwner: TFBClientAPI);
616	>	function TFBStatus.SQLCodeSupported: boolean;
617	>	begin
618	>	Result:= (FOwner <> nil) and assigned(FOwner.isc_sqlcode) and  assigned(FOwner.isc_sql_interprete);
619	>	end;
620	>
621	>	function TFBStatus.GetSQLMessage: Ansistring;
622	>	var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
623	>	begin
624	>	Result := '';
625	>	if (FOwner <> nil) and assigned(FOwner.isc_sql_interprete) then
626	>	begin
627	>	FOwner.isc_sql_interprete(Getsqlcode, local_buffer, sizeof(local_buffer));
628	>	Result := strpas(local_buffer);
629	>	end;
630	>	end;
631	>
632	>	constructor TFBStatus.Create(aOwner: TFBClientAPI; prefix: AnsiString);
633		begin
634		inherited Create;
635		FOwner := aOwner;
636	<	FIBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
636	>	FPrefix := prefix;
637	>	FIBDataBaseErrorMessages := [ShowIBMessage];
638		end;
639
640	<	function TFBStatus.GetIBErrorCode: Long;
640	>	function TFBStatus.GetIBErrorCode: TStatusCode;
641		begin
642		Result := StatusVector^[1];
643		end;
644
645	<	function TFBStatus.Getsqlcode: Long;
645	>	function TFBStatus.Getsqlcode: TStatusCode;
646		begin
647	<	with FOwner do
648	<	Result := isc_sqlcode(PISC_STATUS(StatusVector));
647	>	if (FOwner <> nil) and assigned(FOwner.isc_sqlcode) then
648	>	Result := FOwner.isc_sqlcode(PISC_STATUS(StatusVector))
649	>	else
650	>	Result := -999; {generic SQL Code}
651		end;
652
653		function TFBStatus.GetMessage: AnsiString;
654	<	var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
415	<	IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
416	<	sqlcode: Long;
654	>	var IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
655		begin
656	<	Result := '';
656	>	Result := FPrefix;
657		IBDataBaseErrorMessages := FIBDataBaseErrorMessages;
658	<	sqlcode := Getsqlcode;
659	<	if (ShowSQLCode in IBDataBaseErrorMessages) then
660	<	Result := Result + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
661	<
662	<	Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
663	<	if (ShowSQLMessage in IBDataBaseErrorMessages) then
664	<	begin
665	<	with FOwner do
666	<	isc_sql_interprete(sqlcode, local_buffer, sizeof(local_buffer));
667	<	if (ShowSQLCode in FIBDataBaseErrorMessages) then
668	<	Result := Result + CRLF;
431	<	Result := Result + strpas(local_buffer);
658	>	if SQLCodeSupported then
659	>	begin
660	>	if (ShowSQLCode in IBDataBaseErrorMessages) then
661	>	Result := Result + 'SQLCODE: ' + IntToStr(Getsqlcode); {do not localize}
662	>
663	>	if (ShowSQLMessage in IBDataBaseErrorMessages) then
664	>	begin
665	>	if ShowSQLCode in IBDataBaseErrorMessages then
666	>	Result := Result + LineEnding;
667	>	Result := Result + GetSQLMessage;
668	>	end;
669		end;
670
671		if (ShowIBMessage in IBDataBaseErrorMessages) then
672		begin
673	<	if (ShowSQLCode in IBDataBaseErrorMessages) or
437	<	(ShowSQLMessage in IBDataBaseErrorMessages) then
673	>	if Result <> FPrefix then
674		Result := Result + LineEnding;
675	<	Result := Result + LineEnding + FOwner.FormatStatus(self);
675	>	Result := Result + 'Engine Code: ' + IntToStr(GetIBErrorCode) + LineEnding + GetIBMessage;
676		end;
677		if (Result <> '') and (Result[Length(Result)] = '.') then
678		Delete(Result, Length(Result), 1);

Comparing:
ibx/trunk/fbintf/client/FBClientAPI.pas (property svn:eol-style), Revision 308 by tony, Sat Jul 18 10:26:30 2020 UTC vs.
ibx/branches/udr/client/FBClientAPI.pas (property svn:eol-style), Revision 385 by tony, Mon Jan 17 15:56:35 2022 UTC

#	Line 0 | Line 1
1	+	native

Diff Legend

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