In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/1bd59f2c8b61c62045c3168ba7470136f276702d?hp=0fcd5a598c8b93643371a1ee911cf1da70e787cb>
- Log ----------------------------------------------------------------- commit 1bd59f2c8b61c62045c3168ba7470136f276702d Author: Steve Peters <[email protected]> Date: Fri Mar 15 13:38:44 2013 -0500 Upgrade to Net::Ping 2.40. This should silence much of the black smoke seen on Windows and Cygwin coming from Net::Ping. ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + Porting/Maintainers.pl | 2 +- dist/Net-Ping/Changes | 46 +++++++++++++++++++++++++++++++ dist/Net-Ping/lib/Net/Ping.pm | 59 +++++++++++++++++++++++++--------------- dist/Net-Ping/t/200_ping_tcp.t | 2 +- dist/Net-Ping/t/400_ping_syn.t | 3 +- dist/Net-Ping/t/410_syn_host.t | 4 +- dist/Net-Ping/t/510_ping_udp.t | 28 +++++++------------ dist/Net-Ping/t/520_icmp_ttl.t | 47 +++++++++++++++++++++++++++++++ 9 files changed, 146 insertions(+), 46 deletions(-) create mode 100644 dist/Net-Ping/t/520_icmp_ttl.t diff --git a/MANIFEST b/MANIFEST index a79fd32..3fadb19 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3473,6 +3473,7 @@ dist/Net-Ping/t/410_syn_host.t Ping Net::Ping dist/Net-Ping/t/450_service.t Ping Net::Ping dist/Net-Ping/t/500_ping_icmp.t Ping Net::Ping dist/Net-Ping/t/510_ping_udp.t Ping Net::Ping +dist/Net-Ping/t/520_icmp_ttl.t Ping Net::Ping dist/Safe/Changes Changes for Safe.pm dist/Safe/Makefile.PL Makefile.PL for Safe.pm dist/Safe/MANIFEST MANIFEST for Safe.pm diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 612a056..60ee2cc 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -1330,7 +1330,7 @@ use File::Glob qw(:case); 'Net::Ping' => { 'MAINTAINER' => 'smpeters', - 'DISTRIBUTION' => 'SMPETERS/Net-Ping-2.39.tar.gz', + 'DISTRIBUTION' => 'SMPETERS/Net-Ping-2.40.tar.gz', 'FILES' => q[dist/Net-Ping], 'UPSTREAM' => 'blead', }, diff --git a/dist/Net-Ping/Changes b/dist/Net-Ping/Changes index 905f059..47dddbe 100644 --- a/dist/Net-Ping/Changes +++ b/dist/Net-Ping/Changes @@ -1,5 +1,51 @@ CHANGES ------- +2.40 Mar 15 11:20 2013 + Bugfixes + - several fixes to tests to stop the black smoke on Win32's + and Cygwin since the core updated the module to Test::More. + I had planned a later release, but all the black smoke is + forcing a release. + - fixes to some skips in tests that were still using the + Test style skip's. + - Documentation fix for https://rt.cpan.org/Ticket/Display.html?id=48014. + Thanks to Keith Taylor <[email protected]> + - Instead of using a hard-coded TOS value, import IP_TOS from + Socket. This fixes an outstanding bug on Solaris which uses a + different value for IP_TOS in it headers than Linux. I'm assuming + other OS's were fixed with this change as well. + + Features + - added TTL handling for icmp pings to allow traceroute like + applications to be built with Net::Ping. Thanks to + <[email protected]> for the patch and tests! + + Internals + - replaced SOL_IP with IPPROTO_IP. SOL_IP is not portable and was + hard-coded anyway. + - added IPPROTO_IP, IP_TOS, IP_TTL, and AF_INET to the list of Socket + constants imported. + - removed some hard-coded constants. + - converted all calls to inet_ntoa() to inet_ntop() in preparation + for further ipv6 updates. + + Infrastructure + - Makefile.PL updated to require Test::More, Time::HiRes, and a + recent Socket + - several changes for github hosting + - add a .gitignore file + - added a .travis.yml file to allow CI testing with pushed to + github + - replaced the README with a README.md which displays the + Travis CI build status on github. + + +2.39 Mar 13 09:25 2013 + - patch from Matthew Musgrove to resolve RT #45812. Thanks! + - pulled in several changes from the Perl core + +2.36 Jun 08 12:00 2009 + - release to include a few fixes from the Perl core 2.35 Feb 08 14:42 2008 - Patch in Perl change #33242 by Nicholas Clark diff --git a/dist/Net-Ping/lib/Net/Ping.pm b/dist/Net-Ping/lib/Net/Ping.pm index 850359c..a4d4a50 100644 --- a/dist/Net-Ping/lib/Net/Ping.pm +++ b/dist/Net-Ping/lib/Net/Ping.pm @@ -8,18 +8,15 @@ use vars qw(@ISA @EXPORT $VERSION $def_timeout $def_proto $def_factor $max_datasize $pingstring $hires $source_verify $syn_forking); use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK ); -use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET SO_ERROR - inet_aton inet_ntoa sockaddr_in ); +use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET SO_ERROR IPPROTO_IP IP_TOS IP_TTL + inet_aton inet_ntop AF_INET sockaddr_in ); use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN WNOHANG ); use FileHandle; use Carp; @ISA = qw(Exporter); @EXPORT = qw(pingecho); -$VERSION = "2.39"; - -sub SOL_IP { 0; }; -sub IP_TOS { 1; }; +$VERSION = "2.40"; # Constants @@ -87,6 +84,7 @@ sub new $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 = {}; @@ -110,6 +108,12 @@ sub new $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") @@ -143,7 +147,7 @@ sub new 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"}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'})) or croak "error configuring tos to $self->{'tos'} $!"; } } @@ -161,9 +165,13 @@ sub new 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"}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'})) or croak "error configuring tos to $self->{'tos'} $!"; } + if ($self->{'ttl'}) { + setsockopt($self->{"fh"}, IPPROTO_IP, IP_TTL, pack("I*", $self->{'ttl'})) + or croak "error configuring ttl to $self->{'ttl'} $!"; + } } elsif ($self->{"proto"} eq "tcp" || $self->{"proto"} eq "stream") { @@ -392,7 +400,7 @@ sub ping croak("Unknown protocol \"$self->{proto}\" in ping()"); } - return wantarray ? ($ret, &time() - $ping_time, inet_ntoa($ip)) : $ret; + return wantarray ? ($ret, &time() - $ping_time, inet_ntop(AF_INET, $ip)) : $ret; } # Uses Net::Ping::External to do an external ping. @@ -410,6 +418,8 @@ sub ping_external { use constant ICMP_ECHOREPLY => 0; # ICMP packet types use constant ICMP_UNREACHABLE => 3; # ICMP packet types use constant ICMP_ECHO => 8; +use constant ICMP_TIME_EXCEEDED => 11; # ICMP packet types +use constant ICMP_PARAMETER_PROBLEM => 12; # ICMP packet types use constant ICMP_STRUCT => "C2 n3 A"; # Structure of a minimal ICMP packet use constant SUBCODE => 0; # No ICMP subcode for ECHO and ECHOREPLY use constant ICMP_FLAGS => 0; # No special flags for send or recv @@ -489,14 +499,17 @@ sub ping_icmp $self->{"from_ip"} = $from_ip; $self->{"from_type"} = $from_type; $self->{"from_subcode"} = $from_subcode; - if (($from_pid == $self->{"pid"}) && # Does the packet check out? - (! $source_verify || (inet_ntoa($from_ip) eq inet_ntoa($ip))) && - ($from_seq == $self->{"seq"})) { + next if ($from_pid != $self->{"pid"}); + next if ($from_seq != $self->{"seq"}); + if (! $source_verify || (inet_ntop(AF_INET, $from_ip) eq inet_ntop(AF_INET, $ip))) { # Does the packet check out? if ($from_type == ICMP_ECHOREPLY) { $ret = 1; - $done = 1; + $done = 1; } elsif ($from_type == ICMP_UNREACHABLE) { $done = 1; + } elsif ($from_type == ICMP_TIME_EXCEEDED) { + $ret = 0; + $done = 1; } } } else { # Oops, timed out @@ -510,7 +523,7 @@ sub icmp_result { my ($self) = @_; my $ip = $self->{"from_ip"} || ""; $ip = "\0\0\0\0" unless 4 == length $ip; - return (inet_ntoa($ip),($self->{"from_type"} || 0), ($self->{"from_subcode"} || 0)); + return (inet_ntop(AF_INET, $ip),($self->{"from_type"} || 0), ($self->{"from_subcode"} || 0)); } # Description: Do a checksum on the message. Basically sum all of @@ -593,7 +606,7 @@ sub tcp_connect 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"}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'})) or croak "error configuring tos to $self->{'tos'} $!"; } }; @@ -1037,7 +1050,7 @@ sub ping_syn or croak("error binding to device $self->{'device'} $!"); } if ($self->{'tos'}) { - setsockopt($fh, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'})) + setsockopt($fh, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'})) or croak "error configuring tos to $self->{'tos'} $!"; } # Set O_NONBLOCK property on filehandle @@ -1106,7 +1119,7 @@ sub ping_syn_fork { 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"}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'})) or croak "error configuring tos to $self->{'tos'} $!"; } @@ -1247,7 +1260,7 @@ sub ack } # Everything passed okay, return the answer return wantarray ? - ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1])) + ($entry->[0], &time() - $entry->[3], inet_ntop(AF_INET, $entry->[1])) : $entry->[0]; } else { warn "Corrupted SYN entry: unknown fd [$fd] ready!"; @@ -1283,7 +1296,7 @@ sub ack_unfork { # Host passed as arg if (my $entry = $self->{"good"}->{$host}) { delete $self->{"good"}->{$host}; - return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1])); + return ($entry->[0], &time() - $entry->[3], inet_ntop(AF_INET, $entry->[1])); } } @@ -1327,7 +1340,7 @@ sub ack_unfork { # And wait for the next winner next; } - return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1])); + return ($entry->[0], &time() - $entry->[3], inet_ntop(AF_INET, $entry->[1])); } } else { # Should never happen @@ -1419,7 +1432,7 @@ Net::Ping - check a remote host for reachability $p = Net::Ping->new("tcp", 2); # Try connecting to the www port instead of the echo port - $p->port_number(getservbyname("http", "tcp")); + $p->port_number(scalar(getservbyname("http", "tcp"))); while ($stop_time > time()) { print "$host not reachable ", scalar(localtime()), "\n" @@ -1511,7 +1524,7 @@ This protocol does not require any special privileges. =over 4 -=item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device [, $tos ]]]]]); +=item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device [, $tos [, $ttl ]]]]]]); Create a new ping object. All of the parameters are optional. $proto specifies the protocol to use when doing a ping. The current choices @@ -1535,6 +1548,8 @@ superuser privileges and with udp and icmp protocols at this time. 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 diff --git a/dist/Net-Ping/t/200_ping_tcp.t b/dist/Net-Ping/t/200_ping_tcp.t index 2f8a40b..8ef4fb7 100644 --- a/dist/Net-Ping/t/200_ping_tcp.t +++ b/dist/Net-Ping/t/200_ping_tcp.t @@ -50,7 +50,7 @@ is($p->ping("172.29.249.249"), 0, "Can't reach 172.29.249.249"); # Test a few remote servers # Hopefully they are up when the tests are run. -foreach (qw(www.geocities.com ftp.geocities.com +foreach (qw(www.geocities.com www.wisc.edu www.freeservers.com ftp.freeservers.com yahoo.com www.yahoo.com www.about.com)) { isnt($p->ping($_), 0, "Can ping $_"); diff --git a/dist/Net-Ping/t/400_ping_syn.t b/dist/Net-Ping/t/400_ping_syn.t index 025a0cd..e1cfcba 100644 --- a/dist/Net-Ping/t/400_ping_syn.t +++ b/dist/Net-Ping/t/400_ping_syn.t @@ -46,7 +46,6 @@ BEGIN { "www.yahoo.com." => 1, "www.about.com." => 1, "www.microsoft.com." => 1, - "127.0.0.1" => 1, ); } @@ -78,7 +77,7 @@ foreach my $host (keys %webs) { # ping() does dns resolution and # only sends the SYN at this point Alarm(50); # (Plenty for a DNS lookup) - is($p->ping($host), 1, "Can reach $host $p->{bad}->{$host}"); + is($p->ping($host), 1, "Can reach $host [" . ($p->{bad}->{$host} || "") . "]"); } Alarm(20); diff --git a/dist/Net-Ping/t/410_syn_host.t b/dist/Net-Ping/t/410_syn_host.t index a5b570a..82b3820 100644 --- a/dist/Net-Ping/t/410_syn_host.t +++ b/dist/Net-Ping/t/410_syn_host.t @@ -79,14 +79,14 @@ foreach my $host (keys %webs) { # ping() does dns resolution and # only sends the SYN at this point Alarm(50); # (Plenty for a DNS lookup) - is($p->ping($host), 1, "Can reach $host $p->{bad}->{$host}"); + is($p->ping($host), 1, "Can reach $host [" . ($p->{bad}->{$host} || "") . "]"); } Alarm(20); foreach my $host (sort keys %webs) { my $on = $p->ack($host); if ($on) { - is($webs{$host}, 1, "supposed to be up: http://$host/";); + is($webs{$host}, 1, "supposed to be up: http://$host/ [" . ($p->{bad}->{$host} || "") . "]"); } else { is($webs{$host}, 0, "supposed to be down: http://$host/ [" . ($p->{bad}->{$host} || "") . "]"); } diff --git a/dist/Net-Ping/t/510_ping_udp.t b/dist/Net-Ping/t/510_ping_udp.t index ca8e3b0..cb0ca1b 100644 --- a/dist/Net-Ping/t/510_ping_udp.t +++ b/dist/Net-Ping/t/510_ping_udp.t @@ -5,28 +5,20 @@ use strict; sub isWindowsVista { return unless $^O eq 'MSWin32' or $^O eq "cygwin"; return unless eval { require Win32 }; - return unless defined &Win32::GetOSName; - return Win32::GetOSName() eq "WinVista"; -} + return unless defined &Win32::GetOSVersion(); -BEGIN { - unless (eval "require Socket") { - print "1..0 \# Skip: no Socket\n"; - exit; - } - unless (getservbyname('echo', 'udp')) { - print "1..0 \# Skip: no udp echo port\n"; - exit; - } + #is this Vista or later? + my ($string, $major, $minor, $build, $id) = Win32::GetOSVersion(); + return $build >= 6; - if(isWindowsVista()) { - print "1..0 \# Skip: udp ping blocked by Vista's default settings\n"; - exit; - } } use Test::More tests => 2; BEGIN {use_ok('Net::Ping')}; -my $p = new Net::Ping "udp"; -is($p->ping("127.0.0.1"), 1); +SKIP: { + skip "No udp echo port", 1 unless getservbyname('echo', 'udp'); + skip "udp ping blocked by Window's default settings", 1 if isWindowsVista(); + my $p = new Net::Ping "udp"; + is($p->ping("127.0.0.1"), 1); +} diff --git a/dist/Net-Ping/t/520_icmp_ttl.t b/dist/Net-Ping/t/520_icmp_ttl.t new file mode 100644 index 0000000..f553c63 --- /dev/null +++ b/dist/Net-Ping/t/520_icmp_ttl.t @@ -0,0 +1,47 @@ +# 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::More qw(no_plan); +BEGIN {use_ok('Net::Ping')}; + +SKIP: { + skip "icmp ping requires root privileges.", 1 + if ($> and $^O ne 'VMS' and $^O ne 'cygwin') + or (($^O eq 'MSWin32' or $^O eq 'cygwin') + and !IsAdminUser()) + or ($^O eq 'VMS' + and (`write sys\$output f\$privilege("SYSPRV")` =~ m/FALSE/)); + my $p = new Net::Ping ("icmp",undef,undef,undef,undef,undef); + isa_ok($p, 'Net::Ping'); + 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 = new Net::Ping ("icmp",undef,undef,undef,undef,1); + isa_ok($p, 'Net::Ping'); + $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(); +} + +sub IsAdminUser { + return unless $^O eq 'MSWin32' or $^O eq "cygwin"; + return unless eval { require Win32 }; + return unless defined &Win32::IsAdminUser; + return Win32::IsAdminUser(); +} -- Perl5 Master Repository
