view release on metacpan or  search on metacpan

Traceroute6.pm  view on Meta::CPAN

$VERSION = "0.03";		# Version number is only incremented by
				# hand.

@ISA = qw(Exporter);

@EXPORT = qw(TRACEROUTE_OK
	     TRACEROUTE_TIMEOUT
	     TRACEROUTE_UNKNOWN
	     TRACEROUTE_BSDBUG
	     TRACEROUTE_UNREACH_NET
	     TRACEROUTE_UNREACH_HOST
	     TRACEROUTE_UNREACH_PROTO
	     TRACEROUTE_UNREACH_NEEDFRAG
	     TRACEROUTE_UNREACH_SRCFAIL
	     TRACEROUTE_UNREACH_ADDR
	     TRACEROUTE_UNREACH_FILTER_PROHIB);

###

## Exported functions.

# Perl's facist mode gets very grumbly if a few things aren't declared
# first.

sub TRACEROUTE_OK { 0 }
sub TRACEROUTE_TIMEOUT { 1 }
sub TRACEROUTE_UNKNOWN { 2 }
sub TRACEROUTE_BSDBUG { 3 }
sub TRACEROUTE_UNREACH_NET { 4 }
sub TRACEROUTE_UNREACH_HOST { 5 }
sub TRACEROUTE_UNREACH_PROTO { 6 }
sub TRACEROUTE_UNREACH_NEEDFRAG { 7 }
sub TRACEROUTE_UNREACH_SRCFAIL { 8 }
sub TRACEROUTE_UNREACH_FILTER_PROHIB { 9 }
sub TRACEROUTE_UNREACH_ADDR { 10 }

## Internal data used throughout the module

# Instance variables that are nothing special, and have an obvious
# corresponding accessor/mutator method.
my @simple_instance_vars = qw(base_port
			      debug
			      host
			      max_ttl
			      queries
			      query_timeout
			      timeout
                              af 
                              host_address);

# Field offsets for query info array
my $query_stat_offset = 0;
my $query_host_offset = 1;
my $query_time_offset = 2;

#real address family if you specify PF_UNSPEC
my $real_af = -1;

# check whether we have IPv6 support;
my $inet6 = defined(eval 'PF_INET6');

###
# Public methods

# Constructor

sub new {
    my $self = shift;
    my $type = ref($self) || $self;

    my %hash = ();

    my %arg = @_;

    my $me = bless \%hash, $type;

    # If we've been called through an object, use that one as a template.
    # Does a shallow copy of the hash key/values to the new hash.
    if(ref($self)) {
	my($key, $val);
	while(($key, $val) = each %{$self}) {
	    $me->{$key} = $val;
	}
    }

    # Take our constructer arguments and initialize the attributes with
    # them.
    my $var;
    foreach $var (@simple_instance_vars)  {
	if(defined($arg{$var})) {
	    $me->$var($arg{$var});
	}
    }

    # Initialize debug if it isn't already.
    $me->debug(0) if(!defined($me->debug));

    $me->debug_print(1, "Running in debug mode\n");

    # Initialize status
    $me->stat(TRACEROUTE_UNKNOWN);

    # Initialize address family
    $me->af(PF_UNSPEC) if (!defined($me->af));


    if(defined($me->host)) {
	$me->traceroute;
    }

    $me->debug_print(9, Dumper($me));

    $me;
}

##
# Methods

# Do the actual work.  Not really a published interface; completely
# useable from the constructor.

Traceroute6.pm  view on Meta::CPAN

}

sub queries {
    my $self = shift;
    my $elem = "queries";

    my $old = $self->{$elem};
    $self->{$elem} = $_[0] if @_;
    return $old;
}

sub query_timeout {
    my $self = shift;
    my $elem = "query_timeout";

    my $old = $self->{$elem};
    $self->{$elem} = $_[0] if @_;
    return $old;
}

sub host {
    my $self = shift;
    my $elem = "host";

    my $old = $self->{$elem};
    $self->{$elem} = $_[0] if @_;
    return $old;
}

sub host_address {
    my $self = shift;
    my $elem = "host_address";

    my $old = $self->{$elem};

    # Internal representation always uses IP address in string form.
    if(@_) {
	$self->{$elem} = $_[0];
    }
    return $old;
}

sub timeout {
    my $self = shift;
    my $elem = "timeout";

    my $old = $self->{$elem};
    $self->{$elem} = $_[0] if @_;
    return $old;
}

sub af {
    my $self = shift;
    my $elem = "af";

    my $old = $self->{$elem};
    if (@_) {
	
    	$self->{$elem} = PF_UNSPEC  if ($_[0]== PF_UNSPEC) ;
    	$self->{$elem} = PF_INET  if ($_[0]== PF_INET) ;
    	$self->{$elem} = PF_INET6 if ($inet6 && ($_[0] == PF_INET6));
    }
    return $old;
}

