File Coverage

blib/lib/Net/Traceroute/PurePerl.pm

Criterion	Covered	Total	%
statement	313	370	84.5
branch	94	164	57.3
condition	47	105	44.7
subroutine	42	44	95.4
pod	2	3	66.6
total	498	686	72.5

package Net::Traceroute::PurePerl;

use vars qw(@ISA $VERSION $AUTOLOAD %net_traceroute_native_var %protocols);
use strict;
use warnings;
use Net::Traceroute;
use Socket;
use FileHandle;
use Carp qw(carp croak);
use Time::HiRes qw(time);

@ISA = qw(Net::Traceroute);
$VERSION = '0.10';

# Constants from header files or RFCs

use constant SO_BINDTODEVICE        => 25;   # from asm/socket.h
use constant IPPROTO_IP             => 0;    # from netinet/in.h

# Windows winsock2 uses 4 for IP_TTL instead of 2
use constant IP_TTL                 => ($^O eq "MSWin32") ? 4 : 2;

use constant IP_HEADERS             => 20;   # Length of IP headers
use constant ICMP_HEADERS           => 8;    # Length of ICMP headers
use constant UDP_HEADERS            => 8;    # Length of UDP headers

use constant IP_PROTOCOL            => 9;    # Position of protocol number

use constant UDP_DATA               => IP_HEADERS + UDP_HEADERS;
use constant ICMP_DATA              => IP_HEADERS + ICMP_HEADERS;

use constant UDP_SPORT              => IP_HEADERS + 0; # Position of sport
use constant UDP_DPORT              => IP_HEADERS + 2; # Position of dport

use constant ICMP_TYPE              => IP_HEADERS + 0; # Position of type
use constant ICMP_CODE              => IP_HEADERS + 2; # Position of code
use constant ICMP_ID                => IP_HEADERS + 4; # Position of ID
use constant ICMP_SEQ               => IP_HEADERS + 6; # Position of seq

use constant ICMP_PORT              => 0;    # ICMP has no port

use constant ICMP_TYPE_TIMEEXCEED   => 11;   # ICMP Type
use constant ICMP_TYPE_ECHO         => 8;    # ICMP Type
use constant ICMP_TYPE_UNREACHABLE  => 3;    # ICMP Type
use constant ICMP_TYPE_ECHOREPLY    => 0;    # ICMP Type

use constant ICMP_CODE_ECHO         => 0;    # ICMP Echo has no code

# Perl 5.8.6 under Windows has a bug in the socket code, this env variable
# works around the bug. It may effect other versions as well, and they should
# be added here
BEGIN
{
   if ($^O eq "MSWin32" and $^V eq v5.8.6)
   {
      $ENV{PERL_ALLOW_NON_IFS_LSP} = 1;
   }
}

# The list of currently accepted protocols
%protocols =
(
               'icmp'      => 1,
               'udp'       => 1,
);

my @icmp_unreach_code =
(
               TRACEROUTE_UNREACH_NET,
               TRACEROUTE_UNREACH_HOST,
               TRACEROUTE_UNREACH_PROTO,
               0,
               TRACEROUTE_UNREACH_NEEDFRAG,
               TRACEROUTE_UNREACH_SRCFAIL,
);

# set up allowed autoload attributes we need
my @net_traceroute_native_vars = qw(use_alarm concurrent_hops protocol
      first_hop device);

@net_traceroute_native_var{@net_traceroute_native_vars} = ();

# Methods

# AUTOLOAD (perl internal)
# Used to create the methods for the object dynamically from
# net_traceroute_naive_vars.
sub AUTOLOAD
{
   my $self = shift;
   my $attr = $AUTOLOAD;
   $attr =~ s/.*:://;
   return unless $attr =~ /[^A-Z]/;  # skip DESTROY and all-cap methods
   carp "invalid attribute method: ->$attr()"
      unless exists $net_traceroute_native_var{$attr};
   $self->{$attr} = shift if @_;
   return $self->{$attr};
}

