File Coverage

blib/lib/Net/Traceroute/PurePerl.pm

Criterion	Covered	Total	%
statement	309	369	83.7
branch	91	164	55.4
condition	42	105	40.0
subroutine	42	44	95.4
pod	2	3	66.6
total	486	685	70.9

package Net::Traceroute::PurePerl;

use strict;
use warnings;

use Net::Traceroute;
use Socket;
use FileHandle;
use Carp qw( carp croak );
use Time::HiRes qw(time);

use vars qw( @ISA $VERSION $AUTOLOAD %net_traceroute_native_var %protocols );

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

# 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 SOCKOPT_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_ttl 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_ttl(1)       unless ( defined $self->first_ttl );
    $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";

    for ( my $hop = $self->first_ttl ; $hop <= $self->hops ; $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_ttl( sprintf( '%i', $self->first_ttl ) );
    $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_ttl' must be an integer between 1 and 255"
      if ( $self->first_ttl < 1 or $self->first_ttl > 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_ttl' must be less than or equal to `max_ttl'"
      if ( $self->first_ttl > $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_ttl;
    $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, SOCKOPT_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__