| Subject: | enable setting of TTL and handling of ICMP_TIME_EXCEEDED response |
I wanted to use Net::Ping with lower TTL's to find out intermediate
routers (tracerout-ish behaviour), so I added support for setting the
TTL and properly handling ICMP_TIME_EXCEEDED responses. If it is to
your liking, you can include it.
I have only tested this on a linux platform, though.
| Subject: | Net-Ping-TTL.patch |
diff -ruN src/MANIFEST Net-Ping-2.36/MANIFEST
--- src/MANIFEST 2009-09-10 09:20:36.000000000 +0200
+++ Net-Ping-2.36/MANIFEST 2009-06-08 18:29:23.000000000 +0200
@@ -18,5 +18,4 @@
t/450_service.t
t/500_ping_icmp.t
t/510_ping_udp.t
-t/520_ping_icmp_ttl.t
META.yml Module meta-data (added by MakeMaker)
diff -ruN src/lib/Net/Ping.pm Net-Ping-2.36/lib/Net/Ping.pm
--- src/lib/Net/Ping.pm 2009-09-10 09:11:00.000000000 +0200
+++ Net-Ping-2.36/lib/Net/Ping.pm 2009-06-08 18:30:57.000000000 +0200
@@ -18,9 +18,8 @@
@EXPORT = qw(pingecho);
$VERSION = "2.36";
-use constant SOL_IP => 0;
-use constant IP_TOS => 1;
-use constant IP_TTL => 2;
+sub SOL_IP { 0; };
+sub IP_TOS { 1; };
# Constants
@@ -88,7 +87,6 @@
$data_size, # Optional additional bytes of data
$device, # Optional device to use
$tos, # Optional ToS to set
- $ttl, # Optional TTL to set
) = @_;
my $class = ref($this) || $this;
my $self = {};
@@ -112,12 +110,6 @@
$self->{"tos"} = $tos;
- if ($self->{"proto"} eq 'icmp') {
- croak('TTL must be from 0 to 255')
- if ($ttl && ($ttl < 0 || $ttl > 255));
- $self->{"ttl"} = $ttl;
- }
-
$min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size
$data_size = $min_datasize unless defined($data_size) && $proto ne "tcp";
croak("Data for ping must be from $min_datasize to $max_datasize bytes")
@@ -151,7 +143,7 @@
or croak "error binding to device $self->{'device'} $!";
}
if ($self->{'tos'}) {
- setsockopt($self->{"fh"}, SOL_IP, IP_TOS, pack("I*", $self->{'tos'}))
+ setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
or croak "error configuring tos to $self->{'tos'} $!";
}
}
@@ -169,13 +161,9 @@
or croak "error binding to device $self->{'device'} $!";
}
if ($self->{'tos'}) {
- setsockopt($self->{"fh"}, SOL_IP, IP_TOS, pack("I*", $self->{'tos'}))
+ setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
or croak "error configuring tos to $self->{'tos'} $!";
}
- if ($self->{'ttl'}) {
- setsockopt($self->{"fh"}, SOL_IP, IP_TTL, pack("I*", $self->{'ttl'}))
- or croak "error configuring ttl to $self->{'ttl'} $!";
- }
}
elsif ($self->{"proto"} eq "tcp" || $self->{"proto"} eq "stream")
{
@@ -421,8 +409,6 @@
use constant ICMP_ECHOREPLY => 0; # ICMP packet types
use constant ICMP_UNREACHABLE => 3; # ICMP packet types
-use constant ICMP_TIME_EXCEEDED => 11; # ICMP packet types
-use constant ICMP_PARAMETERPROB => 12; # ICMP packet types
use constant ICMP_ECHO => 8;
use constant ICMP_STRUCT => "C2 n3 A"; # Structure of a minimal ICMP packet
use constant SUBCODE => 0; # No ICMP subcode for ECHO and ECHOREPLY
@@ -503,18 +489,15 @@
$self->{"from_ip"} = $from_ip;
$self->{"from_type"} = $from_type;
$self->{"from_subcode"} = $from_subcode;
- next if ($from_pid != $self->{"pid"});
- next if ($from_seq != $self->{"seq"});
- if (! $source_verify || (inet_ntoa($from_ip) eq inet_ntoa($ip))) { # Does the packet check out?
+ if (($from_pid == $self->{"pid"}) && # Does the packet check out?
+ (! $source_verify || (inet_ntoa($from_ip) eq inet_ntoa($ip))) &&
+ ($from_seq == $self->{"seq"})) {
if ($from_type == ICMP_ECHOREPLY) {
$ret = 1;
$done = 1;
} elsif ($from_type == ICMP_UNREACHABLE) {
$done = 1;
}
- } elsif ($from_type == ICMP_TIME_EXCEEDED) {
- $ret = 0;
- $done = 1;
}
} else { # Oops, timed out
$done = 1;
@@ -610,7 +593,7 @@
or croak("error binding to device $self->{'device'} $!");
}
if ($self->{'tos'}) {
- setsockopt($self->{"fh"}, SOL_IP, IP_TOS, pack("I*", $self->{'tos'}))
+ setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
or croak "error configuring tos to $self->{'tos'} $!";
}
};
@@ -1054,7 +1037,7 @@
or croak("error binding to device $self->{'device'} $!");
}
if ($self->{'tos'}) {
- setsockopt($fh, SOL_IP, IP_TOS, pack("I*", $self->{'tos'}))
+ setsockopt($fh, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
or croak "error configuring tos to $self->{'tos'} $!";
}
# Set O_NONBLOCK property on filehandle
@@ -1123,7 +1106,7 @@
or croak("error binding to device $self->{'device'} $!");
}
if ($self->{'tos'}) {
- setsockopt($self->{"fh"}, SOL_IP, IP_TOS, pack("I*", $self->{'tos'}))
+ setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
or croak "error configuring tos to $self->{'tos'} $!";
}
@@ -1526,7 +1509,7 @@
=over 4
-=item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device [, $tos [, $ttl ]]]]]]);
+=item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device [, $tos ]]]]]);
Create a new ping object. All of the parameters are optional. $proto
specifies the protocol to use when doing a ping. The current choices
@@ -1550,8 +1533,6 @@
If $tos is given, this ToS is configured into the socket.
-For icmp, $ttl can be specified to set the TTL of the outgoing packet.
-
=item $p->ping($host [, $timeout]);
Ping the remote host and wait for a response. $host can be either the
@@ -1791,6 +1772,6 @@
This program is free software; you may redistribute it and/or
modify it under the same terms as Perl itself.
-$Id: Ping.pm,v 1.1 2009/09/09 12:36:52 rolek Exp $
+$Id: Ping.pm,v 1.86 2003/06/27 21:31:07 rob Exp $
=cut
diff -ruN src/t/520_ping_icmp_ttl.t Net-Ping-2.36/t/520_ping_icmp_ttl.t
--- src/t/520_ping_icmp_ttl.t 2009-09-10 09:05:00.000000000 +0200
+++ Net-Ping-2.36/t/520_ping_icmp_ttl.t 1970-01-01 01:00:00.000000000 +0100
@@ -1,59 +0,0 @@
-# Test to perform icmp protocol testing.
-# Root access is required.
-
-BEGIN {
- unless (eval "require Socket") {
- print "1..0 \# Skip: no Socket\n";
- exit;
- }
-}
-
-use Test;
-use Net::Ping;
-plan tests => 8;
-
-# Everything loaded fine
-ok 1;
-
-if (($> and $^O ne 'VMS')
- or (($^O eq 'MSWin32' or $^O eq 'cygwin')
- and !IsAdminUser())
- or ($^O eq 'VMS'
- and (`write sys\$output f\$privilege("SYSPRV")` =~ m/FALSE/))) {
- skip "icmp ping requires root privileges.", 1;
-} elsif ($^O eq 'MacOS') {
- skip "icmp protocol not supported.", 1;
-} else {
- my $p = new Net::Ping ("icmp",undef,undef,undef,undef,undef);
- ok $p->ping("127.0.0.1");
- $p->close();
- $p = new Net::Ping ("icmp",undef,undef,undef,undef,0);
- ok $p->ping("127.0.0.1");
- $p->close();
- $p = undef();
- $p = eval 'new Net::Ping ("icmp",undef,undef,undef,undef,1)';
- ok(defined($p));
- $p = undef();
- $p = eval 'new Net::Ping ("icmp",undef,undef,undef,undef,-1)';
- ok(!defined($p));
- $p = undef();
- $p = eval 'new Net::Ping ("icmp",undef,undef,undef,undef,256)';
- ok(!defined($p));
- $p = new Net::Ping ("icmp",undef,undef,undef,undef,10);
- ok $p->ping("127.0.0.1");
- $p->close();
- $p = new Net::Ping ("icmp",undef,undef,undef,undef,64);
- my $pr = $p->ping("www.cpan.org");
- $q = new Net::Ping ("icmp",undef,undef,undef,undef,1);
- my $qr = $q->ping("www.cpan.org");
- skip (!$pr, !$qr);
- $p->close();
- $q->close();
-}
-
-sub IsAdminUser {
- return unless $^O eq 'MSWin32' or $^O eq "cygwin";
- return unless eval { require Win32 };
- return unless defined &Win32::IsAdminUser;
- return Win32::IsAdminUser();
-}