Трассировка пути до определенного IP адреса (Traceroute)

Материал из DRKB


Трассировка пути до определенного IP адреса (как tracert.exe в Windows)

Пример использования модуля:

procedure TForm1.Button1Click(Sender: TObject);
var
  RT: TTraceRoute;
begin
  RT := TTraceRoute.Create;
  RT.Trace('192.168.5.12', ListBox1.Items);
  RT.Free;
end;


В ListBox1 выведется путь в таком формате:

IP;TIME;TTL;STATUS

Сам модуль:

unit TraceRt;

interface

// ===========================================================================
// TRACEROUTE Class
// Mike Heydon Dec 2003
//
// Method
// Trace(IpAddress : string; ResultList : TStrings)
//             Returns semi-colon delimited list of ip routes to target
//             format .. IP ADDRESS; PING TIME MS; TIME TO LIVE; STATUS
//
// Properties
//             IcmpTimeOut : integer (Default = 5000ms)
//             IcmpMaxHops : integer (Default = 40)
// ===========================================================================

uses Forms, Windows, Classes, SysUtils, IdIcmpClient;

type
  TTraceRoute = class(TObject)
  protected
    procedure ProcessResponse(Status: TReplyStatus);
    procedure AddRoute(AResponseTime: DWORD;
                       AStatus: TReplyStatus; const AInfo: string);
  private
    FIcmpTimeOut,
    FIcmpMaxHops: Integer;
    FResults: TStringList;
    FICMP: TIdIcmpClient;
    FPingStart: Cardinal;
    FCurrentTTL: Integer;
    procedure PingTarget;
  public
    constructor Create;
    procedure Trace(const AIpAddress: string; AResultList: TStrings);
    property IcmpTimeOut: Integer read FIcmpTimeOut write FIcmpTimeOut;
    property IcmpMaxHops: Integer read FIcmpMaxHops write FIcmpMaxHops;
  end;

// ---------------------------------------------------------------------------
implementation

// ========================================
// Create the class and set defaults
// ========================================

constructor TTraceRoute.Create;
begin
  IcmpTimeOut := 5000;
  IcmpMaxHops := 40;
end;


// =============================================
// Use Indy component to ping hops to target
// =============================================
procedure TTraceRoute.PingTarget;
var
  wOldMode: DWORD;
begin
  Application.ProcessMessages;
  Inc(FCurrentTTL);

  if FCurrentTTL < FIcmpMaxHops then
  begin
    FICMP.TTL := FCurrentTTL;
    FICMP.ReceiveTimeout := FIcmpTimeOut;
    FPingStart := GetTickCount;
    wOldMode := SetErrorMode(SEM_FAILCRITICALERRORS);

    try
      FICMP.Ping;
      ProcessResponse(FICMP.ReplyStatus);
    except
      FResults.Add('0.0.0.0;0;0;ERROR');
    end;

    SetErrorMode(wOldMode);
  end
  else
    FResults.Add('0.0.0.0;0;0;MAX HOPS EXCEEDED');
end;


// ============================================================
// Add the ping reply status data to the returned stringlist
// ============================================================
procedure TTraceRoute.AddRoute(AResponseTime: DWORD;
  AStatus: TReplyStatus; const AInfo: string);
begin
  FResults.Add(AStatus.FromIPAddress + ';'
    + IntToStr(GetTickCount - AResponseTime) + ';'
    + IntToStr(AStatus.TimeToLive) + ';' + AInfo);
end;


// ============================================================
// Process the ping reply status record and add to stringlist
// ============================================================
procedure TTraceRoute.ProcessResponse(Status: TReplyStatus);
begin
  case Status.ReplyStatusType of
    // Last Leg - Terminate Trace
    rsECHO: AddRoute(FPingStart,Status,'OK');

    // More Hops to go - Continue Pinging
    rsErrorTTLExceeded:
    begin
      AddRoute(FPingStart, Status, 'OK');
      PingTarget;
    end;

    // Error conditions - Terminate Trace
    rsTimeOut: AddRoute(FPingStart, Status, 'TIMEOUT');
    rsErrorUnreachable: AddRoute(FPingStart, Status, 'UNREACHABLE');
    rsError: AddRoute(FPingStart, Status, 'ERROR');
  end;
end;

// ======================================================
// Trace route to target IP address
// Results returned in semi-colon delimited stringlist
// IP; TIME MS; TIME TO LIVE; STATUS
// ======================================================
procedure TTraceRoute.Trace(const AIpAddress: string; AResultList: TStrings);
begin
  FICMP := TIdIcmpClient.Create(nil);
  FICMP.Host := AIpAddress;
  FResults := TStringList(AResultList);
  FResults.Clear;
  FCurrentTTL := 0;
  PingTarget;
  FICMP.Free;
end;

end.


Author: p0s0l
Source: http://forum.vingrad.ru
ID: 03354