# new (public method)
# Creates a new blessed object of type Net::Traceroute::PurePerl.
# Accepts many options as arguments, and initilizes the new object with
# their values.
# Croaks on bad arguments.
sub new
{
   my $self = shift;
   my $type = ref($self) || $self;
   my %arg = @_;

   $self = bless {}, $type;

   # keep a loop from happening when calling super::new
   my $backend = delete $arg{'backend'};

   # used to get around the real traceroute running the trace
   my $host = delete $arg{'host'};

   # Old method to use ICMP for traceroutes, using `protocol' is preferred
   my $useicmp = delete $arg{'useicmp'};

   $self->debug_print(1,
      "The useicmp parameter is depreciated, use `protocol'\n") if ($useicmp);

   # Initialize blessed hash with passed arguments
   $self->_init(%arg);

   # Set protocol to ICMP if useicmp was set;
   if ($useicmp)
   {
      carp ("Protocol already set, useicmp is overriding")
         if (defined $self->protocol  and $self->protocol ne "icmp");
      $self->protocol('icmp') if ($useicmp);
   }

   # put our host back in and set defaults for undefined options
   $self->host($host)         if (defined $host);
   $self->max_ttl(30)         unless (defined $self->max_ttl);
   $self->queries(3)          unless (defined $self->queries);
   $self->base_port(33434)    unless (defined $self->base_port);
   $self->query_timeout(5)    unless (defined $self->query_timeout);
   $self->packetlen(40)       unless (defined $self->packetlen);
   $self->first_hop(1)        unless (defined $self->first_hop);
   $self->concurrent_hops(6)  unless (defined $self->concurrent_hops);

   # UDP is the UNIX default for traceroute
   $self->protocol('udp')     unless (defined $self->protocol);

   # Depreciated: we no longer use libpcap, so the alarm is no longer
   # required. Kept for backwards compatibility but not used.
   $self->use_alarm(0)        unless (defined $self->use_alarm);

   # Validates all of the parameters.
   $self->_validate();

   return $self;
}

# _init (private initialization method)
# Overrides Net::Traceroutes init to set PurePerl specific parameters.
sub _init
{
   my $self = shift;
   my %arg  = @_;

   foreach my $var (@net_traceroute_native_vars)
   {
      if(defined($arg{$var})) {
         $self->$var($arg{$var});
      }
   }

   $self->SUPER::init(@_);
}

# pretty_print (public method)
# The output of pretty_print tries to match the output of traceroute(1) as
# close as possible, with two excpetions. First, I cleaned up the columns to
# make it easier to read, and second, I start a new line if the host IP changes
# instead of printing the new IP inline. The first column stays the same hop
# number, only the host changes.
sub pretty_print
{
   my $self    = shift;
   my $resolve = shift;

   print "traceroute to " . $self->host;
   print " (" . inet_ntoa($self->{'_destination'}) . "), ";
   print  $self->max_ttl . " hops max, " . $self->packetlen ." byte packets\n";

   my $lasthop = $self->first_hop + $self->hops - 1;

   for (my $hop=$self->first_hop; $hop <= $lasthop; $hop++)
   {
      my $lasthost = '';

      printf '%2s ', $hop;

      if (not $self->hop_queries($hop))
      {
         print "error: no responses\n";
         next;
      }

      for (my $query=1; $query <= $self->hop_queries($hop); $query++) {
         my $host = $self->hop_query_host($hop,$query);
         if ($host and $resolve)
         {
            my $ip = $host;
            $host = (gethostbyaddr(inet_aton($ip),AF_INET))[0] || $ip;
         }
         if ($host and ( not $lasthost or $host ne $lasthost ))
         {
            printf "\n%2s ", $hop if ($lasthost and $host ne $lasthost);
            printf '%-15s ', $host;
            $lasthost = $host;
         }
         my $time = $self->hop_query_time($hop, $query);
         if (defined $time and $time > 0)
         {
            printf '%7s ms ', $time;
         }
         else
         {
            print "* ";
         }
      }

      print "\n";
   }

   return;
}

