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 56 by tony, Mon Mar 6 10:20:02 2017 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 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 110 | 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;
134		procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
135		end;
136
137	+	{ TFBLibrary }
138	+
139	+	TFBLibrary = class(TFBInterfacedObject,IFirebirdLibrary)
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;
147	+	protected
148	+	FFBLibraryName: string;
149	+	FIBLibrary: TLibHandle;
150	+	procedure FreeFBLibrary;
151	+	function GetOverrideLibName: string;
152	+	class procedure SetupEnvironment;
153	+	protected
154	+	function GetFirebird3API: IFirebirdAPI; virtual; abstract;
155	+	function GetLegacyFirebirdAPI: IFirebirdAPI; virtual; abstract;
156	+	public
157	+	constructor Create(aLibPathName: string='');
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;
167	+	function GetLibraryFilePath: string;
168	+	function GetFirebirdAPI: IFirebirdAPI;
169	+	property IBLibrary: TLibHandle read FIBLibrary;
170	+	end;
171	+
172		{ TFBClientAPI }
173
174		TFBClientAPI = class(TFBInterfacedObject)
175		private
176	<	FOwnsIBLibrary: boolean;
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	<	procedure LoadIBLibrary;
181	>	function FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
182	>	procedure GetTZDataSettings;
183		protected
184	<	class var FFBLibraryName: string;
137	<	class var IBLibrary: TLibHandle;
138	<	{$IFDEF WINDOWS}
139	<	class var FFBLibraryPath: string;
140	<	{$ENDIF}
184	>	FFBLibrary: TFBLibrary;
185		function GetProcAddr(ProcName: PAnsiChar): Pointer;
186	<	function GetOverrideLibName: string;
187	<	{$IFDEF UNIX}
188	<	function GetFirebirdLibList: string; virtual; abstract;
189	<	{$ENDIF}
190	<	procedure LoadInterface; virtual;
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;
198		isc_sql_interprete: Tisc_sql_interprete;
151	–	isc_interprete: Tisc_interprete;
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;
157	<	destructor Destroy; override;
204	>	constructor Create(aFBLibrary: TFBLibrary);
205		procedure IBAlloc(var P; OldSize, NewSize: Integer);
206		procedure IBDataBaseError;
207	<	procedure SetupEnvironment;
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;
233	<
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;
242		function IsLibraryLoaded: boolean;
243		function IsEmbeddedServer: boolean; virtual; abstract;
244	<	function GetLibraryName: string;
245	<	function GetCharsetName(CharSetID: integer): AnsiString;
246	<	function CharSetID2CodePage(CharSetID: integer; var CodePage: TSystemCodePage): boolean;
247	<	function CodePage2CharSetID(CodePage: TSystemCodePage; var CharSetID: integer): boolean;
181	<	function CharSetName2CharSetID(CharSetName: AnsiString; var CharSetID: integer): boolean;
182	<	function CharSetWidth(CharSetID: integer; var Width: integer): boolean;
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; 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, {$IFDEF Unix} initc, {$ENDIF}
260	>	uses IBUtils, Registry,
261	>	{$IFDEF Unix} unix, initc, dl, {$ENDIF}
262		{$IFDEF FPC}
263		{$IFDEF WINDOWS }
264		WinDirs,
#	Line 202 | Line 274 | SysUtils;
274		{$I 'include/wloadlibrary.inc'}
275		{$ENDIF}
276
277	<	type
278	<	TCharsetMap = record
279	<	CharsetID: integer;
280	<	CharSetName: AnsiString;
281	<	CharSetWidth: integer;
282	<	CodePage: TSystemCodePage;
277	>
278	>	{ TFBLibrary }
279	>
280	>	function TFBLibrary.GetOverrideLibName: string;
281	>	begin
282	>	Result := FFBLibraryName;
283	>	if (Result = '') and AllowUseOfFBLIB then
284	>	Result := GetEnvironmentVariable('FBLIB');
285	>	if Result = '' then
286	>	begin
287	>	if assigned(OnGetLibraryName) then
288	>	OnGetLibraryName(Result)
289		end;
290	+	end;
291
292	<	const
293	<	CharSetMap: array [0..69] of TCharsetMap = (
294	<	(CharsetID: 0; CharSetName: 'NONE'; CharSetWidth: 1; CodePage: CP_ACP),
295	<	(CharsetID: 1; CharSetName: 'OCTETS'; CharSetWidth: 1; CodePage: CP_NONE),
296	<	(CharsetID: 2; CharSetName: 'ASCII'; CharSetWidth: 1; CodePage: CP_ASCII),
297	<	(CharsetID: 3; CharSetName: 'UNICODE_FSS'; CharSetWidth: 3; CodePage: CP_UTF8),
298	<	(CharsetID: 4; CharSetName: 'UTF8'; CharSetWidth: 4; CodePage: CP_UTF8),
299	<	(CharsetID: 5; CharSetName: 'SJIS_0208'; CharSetWidth: 2; CodePage: 20932),
300	<	(CharsetID: 6; CharSetName: 'EUCJ_0208'; CharSetWidth: 2; CodePage: 20932),
301	<	(CharsetID: 7; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
302	<	(CharsetID: 8; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
303	<	(CharsetID: 9; CharSetName: 'DOS737'; CharSetWidth: 1; CodePage: 737),
304	<	(CharsetID: 10; CharSetName: 'DOS437'; CharSetWidth: 1; CodePage: 437),
305	<	(CharsetID: 11; CharSetName: 'DOS850'; CharSetWidth: 1; CodePage: 850),
306	<	(CharsetID: 12; CharSetName: 'DOS865'; CharSetWidth: 1; CodePage: 865),
307	<	(CharsetID: 13; CharSetName: 'DOS860'; CharSetWidth: 1; CodePage: 860),
308	<	(CharsetID: 14; CharSetName: 'DOS863'; CharSetWidth: 1; CodePage: 863),
309	<	(CharsetID: 15; CharSetName: 'DOS775'; CharSetWidth: 1; CodePage: 775),
310	<	(CharsetID: 16; CharSetName: 'DOS858'; CharSetWidth: 1; CodePage: 858),
311	<	(CharsetID: 17; CharSetName: 'DOS862'; CharSetWidth: 1; CodePage: 862),
312	<	(CharsetID: 18; CharSetName: 'DOS864'; CharSetWidth: 1; CodePage: 864),
313	<	(CharsetID: 19; CharSetName: 'NEXT'; CharSetWidth: 1; CodePage: CP_NONE),
314	<	(CharsetID: 20; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
315	<	(CharsetID: 21; CharSetName: 'ISO8859_1'; CharSetWidth: 1; CodePage: 28591),
316	<	(CharsetID: 22; CharSetName: 'ISO8859_2'; CharSetWidth: 1; CodePage: 28592),
317	<	(CharsetID: 23; CharSetName: 'ISO8859_3'; CharSetWidth: 1; CodePage: 28593),
318	<	(CharsetID: 24; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
319	<	(CharsetID: 25; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
241	<	(CharsetID: 26; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
242	<	(CharsetID: 27; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
243	<	(CharsetID: 28; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
244	<	(CharsetID: 29; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
245	<	(CharsetID: 30; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
246	<	(CharsetID: 31; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
247	<	(CharsetID: 32; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
248	<	(CharsetID: 33; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
249	<	(CharsetID: 34; CharSetName: 'ISO8859_4'; CharSetWidth: 1; CodePage: 28594),
250	<	(CharsetID: 35; CharSetName: 'ISO8859_5'; CharSetWidth: 1; CodePage: 28595),
251	<	(CharsetID: 36; CharSetName: 'ISO8859_6'; CharSetWidth: 1; CodePage: 28596),
252	<	(CharsetID: 37; CharSetName: 'ISO8859_7'; CharSetWidth: 1; CodePage: 28597),
253	<	(CharsetID: 38; CharSetName: 'ISO8859_8'; CharSetWidth: 1; CodePage: 28598),
254	<	(CharsetID: 39; CharSetName: 'ISO8859_9'; CharSetWidth: 1; CodePage: 28599),
255	<	(CharsetID: 40; CharSetName: 'ISO8859_13'; CharSetWidth: 1; CodePage: 28603),
256	<	(CharsetID: 41; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
257	<	(CharsetID: 42; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
258	<	(CharsetID: 43; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
259	<	(CharsetID: 44; CharSetName: 'KSC_5601'; CharSetWidth: 2; CodePage: 949),
260	<	(CharsetID: 45; CharSetName: 'DOS852'; CharSetWidth: 1; CodePage: 852),
261	<	(CharsetID: 46; CharSetName: 'DOS857'; CharSetWidth: 1; CodePage: 857),
262	<	(CharsetID: 47; CharSetName: 'DOS861'; CharSetWidth: 1; CodePage: 861),
263	<	(CharsetID: 48; CharSetName: 'DOS866'; CharSetWidth: 1; CodePage: 866),
264	<	(CharsetID: 49; CharSetName: 'DOS869'; CharSetWidth: 1; CodePage: 869),
265	<	(CharsetID: 50; CharSetName: 'CYRL'; CharSetWidth: 1; CodePage: 1251),
266	<	(CharsetID: 51; CharSetName: 'WIN1250'; CharSetWidth: 1; CodePage: 1250),
267	<	(CharsetID: 52; CharSetName: 'WIN1251'; CharSetWidth: 1; CodePage: 1251),
268	<	(CharsetID: 53; CharSetName: 'WIN1252'; CharSetWidth: 1; CodePage: 1252),
269	<	(CharsetID: 54; CharSetName: 'WIN1253'; CharSetWidth: 1; CodePage: 1253),
270	<	(CharsetID: 55; CharSetName: 'WIN1254'; CharSetWidth: 1; CodePage: 1254),
271	<	(CharsetID: 56; CharSetName: 'BIG_5'; CharSetWidth: 2; CodePage: 950),
272	<	(CharsetID: 57; CharSetName: 'GB_2312'; CharSetWidth: 2; CodePage: 936),
273	<	(CharsetID: 58; CharSetName: 'WIN1255'; CharSetWidth: 1; CodePage: 1255),
274	<	(CharsetID: 59; CharSetName: 'WIN1256'; CharSetWidth: 1; CodePage: 1256),
275	<	(CharsetID: 60; CharSetName: 'WIN1257'; CharSetWidth: 1; CodePage: 1257),
276	<	(CharsetID: 61; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
277	<	(CharsetID: 62; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
278	<	(CharsetID: 63; CharSetName: 'KOI8R'; CharSetWidth: 1; CodePage: 20866),
279	<	(CharsetID: 64; CharSetName: 'KOI8U'; CharSetWidth: 1; CodePage: 21866),
280	<	(CharsetID: 65; CharSetName: 'WIN1258'; CharSetWidth: 1; CodePage: 1258),
281	<	(CharsetID: 66; CharSetName: 'TIS620'; CharSetWidth: 1; CodePage: 874),
282	<	(CharsetID: 67; CharSetName: 'GBK'; CharSetWidth: 2; CodePage: 936),
283	<	(CharsetID: 68; CharSetName: 'CP943C'; CharSetWidth: 2; CodePage: 943),
284	<	(CharsetID: 69; CharSetName: 'GB18030'; CharSetWidth: 4; CodePage: 54936)
285	<	);
286	<
287	<	{$IFDEF Unix}
288	<	{SetEnvironmentVariable doesn't exist so we have to use C Library}
289	<	function setenv(name:Pchar; value:Pchar; replace:integer):integer;cdecl;external clib name 'setenv';
290	<	function unsetenv(name:Pchar):integer;cdecl;external clib name 'unsetenv';
291	<	function SetEnvironmentVariable(name:PAnsiChar; value:PAnsiChar):boolean;
292	<	// Set environment variable; if empty string given, remove it.
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;
302	>	begin
303	>	Result := ExtractFileName(FFBLibraryName);
304	>	end;
305	>
306	>	function TFBLibrary.GetFirebirdAPI: IFirebirdAPI;
307	>	begin
308	>	Result := FFirebirdAPI;
309	>	end;
310	>
311	>	constructor TFBLibrary.Create(aLibPathName: string);
312	>	begin
313	>	inherited Create;
314	>	SetupEnvironment;
315	>	FFBLibraryName := aLibPathName;
316	>	FIBLibrary := NilHandle;
317	>	FFirebirdAPI := GetFirebird3API;
318	>	FRequestedLibName := aLibPathName;
319	>	if aLibPathName <> '' then
320		begin
321	<	result:=false; //assume failure
322	<	if value = '' then
323	<	begin
324	<	// Assume user wants to remove variable.
325	<	if unsetenv(name)=0 then result:=true;
326	<	end
327	<	else
321	>	SetLength(FLibraryList,Length(FLibraryList)+1);
322	>	FLibraryList[Length(FLibraryList)-1] := self;
323	>	end;
324	>	if FFirebirdAPI <> nil then
325	>	begin
326	>	{First try Firebird 3}
327	>	if not LoadIBLibrary or not (FFirebirdAPI as TFBClientAPI).LoadInterface then
328	>	FFirebirdAPI := nil;
329	>	end;
330	>
331	>	if FFirebirdAPI = nil then
332	>	begin
333	>	{now try Firebird 2.5. Under Unix we need to reload the library in case we
334	>	are to use the embedded library}
335	>	FFirebirdAPI := GetLegacyFirebirdAPI;
336	>	if FFirebirdAPI <> nil then
337		begin
338	<	// Non empty so set the variable
339	<	if setenv(name, value, 1)=0 then result:=true;
338	>	{$IFDEF UNIX}
339	>	FreeFBLibrary;
340	>	{$ENDIF}
341	>	if not LoadIBLibrary or not (FFirebirdAPI as TFBClientAPI).LoadInterface then
342	>	FFirebirdAPI := nil;
343		end;
344		end;
345	<	{$ENDIF}
345	>	{Note: FFirebirdAPI will be set to nil if the Firebird API fails to load}
346	>	end;
347
348	<	{ TFBClientAPI }
348	>	destructor TFBLibrary.Destroy;
349	>	begin
350	>	FreeFBLibrary;
351	>	FFirebirdAPI := nil;
352	>	inherited Destroy;
353	>	end;
354
355	<	constructor TFBClientAPI.Create;
355	>	class function TFBLibrary.GetFBLibrary(aLibPathName: string): IFirebirdLibrary;
356	>	var i: integer;
357		begin
358	<	inherited Create;
359	<	LoadIBLibrary;
314	<	if (IBLibrary <> NilHandle) then
358	>	Result := nil;
359	>	if aLibPathName <> '' then
360		begin
361	<	SetupEnvironment;
362	<	LoadInterface;
361	>	for i := 0 to Length(FLibraryList) - 1 do
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	<	FirebirdClientAPI := self;
371	>
372		end;
373
374	<	destructor TFBClientAPI.Destroy;
374	>	class procedure TFBLibrary.FreeLibraries;
375	>	var i: integer;
376		begin
377	<	FirebirdClientAPI := nil;
378	<	if FOwnsIBLibrary and (IBLibrary <> NilHandle) then
379	<	FreeLibrary(IBLibrary);
380	<	IBLibrary := NilHandle;
381	<	inherited Destroy;
377	>	for i := 0 to Length(FLibraryList) - 1 do
378	>	FLibraryList[i] := nil;
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;
390	>	end;
391	>
392	>	{ TFBClientAPI }
393	>
394	>	constructor TFBClientAPI.Create(aFBLibrary: TFBLibrary);
395	>	begin
396	>	inherited Create;
397	>	FFBLibrary := aFBLibrary;
398	>	GetTZDataSettings;
399		end;
400
401		procedure TFBClientAPI.IBAlloc(var P; OldSize, NewSize: Integer);
#	Line 341 | Line 411 | begin
411		raise EIBInterBaseError.Create(GetStatus);
412		end;
413
344	–	{Under Unixes, if using an embedded server then set up local TMP and LOCK Directories}
345	–
346	–	procedure TFBClientAPI.SetupEnvironment;
347	–	var TmpDir: AnsiString;
348	–	begin
349	–	{$IFDEF UNIX}
350	–	TmpDir := GetTempDir +
351	–	DirectorySeparator + 'firebird_' + sysutils.GetEnvironmentVariable('USER');
352	–	if sysutils.GetEnvironmentVariable('FIREBIRD_TMP') = '' then
353	–	begin
354	–	if not DirectoryExists(tmpDir) then
355	–	mkdir(tmpDir);
356	–	SetEnvironmentVariable('FIREBIRD_TMP',PAnsiChar(TmpDir));
357	–	end;
358	–	if sysutils.GetEnvironmentVariable('FIREBIRD_LOCK') = '' then
359	–	begin
360	–	if not DirectoryExists(tmpDir) then
361	–	mkdir(tmpDir);
362	–	SetEnvironmentVariable('FIREBIRD_LOCK',PAnsiChar(TmpDir));
363	–	end;
364	–	{$ENDIF}
365	–	end;
366	–
414		procedure TFBClientAPI.EncodeInteger(aValue: integer; len: integer; buffer: PByte);
415		begin
416		while len > 0 do
#	Line 375 | 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 := IBLibrary <> NilHandle;
457	>	Result := FFBLibrary.IBLibrary <> NilHandle;
458		end;
459
460	<	function TFBClientAPI.GetProcAddr(ProcName: PAnsiChar): Pointer;
460	>	function TFBClientAPI.GetFBLibrary: IFirebirdLibrary;
461		begin
462	<	Result := GetProcAddress(IBLibrary, ProcName);
386	<	if not Assigned(Result) then
387	<	raise Exception.CreateFmt(SFirebirdAPIFuncNotFound,[ProcName]);
462	>	Result := FFBLibrary;
463		end;
464
465	<	function TFBClientAPI.GetOverrideLibName: string;
465	>	function TFBClientAPI.FBTimeStampToDateTime(aDate, aTime: longint): TDateTime;
466		begin
467	<	Result := '';
468	<	if AllowUseOfFBLIB then
469	<	Result := GetEnvironmentVariable('FBLIB');
470	<	if Result = '' then
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	<	if assigned(OnGetLibraryName) then
490	<	OnGetLibraryName(Result)
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	<	procedure TFBClientAPI.LoadInterface;
501	>	{$IFDEF WINDOWS}
502	>	procedure TFBClientAPI.GetTZDataSettings;
503	>	var TZInfo: TTimeZoneInformation;
504		begin
505	<	isc_sqlcode := GetProcAddr('isc_sqlcode'); {do not localize}
506	<	isc_sql_interprete := GetProcAddr('isc_sql_interprete'); {do not localize}
507	<	isc_interprete := GetProcAddr('isc_interprete'); {do not localize}
508	<	isc_event_counts := GetProcAddr('isc_event_counts'); {do not localize}
509	<	isc_event_block := GetProcAddr('isc_event_block'); {do not localize}
510	<	isc_free := GetProcAddr('isc_free'); {do not localize}
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.GetLibraryName: string;
528	>	function TFBClientAPI.GetProcAddr(ProcName: PAnsiChar): Pointer;
529		begin
530	<	Result := FFBLibraryName;
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.GetCharsetName(CharSetID: integer): AnsiString;
537	>	function TFBClientAPI.HasDecFloatSupport: boolean;
538		begin
539	<	Result := '';
420	<	if (CharSetID >= Low(CharSetMap)) and (CharSetID <= High(CharSetMap)) and
421	<	(CharSetMap[CharSetID].CharSetID = CharSetID) then
422	<	begin
423	<	Result := CharSetMap[CharSetID].CharSetName;
424	<	Exit;
425	<	end;
539	>	Result := GetClientMajor >= 4;
540		end;
541
542	<	function TFBClientAPI.CharSetID2CodePage(CharSetID: integer;
429	<	var CodePage: TSystemCodePage): boolean;
542	>	function TFBClientAPI.HasInt128Support: boolean;
543		begin
544	<	Result := (CharSetID >= Low(CharSetMap)) and (CharSetID <= High(CharSetMap))
432	<	and (CharSetMap[CharSetID].CharSetID = CharSetID);
433	<	if Result then
434	<	begin
435	<	CodePage := CharSetMap[CharSetID].CodePage;
436	<	Result := true;
437	<	Exit;
438	<	end;
544	>	Result := false;
545		end;
546
547	<	function TFBClientAPI.CodePage2CharSetID(CodePage: TSystemCodePage;
442	<	var CharSetID: integer): boolean;
443	<	var i: integer;
547	>	function TFBClientAPI.HasLocalTZDB: boolean;
548		begin
549		Result := false;
446	–	for i := Low(CharSetMap) to High(CharSetMap) do
447	–	if CharSetMap[i].CodePage = CodePage then
448	–	begin
449	–	CharSetID := CharSetMap[i].CharSetID;
450	–	Result := true;
451	–	Exit;
452	–	end;
550		end;
551
552	<	function TFBClientAPI.CharSetName2CharSetID(CharSetName: AnsiString;
456	<	var CharSetID: integer): boolean;
457	<	var i: integer;
552	>	function TFBClientAPI.HasExtendedTZSupport: boolean;
553		begin
554		Result := false;
460	–	for i := Low(CharSetMap) to High(CharSetMap) do
461	–	if AnsiCompareStr(CharSetMap[i].CharSetName, CharSetName) = 0 then
462	–	begin
463	–	CharSetID := CharSetMap[i].CharSetID;
464	–	Result := true;
465	–	Exit;
466	–	end;
555		end;
556
557	<	function TFBClientAPI.CharSetWidth(CharSetID: integer; var Width: integer
470	<	): boolean;
557	>	function TFBClientAPI.HasTimeZoneSupport: boolean;
558		begin
559	<	Result := (CharSetID >= Low(CharSetMap)) and (CharSetID <= High(CharSetMap))
473	<	and (CharSetMap[CharSetID].CharSetID = CharSetID);
474	<	if Result then
475	<	begin
476	<	Width := CharSetMap[CharSetID].CharSetWidth;
477	<	Result := true;
478	<	Exit;
479	<	end;
559	>	Result := false;
560		end;
561
562	<	const
563	<	IBLocalBufferLength = 512;
564	<	IBBigLocalBufferLength = IBLocalBufferLength * 2;
565	<	IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;
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}
570	>	isc_sql_interprete := GetProcAddr('isc_sql_interprete'); {do not localize}
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 508 | Line 607 | function TFBStatus.GetMessage: AnsiStrin
607		var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
608		IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
609		sqlcode: Long;
511	–	psb: PStatusVector;
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
519	–	Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
617		if (ShowSQLMessage in IBDataBaseErrorMessages) then
618		begin
619		with FOwner do
620	<	isc_sql_interprete(sqlcode, local_buffer, IBLocalBufferLength);
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
627		begin
628		if (ShowSQLCode in IBDataBaseErrorMessages) or
629		(ShowSQLMessage in IBDataBaseErrorMessages) then
630	<	Result := Result + CRLF;
631	<	psb := StatusVector;
535	<	with FOwner do
536	<	while (isc_interprete(@local_buffer, @psb) > 0) do
537	<	begin
538	<	if (Result <> '') and (Result[Length(Result)] <> LF) then
539	<	Result := Result + CRLF;
540	<	Result := Result + strpas(local_buffer);
541	<	end;
630	>	Result := Result + LineEnding;
631	>	Result := Result + FOwner.FormatStatus(self);
632		end;
633		if (Result <> '') and (Result[Length(Result)] = '.') then
634		Delete(Result, Length(Result), 1);
#	Line 594 | Line 684 | begin
684		LeaveCriticalSection(TFBClientAPI.FIBCS);
685		end;
686		end;
687	+
688		initialization
689	<	TFBClientAPI.IBLibrary := NilHandle;
689	>	TFBLibrary.FEnvSetupDone := false;
690		{$IFNDEF FPC}
691		InitializeCriticalSection(TFBClientAPI.FIBCS);
692		{$ELSE}
#	Line 603 | Line 694 | initialization
694		{$ENDIF}
695
696		finalization
697	+	TFBLibrary.FreeLibraries;
698		{$IFNDEF FPC}
699		DeleteCriticalSection(TFBClientAPI.FIBCS);
700		{$ELSE}
701		DoneCriticalSection(TFBClientAPI.FIBCS);
702		{$ENDIF}
611	–	if TFBClientAPI.IBLibrary <> NilHandle then
612	–	begin
613	–	FreeLibrary(TFBClientAPI.IBLibrary);
614	–	TFBClientAPI.IBLibrary := NilHandle;
615	–	TFBClientAPI.FFBLibraryName := '';
616	–	end;
617	–
703		end.
704

Diff Legend

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