Perl tracert

#!/usr/bin/perl
use strict; $|=1; # $Id: traceiface.pl,v 1.1 2007/02/04 22:58:04 jtk Exp $ # traceiface - traceroute with extension to discover router egress hop address # TODO: IPv6 support

use Net::Traceroute::PurePerl; use NetAddr::IP; use Getopt::Std; use Socket; use constant PROGRAM_NAME => 'traceiface'; # gather parameters and validate them
my %opts = (); getopts('d:f:i:m:M:np:P:q:s:w:',%opts); # expect at least a host argument,optional packet_size argument
usage() if ($#ARGV+1 < 1 || $#ARGV+1 > 3);
my $host = $ARGV[0]; # if it looks like a domain name,resolve it
my $domain_name; if ($host !~ /^d{1,3}(?:.d{1,3}){3}4/) { $domain_name = $host; my $packed_address = gethostbyname($domain_name) ||
        die PROGRAM_NAME,": unknown host $hostn"; # WARNING: using the first address we get
    $host = inet_ntoa($packed_address); } my $packet_size; $packet_size = $ARGV[1] if $#ARGV+1 == 2;
if ($packet_size) { usage() if ($packet_size < 0 || $packet_size > 65535); } my $debuglvl = $opts{d} || 0; usage() if ($debuglvl < 0 || $debuglvl > 9); my $first_ttl = $opts{f} || 1; usage() if ($first_ttl < 0 || $first_ttl > 255); my $interface = $opts{i} || undef; my $max_ttl = $opts{m} || 32; if ($max_ttl) { usage() if $max_ttl <= $first_ttl; } # TODO: support IPv6 masks?
my $mask = $opts{M} || 24; usage() if ($mask < 0 || $mask > 32); my $name_resolution = 1 if $opts{n} || undef; # PurePerl limits port selection to 1 to 65280 inclusive (no wrap)
my $base_port = $opts{p} || 33434; usage() if ($base_port < 1 || $base_port > 65280); # limited to what PurePerl module supports # WARNING: PurePerl.pm has insecure dependency with UDP,this won't work # TODO: fix PurePerl so UDP will work
use constant VALID_PROTOCOLS => 'icmp|udp'; my $protocol = lc($opts{P}) || 'icmp'; usage() if VALID_PROTOCOLS !~ /$protocol/; my $nqueries = $opts{q} || 1; usage() if ($nqueries < 1 || $nqueries > 65535); #TODO: src_addr integrity check necessary?
my $src_addr = $opts{s} || undef; my $wait_time = $opts{w} || 5; usage() if ($wait_time < 1 || $wait_time > 65535); # initialize traceroute object (host,first_hop and max_ttl set later)
my $t = new Net::Traceroute::PurePerl( debug => $debuglvl, device => $interface, base_port => $base_port, protocol => $protocol, queries => $nqueries, source_address => $src_addr, query_timeout => $wait_time, concurrent_hops => 1, packetlen => $packet_size, ); # TODO: print summary line of trace to be performed # main routine. process each forward and backward hop
my $complete = 0; for(my $hop = $first_ttl; $hop < $max_ttl; $hop++) { my $result; # the forward facing (probe ingress) interface
    $result = forward_trace($hop); print_hop($hop,'forward'); $complete = 1 if $result; # no backward facing interface on the first hop
    next if $hop == 1; # the backward facing (probe egress) interface
    $result = backward_trace($hop); if ($result) { print_hop($hop-1,'backward'); } else { printf "%s < no backward hop foundn",$hop; } last if $complete; } # # we have to post-process each hop so we set first_ttl and max_ttl to # the current hop we receive from main. this routine tries to get the # forward ingress interface result for the hop we get from main. we # use the results later (available in the global var $t) in the # backward_trace routine. we also access the print_hop routine from # here to display our results before returning our result to main. #
sub forward_trace { my $hop = shift; # update per hop specific options
    $t->first_hop($hop);  # current hop
    $t->max_ttl($hop);    # current hop
    $t->host($host);      # user specified destination

    my $result = $t->traceroute(); return $result; } # # here is the novel addition to traceroute. we attempt to find a response # from a route hop one less than the last forward ingress response received. # we do this by brute force,but somewhat intelligently guessing the backward # facing neighbor address of the forward hop. We reduce the TTL to one so # that we know we got the backward facing router if we get an actual complete # response as opposed to a TTL. technically this could be another interface # on the backward facing router,but we assume the first one we find in # spreading range is the backward hop. #
sub backward_trace { my $hop = shift; # TODO: how to examine all hosts that respond # will hop_query_host($hop) return them all? # # return addr of the first host that responded
    my $forward_host = $t->hop_query_host($hop,0) || return 0; # $mask is a global var
    my $backward_host = new NetAddr::IP "$forward_host/$mask"; # TODO: verify this works and for /31's and /32's too # we loop out from addr as far as mask allows # we compute spreading range based on addresses in netblock # we add one because NetAddr::IP doesn't cont network/broacast addr # and we need to fan spread at least one for /31's and /32's
    my $range = round($backward_host->num() / 2) + 1; # try to find the neighbor address of the forward hop
    for (my $counter = 1; $counter < $range; $counter++) { my $host_to_test; # update traceroute object params
        $t->first_hop($hop-1); $t->max_ttl($hop-1); # first we decrement the address
        $host_to_test = $backward_host - $counter; $t->host($host_to_test->addr()); my $result = $t->traceroute(); return $result if $result; # now try incrementing the address 
        $host_to_test = $backward_host + $counter; $t->host($host_to_test->addr()); $result = $t->traceroute(); return $result if $result; } # no neighbor found
    return 0; } # print a line of output #
sub print_hop { my $hop = shift; my $direction = shift; if ($direction eq 'forward') { printf '%d > ',$hop; } else { # add one to align forward and backward output
        printf '%d < ',$hop+1; } if (not $t->hop_queries($hop)) { print "error: no responsesn"; return; } # loop through each of $nqueries
    for (my $query = 1; $query <= $t->hop_queries($hop); $query++) { my $host = $t->hop_query_host($hop,$query) || undef; # if we didn't get any response,move to the next query
        if (not defined($host)) { print '* '; next; } # resolve names if applicable
        my $name; if ($name_resolution) { #TODO: create local cache?
            $name = gethostbyaddr(inet_aton($host),AF_INET) || undef; } if (defined $name) { printf '%-s (%s) ',$name,$host; } else { printf '%-s ',$host; } my $time = $t->hop_query_time($hop,$query); if (defined $time && $time > 0) { printf '%7s ms ',$time; } else { print '* '; } } print "n"; } # # from old Perl FAQ 4.13
sub round { my $number = shift; return int($number + .5 * ($number <=> 0)); } # # invalid invocation or help requested #
sub usage { my $usage =
"Usage: traceiface [-n] [-d debuglvl] [-f first_ttl] [-i iface] [-m max_ttl] [-P proto] [-p base_port] [-q nqueries] [-s src_addr] [-w waittime] host [packetsize]n"; die $usage; }