# traceroute (public method)
# Starts a new traceroute. This is a blocking call and it will either croak on
# error, or return 0 if the host wasn't reached, or 1 if it was.
sub traceroute
{
   my $self = shift;

   # Revalidate parameters incase they were changed by calling $t->parameter()
   # since the object was created.
   $self->_validate();

   carp "No host provided!" && return undef unless (defined $self->host);

   $self->debug_print(1, "Performing traceroute\n");

   # Lookup the destination IP inside of a local scope
   {
      my $destination = inet_aton($self->host);

      croak "Could not resolve host " . $self->host
         unless (defined $destination);

      $self->{_destination} = $destination;
   }

   # release any old hop structure
   $self->_zero_hops();

   # Create the ICMP socket, used to send ICMP messages and receive ICMP errors
   # Under windows, the ICMP socket doesn't get the ICMP errors unless the
   # sending socket was ICMP, or the interface is in promiscuous mode, which
   # is why ICMP is the only supported protocol under windows.
   my $icmpsocket = FileHandle->new();

   socket($icmpsocket, PF_INET, SOCK_RAW, getprotobyname('icmp')) ||
      croak("ICMP Socket error - $!");

   $self->debug_print(2, "Created ICMP socket to receive errors\n");

   $self->{'_icmp_socket'}    = $icmpsocket;
   $self->{'_trace_socket'}   = $self->_create_tracert_socket();

   # _run_traceroute is the event loop that actually does the work.
   my $success = $self->_run_traceroute();

   return $success;
}

# Private methods

# _validate (private method)
# Normalizes and validates all parameters, croaks on error
sub _validate
{
   my $self = shift;

   # Normalize values;

   $self->protocol(           lc $self->protocol);

   $self->max_ttl(            sprintf('%i',$self->max_ttl));
   $self->queries(            sprintf('%i',$self->queries));
   $self->base_port(          sprintf('%i',$self->base_port));
   $self->query_timeout(      sprintf('%i',$self->query_timeout));
   $self->packetlen(          sprintf('%i',$self->packetlen));
   $self->first_hop(          sprintf('%i',$self->first_hop));
   $self->concurrent_hops(    sprintf('%i',$self->concurrent_hops));

   # Check to see if values are sane

   croak "Parameter `protocol' value is not supported : " . $self->protocol
      if (not exists $protocols{$self->protocol});

   croak "Parameter `first_hop' must be an integer between 1 and 255"
      if ($self->first_hop < 1 or $self->first_hop > 255);

   croak "Parameter `max_ttl' must be an integer between 1 and 255"
      if ($self->max_ttl < 1 or $self->max_ttl > 255);

   croak "Parameter `base_port' must be an integer between 1 and 65280"
      if ($self->base_port < 1 or $self->base_port > 65280);

   croak "Parameter `packetlen' must be an integer between 40 and 1492"
      if ($self->packetlen < 40 or $self->packetlen > 1492);

   croak "Parameter `first_hop' must be less than or equal to `max_ttl'"
      if ($self->first_hop > $self->max_ttl);

   croak "parameter `queries' must be an interger between 1 and 255"
      if ($self->queries < 1 or $self->queries > 255);

   croak "parameter `concurrent_hops' must be an interger between 1 and 255"
      if ($self->concurrent_hops < 1 or $self->concurrent_hops > 255);

   croak "protocol " . $self->protocol . " not supported under Windows"
      if ($self->protocol ne 'icmp' and $^O eq 'MSWin32');

   return;
}

# _run_traceroute (private method)
# The heart of the traceroute method. Sends out packets with incrementing
# ttls per hop. Recieves responses, validates them, and updates the hops
# hash with the time and host. Processes timeouts and returns when the host
# is reached, or the last packet on the last hop sent has been received
# or has timed out. Returns 1 if the host was reached, or 0.
sub _run_traceroute
{
   my $self = shift;

   my (  $end,          # Counter for endhop to wait until all queries return
         $endhop,       # The hop that the host was reached on
         $stop,         # Tells the main loop to exit
         $sentpackets,  # Number of packets sent
         $currenthop,   # Current hop
         $currentquery, # Current query within the hop
         $nexttimeout,  # Next time a packet will timeout
         $rbits,        # select() bits
         $nfound,       # Number of ready sockets from select()
         %packets,      # Hash of packets sent but without a response
         %pktids,       # Hash of packet port or seq numbers to packet ids
      );

   $stop = $end = $endhop = $sentpackets = 0;

   %packets = ();
   %pktids  = ();

   $currenthop    = $self->first_hop;
   $currentquery  = 0;

   $rbits   = "";
   vec($rbits,$self->{'_icmp_socket'}->fileno(), 1) = 1;

   while (not $stop)
   {
      # Reset the variable
      $nfound = 0;

      # Send packets so long as there are packets to send, there is less than
      # conncurrent_hops packets currently outstanding, there is no packets
      # waiting to be read on the socket and we haven't reached the host yet.
      while (scalar keys %packets < $self->concurrent_hops and
            $currenthop <= $self->max_ttl and
            (not $endhop or $currenthop <= $endhop) and
            not $nfound = select((my $rout = $rbits),undef,undef,0))
      {
         # sentpackets is used as an uid in the %packets hash.
         $sentpackets++;

         $self->debug_print(1,"Sending packet $currenthop $currentquery\n");
         my $start_time = $self->_send_packet($currenthop,$currentquery);
         my $id         = $self->{'_last_id'};
         my $localport  = $self->{'_local_port'};

         $packets{$sentpackets} =
         {
               'id'        => $id,
               'hop'       => $currenthop,
               'query'     => $currentquery,
               'localport' => $localport,
               'starttime' => $start_time,
               'timeout'   => $start_time+$self->query_timeout,
         };

         $pktids{$id} = $sentpackets;

         $nexttimeout = $packets{$sentpackets}{'timeout'}
            unless ($nexttimeout);

         # Current query and current hop increments
         $currentquery = ($currentquery + 1) % $self->queries;
         if ($currentquery == 0)
         {
            $currenthop++;
         }
      }

      # If $nfound is nonzero than data is waiting to be read, no need to
      # call select again.
      if (not $nfound) # No data waiting to be read yet
      {
         # This sets the timeout for select to no more than .1 seconds
         my $timeout = $nexttimeout - time;
         $timeout    = .1 if ($timeout > .1);
         $nfound     = select((my $rout = $rbits),undef,undef,$timeout);
      }

      # While data is waiting to be read, read it.
      while ($nfound and keys %packets)
      {
         my (  $recv_msg,     # The packet read by recv()
               $from_saddr,   # The saddr returned by recv()
               $from_port,    # The port the packet came from
               $from_ip,      # The IP the packet came from
               $from_id,      # The dport / seq of the received packet
               $from_proto,   # The protocol of the packet
               $from_type,    # The ICMP type of the packet
               $from_code,    # The ICMP code of the packet
               $icmp_data,    # The data portion of the ICMP packet
               $local_port,   # The local port the packet is a reply to
               $end_time,     # The time the packet arrived
               $last_hop,     # Set to 1 if this packet came from the host
            );

         $end_time   = time;

         $from_saddr = recv($self->{'_icmp_socket'},$recv_msg,1500,0);
         if (defined $from_saddr)
         {
            ($from_port,$from_ip)   = sockaddr_in($from_saddr);
            $from_ip                = inet_ntoa($from_ip);
            $self->debug_print(1,"Received packet from $from_ip\n");
         }
         else
         {
            $self->debug_print(1,"No packet?\n");
            $nfound = 0;
            last;
         }

         $from_proto = unpack('C',substr($recv_msg,IP_PROTOCOL,1));

         if ($from_proto != getprotobyname('icmp'))
         {
            my $protoname = getprotobynumber($from_proto);
            $self->debug_print(1,"Packet not ICMP $from_proto($protoname)\n");
            last;
         }

         ($from_type,$from_code) = unpack('CC',substr($recv_msg,ICMP_TYPE,2));
         $icmp_data              = substr($recv_msg,ICMP_DATA);

         if (not $icmp_data)
         {
            $self->debug_print(1,
                  "No data in packet ($from_type,$from_code)\n");
            last;
         }

# TODO This code does not decode ICMP codes, only ICMP types, which can lead
# to false results if a router sends, for instance, a Network Unreachable
# or Fragmentation Needed packet.
         if (  $from_type == ICMP_TYPE_TIMEEXCEED or
               $from_type == ICMP_TYPE_UNREACHABLE or
               ($self->protocol eq "icmp" and
                  $from_type == ICMP_TYPE_ECHOREPLY) )
         {

            if ($self->protocol eq 'udp')
            {
               # The local port is used to verify the packet was sent from
               # This process.
               $local_port    = unpack('n',substr($icmp_data,UDP_SPORT,2));

               # The ID for UDP is the destination port number of the packet
               $from_id       = unpack('n',substr($icmp_data,UDP_DPORT,2));

               # The target system will send ICMP port unreachable, routers
               # along the path will send ICMP Time Exceeded messages.
               $last_hop      = ($from_type == ICMP_TYPE_UNREACHABLE) ? 1 : 0;
            }
            elsif ($self->protocol eq 'icmp')
            {
               if ($from_type == ICMP_TYPE_ECHOREPLY)
               {
                  # The ICMP ID is used to verify the packet was sent from
                  # this process.
                  my $icmp_id = unpack('n',substr($recv_msg,ICMP_ID,2));
                  last unless ($icmp_id == $$);

                  my $seq     = unpack('n',substr($recv_msg,ICMP_SEQ,2));
                  $from_id    = $seq; # The ID for ICMP is the seq number
                  $last_hop   = 1;;
               }
               else
               {
                  # The ICMP ID is used to verify the packet was sent from
                  # this process.
                  my $icmp_id = unpack('n',substr($icmp_data,ICMP_ID,2));
                  last unless ($icmp_id == $$);

                  my $ptype   = unpack('C',substr($icmp_data,ICMP_TYPE,1));
                  my $pseq    = unpack('n',substr($icmp_data,ICMP_SEQ,2));
                  if ($ptype eq ICMP_TYPE_ECHO)
                  {
                     $from_id = $pseq; # The ID for ICMP is the seq number
                  }
               }
            }
         }

         # If we got and decoded the packet to get an ID, process it.
         if ($from_ip and $from_id)
         {
            my $id = $pktids{$from_id};
            if (not $id)
            {
               $self->debug_print(1,"No packet sent matches the reply\n");
               last;
            }
            if (not exists $packets{$id})
            {
               $self->debug_print(1,"Packet $id received after ID deleted");
               last;
            }
            if ($packets{$id}{'id'} == $from_id)
            {
               last if ($self->protocol eq 'udp' and
                     $packets{$id}{'localport'} != $local_port);

               my $total_time = $end_time - $packets{$id}{'starttime'};
               my $hop        = $packets{$id}{'hop'};
               my $query      = $packets{$id}{'query'};

               if (not $endhop or $hop <= $endhop)
               {
                  $self->debug_print(1,"Recieved response for $hop $query\n");
                  $self->_add_hop_query($hop, $query+1, TRACEROUTE_OK,
                        $from_ip, sprintf("%.2f", 1000 * $total_time) );

                  # Sometimes a route will change and last_hop won't be set
                  # causing the traceroute to hang. Therefore if hop = endhop
                  # we set $end to the number of query responses for the
                  # hop recieved so far.

                  if ($last_hop or ($endhop and $hop == $endhop))
                  {
                     $end     = $self->hop_queries($hop);
                     $endhop  = $hop;
                  }
               }

               # No longer waiting for this packet
               delete $packets{$id};
            }
         }
         # Check if more data is waiting to be read, if so keep reading
         $nfound  = select((my $rout = $rbits),undef,undef,0);
      }

      # Process timed out packets
      if (keys %packets and $nexttimeout < time)
      {
         undef $nexttimeout;

         foreach my $id (sort keys %packets)
         {
            my $hop        = $packets{$id}{'hop'};

            if ($packets{$id}{'timeout'} < time)
            {
               my $query      = $packets{$id}{'query'};

               $self->debug_print(1,"Timeout for $hop $query\n");
               $self->_add_hop_query($hop, $query+1, TRACEROUTE_TIMEOUT,
                     "", 0 );

               if ($endhop and $hop == $endhop)
               {
                  # Sometimes a route will change and last_hop won't be set
                  # causing the traceroute to hang. Therefore if hop = endhop
                  # we set $end to the number of query responses for the
                  # hop recieved so far.

                  $end = $self->hop_queries($hop);
               }

               # No longer waiting for this packet
               delete $packets{$id};
            }
            elsif (not defined $nexttimeout)
            {
               # Reset next timeout to the next packet
               $nexttimeout = $packets{$id}{'timeout'};
               last;
            }
         }
      }

      # Check if it is time to stop the looping
      if ($currenthop > $self->max_ttl and not keys %packets)
      {
         $self->debug_print(1,"No more packets, reached max_ttl\n");
         $stop = 1;
      }
      elsif ($end >= $self->queries)
      {
         # Delete packets for hops after $endhop
         foreach my $id (sort keys %packets)
         {
            my $hop        = $packets{$id}{'hop'};
            if (not $hop or ( $endhop and $hop > $endhop) )
            {
               # No longer care about this packet
               delete $packets{$id};
            }
         }
         if (not keys %packets)
         {
            $self->debug_print(1,"Reached host on $endhop hop\n");
            $end  = 1;
            $stop = 1;
         }
      }

      # Looping
   }

   return $end;
}

# _create_tracert_socket (private method)
# Reuses the ICMP socket already created for icmp traceroutes, or creates a
# new socket. It then binds the socket to the user defined device and/or
# source address if provided and returns the created socket.
sub _create_tracert_socket
{
   my $self = shift;
   my $socket;

   if ($self->protocol eq "icmp")
   {
      $socket = $self->{'_icmp_socket'};
   }
   elsif ($self->protocol eq "udp")
   {
      $socket     = FileHandle->new();

      socket($socket, PF_INET, SOCK_DGRAM, getprotobyname('udp')) or
         croak "UDP Socket creation error - $!";

      $self->debug_print(2,"Created UDP socket");
   }

   if ($self->device)
   {
      setsockopt($socket, SOL_SOCKET, SO_BINDTODEVICE,
         pack('Z*', $self->device)) or
            croak "error binding to ". $self->device ." - $!";

      $self->debug_print(2,"Bound socket to ". $self->device ."\n");
   }

   if ($self->source_address and $self->source_address ne '0.0.0.0')
   {
      $self->_bind($socket);
   }

   return $socket;
}

# _bind (private method)
# binds a sockets to a local address so all packets originate from that IP.
sub _bind
{
   my $self    = shift;
   my $socket  = shift;

   my $ip = inet_aton($self->source_address);

   croak "Nonexistant local address ". $self->source_address
      unless (defined $ip);

   CORE::bind($socket, sockaddr_in(0,$ip)) or
      croak "Error binding to ".$self->source_address.", $!";

   $self->debug_print(2,"Bound socket to " . $self->source_address . "\n");

   return;
}

# _send_packet (private method)
# Sends the packet for $hop, $query to the destination. Actually calls
# submethods for the different protocols which create and send the packet.
sub _send_packet
{
   my $self          = shift;
   my ($hop,$query)  = @_;

   if ($self->protocol eq "icmp")
   {
      # Sequence ID for the ICMP echo request
      my $seq = ($hop-1) * $self->queries + $query + 1;
      $self->_send_icmp_packet($seq,$hop);
      $self->{'_last_id'} = $seq;
   }
   elsif ($self->protocol eq "udp")
   {
      # Destination port for the UDP packet
      my $dport = $self->base_port + ($hop-1) * $self->queries + $query;
      $self->_send_udp_packet($dport,$hop);
      $self->{'_last_id'} = $dport;
   }

   return time;
}

# _send_icmp_packet (private method)
# Sends an ICMP packet with the given sequence number. The PID is used as
# the packet ID and $seq is the sequence number.
sub _send_icmp_packet
{
   my $self             = shift;
   my ($seq,$hop)       = @_;

   # Set TTL of socket to $hop.
   my $saddr            = $self->_connect(ICMP_PORT,$hop);
   my $data             = 'a' x ($self->packetlen - ICMP_DATA);

   my ($pkt, $chksum)   = (0,0);

   # Create packet twice, once without checksum, once with it
   foreach (1 .. 2)
   {
      $pkt     = pack('CC n3 A*',
                        ICMP_TYPE_ECHO,   # Type
                        ICMP_CODE_ECHO,   # Code
                        $chksum,          # Checksum
                        $$,               # ID (pid)
                        $seq,             # Sequence
                        $data,            # Data
                     );

      $chksum  = $self->_checksum($pkt) unless ($chksum);
   }

   send($self->{'_trace_socket'}, $pkt, 0, $saddr);

   return;
}

# _send_udp_packet (private method)
# Sends a udp packet to the given destination port.
sub _send_udp_packet
{
   my $self          = shift;
   my ($dport,$hop)  = @_;

   # Connect socket to destination port and set TTL
   my $saddr         = $self->_connect($dport,$hop);
   my $data          = 'a' x ($self->packetlen - UDP_DATA);

   $self->_connect($dport,$hop);

   send($self->{'_trace_socket'}, $data, 0);

   return;
}

# _connect (private method)
# Connects the socket unless the protocol is ICMP and sets the TTL.
sub _connect
{
   my $self          = shift;
   my ($port,$hop)   = @_;

   my $socket_addr   = sockaddr_in($port,$self->{_destination});

   if ($self->protocol eq 'udp')
   {
      CORE::connect($self->{'_trace_socket'},$socket_addr);
      $self->debug_print(2,"Connected to " . $self->host . "\n");
   }

   setsockopt($self->{'_trace_socket'}, IPPROTO_IP, IP_TTL, pack('C',$hop));
   $self->debug_print(2,"Set TTL to $hop\n");

   if ($self->protocol eq 'udp')
   {
      my $localaddr                    = getsockname($self->{'_trace_socket'});
      my ($lport,undef)                = sockaddr_in($localaddr);
      $self->{'_local_port'}           = $lport;
   }

   return ($self->protocol eq 'icmp') ? $socket_addr : undef;
}

# _checksum (private method)
# Lifted verbatum from Net::Ping 2.31
# Description:  Do a checksum on the message.  Basically sum all of
# the short words and fold the high order bits into the low order bits.
sub _checksum
{
   my $self = shift;
   my $msg = shift;

   my (  $len_msg,       # Length of the message
         $num_short,     # The number of short words in the message
         $short,         # One short word
         $chk            # The checksum
      );

   $len_msg    = length($msg);
   $num_short  = int($len_msg / 2);
   $chk        = 0;
   foreach $short (unpack("n$num_short", $msg))
   {
      $chk += $short;
   }                                           # Add the odd byte in
   $chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_msg % 2;
   $chk = ($chk >> 16) + ($chk & 0xffff);      # Fold high into low
   return(~(($chk >> 16) + $chk) & 0xffff);    # Again and complement
}

1;

__END__