unit Tsocketc;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, NWinSock;

const
     ICMP_ECHO = 8;		{ An ICMP echo message }
     ICMP_ECHOREPLY = 0;	{ An ICMP echo reply message }
     ICMP_HEADERSIZE = 8;	{ ICMP header size ("echo messages" only) }
{ If Using the Delphi 32 Winsock.pas }
type
     _Socket = TSocket;
     fd_set = TFDSet;
     Pfd_set = PFDSet;
     timeval = TTimeVal;
     hostent = THostEnt;
     netent = TNetEnt;
     servent = TServEnt;
     protoent = TProtoEnt;
     in_addr = TInAddr;
     Pin_addr = PInAddr;
     Sockaddr_in = TSockAddrIn;
     PSockaddr_in = PSockAddrIn;
     WSADATA = TWSAData;
     LPWSADATA = PWSAData;
     sockaddr = TSockAddr;
     sockproto = TSockProto;
     linger = TLinger;
     LPSOCKADDR = ^sockaddr;
     LPSOCKADDR_IN = ^sockaddr_in;
     LPLINGER = ^linger;
     LPIN_ADDR = ^in_addr;
     LPFD_SET = ^fd_set;
     LPHOSTENT = ^hostent;
     LPSERVENT = ^servent;
     LPPROTOENT = ^protoent;
     LPTIMEVAL = ^timeval;
const
     FIONREAD = (IOC_OUT or ((4 and IOCPARM_MASK) SHL 16) or
           (102 SHL 8) or 127);
{ End of Delphi 32 Winsock.pas compatability type definitions }
type
    Pip = ^ip;
    ip = record 		{ Structure for IP datagram header }
	ip_verlen: Byte;	{ Version and header length }
	ip_tos: Byte;		{ Type of service }
	ip_len: Word;		{ Total packet length }
	ip_id: Word;		{ Datagram identification }
	ip_fragoff: Word;	{ Fragment offset }
	ip_ttl: Byte;		{ Time to live }
	ip_proto: Byte;		{ Protocol }
	ip_chksum: Word;	{ Checksum }
	ip_src_addr: in_addr;	{ Source address }
	ip_dst_addr: in_addr;	{ Destination address }
	ip_data: Byte;		{ Variable length data area }
    end;

