Simple ping for windows.

gistfile1.txt

program SimplePing;

{$MODE OBJFPC}{$H+}

uses
  Windows, WinSock;

type
  // Структура для опций ICMP запроса
  IP_OPTION_INFORMATION = record
    TTL: Byte;
    TOS: Byte;
    Flags: Byte;
    OptionsSize: Byte;
    OptionsData: Pointer;
  end;
  PIP_OPTION_INFORMATION = ^IP_OPTION_INFORMATION;

  // Структура для ответа ICMP
  ICMP_ECHO_REPLY = record
    Address: ULONG;
    Status: ULONG;
    RoundTripTime: ULONG;
    DataSize: Word;
    Reserved: Word;
    Data: Pointer;
    Options: IP_OPTION_INFORMATION;
  end;
  PICMP_ECHO_REPLY = ^ICMP_ECHO_REPLY;

// Импорт функций из icmp.dll
function IcmpCreateFile: THandle; stdcall; external 'icmp.dll';
function IcmpCloseHandle(IcmpHandle: THandle): BOOL; stdcall; external 'icmp.dll';
function IcmpSendEcho(
  IcmpHandle: THandle;
  DestinationAddress: ULONG;
  RequestData: Pointer;
  RequestSize: Word;
  RequestOptions: Pointer;
  ReplyBuffer: Pointer;
  ReplySize: DWORD;
  Timeout: DWORD): DWORD; stdcall; external 'icmp.dll';

// Функция отправки ICMP Echo Request
function SendPing(const Host: string; Timeout: DWORD = 4000): Boolean;
const
  SEND_DATA = 'abcdefghijklmnopqrstuvwxyz012345'; // 32 байта данных
var
  IcmpHandle: THandle;
  ReplyBuffer: array[0..255] of Byte;
  ReplySize: DWORD;
  IPAddr: ULONG;
  HostEnt: PHostEnt;
  WSAData: TWSAData;
  Reply: PICMP_ECHO_REPLY;
  Options: IP_OPTION_INFORMATION;
  RetVal: DWORD;
  AddrStr: string;
  i: Integer;
begin
  Result := False;

  // Инициализация WinSock для разрешения имен
  if WSAStartup(MakeWord(2, 2), WSAData) <> 0 then
  begin
    Writeln('Failed to initialize WinSock');
    Exit;
  end;

  try
    // Преобразование имени хоста в IP-адрес
    IPAddr := inet_addr(PChar(Host));
    if IPAddr = INADDR_NONE then
    begin
      HostEnt := gethostbyname(PChar(Host));
      if HostEnt = nil then
      begin
        Writeln('Unknown host: ', Host);
        Exit;
      end;
      IPAddr := PULONG(HostEnt^.h_addr_list^)^;
    end;

    // Создание ICMP дескриптора
    IcmpHandle := IcmpCreateFile;
    if IcmpHandle = INVALID_HANDLE_VALUE then
    begin
      Writeln('Unable to create ICMP handle');
      Exit;
    end;

    try
      // Настройка опций IP
      FillChar(Options, SizeOf(Options), 0);
      Options.TTL := 128;
      Options.TOS := 0;
      Options.Flags := 0;
      Options.OptionsSize := 0;
      Options.OptionsData := nil;

      // Размер буфера ответа
      ReplySize := SizeOf(ICMP_ECHO_REPLY) + Length(SEND_DATA) + 8;

      // Вывод заголовка
      AddrStr := inet_ntoa(TInAddr(IPAddr));
      Writeln('Pinging ', Host, ' [', AddrStr, '] with ', Length(SEND_DATA), ' bytes of data:');
      Writeln;

      // Отправка 4 пакетов
      
      for i := 1 to 4 do
      begin
        FillChar(ReplyBuffer, SizeOf(ReplyBuffer), 0);

        // Отправка ICMP Echo Request
        RetVal := IcmpSendEcho(
          IcmpHandle,
          IPAddr,
          @SEND_DATA[1],
          Length(SEND_DATA),
          @Options,
          @ReplyBuffer[0],
          ReplySize,
          Timeout
        );

        if RetVal > 0 then
        begin
          Reply := PICMP_ECHO_REPLY(@ReplyBuffer[0]);

          if Reply^.Status = 0 then
          begin
            Writeln('Reply from ', inet_ntoa(TInAddr(Reply^.Address)),
                    ': bytes=', Reply^.DataSize,
                    ' time=', Reply^.RoundTripTime, 'ms',
                    ' TTL=', Reply^.Options.TTL);
            Result := True;
          end
          else
            Writeln('Request failed with status: ', Reply^.Status);
        end
        else
          Writeln('Request timed out.');

        if i < 4 then
          Sleep(1000);
      end;

    finally
      IcmpCloseHandle(IcmpHandle);
    end;

  finally
    WSACleanup;
  end;
end;


var
  TargetHost: string;
begin
  Writeln('Simple Ping Utility');
  Writeln('===================');
  Writeln;

  if ParamCount > 0 then
    TargetHost := ParamStr(1)
  else
  begin
    Write('Enter host to ping (e.g., google.com or 8.8.8.8): ');
    Readln(TargetHost);
  end;

  if TargetHost <> '' then
  begin
    SendPing(TargetHost);
    Writeln;
  end
  else
    Writeln('No host specified.');

  Writeln('Press Enter to exit...');
  Readln;
end.