 | 
|
|
|
{$INCLUDE ..\cDefines.inc}
unit cWinSock;
{ }
{ WinSock functions 3.05 }
{ }
{ This unit is copyright © 2001-2004 by David J Butler }
{ }
{ This unit is part of Delphi Fundamentals. }
{ Its original file name is cWinSock.pas }
{ The latest version is available from the Fundamentals home page }
{ http://fundementals.sourceforge.net/ }
{ }
{ I invite you to use this unit, free of charge. }
{ I invite you to distibute this unit, but it must be for free. }
{ I also invite you to contribute to its development, }
{ but do not distribute a modified copy of this file. }
{ }
{ A forum is available on SourceForge for general discussion }
{ http://sourceforge.net/forum/forum.php?forum_id=2117 }
{ }
{ }
{ Description: }
{ Support functions to access WinSock API. }
{ }
{ Revision history: }
{ 11/12/2001 0.01 Spawned from cSockets. }
{ 12/12/2001 0.02 Added LocalHost functions. }
{ 01/07/2002 3.03 Refactored for Fundamentals 3. }
{ 19/08/2003 3.04 Added IPAddressType function. }
{ 01/04/2004 3.05 Change to dynamically load WinSock library. }
{ }
interface
uses
{ Delphi }
Windows,
SysUtils,
Classes,
WinSock,
{ Fundamentals }
cUtils;
{ }
{ Dynamically linked WinSock functions }
{ }
procedure WSASetLastError(iError: Integer);
function WSAGetLastError: Integer;
function WSACancelAsyncRequest(hAsyncTaskHandle: THandle): Integer;
function WSAAsyncGetHostByName(HWindow: HWND; wMsg: u_int; name, buf: PChar;
buflen: Integer): THandle;
function WSAAsyncGetHostByAddr(HWindow: HWND; wMsg: u_int;
addr: PChar; len, Struct: Integer; buf: PChar; buflen: Integer): THandle;
function WSAAsyncSelect(s: TSocket; HWindow: HWND; wMsg: u_int; lEvent: Longint): Integer;
function GetServByName(name, proto: PChar): PServEnt;
function GetProtoByName(name: PChar): PProtoEnt;
function GetHostByName(name: PChar): PHostEnt;
function GetHostByAddr(addr: Pointer; len, Struct: Integer): PHostEnt;
function GetHostName(name: PChar; len: Integer): Integer;
function Socket(af, Struct, protocol: Integer): TSocket;
function Shutdown(s: TSocket; how: Integer): Integer;
function SetSockOpt(s: TSocket; level, optname: Integer; optval: PChar;
optlen: Integer): Integer;
function GetSockOpt(s: TSocket; level, optname: Integer; optval: PChar;
var optlen: Integer): Integer;
function SendTo(s: TSocket; var Buf; len, flags: Integer; var addrto: TSockAddr;
tolen: Integer): Integer;
function Send(s: TSocket; var Buf; len, flags: Integer): Integer;
function Recv(s: TSocket; var Buf; len, flags: Integer): Integer;
function RecvFrom(s: TSocket; var Buf; len, flags: Integer; var from: TSockAddr;
var fromlen: Integer): Integer;
function ntohs(netshort: u_short): u_short;
function ntohl(netlong: u_long): u_long;
function Listen(s: TSocket; backlog: Integer): Integer;
function IoctlSocket(s: TSocket; cmd: DWORD; var arg: u_long): Integer;
function WSAIoctl(s: TSocket; IoControlCode: DWORD; InBuffer: Pointer;
InBufferSize: DWORD; OutBuffer: Pointer; OutBufferSize: DWORD;
var BytesReturned: DWORD; Overlapped: POverlapped;
CompletionRoutine: FARPROC): Integer;
function inet_ntoa(inaddr: TInAddr): PChar;
function inet_addr(cp: PChar): u_long;
function htons(hostshort: u_short): u_short;
function htonl(hostlong: u_long): u_long;
function GetSockName(s: TSocket; var name: TSockAddr; var namelen: Integer): Integer;
function GetPeerName(s: TSocket; var name: TSockAddr; var namelen: Integer): Integer;
function Connect(s: TSocket; var name: TSockAddr; namelen: Integer): Integer;
function CloseSocket(s: TSocket): Integer;
function Bind(s: TSocket; var addr: TSockAddr; namelen: Integer): Integer;
function Accept(s: TSocket; addr: PSockAddr; addrlen: PInteger): TSocket;
{ }
{ WinSockStartup }
{ The first call to WinSockStartup initializes the WinSock API. Subsequent }
{ calls have no effect. The WinSock API is shut down when the application }
{ shuts down. }
{ }
procedure WinSockStartup;
{ }
{ Exceptions }
{ }
type
EWinSock = class(Exception);
procedure RaiseSocketError(const Msg: String);
procedure RaiseWinSockError(const Msg: String; const WinSockError: Integer);
procedure RaiseLastWinSockError(const Msg: String);
{ }
{ WinSockErrorAsString }
{ }
function WinSockErrorAsString(const Error: Integer): String;
{ }
{ TSocketProtocol }
{ }
type
TSocketProtocol = (spTCP, spUDP);
function SocketProtocolAsString(const Protocol: TSocketProtocol): String;
{ }
{ IP Addresses }
{ IsIPAddress returns True if Address is a valid IP address. NetAddress }
{ contains the address in network byte order. }
{ IsInternetIP returns True if Address appears to be an Internet IP. }
{ }
type
TInAddr = WinSock.TInAddr;
TInAddrArray = Array of TInAddr;
TInAddrArrayArray = Array of TInAddrArray;
type
TIPAddressType = (ipaPublic, ipaPrivate, ipaNone, ipaReserved,
ipaLoopback, ipaLinkLocalNetwork, ipaTestNetwork, ipaMulticast,
ipaBroadcast);
function IsIPAddress(const Address: String; var NetAddress: TInAddr): Boolean;
function IPAddressStr(const Address: TInAddr): String;
function IPAddressType(const Address: TInAddr): TIPAddressType;
function IsInternetIPAddress(const Address: TInAddr): Boolean;
function ReversedIP(const Address: TInAddr): TInAddr;
procedure ReverseIP(var Address: TInAddr);
{ }
{ ResolvePort }
{ Returns the WinSock error (0 for success). }
{ NetPort contains the Port value in network byte order. }
{ }
function ResolvePort(const Port: String; const Protocol: TSocketProtocol;
var NetPort: Word): Integer;
function NetPortToPort(const NetPort: Word): Word;
function NetPortToPortStr(const NetPort: Word): String;
function PortToNetPort(const Port: Word): Word;
{ }
{ ResolveHost }
{ Resolves Host (IP or domain name). Blocks. Returns 0 if successful. }
{ }
function ResolveHost(const Host: String; var Address : TInAddr): Integer;
{ }
{ HostEnt functions }
{ }
function HostEntAddressesCount(const HostEnt: PHostEnt): Integer;
function HostEntAddresses(const HostEnt: PHostEnt): TInAddrArray;
function HostEntAddress(const HostEnt: PHostEnt; const Index: Integer = 0): TInAddr;
function HostEntAddressStr(const HostEnt: PHostEnt; const Index: Integer = 0): String;
function HostEntName(const HostEnt: PHostEnt): String;
{ }
{ LocalHost }
{ }
function LocalHostName: String;
function LocalIPAddresses: TInAddrArray;
function LocalIPAddressesStr: StringArray;
procedure AddLocalIPAddressesToStrings(const S: TStrings);
function GuessInternetIP: TInAddr;
function GuessInternetIPStr: String;
{ }
{ RemoteHost }
{ }
function GetRemoteHostName(const Address: TInAddr): String;
{ }
{ AllocateSocketHandle }
{ Returns a handle to a new WinSock socket. }
{ }
function AllocateSocketHandle(const Protocol: TSocketProtocol): TSocket;
{ }
{ WinSock structures }
{ }
procedure PopulateSockAddr(var SockAddr : TSockAddr; const Addr: TInAddr; const Port: Word);
{ }
{ WinSock constants }
{ }
const
SD_RECEIVE = 0;
SD_SEND = 1;
SD_BOTH = 2;
// WinSock2 Socket Options extentions
SO_GROUP_ID = $2001; // ID of a socket group
SO_GROUP_PRIORITY = $2002; // the relative priority within a group
SO_MAX_MSG_SIZE = $2003; // maximum message size
implementation
uses
{ Fundamentals }
cStrings;
{ }
{ WinSock lock }
{ }
var
WinSockLock : TRTLCriticalSection;
procedure InitializeWinSockLock;
begin
InitializeCriticalSection(WinSockLock);
end;
procedure FinalizeWinSockLock;
begin
DeleteCriticalSection(WinSockLock);
end;
{ }
{ Dynamically linked WinSock functions }
{ }
type
TWSAStartupProc = function (wVersionRequired: Word;
var WSData: TWSAData): Integer; stdcall;
TWSACleanupProc = function : Integer; stdcall;
TWSASetLastErrorProc = procedure (iError: Integer); stdcall;
TWSAGetLastErrorProc = function : Integer; stdcall;
TWSACancelAsyncRequestProc = function (hAsyncTaskHandle: THandle): Integer; stdcall;
TWSAAsyncGetHostByNameProc = function (HWindow: HWND; wMsg: u_int; name, buf: PChar;
buflen: Integer): THandle; stdcall;
TWSAAsyncGetHostByAddrProc = function (HWindow: HWND; wMsg: u_int;
addr: PChar; len, Struct: Integer;
buf: PChar; buflen: Integer): THandle; stdcall;
TWSAAsyncSelectProc = function (s: TSocket; HWindow: HWND; wMsg: u_int;
lEvent: Longint): Integer; stdcall;
TGetServByNameProc = function (name, proto: PChar): PServEnt; stdcall;
TGetProtoByNameProc = function (name: PChar): PProtoEnt; stdcall;
TGetHostByNameProc = function (name: PChar): PHostEnt; stdcall;
TGetHostByAddrProc = function (addr: Pointer; len, Struct: Integer): PHostEnt; stdcall;
TGetHostNameProc = function (name: PChar; len: Integer): Integer; stdcall;
TSocketProc = function (af, Struct, protocol: Integer): TSocket; stdcall;
TShutdownProc = function (s: TSocket; how: Integer): Integer; stdcall;
TSetSockOptProc = function (s: TSocket; level, optname: Integer;
optval: PChar; optlen: Integer): Integer; stdcall;
TGetSockOptProc = function (s: TSocket; level, optname: Integer;
optval: PChar; var optlen: Integer): Integer; stdcall;
TSendToProc = function (s: TSocket; var Buf; len, flags: Integer;
var addrto: TSockAddr; tolen: Integer): Integer; stdcall;
TSendProc = function (s: TSocket; var Buf; len, flags: Integer): Integer; stdcall;
TRecvProc = function (s: TSocket; var Buf; len, flags: Integer): Integer; stdcall;
TRecvFromProc = function (s: TSocket; var Buf; len, flags: Integer;
var from: TSockAddr; var fromlen: Integer): Integer; stdcall;
TntohsProc = function (netshort: u_short): u_short; stdcall;
TntohlProc = function (netlong: u_long): u_long; stdcall;
TListenProc = function (s: TSocket; backlog: Integer): Integer; stdcall;
TIoctlSocketProc = function (s: TSocket; cmd: DWORD;
var arg: u_long): Integer; stdcall;
TWSAIoctlProc = function (s : TSocket;
IoControlCode : DWORD;
InBuffer : Pointer;
InBufferSize : DWORD;
OutBuffer : Pointer;
OutBufferSize : DWORD;
var BytesReturned : DWORD;
Overlapped : POverlapped;
CompletionRoutine : FARPROC): Integer; stdcall;
Tinet_ntoaProc = function (inaddr: TInAddr): PChar; stdcall;
Tinet_addrProc = function (cp: PChar): u_long; stdcall;
ThtonsProc = function (hostshort: u_short): u_short; stdcall;
ThtonlProc = function (hostlong: u_long): u_long; stdcall;
TGetSockNameProc = function (s: TSocket; var name: TSockAddr;
var namelen: Integer): Integer; stdcall;
TGetPeerNameProc = function (s: TSocket; var name: TSockAddr;
var namelen: Integer): Integer; stdcall;
TConnectProc = function (s: TSocket; var name: TSockAddr;
namelen: Integer): Integer; stdcall;
TCloseSocketProc = function (s: TSocket): Integer; stdcall;
TBindProc = function (s: TSocket; var addr: TSockAddr;
namelen: Integer): Integer; stdcall;
TAcceptProc = function (s: TSocket; addr: PSockAddr;
addrlen: PInteger): TSocket; stdcall;
var
WSAStartupProc : TWSAStartupProc = nil;
WSACleanupProc : TWSACleanupProc = nil;
WSASetLastErrorProc : TWSASetLastErrorProc = nil;
WSAGetLastErrorProc : TWSAGetLastErrorProc = nil;
WSACancelAsyncRequestProc : TWSACancelAsyncRequestProc = nil;
WSAAsyncGetHostByNameProc : TWSAAsyncGetHostByNameProc = nil;
WSAAsyncGetHostByAddrProc : TWSAAsyncGetHostByAddrProc = nil;
WSAAsyncSelectProc : TWSAAsyncSelectProc = nil;
GetServByNameProc : TGetServByNameProc = nil;
GetProtoByNameProc : TGetProtoByNameProc = nil;
GetHostByNameProc : TGetHostByNameProc = nil;
GetHostByAddrProc : TGetHostByAddrProc = nil;
GetHostNameProc : TGetHostNameProc = nil;
SocketProc : TSocketProc = nil;
ShutdownProc : TShutdownProc = nil;
SetSockOptProc : TSetSockOptProc = nil;
GetSockOptProc : TGetSockOptProc = nil;
SendToProc : TSendToProc = nil;
SendProc : TSendProc = nil;
RecvProc : TRecvProc = nil;
RecvFromProc : TRecvFromProc = nil;
ntohsProc : TntohsProc = nil;
ntohlProc : TntohlProc = nil;
ListenProc : TListenProc = nil;
IoctlSocketProc : TIoctlSocketProc = nil;
WSAIoctlProc : TWSAIoctlProc = nil;
inet_ntoaProc : TInet_ntoaProc = nil;
inet_addrProc : TInet_addrProc = nil;
htonsProc : ThtonsProc = nil;
htonlProc : ThtonlProc = nil;
GetSockNameProc : TGetSockNameProc = nil;
GetPeerNameProc : TGetPeerNameProc = nil;
ConnectProc : TConnectProc = nil;
CloseSocketProc : TCloseSocketProc = nil;
BindProc : TBindProc = nil;
AcceptProc : TAcceptProc = nil;
var
WinSockDLLHandle : HMODULE = 0;
function GetWinSockProc(const ProcName: String): Pointer;
begin
EnterCriticalSection(WinSockLock);
try
if WinSockDLLHandle = 0 then
begin
WinSockDLLHandle := LoadLibrary('wsock32.dll');
if WinSockDLLHandle <= HINSTANCE_ERROR then
begin
WinSockDLLHandle := 0;
RaiseSocketError('Unable to load wsock32.dll');
end;
end;
Result := GetProcAddress(WinSockDLLHandle, PAnsiChar(ProcName));
if not Assigned(Result) then
RaiseSocketError('Unable to load wsock32.dll procedure ''' + ProcName + '''');
finally
LeaveCriticalSection(WinSockLock);
end;
end;
function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer;
begin
if not Assigned(WSAStartupProc) then
WSAStartupProc := GetWinSockProc('WSAStartup');
Result := WSAStartupProc(wVersionRequired, WSData);
end;
function WSACleanup: Integer;
begin
if not Assigned(WSACleanupProc) then
WSACleanupProc := GetWinSockProc('WSACleanup');
Result := WSACleanupProc;
end;
procedure WSASetLastError(iError: Integer);
begin
if not Assigned(WSASetLastErrorProc) then
WSASetLastErrorProc := GetWinSockProc('WSASetLastError');
WSASetLastErrorProc(iError);
end;
function WSAGetLastError: Integer;
begin
if not Assigned(WSAGetLastErrorProc) then
WSAGetLastErrorProc := GetWinSockProc('WSAGetLastError');
Result := WSAGetLastErrorProc;
end;
function WSACancelAsyncRequest(hAsyncTaskHandle: THandle): Integer;
begin
if not Assigned(WSACancelAsyncRequestProc) then
WSACancelAsyncRequestProc := GetWinSockProc('WSACancelAsyncRequest');
Result := WSACancelAsyncRequestProc(hAsyncTaskHandle);
end;
function WSAAsyncGetHostByName(HWindow: HWND; wMsg: u_int; name, buf: PChar;
buflen: Integer): THandle;
begin
if not Assigned(WSAAsyncGetHostByNameProc) then
WSAAsyncGetHostByNameProc := GetWinSockProc('WSAAsyncGetHostByName');
Result := WSAAsyncGetHostByNameProc(HWindow, wMsg, name, buf, buflen);
end;
function WSAAsyncGetHostByAddr(HWindow: HWND; wMsg: u_int;
addr: PChar; len, Struct: Integer; buf: PChar; buflen: Integer): THandle;
begin
if not Assigned(WSAAsyncGetHostByAddrProc) then
WSAAsyncGetHostByAddrProc := GetWinSockProc('WSAAsyncGetHostByAddr');
Result := WSAAsyncGetHostByAddrProc(HWindow, wMsg, addr, len, Struct, buf, buflen);
end;
function WSAAsyncSelect(s: TSocket; HWindow: HWND; wMsg: u_int; lEvent: Longint): Integer;
begin
if not Assigned(WSAAsyncSelectProc) then
WSAAsyncSelectProc := GetWinSockProc('WSAAsyncSelect');
Result := WSAAsyncSelectProc(s, HWindow, wMsg, lEvent);
end;
function GetServByName(name, proto: PChar): PServEnt;
begin
if not Assigned(GetServByNameProc) then
GetServByNameProc := GetWinSockProc('getservbyname');
Result := GetServByNameProc(name, proto);
end;
function GetProtoByName(name: PChar): PProtoEnt;
begin
if not Assigned(GetProtoByNameProc) then
GetProtoByNameProc := GetWinSockProc('getprotobyname');
Result := GetProtoByNameProc(name);
end;
function GetHostByName(name: PChar): PHostEnt;
begin
if not Assigned(GetHostByNameProc) then
GetHostByNameProc := GetWinSockProc('gethostbyname');
Result := GetHostByNameProc(name);
end;
function GetHostByAddr(addr: Pointer; len, Struct: Integer): PHostEnt;
begin
if not Assigned(GetHostByAddrProc) then
GetHostByAddrProc := GetWinSockProc('gethostbyaddr');
Result := GetHostByAddrProc(addr, len, Struct);
end;
function GetHostName(name: PChar; len: Integer): Integer;
begin
if not Assigned(GetHostNameProc) then
GetHostNameProc := GetWinSockProc('gethostname');
Result := GetHostNameProc(name, len);
end;
function Socket(af, Struct, protocol: Integer): TSocket;
begin
if not Assigned(SocketProc) then
SocketProc := GetWinSockProc('socket');
Result := SocketProc(af, Struct, protocol);
end;
function Shutdown(s: TSocket; how: Integer): Integer;
begin
if not Assigned(ShutdownProc) then
ShutdownProc := GetWinSockProc('shutdown');
Result := ShutdownProc(s, how);
end;
function SetSockOpt(s: TSocket; level, optname: Integer; optval: PChar;
optlen: Integer): Integer;
begin
if not Assigned(SetSockOptProc) then
SetSockOptProc := GetWinSockProc('setsockopt');
Result := SetSockOptProc(s, level, optname, optval, optlen);
end;
function GetSockOpt(s: TSocket; level, optname: Integer; optval: PChar;
var optlen: Integer): Integer;
begin
if not Assigned(GetSockOptProc) then
GetSockOptProc := GetWinSockProc('getsockopt');
Result := GetSockOptProc(s, level, optname, optval, optlen);
end;
function SendTo(s: TSocket; var Buf; len, flags: Integer; var addrto: TSockAddr;
tolen: Integer): Integer;
begin
if not Assigned(SendToProc) then
SendToProc := GetWinSockProc('sendto');
Result := SendToProc(s, Buf, len, flags, addrto, tolen);
end;
function Send(s: TSocket; var Buf; len, flags: Integer): Integer;
begin
if not Assigned(SendProc) then
SendProc := GetWinSockProc('send');
Result := SendProc(s, Buf, len, flags);
end;
function Recv(s: TSocket; var Buf; len, flags: Integer): Integer;
begin
if not Assigned(RecvProc) then
RecvProc := GetWinSockProc('recv');
Result := RecvProc(s, Buf, len, flags);
end;
function RecvFrom(s: TSocket; var Buf; len, flags: Integer; var from: TSockAddr;
var fromlen: Integer): Integer;
begin
if not Assigned(RecvFromProc) then
RecvFromProc := GetWinSockProc('recvfrom');
Result := RecvFromProc(s, Buf, len, flags, from, fromlen);
end;
function ntohs(netshort: u_short): u_short;
begin
if not Assigned(ntohsProc) then
ntohsProc := GetWinSockProc('ntohs');
Result := ntohsProc(netshort);
end;
function ntohl(netlong: u_long): u_long;
begin
if not Assigned(ntohlProc) then
ntohlProc := GetWinSockProc('ntohl');
Result := ntohlProc(netlong);
end;
function Listen(s: TSocket; backlog: Integer): Integer;
begin
if not Assigned(ListenProc) then
ListenProc := GetWinSockProc('listen');
Result := ListenProc(s, backlog);
end;
function IoctlSocket(s: TSocket; cmd: DWORD; var arg: u_long): Integer;
begin
if not Assigned(IoctlSocketProc) then
IoctlSocketProc := GetWinSockProc('ioctlsocket');
Result := IoctlSocketProc(s, cmd, arg);
end;
function WSAIoctl(s: TSocket; IoControlCode: DWORD; InBuffer: Pointer;
InBufferSize: DWORD; OutBuffer: Pointer; OutBufferSize: DWORD;
var BytesReturned: DWORD; Overlapped: POverlapped;
CompletionRoutine: FARPROC): Integer;
begin
if not Assigned(WSAIoctlProc) then
WSAIoctlProc := GetWinSockProc('WSAIoctl');
Result := WSAIoctlProc(s, IoControlCode, InBuffer, InBufferSize,
OutBuffer, OutBufferSize, BytesReturned, Overlapped, CompletionRoutine);
end;
function inet_ntoa(inaddr: TInAddr): PChar;
begin
if not Assigned(Inet_ntoaProc) then
Inet_ntoaProc := GetWinSockProc('inet_ntoa');
Result := Inet_ntoaProc(inaddr);
end;
function inet_addr(cp: PChar): u_long;
begin
if not Assigned(Inet_addrProc) then
Inet_addrProc := GetWinSockProc('inet_addr');
Result := Inet_addrProc(cp);
end;
function htons(hostshort: u_short): u_short;
begin
if not Assigned(htonsProc) then
htonsProc := GetWinSockProc('htons');
Result := htonsProc(hostshort);
end;
function htonl(hostlong: u_long): u_long;
begin
if not Assigned(htonlProc) then
htonlProc := GetWinSockProc('htonl');
Result := htonlProc(hostlong);
end;
function GetSockName(s: TSocket; var name: TSockAddr; var namelen: Integer): Integer;
begin
if not Assigned(GetSockNameProc) then
GetSockNameProc := GetWinSockProc('getsockname');
Result := GetSockNameProc(s, name, namelen);
end;
function GetPeerName(s: TSocket; var name: TSockAddr; var namelen: Integer): Integer;
begin
if not Assigned(GetPeerNameProc) then
GetPeerNameProc := GetWinSockProc('getpeername');
Result := GetPeerNameProc(s, name, namelen);
end;
function Connect(s: TSocket; var name: TSockAddr; namelen: Integer): Integer;
begin
if not Assigned(ConnectProc) then
ConnectProc := GetWinSockProc('connect');
Result := ConnectProc(s, name, namelen);
end;
function CloseSocket(s: TSocket): Integer;
begin
if not Assigned(CloseSocketProc) then
CloseSocketProc := GetWinSockProc('closesocket');
Result := CloseSocketProc(s);
end;
function Bind(s: TSocket; var addr: TSockAddr; namelen: Integer): Integer;
begin
if not Assigned(BindProc) then
BindProc := GetWinSockProc('bind');
Result := BindProc(s, addr, namelen);
end;
function Accept(s: TSocket; addr: PSockAddr; addrlen: PInteger): TSocket;
begin
if not Assigned(AcceptProc) then
AcceptProc := GetWinSockProc('accept');
Result := AcceptProc(s, addr, addrlen);
end;
{ }
{ WinSockStartup / WinSockCleanup }
{ }
var
WinSockStarted : Boolean = False;
WinSockData : WSAData;
procedure WinSockStartup;
var Err : Integer;
begin
EnterCriticalSection(WinSockLock);
try
if WinSockStarted then
exit;
Err := WSAStartup($101, WinSockData);
if Err <> 0 then
RaiseWinSockError('Winsock startup failed', Err);
WinSockStarted := True;
finally
LeaveCriticalSection(WinSockLock);
end;
end;
procedure WinSockCleanup;
begin
EnterCriticalSection(WinSockLock);
try
if WinSockStarted then
begin
WSACleanup;
WinSockStarted := False;
end;
if WinSockDLLHandle <> 0 then
begin
FreeLibrary(WinSockDLLHandle);
WinSockDLLHandle := 0;
end;
finally
LeaveCriticalSection(WinSockLock);
end;
end;
{ }
{ RaiseSocketError }
{ }
procedure RaiseSocketError(const Msg: String);
begin
raise EWinSock.Create(Msg);
end;
procedure RaiseWinSockError(const Msg: String; const WinSockError: Integer);
begin
RaiseSocketError(Msg + ': ' + WinSockErrorAsString(WinSockError));
end;
procedure RaiseLastWinSockError(const Msg: String);
begin
RaiseWinSockError(Msg, WSAGetLastError);
end;
{ }
{ WinSockErrorAsString }
{ }
function WinSockErrorAsString(const Error: Integer): String;
begin
Case Error of
0 : Result := '';
WSASYSNOTREADY : Result := 'WinSock not ready';
WSAVERNOTSUPPORTED : Result := 'WinSock version not supported';
WSAEINPROGRESS : Result := 'Blocking WinSock operation in progress';
WSAEPROCLIM : Result := 'WinSock task limit reached';
WSAEFAULT : Result := 'Generic WinSock fault';
WSANOTINITIALISED : Result := 'WinSock not initialized';
WSAENETDOWN : Result := 'The network subsystem has failed';
WSAENETUNREACH : Result := 'The network is unreachable';
WSAENETRESET : Result := 'Network reset';
WSAEHOSTDOWN : Result := 'Host is unavailable';
WSAEHOSTUNREACH : Result := 'Host is unreachable';
WSAHOST_NOT_FOUND : Result := 'Host not found';
WSATRY_AGAIN : Result := 'Host not found';
WSANO_DATA : Result := 'Host address not found';
WSAECONNRESET : Result := 'Connection reset by peer';
WSANO_RECOVERY : Result := 'Nonrecoverable WinSock error occurred';
WSAEMFILE : Result := 'WinSock file error';
WSAENOBUFS : Result := 'No buffer space available for socket';
WSAESOCKTNOSUPPORT : Result := 'The socket type is not supported';
WSAENOTSOCK : Result := 'Socket operation on non-socket or not connected';
WSAENOTCONN : Result := 'Socket is not connected';
WSAESHUTDOWN : Result := 'Socket is shutting down';
WSAETIMEDOUT : Result := 'Socket operation timed out';
WSAECONNREFUSED : Result := 'Connection refused';
WSAEADDRINUSE : Result := 'Address in use';
WSAEADDRNOTAVAIL : Result := 'Address not available';
WSAEBADF : Result := 'Socket error: Invalid format';
WSAEINVAL : Result := 'Socket error: Invalid operation';
WSAEACCES : Result := 'Socket permission denied';
WSAEMSGSIZE : Result := 'Socket error: Invalid message size';
WSAENOPROTOOPT : Result := 'Protocol not available';
WSAEPROTONOSUPPORT : Result := 'Protocol not supported';
WSAEPFNOSUPPORT : Result := 'Protocol family not supported';
WSAEAFNOSUPPORT : Result := 'Address family not supported by protocol family';
WSAEOPNOTSUPP : Result := 'Socket error: Operation not supported';
WSAENAMETOOLONG : Result := 'Socket error: Name too long';
WSAEINTR : Result := 'Socket error: System level interruption';
WSAECONNABORTED : Result := 'Connection aborted';
WSAEDISCON : Result := 'Socket has been disconnected';
else
Result := 'WinSock error #' + IntToStr(Error);
end;
end;
{ }
{ SocketProtocolAsString }
{ }
const
ProtocolStr: Array[TSocketProtocol] of String = ('tcp', 'udp');
function SocketProtocolAsString(const Protocol: TSocketProtocol): String;
begin
Result := ProtocolStr[Protocol];
end;
{ }
{ IsIPAddress }
{ }
function IsIPAddress(const Address: String; var NetAddress: TInAddr): Boolean;
var P, Q : PChar;
I : Integer;
begin
// Not long enough
if Length(Address) < 7 then
begin
NetAddress.S_addr := u_long(INADDR_NONE);
Result := False;
exit;
end;
// Quick validity checking
P := PChar(Address);
While P^ = ' ' do
Inc(P);
Q := P;
I := 0;
While Q^ <> #0 do
if not (Q^ in ['0'..'9', '.', ' ']) then
begin
NetAddress.S_addr := u_long(INADDR_NONE);
Result := False;
exit;
end else
begin
if Q^ = '.' then
Inc(I);
Inc(Q);
end;
if I <> 3 then // 3 dots required
begin
NetAddress.S_addr := u_long(INADDR_NONE);
Result := False;
exit;
end;
// Use WinSock to resolve IP
if not WinSockStarted then
WinSockStartup;
NetAddress.S_addr := Inet_Addr(P);
if NetAddress.S_addr <> u_long(INADDR_NONE) then
Result := True else
if Address = '255.255.255.255' then // Check for broadcast IP (INADDR_NONE = INADDR_BROADCAST)
begin
NetAddress.S_addr := u_long(INADDR_BROADCAST);
Result := True;
end else
Result := False;
end;
{ }
{ IPAddressStr }
{ }
function IPAddressStr(const Address: TInAddr): String;
begin
Result := PChar(inet_ntoa(Address));
end;
{ }
{ ResolvePort }
{ }
function ResolvePort(const Port: String; const Protocol: TSocketProtocol;
var NetPort: Word): Integer;
var PEnt : PServEnt;
Prot : String;
begin
if Port = '' then
begin
NetPort := 0;
Result := 0;
exit;
end;
if StrIsNumeric(Port) then
begin
NetPort := htons(StrToInt(Port));
Result := 0;
exit;
end;
if not WinSockStarted then
WinSockStartup;
Prot := SocketProtocolAsString(Protocol);
PEnt := GetServByName(PChar(Port), PChar(Prot));
if not Assigned(PEnt) then
begin
NetPort := 0;
Result := WSAGetLastError;
end else
begin
NetPort := PEnt^.s_port;
Result := 0;
end;
end;
function NetPortToPort(const NetPort: Word): Word;
begin
Result := ntohs(NetPort);
end;
function NetPortToPortStr(const NetPort: Word): String;
begin
Result := IntToStr(NetPortToPort(NetPort));
end;
function PortToNetPort(const Port: Word): Word;
begin
Result := htons(Port);
end;
{ }
{ ResolveHost }
{ }
function ResolveHost(const Host: String; var Address : TInAddr): Integer;
var HostEnt : PHostEnt;
begin
if IsIPAddress(Host, Address) then
begin
Result := 0;
exit;
end;
HostEnt := GetHostByName(PChar(Host));
Result := WSAGetLastError;
if Assigned(HostEnt) then
Address := HostEntAddress(HostEnt, 0) else
Address.S_addr := u_long(INADDR_NONE);
end;
{ }
{ HostEntAddressCount }
{ }
function HostEntAddressesCount(const HostEnt: PHostEnt): Integer;
var P : ^PInAddr;
Q : PInAddr;
begin
Result := 0;
if not Assigned(HostEnt) then
exit;
Assert(HostEnt^.h_addrtype = AF_INET, 'IP addresses required');
Assert(HostEnt^.h_length = Sizeof(TInAddr), 'IP addresses required');
P := Pointer(HostEnt^.h_addr_list);
if not Assigned(P) then
exit;
Q := P^;
While Assigned(Q) do
begin
Inc(P);
Inc(Result);
Q := P^
end;
end;
{ }
{ HostEntAddresses }
{ }
function HostEntAddresses(const HostEnt: PHostEnt): TInAddrArray;
var P : ^PInAddr;
I, L : Integer;
begin
L := HostEntAddressesCount(HostEnt);
SetLength(Result, L);
if L = 0 then
exit;
P := Pointer(HostEnt^.h_addr_list);
For I := 0 to L - 1 do
begin
Result[I] := P^^;
Inc(P);
end;
end;
{ }
{ HostEntAddress }
{ }
function HostEntAddress(const HostEnt: PHostEnt; const Index: Integer): TInAddr;
var P : ^PInAddr;
Q : PInAddr;
I : Integer;
begin
LongInt(Result.S_addr) := LongInt(INADDR_NONE);
if not Assigned(HostEnt) then
exit;
Assert(HostEnt^.h_addrtype = AF_INET, 'IP addresses required');
Assert(HostEnt^.h_length = Sizeof(TInAddr), 'IP addresses required');
P := Pointer(HostEnt^.h_addr_list);
if not Assigned(P) then
exit;
Q := P^;
I := 0;
While Assigned(Q) and (I < Index) do
begin
Inc(P);
Inc(I);
Q := P^
end;
if Assigned(Q) then
Result := Q^;
end;
{ }
{ HostEntAddressStr }
{ }
function HostEntAddressStr(const HostEnt: PHostEnt; const Index: Integer): String;
begin
Result := IPAddressStr(HostEntAddress(HostEnt, Index));
end;
{ }
{ HostEntName }
{ }
function HostEntName(const HostEnt: PHostEnt): String;
begin
Result := HostEnt.h_name;
end;
{ }
{ LocalHostName }
{ }
function LocalHostName: String;
var Buf : Array[0..255] of Char;
begin
if not WinSockStarted then
WinSockStartup;
if gethostname(@Buf, Sizeof(Buf)) <> 0 then
RaiseLastWinSockError('LocalHostName not available');
Result := PChar(@Buf);
end;
{ }
{ LocalIPAddress }
{ }
function LocalIPAddresses: TInAddrArray;
begin
if not WinSockStarted then
WinSockStartup;
Result := HostEntAddresses(gethostbyname(PChar(LocalHostName)));
end;
function LocalIPAddressesStr: StringArray;
var V : TInAddrArray;
I, L : Integer;
begin
V := LocalIPAddresses;
L := Length(V);
SetLength(Result, L);
For I := 0 to L - 1 do
Result[I] := IPAddressStr(V[I]);
end;
procedure AddLocalIPAddressesToStrings(const S: TStrings);
var V : TInAddrArray;
I, L : Integer;
begin
V := LocalIPAddresses;
L := Length(V);
For I := 0 to L - 1 do
S.Add(IPAddressStr(V[I]));
end;
{ }
{ IP Address Types }
{ }
function IPAddressType(const Address: TInAddr): TIPAddressType;
begin
Result := ipaPublic;
Case Byte(Address.S_un_b.s_b1) of
0 : if LongWord(Address.S_addr) = 0 then
Result := ipaNone;
10 : Result := ipaPrivate;
127 : Result := ipaLoopback;
169 : if Byte(Address.S_un_b.s_b2) = 254 then
Result := ipaLinkLocalNetwork;
172 : if Byte(Address.S_un_b.s_b2) and $F0 = $10 then
Result := ipaPrivate;
192 : Case Byte(Address.S_un_b.s_b2) of
0 : if Byte(Address.S_un_b.s_b3) = 2 then
Result := ipaTestNetwork;
168 : Result := ipaPrivate;
end;
224..239 : Result := ipaMulticast;
255 : if LongWord(Address.S_addr) = $FFFFFFFF then
Result := ipaBroadcast;
end;
if Result = ipaPublic then
if Byte(Address.S_un_b.s_b1) in [0..2, 5, 7, 23, 27, 31, 36..37,
39, 41..42, 58..59, 70..79, 83..127, 197, 223, 240..255] then
Result := ipaReserved;
end;
function IsInternetIPAddress(const Address: TInAddr): Boolean;
begin
Result := IPAddressType(Address) = ipaPublic;
end;
function ReversedIP(const Address: TInAddr): TInAddr;
begin
Result.S_addr := Address.S_addr;
Swap(Byte(Result.S_un_b.s_b1), Byte(Result.S_un_b.s_b4));
Swap(Byte(Result.S_un_b.s_b2), Byte(Result.S_un_b.s_b3));
end;
procedure ReverseIP(var Address: TInAddr);
begin
Swap(Byte(Address.S_un_b.s_b1), Byte(Address.S_un_b.s_b4));
Swap(Byte(Address.S_un_b.s_b2), Byte(Address.S_un_b.s_b3));
end;
{ }
{ GuessInternetIP }
{ }
function GuessInternetIP: TInAddr;
var A : TInAddrArray;
I : Integer;
begin
A := LocalIPAddresses;
For I := 0 to Length(A) - 1 do
if IsInternetIPAddress(A[I]) then
begin
Result := A[I];
exit;
end;
LongInt(Result.S_addr) := LongInt(INADDR_NONE);
end;
{ }
{ GuessInternetIPStr }
{ }
function GuessInternetIPStr: String;
var A : TInAddr;
begin
A := GuessInternetIP;
if LongInt(A) = LongInt(INADDR_NONE) then
Result := '' else
Result := IPAddressStr(A);
end;
{ }
{ RemoteHost }
{ }
function GetRemoteHostName(const Address: TInAddr): String;
var E : PHostEnt;
begin
E := gethostbyaddr(@Address, Sizeof(TInAddr), AF_INET);
if not Assigned(E) then
begin
Result := '';
exit;
end;
Result := StrPas(E^.h_name);
end;
{ }
{ AllocateSocketHandle }
{ }
function AllocateSocketHandle(const Protocol: TSocketProtocol): TSocket;
begin
if not WinSockStarted then
WinSockStartup;
Case Protocol of
spTCP : Result := Socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
spUDP : Result := Socket(AF_INET, SOCK_DGRAM, IPPROTO_UDP);
else Result := INVALID_SOCKET;
end;
if Result = INVALID_SOCKET then
RaiseLastWinSockError('Socket allocation failed');
end;
{ }
{ WinSock structures }
{ }
procedure PopulateSockAddr(var SockAddr: TSockAddr; const Addr: TInAddr; const Port: Word);
begin
FillChar(SockAddr, Sizeof(TSockAddr), #0);
With SockAddr do
begin
sin_family := AF_INET;
sin_port := htons(Port);
sin_addr := Addr;
end;
end;
initialization
InitializeWinSockLock;
finalization
WinSockCleanup;
FinalizeWinSockLock;
end.