[Сеть, интернет] Трассировка маршрута (Tracert)

    ////////////////////////////////////////////////////////////////////////////////
    //
    //  Демонстрационная программа Tracert.exe
    //  Цель: показать принцип трассировки
    //
    //  Автор: Александр (Rouse_) Багель
    //  mailto: [email protected]
    //
    //  Отдельное спасибо Игорю Шевченко за тестирование кода
    //  и указание на ошибки, которые могут возникнуть при компиляции
    //  в различных версиях Delphi, а также за советы по оптимизации кода
    //
    //  8 апреля 2004 года
    //
    ////////////////////////////////////////////////////////////////////////////////
    //
    //  Как это работает?
    //
    //  Для начала нужно вспомнить формат заголовка IP-пакета,
    //  точнее одно из его полей - TTL (Time To Live).
    //  Это восьмибитное поле задает максимальное число хопов
    //  (hop - "прыжок" - прохождение дейтаграммы от одного маршрутизатора к другому)
    //  в течение которого пакет может находиться в сети.
    //  Каждый маршрутизатор,  обрабатывающий эту дейтаграмму,
    //  выполняет операцию TTL=TTL-1.
    //  Когда TTL становится равным нулю,
    //  маршрутизатор уничтожает пакет,
    //  отправителю высылается ICMP-сообщение Time Exceeded.
    //
    //  Утилита посылает в направлении заданного хоста пакет с TTL=1,
    //  и ждет, от кого вернется ответ time exceeded.
    //  Отвечающий записывается как первый хоп
    //  (результат первого шага на пути к цели).
    //  Затем посылаются последовательно пакеты с TTL=2, 3, 4 и т.д. по порядку,
    //  пока при некотором значении TTL пакет не достигнет цели
    //  и не получит от нее ответ.
    //
    //  © http://www.nvkz.net/taifun/xak/tracert.htm
    //
    ////////////////////////////////////////////////////////////////////////////////
     
    unit uMain;
     
    interface
     
    uses
      Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
      Dialogs, StdCtrls, WinSock, Spin;
     
    {$DEFINE NO_MESSAGE}
     
    const
      ICMP = 'ICMP.DLL';
      RES_UNKNOWN   = 'Unknown';
      WSA_TYPE = $101;
      STR_TRACE = 'Трассировка маршрута к ';
      STR_JUMP = 'с максимальным числом прыжков ';
      STR_DONE = 'Трассировка завершена.' + #13#10;
      HOST_NOT_REPLY = 'Превышен интервал ожидания для запроса.';
      
    type
      IP_INFO = packed record
        Ttl: Byte;
        Tos: Byte;
        IPFlags: Byte;
        OptSize: Byte;
        Options: Pointer;
      end;
      PIP_INFO = ^IP_INFO;
     
      ICMP_ECHO = packed record
        Source: Longint;
        Status: Longint;
        RTTime: Longint;
        DataSize: Word;
        Reserved: Word;
        pData: Pointer;
        i_ipinfo: IP_INFO;
      end;
     
      TfrmMain = class(TForm)
        gbTracert: TGroupBox;
        memShowTracert: TMemo;
        edAddr: TEdit;
        btnStart: TButton;
        sedCount: TSpinEdit;
        lblHost: TLabel;
        lblHop: TLabel;
        procedure btnStartClick(Sender: TObject);
      end;
     
      TTraceThread = class(TThread)
      private
        DestAddr: in_addr;
        TraceHandle: THandle;
        DestinationAddress,
        ReportString: String;
        IterationCount: Byte;
      public
        procedure Execute; override;
        procedure Log;
        function Trace(const Iteration: Byte): Longint;
      end;
     
    var
      frmMain: TfrmMain;
     
    implementation
     
    {$R *.dfm}
     
    function IcmpCreateFile: THandle; stdcall; external ICMP name 'IcmpCreateFile';
    function IcmpCloseHandle(IcmpHandle: THandle): BOOL; stdcall;
      external ICMP name 'IcmpCloseHandle';
    function IcmpSendEcho(IcmpHandle : THandle; DestAddress: Longint;
      RequestData: Pointer; RequestSize: Word; RequestOptns: PIP_INFO;
      ReplyBuffer: Pointer; ReplySize, Timeout: DWORD): DWORD; stdcall;
      external ICMP name 'IcmpSendEcho';
     
    { Other functions }
     
    // Функция возвращает имя хоста по его IP адресу
    function GetNameFromIP(const IP: String): String;
    const
      ERR_INADDR    = 'Can not convert IP to in_addr.';
      ERR_HOST      = 'Can not get host information.';
      ERR_WSA       = 'Can not initialize WSA.';
    var
      WSA   : TWSAData;
      Host  : PHostEnt;
      Addr  : u_long;
      Err   : Integer;
    begin
      Result := RES_UNKNOWN;
      Err := WSAStartup(WSA_TYPE, WSA);
      if Err <> 0 then
      begin
        {$IFNDEF NO_MESSAGE}
          MessageDlg(ERR_WSA, mtError, [mbOK], 0);
        {$ENDIF}
        Exit;
      end;
      try
        Addr := inet_addr(PChar(IP));
        if Addr = u_long(INADDR_NONE) then
        begin
          {$IFNDEF NO_MESSAGE}
            MessageDlg(ERR_INADDR, mtError, [mbOK], 0);
          {$ENDIF}
          Exit;
        end;
        Host := gethostbyaddr(@Addr, SizeOf(Addr), PF_INET);
        if Assigned(Host) then
          Result := Host.h_name
        {$IFNDEF NO_MESSAGE}
          else
            MessageDlg(ERR_HOST, mtError, [mbOK], 0)
        {$ENDIF}
        ;
      finally
        WSACleanup;
      end;
    end;
     
    // Функция преобразует IP адрес в его строковый эквивалент
    function GetDottetIP(const IP: Longint): String;
    begin
      Result := Format('%d.%d.%d.%d', [IP and $FF,
        (IP shr 8) and $FF, (IP shr 16) and $FF, (IP shr 24) and $FF]);
    end;
     
    { TfrmMain }
     
    procedure TfrmMain.btnStartClick(Sender: TObject);
    begin
      // Чтобы программа не подвисала
      // запускаем трассировку в отдельном потоке
      with TTraceThread.Create(False) do begin
        FreeOnTerminate := True;
        // Передаем имя хоста
        DestinationAddress := edAddr.Text;
        // и максимальное число прыжков
        IterationCount := sedCount.Value;
        Resume;
      end;
    end;
     
    { TTraceThread }
     
    procedure TTraceThread.Execute;
    var
      WSAData: TWSAData;   // Служебные
      Host: PHostEnt;      // переменные
      Error,               // для просмотра кодов ошибок
      TickStart: DWORD;    // для подсчета времени ответа на пинг
      Result: Longint;     // содержит результат выполнения Trace
      I,                   // для цикла
      Iteration: Byte;     // используется для увеличения TTL
      HostName: String;    // содержит имя хоста
      HostReply: Boolean;  // флаг False если хост не ответил 3 раза на пинг
      HostIP: LongInt;     // при ответе хоста сюда заносится его IP (во избежания глюка)
    begin
      // Инициализируем Winsock
      Error := WSAStartup(WSA_TYPE, WSAData);
      if Error <> 0 then
      begin
        ReportString := SysErrorMessage(WSAGetLastError);
        Synchronize(Log);
        Exit;
      end;
     
      try
        // Пытаемся получить IP адрес
        // до которого будем проводить трассировку
        Host := gethostbyname(PChar(DestinationAddress));
        if not Assigned(Host) then
        begin
          ReportString := SysErrorMessage(WSAGetLastError);
          Synchronize(Log);
          Exit;
        end;
     
        // Запоминаем полученый адрес
        DestAddr := PInAddr(Host.h_addr_list^)^;
     
        // Подготавливаемся к отправке эхозапросов (пинга)
        TraceHandle := IcmpCreateFile;
        if TraceHandle = INVALID_HANDLE_VALUE then
        begin
          ReportString := SysErrorMessage(GetLastError);
          Synchronize(Log);
          Exit;
        end;
     
        try
          // Выводим информационные строки вида:
          // Трассировка маршрута к www.delphimaster.ru [62.118.251.90]
          // с максимальным числом прыжков 30:
          ReportString := STR_TRACE + DestinationAddress
            + ' [' + GetDottetIP(DestAddr.S_addr)+ ']' + #13#10;
          Synchronize(Log);
          ReportString := STR_JUMP + IntToStr(IterationCount) + ':' + #13#10;
          Synchronize(Log);
     
          // Инициализируем переменные
          Result := 0;
          Iteration := 0;
     
          // Начинаем трассировку до тех пор
          while (Result <> DestAddr.S_addr) and // пока IP адреса не совпадут
                (Iteration < IterationCount) do // или кол-во прыжков достигнет максимального
          begin
            Inc(Iteration); // Увеличиваем время жизни пакета
     
            HostReply := False; // Выставляем флаг, "хост пока не ответил"
     
            // Запускаем серию из 3 эхозапросов
            for I := 0 to 2 do
            begin
              TickStart := GetTickCount;  // Для каждого засекаем время
              Result := Trace(Iteration); // Делаем пинг
     
              if Result = -1 then // Если нет ответа выводим звезду
                ReportString := '    *    '
              else
              begin  // Если есть ответ - выводим данные (результатом будет IP ответившего)
                ReportString := Format('%6d ms', [GetTickCount - TickStart]);
                HostReply := True;  // и не забываем выставить флаг
                HostIP := Result;
              end;
     
              if I = 0 then
                ReportString := Format('%3d: %s', [Iteration, ReportString]);
              Synchronize(Log);
            end;
     
            if HostReply then // Если хост ответил хотябы на 1 пинг
            begin
              // Получаем преобразованный в строковый вид IP
              ReportString := GetDottetIP(HostIP);
              // Получаем имя хоста
              HostName := GetNameFromIP(ReportString);
              // Вывод данных в зависимости от того - получено ли имя хоста
              if HostName <> RES_UNKNOWN then
                ReportString := HostName + '[' + ReportString + ']';
              ReportString := ReportString + #13#10;
            end
            else
              ReportString := HOST_NOT_REPLY + #13#10;
     
            ReportString := '  ' + ReportString;
            Synchronize(Log);
          end;
     
        finally
          IcmpCloseHandle(TraceHandle);
        end;
     
        // Выводим информационную строку "Трассировка завершена."
        ReportString := STR_DONE;
        Synchronize(Log);
      finally
        WSACleanup;
      end;
    end;
     
    // Процедура отвечает за вывод информации в memShowTracert
    procedure TTraceThread.Log;
    begin
      frmMain.memShowTracert.Text :=
        frmMain.memShowTracert.Text + ReportString;
      SendMessage(frmMain.memShowTracert.Handle, WM_VSCROLL, SB_BOTTOM, 0);
    end;
     
    // Однократная посылка эхозапроса
    function TTraceThread.Trace(const Iteration: Byte): Longint;
    var
      IP: IP_INFO;
      ECHO: ^ICMP_ECHO;
      Error: Integer;
    begin
      GetMem(ECHO, SizeOf(ICMP_ECHO));
      try
        with IP do // Заполнение заголовка
        begin
          Ttl := Iteration; // Самый важный момент в трассировке -  постепенное увеличение TTL
          Tos := 0;
          IPFlags := 0;
          OptSize := 0;
          Options := nil;
        end;
     
        // Непосредственно посылка эхозапроса
        Error := IcmpSendEcho(TraceHandle,
                              DestAddr.S_addr,
                              nil,
                              0,
                              @IP,
                              ECHO,
                              SizeOf(ICMP_ECHO),
                              5000);
        // Проверка на ошибки
        if Error = 0 then
        begin
          Result := -1;
          Exit;
        end;
     
        // Если ошибок не обнаружено результатом будет IP адрес ответившего хоста
        Result := ECHO.Source;
     
      finally
        FreeMem(ECHO);
      end;
     
    end;
     
    end.