unit ICMPUtils;

interface

{$IFDEF VER80}

{

This source file is *NOT* compatible with Delphi 1 because it uses

Win 32 features.

}

{$ENDIF}

uses

  Windows, SysUtils, Classes, WinSock;

const

  IcmpVersion = ;

  IcmpDLL     = 'icmp.dll';

  {IP status codes returned to transports and user IOCTLs.}

  IP_SUCCESS                  = ;

  IP_STATUS_BASE              = ;

  IP_BUF_TOO_SMALL            = (IP_STATUS_BASE + );

  IP_DEST_NET_UNREACHABLE     = (IP_STATUS_BASE + );

  IP_DEST_HOST_UNREACHABLE    = (IP_STATUS_BASE + );

  IP_DEST_PROT_UNREACHABLE    = (IP_STATUS_BASE + );

  IP_DEST_PORT_UNREACHABLE    = (IP_STATUS_BASE + );

  IP_NO_RESOURCES             = (IP_STATUS_BASE + );

  IP_BAD_OPTION               = (IP_STATUS_BASE + );

  IP_HW_ERROR                 = (IP_STATUS_BASE + );

  IP_PACKET_TOO_BIG           = (IP_STATUS_BASE + );

  IP_REQ_TIMED_OUT            = (IP_STATUS_BASE + );

  IP_BAD_REQ                  = (IP_STATUS_BASE + );

  IP_BAD_ROUTE                = (IP_STATUS_BASE + );

  IP_TTL_EXPIRED_TRANSIT      = (IP_STATUS_BASE + );

  IP_TTL_EXPIRED_REASSEM      = (IP_STATUS_BASE + );

  IP_PARAM_PROBLEM            = (IP_STATUS_BASE + );

  IP_SOURCE_QUENCH            = (IP_STATUS_BASE + );

  IP_OPTION_TOO_BIG           = (IP_STATUS_BASE + );

  IP_BAD_DESTINATION          = (IP_STATUS_BASE + ); 

  {status codes passed up on status indications.}

  IP_ADDR_DELETED             = (IP_STATUS_BASE + );

  IP_SPEC_MTU_CHANGE          = (IP_STATUS_BASE + );

  IP_MTU_CHANGE               = (IP_STATUS_BASE + ); 

  IP_GENERAL_FAILURE          = (IP_STATUS_BASE + ); 

  MAX_IP_STATUS               = IP_GENERAL_FAILURE; 

  IP_PENDING                  = (IP_STATUS_BASE + ); 

  {IP header flags}

  IP_FLAG_DF                  = $; {Don't fragment this packet.}

  {IP Option Types}

  IP_OPT_EOL                  = $; {End of list option}

  IP_OPT_NOP                  = $; {No operation}

  IP_OPT_SECURITY             = $; {Security option.}

  IP_OPT_LSRR                 = $; {Loose source route.}

  IP_OPT_SSRR                 = $; {Strict source route.}

  IP_OPT_RR                   = $; {Record route.}

  IP_OPT_TS                   = $; {Timestamp.}

  IP_OPT_SID                  = $; {Stream ID (obsolete)}

  MAX_OPT_SIZE                = $; 

type

  {IP types}

  TIPAddr   = DWORD; {An IP address.}

  TIPMask   = DWORD; {An IP subnet mask.}

  TIPStatus = DWORD; {Status code returned from IP APIs.}

  PIPOptionInformation = ^TIPOptionInformation;

  TIPOptionInformation = packed record

     TTL:         Byte; {Time To Live (used for traceroute)}

     TOS:         Byte; {Type Of Service (usually 0)}

     Flags:       Byte; {IP header flags (usually 0)}

     OptionsSize: Byte; {Size of options data (usually 0, max 40)}

     OptionsData: PChar; {Options data buffer}

  end; 

  PIcmpEchoReply = ^TIcmpEchoReply;

  TIcmpEchoReply = packed record

     Address:       TIPAddr; {Replying address}

     Status:        DWord; {IP status value}

     RTT:           DWord; {Round Trip Time in milliseconds}

     DataSize:      Word; {Reply data size}

     Reserved:      Word; {Reserved}

     Data:          Pointer; {Pointer to reply data buffer}

     Options:       TIPOptionInformation; {Reply options}

  end; 

{

  IcmpCreateFile:

      Opens a handle on which ICMP Echo Requests can be issued.

  Arguments:

      None.

  Return Value:

      An open file handle or INVALID_HANDLE_VALUE. Extended error information

      is available by calling GetLastError().

}

  TIcmpCreateFile  = function: THandle; stdcall;

{

  IcmpCloseHandle:

      Closes a handle opened by ICMPOpenFile.

  Arguments:

      IcmpHandle  - The handle to close.

  Return Value:

      TRUE if the handle was closed successfully, otherwise FALSE. Extended

      error information is available by calling GetLastError().

}

  TIcmpCloseHandle = function(IcmpHandle: THandle): Boolean; stdcall; 

{

  IcmpSendEcho:

      Sends an ICMP Echo request and returns one or more replies. The

      call returns when the timeout has expired or the reply buffer

      is filled.

  Arguments:

      IcmpHandle         - An open handle returned by ICMPCreateFile.

      DestinationAddress - The destination of the echo request.

      RequestData        - A buffer containing the data to send in the

                           request.

      RequestSize        - The number of bytes in the request data buffer.

      RequestOptions     - Pointer to the IP header options for the request.

                           May be NULL.

      ReplyBuffer        - A buffer to hold any replies to the request.

                           On return, the buffer will contain an array of

                           ICMP_ECHO_REPLY structures followed by options

                           and data. The buffer should be large enough to

                           hold at least one ICMP_ECHO_REPLY structure

                           and 8 bytes of data - this is the size of

                           an ICMP error message.

      ReplySize          - The size in bytes of the reply buffer.

      Timeout            - The time in milliseconds to wait for replies.

  Return Value:

      Returns the number of replies received and stored in ReplyBuffer. If

      the return value is zero, extended error information is available

      via GetLastError().

}

  TIcmpSendEcho    = function(IcmpHandle:          THandle;

                              DestinationAddress:  TIPAddr;

                              RequestData:         Pointer;

                              RequestSize:         Word;

                              RequestOptions:      PIPOptionInformation;

                              ReplyBuffer:         Pointer;

                              ReplySize:           DWord;

                              Timeout:             DWord

                             ): DWord; stdcall; 

  {Event handler type declaration for TICMP.OnDisplay event.}

  TICMPDisplay = procedure(Sender: TObject; Msg : String) of object;

  TICMPReply   = procedure(Sender: TObject; Error : Integer) of object;

  {The object wich encapsulate the ICMP.DLL}

  TICMP = class(TObject)

  private

    hICMPdll :        HModule; {Handle for ICMP.DLL}

    IcmpCreateFile :  TIcmpCreateFile;

    IcmpCloseHandle : TIcmpCloseHandle;

    IcmpSendEcho :    TIcmpSendEcho;

    hICMP :           THandle; {Handle for the ICMP Calls}

    FReply :          TIcmpEchoReply; {ICMP Echo reply buffer}

    FAddress :        String; {Address given}

    FHostName :       String; {Dotted IP of host (output)}

    FHostIP :         String; {Name of host      (Output)}

    FIPAddress :      TIPAddr; {Address of host to contact}

    FSize :           Integer; {Packet size (default to 56)}

    FTimeOut :        Integer; {Timeout (default to 4000mS)}

    FTTL :            Integer; {Time To Live (for send)}

    FOnDisplay :      TICMPDisplay; {Event handler to display}

    FOnEchoRequest :  TNotifyEvent;

    FOnEchoReply :    TICMPReply;

    FLastError :      DWORD; {After sending ICMP packet}

    FAddrResolved :   Boolean;

    procedure ResolveAddr;

  public

    constructor Create; virtual;

    destructor  Destroy; override;

    function    Ping : Integer;

    procedure   SetAddress(Value : String);

    function    GetErrorString : String; 

    property Address       : String         read  FAddress   write SetAddress;

    property Size          : Integer        read  FSize      write FSize;

    property Timeout       : Integer        read  FTimeout   write FTimeout;

    property Reply         : TIcmpEchoReply read  FReply;

    property TTL           : Integer        read  FTTL       write FTTL;

    property ErrorCode     : Cardinal       read  FLastError;

    property ErrorString   : String         read  GetErrorString;

    property HostName      : String         read  FHostName;

    property HostIP        : String         read  FHostIP;

    property OnDisplay     : TICMPDisplay   read  FOnDisplay write FOnDisplay;

    property OnEchoRequest : TNotifyEvent   read  FOnEchoRequest

                                            write FOnEchoRequest;

    property OnEchoReply   : TICMPReply     read  FOnEchoReply

                                            write FOnEchoReply;

  end; 

  TICMPException = class(Exception); 

implementation 

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

constructor TICMP.Create;

var

  WSAData: TWSAData;

begin

  hICMP := INVALID_HANDLE_VALUE;

  FSize := ;

  FTTL := ;

  FTimeOut := ;

  {initialise winsock}

  if WSAStartup($, WSAData) <>  then

    raise TICMPException.Create('Error initialising Winsock');

  {register the icmp.dll stuff}

  hICMPdll := LoadLibrary(icmpDLL);

  if hICMPdll =  then

    raise TICMPException.Create('Unable to register ' + icmpDLL);

  @ICMPCreateFile := GetProcAddress(hICMPdll, 'IcmpCreateFile');

  @IcmpCloseHandle := GetProcAddress(hICMPdll, 'IcmpCloseHandle');

  @IcmpSendEcho := GetProcAddress(hICMPdll, 'IcmpSendEcho');

  if (@ICMPCreateFile = nil)

    or (@IcmpCloseHandle = nil)

    or (@IcmpSendEcho = nil) then

    raise TICMPException.Create('Error loading dll functions');

  hICMP := IcmpCreateFile;

  if hICMP = INVALID_HANDLE_VALUE then

    raise TICMPException.Create('Unable to get ping handle');

end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

destructor TICMP.Destroy;

begin

  if hICMP <> INVALID_HANDLE_VALUE then

    IcmpCloseHandle(hICMP);

  if hICMPdll <>  then

    FreeLibrary(hICMPdll);

  WSACleanup;

  inherited Destroy;

end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

function MinInteger(X, Y: Integer): Integer;

begin

  if X >= Y then

    Result := Y

  else

    Result := X;

end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

procedure TICMP.ResolveAddr;

var

  Phe: PHostEnt; {HostEntry buffer for name lookup}

begin

  {Convert host address to IP address}

  FIPAddress := inet_addr(PAnsiChar(AnsiString(FAddress)));

  if FIPAddress <> INADDR_NONE then

    {Was a numeric dotted address let it in this format}

    FHostName := FAddress

  else begin

    {Not a numeric dotted address, try to resolve by name}

    Phe := GetHostByName(PAnsiChar(AnsiString(FAddress)));

    if Phe = nil then

    begin

      FLastError := GetLastError;

      if Assigned(FOnDisplay) then

        FOnDisplay(Self, 'Unable to resolve ' + FAddress);

      Exit;

    end;

    FIPAddress := longint(plongint(Phe^.h_addr_list^)^);

    FHostName := Phe^.h_name;

  end;

  FHostIP := StrPas(inet_ntoa(TInAddr(FIPAddress)));

  FAddrResolved := TRUE;

end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

procedure TICMP.SetAddress(Value : String);

begin

  {Only change if needed (could take a long time)}

  if FAddress = Value then

    Exit;

  FAddress := Value;

  FAddrResolved := FALSE;

//  ResolveAddr;

end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

function TICMP.GetErrorString : String;

begin

  case FLastError of

    IP_SUCCESS:               Result := 'No error';

    IP_BUF_TOO_SMALL:         Result := 'Buffer too small';

    IP_DEST_NET_UNREACHABLE:  Result := 'Destination network unreachable';

    IP_DEST_HOST_UNREACHABLE: Result := 'Destination host unreachable';

    IP_DEST_PROT_UNREACHABLE: Result := 'Destination protocol unreachable';

    IP_DEST_PORT_UNREACHABLE: Result := 'Destination port unreachable';

    IP_NO_RESOURCES:          Result := 'No resources';

    IP_BAD_OPTION:            Result := 'Bad option';

    IP_HW_ERROR:              Result := 'Hardware error';

    IP_PACKET_TOO_BIG:        Result := 'Packet too big';

    IP_REQ_TIMED_OUT:         Result := 'Request timed out';

    IP_BAD_REQ:               Result := 'Bad request';

    IP_BAD_ROUTE:             Result := 'Bad route';

    IP_TTL_EXPIRED_TRANSIT:   Result := 'TTL expired in transit';

    IP_TTL_EXPIRED_REASSEM:   Result := 'TTL expired in reassembly';

    IP_PARAM_PROBLEM:         Result := 'Parameter problem';

    IP_SOURCE_QUENCH:         Result := 'Source quench';

    IP_OPTION_TOO_BIG:        Result := 'Option too big';

    IP_BAD_DESTINATION:       Result := 'Bad Destination';

    IP_ADDR_DELETED:          Result := 'Address deleted';

    IP_SPEC_MTU_CHANGE:       Result := 'Spec MTU change';

    IP_MTU_CHANGE:            Result := 'MTU change';

    IP_GENERAL_FAILURE:       Result := 'General failure';

    IP_PENDING:               Result := 'Pending';

  else

    Result := 'ICMP error #' + IntToStr(FLastError);

  end;

end; 

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

function TICMP.Ping : Integer;

var

  BufferSize: Integer;

  pReqData, pData: Pointer;

  pIPE: PIcmpEchoReply; {ICMP Echo reply buffer}

  IPOpt: TIPOptionInformation; {IP Options for packet to send}

  Msg: String;

begin

  Result := ;

  FLastError := ;

  if not FAddrResolved then

    ResolveAddr;

  if FIPAddress = INADDR_NONE then

  begin

    FLastError := IP_BAD_DESTINATION;

    if Assigned(FOnDisplay) then

      FOnDisplay(Self, 'Invalid host address');

    Exit;

  end;

  {Allocate space for data buffer space}

  BufferSize := SizeOf(TICMPEchoReply) + FSize;

  GetMem(pReqData, FSize);

  GetMem(pData, FSize);

  GetMem(pIPE, BufferSize);

  try

    {Fill data buffer with some data bytes}

    FillChar(pReqData^, FSize, $);

    Msg := 'Pinging from Delphi code written by F. Piette';

    Move(Msg[], pReqData^, MinInteger(FSize, Length(Msg))); 

    pIPE^.Data := pData;

    FillChar(pIPE^, SizeOf(pIPE^), ); 

    if Assigned(FOnEchoRequest) then

      FOnEchoRequest(Self);

    FillChar(IPOpt, SizeOf(IPOpt), );

    IPOpt.TTL := FTTL;

    Result := IcmpSendEcho(hICMP, FIPAddress, pReqData, FSize,

                               @IPOpt, pIPE, BufferSize, FTimeOut);

    FLastError := GetLastError;

    FReply := pIPE^;

    if Assigned(FOnEchoReply) then

      FOnEchoReply(Self, Result);

  finally

    {Free those buffers}

    FreeMem(pIPE);

    FreeMem(pData);

    FreeMem(pReqData);

  end;

end;

end.