# Accessor for status of this traceroute object.  Externally read only
# (not enforced).
sub stat {
    my $self = shift;
    my $elem = "stat";

    my $old = $self->{$elem};
    $self->{$elem} = $_[0] if @_;
    return $old;
}

##
# Hop and query functions

sub hops {
    my $self = shift;

    my $hop_ary = $self->{"hops"};

    return() unless $hop_ary;

    return(int(@{$hop_ary}));
}

sub hop_queries {
    my $self = shift;
    my $hop = (shift) - 1;

    $self->{"hops"} && $self->{"hops"}->[$hop] &&
	int(@{$self->{"hops"}->[$hop]});
}

sub found {
    my $self = shift;
    my $hops = $self->hops();

    if($hops) {
	my $host_address = $self->host_address;

	my $last_hop = $self->hop_query_host($hops, 0);
	my $stat = $self->hop_query_stat($hops,  0);

	if( $last_hop eq $host_address &&
	   (($stat == TRACEROUTE_OK) || ($stat == TRACEROUTE_BSDBUG) ||
	    ($stat == TRACEROUTE_UNREACH_PROTO))) {
	    return(1);
	}
    }
    return(undef);
}

sub hop_query_stat {
    _query_accessor_common(@_,$query_stat_offset);
}

sub hop_query_host {
    _query_accessor_common(@_,$query_host_offset);
}

sub hop_query_time {
    _query_accessor_common(@_,$query_time_offset);
}

###
# Various internal methods

# Many of these would be useful to override in a derived class.

# Build and return the pipe that talks to our child traceroute.
sub _make_pipe {
    my $self = shift;

    my @tr_args = $self->_tr_program_name();

    push(@tr_args, $self->_tr_cmd_args());
    push(@tr_args, $self->host_address());

    # XXX we probably shouldn't throw stderr away.
    open(SAVESTDERR, ">&STDERR");
    #open(STDERR, ">/tmp/log");
    open(STDERR, ">/dev/null");

    my $pipe = new IO::Pipe;

    # IO::Pipe is very unhelpful about error catching.  It calls die
    # in the child program, but returns a reasonable looking object in
    # the parent.  This is really a standard unix fork/exec issue, but
    # the library really doesn't help us.
    my $result = $pipe->reader(@tr_args);

    open(STDERR, ">& SAVESTDERR");
    close(SAVESTDERR);

    # XXX We're going to assume that an eof right after fork/exec is
    # actually a failure.  This is quite dubious.
    if($result->eof) {
  	die "No output from traceroute.  Exec failure?";
    }

    $result;
}

# Return the name of the traceroute executable itself
sub _tr_program_name {
    my $self = shift;
    my @args; # collector of arguments
    my $os=$Config{'osname'};
    my $prg_sw;

OSNAMESW: {
    # here comes Solaris
    if ($os = ~ /solaris/) {
	push (@args, "traceroute");
	push (@args, "-A");
    	$prg_sw = ($self->af == PF_INET6) ? "inet6" : "inet";
	push (@args, $prg_sw);
	last OSNAMESW;
    }
    # here comes AIX
    #
    # here comes Tru64 UNIX
    #
    # here comes W2K
    #
    # for the rest we assume traceroute6/traceroute
    
   	$prg_sw = ($self->af == PF_INET6) ? "traceroute6" : "traceroute";
	push (@args, $prg_sw);
	last OSNAMESW;
    }

    @args;
}

# How to map some of the instance variables to command line arguments
my %cmdline_map = ("base_port" => "-p",
		   "max_ttl" => "-m",
		   "queries" => "-q",
		   "query_timeout" => "-w");

# Build a list of command line arguments
sub _tr_cmd_args {
    my $self = shift;

    my @result;

    push(@result, "-n");

    my($key, $flag);
    while(($key, $flag) = each %cmdline_map) {
	my $val = $self->$key();
	if(defined $val) {
	    push(@result, $flag, $val);
	}
    }

    @result;
}

# Map !<Mumble> notation traceroute uses for various icmp packet types
# it may receive.
my %icmp_map = (N => TRACEROUTE_UNREACH_NET,
		H => TRACEROUTE_UNREACH_HOST,
		P => TRACEROUTE_UNREACH_PROTO,
		F => TRACEROUTE_UNREACH_NEEDFRAG,
		S => TRACEROUTE_UNREACH_SRCFAIL,
		A => TRACEROUTE_UNREACH_ADDR,
		X => TRACEROUTE_UNREACH_FILTER_PROHIB);

# Do the grunt work of parsing the output.
sub _parse {
    my $self = shift;
    my $tr_output = shift;

  ttl: