////////////////////////////////////////////////////////////////////////////////
//
//  Демонстрационная программа Tracert.exe
//  Цель: показать принцип трассировки
//
//  Автор: Александр (Rouse_) Багель
//  mailto: rouse79@yandex.ru
//
//  Отдельное спасибо Игорю Шевченко за тестирование кода
//  и указание на ошибки, которые могут возникнуть при компиляции
//  в различных версиях Delphi, а также за советы по оптимизации кода
//
//  Специально для FAQ сайта "Мастера Дельфи"
//  http://www.delphimasters.ru
//
//  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); // Увеличиваем время жизни пакета (TTL)

        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;   // а также запомним его IP
          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.

