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 45 by tony, Tue Dec 6 10:33:46 2016 UTC vs.
Revision 56 by tony, Mon Mar 6 10:20:02 2017 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;
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	+	{$IFNDEF FPC}
94	+	type
95	+	TLibHandle = THandle;
96	+
97	+	const
98	+	NilHandle = 0;
99	+	DirectorySeparator = '\';
100	+	{$ENDIF}
101	+
102		type
103		TStatusVector              = array[0..19] of NativeInt;
104		PStatusVector              = ^TStatusVector;
#	Line 94 | Line 109 | type
109
110		TFBStatus = class(TFBInterfacedObject)
111		private
97	–	FIBCS: TRTLCriticalSection; static;
112		FIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
113		protected
114		FOwner: TFBClientAPI;
#	Line 105 | Line 119 | type
119		{IStatus}
120		function GetIBErrorCode: Long;
121		function Getsqlcode: Long;
122	<	function GetMessage: string;
122	>	function GetMessage: AnsiString;
123		function CheckStatusVector(ErrorCodes: array of TFBStatusCode): Boolean;
124		function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
125		procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
#	Line 116 | Line 130 | type
130		TFBClientAPI = class(TFBInterfacedObject)
131		private
132		FOwnsIBLibrary: boolean;
133	+	class var FIBCS: TRTLCriticalSection;
134		procedure LoadIBLibrary;
135		protected
136	<	FFBLibraryName: string; static;
137	<	FFBLibraryPath: string; static;
138	<	IBLibrary: TLibHandle; static;
139	<	function GetProcAddr(ProcName: PChar): Pointer;
136	>	class var FFBLibraryName: string;
137	>	class var IBLibrary: TLibHandle;
138	>	{$IFDEF WINDOWS}
139	>	class var FFBLibraryPath: string;
140	>	{$ENDIF}
141	>	function GetProcAddr(ProcName: PAnsiChar): Pointer;
142		function GetOverrideLibName: string;
143		{$IFDEF UNIX}
144		function GetFirebirdLibList: string; virtual; abstract;
#	Line 143 | Line 160 | type
160		procedure SetupEnvironment;
161
162		{Encode/Decode}
163	<	procedure EncodeInteger(aValue: integer; len: integer; buffer: PChar);
164	<	function DecodeInteger(bufptr: PChar; len: short): integer; virtual; abstract;
165	<	procedure SQLEncodeDate(aDate: TDateTime; bufptr: PChar); virtual; abstract;
166	<	function SQLDecodeDate(byfptr: PChar): TDateTime; virtual; abstract;
167	<	procedure SQLEncodeTime(aTime: TDateTime; bufptr: PChar); virtual; abstract;
168	<	function SQLDecodeTime(bufptr: PChar): TDateTime;  virtual; abstract;
169	<	procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PChar); virtual; abstract;
170	<	function SQLDecodeDateTime(bufptr: PChar): TDateTime; virtual; abstract;
163	>	procedure EncodeInteger(aValue: integer; len: integer; buffer: PByte);
164	>	function DecodeInteger(bufptr: PByte; len: short): integer; virtual; abstract;
165	>	procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte); virtual; abstract;
166	>	function SQLDecodeDate(byfptr: PByte): TDateTime; virtual; abstract;
167	>	procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte); virtual; abstract;
168	>	function SQLDecodeTime(bufptr: PByte): TDateTime;  virtual; abstract;
169	>	procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte); virtual; abstract;
170	>	function SQLDecodeDateTime(bufptr: PByte): TDateTime; virtual; abstract;
171
172
173		{IFirebirdAPI}
#	Line 158 | Line 175 | type
175		function IsLibraryLoaded: boolean;
176		function IsEmbeddedServer: boolean; virtual; abstract;
177		function GetLibraryName: string;
178	<	function GetCharsetName(CharSetID: integer): string;
178	>	function GetCharsetName(CharSetID: integer): AnsiString;
179		function CharSetID2CodePage(CharSetID: integer; var CodePage: TSystemCodePage): boolean;
180		function CodePage2CharSetID(CodePage: TSystemCodePage; var CharSetID: integer): boolean;
181	<	function CharSetName2CharSetID(CharSetName: string; var CharSetID: integer): boolean;
181	>	function CharSetName2CharSetID(CharSetName: AnsiString; var CharSetID: integer): boolean;
182		function CharSetWidth(CharSetID: integer; var Width: integer): boolean;
183		end;
184
185	<	const FirebirdClientAPI: TFBClientAPI = nil;
185	>	var FirebirdClientAPI: TFBClientAPI = nil;
186
187		implementation
188
189	<	uses IBUtils, {$IFDEF Unix} initc, {$ENDIF}
189	>	uses IBUtils, Registry, {$IFDEF Unix} initc, {$ENDIF}
190	>	{$IFDEF FPC}
191		{$IFDEF WINDOWS }
192	<	Windows,Registry, WinDirs,
192	>	WinDirs,
193	>	{$ENDIF}
194	>	{$ELSE}
195	>	ShlObj,
196		{$ENDIF}
197		SysUtils;
198
199		{$IFDEF UNIX}
200	<	{$I uloadlibrary.inc}
200	>	{$I 'include/uloadlibrary.inc'}
201		{$ELSE}
202	<	{$I wloadlibrary.inc}
202	>	{$I 'include/wloadlibrary.inc'}
203		{$ENDIF}
204
205		type
206		TCharsetMap = record
207		CharsetID: integer;
208	<	CharSetName: string;
208	>	CharSetName: AnsiString;
209		CharSetWidth: integer;
210		CodePage: TSystemCodePage;
211		end;
212
213		const
214		CharSetMap: array [0..69] of TCharsetMap = (
215	<	(CharsetID: 0; CharSetName: 'NONE'; CharSetWidth: 1; CodePage: CP_NONE),
215	>	(CharsetID: 0; CharSetName: 'NONE'; CharSetWidth: 1; CodePage: CP_ACP),
216		(CharsetID: 1; CharSetName: 'OCTETS'; CharSetWidth: 1; CodePage: CP_NONE),
217		(CharsetID: 2; CharSetName: 'ASCII'; CharSetWidth: 1; CodePage: CP_ASCII),
218		(CharsetID: 3; CharSetName: 'UNICODE_FSS'; CharSetWidth: 3; CodePage: CP_UTF8),
#	Line 267 | Line 288 | const
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:PChar; value:PChar):boolean;
291	>	function SetEnvironmentVariable(name:PAnsiChar; value:PAnsiChar):boolean;
292		// Set environment variable; if empty string given, remove it.
293		begin
294		result:=false; //assume failure
#	Line 302 | Line 323 | destructor TFBClientAPI.Destroy;
323		begin
324		FirebirdClientAPI := nil;
325		if FOwnsIBLibrary and (IBLibrary <> NilHandle) then
326	<	UnloadLibrary(IBLibrary);
326	>	FreeLibrary(IBLibrary);
327		IBLibrary := NilHandle;
328		inherited Destroy;
329		end;
#	Line 312 | Line 333 | var
333		i: Integer;
334		begin
335		ReallocMem(Pointer(P), NewSize);
336	<	for i := OldSize to NewSize - 1 do PChar(P)[i] := #0;
336	>	for i := OldSize to NewSize - 1 do PAnsiChar(P)[i] := #0;
337		end;
338
339		procedure TFBClientAPI.IBDataBaseError;
#	Line 323 | Line 344 | end;
344		{Under Unixes, if using an embedded server then set up local TMP and LOCK Directories}
345
346		procedure TFBClientAPI.SetupEnvironment;
347	<	var TmpDir: string;
347	>	var TmpDir: AnsiString;
348		begin
349		{$IFDEF UNIX}
350		TmpDir := GetTempDir +
#	Line 332 | Line 353 | begin
353		begin
354		if not DirectoryExists(tmpDir) then
355		mkdir(tmpDir);
356	<	SetEnvironmentVariable('FIREBIRD_TMP',PChar(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',PChar(TmpDir));
362	>	SetEnvironmentVariable('FIREBIRD_LOCK',PAnsiChar(TmpDir));
363		end;
364		{$ENDIF}
365		end;
366
367	<	procedure TFBClientAPI.EncodeInteger(aValue: integer; len: integer; buffer: PChar);
367	>	procedure TFBClientAPI.EncodeInteger(aValue: integer; len: integer; buffer: PByte);
368		begin
369		while len > 0 do
370		begin
371	<	buffer^ := char(aValue and $FF);
371	>	buffer^ := aValue and $FF;
372		Inc(buffer);
373		Dec(len);
374		aValue := aValue shr 8;
#	Line 359 | Line 380 | begin
380		Result := IBLibrary <> NilHandle;
381		end;
382
383	<	function TFBClientAPI.GetProcAddr(ProcName: PChar): Pointer;
383	>	function TFBClientAPI.GetProcAddr(ProcName: PAnsiChar): Pointer;
384		begin
385		Result := GetProcAddress(IBLibrary, ProcName);
386		if not Assigned(Result) then
#	Line 393 | Line 414 | begin
414		Result := FFBLibraryName;
415		end;
416
417	<	function TFBClientAPI.GetCharsetName(CharSetID: integer): string;
417	>	function TFBClientAPI.GetCharsetName(CharSetID: integer): AnsiString;
418		begin
419		Result := '';
420		if (CharSetID >= Low(CharSetMap)) and (CharSetID <= High(CharSetMap)) and
#	Line 431 | Line 452 | begin
452		end;
453		end;
454
455	<	function TFBClientAPI.CharSetName2CharSetID(CharSetName: string;
455	>	function TFBClientAPI.CharSetName2CharSetID(CharSetName: AnsiString;
456		var CharSetID: integer): boolean;
457		var i: integer;
458		begin
459		Result := false;
460		for i := Low(CharSetMap) to High(CharSetMap) do
461	<	if CompareStr(CharSetMap[i].CharSetName, CharSetName) = 0 then
461	>	if AnsiCompareStr(CharSetMap[i].CharSetName, CharSetName) = 0 then
462		begin
463		CharSetID := CharSetMap[i].CharSetID;
464		Result := true;
#	Line 483 | Line 504 | begin
504		Result := isc_sqlcode(PISC_STATUS(StatusVector));
505		end;
506
507	<	function TFBStatus.GetMessage: string;
508	<	var local_buffer: array[0..IBHugeLocalBufferLength - 1] of char;
507	>	function TFBStatus.GetMessage: AnsiString;
508	>	var local_buffer: array[0..IBHugeLocalBufferLength - 1] of AnsiChar;
509		IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
510		sqlcode: Long;
511		psb: PStatusVector;
#	Line 530 | Line 551 | var
551		i: Integer;
552		procedure NextP(i: Integer);
553		begin
554	<	p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
554	>	p := PISC_STATUS(PAnsiChar(p) + (i * SizeOf(ISC_STATUS)));
555		end;
556		begin
557		p := PISC_STATUS(StatusVector);
#	Line 556 | Line 577 | end;
577
578		function TFBStatus.GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
579		begin
580	<	EnterCriticalSection(FIBCS);
580	>	EnterCriticalSection(TFBClientAPI.FIBCS);
581		try
582		result := FIBDataBaseErrorMessages;
583		finally
584	<	LeaveCriticalSection(FIBCS);
584	>	LeaveCriticalSection(TFBClientAPI.FIBCS);
585		end;
586		end;
587
588		procedure TFBStatus.SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
589		begin
590	<	EnterCriticalSection(FIBCS);
590	>	EnterCriticalSection(TFBClientAPI.FIBCS);
591		try
592		FIBDataBaseErrorMessages := Value;
593		finally
594	<	LeaveCriticalSection(FIBCS);
594	>	LeaveCriticalSection(TFBClientAPI.FIBCS);
595		end;
596		end;
597		initialization
598		TFBClientAPI.IBLibrary := NilHandle;
599	<	InitCriticalSection(TFBStatus.FIBCS);
599	>	{$IFNDEF FPC}
600	>	InitializeCriticalSection(TFBClientAPI.FIBCS);
601	>	{$ELSE}
602	>	InitCriticalSection(TFBClientAPI.FIBCS);
603	>	{$ENDIF}
604
605		finalization
606	<	DoneCriticalSection(TFBStatus.FIBCS);
606	>	{$IFNDEF FPC}
607	>	DeleteCriticalSection(TFBClientAPI.FIBCS);
608	>	{$ELSE}
609	>	DoneCriticalSection(TFBClientAPI.FIBCS);
610	>	{$ENDIF}
611		if TFBClientAPI.IBLibrary <> NilHandle then
612		begin
613		FreeLibrary(TFBClientAPI.IBLibrary);

Diff Legend

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