aksdb
/
restemplate
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
restemplate/indy/System/IdWship6.pas

1528 lines
48 KiB
Plaintext
Raw Normal View History

* Replaced fphttpclient with indy10. * Added compression support
2015-10-04 14:14:55 +02:00
{
$Project$
$Workfile$
$Revision$
$DateUTC$
$Id$
This file is part of the Indy (Internet Direct) project, and is offered
under the dual-licensing agreement described on the Indy website.
(http://www.indyproject.org/)
Copyright:
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
}
{
$Log$
}
{
Rev 1.0 2004.02.03 3:14:52 PM czhower
Move and updates
Rev 1.2 10/15/2003 9:43:20 PM DSiders
Added localization comments.
Rev 1.1 1-10-2003 19:44:28 BGooijen
fixed leak in CloseLibrary()
Rev 1.0 11/13/2002 09:03:24 AM JPMugaas
}
unit IdWship6;
interface
{$I IdCompilerDefines.inc}
{$IFDEF FPC}
{$IFDEF WIN32}
{$ALIGN OFF}
{$ELSE}
//It turns out that Win64 and WinCE require record alignment
{$PACKRECORDS C}
{$ENDIF}
{$ELSE}
{$IFDEF WIN64}
{$ALIGN ON}
{$MINENUMSIZE 4}
{$ELSE}
{$MINENUMSIZE 4}
{$IFDEF REQUIRES_PROPER_ALIGNMENT}
{$ALIGN ON}
{$ELSE}
{$ALIGN OFF}
{$WRITEABLECONST OFF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
uses
{$IFDEF HAS_TInterlocked}
syncobjs, //here to facilitate inlining with Delphi
{$ENDIF}
{$IFNDEF HAS_SIZE_T}
IdGlobal,
{$ENDIF}
Windows,
IdWinsock2;
const
Wship6_dll = 'Wship6.dll'; {do not localize}
iphlpapi_dll = 'iphlpapi.dll'; {do not localize}
fwpuclnt_dll = 'Fwpuclnt.dll'; {Do not localize}
// Error codes from getaddrinfo().
//JPM
//Note that I am adding a GIA_ prefix on my own because
//some names here share some names defined in IdWinsock2 causing
//an unpredictible problem. The values are not defined the same in IdWinsock2
{$EXTERNALSYM GIA_EAI_ADDRFAMILY}
GIA_EAI_ADDRFAMILY = 1 ; // Address family for nodename not supported.
{$EXTERNALSYM GIA_EAI_AGAIN}
GIA_EAI_AGAIN = 2 ; // Temporary failure in name resolution.
{$EXTERNALSYM GIA_EAI_BADFLAGS}
GIA_EAI_BADFLAGS = 3 ; // Invalid value for ai_flags.
{$EXTERNALSYM GIA_EAI_FAIL}
GIA_EAI_FAIL = 4 ; // Non-recoverable failure in name resolution.
{$EXTERNALSYM GIA_EAI_FAMILY}
GIA_EAI_FAMILY = 5 ; // Address family ai_family not supported.
{$EXTERNALSYM GIA_EAI_MEMORY}
GIA_EAI_MEMORY = 6 ; // Memory allocation failure.
{$EXTERNALSYM GIA_EAI_NODATA}
GIA_EAI_NODATA = 7 ; // No address associated with nodename.
{$EXTERNALSYM GIA_EAI_NONAME}
GIA_EAI_NONAME = 8 ; // Nodename nor servname provided, or not known.
{$EXTERNALSYM GIA_EAI_SERVICE}
GIA_EAI_SERVICE = 9 ; // Servname not supported for ai_socktype.
{$EXTERNALSYM GIA_EAI_SOCKTYPE}
GIA_EAI_SOCKTYPE = 10 ; // Socket type ai_socktype not supported.
{$EXTERNALSYM GIA_EAI_SYSTEM}
GIA_EAI_SYSTEM = 11 ; // System error returned in errno.
{$EXTERNALSYM NI_MAXHOST}
NI_MAXHOST = 1025; // Max size of a fully-qualified domain name.
{$EXTERNALSYM NI_MAXSERV}
NI_MAXSERV = 32; // Max size of a service name.
// Flags for getnameinfo().
{$EXTERNALSYM NI_NOFQDN}
NI_NOFQDN = $1 ; // Only return nodename portion for local hosts.
{$EXTERNALSYM NI_NUMERICHOST}
NI_NUMERICHOST = $2 ; // Return numeric form of the host's address.
{$EXTERNALSYM NI_NAMEREQD}
NI_NAMEREQD = $4 ; // Error if the host's name not in DNS.
{$EXTERNALSYM NI_NUMERICSERV}
NI_NUMERICSERV = $8 ; // Return numeric form of the service (port #).
{$EXTERNALSYM NI_DGRAM}
NI_DGRAM = $10 ; // Service is a datagram service.
//JPM - These may not be supported in WinCE 4.2
{$EXTERNALSYM PROTECTION_LEVEL_RESTRICTED}
PROTECTION_LEVEL_RESTRICTED = 30; //* for Intranet apps /*
{$EXTERNALSYM PROTECTION_LEVEL_DEFAULT}
PROTECTION_LEVEL_DEFAULT = 20; //* default level /*
{$EXTERNALSYM PROTECTION_LEVEL_UNRESTRICTED}
PROTECTION_LEVEL_UNRESTRICTED = 10; //* for peer-to-peer apps /*
{$EXTERNALSYM SOCKET_SETTINGS_GUARANTEE_ENCRYPTION}
SOCKET_SETTINGS_GUARANTEE_ENCRYPTION = $00000001;
{$EXTERNALSYM SOCKET_SETTINGS_ALLOW_INSECURE}
SOCKET_SETTINGS_ALLOW_INSECURE = $00000002;
{$EXTERNALSYM SOCKET_INFO_CONNECTION_SECURED}
SOCKET_INFO_CONNECTION_SECURED = $00000001;
{$EXTERNALSYM SOCKET_INFO_CONNECTION_ENCRYPTED}
SOCKET_INFO_CONNECTION_ENCRYPTED = $00000002;
type
// RLebeau: find a better place for this
{$IFNDEF HAS_UInt64}
{$EXTERNALSYM UINT64}
UINT64 = {$IFDEF HAS_QWord}QWord{$ELSE}Int64{$ENDIF};
{$ENDIF}
{$NODEFINE PPaddrinfo}
PPaddrinfo = ^PAddrInfo;
{$NODEFINE PPaddrinfoW}
PPaddrinfoW = ^PAddrInfoW;
{$IFNDEF WINCE}
{$EXTERNALSYM SOCKET_SECURITY_PROTOCOL}
{$EXTERNALSYM SOCKET_SECURITY_PROTOCOL_DEFAULT}
{$EXTERNALSYM SOCKET_SECURITY_PROTOCOL_IPSEC}
{$EXTERNALSYM SOCKET_SECURITY_PROTOCOL_INVALID}
SOCKET_SECURITY_PROTOCOL = (
SOCKET_SECURITY_PROTOCOL_DEFAULT, SOCKET_SECURITY_PROTOCOL_IPSEC, SOCKET_SECURITY_PROTOCOL_INVALID
);
{$EXTERNALSYM SOCKET_SECURITY_SETTINGS_IPSEC}
SOCKET_SECURITY_SETTINGS_IPSEC = record
SecurityProtocol : SOCKET_SECURITY_PROTOCOL;
SecurityFlags : ULONG;
IpsecFlags : ULONG;
AuthipMMPolicyKey : TGUID;
AuthipQMPolicyKey : TGUID;
Reserved : TGUID;
Reserved2 : UINT64;
UserNameStringLen : ULONG;
DomainNameStringLen : ULONG;
PasswordStringLen : ULONG;
// wchar_t AllStrings[0];
end;
{$EXTERNALSYM PSOCKET_SECURITY_SETTINGS_IPSEC}
PSOCKET_SECURITY_SETTINGS_IPSEC = ^SOCKET_SECURITY_SETTINGS_IPSEC;
{$EXTERNALSYM SOCKET_SECURITY_SETTINGS}
SOCKET_SECURITY_SETTINGS = record
SecurityProtocol : SOCKET_SECURITY_PROTOCOL;
SecurityFlags : ULONG;
end;
{$EXTERNALSYM PSOCKET_SECURITY_SETTINGS}
PSOCKET_SECURITY_SETTINGS = ^SOCKET_SECURITY_SETTINGS;
{$EXTERNALSYM SOCKET_PEER_TARGET_NAME}
SOCKET_PEER_TARGET_NAME = record
SecurityProtocol : SOCKET_SECURITY_PROTOCOL;
PeerAddress : SOCKADDR_STORAGE;
PeerTargetNameStringLen : ULONG;
//wchar_t AllStrings[0];
end;
{$EXTERNALSYM PSOCKET_PEER_TARGET_NAME}
PSOCKET_PEER_TARGET_NAME = ^SOCKET_PEER_TARGET_NAME;
{$EXTERNALSYM SOCKET_SECURITY_QUERY_INFO}
SOCKET_SECURITY_QUERY_INFO = record
SecurityProtocol : SOCKET_SECURITY_PROTOCOL;
Flags : ULONG;
PeerApplicationAccessTokenHandle : UINT64;
PeerMachineAccessTokenHandle : UINT64;
end;
{$EXTERNALSYM PSOCKET_SECURITY_QUERY_INFO}
PSOCKET_SECURITY_QUERY_INFO = ^SOCKET_SECURITY_QUERY_INFO;
{$EXTERNALSYM SOCKET_SECURITY_QUERY_TEMPLATE}
SOCKET_SECURITY_QUERY_TEMPLATE = record
SecurityProtocol : SOCKET_SECURITY_PROTOCOL;
PeerAddress : SOCKADDR_STORAGE;
PeerTokenAccessMask : ULONG;
end;
{$EXTERNALSYM PSOCKET_SECURITY_QUERY_TEMPLATE}
PSOCKET_SECURITY_QUERY_TEMPLATE = ^SOCKET_SECURITY_QUERY_TEMPLATE;
//callback defs
type
{$EXTERNALSYM LPLOOKUPSERVICE_COMPLETION_ROUTINE}
LPLOOKUPSERVICE_COMPLETION_ROUTINE = procedure (const dwError, dwBytes : DWORD; lpOverlapped : LPWSAOVERLAPPED); stdcall;
{$ENDIF}
type
{$EXTERNALSYM LPFN_GETADDRINFO}
LPFN_GETADDRINFO = function(NodeName: PAnsiChar; ServiceName: PAnsiChar; Hints: Paddrinfo; ppResult: PPaddrinfo): Integer; stdcall;
{$EXTERNALSYM LPFN_GETADDRINFOW}
LPFN_GETADDRINFOW = function(NodeName: PWideChar; ServiceName: PWideChar; Hints: PaddrinfoW; ppResult: PPaddrinfoW): Integer; stdcall;
{$EXTERNALSYM LPFN_GETNAMEINFO}
//The IPv6 preview for Win2K defines hostlen and servelen as size_t but do not use them
//for these definitions as the newer SDK's define those as DWORD.
LPFN_GETNAMEINFO = function(sa: psockaddr; salen: u_int; host: PAnsiChar; hostlen: u_int; serv: PAnsiChar; servlen: u_int; flags: Integer): Integer; stdcall;
{$EXTERNALSYM LPFN_GETNAMEINFOW}
LPFN_GETNAMEINFOW = function(sa: psockaddr; salen: u_int; host: PWideChar; hostlen: u_int; serv: PWideChar; servlen: u_int; flags: Integer): Integer; stdcall;
{$EXTERNALSYM LPFN_FREEADDRINFO}
LPFN_FREEADDRINFO = procedure(ai: Paddrinfo); stdcall;
{$EXTERNALSYM LPFN_FREEADDRINFOW}
LPFN_FREEADDRINFOW = procedure(ai: PaddrinfoW); stdcall;
//function GetAdaptersAddresses( Family:ULONG; Flags:ULONG; Reserved:Pointer; pAdapterAddresses: PIP_ADAPTER_ADDRESSES; pOutBufLen:PULONG):ULONG;stdcall; external iphlpapi_dll;
{ the following are not used, nor tested}
{function getipnodebyaddr(const src:pointer; len:integer; af:integer;var error_num:integer) :phostent;stdcall; external Wship6_dll;
procedure freehostent(ptr:phostent);stdcall; external Wship6_dll;
function inet_pton(af:integer; const src:pchar; dst:pointer):integer;stdcall; external Wship6_dll;
function inet_ntop(af:integer; const src:pointer; dst:pchar;size:integer):pchar;stdcall; external Wship6_dll;
}
{$IFNDEF WINCE}
{$EXTERNALSYM LPFN_INET_PTON}
LPFN_INET_PTON = function (af: Integer; const src: PAnsiChar; dst: Pointer): Integer; stdcall;
{$EXTERNALSYM LPFN_INET_PTONW}
LPFN_INET_PTONW = function (af: Integer; const src: PWideChar; dst: Pointer): Integer; stdcall;
{$EXTERNALSYM LPFN_INET_NTOP}
LPFN_INET_NTOP = function (af: Integer; const src: Pointer; dst: PAnsiChar; size: size_t): PAnsiChar; stdcall;
{$EXTERNALSYM LPFN_INET_NTOPW}
LPFN_INET_NTOPW = function (af: Integer; const src: Pointer; dst: PWideChar; size: size_t): PAnsiChar; stdcall;
{ end the following are not used, nor tested}
//These are provided in case we need them later
//Windows Vista
{$EXTERNALSYM LPFN_GETADDRINFOEXA}
LPFN_GETADDRINFOEXA = function(pName : PAnsiChar; pServiceName : PAnsiChar;
const dwNameSpace: DWord; lpNspId : LPGUID; hints : PADDRINFOEXA;
var ppResult : PADDRINFOEXA; timeout : Ptimeval; lpOverlapped : LPWSAOVERLAPPED;
lpCompletionRoutine : LPLOOKUPSERVICE_COMPLETION_ROUTINE;
lpNameHandle : PHandle) : Integer; stdcall;
{$EXTERNALSYM LPFN_GETADDRINFOEXW}
LPFN_GETADDRINFOEXW = function(pName : PWideChar; pServiceName : PWideChar;
const dwNameSpace: DWord; lpNspId : LPGUID;hints : PADDRINFOEXW;
var ppResult : PADDRINFOEXW; timeout : Ptimeval; lpOverlapped : LPWSAOVERLAPPED;
lpCompletionRoutine : LPLOOKUPSERVICE_COMPLETION_ROUTINE;
lpNameHandle : PHandle) : Integer; stdcall;
{$EXTERNALSYM LPFN_SETADDRINFOEXA}
LPFN_SETADDRINFOEXA= function(pName : PAnsiChar; pServiceName : PAnsiChar;
pAddresses : PSOCKET_ADDRESS; const dwAddressCount : DWord; lpBlob : LPBLOB;
const dwFlags : DWord; const dwNameSpace : DWord; lpNspId : LPGUID;
timeout : Ptimeval;
lpOverlapped : LPWSAOVERLAPPED;
lpCompletionRoutine : LPLOOKUPSERVICE_COMPLETION_ROUTINE; lpNameHandle : PHandle) : Integer; stdcall;
{$EXTERNALSYM LPFN_SETADDRINFOEXW}
LPFN_SETADDRINFOEXW= function(pName : PWideChar; pServiceName : PWideChar;
pAddresses : PSOCKET_ADDRESS; const dwAddressCount : DWord; lpBlob : LPBLOB;
const dwFlags : DWord; const dwNameSpace : DWord; lpNspId : LPGUID;
timeout : Ptimeval;
lpOverlapped : LPWSAOVERLAPPED;
lpCompletionRoutine : LPLOOKUPSERVICE_COMPLETION_ROUTINE; lpNameHandle : PHandle) : Integer; stdcall;
{$EXTERNALSYM LPFN_FREEADDRINFOEX}
LPFN_FREEADDRINFOEX = procedure(pAddrInfoEx : PADDRINFOEXA) ; stdcall;
{$EXTERNALSYM LPFN_FREEADDRINFOEXW}
LPFN_FREEADDRINFOEXW = procedure(pAddrInfoEx : PADDRINFOEXW) ; stdcall;
{$EXTERNALSYM LPFN_GETADDRINFOEX}
{$EXTERNALSYM LPFN_SETADDRINFOEX}
{$IFDEF UNICODE}
LPFN_GETADDRINFOEX = LPFN_GETADDRINFOEXW;
LPFN_SETADDRINFOEX = LPFN_SETADDRINFOEXW;
{$ELSE}
LPFN_GETADDRINFOEX = LPFN_GETADDRINFOEXA;
LPFN_SETADDRINFOEX = LPFN_SETADDRINFOEXA;
{$ENDIF}
// Fwpuclnt.dll - API
{$EXTERNALSYM LPFN_WSASetSocketSecurity}
LPFN_WSASetSocketSecurity = function (socket : TSocket;
SecuritySettings : PSOCKET_SECURITY_SETTINGS; const SecuritySettingsLen : ULONG;
OVERLAPPED : LPWSAOVERLAPPED; CompletionRoutine : LPWSAOVERLAPPED_COMPLETION_ROUTINE) : Integer; stdcall;
{$EXTERNALSYM LPFN_WSADELETESOCKETPEERTARGETNAME}
LPFN_WSADELETESOCKETPEERTARGETNAME = function (Socket : TSocket;
PeerAddr : Psockaddr; PeerAddrLen : ULONG;
Overlapped : LPWSAOVERLAPPED; CompletionRoutine : LPWSAOVERLAPPED_COMPLETION_ROUTINE): Integer; stdcall;
{$EXTERNALSYM LPFN_WSASETSOCKETPEERTARGETNAME}
LPFN_WSASETSOCKETPEERTARGETNAME = function (Socket : TSocket;
PeerTargetName : PSOCKET_PEER_TARGET_NAME; PeerTargetNameLen : ULONG;
Overlapped : LPWSAOVERLAPPED; CompletionRoutine : LPWSAOVERLAPPED_COMPLETION_ROUTINE) : Integer; stdcall;
{$EXTERNALSYM LPFN_WSAIMPERSONATESOCKETPEER}
LPFN_WSAIMPERSONATESOCKETPEER = function (Socket : TSocket;
PeerAddress : Psockaddr; peerAddressLen : ULONG) : Integer; stdcall;
{$EXTERNALSYM LPFN_WSAQUERYSOCKETSECURITY}
LPFN_WSAQUERYSOCKETSECURITY = function (Socket : TSocket;
SecurityQueryTemplate : PSOCKET_SECURITY_QUERY_TEMPLATE; const SecurityQueryTemplateLen : ULONG;
SecurityQueryInfo : PSOCKET_SECURITY_QUERY_INFO; var SecurityQueryInfoLen : ULONG;
Overlapped : LPWSAOVERLAPPED; CompletionRoutine : LPWSAOVERLAPPED_COMPLETION_ROUTINE) : Integer; stdcall;
{$EXTERNALSYM LPFN_WSAREVERTIMPERSONATION}
LPFN_WSAREVERTIMPERSONATION = function : Integer; stdcall;
{$ENDIF}
const
{$NODEFINE fn_GetAddrInfo}
{$NODEFINE fn_getnameinfo}
{$NODEFINE fn_freeaddrinfo}
{$IFNDEF WINCE}
{$NODEFINE fn_GetAddrInfoEx}
{$NODEFINE fn_SetAddrInfoEx}
{$NODEFINE fn_FreeAddrInfoEx}
{$NODEFINE fn_inet_pton}
{$NODEFINE fn_inet_ntop}
{$ENDIF}
{$IFDEF UNICODE}
// WinCE does not support GetAddrInfoW(), GetNameInfoW(), or FreeAddrInfoW().
// To support IPv6 on WinCE when UNICODE is defined, we will use our own
// wrappers that internally call WinCE's functions...
fn_GetAddrInfo = {$IFDEF WINCE}'getaddrinfo'{$ELSE}'GetAddrInfoW'{$ENDIF};
fn_getnameinfo = {$IFDEF WINCE}'getnameinfo'{$ELSE}'GetNameInfoW'{$ENDIF};
fn_freeaddrinfo = {$IFDEF WINCE}'freeaddrinfo'{$ELSE}'FreeAddrInfoW'{$ENDIF};
{$IFNDEF WINCE}
fn_GetAddrInfoEx = 'GetAddrInfoExW';
fn_SetAddrInfoEx = 'SetAddrInfoExW';
fn_FreeAddrInfoEx = 'FreeAddrInfoExW';
fn_inet_pton = 'InetPtonW';
fn_inet_ntop = 'InetNtopW';
{$ENDIF}
{$ELSE}
fn_GetAddrInfo = 'getaddrinfo';
fn_getnameinfo = 'getnameinfo';
fn_freeaddrinfo = 'freeaddrinfo';
{$IFNDEF WINCE}
fn_GetAddrInfoEx = 'GetAddrInfoExA';
fn_SetAddrInfoEx = 'SetAddrInfoExA';
fn_FreeAddrInfoEx = 'FreeAddrInfoEx';
fn_inet_pton = 'inet_pton';
fn_inet_ntop = 'inet_ntop';
{$ENDIF}
{$ENDIF}
{$UNDEF WINCE_UNICODE}
{$IFDEF WINCE}
{$IFDEF UNICODE}
{$DEFINE WINCE_UNICODE}
{$ENDIF}
{$ENDIF}
var
{$EXTERNALSYM getaddrinfo}
{$EXTERNALSYM getnameinfo}
{$EXTERNALSYM freeaddrinfo}
{$IFNDEF WINCE}
{$EXTERNALSYM inet_pton}
{$EXTERNALSYM inet_ntop}
{$ENDIF}
{$IFDEF UNICODE}
{$IFDEF WINCE}
getaddrinfoCE: LPFN_GETADDRINFO = nil;
getnameinfoCE: LPFN_GETNAMEINFO = nil;
freeaddrinfoCE: LPFN_FREEADDRINFO = nil;
{$ENDIF}
getaddrinfo: LPFN_GETADDRINFOW = nil;
getnameinfo: LPFN_GETNAMEINFOW = nil;
freeaddrinfo: LPFN_FREEADDRINFOW = nil;
{$IFNDEF WINCE}
//These are here for completeness
inet_pton : LPFN_inet_ptonW = nil;
inet_ntop : LPFN_inet_ntopW = nil;
{$ENDIF}
{$ELSE}
getaddrinfo: LPFN_GETADDRINFO = nil;
getnameinfo: LPFN_GETNAMEINFO = nil;
freeaddrinfo: LPFN_FREEADDRINFO = nil;
{$IFNDEF WINCE}
//These are here for completeness
inet_pton : LPFN_inet_pton = nil;
inet_ntop : LPFN_inet_ntop = nil;
{$ENDIF}
{$ENDIF}
{$IFNDEF WINCE}
{
IMPORTANT!!!
These are Windows Vista functions and there's no guarantee that you will have
them so ALWAYS check the function pointer before calling them.
}
{$EXTERNALSYM GetAddrInfoEx}
GetAddrInfoEx : LPFN_GETADDRINFOEX = nil;
{$EXTERNALSYM SetAddrInfoEx}
SetAddrInfoEx : LPFN_SETADDRINFOEX = nil;
{$EXTERNALSYM FreeAddrInfoEx}
//You can't alias the LPFN for this because the ASCII version of this
//does not end with an "a"
{$IFDEF UNICODE}
FreeAddrInfoEx : LPFN_FREEADDRINFOEXW = nil;
{$ELSE}
FreeAddrInfoEx : LPFN_FREEADDRINFOEX = nil;
{$ENDIF}
//Fwpuclnt.dll available for Windows Vista and later
{$EXTERNALSYM WSASetSocketSecurity}
WSASetSocketSecurity : LPFN_WSASetSocketSecurity = nil;
{$EXTERNALSYM WSASETSOCKETPEERTARGETNAME}
WSASetSocketPeerTargetName : LPFN_WSASETSOCKETPEERTARGETNAME = nil;
{$EXTERNALSYM WSADELETESOCKETPEERTARGETNAME}
WSADeleteSocketPeerTargetName : LPFN_WSADELETESOCKETPEERTARGETNAME = nil;
{$EXTERNALSYM WSAImpersonateSocketPeer}
WSAImpersonateSocketPeer : LPFN_WSAIMPERSONATESOCKETPEER = nil;
{$EXTERNALSYM WSAQUERYSOCKETSECURITY}
WSAQUERYSOCKETSECURITY : LPFN_WSAQUERYSOCKETSECURITY = nil;
{$EXTERNALSYM WSAREVERTIMPERSONATION}
WSARevertImpersonation : LPFN_WSAREVERTIMPERSONATION = nil;
{$ENDIF}
var
GIdIPv6FuncsAvailable: Boolean = False {$IFDEF HAS_DEPRECATED}deprecated{$ENDIF};
function gaiErrorToWsaError(const gaiError: Integer): Integer;
//We want to load this library only after loading Winsock and unload immediately
//before unloading Winsock.
procedure InitLibrary;
procedure CloseLibrary;
implementation
uses
SysUtils
{$IFDEF HAS_SIZE_T}
, IdGlobal
{$ENDIF};
var
hWship6Dll : THandle = 0; // Wship6.dll handle
//Use this instead of hWship6Dll because this will point to the correct lib.
hProcHandle : THandle = 0;
{$IFNDEF WINCE}
hfwpuclntDll : THandle = 0;
{$ENDIF}
function gaiErrorToWsaError(const gaiError: Integer): Integer;
begin
case gaiError of
GIA_EAI_ADDRFAMILY: Result := 0; // TODO: find a decent error for here
GIA_EAI_AGAIN: Result := WSATRY_AGAIN;
GIA_EAI_BADFLAGS: Result := WSAEINVAL;
GIA_EAI_FAIL: Result := WSANO_RECOVERY;
GIA_EAI_FAMILY: Result := WSAEAFNOSUPPORT;
GIA_EAI_MEMORY: Result := WSA_NOT_ENOUGH_MEMORY;
GIA_EAI_NODATA: Result := WSANO_DATA;
GIA_EAI_NONAME: Result := WSAHOST_NOT_FOUND;
GIA_EAI_SERVICE: Result := WSATYPE_NOT_FOUND;
GIA_EAI_SOCKTYPE: Result := WSAESOCKTNOSUPPORT;
GIA_EAI_SYSTEM:
begin
Result := 0; // avoid warning
IndyRaiseLastError;
end;
else
Result := gaiError;
end;
end;
procedure CloseLibrary;
var
h : THandle;
begin
h := InterlockedExchangeTHandle(hWship6Dll, 0);
if h <> 0 then begin
FreeLibrary(h);
end;
{$IFNDEF WINCE}
h := InterlockedExchangeTHandle(hfwpuclntDll, 0);
if h <> 0 then begin
FreeLibrary(h);
end;
{$ENDIF}
{$I IdSymbolDeprecatedOff.inc}
GIdIPv6FuncsAvailable := False;
{$I IdSymbolDeprecatedOn.inc}
{$IFDEF WINCE_UNICODE}
getaddrinfoCE := nil;
getnameinfoCE := nil;
freeaddrinfoCE := nil;
{$ENDIF}
getaddrinfo := nil;
getnameinfo := nil;
freeaddrinfo := nil;
{$IFNDEF WINCE}
inet_pton := nil;
inet_ntop := nil;
GetAddrInfoEx := nil;
SetAddrInfoEx := nil;
FreeAddrInfoEx := nil;
WSASetSocketPeerTargetName := nil;
WSADeleteSocketPeerTargetName := nil;
WSAImpersonateSocketPeer := nil;
WSAQuerySocketSecurity := nil;
WSARevertImpersonation := nil;
{$ENDIF}
end;
{$IFDEF FPC} //{$IFDEF STRING_IS_ANSI}
{$IFDEF UNICODE}
// FreePascal does not have PWideChar overloads of these functions
function StrComp(const Str1, Str2: PWideChar): Integer; overload;
var
P1, P2: PWideChar;
begin
P1 := Str1;
P2 := Str2;
while True do
begin
if (P1^ <> P2^) or (P1^ = #0) then
begin
Result := Ord(P1^) - Ord(P2^);
Exit;
end;
Inc(P1);
Inc(P2);
end;
Result := 0;
end;
function StrScan(const Str: PWideChar; Chr: WideChar): PWideChar; overload;
begin
Result := Str;
while Result^ <> #0 do
begin
if Result^ = Chr then begin
Exit;
end;
Inc(Result);
end;
if Chr <> #0 then begin
Result := nil;
end;
end;
{$ENDIF}
{$ENDIF}
// The IPv6 functions were added to the Ws2_32.dll on Windows XP and later.
// To execute an application that uses these functions on earlier versions of
// Windows, the functions are defined as inline functions in the Wspiapi.h file.
// At runtime, the functions are implemented in such a way that if the Ws2_32.dll
// or the Wship6.dll (the file containing the functions in the IPv6 Technology
// Preview for Windows 2000) does not include them, then versions are implemented
// inline based on code in the Wspiapi.h header file. This inline code will be
// used on older Windows platforms that do not natively support the functions.
// RLebeau: Wspiapi.h only defines Ansi versions of the legacy functions, but we
// need to handle Unicode as well...
function WspiapiMalloc(tSize: size_t): Pointer;
begin
try
GetMem(Result, tSize);
ZeroMemory(Result, tSize);
except
Result := nil;
end;
end;
procedure WspiapiFree(p: Pointer);
begin
FreeMem(p);
end;
procedure WspiapiSwap(var a, b, c: PIdPlatformChar);
{$IFDEF USE_INLINE}inline;{$ENDIF}
begin
c := a;
a := b;
b := c;
end;
function WspiapiStrdup(const pszString: PIdPlatformChar): PIdPlatformChar; stdcall;
var
pszMemory: PIdPlatformChar;
cchMemory: size_t;
begin
if pszString = nil then begin
Result := nil;
Exit;
end;
cchMemory := StrLen(pszString) + 1;
pszMemory := PIdPlatformChar(WspiapiMalloc(cchMemory * SizeOf(TIdPlatformChar)));
if pszMemory = nil then begin
Result := nil;
Exit;
end;
StrLCopy(pszMemory, pszString, cchMemory);
Result := pszMemory;
end;
function WspiapiParseV4Address(const pszAddress: PIdPlatformChar; var pdwAddress: DWORD): BOOL; stdcall;
var
dwAddress: DWORD;
pcNext: PIdPlatformChar;
iCount: Integer;
begin
iCount := 0;
// ensure there are 3 '.' (periods)
pcNext := pszAddress;
while pcNext^ <> TIdPlatformChar(0) do begin
if pcNext^ = '.' then begin
Inc(iCount);
end;
Inc(pcNext);
end;
if iCount <> 3 then begin
Result := FALSE;
Exit;
end;
// return an error if dwAddress is INADDR_NONE (255.255.255.255)
// since this is never a valid argument to getaddrinfo.
dwAddress := inet_addr(
{$IFNDEF UNICODE}
pszAddress
{$ELSE}
PAnsiChar(AnsiString(pszAddress))
{$ENDIF}
);
if dwAddress = INADDR_NONE then begin
Result := FALSE;
Exit;
end;
pdwAddress := dwAddress;
Result := TRUE;
end;
function WspiapiNewAddrInfo(iSocketType, iProtocol: Integer; wPort: WORD; dwAddress: DWORD): {$IFDEF UNICODE}PaddrinfoW{$ELSE}Paddrinfo{$ENDIF}; stdcall;
var
ptNew: {$IFDEF UNICODE}PaddrinfoW{$ELSE}Paddrinfo{$ENDIF};
ptAddress: PSockAddrIn;
begin
// allocate a new addrinfo structure.
{$IFDEF UNICODE}
ptNew := PaddrinfoW(WspiapiMalloc(SizeOf(addrinfoW)));
{$ELSE}
ptNew := Paddrinfo(WspiapiMalloc(SizeOf(addrinfo)));
{$ENDIF}
if ptNew = nil then begin
Result := nil;
Exit;
end;
ptAddress := PSockAddrIn(WspiapiMalloc(SizeOf(sockaddr_in)));
if ptAddress = nil then begin
WspiapiFree(ptNew);
Result := nil;
Exit;
end;
ptAddress^.sin_family := AF_INET;
ptAddress^.sin_port := wPort;
ptAddress^.sin_addr.s_addr := dwAddress;
// fill in the fields...
ptNew^.ai_family := PF_INET;
ptNew^.ai_socktype := iSocketType;
ptNew^.ai_protocol := iProtocol;
ptNew^.ai_addrlen := SizeOf(sockaddr_in);
ptNew^.ai_addr := Psockaddr(ptAddress);
Result := ptNew;
end;
function WspiapiQueryDNS(const pszNodeName: PIdPlatformChar; iSocketType, iProtocol: Integer;
wPort: WORD; pszAlias: PIdPlatformChar; var pptResult: {$IFDEF UNICODE}PaddrinfoW{$ELSE}Paddrinfo{$ENDIF}): Integer; stdcall;
var
pptNext: {$IFDEF UNICODE}PPaddrinfoW{$ELSE}PPaddrinfo{$ENDIF};
ptHost: Phostent;
ppAddresses: ^PInAddr;
begin
pptNext := @pptResult;
pptNext^ := nil;
pszAlias^ := TIdPlatformChar(0);
ptHost := gethostbyname(
{$IFNDEF UNICODE}
pszNodeName
{$ELSE}
PAnsiChar(AnsiString(pszNodeName))
{$ENDIF}
);
if ptHost <> nil then begin
if (ptHost^.h_addrtype = AF_INET) and (ptHost^.h_length = SizeOf(in_addr)) then begin
ppAddresses := Pointer(ptHost^.h_address_list);
while ppAddresses^ <> nil do begin
// create an addrinfo structure...
pptNext^ := WspiapiNewAddrInfo(iSocketType, iProtocol, wPort, ppAddresses^^.s_addr);
if pptNext^ = nil then begin
Result := EAI_MEMORY;
Exit;
end;
pptNext := @((pptNext^)^.ai_next);
Inc(ppAddresses);
end;
end;
// pick up the canonical name.
StrLCopy(pszAlias,
{$IFNDEF UNICODE}
ptHost^.h_name
{$ELSE}
PIdPlatformChar(TIdPlatformString(ptHost^.h_name))
{$ENDIF}
, NI_MAXHOST);
Result := 0;
Exit;
end;
case WSAGetLastError() of
WSAHOST_NOT_FOUND: Result := EAI_NONAME;
WSATRY_AGAIN: Result := EAI_AGAIN;
WSANO_RECOVERY: Result := EAI_FAIL;
WSANO_DATA: Result := EAI_NODATA;
else
Result := EAI_NONAME;
end;
end;
function WspiapiLookupNode(const pszNodeName: PIdPlatformChar; iSocketType: Integer;
iProtocol: Integer; wPort: WORD; bAI_CANONNAME: BOOL; var pptResult: {$IFDEF UNICODE}PaddrinfoW{$ELSE}Paddrinfo{$ENDIF}): Integer; stdcall;
var
iError: Integer;
iAliasCount: Integer;
szFQDN1: array[0..NI_MAXHOST-1] of TIdPlatformChar;
szFQDN2: array[0..NI_MAXHOST-1] of TIdPlatformChar;
pszName: PIdPlatformChar;
pszAlias: PIdPlatformChar;
pszScratch: PIdPlatformChar;
begin
iAliasCount := 0;
ZeroMemory(@szFQDN1, SizeOf(szFQDN1));
ZeroMemory(@szFQDN2, SizeOf(szFQDN2));
pszName := @szFQDN1[0];
pszAlias := @szFQDN2[0];
pszScratch := nil;
StrLCopy(pszName, pszNodeName, NI_MAXHOST);
repeat
iError := WspiapiQueryDNS(pszNodeName, iSocketType, iProtocol, wPort, pszAlias, pptResult);
if iError <> 0 then begin
Break;
end;
// if we found addresses, then we are done.
if pptResult <> nil then begin
Break;
end;
// stop infinite loops due to DNS misconfiguration. there appears
// to be no particular recommended limit in RFCs 1034 and 1035.
if (StrLen(pszAlias) = 0) or (StrComp(pszName, pszAlias) = 0) then begin
iError := EAI_FAIL;
Break;
end;
Inc(iAliasCount);
if iAliasCount = 16 then begin
iError := EAI_FAIL;
Break;
end;
// there was a new CNAME, look again.
WspiapiSwap(pszName, pszAlias, pszScratch);
until False;
if (iError = 0) and bAI_CANONNAME then begin
pptResult^.ai_canonname := WspiapiStrdup(pszAlias);
if pptResult^.ai_canonname = nil then begin
iError := EAI_MEMORY;
end;
end;
Result := iError;
end;
function WspiapiClone(wPort: WORD; ptResult: {$IFDEF UNICODE}PaddrinfoW{$ELSE}Paddrinfo{$ENDIF}): Integer; stdcall;
var
ptNext, ptNew: {$IFDEF UNICODE}PaddrinfoW{$ELSE}Paddrinfo{$ENDIF};
begin
ptNext := ptResult;
while ptNext <> nil do begin
// create an addrinfo structure...
ptNew := WspiapiNewAddrInfo(SOCK_DGRAM, ptNext^.ai_protocol, wPort, PSockAddrIn(ptNext^.ai_addr)^.sin_addr.s_addr);
if ptNew = nil then begin
Break;
end;
// link the cloned addrinfo
ptNew^.ai_next := ptNext^.ai_next;
ptNext^.ai_next := ptNew;
ptNext := ptNew^.ai_next;
end;
if ptNext <> nil then begin
Result := EAI_MEMORY;
Exit;
end;
Result := 0;
end;
procedure WspiapiLegacyFreeAddrInfo(ptHead: {$IFDEF UNICODE}PaddrinfoW{$ELSE}Paddrinfo{$ENDIF}); stdcall;
var
ptNext: {$IFDEF UNICODE}PaddrinfoW{$ELSE}Paddrinfo{$ENDIF};
begin
ptNext := ptHead;
while ptNext <> nil do
begin
if ptNext^.ai_canonname <> nil then begin
WspiapiFree(ptNext^.ai_canonname);
end;
if ptNext^.ai_addr <> nil then begin
WspiapiFree(ptNext^.ai_addr);
end;
ptHead := ptNext^.ai_next;
WspiapiFree(ptNext);
ptNext := ptHead;
end;
end;
{$IFNDEF HAS_TryStrToInt}
// TODO: use the implementation already in IdGlobalProtocols...
function TryStrToInt(const S: string; out Value: Integer): Boolean;
{$IFDEF USE_INLINE}inline;{$ENDIF}
var
E: Integer;
begin
Val(S, Value, E);
Result := E = 0;
end;
{$ENDIF}
function WspiapiLegacyGetAddrInfo(const pszNodeName: PIdPlatformChar; const pszServiceName: PIdPlatformChar;
const ptHints: {$IFDEF UNICODE}PaddrinfoW{$ELSE}Paddrinfo{$ENDIF};
var pptResult: {$IFDEF UNICODE}PaddrinfoW{$ELSE}Paddrinfo{$ENDIF}): Integer; stdcall;
var
iError: Integer;
iFlags: Integer;
iSocketType: Integer;
iProtocol: Integer;
wPort: WORD;
iTmp: Integer;
dwAddress: DWORD;
ptService: Pservent;
bClone: BOOL;
wTcpPort: WORD;
wUdpPort: WORD;
begin
iError := 0;
iFlags := 0;
iSocketType := 0;
iProtocol := 0;
wPort := 0;
dwAddress := 0;
bClone := FALSE;
wTcpPort := 0;
wUdpPort := 0;
// initialize pptResult with default return value.
pptResult := nil;
////////////////////////////////////////
// validate arguments...
//
// both the node name and the service name can't be NULL.
if (pszNodeName = nil) and (pszServiceName = nil) then begin
Result := EAI_NONAME;
Exit;
end;
// validate hints.
if ptHints <> nil then
begin
// all members other than ai_flags, ai_family, ai_socktype
// and ai_protocol must be zero or a null pointer.
if (ptHints^.ai_addrlen <> 0) or
(ptHints^.ai_canonname <> nil) or
(ptHints^.ai_addr <> nil) or
(ptHints^.ai_next <> nil) then
begin
Result := EAI_FAIL;
Exit;
end;
// the spec has the "bad flags" error code, so presumably we
// should check something here. insisting that there aren't
// any unspecified flags set would break forward compatibility,
// however. so we just check for non-sensical combinations.
//
// we cannot come up with a canonical name given a null node name.
iFlags := ptHints^.ai_flags;
if ((iFlags and AI_CANONNAME) <> 0) and (pszNodeName = nil) then begin
Result := EAI_BADFLAGS;
Exit;
end;
// we only support a limited number of protocol families.
if (ptHints^.ai_family <> PF_UNSPEC) and (ptHints^.ai_family <> PF_INET) then begin
Result := EAI_FAMILY;
Exit;
end;
// we only support only these socket types.
iSocketType := ptHints^.ai_socktype;
if (iSocketType <> 0) and
(iSocketType <> SOCK_STREAM) and
(iSocketType <> SOCK_DGRAM) and
(iSocketType <> SOCK_RAW) then
begin
Result := EAI_SOCKTYPE;
Exit;
end;
// REVIEW: What if ai_socktype and ai_protocol are at odds?
iProtocol := ptHints^.ai_protocol;
end;
////////////////////////////////////////
// do service lookup...
if pszServiceName <> nil then begin
if TryStrToInt(pszServiceName, iTmp) and (iTmp >= 0) then begin
wPort := htons(WORD(iTmp));
//wTcpPort := wPort; // never used
wUdpPort := wPort;
if iSocketType = 0 then begin
bClone := TRUE;
iSocketType := SOCK_STREAM;
end;
end else
begin
if (iSocketType = 0) or (iSocketType = SOCK_DGRAM) then begin
ptService := getservbyname(
{$IFNDEF UNICODE}
pszServiceName
{$ELSE}
PAnsiChar(AnsiString(pszServiceName))
{$ENDIF}
, 'udp'); {do not localize}
if ptService <> nil then begin
wPort := ptService^.s_port;
wUdpPort := wPort;
end;
end;
if (iSocketType = 0) or (iSocketType = SOCK_STREAM) then begin
ptService := getservbyname(
{$IFNDEF UNICODE}
pszServiceName
{$ELSE}
PAnsiChar(AnsiString(pszServiceName))
{$ENDIF}
, 'tcp'); {do not localize}
if ptService <> nil then begin
wPort := ptService^.s_port;
wTcpPort := wPort;
end;
end;
// assumes 0 is an invalid service port...
if wPort = 0 then begin
Result := iif(iSocketType <> 0, EAI_SERVICE, EAI_NONAME);
Exit;
end;
if iSocketType = 0 then begin
// if both tcp and udp, process tcp now & clone udp later.
iSocketType := iif(wTcpPort <> 0, SOCK_STREAM, SOCK_DGRAM);
bClone := (wTcpPort <> 0) and (wUdpPort <> 0);
end;
end;
end;
////////////////////////////////////////
// do node name lookup...
// if we weren't given a node name,
// return the wildcard or loopback address (depending on AI_PASSIVE).
//
// if we have a numeric host address string,
// return the binary address.
//
if ((pszNodeName = nil) or WspiapiParseV4Address(pszNodeName, dwAddress)) then begin
if pszNodeName = nil then begin
dwAddress := htonl(iif((iFlags and AI_PASSIVE) <> 0, INADDR_ANY, INADDR_LOOPBACK));
end;
// create an addrinfo structure...
pptResult := WspiapiNewAddrInfo(iSocketType, iProtocol, wPort, dwAddress);
if pptResult = nil then begin
iError := EAI_MEMORY;
end;
if (iError = 0) and (pszNodeName <> nil) then begin
// implementation specific behavior: set AI_NUMERICHOST
// to indicate that we got a numeric host address string.
pptResult^.ai_flags := pptResult^.ai_flags or AI_NUMERICHOST;
// return the numeric address string as the canonical name
if (iFlags and AI_CANONNAME) <> 0 then begin
pptResult^.ai_canonname := WspiapiStrdup(
{$IFNDEF UNICODE}
inet_ntoa(PInAddr(@dwAddress)^)
{$ELSE}
PWideChar(TIdUnicodeString(inet_ntoa(PInAddr(@dwAddress)^)))
{$ENDIF}
);
if pptResult^.ai_canonname = nil then begin
iError := EAI_MEMORY;
end;
end;
end;
end
// if we do not have a numeric host address string and
// AI_NUMERICHOST flag is set, return an error!
else if ((iFlags and AI_NUMERICHOST) <> 0) then begin
iError := EAI_NONAME;
end
// since we have a non-numeric node name,
// we have to do a regular node name lookup.
else begin
iError := WspiapiLookupNode(pszNodeName, iSocketType, iProtocol, wPort, (iFlags and AI_CANONNAME) <> 0, pptResult);
end;
if (iError = 0) and bClone then begin
iError := WspiapiClone(wUdpPort, pptResult);
end;
if iError <> 0 then begin
WspiapiLegacyFreeAddrInfo(pptResult);
pptResult := nil;
end;
Result := iError;
end;
function iif(ATest: Boolean; const ATrue, AFalse: PAnsiChar): PAnsiChar;
{$IFDEF USE_INLINE}inline;{$ENDIF}
begin
if ATest then begin
Result := ATrue;
end else begin
Result := AFalse;
end;
end;
function WspiapiLegacyGetNameInfo(ptSocketAddress: Psockaddr;
tSocketLength: u_int; pszNodeName: PIdPlatformChar; tNodeLength: size_t;
pszServiceName: PIdPlatformChar; tServiceLength: size_t; iFlags: Integer): Integer; stdcall;
var
ptService: Pservent;
wPort: WORD;
szBuffer: array[0..5] of TIdPlatformChar;
pszService: PIdPlatformChar;
ptHost: Phostent;
tAddress: in_addr;
pszNode: PIdPlatformChar;
pc: PIdPlatformChar;
{$IFDEF UNICODE}
tmpService: TIdUnicodeString;
tmpNode: TIdUnicodeString;
{$ENDIF}
begin
StrCopy(szBuffer, '65535');
pszService := szBuffer;
// sanity check ptSocketAddress and tSocketLength.
if (ptSocketAddress = nil) or (tSocketLength < SizeOf(sockaddr)) then begin
Result := EAI_FAIL;
Exit;
end;
if ptSocketAddress^.sa_family <> AF_INET then begin
Result := EAI_FAMILY;
Exit;
end;
if tSocketLength < SizeOf(sockaddr_in) then begin
Result := EAI_FAIL;
Exit;
end;
if (not ((pszNodeName <> nil) and (tNodeLength > 0))) and (not ((pszServiceName <> nil) and (tServiceLength > 0))) then begin
Result := EAI_NONAME;
Exit;
end;
// the draft has the "bad flags" error code, so presumably we
// should check something here. insisting that there aren't
// any unspecified flags set would break forward compatibility,
// however. so we just check for non-sensical combinations.
if ((iFlags and NI_NUMERICHOST) <> 0) and ((iFlags and NI_NAMEREQD) <> 0) then begin
Result := EAI_BADFLAGS;
Exit;
end;
// translate the port to a service name (if requested).
if (pszServiceName <> nil) and (tServiceLength > 0) then begin
wPort := PSockAddrIn(ptSocketAddress)^.sin_port;
if (iFlags and NI_NUMERICSERV) <> 0 then begin
// return numeric form of the address.
StrPLCopy(szBuffer, IntToStr(ntohs(wPort)), Length(szBuffer));
end else
begin
// return service name corresponding to port.
ptService := getservbyport(wPort, iif((iFlags and NI_DGRAM) <> 0, 'udp', nil));
if (ptService <> nil) and (ptService^.s_name <> nil) then begin
// lookup successful.
{$IFNDEF UNICODE}
pszService := ptService^.s_name;
{$ELSE}
tmpService := TIdUnicodeString(ptService^.s_name);
pszService := PWideChar(tmpService);
{$ENDIF}
end else begin
// DRAFT: return numeric form of the port!
StrPLCopy(szBuffer, IntToStr(ntohs(wPort)), Length(szBuffer));
end;
end;
if tServiceLength > size_t(StrLen(pszService)) then begin
StrLCopy(pszServiceName, pszService, tServiceLength);
end else begin
Result := EAI_FAIL;
Exit;
end;
end;
// translate the address to a node name (if requested).
if (pszNodeName <> nil) and (tNodeLength > 0) then begin
// this is the IPv4-only version, so we have an IPv4 address.
tAddress := PSockAddrIn(ptSocketAddress)^.sin_addr;
if (iFlags and NI_NUMERICHOST) <> 0 then begin
// return numeric form of the address.
{$IFNDEF UNICODE}
pszNode := inet_ntoa(tAddress);
{$ELSE}
tmpNode := TIdUnicodeString(inet_ntoa(tAddress));
pszNode := PWideChar(tmpNode);
{$ENDIF}
end else
begin
// return node name corresponding to address.
ptHost := gethostbyaddr(PAnsiChar(@tAddress), SizeOf(in_addr), AF_INET);
if (ptHost <> nil) and (ptHost^.h_name <> nil) then begin
// DNS lookup successful.
// stop copying at a "." if NI_NOFQDN is specified.
{$IFNDEF UNICODE}
pszNode := ptHost^.h_name;
{$ELSE}
tmpNode := TIdUnicodeString(ptHost^.h_name);
pszNode := PWideChar(tmpNode);
{$ENDIF}
if (iFlags and NI_NOFQDN) <> 0 then begin
pc := StrScan(pszNode, '.');
if pc <> nil then begin
pc^ := TIdPlatformChar(0);
end;
end;
end else
begin
// DNS lookup failed. return numeric form of the address.
if (iFlags and NI_NAMEREQD) <> 0 then begin
case WSAGetLastError() of
WSAHOST_NOT_FOUND: Result := EAI_NONAME;
WSATRY_AGAIN: Result := EAI_AGAIN;
WSANO_RECOVERY: Result := EAI_FAIL;
else
Result := EAI_NONAME;
end;
Exit;
end else begin
{$IFNDEF UNICODE}
pszNode := inet_ntoa(tAddress);
{$ELSE}
tmpNode := TIdUnicodeString(inet_ntoa(tAddress));
pszNode := PWideChar(tmpNode);
{$ENDIF}
end;
end;
end;
if tNodeLength > size_t(StrLen(pszNode)) then begin
StrLCopy(pszNodeName, pszNode, tNodeLength);
end else begin
Result := EAI_FAIL;
Exit;
end;
end;
Result := 0;
end;
{$IFDEF WINCE_UNICODE}
function IndyStrdupAToW(const pszString: PAnsiChar): PWideChar;
var
szStr: TIdUnicodeString;
pszMemory: PWideChar;
cchMemory: size_t;
begin
if pszString = nil then begin
Result := nil;
Exit;
end;
szStr := TIdUnicodeString(pszString);
cchMemory := Length(szStr) + 1;
pszMemory := PWideChar(WspiapiMalloc(cchMemory * SizeOf(WideChar)));
if pszMemory = nil then begin
Result := nil;
Exit;
end;
StrLCopy(pszMemory, PWideChar(szStr), cchMemory);
Result := pszMemory;
end;
procedure IndyFreeAddrInfoW(ptHead: PaddrinfoW); stdcall;
var
ptNext: PaddrinfoW;
begin
ptNext := ptHead;
while ptNext <> nil do
begin
if ptNext^.ai_canonname <> nil then begin
WspiapiFree(ptNext^.ai_canonname);
end;
if ptNext^.ai_addr <> nil then begin
WspiapiFree(ptNext^.ai_addr);
end;
ptHead := ptNext^.ai_next;
WspiapiFree(ptNext);
ptNext := ptHead;
end;
end;
function IndyAddrInfoConvert(AddrInfo: Paddrinfo): PaddrinfoW;
var
ptNew: PaddrinfoW;
ptAddress: Pointer;
begin
Result := nil;
if AddrInfo = nil then begin
Exit;
end;
// allocate a new addrinfo structure.
ptNew := PaddrinfoW(WspiapiMalloc(SizeOf(addrinfoW)));
if ptNew = nil then begin
WspiapiFree(ptNew);
Exit;
end;
ptAddress := WspiapiMalloc(AddrInfo^.ai_addrlen);
if ptAddress = nil then begin
WspiapiFree(ptNew);
Exit;
end;
Move(AddrInfo^.ai_addr^, ptAddress^, AddrInfo^.ai_addrlen);
// fill in the fields...
ptNew^.ai_flags := AddrInfo^.ai_flags;
ptNew^.ai_family := AddrInfo^.ai_family;
ptNew^.ai_socktype := AddrInfo^.ai_socktype;
ptNew^.ai_protocol := AddrInfo^.ai_protocol;
ptNew^.ai_addrlen := AddrInfo^.ai_addrlen;
ptNew^.ai_canonname := nil;
ptNew^.ai_addr := Psockaddr(ptAddress);
ptNew^.ai_next := nil;
if AddrInfo^.ai_canonname <> nil then begin
ptNew^.ai_canonname := IndyStrdupAToW(AddrInfo^.ai_canonname);
if ptNew^.ai_canonname = nil then begin
IndyFreeAddrInfoW(ptNew);
Exit;
end;
end;
if AddrInfo^.ai_next <> nil then begin
ptNew^.ai_next := IndyAddrInfoConvert(AddrInfo^.ai_next);
if ptNew^.ai_next = nil then begin
IndyFreeAddrInfoW(ptNew);
Exit;
end;
end;
Result := ptNew;
end;
function IndyGetAddrInfoW(const pszNodeName: PWideChar; const pszServiceName: PWideChar;
const ptHints: PaddrinfoW; var pptResult: PaddrinfoW): Integer; stdcall;
var
LNodeName: AnsiString;
LPNodeName: PAnsiChar;
LServiceName: AnsiString;
LPServiceName: PAnsiChar;
LHints: addrinfo;
LPHints: Paddrinfo;
LResult: Paddrinfo;
begin
// initialize pptResult with default return value.
pptResult := nil;
if pszNodeName <> nil then begin
LNodeName := AnsiString(pszNodeName);
LPNodeName := PAnsiChar(LNodeName);
end else begin
LPNodeName := nil;
end;
if pszServiceName <> nil then begin
LServiceName := AnsiString(pszServiceName);
LPServiceName := PAnsiChar(LServiceName);
end else begin
LPServiceName := nil;
end;
if ptHints <> nil then begin
ZeroMemory(@LHints, SizeOf(LHints));
LHints.ai_flags := ptHints^.ai_flags;
LHints.ai_family := ptHints^.ai_family;
LHints.ai_socktype := ptHints^.ai_socktype;
LHints.ai_protocol := ptHints^.ai_protocol;
LPHints := @LHints;
end else begin
LPHints := nil;
end;
Result := getaddrinfoCE(LPNodeName, LPServiceName, LPHints, @LResult);
if Result = 0 then begin
try
pptResult := IndyAddrInfoConvert(LResult);
finally
freeaddrinfoCE(LResult);
end;
if pptResult = nil then begin
Result := EAI_MEMORY;
end;
end;
end;
function IndyGetNameInfoW(ptSocketAddress: Psockaddr; tSocketLength: u_int;
pszNodeName: PWideChar; tNodeLength: size_t; pszServiceName: PWideChar;
tServiceLength: size_t; iFlags: Integer): Integer; stdcall;
var
LHost: array[0..NI_MAXHOST-1] of AnsiChar;
LPHost: PAnsiChar;
LHostLen: u_int;
LServ: array[0..NI_MAXSERV-1] of AnsiChar;
LPServ: PAnsiChar;
LServLen: u_int;
begin
if pszNodeName <> nil then
begin
LPHost := @LHost[0];
LHostLen := Length(LHost);
end else begin
LPHost := nil;
LHostLen := 0;
end;
if pszServiceName <> nil then
begin
LPServ := @LServ[0];
LServLen := Length(LServ);
end else begin
LPServ := nil;
LServLen := 0;
end;
Result := getnameinfoCE(ptSocketAddress, tSocketLength, LPHost, LHostLen, LPServ, LServLen, iFlags);
if Result = 0 then begin
if pszNodeName <> nil then begin
StrPLCopy(pszNodeName, TIdUnicodeString(LPHost), tNodeLength);
end;
if pszServiceName <> nil then begin
StrPLCopy(pszServiceName, TIdUnicodeString(LPServ), tServiceLength);
end;
end;
end;
{$ENDIF}
procedure InitLibrary;
var
{$IFDEF WINCE_UNICODE}
gai: LPFN_GETADDRINFO;
gni: LPFN_GETNAMEINFO;
fai: LPFN_FREEADDRINFO;
{$ELSE}
gai: {$IFDEF UNICODE}LPFN_GETADDRINFOW{$ELSE}LPFN_GETADDRINFO{$ENDIF};
gni: {$IFDEF UNICODE}LPFN_GETNAMEINFOW{$ELSE}LPFN_GETNAMEINFO{$ENDIF};
fai: {$IFDEF UNICODE}LPFN_FREEADDRINFOW{$ELSE}LPFN_FREEADDRINFO{$ENDIF};
{$ENDIF}
begin
{
IMPORTANT!!!
I am doing things this way because the functions we want are probably in
the Winsock2 dll. If they are not there, only then do you actually want
to try the Wship6.dll. I know it's a mess but I found that the functions
may not load if they aren't in Wship6.dll (and they aren't there in some
versions of Windows).
hProcHandle provides a transparant way of managing the two possible library
locations. hWship6Dll is kept so we can unload the Wship6.dll if necessary.
}
//Winsock2 has to be loaded by IdWinsock first.
if not IdWinsock2.Winsock2Loaded then
begin
IdWinsock2.InitializeWinSock;
end;
hProcHandle := IdWinsock2.WinsockHandle;
gai := GetProcAddress(hProcHandle, fn_getaddrinfo);
if not Assigned(gai) then
begin
hWship6Dll := SafeLoadLibrary(Wship6_dll);
hProcHandle := hWship6Dll;
gai := GetProcAddress(hProcHandle, fn_getaddrinfo); {do not localize}
end;
if Assigned(gai) then
begin
gni := GetProcAddress(hProcHandle, fn_getnameinfo); {do not localize}
if Assigned(gni) then
begin
fai := GetProcAddress(hProcHandle, fn_freeaddrinfo); {do not localize}
if Assigned(fai) then
begin
{$IFDEF WINCE_UNICODE}
getaddrinfoCE := gai;
getnameinfoCE := gni;
freeaddrinfoCE := fai;
getaddrinfo := @IndyGetAddrInfoW;
getnameinfo := @IndyGetNameInfoW;
freeaddrinfo := @IndyFreeAddrInfoW;
{$ELSE}
getaddrinfo := gai;
getnameinfo := gni;
freeaddrinfo := fai;
{$ENDIF}
//Additional functions should be initialized here.
{$IFNDEF WINCE}
inet_pton := GetProcAddress(hProcHandle, fn_inet_pton); {do not localize}
inet_ntop := GetProcAddress(hProcHandle, fn_inet_ntop); {do not localize}
GetAddrInfoEx := GetProcAddress(hProcHandle, fn_GetAddrInfoEx); {Do not localize}
SetAddrInfoEx := GetProcAddress(hProcHandle, fn_SetAddrInfoEx); {Do not localize}
FreeAddrInfoEx := GetProcAddress(hProcHandle, fn_FreeAddrInfoEx); {Do not localize}
hfwpuclntDll := SafeLoadLibrary(fwpuclnt_dll);
if hfwpuclntDll <> 0 then
begin
WSASetSocketSecurity := GetProcAddress(hfwpuclntDll,
'WSASetSocketSecurity');
WSAQuerySocketSecurity := GetProcAddress(hfwpuclntDll, 'WSAQuerySocketSecurity'); {Do not localize}
WSASetSocketPeerTargetName := GetProcAddress(hfwpuclntDll, 'WSASetSocketPeerTargetName'); {Do not localize}
WSADeleteSocketPeerTargetName := GetProcAddress(hfwpuclntDll, 'WSADeleteSocketPeerTargetName'); {Do not localize}
WSAImpersonateSocketPeer := GetProcAddress(hfwpuclntDll, 'WSAImpersonateSocketPeer'); {Do not localize}
WSARevertImpersonation := GetProcAddress(hfwpuclntDll, 'WSARevertImpersonation'); {Do not localize}
end;
{$ENDIF}
Exit;
end;
end;
end;
CloseLibrary;
getaddrinfo := Addr(WspiapiLegacyGetAddrInfo);
getnameinfo := Addr(WspiapiLegacyGetNameInfo);
freeaddrinfo := Addr(WspiapiLegacyFreeAddrInfo);
{$I IdSymbolDeprecatedOff.inc}
GIdIPv6FuncsAvailable := True;
{$I IdSymbolDeprecatedOn.inc}
end;
initialization
finalization
CloseLibrary;
end.