type
   Picmp = ^icmp;
   icmp = record
        icmp_type: BYTE;	{ Type of message }
	icmp_code: BYTE;	{ Type "sub code" (zero for echos) }
	icmp_cksum: WORD;	{ 1's complement checksum }
	icmp_id: WORD;	        { Unique ID (the instance handle) }
	icmp_seq: WORD;	        { Tracks multiple pings }
	icmp_data: BYTE;	{ The start of optional data }
   end;
type
  _TSocket = class(TObject)
  private
    { Private declarations }
    {WinSock interface information}
    isp_WinSockInfo: WSADATA;
    {The current socket state flag}
    ii_SocketState: Integer;
    {The host Internet address record}
    ihe_HostEntry: Phostent;
    isp_HostAddressList: PChar;
    {The address of this socket}
    isa_SocketAddress: Sockaddr_in;
    {The address of the other computer socket}
    isa_SocketHostAddress: Sockaddr_in;
    {A socket address}
    isa_sockaddr: sockaddr;
    {Timestamps, for use in a ping implementation}
    iwSendTimeStamp: LongInt;
    iwReceiveTimeStamp: LongInt;
    iwRoundTripTimeStamp: LongInt;
    ihPingID: THandle;
    ibPingAlive: Boolean;
  protected
    { Protected declarations }
  public
    { Public declarations }
    ispHostName: PChar;
    ip_icmp: Picmp;
    ipHeader: Pip;
    icp_Buffer: PChar;
    function InitializeSocket: Boolean;
    procedure ShutdownSocket;
    function SocketError: String;
    function CreateSocket: _SOCKET;
    function CreateDataSocket(CommandSocket: _SOCKET; hWnd: THandle;  wMsg: Word): _SOCKET;
    function CreateListenSocket(hWnd: THandle; wMsg: Word; aiPort: Integer): _SOCKET;
    function AcceptConnectingSocket(ListenSocket: _SOCKET; hWnd: THandle;  wMsg: Word): _SOCKET;
    function AcceptDataSocket(ListenSocket: _SOCKET; hWnd: THandle;  wMsg: Word): _SOCKET;
    procedure SetSocketBufferSize(BufSocket: _SOCKET; NewSize: Integer);
    function CreateRawSocket: _SOCKET;
    function GetSocketState: Integer;
    procedure GetHostAddress(hWnd: THandle;  wMsg: Word; lsHostName: String; NewState: Integer);
    function GetSocketDescription: String;
    function GetSocketSystemState: String;
    function GetMaxNumSockets: Integer;
    function GetUDPPacketSize: Word;
    function ProcessHostAddress: Boolean;
    procedure CloseSocketConnection(SocketToClose: _SOCKET);
    function OpenSocketConnection(hWnd: THandle;  wMsg: Word; NewState: Integer; ConnectPort: Integer): _SOCKET;
    procedure OpenDataSocketConnection(hWnd: THandle;  wMsg: Word; NewSocket: _SOCKET; HostAddr: String; ConnectPort: Integer);
    function InetChecksum(Data: PWORD; DataLength: WORD): WORD;
    function SendPing(hWnd: THandle;  wMsg: Word; NewState: Integer): _SOCKET;
    procedure RecvPing(RecvSocket: _SOCKET; NewState: Integer);
    function GetHostAddressString: String;
    procedure ProcessPingReply;
    function GetPingReplyString: String;
    procedure SocketSend(SendSocket: _SOCKET; hWnd: THandle; wMsg: Word; sSendStr: String; NewState: Integer);
    procedure SocketSendMessage(SendSocket: _SOCKET; hWnd: THandle; wMsg: Word; sSendStr: PChar; iStrLen, NewState: Integer);
    procedure SocketSendBuffer(SendSocket: _SOCKET; hWnd: THandle; wMsg: Word; sSendStr: PChar; iStrLen, NewState: Integer);
    procedure SocketReceive(RecvSocket: _SOCKET; hWnd: THandle; wMsg: Word;
                                        sBuffer: PChar; BufSize: Integer; NewState: Integer);
    procedure SocketReceivePeek(RecvSocket: _SOCKET; hWnd: THandle; wMsg: Word;
                                        sBuffer: PChar; BufSize: Integer; NewState: Integer);
    function ProcessReceive: PChar;
    procedure GetReceive(RecvSocket: _SOCKET; hWnd: THandle; wMsg: Word; sBuffer: PChar; BufSize: Integer);
    procedure SetSocketState(NewState: Integer);
    function CheckSocketError: Boolean;
    function GetLine(TargetString, SourceString: PChar): Boolean;
    function GetSockAddr: String;
    function IsSocketConnected(TestSocket: _SOCKET): Boolean;
  end;


implementation


function _TSocket.InitializeSocket: Boolean;
var
   lw_SocketVersion: Word;
   li_ErrorReturn: Integer;
   lsp_WinSockInfo: LPWSADATA;
begin
   {This functionality needs WinSock version 1.1 or higher}
   lw_SocketVersion := $0101;
   {Initialize the WinSock services}
   li_ErrorReturn := WSAStartup(lw_SocketVersion, isp_WinSockInfo);
   case li_ErrorReturn of
        WSAEINVAL: InitializeSocket := FALSE;
        WSASYSNOTREADY: InitializeSocket := FALSE;
        WSAVERNOTSUPPORTED: InitializeSocket := FALSE;
   else
       InitializeSocket := TRUE;
   end;
end;

procedure _TSocket.ShutdownSocket;
begin
     {Close and shutdown the WinSock services}
     WSACancelBlockingCall;
     WSACleanup;
end;

function _TSocket.SocketError: String;
var
   ls_ErrorMsg: String;
   li_ErrorNum: Integer;
begin
   {Return a message string to explain the last error that occured}
   li_ErrorNum := WSAGetLastError;
   case li_ErrorNum of
        WSAEINTR: ls_ErrorMsg := 'The call was canceled via WSACancelBlickingCall().';
        WSAEBADF: ls_ErrorMsg := 'Bad file number.';
        WSAEACCES: ls_ErrorMsg := 'The address specified is a broadcast address, but the socket doesn' +
                               #39 + 't support sending broadcast packets.';
        WSAEFAULT: ls_ErrorMsg := 'The address length supplied is too small.';
        WSAEINVAL: ls_ErrorMsg := 'This function shouldn' + #39 + 't be called at this ' +
                                  'time because listen() wasn' + #39 + 't called before accept().';
        WSAEMFILE: ls_ErrorMsg := 'The queue is empty and no descriptors are available.';
        WSAEWOULDBLOCK: ls_ErrorMsg := 'This is a non-blocking socket and no connections are present.';
        WSAEINPROGRESS: ls_ErrorMsg := 'A blocking call is now in progress.';
        WSAEALREADY: ls_ErrorMsg := 'The non-blocking routine has already finished.';
        WSAENOTSOCK: ls_ErrorMsg := 'The socket number used isn' + #39 + 't a socket.';
        WSAEDESTADDRREQ: ls_ErrorMsg := 'A destination address wasn' + #39 + 't given.';
        WSAEMSGSIZE: ls_ErrorMsg := 'The datagram was too large for the buffer and was truncated.';
        WSAEPROTOTYPE: ls_ErrorMsg := 'The socket can' + #39 + 't use the protocol specified.';
        WSAENOPROTOOPT: ls_ErrorMsg := 'The option is unknown or unsupported.';
        WSAEPROTONOSUPPORT: ls_ErrorMsg := 'This protocol isn' + #39 + 't supported.';
        WSAESOCKTNOSUPPORT: ls_ErrorMsg := 'This address family doesn' + #39 + 't support the socket type specified.';
        WSAEOPNOTSUPP: ls_ErrorMsg := 'The socket referenced isn' + #39 + 't open for connection oriented services.';
        WSAEPFNOSUPPORT: ls_ErrorMsg := 'The address family specified isn' + #39 + 't supported by this protocol.';
        WSAEAFNOSUPPORT: ls_ErrorMsg := 'The address family specified isn' + #39 + 't supported by this protocol.';
        WSAEADDRINUSE: ls_ErrorMsg := 'The address given is already in use.';
        WSAEADDRNOTAVAIL: ls_ErrorMsg := 'The address isn' + #39 + 't available from this machine.';
        WSAENETDOWN: ls_ErrorMsg := 'WINSOCK.DLL has reported that the network subsystem has failed.';
        WSAENETUNREACH: ls_ErrorMsg := 'The network can' + #39 + 't be reached.';
        WSAENETRESET: ls_ErrorMsg := 'Winsock dropped the connection.';
        WSAECONNABORTED: ls_ErrorMsg := 'The connection was aborted due to a network failure.';
        WSAECONNRESET: ls_ErrorMsg := 'The connection was reset by the remote host.';
        WSAENOBUFS: ls_ErrorMsg := 'No buffer space is available.';
        WSAEISCONN: ls_ErrorMsg := 'The socket is already connected.';
        WSAENOTCONN: ls_ErrorMsg := 'The socket isn' + #39 + 't connected.';
        WSAESHUTDOWN: ls_ErrorMsg := 'The socket has been shut down.';
        WSAETOOMANYREFS: ls_ErrorMsg := '';
        WSAETIMEDOUT: ls_ErrorMsg := 'A connection attempt timed out; no connection was established.';
        WSAECONNREFUSED: ls_ErrorMsg := 'The connection was refused.';
        WSAELOOP: ls_ErrorMsg := '';
        WSAENAMETOOLONG: ls_ErrorMsg := '';
        WSAEHOSTDOWN: ls_ErrorMsg := '';
        WSAEHOSTUNREACH: ls_ErrorMsg := '';
        WSAENOTEMPTY: ls_ErrorMsg := '';
        WSAEPROCLIM: ls_ErrorMsg := '';
        WSAEUSERS: ls_ErrorMsg := '';
        WSAEDQUOT: ls_ErrorMsg := '';
        WSAESTALE: ls_ErrorMsg := '';
        WSAEREMOTE: ls_ErrorMsg := '';
        WSAEDISCON: ls_ErrorMsg := 'The message terminated gracefully.';
        WSASYSNOTREADY: ls_ErrorMsg := 'The network subsystem isn' + #39 + 't ready for communications.';
        WSAVERNOTSUPPORTED: ls_ErrorMsg := 'The Winsock API version requested isn' + #39 + 't supported.';
        WSANOTINITIALISED: ls_ErrorMsg := 'WSAStartup() must be called ' +
                           'successfully before you can use this function.';
        WSAHOST_NOT_FOUND: ls_ErrorMsg := 'The Authoritative Answer Host isn' + #39 + 't available.';
        WSATRY_AGAIN: ls_ErrorMsg := 'The Non-Authoritative Host isn' + #39 + 't available.';
        WSANO_RECOVERY: ls_ErrorMsg := 'This is a non-recoverable error or SERVERFAIL.';
        WSANO_DATA: ls_ErrorMsg := 'No data record of the type has been requested.';
   else
      ls_ErrorMsg := 'Unknown Error Occured.';
   end;
   SocketError := ls_ErrorMsg;
end;

function _TSocket.CreateSocket: _SOCKET;
var
   NewSock: _SOCKET;
begin
   {Create a new socket}
   NewSock := socket(PF_INET, SOCK_STREAM, 0);
   if (NewSock = INVALID_SOCKET) then
   begin
        ShowMessage(SocketError);
   end;
   CreateSocket := NewSock;
end;

function _TSocket.CreateDataSocket(CommandSocket: _SOCKET; hWnd: THandle;  wMsg: Word): _SOCKET;
var
   NewSock: _SOCKET;
   liSockaddrSize: Integer;
   lsSockVal: array[0..10] of Char;
   liSockValLen: Integer;
   lsa_sockaddr: sockaddr_in;
begin
   liSockaddrSize := SizeOf(sockaddr_in);
   {Get the address and port that the command socket is using}
   if (getsockname(CommandSocket, lsa_sockaddr, liSockaddrSize) = 0) then
   begin
      {Create a new socket to use as the data socket}
      NewSock := CreateSocket;
      if (NewSock <> INVALID_SOCKET) then
      begin
         {If this is included in the FTP client, comment out the following lines}
         lsa_sockaddr.sin_port := htons((ntohs(lsa_sockaddr.sin_port) - 1));
         if (bind(NewSock, lsa_sockaddr, liSockaddrSize) = 0) then
         begin
            WSAAsyncSelect(NewSock, hWnd, wMsg, FD_CONNECT or FD_ACCEPT or FD_READ or FD_WRITE or FD_CLOSE);
         end
         else
         begin
            ShowMessage(SocketError);
            closesocket(NewSock);
            NewSock := INVALID_SOCKET;
         end
         {End of the FTP Server specific section }
      end;
   end
   else
      {You couldn't get the command socket address}
      NewSock := INVALID_SOCKET;
   {Return the data socket}
   CreateDataSocket := NewSock;
end;

function _TSocket.CreateListenSocket(hWnd: THandle; wMsg: Word; aiPort: Integer): _SOCKET;
var
   NewSock: _SOCKET;
   liSockaddrSize: Integer;
   lsa_sockaddr: sockaddr_in;
begin
   liSockaddrSize := SizeOf(sockaddr);
   {Create a new socket}
   NewSock := CreateSocket;
   {Specify the Internet Address family, the port passed as a function
   argument, and INADDR_ANY for the address. This causes bind() to
   use the computer TCP/IP address for binding}
   lsa_sockaddr.sin_family := PF_INET;
   lsa_sockaddr.sin_port := htons(aiPort);
   lsa_sockaddr.sin_addr.S_addr := INADDR_ANY;
   if (NewSock <> INVALID_SOCKET) then
   begin
      {Bind the socket to the address that you just specified}
      if (bind(NewSock, lsa_sockaddr, liSockaddrSize) = 0) then
      begin
         {Get the socket name (and address). This might return only zeros
         for the TCP/IP address}
         getsockname(NewSock, isa_sockaddr, liSockaddrSize);
         {Place the socket into asynchronous mode, telling it what event
         to trigger if one of the specified events occurs}
         WSAAsyncSelect(NewSock, hWnd, wMsg, FD_CONNECT or FD_ACCEPT or FD_READ or FD_WRITE or FD_CLOSE);
         {Tell the socket to listen for incoming connection requests}
         if (listen(NewSock, 1) = SOCKET_ERROR) then
         begin
            {If an error occurred, tell the user}
            ShowMessage(SocketError);
            closesocket(NewSock);
            NewSock := INVALID_SOCKET;
         end;
      end
      else
      begin
         {If an error occurred, tell the user}
         ShowMessage(SocketError);
         closesocket(NewSock);
         NewSock := INVALID_SOCKET;
      end
   end;
   {Return the new socket}
   CreateListenSocket := NewSock;
end;

function _TSocket.AcceptConnectingSocket(ListenSocket: _SOCKET; hWnd: THandle;  wMsg: Word): _SOCKET;
var
   NewSock: _SOCKET;
   liSockaddrSize: Integer;
begin
   liSockaddrSize := SizeOf(sockaddr);
   {Accept the incoming connection request, creating a new socket}
   NewSock := accept(ListenSocket, isa_sockaddr, liSockaddrSize);
   {Reset asynchronous mode on the new socket, changing which event
   it triggers}
   WSAAsyncSelect(NewSock, hWnd, wMsg, FD_CONNECT or FD_ACCEPT or FD_READ or FD_WRITE or FD_CLOSE);
   {Did you receive a valid socket?}
   if (NewSock = INVALID_SOCKET) then
      if (WSAGetLastError <> WSAEWOULDBLOCK) then
         ShowMessage(SocketError);
   {Return the new socket}
   AcceptConnectingSocket := NewSock;
end;

{The following function is similar to the previous function, only this one
is for use in a FTP client, in which the listening socket is needed only
until the data socket connection has been made}
function _TSocket.AcceptDataSocket(ListenSocket: _SOCKET; hWnd: THandle;  wMsg: Word): _SOCKET;
var
   NewSock: _SOCKET;
   liSockaddrSize: Integer;
begin
   liSockaddrSize := SizeOf(sockaddr);
   {Accept the incoming connection request, creating a new socket}
   NewSock := accept(ListenSocket, isa_sockaddr, liSockaddrSize);
   {Close the listening socket, as it's no longer needed}
   closesocket(ListenSocket);
   if (NewSock = INVALID_SOCKET) then
      if (WSAGetLastError <> WSAEWOULDBLOCK) then
         ShowMessage(SocketError);
   AcceptDataSocket := NewSock;
end;

{The following procedure is used to adjust the size of the buffer being
used by the WinSock services for sending and receiving data}
procedure _TSocket.SetSocketBufferSize(BufSocket: _SOCKET; NewSize: Integer);
var
   liBufSiz: Integer;
   liSize: Integer;
   liRetnVal: Integer;
begin
   liBufSiz := NewSize;
   liRetnVal := setsockopt(BufSocket, Integer(SOL_SOCKET), SO_RCVBUF, @liBufSiz, SizeOf(Integer));
end;

{The following function creates a raw socket, which can be used in a PING
or TRACEROUTE type of functionality. Unfortunately, not all WinSock 
implementations support raw sockets, so you may not be able to use this
function}
function _TSocket.CreateRawSocket: _SOCKET;
var
   NewSock: _SOCKET;
   lpProtoEntry: PProtoent;
   liProtoToUse: Integer;
begin
   {Get the ID of the ICMP protocol}
   lpProtoEntry := getprotobyname('icmp');
   {If a null number was returned, use the default protocol ID}
   if (lpProtoEntry = nil) then
      liProtoToUse := IPPROTO_ICMP
   else
      liProtoToUse := lpProtoEntry^.p_proto;
   {Create a raw socket}
   NewSock := socket(PF_INET, SOCK_RAW, liProtoToUse);
   if (NewSock = INVALID_SOCKET) then
   begin
        ShowMessage(SocketError);
   end;
   CreateRawSocket := NewSock;
end;

{This function returns the current value of the socket state flag}
function _TSocket.GetSocketState: Integer;
begin
   GetSocketState := ii_SocketState;
end;

{This procedure looks up the Internet address of the requested "host" computer}
procedure _TSocket.GetHostAddress(hWnd: THandle;  wMsg: Word; lsHostName: String; NewState: Integer);
var
   ltHandle: THandle;
begin
   {Free the current memory held by the ispHostName pointer}
   StrDispose(ispHostName);
   {Allocate new memory to hold the requested host name}
   ispHostName := StrAlloc(Length(lsHostName) + 1);
   {Copy the host computer name into the allocated memory}
   StrPCopy(ispHostName, lsHostName);
   {Free the memory held by the record that will be returned}
   StrDispose(icp_Buffer);
   {Allocate memory for holding the host address}
   icp_Buffer := StrAlloc((MAXGETHOSTSTRUCT + 1));
   ii_SocketState := NewState;
   {Request the host address}
   ltHandle := WSAAsyncGetHostByName(hWnd, wMsg, ispHostName, icp_Buffer,
                               (MAXGETHOSTSTRUCT + 1));
   if (ltHandle = 0) then
      ShowMessage(SocketError);
end;

{This function returns the description of the WinSock system}
function _TSocket.GetSocketDescription: String;
begin
   GetSocketDescription := StrPas(isp_WinSockInfo.szDescription);
end;

{This function returns the current state of the TCP/IP network running 
on this computer}
function _TSocket.GetSocketSystemState: String;
begin
   GetSocketSystemState := StrPas(isp_WinSockInfo.szSystemStatus);
end;

{This function returns the maximum number of available sockets}
function _TSocket.GetMaxNumSockets: Integer;
begin
   GetMaxNumSockets := isp_WinSockInfo.iMaxSockets;
end;

{This function returns the maximum size that can be used for UDP packets}
function _TSocket.GetUDPPacketSize: Word;
begin
   GetUDPPacketSize := isp_WinSockInfo.iMaxUdpDg;
end;

{This function determines whether a valid address was returned for
the requested host computer}
function _TSocket.ProcessHostAddress: Boolean;
var
   lhe_HostEntBuf: PHostEnt;
   llLength: LongInt;
begin
   {Cast the host address buffer as a THostEnt record}
   ihe_HostEntry := PHostEnt(icp_Buffer);
   {Check the length of the address}
   if (ihe_HostEntry^.h_length <= 0) then
      ProcessHostAddress := FALSE
   else
   begin
      try
         {Allocate new memory to hold the new host addresses}
         llLength := StrLen(ihe_HostEntry^.h_addr_list^);
         StrDispose(isp_HostAddressList);
         if (llLength < ihe_HostEntry^.h_length) then
            isp_HostAddressList := StrAlloc(llLength)
         else
            isp_HostAddressList := StrAlloc(ihe_HostEntry^.h_length + 1);
         {Copy the new addresses into the new memory}
         StrLCopy(isp_HostAddressList, PChar(ihe_HostEntry^.h_addr_list^), ihe_HostEntry^.h_length);
         isp_HostAddressList[ihe_HostEntry^.h_length] := Char(0);
         ProcessHostAddress := TRUE;
      except
         ProcessHostAddress := FALSE;
      end;
   end;
end;

{This procedure closes a socket connection}
procedure _TSocket.CloseSocketConnection(SocketToClose: _SOCKET);
begin
   closesocket(SocketToClose);
end;

function _TSocket.OpenSocketConnection(hWnd: THandle;  wMsg: Word; NewState: Integer; ConnectPort: Integer): _SOCKET;
var
   NewSocket: _Socket;
   lcAddress: PChar;
   lsAddress: String;
   llAddress: LongInt;
begin
   {Create a new socket}
   NewSocket := CreateSocket;
   if (NewSocket <> INVALID_SOCKET) then
   begin
      {Set the socket address information, Protocol, port, and address to which
      to connect}
      isa_SocketAddress.sin_family := AF_INET;
      isa_SocketAddress.sin_port := htons(ConnectPort);
      lsAddress := GetHostAddressString;
      lcAddress := StrAlloc(Length(lsAddress) + 1);
      StrPCopy(lcAddress, lsAddress);
      llAddress := inet_addr(lcAddress);
      StrDispose(lcAddress);
      isa_SocketAddress.sin_addr.s_addr := llAddress;
      isa_SocketAddress.sin_zero[0] := Char(0);
      {Set the socket into asynchronous mode, so it will trigger the wMsg
      event in the hWnd window when the connection has been made}
      WSAAsyncSelect(NewSocket, hWnd, wMsg, FD_CONNECT or FD_WRITE or FD_READ or FD_CLOSE);
      ii_SocketState := NewState;
      {Connect the socket to the other computer}
      if (connect(NewSocket, isa_SocketAddress, 16) = SOCKET_ERROR) then
      begin
         if (WSAGetLastError <> WSAEWOULDBLOCK) then
            ShowMessage(SocketError);
      end;
   end;
   OpenSocketConnection := NewSocket
end;

procedure _TSocket.OpenDataSocketConnection(hWnd: THandle;  wMsg: Word;
                 NewSocket: _SOCKET; HostAddr: String; ConnectPort: Integer);
var
   lcAddress: PChar;
   llAddress: LongInt;
begin
   {Check to ensure that you have received a valid socket}
   if (NewSocket <> INVALID_SOCKET) then
   begin
      {Specify the connection protocol, port, and address}
      isa_SocketAddress.sin_family := AF_INET;
      isa_SocketAddress.sin_port := htons(ConnectPort);
      lcAddress := StrAlloc(Length(HostAddr) + 1);
      StrPCopy(lcAddress, HostAddr);
      llAddress := inet_addr(lcAddress);
      StrDispose(lcAddress);
      isa_SocketAddress.sin_addr.s_addr := llAddress;
      isa_SocketAddress.sin_zero[0] := Char(0);
      {Connect the socket to the data socket on the FTP server}
      if (connect(NewSocket, isa_SocketAddress, 16) = SOCKET_ERROR) then
      begin
         {If you received an error, inform the user}
         if (WSAGetLastError <> WSAEWOULDBLOCK) then
            ShowMessage(SocketError);
      end;
   end;
end;

{This is a simple checksum function for use in Ping functionality}
function _TSocket.InetChecksum(Data: PWORD; DataLength: WORD): WORD;
var
   llSum: LongInt;
   lwOddByte: BYTE;
begin
   llSum := 0;
   while (DataLength > 1) do
   begin
      llSum := llSum + LongInt(Data^);
      Inc(Data);
      DataLength := DataLength - 2;
   end;
   if (DataLength = 1) then
   begin
      lwOddByte := 0;
      lwOddByte := BYTE(Data^);
      llSum := llSum + lwOddByte;
   end;
   llSum := (llSum SHR 16) + (llSum and $ffff);
   llSum := llSum + (llSum SHR 16);
   InetChecksum := WORD(not llSum);
end;

{This function sends out a ping}
function _TSocket.SendPing(hWnd: THandle; wMsg: Word; NewState: Integer): _SOCKET;
var
   NewSocket: _SOCKET;
   liPacketSize: Integer;
   liBytesSent: Integer;
begin
   NewSocket := CreateRawSocket;
   if (NewSocket <> INVALID_SOCKET) then
   begin
      isa_SocketAddress.sin_family := AF_INET;
      isa_SocketAddress.sin_addr := in_addr(ihe_HostEntry^.h_addr_list);
      WSAAsyncSelect(NewSocket, hWnd, wMsg, FD_READ and FD_WRITE);
      ii_SocketState := NewState;
      StrDispose(PChar(ip_icmp));
      ip_icmp := Picmp(StrAlloc(1024));
      ip_icmp^.icmp_type := ICMP_ECHO;
      ip_icmp^.icmp_code := 0;
      ip_icmp^.icmp_id := hWnd;
      ihPingID := hWnd;
      ip_icmp^.icmp_seq := 0;
      ip_icmp^.icmp_cksum := 0;
      iwSendTimeStamp := GetTickCount;
      liPacketSize := ICMP_HEADERSIZE + SizeOf(LongInt);
      ip_icmp^.icmp_cksum := InetChecksum(PWORD(ip_icmp), liPacketSize);
      if (ip_icmp^.icmp_cksum <> 0) then
      begin
         liBytesSent := sendto(NewSocket, PChar(ip_icmp), liPacketSize,
                        0, TSOCKADDR(isa_SocketAddress), SizeOf(isa_SocketAddress));
         if ((liBytesSent = SOCKET_ERROR) or (liBytesSent <> liPacketSize)) then
         begin
            CloseSocketConnection(NewSocket);
            ShowMessage(SocketError);
            NewSocket := INVALID_SOCKET;
         end;
      end
      else
      begin
         CloseSocketConnection(NewSocket);
         ShowMessage('Checksum Error. Computation Result was Zero.');
         NewSocket := INVALID_SOCKET;
      end;
   end;
   SendPing := NewSocket;
end;

{This function receives a ping}
procedure _TSocket.RecvPing(RecvSocket: _SOCKET; NewState: Integer);
var
   liHostAddrLength: Integer;
   liBytesRecvd: Integer;
begin
   StrDispose(icp_Buffer);
   icp_Buffer := StrAlloc(1024);
   liHostAddrLength := SizeOf(isa_SocketHostAddress);
   ii_SocketState := NewState;
   liBytesRecvd := recvfrom(RecvSocket, icp_Buffer, 1024, 0,
                   TSOCKADDR(isa_SocketHostAddress), liHostAddrLength);
end;

{This function converts the received address for the host computer into
a string and returns it to the calling function}
function _TSocket.GetHostAddressString: String;
var
   lsHostAddress: String;
begin
    lsHostAddress := IntToStr(Integer(isp_HostAddressList[0])) + '.' +
                     IntToStr(Integer(isp_HostAddressList[1])) + '.' +
                     IntToStr(Integer(isp_HostAddressList[2])) + '.' +
                     IntToStr(Integer(isp_HostAddressList[3]));
    GetHostAddressString := lsHostAddress;
end;

{This procedure processes a ping reply to determine the roundtrip time}
procedure _TSocket.ProcessPingReply;
var
   liIPHeadLength: Integer;
begin
   iwReceiveTimeStamp := GetTickCount;
   iwRoundTripTimeStamp := iwReceiveTimeStamp - iwSendTimeStamp;
   ibPingAlive := FALSE;
   ipHeader := Pip(icp_Buffer);
   liIPHeadLength := ((ipHeader^.ip_verlen SHR 4) SHL 2);
   ip_icmp := Picmp(icp_Buffer + liIPHeadLength);
   if (ip_icmp^.icmp_type = ICMP_ECHOREPLY) then
   begin
      if (ip_icmp^.icmp_id = ihPingID) then
      begin
         ibPingAlive := TRUE;
      end;
   end;
end;

{This function converts the ping reply into a string for display}
function _TSocket.GetPingReplyString: String;
begin
   if ibPingAlive then
      GetPingReplyString := 'Round-trip travel time to ' + StrPas(ihe_HostEntry^.h_name) + ' [' +
                         GetHostAddressString + '] was ' + IntToStr(iwRoundTripTimeStamp) + ' milliseconds.'
   else
      GetPingReplyString := 'Could not reach ' + StrPas(ihe_HostEntry^.h_name) + ' [' + GetHostAddressString + '].';
end;

{This procedure sends a message over a open socket connection}
procedure _TSocket.SocketSend(SendSocket: _SOCKET; hWnd: THandle; wMsg: Word; sSendStr: String; NewState: Integer);
var
   liBytesSent: Integer;
begin
   ii_SocketState := NewState;
   {Convert the string into a null-terminated string (PChar), adding a 
   carrage-return/new-line on the end}
   StrDispose(icp_Buffer);
   icp_Buffer := StrAlloc(1024);
   StrPCopy(icp_Buffer, (sSendStr + #13#10));
   {Send the string to the other computer}
   liBytesSent := send(SendSocket, icp_Buffer, StrLen(icp_Buffer), 0);
   if (liBytesSent = SOCKET_ERROR) then
      if (WSAGetLastError <> WSAEWOULDBLOCK) then
         ShowMessage(SocketError);
end;

{This function is pretty much the same as the previous, but expects to be
passed a PChar string instead of a Pascal string}
procedure _TSocket.SocketSendMessage(SendSocket: _SOCKET; hWnd: THandle; wMsg: Word; sSendStr: PChar;
                                                 iStrLen, NewState: Integer);
var
   liBytesSent: Integer;
begin
   ii_SocketState := NewState;
   WSAAsyncSelect(SendSocket, hWnd, wMsg, FD_WRITE or FD_READ or FD_CLOSE);
   liBytesSent := send(SendSocket, sSendStr, iStrLen, 0);
   if (liBytesSent = SOCKET_ERROR) then
      if (WSAGetLastError <> WSAEWOULDBLOCK) then
         ShowMessage(SocketError);
end;

{This procedure sends a buffer of data}
procedure _TSocket.SocketSendBuffer(SendSocket: _SOCKET; hWnd: THandle; wMsg: Word;
                                      sSendStr: PChar; iStrLen, NewState: Integer);
begin
   SocketSendMessage(SendSocket, hWnd, wMsg, sSendStr, iStrLen, NewState);
end;

{This procedure receives data from a open socket connection}
procedure _TSocket.SocketReceive(RecvSocket: _SOCKET; hWnd: THandle; wMsg: Word;
                                             sBuffer: PChar; BufSize: Integer; NewState: Integer);
var
   liBytesReceived: LongInt;
   llBytesQueued: LongInt;
begin
   {Make sure that the socket is operating in asynchronous mode}
   WSAAsyncSelect(RecvSocket, hWnd, wMsg, FD_WRITE or FD_READ or FD_CLOSE);
   {Receive any incoming data that is available}
   liBytesReceived := recv(RecvSocket, sBuffer, BufSize, 0);
   if (liBytesReceived = SOCKET_ERROR) then
   begin
      if (WSAGetLastError <> WSAEWOULDBLOCK) then
         ShowMessage(SocketError);
   end;
   ii_SocketState := NewState;
end;

{This procedure looks to see if there is any incoming data available for 
receiving. This procedure is mostly useful when using sockets in synchronous
mode, either blocking or non-blocking}
procedure _TSocket.SocketReceivePeek(RecvSocket: _SOCKET; hWnd: THandle; wMsg: Word;
                                             sBuffer: PChar; BufSize: Integer; NewState: Integer);
var
   liBytesReceived: LongInt;
   llBytesQueued: LongInt;
begin
   {Make sure that the socket is not in asynchronous mode}
   WSAAsyncSelect(RecvSocket, hWnd, 0, 0);
   {Check to see how much is queued for receiving}
   ioctlsocket(RecvSocket, FIONREAD, llBytesQueued);
   if (llBytesQueued <> 0) then
   begin
      {If there is any available, receive it}
      liBytesReceived := recv(RecvSocket, sBuffer, BufSize, MSG_PEEK);
      if (liBytesReceived = SOCKET_ERROR) then
      begin
         if (WSAGetLastError <> WSAEWOULDBLOCK) then
            ShowMessage(SocketError);
      end
      else
      begin
         {Make sure that the received data has been terminated}
         if (liBytesReceived > 0) then
            sBuffer[liBytesReceived] := Char(0);
      end;
   end;
   ii_SocketState := NewState;
end;

function _TSocket.ProcessReceive: PChar;
begin
   ProcessReceive := icp_Buffer;
end;

procedure _TSocket.GetReceive(RecvSocket: _SOCKET; hWnd: THandle; wMsg: Word; sBuffer: PChar; BufSize: Integer);
var
   llDataInLngth, llDataRecv: LongInt;
   lsTempStr: String;
begin
   WSAAsyncSelect(RecvSocket, hWnd, 0, 0);
   sBuffer[0] := Char(0);
   ioctlsocket(RecvSocket, FIONREAD, llDataInLngth);
   llDataRecv := recv(RecvSocket, sBuffer, BufSize, 0);
   sBuffer[llDataRecv] := Char(0);
   WSAAsyncSelect(RecvSocket, hWnd, wMsg, FD_READ or FD_WRITE or FD_CLOSE);
end;

{This procedure sets the socket state flag}
procedure _TSocket.SetSocketState(NewState: Integer);
begin
   ii_SocketState := NewState;
end;

{This function returns true or false depending on whether a error
has occured on the socket}
function _TSocket.CheckSocketError: Boolean;
begin
   if (WSAGetLastError <> WSAEWOULDBLOCK) then
      CheckSocketError := TRUE
   else
      CheckSocketError := FALSE;
end;

function _TSocket.GetLine(TargetString, SourceString: PChar): Boolean;
var
   liCurPos: Integer;
   liCarRetnPos: Integer;
   liCopyPos: Integer;
begin
   {Initialize the position pointer}
   liCurPos := 0;
   {Scan the SourceString buffer until the first carriage-return or
   null character is found, copying the characters into the
   TargetString buffer as you scan}
   while ((SourceString[liCurPos] <> Char(13)) and
         (SourceString[liCurPos] <> Char(0))) do
   begin
      TargetString[liCurPos] := SourceString[liCurPos];
      Inc(liCurPos);
   end;
   {Terminate the TargetString buffer with a null character}
   TargetString[liCurPos] := Char(0);
   {Did you find a carriage-return?}
   if (SourceString[liCurPos] = Char(13)) then
   begin
      {Move everything after the newline character forward, removing
      the copied line from the SourceString buffer}
      liCopyPos := 0;
      if (SourceString[(liCurPos + 1)] = Char(10)) then
      begin
         liCurPos := (liCurPos + 2);
         while (SourceString[liCurPos] <> Char(0)) do
         begin
            SourceString[liCopyPos] := SourceString[liCurPos];
            Inc(liCurPos);
            Inc(liCopyPos);
         end;
         {Terminate the SourceString buffer}
         SourceString[liCopyPos] := Char(0);
         {Return TRUE to indicate that you are returning a complete line}
         GetLine := TRUE;
      end
      else
      begin
         {The first character after the carriage-return was not a 
         newline character, so return FALSE, to indicate that you are
         not returning a complete line}
         SourceString[0] := Char(0);
         GetLine := FALSE;
      end;
   end
   else
   begin
      {You ended on a null character, return FALSE to indicate that you
      are not returning a complete line}
      SourceString[0] := Char(0);
      GetLine := FALSE;
   end;
end;

{This function formats the socket address in the format needed in the FTP
PORT and PASV commands}
function _TSocket.GetSockAddr: String;
var
   lsSockAddress: String;
begin
    lsSockAddress := IntToStr(Integer(isa_sockaddr.sa_data[2])) + ',' +
                     IntToStr(Integer(isa_sockaddr.sa_data[3])) + ',' +
                     IntToStr(Integer(isa_sockaddr.sa_data[4])) + ',' +
                     IntToStr(Integer(isa_sockaddr.sa_data[5])) + ',' +
                     IntToStr(Integer(isa_sockaddr.sa_data[0])) + ',' +
                     IntToStr(Integer(isa_sockaddr.sa_data[1]));
    GetSockAddr := lsSockAddress;
end;

function _TSocket.IsSocketConnected(TestSocket: _SOCKET): Boolean;
var
   lst_peeraddr: sockaddr;
   li_namelen: Integer;
begin
   {Allocate memory for the other computer's address}
   li_namelen := SizeOf(sockaddr);
   {Request the other computer's address}
   if (getpeername(TestSocket, lst_peeraddr, li_namelen) = 0) then
      {No errors, you must be connected}
      IsSocketConnected := TRUE
   else
   begin
      {You received an error, was it NOT CONNECTED?}
      if (WSAGetLastError <> WSAENOTCONN) then
         ShowMessage(SocketError)
      else
         {You are not connected}
         IsSocketConnected := FALSE;
   end;
end;

end.
