Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

Traсert, принцип трассировки маршрута прохождения сетевого запроса

01.01.2007
////////////////////////////////////////////////////////////////////////////////
//
//  Демонстрационная программа Tracert.exe
//  Цель: показать принцип трассировки
//
//  Автор: Александр (Rouse_) Багель
//  mailto: rouse79@yandex.ru
//
//  Отдельное спасибо Игорю Шевченко за тестирование кода
//  и указание на ошибки, которые могут возникнуть при компиляции
//  в различных версиях 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.

 
 

Проект также доступен по адресу: http://rouse.front.ru/tracert.zip

Взято из https://forum.sources.ru

Автор: Rouse_