一个ICMP单元

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 = 102;
  IcmpDLL     = 'icmp.dll';

  {IP status codes returned to transports and user IOCTLs.}
  IP_SUCCESS                  = 0;
  IP_STATUS_BASE              = 11000;
  IP_BUF_TOO_SMALL            = (IP_STATUS_BASE + 1);
  IP_DEST_NET_UNREACHABLE     = (IP_STATUS_BASE + 2);
  IP_DEST_HOST_UNREACHABLE    = (IP_STATUS_BASE + 3);
  IP_DEST_PROT_UNREACHABLE    = (IP_STATUS_BASE + 4);
  IP_DEST_PORT_UNREACHABLE    = (IP_STATUS_BASE + 5);
  IP_NO_RESOURCES             = (IP_STATUS_BASE + 6); 
  IP_BAD_OPTION               = (IP_STATUS_BASE + 7); 
  IP_HW_ERROR                 = (IP_STATUS_BASE + 8); 
  IP_PACKET_TOO_BIG           = (IP_STATUS_BASE + 9); 
  IP_REQ_TIMED_OUT            = (IP_STATUS_BASE + 10); 
  IP_BAD_REQ                  = (IP_STATUS_BASE + 11); 
  IP_BAD_ROUTE                = (IP_STATUS_BASE + 12); 
  IP_TTL_EXPIRED_TRANSIT      = (IP_STATUS_BASE + 13); 
  IP_TTL_EXPIRED_REASSEM      = (IP_STATUS_BASE + 14); 
  IP_PARAM_PROBLEM            = (IP_STATUS_BASE + 15); 
  IP_SOURCE_QUENCH            = (IP_STATUS_BASE + 16); 
  IP_OPTION_TOO_BIG           = (IP_STATUS_BASE + 17); 
  IP_BAD_DESTINATION          = (IP_STATUS_BASE + 18); 

  {status codes passed up on status indications.}
  IP_ADDR_DELETED             = (IP_STATUS_BASE + 19); 
  IP_SPEC_MTU_CHANGE          = (IP_STATUS_BASE + 20); 
  IP_MTU_CHANGE               = (IP_STATUS_BASE + 21); 

  IP_GENERAL_FAILURE          = (IP_STATUS_BASE + 50); 

  MAX_IP_STATUS               = IP_GENERAL_FAILURE; 

  IP_PENDING                  = (IP_STATUS_BASE + 255); 

  {IP header flags}
  IP_FLAG_DF                  = $02; {Don't fragment this packet.}

  {IP Option Types}
  IP_OPT_EOL                  = $00; {End of list option}
  IP_OPT_NOP                  = $01; {No operation}
  IP_OPT_SECURITY             = $82; {Security option.}
  IP_OPT_LSRR                 = $83; {Loose source route.}
  IP_OPT_SSRR                 = $89; {Strict source route.}
  IP_OPT_RR                   = $07; {Record route.}
  IP_OPT_TS                   = $44; {Timestamp.}
  IP_OPT_SID                  = $88; {Stream ID (obsolete)}
  MAX_OPT_SIZE                = $40; 

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 := 56;
  FTTL := 64;
  FTimeOut := 4000;

  {initialise winsock}
  if WSAStartup($101, WSAData) <> 0 then
    raise TICMPException.Create('Error initialising Winsock');

  {register the icmp.dll stuff}
  hICMPdll := LoadLibrary(icmpDLL);
  if hICMPdll = 0 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 <> 0 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 := 0;
  FLastError := 0;

  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, $20); 
    Msg := 'Pinging from Delphi code written by F. Piette';
    Move(Msg[1], pReqData^, MinInteger(FSize, Length(Msg))); 

    pIPE^.Data := pData; 
    FillChar(pIPE^, SizeOf(pIPE^), 0); 

    if Assigned(FOnEchoRequest) then 
      FOnEchoRequest(Self);

    FillChar(IPOpt, SizeOf(IPOpt), 0); 
    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.