ViewVC Help

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

root/public/ibx/trunk/fbintf/client/FBClientAPI.pas

Comparing ibx/trunk/fbintf/client/FBClientAPI.pas (file contents):
Revision 45 by tony, Tue Dec 6 10:33:46 2016 UTC vs.
Revision 315 by tony, Thu Feb 25 11:56:36 2021 UTC

#	Line 60 | Line 60
60		{                                                                        }
61		{************************************************************************}
62		unit FBClientAPI;
63	+	{$IFDEF MSWINDOWS}
64	+	{$DEFINE WINDOWS}
65	+	{$ENDIF}
66
67		{$IFDEF FPC}
68		{$mode delphi}
#	Line 70 | Line 73 | unit FBClientAPI;
73		interface
74
75		uses
76	<	Classes,  Dynlibs, IB, IBHeader, FBActivityMonitor, FBMessages, IBExternals;
76	>	Classes,
77	>	{$IFDEF WINDOWS}Windows, {$ENDIF}
78	>	{$IFDEF FPC} Dynlibs, {$ENDIF}
79	>	IB, IBHeader, FBActivityMonitor, FBMessages, IBExternals, FmtBCD;
80
81		{For Linux see result of GetFirebirdLibList method}
82		{$IFDEF DARWIN}
#	Line 84 | Line 90 | FIREBIRD_CLIENT = 'fbclient.dll'; {do no
90		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;
109	+
110		type
111		TStatusVector              = array[0..19] of NativeInt;
112		PStatusVector              = ^TStatusVector;
#	Line 94 | Line 117 | type
117
118		TFBStatus = class(TFBInterfacedObject)
119		private
97	–	FIBCS: TRTLCriticalSection; static;
120		FIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
121		protected
122		FOwner: TFBClientAPI;
#	Line 105 | Line 127 | type
127		{IStatus}
128		function GetIBErrorCode: Long;
129		function Getsqlcode: Long;
130	<	function GetMessage: string;
130	>	function GetMessage: AnsiString;
131		function CheckStatusVector(ErrorCodes: array of TFBStatusCode): Boolean;
132		function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
133		procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
134		end;
135
136	+	{ TFBLibrary }
137	+
138	+	TFBLibrary = class(TFBInterfacedObject,IFirebirdLibrary)
139	+	private
140	+	class var FEnvSetupDone: boolean;
141	+	class var FLibraryList: array of IFirebirdLibrary;
142	+	private
143	+	FFirebirdAPI: IFirebirdAPI;
144	+	FRequestedLibName: string;
145	+	function LoadIBLibrary: boolean;
146	+	protected
147	+	FFBLibraryName: string;
148	+	FIBLibrary: TLibHandle;
149	+	procedure FreeFBLibrary;
150	+	function GetOverrideLibName: string;
151	+	class procedure SetupEnvironment;
152	+	protected
153	+	function GetFirebird3API: IFirebirdAPI; virtual; abstract;
154	+	function GetLegacyFirebirdAPI: IFirebirdAPI; virtual; abstract;
155	+	public
156	+	constructor Create(aLibPathName: string='');
157	+	destructor Destroy; override;
158	+	class function GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
159	+	class procedure FreeLibraries;
160	+	function SameLibrary(aLibName: string): boolean;
161	+
162	+	public
163	+	{IFirebirdLibrary}
164	+	function GetHandle: TLibHandle;
165	+	function GetLibraryName: string;
166	+	function GetLibraryFilePath: string;
167	+	function GetFirebirdAPI: IFirebirdAPI;
168	+	property IBLibrary: TLibHandle read FIBLibrary;
169	+	end;
170	+
171		{ TFBClientAPI }
172
173		TFBClientAPI = class(TFBInterfacedObject)
174		private
175	<	FOwnsIBLibrary: boolean;
176	<	procedure LoadIBLibrary;
175	>	FLocalTimeZoneName: AnsiString; {Informal Time Zone Name from tzname e.g. GMT or BST}
176	>	FTZDataTimeZoneID: AnsiString; {TZData DB ID e.g. Europe/London}
177	>	FLocalTimeOffset: integer;
178	>	FIsDaylightSavingsTime: boolean;
179	>	class var FIBCS: TRTLCriticalSection;
180	>	function FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
181	>	procedure GetTZDataSettings;
182		protected
183	<	FFBLibraryName: string; static;
184	<	FFBLibraryPath: string; static;
185	<	IBLibrary: TLibHandle; static;
186	<	function GetProcAddr(ProcName: PChar): Pointer;
187	<	function GetOverrideLibName: string;
188	<	{$IFDEF UNIX}
189	<	function GetFirebirdLibList: string; virtual; abstract;
190	<	{$ENDIF}
191	<	procedure LoadInterface; virtual;
183	>	FFBLibrary: TFBLibrary;
184	>	function GetProcAddr(ProcName: PAnsiChar): Pointer;
185	>
186	>	protected type
187	>	Tfb_shutdown = function (timeout: uint;
188	>	const reason: int): int;
189	>	{$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
190	>	protected
191	>	{FB Shutdown API}
192	>	fb_shutdown: Tfb_shutdown;
193	>
194		public
195		{Taken from legacy API}
196		isc_sqlcode: Tisc_sqlcode;
197		isc_sql_interprete: Tisc_sql_interprete;
134	–	isc_interprete: Tisc_interprete;
198		isc_event_counts: Tisc_event_counts;
199		isc_event_block: Tisc_event_block;
200		isc_free: Tisc_free;
201
202	<	constructor Create;
140	<	destructor Destroy; override;
202	>	constructor Create(aFBLibrary: TFBLibrary);
203		procedure IBAlloc(var P; OldSize, NewSize: Integer);
204		procedure IBDataBaseError;
205	<	procedure SetupEnvironment;
205	>	function LoadInterface: boolean; virtual;
206	>	procedure FBShutdown; virtual;
207	>	function GetAPI: IFirebirdAPI; virtual; abstract;
208	>	{$IFDEF UNIX}
209	>	function GetFirebirdLibList: string; virtual; abstract;
210	>	{$ENDIF}
211	>	function HasDecFloatSupport: boolean;
212	>	function HasInt128Support: boolean; virtual;
213	>	function HasLocalTZDB: boolean; virtual;
214	>	function HasExtendedTZSupport: boolean; virtual;
215	>	function HasTimeZoneSupport: boolean; virtual;
216
217	+	public
218	+	property LocalTimeZoneName: AnsiString read FLocalTimeZoneName;
219	+	property TZDataTimeZoneID: AnsiString read FTZDataTimeZoneID;
220	+	property LocalTimeOffset: integer read FLocalTimeOffset;
221	+	public
222		{Encode/Decode}
223	<	procedure EncodeInteger(aValue: integer; len: integer; buffer: PChar);
224	<	function DecodeInteger(bufptr: PChar; len: short): integer; virtual; abstract;
225	<	procedure SQLEncodeDate(aDate: TDateTime; bufptr: PChar); virtual; abstract;
226	<	function SQLDecodeDate(byfptr: PChar): TDateTime; virtual; abstract;
227	<	procedure SQLEncodeTime(aTime: TDateTime; bufptr: PChar); virtual; abstract;
228	<	function SQLDecodeTime(bufptr: PChar): TDateTime;  virtual; abstract;
229	<	procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PChar); virtual; abstract;
230	<	function SQLDecodeDateTime(bufptr: PChar): TDateTime; virtual; abstract;
231	<
223	>	procedure EncodeInteger(aValue: integer; len: integer; buffer: PByte);
224	>	function DecodeInteger(bufptr: PByte; len: short): integer; virtual; abstract;
225	>	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	>	function SQLDecodeTime(bufptr: PByte): TDateTime;  virtual; abstract;
229	>	procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte); virtual; abstract;
230	>	function  SQLDecodeDateTime(bufptr: PByte): TDateTime; virtual; abstract;
231	>	function FormatStatus(Status: TFBStatus): AnsiString; 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	>	function FormatStatus(Status: TFBStatus): AnsiString; virtual; abstract;
238
239		{IFirebirdAPI}
240		function GetStatus: IStatus; virtual; abstract;
241		function IsLibraryLoaded: boolean;
242		function IsEmbeddedServer: boolean; virtual; abstract;
243	<	function GetLibraryName: string;
244	<	function GetCharsetName(CharSetID: integer): string;
245	<	function CharSetID2CodePage(CharSetID: integer; var CodePage: TSystemCodePage): boolean;
246	<	function CodePage2CharSetID(CodePage: TSystemCodePage; var CharSetID: integer): boolean;
247	<	function CharSetName2CharSetID(CharSetName: string; var CharSetID: integer): boolean;
165	<	function CharSetWidth(CharSetID: integer; var Width: integer): boolean;
166	<	end;
167	<
168	<	const FirebirdClientAPI: TFBClientAPI = nil;
243	>	function GetFBLibrary: IFirebirdLibrary;
244	>	function GetImplementationVersion: AnsiString;
245	>	function GetClientMajor: integer;  virtual; abstract;
246	>	function GetClientMinor: integer;  virtual; abstract;
247	>	end;
248
249		implementation
250
251	<	uses IBUtils, {$IFDEF Unix} initc, {$ENDIF}
251	>	uses IBUtils, Registry,
252	>	{$IFDEF Unix} unix, initc, dl, {$ENDIF}
253	>	{$IFDEF FPC}
254		{$IFDEF WINDOWS }
255	<	Windows,Registry, WinDirs,
255	>	WinDirs,
256	>	{$ENDIF}
257	>	{$ELSE}
258	>	ShlObj,
259		{$ENDIF}
260		SysUtils;
261
262		{$IFDEF UNIX}
263	<	{$I uloadlibrary.inc}
263	>	{$I 'include/uloadlibrary.inc'}
264		{$ELSE}
265	<	{$I wloadlibrary.inc}
265	>	{$I 'include/wloadlibrary.inc'}
266		{$ENDIF}
267
268	<	type
269	<	TCharsetMap = record
270	<	CharsetID: integer;
271	<	CharSetName: string;
272	<	CharSetWidth: integer;
273	<	CodePage: TSystemCodePage;
268	>
269	>	{ TFBLibrary }
270	>
271	>	function TFBLibrary.GetOverrideLibName: string;
272	>	begin
273	>	Result := FFBLibraryName;
274	>	if (Result = '') and AllowUseOfFBLIB then
275	>	Result := GetEnvironmentVariable('FBLIB');
276	>	if Result = '' then
277	>	begin
278	>	if assigned(OnGetLibraryName) then
279	>	OnGetLibraryName(Result)
280		end;
281	+	end;
282
283	<	const
284	<	CharSetMap: array [0..69] of TCharsetMap = (
285	<	(CharsetID: 0; CharSetName: 'NONE'; CharSetWidth: 1; CodePage: CP_NONE),
286	<	(CharsetID: 1; CharSetName: 'OCTETS'; CharSetWidth: 1; CodePage: CP_NONE),
287	<	(CharsetID: 2; CharSetName: 'ASCII'; CharSetWidth: 1; CodePage: CP_ASCII),
288	<	(CharsetID: 3; CharSetName: 'UNICODE_FSS'; CharSetWidth: 3; CodePage: CP_UTF8),
289	<	(CharsetID: 4; CharSetName: 'UTF8'; CharSetWidth: 4; CodePage: CP_UTF8),
290	<	(CharsetID: 5; CharSetName: 'SJIS_0208'; CharSetWidth: 2; CodePage: 20932),
291	<	(CharsetID: 6; CharSetName: 'EUCJ_0208'; CharSetWidth: 2; CodePage: 20932),
292	<	(CharsetID: 7; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
293	<	(CharsetID: 8; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
294	<	(CharsetID: 9; CharSetName: 'DOS737'; CharSetWidth: 1; CodePage: 737),
295	<	(CharsetID: 10; CharSetName: 'DOS437'; CharSetWidth: 1; CodePage: 437),
296	<	(CharsetID: 11; CharSetName: 'DOS850'; CharSetWidth: 1; CodePage: 850),
297	<	(CharsetID: 12; CharSetName: 'DOS865'; CharSetWidth: 1; CodePage: 865),
298	<	(CharsetID: 13; CharSetName: 'DOS860'; CharSetWidth: 1; CodePage: 860),
299	<	(CharsetID: 14; CharSetName: 'DOS863'; CharSetWidth: 1; CodePage: 863),
300	<	(CharsetID: 15; CharSetName: 'DOS775'; CharSetWidth: 1; CodePage: 775),
301	<	(CharsetID: 16; CharSetName: 'DOS858'; CharSetWidth: 1; CodePage: 858),
302	<	(CharsetID: 17; CharSetName: 'DOS862'; CharSetWidth: 1; CodePage: 862),
303	<	(CharsetID: 18; CharSetName: 'DOS864'; CharSetWidth: 1; CodePage: 864),
304	<	(CharsetID: 19; CharSetName: 'NEXT'; CharSetWidth: 1; CodePage: CP_NONE),
305	<	(CharsetID: 20; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
306	<	(CharsetID: 21; CharSetName: 'ISO8859_1'; CharSetWidth: 1; CodePage: 28591),
307	<	(CharsetID: 22; CharSetName: 'ISO8859_2'; CharSetWidth: 1; CodePage: 28592),
308	<	(CharsetID: 23; CharSetName: 'ISO8859_3'; CharSetWidth: 1; CodePage: 28593),
309	<	(CharsetID: 24; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
310	<	(CharsetID: 25; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
220	<	(CharsetID: 26; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
221	<	(CharsetID: 27; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
222	<	(CharsetID: 28; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
223	<	(CharsetID: 29; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
224	<	(CharsetID: 30; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
225	<	(CharsetID: 31; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
226	<	(CharsetID: 32; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
227	<	(CharsetID: 33; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
228	<	(CharsetID: 34; CharSetName: 'ISO8859_4'; CharSetWidth: 1; CodePage: 28594),
229	<	(CharsetID: 35; CharSetName: 'ISO8859_5'; CharSetWidth: 1; CodePage: 28595),
230	<	(CharsetID: 36; CharSetName: 'ISO8859_6'; CharSetWidth: 1; CodePage: 28596),
231	<	(CharsetID: 37; CharSetName: 'ISO8859_7'; CharSetWidth: 1; CodePage: 28597),
232	<	(CharsetID: 38; CharSetName: 'ISO8859_8'; CharSetWidth: 1; CodePage: 28598),
233	<	(CharsetID: 39; CharSetName: 'ISO8859_9'; CharSetWidth: 1; CodePage: 28599),
234	<	(CharsetID: 40; CharSetName: 'ISO8859_13'; CharSetWidth: 1; CodePage: 28603),
235	<	(CharsetID: 41; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
236	<	(CharsetID: 42; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
237	<	(CharsetID: 43; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
238	<	(CharsetID: 44; CharSetName: 'KSC_5601'; CharSetWidth: 2; CodePage: 949),
239	<	(CharsetID: 45; CharSetName: 'DOS852'; CharSetWidth: 1; CodePage: 852),
240	<	(CharsetID: 46; CharSetName: 'DOS857'; CharSetWidth: 1; CodePage: 857),
241	<	(CharsetID: 47; CharSetName: 'DOS861'; CharSetWidth: 1; CodePage: 861),
242	<	(CharsetID: 48; CharSetName: 'DOS866'; CharSetWidth: 1; CodePage: 866),
243	<	(CharsetID: 49; CharSetName: 'DOS869'; CharSetWidth: 1; CodePage: 869),
244	<	(CharsetID: 50; CharSetName: 'CYRL'; CharSetWidth: 1; CodePage: 1251),
245	<	(CharsetID: 51; CharSetName: 'WIN1250'; CharSetWidth: 1; CodePage: 1250),
246	<	(CharsetID: 52; CharSetName: 'WIN1251'; CharSetWidth: 1; CodePage: 1251),
247	<	(CharsetID: 53; CharSetName: 'WIN1252'; CharSetWidth: 1; CodePage: 1252),
248	<	(CharsetID: 54; CharSetName: 'WIN1253'; CharSetWidth: 1; CodePage: 1253),
249	<	(CharsetID: 55; CharSetName: 'WIN1254'; CharSetWidth: 1; CodePage: 1254),
250	<	(CharsetID: 56; CharSetName: 'BIG_5'; CharSetWidth: 2; CodePage: 950),
251	<	(CharsetID: 57; CharSetName: 'GB_2312'; CharSetWidth: 2; CodePage: 936),
252	<	(CharsetID: 58; CharSetName: 'WIN1255'; CharSetWidth: 1; CodePage: 1255),
253	<	(CharsetID: 59; CharSetName: 'WIN1256'; CharSetWidth: 1; CodePage: 1256),
254	<	(CharsetID: 60; CharSetName: 'WIN1257'; CharSetWidth: 1; CodePage: 1257),
255	<	(CharsetID: 61; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
256	<	(CharsetID: 62; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
257	<	(CharsetID: 63; CharSetName: 'KOI8R'; CharSetWidth: 1; CodePage: 20866),
258	<	(CharsetID: 64; CharSetName: 'KOI8U'; CharSetWidth: 1; CodePage: 21866),
259	<	(CharsetID: 65; CharSetName: 'WIN1258'; CharSetWidth: 1; CodePage: 1258),
260	<	(CharsetID: 66; CharSetName: 'TIS620'; CharSetWidth: 1; CodePage: 874),
261	<	(CharsetID: 67; CharSetName: 'GBK'; CharSetWidth: 2; CodePage: 936),
262	<	(CharsetID: 68; CharSetName: 'CP943C'; CharSetWidth: 2; CodePage: 943),
263	<	(CharsetID: 69; CharSetName: 'GB18030'; CharSetWidth: 4; CodePage: 54936)
264	<	);
265	<
266	<	{$IFDEF Unix}
267	<	{SetEnvironmentVariable doesn't exist so we have to use C Library}
268	<	function setenv(name:Pchar; value:Pchar; replace:integer):integer;cdecl;external clib name 'setenv';
269	<	function unsetenv(name:Pchar):integer;cdecl;external clib name 'unsetenv';
270	<	function SetEnvironmentVariable(name:PChar; value:PChar):boolean;
271	<	// Set environment variable; if empty string given, remove it.
283	>	procedure TFBLibrary.FreeFBLibrary;
284	>	begin
285	>	(FFirebirdAPI as TFBClientAPI).FBShutdown;
286	>	if FIBLibrary <> NilHandle then
287	>	FreeLibrary(FIBLibrary);
288	>	FIBLibrary := NilHandle;
289	>	FFBLibraryName := '';
290	>	end;
291	>
292	>	function TFBLibrary.GetLibraryName: string;
293	>	begin
294	>	Result := ExtractFileName(FFBLibraryName);
295	>	end;
296	>
297	>	function TFBLibrary.GetFirebirdAPI: IFirebirdAPI;
298	>	begin
299	>	Result := FFirebirdAPI;
300	>	end;
301	>
302	>	constructor TFBLibrary.Create(aLibPathName: string);
303	>	begin
304	>	inherited Create;
305	>	SetupEnvironment;
306	>	FFBLibraryName := aLibPathName;
307	>	FIBLibrary := NilHandle;
308	>	FFirebirdAPI := GetFirebird3API;
309	>	FRequestedLibName := aLibPathName;
310	>	if aLibPathName <> '' then
311		begin
312	<	result:=false; //assume failure
313	<	if value = '' then
314	<	begin
315	<	// Assume user wants to remove variable.
316	<	if unsetenv(name)=0 then result:=true;
317	<	end
318	<	else
312	>	SetLength(FLibraryList,Length(FLibraryList)+1);
313	>	FLibraryList[Length(FLibraryList)-1] := self;
314	>	end;
315	>	if FFirebirdAPI <> nil then
316	>	begin
317	>	{First try Firebird 3}
318	>	if not LoadIBLibrary or not (FFirebirdAPI as TFBClientAPI).LoadInterface then
319	>	FFirebirdAPI := nil;
320	>	end;
321	>
322	>	if FFirebirdAPI = nil then
323	>	begin
324	>	{now try Firebird 2.5. Under Unix we need to reload the library in case we
325	>	are to use the embedded library}
326	>	FFirebirdAPI := GetLegacyFirebirdAPI;
327	>	if FFirebirdAPI <> nil then
328		begin
329	<	// Non empty so set the variable
330	<	if setenv(name, value, 1)=0 then result:=true;
329	>	{$IFDEF UNIX}
330	>	FreeFBLibrary;
331	>	{$ENDIF}
332	>	if not LoadIBLibrary or not (FFirebirdAPI as TFBClientAPI).LoadInterface then
333	>	FFirebirdAPI := nil;
334		end;
335		end;
336	<	{$ENDIF}
336	>	{Note: FFirebirdAPI will be set to nil if the Firebird API fails to load}
337	>	end;
338
339	<	{ TFBClientAPI }
339	>	destructor TFBLibrary.Destroy;
340	>	begin
341	>	FreeFBLibrary;
342	>	FFirebirdAPI := nil;
343	>	inherited Destroy;
344	>	end;
345
346	<	constructor TFBClientAPI.Create;
346	>	class function TFBLibrary.GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
347	>	var i: integer;
348		begin
349	<	inherited Create;
350	<	LoadIBLibrary;
293	<	if (IBLibrary <> NilHandle) then
349	>	Result := nil;
350	>	if aLibPathName <> '' then
351		begin
352	<	SetupEnvironment;
353	<	LoadInterface;
352	>	for i := 0 to Length(FLibraryList) - 1 do
353	>	begin
354	>	if (FLibraryList[i] as TFBLibrary).SameLibrary(aLibPathName) then
355	>	begin
356	>	Result := FLibraryList[i];
357	>	Exit;
358	>	end;
359	>	end;
360	>	Result := Create(aLibPathName);
361		end;
362	<	FirebirdClientAPI := self;
362	>
363		end;
364
365	<	destructor TFBClientAPI.Destroy;
365	>	class procedure TFBLibrary.FreeLibraries;
366	>	var i: integer;
367		begin
368	<	FirebirdClientAPI := nil;
369	<	if FOwnsIBLibrary and (IBLibrary <> NilHandle) then
370	<	UnloadLibrary(IBLibrary);
371	<	IBLibrary := NilHandle;
372	<	inherited Destroy;
368	>	for i := 0 to Length(FLibraryList) - 1 do
369	>	FLibraryList[i] := nil;
370	>	SetLength(FLibraryList,0);
371	>	end;
372	>
373	>	function TFBLibrary.SameLibrary(aLibName: string): boolean;
374	>	begin
375	>	Result := FRequestedLibName = aLibName;
376	>	end;
377	>
378	>	function TFBLibrary.GetHandle: TLibHandle;
379	>	begin
380	>	Result := FIBLibrary;
381	>	end;
382	>
383	>	{ TFBClientAPI }
384	>
385	>	constructor TFBClientAPI.Create(aFBLibrary: TFBLibrary);
386	>	begin
387	>	inherited Create;
388	>	FFBLibrary := aFBLibrary;
389	>	GetTZDataSettings;
390		end;
391
392		procedure TFBClientAPI.IBAlloc(var P; OldSize, NewSize: Integer);
#	Line 312 | Line 394 | var
394		i: Integer;
395		begin
396		ReallocMem(Pointer(P), NewSize);
397	<	for i := OldSize to NewSize - 1 do PChar(P)[i] := #0;
397	>	for i := OldSize to NewSize - 1 do PAnsiChar(P)[i] := #0;
398		end;
399
400		procedure TFBClientAPI.IBDataBaseError;
#	Line 320 | Line 402 | begin
402		raise EIBInterBaseError.Create(GetStatus);
403		end;
404
405	<	{Under Unixes, if using an embedded server then set up local TMP and LOCK Directories}
324	<
325	<	procedure TFBClientAPI.SetupEnvironment;
326	<	var TmpDir: string;
327	<	begin
328	<	{$IFDEF UNIX}
329	<	TmpDir := GetTempDir +
330	<	DirectorySeparator + 'firebird_' + sysutils.GetEnvironmentVariable('USER');
331	<	if sysutils.GetEnvironmentVariable('FIREBIRD_TMP') = '' then
332	<	begin
333	<	if not DirectoryExists(tmpDir) then
334	<	mkdir(tmpDir);
335	<	SetEnvironmentVariable('FIREBIRD_TMP',PChar(TmpDir));
336	<	end;
337	<	if sysutils.GetEnvironmentVariable('FIREBIRD_LOCK') = '' then
338	<	begin
339	<	if not DirectoryExists(tmpDir) then
340	<	mkdir(tmpDir);
341	<	SetEnvironmentVariable('FIREBIRD_LOCK',PChar(TmpDir));
342	<	end;
343	<	{$ENDIF}
344	<	end;
345	<
346	<	procedure TFBClientAPI.EncodeInteger(aValue: integer; len: integer; buffer: PChar);
405	>	procedure TFBClientAPI.EncodeInteger(aValue: integer; len: integer; buffer: PByte);
406		begin
407		while len > 0 do
408		begin
409	<	buffer^ := char(aValue and $FF);
409	>	buffer^ := aValue and $FF;
410		Inc(buffer);
411		Dec(len);
412		aValue := aValue shr 8;
413		end;
414		end;
415
416	+	function TFBClientAPI.Int128ToStr(bufptr: PByte; scale: integer): AnsiString;
417	+	begin
418	+	if not HasInt128Support then
419	+	IBError(ibxeNotSupported,[]);
420	+	end;
421	+
422	+	procedure TFBClientAPI.StrToInt128(scale: integer; aValue: AnsiString; bufptr: PByte);
423	+	begin
424	+	if not HasInt128Support then
425	+	IBError(ibxeNotSupported,[]);
426	+	end;
427	+
428	+	procedure TFBClientAPI.SQLDecFloatEncode(aValue: tBCD; SQLType: cardinal;
429	+	bufptr: PByte);
430	+	begin
431	+	if not HasDecFloatSupport then
432	+	IBError(ibxeNotSupported,[]);
433	+	end;
434	+
435	+	function TFBClientAPI.SQLDecFloatDecode(SQLType: cardinal; bufptr: PByte): tBCD;
436	+	begin
437	+	if not HasDecFloatSupport then
438	+	IBError(ibxeNotSupported,[]);
439	+	end;
440	+
441		function TFBClientAPI.IsLibraryLoaded: boolean;
442		begin
443	<	Result := IBLibrary <> NilHandle;
443	>	Result := FFBLibrary.IBLibrary <> NilHandle;
444		end;
445
446	<	function TFBClientAPI.GetProcAddr(ProcName: PChar): Pointer;
446	>	function TFBClientAPI.GetFBLibrary: IFirebirdLibrary;
447		begin
448	<	Result := GetProcAddress(IBLibrary, ProcName);
365	<	if not Assigned(Result) then
366	<	raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
448	>	Result := FFBLibrary;
449		end;
450
451	<	function TFBClientAPI.GetOverrideLibName: string;
451	>	function TFBClientAPI.FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
452		begin
453	<	Result := '';
454	<	if AllowUseOfFBLIB then
455	<	Result := GetEnvironmentVariable('FBLIB');
456	<	if Result = '' then
453	>	{aDate/aTime are in TTimestamp format but aTime is decimilliseconds}
454	>	aDate := aDate - DateDelta;
455	>	if aDate < 0 then
456	>	Result := trunc(aDate) - abs(frac(aTime / (MSecsPerDay*10)))
457	>	else
458	>	Result := trunc(aDate) + abs(frac(aTime / (MSecsPerDay*10)));
459	>	end;
460	>
461	>	{$IFDEF UNIX}
462	>	procedure TFBClientAPI.GetTZDataSettings;
463	>	var S: TStringList;
464	>	begin
465	>	FLocalTimeOffset := GetLocalTimeOffset;
466	>	FLocalTimeZoneName := strpas(tzname[tzdaylight]);
467	>	FIsDaylightSavingsTime := tzdaylight;
468	>	if FileExists(DefaultTimeZoneFile) then
469		begin
470	<	if assigned(OnGetLibraryName) then
471	<	OnGetLibraryName(Result)
470	>	S := TStringList.Create;
471	>	try
472	>	S.LoadFromFile(DefaultTimeZoneFile);
473	>	if S.Count > 0 then
474	>	FTZDataTimeZoneID := S[0];
475	>	finally
476	>	S.Free;
477	>	end;
478		end;
479		end;
480	+	{$ENDIF}
481
482	<	procedure TFBClientAPI.LoadInterface;
482	>	{$IFDEF WINDOWS}
483	>	procedure TFBClientAPI.GetTZDataSettings;
484	>	var TZInfo: TTimeZoneInformation;
485		begin
486	<	isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
487	<	isc_sql_interprete := GetProcAddr('isc_sql_interprete'); {do not localize}
488	<	isc_interprete := GetProcAddr('isc_interprete'); {do not localize}
489	<	isc_event_counts := GetProcAddr('isc_event_counts'); {do not localize}
490	<	isc_event_block := GetProcAddr('isc_event_block'); {do not localize}
491	<	isc_free := GetProcAddr('isc_free'); {do not localize}
486	>	FIsDaylightSavingsTime := false;
487	>	{is there any way of working out the default TZData DB time zone ID under Windows?}
488	>	case GetTimeZoneInformation(TZInfo) of
489	>	TIME_ZONE_ID_UNKNOWN:
490	>	begin
491	>	FLocalTimeZoneName := '';
492	>	FLocalTimeOffset := 0;
493	>	end;
494	>	TIME_ZONE_ID_STANDARD:
495	>	begin
496	>	FLocalTimeZoneName := strpas(PWideChar(@TZInfo.StandardName));
497	>	FLocalTimeOffset := TZInfo.Bias;
498	>	end;
499	>	TIME_ZONE_ID_DAYLIGHT:
500	>	begin
501	>	FLocalTimeZoneName := strpas(PWideChar(@TZInfo.DaylightName));
502	>	FLocalTimeOffset := TZInfo.DayLightBias;
503	>	FIsDaylightSavingsTime := true;
504	>	end;
505	>	end;
506		end;
507	+	{$ENDIF}
508
509	<	function TFBClientAPI.GetLibraryName: string;
509	>	function TFBClientAPI.GetProcAddr(ProcName: PAnsiChar): Pointer;
510		begin
511	<	Result := FFBLibraryName;
511	>	Result := GetProcAddress(FFBLibrary.IBLibrary, ProcName);
512	>	if not Assigned(Result) then
513	>	raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
514		end;
515
516	<	function TFBClientAPI.GetCharsetName(CharSetID: integer): string;
516	>	function TFBClientAPI.HasDecFloatSupport: boolean;
517		begin
518	<	Result := '';
399	<	if (CharSetID >= Low(CharSetMap)) and (CharSetID <= High(CharSetMap)) and
400	<	(CharSetMap[CharSetID].CharSetID = CharSetID) then
401	<	begin
402	<	Result := CharSetMap[CharSetID].CharSetName;
403	<	Exit;
404	<	end;
518	>	Result := GetClientMajor >= 4;
519		end;
520
521	<	function TFBClientAPI.CharSetID2CodePage(CharSetID: integer;
408	<	var CodePage: TSystemCodePage): boolean;
521	>	function TFBClientAPI.HasInt128Support: boolean;
522		begin
523	<	Result := (CharSetID >= Low(CharSetMap)) and (CharSetID <= High(CharSetMap))
411	<	and (CharSetMap[CharSetID].CharSetID = CharSetID);
412	<	if Result then
413	<	begin
414	<	CodePage := CharSetMap[CharSetID].CodePage;
415	<	Result := true;
416	<	Exit;
417	<	end;
523	>	Result := false;
524		end;
525
526	<	function TFBClientAPI.CodePage2CharSetID(CodePage: TSystemCodePage;
421	<	var CharSetID: integer): boolean;
422	<	var i: integer;
526	>	function TFBClientAPI.HasLocalTZDB: boolean;
527		begin
528		Result := false;
425	–	for i := Low(CharSetMap) to High(CharSetMap) do
426	–	if CharSetMap[i].CodePage = CodePage then
427	–	begin
428	–	CharSetID := CharSetMap[i].CharSetID;
429	–	Result := true;
430	–	Exit;
431	–	end;
529		end;
530
531	<	function TFBClientAPI.CharSetName2CharSetID(CharSetName: string;
435	<	var CharSetID: integer): boolean;
436	<	var i: integer;
531	>	function TFBClientAPI.HasExtendedTZSupport: boolean;
532		begin
533		Result := false;
439	–	for i := Low(CharSetMap) to High(CharSetMap) do
440	–	if CompareStr(CharSetMap[i].CharSetName, CharSetName) = 0 then
441	–	begin
442	–	CharSetID := CharSetMap[i].CharSetID;
443	–	Result := true;
444	–	Exit;
445	–	end;
534		end;
535
536	<	function TFBClientAPI.CharSetWidth(CharSetID: integer; var Width: integer
449	<	): boolean;
536	>	function TFBClientAPI.HasTimeZoneSupport: boolean;
537		begin
538	<	Result := (CharSetID >= Low(CharSetMap)) and (CharSetID <= High(CharSetMap))
452	<	and (CharSetMap[CharSetID].CharSetID = CharSetID);
453	<	if Result then
454	<	begin
455	<	Width := CharSetMap[CharSetID].CharSetWidth;
456	<	Result := true;
457	<	Exit;
458	<	end;
538	>	Result := false;
539		end;
540
541	<	const
542	<	IBLocalBufferLength = 512;
543	<	IBBigLocalBufferLength = IBLocalBufferLength * 2;
544	<	IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;
541	>	function TFBClientAPI.GetImplementationVersion: AnsiString;
542	>	begin
543	>	Result := Format('%d.%d',[GetClientMajor,GetClientMinor]);
544	>	end;
545	>
546	>	function TFBClientAPI.LoadInterface: boolean;
547	>	begin
548	>	isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
549	>	isc_sql_interprete := GetProcAddr('isc_sql_interprete'); {do not localize}
550	>	isc_event_counts := GetProcAddr('isc_event_counts'); {do not localize}
551	>	isc_event_block := GetProcAddr('isc_event_block'); {do not localize}
552	>	isc_free := GetProcAddr('isc_free'); {do not localize}
553	>	fb_shutdown := GetProcAddr('fb_shutdown'); {do not localize}
554	>	Result := assigned(isc_free);
555	>	end;
556	>
557	>	procedure TFBClientAPI.FBShutdown;
558	>	begin
559	>	if assigned(fb_shutdown) then
560	>	fb_shutdown(0,fb_shutrsn_exit_called);
561	>	end;
562
563		{ TFBStatus }
564
#	Line 483 | Line 580 | begin
580		Result := isc_sqlcode(PISC_STATUS(StatusVector));
581		end;
582
583	<	function TFBStatus.GetMessage: string;
584	<	var local_buffer: array[0..IBHugeLocalBufferLength - 1] of char;
583	>	function TFBStatus.GetMessage: AnsiString;
584	>	var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
585		IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
586		sqlcode: Long;
490	–	psb: PStatusVector;
587		begin
588		Result := '';
589		IBDataBaseErrorMessages := FIBDataBaseErrorMessages;
#	Line 499 | Line 595 | begin
595		if (ShowSQLMessage in IBDataBaseErrorMessages) then
596		begin
597		with FOwner do
598	<	isc_sql_interprete(sqlcode, local_buffer, IBLocalBufferLength);
598	>	isc_sql_interprete(sqlcode, local_buffer, sizeof(local_buffer));
599		if (ShowSQLCode in FIBDataBaseErrorMessages) then
600		Result := Result + CRLF;
601		Result := Result + strpas(local_buffer);
#	Line 509 | Line 605 | begin
605		begin
606		if (ShowSQLCode in IBDataBaseErrorMessages) or
607		(ShowSQLMessage in IBDataBaseErrorMessages) then
608	<	Result := Result + CRLF;
609	<	psb := StatusVector;
514	<	with FOwner do
515	<	while (isc_interprete(@local_buffer, @psb) > 0) do
516	<	begin
517	<	if (Result <> '') and (Result[Length(Result)] <> LF) then
518	<	Result := Result + CRLF;
519	<	Result := Result + strpas(local_buffer);
520	<	end;
608	>	Result := Result + LineEnding;
609	>	Result := Result + FOwner.FormatStatus(self);
610		end;
611		if (Result <> '') and (Result[Length(Result)] = '.') then
612		Delete(Result, Length(Result), 1);
#	Line 530 | Line 619 | var
619		i: Integer;
620		procedure NextP(i: Integer);
621		begin
622	<	p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
622	>	p := PISC_STATUS(PAnsiChar(p) + (i * SizeOf(ISC_STATUS)));
623		end;
624		begin
625		p := PISC_STATUS(StatusVector);
#	Line 556 | Line 645 | end;
645
646		function TFBStatus.GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
647		begin
648	<	EnterCriticalSection(FIBCS);
648	>	EnterCriticalSection(TFBClientAPI.FIBCS);
649		try
650		result := FIBDataBaseErrorMessages;
651		finally
652	<	LeaveCriticalSection(FIBCS);
652	>	LeaveCriticalSection(TFBClientAPI.FIBCS);
653		end;
654		end;
655
656		procedure TFBStatus.SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
657		begin
658	<	EnterCriticalSection(FIBCS);
658	>	EnterCriticalSection(TFBClientAPI.FIBCS);
659		try
660		FIBDataBaseErrorMessages := Value;
661		finally
662	<	LeaveCriticalSection(FIBCS);
662	>	LeaveCriticalSection(TFBClientAPI.FIBCS);
663		end;
664		end;
665	+
666		initialization
667	<	TFBClientAPI.IBLibrary := NilHandle;
668	<	InitCriticalSection(TFBStatus.FIBCS);
667	>	TFBLibrary.FEnvSetupDone := false;
668	>	{$IFNDEF FPC}
669	>	InitializeCriticalSection(TFBClientAPI.FIBCS);
670	>	{$ELSE}
671	>	InitCriticalSection(TFBClientAPI.FIBCS);
672	>	{$ENDIF}
673
674		finalization
675	<	DoneCriticalSection(TFBStatus.FIBCS);
676	<	if TFBClientAPI.IBLibrary <> NilHandle then
677	<	begin
678	<	FreeLibrary(TFBClientAPI.IBLibrary);
679	<	TFBClientAPI.IBLibrary := NilHandle;
680	<	TFBClientAPI.FFBLibraryName := '';
587	<	end;
588	<
675	>	TFBLibrary.FreeLibraries;
676	>	{$IFNDEF FPC}
677	>	DeleteCriticalSection(TFBClientAPI.FIBCS);
678	>	{$ELSE}
679	>	DoneCriticalSection(TFBClientAPI.FIBCS);
680	>	{$ENDIF}
681		end.
682

Diff Legend

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