In perl.git, the branch blead has been updated
<https://perl5.git.perl.org/perl.git/commitdiff/673bd1ed6f78d45de6dea7b10523c70eb32afe4e?hp=a6afdf72cdabc9d256e910f1b59a91df3871f687>
- Log -----------------------------------------------------------------
commit 673bd1ed6f78d45de6dea7b10523c70eb32afe4e
Author: Nicolas R <atoo...@cpan.org>
Date: Thu Feb 14 10:15:10 2019 -0600
t/porting/manifest.t add line number
Improve t/porting/manifest.t output on errors
to show the line number.
commit 551524d7c29d0588fce9077be3d0ec93f8ca4c71
Author: Nicolas R <atoo...@cpan.org>
Date: Wed Feb 13 20:22:10 2019 -0600
Net::Ping 501_ping_icmpv6.t: disable sudo test
This is similar to the changes made in 7bfdd8260c
we do not want to use 'sudo' during the tests.
commit 2e598186867b2c0c875266a20b92853486e2b627
Author: Nicolas R <atoo...@cpan.org>
Date: Wed Feb 13 18:32:46 2019 -0600
Update Net::Ping to upstream version 2.71
This retains blead customizations:
* 1a58b39af8 remove of 'use vars'
* 7bfdd8260c 500_ping_icmp.t: remove sudo code
These changes are not required anymore, they
are merged upstream
* 0fc44d0a18 avoid stderr noise in tests
-----------------------------------------------------------------------
Summary of changes:
MANIFEST | 4 +-
Porting/Maintainers.pl | 11 +-
dist/Net-Ping/Changes | 83 ++++++++++++
dist/Net-Ping/lib/Net/Ping.pm | 246 +++++++++++++++++++++++++-----------
dist/Net-Ping/t/001_new.t | 4 +-
dist/Net-Ping/t/190_alarm.t | 5 +-
dist/Net-Ping/t/200_ping_tcp.t | 14 +-
dist/Net-Ping/t/300_ping_stream.t | 8 +-
dist/Net-Ping/t/400_ping_syn.t | 15 ++-
dist/Net-Ping/t/410_syn_host.t | 6 +-
dist/Net-Ping/t/420_ping_syn_port.t | 103 +++++++++++++++
dist/Net-Ping/t/500_ping_icmp.t | 57 ++++++++-
dist/Net-Ping/t/501_ping_icmpv6.t | 73 +++++++++++
dist/Net-Ping/t/510_ping_udp.t | 16 ++-
t/porting/customized.dat | 5 +-
t/porting/known_pod_issues.dat | 2 +-
t/porting/manifest.t | 6 +-
17 files changed, 552 insertions(+), 106 deletions(-)
create mode 100644 dist/Net-Ping/t/420_ping_syn_port.t
create mode 100644 dist/Net-Ping/t/501_ping_icmpv6.t
diff --git a/MANIFEST b/MANIFEST
index 793cdb4c7f..08d7df6109 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3588,14 +3588,16 @@ dist/Net-Ping/t/120_udp_inst.t Ping Net::Ping
dist/Net-Ping/t/130_tcp_inst.t Ping Net::Ping
dist/Net-Ping/t/140_stream_inst.t Ping Net::Ping
dist/Net-Ping/t/150_syn_inst.t Ping Net::Ping
-dist/Net-Ping/t/190_alarm.t Ping Net::Ping
+dist/Net-Ping/t/190_alarm.t Ping Net::Ping
dist/Net-Ping/t/200_ping_tcp.t Ping Net::Ping
dist/Net-Ping/t/250_ping_hires.t Ping Net::Ping
dist/Net-Ping/t/300_ping_stream.t Ping Net::Ping
dist/Net-Ping/t/400_ping_syn.t Ping Net::Ping
dist/Net-Ping/t/410_syn_host.t Ping Net::Ping
+dist/Net-Ping/t/420_ping_syn_port.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/501_ping_icmpv6.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/PathTools/Changes Changelog for PathTools dist
diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl
index e851149adc..e07e222dbb 100755
--- a/Porting/Maintainers.pl
+++ b/Porting/Maintainers.pl
@@ -812,7 +812,7 @@ use File::Glob qw(:case);
},
'Net::Ping' => {
- 'DISTRIBUTION' => 'RURBAN/Net-Ping-2.61.tar.gz',
+ 'DISTRIBUTION' => 'RURBAN/Net-Ping-2.71.tar.gz',
'FILES' => q[dist/Net-Ping],
'EXCLUDED' => [
qw(README.md.PL),
@@ -821,9 +821,12 @@ use File::Glob qw(:case);
qw(t/601_pod-coverage.t),
],
'CUSTOMIZED' => [
- qw( t/000_load.t
- t/001_new.t
- t/500_ping_icmp.t),
+ qw(
+ lib/Net/Ping.pm
+ t/000_load.t
+ t/500_ping_icmp.t
+ t/501_ping_icmpv6.t
+ ),
],
},
diff --git a/dist/Net-Ping/Changes b/dist/Net-Ping/Changes
index 2da51e7a25..228663fdd0 100644
--- a/dist/Net-Ping/Changes
+++ b/dist/Net-Ping/Changes
@@ -1,5 +1,88 @@
CHANGES
-------
+
+2.71 Tue Oct 16 18:41:51 CEST 2018 (rurban)
+ Features
+ - Allow data_size > 1024, up to 65535, i.e. fragmented packets.
+ It is recommended to stay below 1472 though for the typical 1500 MTU.
+ Many simple devices do not allow fragmented ICMP packets (> 1472).
+ RT #17409
+ Bugfixes
+ - Fix the max_datasize documentation
+ Test fixes
+ - The 2 sudo tests on PERL_CORE with a shared perl lib
+
+2.70 Tue Aug 7 10:33:24 CEST 2018 (rurban)
+ Test fixes
+ - Fix broken skip count on 510_ping_udp.t (windows only)
+
+2.69 Mon Aug 6 15:13:25 CEST 2018 (rurban)
+ Test fixes
+ - Allow NET_PING_FAIL_IP override for testing an IP which should not
exist,
+ RT #126006 hmbrand
+ META Changes
+ - Updated README
+
+2.68 Wed Jun 27 11:55:06 CEST 2018 (rurban)
+ Bugfixes
+ - Fixed _resolv return value on failing DNS name lookup. (GH #12
nlv02636)
+ - Fixed installation dir from CPAN. Install into site, not perl there.
+ (GH #12 nlv02636)
+
+2.67 Mon Jun 25 18:10:42 CEST 2018 (rurban)
+ Bugfixes
+ - Fixed non-core icmp ping test. PR #10 Guillaume Bougard
+ - Change croak on failing name lookup to return undef,
+ matching the documentation.
+ Fixes the regression from 2.43, RT #124830
+ - Stabilize Socket::VERSION comparisons, errored with Net::Socket
+ 2.020_03, RT #125677 Smoot Carl-Mitchell
+ Features
+ - Added icmp message_type method with timestamp support.
+ PR #11 Guillaume Bougard
+
+2.66 Thu Mar 8 16:44:03 CET 2018 (rurban)
+ Bugfixes
+ - Fixed icmpv6 ICMP_ECHOREPLY: niko...@garofil.be RT 80479
+ - Fixed icmpv6 default family
+ - Simplify t/020_external.t
+ - Seperate timeout=0 and undef RT #97884
+ Features
+ - Added icmpv6 test.
+ - Added optional local tests hosts for the icmp tests:
+ TEST_PING_HOST and TEST_PING6_HOST
+ - allow sudo tests with local .git
+ - skip sudo test with asan leak detector on linux
+
+2.65 Wed Mar 7 09:38:51 CET 2018 (rurban)
+ META Changes
+ - strip wrong Text::Template dependency and generation for the README
+ https://rt.cpan.org/Public/Bug/Display.html?id=124693
+ This is in core.
+ - Changed repo name from net-ping to Net-Ping.
+ - Changed bugtracker to https://github.com/rurban/Net-Ping/issues
+ - Made Makefile.PL more stable for the CPAN release, support older
+ perl + EUMM versions.
+ - Fixed up TODO for IPv6
+
+2.64 Sat Mar 3 15:56:14 CET 2018 (rurban)
+ Bugfixes
+ - use NIx_NOSERV flag for windows (PR #6 by chorny)
+
+2.63 Sun Nov 26 18:56:04 CET 2017 (rurban)
+ Bugfixes
+ - Keep v5.002 - v5.6 support
+ - Removed outdated demo/fping from the documentation
+ (RT #123750 by Steve Morris)
+ - Added t/420_ping_syn_port.t (#4 by Julio Fraire)
+ with fixes.
+ Features
+ - added indices and crosslinks to the documentation
+
+2.62 Tue Sep 12 13:20:25 2017 -0600 (Nicholas R)
+ Limitations (not on CPAN)
+ - Removed support for v5.002 < v5.6 by introducing our
+
2.61 Sat Jun 17 13:12:58 CEST 2017 (rurban)
Bugfixes
- Fix ping_udp for a started udp echo server (PR#5 by Stephan Loyd)
diff --git a/dist/Net-Ping/lib/Net/Ping.pm b/dist/Net-Ping/lib/Net/Ping.pm
index 5aa32429cc..dce735a0a0 100644
--- a/dist/Net-Ping/lib/Net/Ping.pm
+++ b/dist/Net-Ping/lib/Net/Ping.pm
@@ -19,7 +19,7 @@ use Time::HiRes;
our @ISA = qw(Exporter);
our @EXPORT = qw(pingecho);
our @EXPORT_OK = qw(wakeonlan);
-our $VERSION = "2.62";
+our $VERSION = "2.71";
# Globals
@@ -27,7 +27,7 @@ our $def_timeout = 5; # Default timeout to wait for
a reply
our $def_proto = "tcp"; # Default protocol to use for pinging
our $def_factor = 1.2; # Default exponential backoff rate.
our $def_family = AF_INET; # Default family.
-our $max_datasize = 1024; # Maximum data bytes in a packet
+our $max_datasize = 65535; # Maximum data bytes. recommended: 1472
(Ethernet MTU: 1500)
# The data we exchange with the server for the stream protocol
our $pingstring = "pingschwingping!\n";
our $source_verify = 1; # Default is to verify source endpoint
@@ -40,9 +40,11 @@ my $AF_UNSPEC = eval { Socket::AF_UNSPEC() };
my $AI_NUMERICHOST = eval { Socket::AI_NUMERICHOST() } || 4;
my $NI_NUMERICHOST = eval { Socket::NI_NUMERICHOST() } || 2;
my $IPPROTO_IPV6 = eval { Socket::IPPROTO_IPV6() } || 41;
+my $NIx_NOSERV = eval { Socket::NIx_NOSERV() } || 2;
#my $IPV6_HOPLIMIT = eval { Socket::IPV6_HOPLIMIT() }; # ping6 -h 0-255
my $qr_family = qr/^(?:(?:(:?ip)?v?(?:4|6))|${\AF_INET}|$AF_INET6)$/;
my $qr_family4 = qr/^(?:(?:(:?ip)?v?4)|${\AF_INET})$/;
+my $Socket_VERSION = eval { $Socket::VERSION };
if ($^O =~ /Win32/i) {
# Hack to avoid this Win32 spewage:
@@ -130,7 +132,7 @@ sub new
unless $proto =~ m/^(icmp|icmpv6|udp|tcp|syn|stream|external)$/;
$self->{proto} = $proto;
- $timeout = $def_timeout unless $timeout; # Determine the timeout
+ $timeout = $def_timeout unless defined $timeout; # Determine the timeout
croak("Default timeout for ping must be greater than 0 seconds")
if $timeout <= 0;
$self->{timeout} = $timeout;
@@ -141,8 +143,8 @@ sub new
if ($self->{'host'}) {
my $host = $self->{'host'};
- my $ip = _resolv($host)
- or croak("could not resolve host $host");
+ my $ip = _resolv($host) or
+ carp("could not resolve host $host");
$self->{host} = $ip;
$self->{family} = $ip->{family};
}
@@ -150,7 +152,7 @@ sub new
if ($self->{bind}) {
my $addr = $self->{bind};
my $ip = _resolv($addr)
- or croak("could not resolve local addr $addr");
+ or carp("could not resolve local addr $addr");
$self->{local_addr} = $ip;
} else {
$self->{local_addr} = undef; # Don't bind by default
@@ -173,11 +175,16 @@ sub new
croak('Family must be "ipv4" or "ipv6"')
}
} else {
- $self->{family} = $def_family;
+ if ($self->{proto} eq 'icmpv6') {
+ $self->{family} = $AF_INET6;
+ } else {
+ $self->{family} = $def_family;
+ }
}
$min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size
$data_size = $min_datasize unless defined($data_size) && $proto ne "tcp";
+ # allow for fragmented packets if data_size>1472 (MTU 1500)
croak("Data for ping must be from $min_datasize to $max_datasize bytes")
if ($data_size < $min_datasize) || ($data_size > $max_datasize);
$data_size-- if $self->{proto} eq "udp"; # We provide the first byte
@@ -225,7 +232,7 @@ sub new
}
elsif ($self->{proto} eq "icmpv6")
{
- croak("icmpv6 ping requires root privilege") if !_isroot();
+ #croak("icmpv6 ping requires root privilege") if !_isroot();
croak("Wrong family $self->{family} for icmpv6 protocol")
if $self->{family} and $self->{family} != $AF_INET6;
$self->{family} = $AF_INET6;
@@ -321,7 +328,7 @@ sub bind
($self->{proto} eq "udp" || $self->{proto} eq "icmp");
$ip = $self->_resolv($local_addr);
- croak("nonexistent local address $local_addr") unless defined($ip);
+ carp("nonexistent local address $local_addr") unless defined($ip);
$self->{local_addr} = $ip;
if (($self->{proto} ne "udp") &&
@@ -636,12 +643,33 @@ use constant ICMP_ECHO => 8;
use constant ICMPv6_ECHO => 128;
use constant ICMP_TIME_EXCEEDED => 11; # ICMP packet types
use constant ICMP_PARAMETER_PROBLEM => 12; # ICMP packet types
+use constant ICMP_TIMESTAMP => 13;
+use constant ICMP_TIMESTAMP_REPLY => 14;
use constant ICMP_STRUCT => "C2 n3 A"; # Structure of a minimal ICMP
packet
+use constant ICMP_TIMESTAMP_STRUCT => "C2 n3 N3"; # Structure of a minimal
timestamp 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
use constant ICMP_PORT => 0; # No port with ICMP
use constant IP_MTU_DISCOVER => 10; # linux only
+sub message_type
+{
+ my ($self,
+ $type
+ ) = @_;
+
+ croak "Setting message type only supported on 'icmp' protocol"
+ unless $self->{proto} eq 'icmp';
+
+ return $self->{message_type} || 'echo'
+ unless defined($type);
+
+ croak "Supported icmp message type are limited to 'echo' and 'timestamp':
'$type' not supported"
+ unless $type =~ /^echo|timestamp$/i;
+
+ $self->{message_type} = lc($type);
+}
+
sub ping_icmp
{
my ($self,
@@ -662,6 +690,7 @@ sub ping_icmp
$from_saddr, # sockaddr_in of sender
$from_port, # Port packet was sent from
$from_ip, # Packed IP of sender
+ $timestamp_msg, # ICMP timestamp message type
$from_type, # ICMP type
$from_subcode, # ICMP subcode
$from_chk, # ICMP packet checksum
@@ -672,6 +701,7 @@ sub ping_icmp
$ip = $self->{host} if !defined $ip and $self->{host};
$timeout = $self->{timeout} if !defined $timeout and $self->{timeout};
+ $timestamp_msg = $self->{message_type} && $self->{message_type} eq
'timestamp' ? 1 : 0;
socket($self->{fh}, $ip->{family}, SOCK_RAW, $self->{proto_num}) ||
croak("icmp socket error - $!");
@@ -685,19 +715,29 @@ sub ping_icmp
$self->{seq} = ($self->{seq} + 1) % 65536; # Increment sequence
$checksum = 0; # No checksum for starters
if ($ip->{family} == AF_INET) {
- $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMP_ECHO, SUBCODE,
- $checksum, $self->{pid}, $self->{seq}, $self->{data});
+ if ($timestamp_msg) {
+ $msg = pack(ICMP_TIMESTAMP_STRUCT, ICMP_TIMESTAMP, SUBCODE,
+ $checksum, $self->{pid}, $self->{seq}, 0, 0, 0);
+ } else {
+ $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMP_ECHO, SUBCODE,
+ $checksum, $self->{pid}, $self->{seq}, $self->{data});
+ }
} else {
# how to get SRC
- my $pseudo_header = pack('a16a16Nnn', $ip->{addr_in}, $ip->{addr_in},
8+length($self->{data}), "\0", 0x003a);
+ my $pseudo_header = pack('a16a16Nnn', $ip->{addr_in}, $ip->{addr_in},
8+length($self->{data}), 0, 0x003a);
$msg = pack(ICMP_STRUCT . $self->{data_size}, ICMPv6_ECHO, SUBCODE,
$checksum, $self->{pid}, $self->{seq}, $self->{data});
$msg = $pseudo_header.$msg
}
$checksum = Net::Ping->checksum($msg);
if ($ip->{family} == AF_INET) {
- $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMP_ECHO, SUBCODE,
- $checksum, $self->{pid}, $self->{seq}, $self->{data});
+ if ($timestamp_msg) {
+ $msg = pack(ICMP_TIMESTAMP_STRUCT, ICMP_TIMESTAMP, SUBCODE,
+ $checksum, $self->{pid}, $self->{seq}, 0, 0, 0);
+ } else {
+ $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMP_ECHO, SUBCODE,
+ $checksum, $self->{pid}, $self->{seq}, $self->{data});
+ }
} else {
$msg = pack(ICMP_STRUCT . $self->{data_size}, ICMPv6_ECHO, SUBCODE,
$checksum, $self->{pid}, $self->{seq}, $self->{data});
@@ -731,14 +771,29 @@ sub ping_icmp
$from_saddr = recv($self->{fh}, $recv_msg, 1500, ICMP_FLAGS);
($from_port, $from_ip) = _unpack_sockaddr_in($from_saddr, $ip->{family});
($from_type, $from_subcode) = unpack("C2", substr($recv_msg, 20, 2));
- if ($from_type == ICMP_ECHOREPLY) {
+ if ($from_type == ICMP_TIMESTAMP_REPLY) {
($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4))
if length $recv_msg >= 28;
+ } elsif ($from_type == ICMP_ECHOREPLY) {
+ #warn "ICMP_ECHOREPLY: ", $ip->{family}, " ",$recv_msg, ":",
length($recv_msg);
+ ($from_pid, $from_seq) = unpack("n2", substr($recv_msg, 24, 4))
+ if ($ip->{family} == AF_INET && length $recv_msg == 28);
+ ($from_pid, $from_seq) = unpack("n2", substr($recv_msg, 4, 4))
+ if ($ip->{family} == $AF_INET6 && length $recv_msg == 8);
} elsif ($from_type == ICMPv6_ECHOREPLY) {
- ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4))
- if length $recv_msg >= 28;
+ #($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4))
+ # if length $recv_msg >= 28;
+ #($from_pid, $from_seq) = unpack("n2", substr($recv_msg, 24, 4))
+ # if ($ip->{family} == AF_INET && length $recv_msg == 28);
+ #warn "ICMPv6_ECHOREPLY: ", $ip->{family}, " ",$recv_msg, ":",
length($recv_msg);
+ ($from_pid, $from_seq) = unpack("n2", substr($recv_msg, 4, 4))
+ if ($ip->{family} == $AF_INET6 && length $recv_msg == 8);
+ #} elsif ($from_type == ICMPv6_NI_REPLY) {
+ # ($from_pid, $from_seq) = unpack("n2", substr($recv_msg, 4, 4))
+ # if ($ip->{family} == $AF_INET6 && length $recv_msg == 8);
} else {
- ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 52, 4))
+ #warn "ICMP: ", $from_type, " ",$ip->{family}, " ",$recv_msg, ":",
length($recv_msg);
+ ($from_pid, $from_seq) = unpack("n2", substr($recv_msg, 52, 4))
if length $recv_msg >= 56;
}
$self->{from_ip} = $from_ip;
@@ -747,7 +802,10 @@ sub ping_icmp
next if ($from_pid != $self->{pid});
next if ($from_seq != $self->{seq});
if (! $source_verify || ($self->ntop($from_ip) eq $self->ntop($ip))) { #
Does the packet check out?
- if (($from_type == ICMP_ECHOREPLY) || ($from_type ==
ICMPv6_ECHOREPLY)) {
+ if (!$timestamp_msg && (($from_type == ICMP_ECHOREPLY) || ($from_type
== ICMPv6_ECHOREPLY))) {
+ $ret = 1;
+ $done = 1;
+ } elsif ($timestamp_msg && $from_type == ICMP_TIMESTAMP_REPLY) {
$ret = 1;
$done = 1;
} elsif (($from_type == ICMP_UNREACHABLE) || ($from_type ==
ICMPv6_UNREACHABLE)) {
@@ -1130,13 +1188,14 @@ sub open
$self->{family_local} = $self->{family};
}
- $ip = $self->_resolv($host);
$timeout = $self->{timeout} unless $timeout;
+ $ip = $self->_resolv($host);
- if($self->{proto} eq "stream") {
- if(defined($self->{fh}->fileno())) {
+ if ($self->{proto} eq "stream") {
+ if (defined($self->{fh}->fileno())) {
croak("socket is already open");
} else {
+ return () unless $ip;
$self->tcp_connect($ip, $timeout);
}
}
@@ -1793,12 +1852,13 @@ sub _resolv {
# Clean up port
if (defined($h{port}) && (($h{port} !~ /^\d{1,5}$/) || ($h{port} < 1) ||
($h{port} > 65535))) {
croak("Invalid port `$h{port}' in `$name'");
+ return undef;
}
# END - host:port
# address check
# new way
- if ($Socket::VERSION >= 1.94) {
+ if ($Socket_VERSION > 1.94) {
my %hints = (
family => $AF_UNSPEC,
protocol => IPPROTO_TCP,
@@ -1831,7 +1891,7 @@ sub _resolv {
# resolve
# new way
- if ($Socket::VERSION >= 1.94) {
+ if ($Socket_VERSION >= 1.94) {
my %hints = (
family => $family,
protocol => IPPROTO_TCP
@@ -1839,7 +1899,7 @@ sub _resolv {
my ($err, @getaddr) = Socket::getaddrinfo($h{host}, undef, \%hints);
if (defined($getaddr[0])) {
- my ($err, $address) = Socket::getnameinfo($getaddr[0]->{addr},
$NI_NUMERICHOST);
+ my ($err, $address) = Socket::getnameinfo($getaddr[0]->{addr},
$NI_NUMERICHOST, $NIx_NOSERV);
if (defined($address)) {
$h{addr} = $address;
$h{addr} =~ s/\%(.)*$//; # remove %ifID if IPv6
@@ -1849,18 +1909,21 @@ sub _resolv {
} else {
(undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in6
$getaddr[0]->{addr};
}
- return \%h
+ return \%h;
} else {
- croak("getnameinfo($getaddr[0]->{addr}) failed - $err");
+ carp("getnameinfo($getaddr[0]->{addr}) failed - $err");
+ return undef;
}
} else {
- croak(sprintf("getaddrinfo($h{host},,%s) failed - $err",
+ warn(sprintf("getaddrinfo($h{host},,%s) failed - $err",
$family == AF_INET ? "AF_INET" : "AF_INET6"));
+ return undef;
}
# old way
} else {
if ($family == $AF_INET6) {
croak("Socket >= 1.94 required for IPv6 - found Socket
$Socket::VERSION");
+ return undef;
}
my @gethost = gethostbyname($h{host});
@@ -1870,9 +1933,11 @@ sub _resolv {
$h{family} = AF_INET;
return \%h
} else {
- croak("gethostbyname($h{host}) failed - $^E");
+ carp("gethostbyname($h{host}) failed - $^E");
+ return undef;
}
}
+ return undef;
}
sub _pack_sockaddr_in($$) {
@@ -1907,12 +1972,12 @@ sub _inet_ntoa {
) = @_;
my $ret;
- if ($Socket::VERSION >= 1.94) {
+ if ($Socket_VERSION >= 1.94) {
my ($err, $address) = Socket::getnameinfo($addr, $NI_NUMERICHOST);
if (defined($address)) {
$ret = $address;
} else {
- croak("getnameinfo($addr) failed - $err");
+ carp("getnameinfo($addr) failed - $err");
}
} else {
$ret = inet_ntoa($addr)
@@ -2022,7 +2087,7 @@ utility to perform the ping, and generally produces
relatively
accurate results. If C<Net::Ping::External> if not installed on your
system, specifying the "external" protocol will result in an error.
-If the "syn" protocol is specified, the ping() method will only
+If the "syn" protocol is specified, the L</ping> method will only
send a TCP SYN packet to the remote host then immediately return.
If the syn packet was sent successfully, it will return a true value,
otherwise it will return false. NOTE: Unlike the other protocols,
@@ -2030,12 +2095,10 @@ the return value does NOT determine if the remote host
is alive or
not since the full TCP three-way handshake may not have completed
yet. The remote host is only considered reachable if it receives
a TCP ACK within the timeout specified. To begin waiting for the
-ACK packets, use the ack() method as explained below. Use the
+ACK packets, use the L</ack> method as explained below. Use the
"syn" protocol instead the "tcp" protocol to determine reachability
of multiple destinations simultaneously by sending parallel TCP
SYN packets. It will not block while testing each remote host.
-demo/fping is provided in this distribution to demonstrate the
-"syn" protocol as an example.
This protocol does not require any special privileges.
=head2 Functions
@@ -2046,6 +2109,7 @@ This protocol does not require any special privileges.
host, port, bind, gateway, retrans, pingstring,
source_verify econnrefused dontfrag
IPV6_USE_MIN_MTU IPV6_RECVPATHMTU])
+X<new>
Create a new ping object. All of the parameters are optional and can
be passed as hash ref. All options besides the first 7 must be passed
@@ -2064,7 +2128,8 @@ are included in the ping packet sent to the remote host.
The number of
data bytes is ignored if the protocol is "tcp". The minimum (and
default) number of data bytes is 1 if the protocol is "udp" and 0
otherwise. The maximum number of data bytes that can be specified is
-1024.
+65535, but staying below the MTU (1472 bytes for ICMP) is recommended.
+Many small devices cannot deal with fragmented ICMP packets.
If C<device> is given, this device is used to bind the source endpoint
before sending the ping packet. I believe this only works with
@@ -2105,6 +2170,7 @@ IP_PMTUDISC_DO but need we don't chunk oversized packets.
You need to
set $data_size manually.
=item $p->ping($host [, $timeout [, $family]]);
+X<ping>
Ping the remote host and wait for a response. $host can be either the
hostname or the IP number of the remote host. The optional timeout
@@ -2120,6 +2186,7 @@ be a float, as returned by the Time::HiRes::time()
function, if hires()
has been previously called, otherwise it is returned as an integer.
=item $p->source_verify( { 0 | 1 } );
+X<source_verify>
Allows source endpoint verification to be enabled or disabled.
This is useful for those remote destinations with multiples
@@ -2130,6 +2197,7 @@ This only affects udp and icmp protocol pings.
This is enabled by default.
=item $p->service_check( { 0 | 1 } );
+X<service_check>
Set whether or not the connect behavior should enforce
remote service availability as well as reachability. Normally,
@@ -2154,28 +2222,34 @@ This affects the "udp", "tcp", and "syn" protocols.
This is disabled by default.
=item $p->tcp_service_check( { 0 | 1 } );
+X<tcp_service_check>
Deprecated method, but does the same as service_check() method.
=item $p->hires( { 0 | 1 } );
+X<hires>
With 1 causes this module to use Time::HiRes module, allowing milliseconds
to be returned by subsequent calls to ping().
=item $p->time
+X<time>
The current time, hires or not.
=item $p->socket_blocking_mode( $fh, $mode );
+X<socket_blocking_mode>
Sets or clears the O_NONBLOCK flag on a file handle.
=item $p->IPV6_USE_MIN_MTU
+X<IPV6_USE_MIN_MTU>
With argument sets the option.
Without returns the option value.
=item $p->IPV6_RECVPATHMTU
+X<IPV6_RECVPATHMTU>
Notify an according IPv6 MTU.
@@ -2183,11 +2257,13 @@ With argument sets the option.
Without returns the option value.
=item $p->IPV6_HOPLIMIT
+X<IPV6_HOPLIMIT>
With argument sets the option.
Without returns the option value.
=item $p->IPV6_REACHCONF I<NYI>
+X<IPV6_REACHCONF>
Sets ipv6 reachability
IPV6_REACHCONF was removed in RFC3542. ping6 -R supports it.
@@ -2199,6 +2275,7 @@ Without returns the option value.
Not yet implemented.
=item $p->bind($local_addr);
+X<bind>
Sets the source address from which pings will be sent. This must be
the address of one of the interfaces on the local host. $local_addr
@@ -2215,7 +2292,17 @@ object.
The bind() call can be omitted when specifying the C<bind> option to
new().
+=item $p->message_type([$ping_type]);
+X<message_type>
+
+When you are using the "icmp" protocol, this call permit to change the
+message type to 'echo' or 'timestamp' (only for IPv4, see RFC 792).
+
+Without argument, it returns the currently used icmp protocol message type.
+By default, it returns 'echo'.
+
=item $p->open($host);
+X<open>
When you are using the "stream" protocol, this call pre-opens the
tcp socket. It's only necessary to do this if you want to
@@ -2230,6 +2317,7 @@ The $host argument can be omitted when specifying the
C<host> option to
new().
=item $p->ack( [ $host ] );
+X<ack>
When using the "syn" protocol, use this method to determine
the reachability of the remote host. This method is meant
@@ -2243,57 +2331,66 @@ host is not listening on the port attempted, then the
TCP
connection will not be established and ack() will return
undef. In list context, the host, the ack time, the dotted ip
string, and the port number will be returned instead of just the host.
-If the optional $host argument is specified, the return
+If the optional C<$host> argument is specified, the return
value will be pertaining to that host only.
This call simply does nothing if you are using any protocol
-other than syn.
+other than "syn".
-When new() had a host option, this host will be used.
-Without host argument, all hosts are scanned.
+When L</new> had a host option, this host will be used.
+Without C<$host> argument, all hosts are scanned.
=item $p->nack( $failed_ack_host );
+X<nack>
-The reason that host $failed_ack_host did not receive a
-valid ACK. Useful to find out why when ack( $fail_ack_host )
+The reason that C<host $failed_ack_host> did not receive a
+valid ACK. Useful to find out why when C<ack($fail_ack_host)>
returns a false value.
=item $p->ack_unfork($host)
+X<ack_unfork>
-The variant called by ack() with the syn protocol and $syn_forking
+The variant called by L</ack> with the "syn" protocol and C<$syn_forking>
enabled.
=item $p->ping_icmp([$host, $timeout, $family])
+X<ping_icmp>
-The ping() method used with the icmp protocol.
+The L</ping> method used with the icmp protocol.
=item $p->ping_icmpv6([$host, $timeout, $family]) I<NYI>
+X<ping_icmpv6>
-The ping() method used with the icmpv6 protocol.
+The L</ping> method used with the icmpv6 protocol.
=item $p->ping_stream([$host, $timeout, $family])
+X<ping_stream>
-The ping() method used with the stream protocol.
+The L</ping> method used with the stream protocol.
Perform a stream ping. If the tcp connection isn't
already open, it opens it. It then sends some data and waits for
a reply. It leaves the stream open on exit.
=item $p->ping_syn([$host, $ip, $start_time, $stop_time])
+X<ping_syn>
-The ping() method used with the syn protocol.
+The L</ping> method used with the syn protocol.
Sends a TCP SYN packet to host specified.
=item $p->ping_syn_fork([$host, $timeout, $family])
+X<ping_syn_fork>
-The ping() method used with the forking syn protocol.
+The L</ping> method used with the forking syn protocol.
=item $p->ping_tcp([$host, $timeout, $family])
+X<ping_tcp>
-The ping() method used with the tcp protocol.
+The L</ping> method used with the tcp protocol.
=item $p->ping_udp([$host, $timeout, $family])
+X<ping_udp>
-The ping() method used with the udp protocol.
+The L</ping> method used with the udp protocol.
Perform a udp echo ping. Construct a message of
at least the one-byte sequence number and any additional data bytes.
@@ -2303,21 +2400,25 @@ done. Otherwise go back and wait for the message until
we run out
of time. Return the result of our efforts.
=item $p->ping_external([$host, $timeout, $family])
+X<ping_external>
-The ping() method used with the external protocol.
-Uses Net::Ping::External to do an external ping.
+The L</ping> method used with the external protocol.
+Uses L<Net::Ping::External> to do an external ping.
=item $p->tcp_connect([$ip, $timeout])
+X<tcp_connect>
Initiates a TCP connection, for a tcp ping.
=item $p->tcp_echo([$ip, $timeout, $pingstring])
+X<tcp_echo>
Performs a TCP echo.
It writes the given string to the socket and then reads it
back. It returns 1 on success, 0 on failure.
=item $p->close();
+X<close>
Close the network connection for this ping object. The network
connection is also closed by "undef $p". The network connection is
@@ -2325,45 +2426,52 @@ automatically closed if the ping object goes out of
scope (e.g. $p is
local to a subroutine and you leave the subroutine).
=item $p->port_number([$port_number])
+X<port_number>
When called with a port number, the port number used to ping is set to
-$port_number rather than using the echo port. It also has the effect
+C<$port_number> rather than using the echo port. It also has the effect
of calling C<$p-E<gt>service_check(1)> causing a ping to return a successful
response only if that specific port is accessible. This function returns
-the value of the port that C<ping()> will connect to.
+the value of the port that L</ping> will connect to.
=item $p->mselect
+X<mselect>
-A select() wrapper that compensates for platform
+A C<select()> wrapper that compensates for platform
peculiarities.
=item $p->ntop
+X<ntop>
-Platform abstraction over inet_ntop()
+Platform abstraction over C<inet_ntop()>
=item $p->checksum($msg)
+X<checksum>
Do a checksum on the message. Basically sum all of
the short words and fold the high order bits into the low order bits.
=item $p->icmp_result
+X<icmp_result>
Returns a list of addr, type, subcode.
=item pingecho($host [, $timeout]);
+X<pingecho>
To provide backward compatibility with the previous version of
-Net::Ping, a pingecho() subroutine is available with the same
-functionality as before. pingecho() uses the tcp protocol. The
-return values and parameters are the same as described for the ping()
+L<Net::Ping>, a C<pingecho()> subroutine is available with the same
+functionality as before. C<pingecho()> uses the tcp protocol. The
+return values and parameters are the same as described for the L</ping>
method. This subroutine is obsolete and may be removed in a future
-version of Net::Ping.
+version of L<Net::Ping>.
=item wakeonlan($mac, [$host, [$port]])
+X<wakeonlan>
Emit the popular wake-on-lan magic udp packet to wake up a local
device. See also L<Net::Wake>, but this has the mac address as 1st arg.
-$host should be the local gateway. Without it will broadcast.
+C<$host> should be the local gateway. Without it will broadcast.
Default host: '255.255.255.255'
Default port: 9
@@ -2406,7 +2514,7 @@ kinds of ICMP packets.
The latest source tree is available via git:
- git clone https://github.com/rurban/net-ping.git Net-Ping
+ git clone https://github.com/rurban/Net-Ping.git
cd Net-Ping
The tarball can be created as follows:
@@ -2420,18 +2528,12 @@ The latest Net::Ping releases are included in cperl and
perl5.
For a list of known issues, visit:
L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Ping>
+and
+L<https://github.com/rurban/Net-Ping/issues>
To report a new bug, visit:
-L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-Ping> (stale)
-
-or call:
-
- perlbug
-
-resp.:
-
- cperlbug
+L<https://github.com/rurban/Net-Ping/issues>
=head1 AUTHORS
@@ -2461,6 +2563,8 @@ resp.:
=head1 COPYRIGHT
+Copyright (c) 2017-2018, Reini Urban. All rights reserved.
+
Copyright (c) 2016, cPanel Inc. All rights reserved.
Copyright (c) 2012, Steve Peters. All rights reserved.
diff --git a/dist/Net-Ping/t/001_new.t b/dist/Net-Ping/t/001_new.t
index a51279e0a6..6b097d70a8 100644
--- a/dist/Net-Ping/t/001_new.t
+++ b/dist/Net-Ping/t/001_new.t
@@ -42,7 +42,7 @@ eval {
like($@, qr/Data for ping must be from/, "new() errors for invalid data size");
eval {
- $p = Net::Ping->new("udp", 10, 1025);
+ $p = Net::Ping->new("udp", 10, 70000);
};
like($@, qr/Data for ping must be from/, "new() errors for invalid data size");
@@ -51,7 +51,7 @@ like($@, qr/Data for ping must be from/, "new() errors for
invalid data size");
# force failures for tcp
SKIP: {
- note "Checking icmp";
+ # diag "Checking icmp";
eval { $p = Net::Ping->new('icmp'); };
skip "icmp ping requires root privileges.", 3
if !Net::Ping::_isroot() or $^O eq 'MSWin32';
diff --git a/dist/Net-Ping/t/190_alarm.t b/dist/Net-Ping/t/190_alarm.t
index addfa9e8b8..65276a27d7 100644
--- a/dist/Net-Ping/t/190_alarm.t
+++ b/dist/Net-Ping/t/190_alarm.t
@@ -28,6 +28,9 @@ use strict;
use Test::More tests => 6;
BEGIN {use_ok 'Net::Ping'};
+# Hopefully this is never a routeable host
+my $fail_ip = $ENV{NET_PING_FAIL_IP} || "172.29.249.249";
+
eval {
my $timeout = 11;
@@ -42,7 +45,7 @@ eval {
my $ping = Net::Ping->new("tcp", 2);
# It does not matter if alive or not
$ping->ping("127.0.0.1");
- $ping->ping("172.29.249.249");
+ $ping->ping($fail_ip);
die "alarm failed" if time > $start + $timeout + 1;
}
};
diff --git a/dist/Net-Ping/t/200_ping_tcp.t b/dist/Net-Ping/t/200_ping_tcp.t
index a26b2f1b3d..47168b014a 100644
--- a/dist/Net-Ping/t/200_ping_tcp.t
+++ b/dist/Net-Ping/t/200_ping_tcp.t
@@ -17,6 +17,9 @@ BEGIN {
}
}
+# Hopefully this is never a routeable host
+my $fail_ip = $ENV{NET_PING_FAIL_IP} || "172.29.249.249";
+
# Remote network test using tcp protocol.
#
# NOTE:
@@ -28,13 +31,19 @@ BEGIN {
#
# $ PERL_CORE=1 make test
-use Test::More tests => 12;
+use Test::More tests => 13;
BEGIN {use_ok('Net::Ping');}
my $p = new Net::Ping "tcp",9;
isa_ok($p, 'Net::Ping', 'new() worked');
+# message_type can't be used
+eval {
+ $p->message_type();
+};
+like($@, qr/message type only supported on 'icmp' protocol/, "message_type()
API only concern 'icmp' protocol");
+
isnt($p->ping("localhost"), 0, 'Test on the default port');
# Change to use the more common web port.
@@ -44,8 +53,7 @@ isnt($p->{port_num} = (getservbyname("http", "tcp") || 80),
undef);
isnt($p->ping("localhost"), 0, 'Test localhost on the web port');
-# Hopefully this is never a routeable host
-is($p->ping("172.29.249.249"), 0, "Can't reach 172.29.249.249");
+is($p->ping($fail_ip), 0, "Can't reach $fail_ip");
# Test a few remote servers
# Hopefully they are up when the tests are run.
diff --git a/dist/Net-Ping/t/300_ping_stream.t
b/dist/Net-Ping/t/300_ping_stream.t
index f3b4ee454d..8750dd3a85 100644
--- a/dist/Net-Ping/t/300_ping_stream.t
+++ b/dist/Net-Ping/t/300_ping_stream.t
@@ -30,7 +30,7 @@ BEGIN {
# to really test the stream protocol ping. See
# the end of this document on how to enable it.
-use Test::More tests => 22;
+use Test::More tests => 23;
use Net::Ping;
my $p = new Net::Ping "stream";
@@ -38,6 +38,12 @@ my $p = new Net::Ping "stream";
# new() worked?
isa_ok($p, 'Net::Ping', 'new() worked');
+# message_type can't be used
+eval {
+ $p->message_type();
+};
+like($@, qr/message type only supported on 'icmp' protocol/, "message_type()
API only concern 'icmp' protocol");
+
is($p->ping("localhost"), 1, 'Attempt to connect to the echo port');
for (1..20) {
diff --git a/dist/Net-Ping/t/400_ping_syn.t b/dist/Net-Ping/t/400_ping_syn.t
index edad0fc5fc..1ccec9f0ee 100644
--- a/dist/Net-Ping/t/400_ping_syn.t
+++ b/dist/Net-Ping/t/400_ping_syn.t
@@ -32,13 +32,14 @@ BEGIN {
#
# $ PERL_CORE=1 make test
+# Hopefully this is never a routeable host
+my $fail_ip = $ENV{NET_PING_FAIL_IP} || "172.29.249.249";
+
# Try a few remote servers
my %webs = (
- # Hopefully this is never a routeable host
- "172.29.249.249" => 0,
+ $fail_ip => 0,
# Hopefully all these web ports are open
- "www.freeservers.com." => 1,
"yahoo.com." => 1,
"www.yahoo.com." => 1,
"www.about.com." => 1,
@@ -46,7 +47,7 @@ my %webs = (
);
use Test::More;
-plan tests => 3 + 2 * keys %webs;
+plan tests => 4 + 2 * keys %webs;
use_ok('Net::Ping');
@@ -70,6 +71,12 @@ isa_ok($p, 'Net::Ping', 'new() worked');
# (Make sure getservbyname works in scalar context.)
cmp_ok(($p->{port_num} = getservbyname("http", "tcp")), '>', 0, 'valid port');
+# message_type can't be used
+eval {
+ $p->message_type();
+};
+like($@, qr/message type only supported on 'icmp' protocol/, "message_type()
API only concern 'icmp' protocol");
+
# check if network is up
eval { $p->ping('www.google.com.'); };
if ($@ =~ /getaddrinfo.*failed/) {
diff --git a/dist/Net-Ping/t/410_syn_host.t b/dist/Net-Ping/t/410_syn_host.t
index 8e89e32ac8..d84a7eb6ae 100644
--- a/dist/Net-Ping/t/410_syn_host.t
+++ b/dist/Net-Ping/t/410_syn_host.t
@@ -36,9 +36,11 @@ BEGIN {
# Try a few remote servers
my %webs;
BEGIN {
- %webs = (
# Hopefully this is never a routeable host
- "172.29.249.249" => 0,
+ my $fail_ip = $ENV{NET_PING_FAIL_IP} || "172.29.249.249";
+
+ %webs = (
+ $fail_ip => 0,
# Hopefully all these web ports are open
"www.google.com." => 1,
diff --git a/dist/Net-Ping/t/420_ping_syn_port.t
b/dist/Net-Ping/t/420_ping_syn_port.t
new file mode 100644
index 0000000000..55ee88a835
--- /dev/null
+++ b/dist/Net-Ping/t/420_ping_syn_port.t
@@ -0,0 +1,103 @@
+# Same as 400_ping_sync.t, but port should be included in return
+use strict;
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ unless ($ENV{PERL_TEST_Net_Ping}) {
+ print "1..0 # Skip: network dependent test\n";
+ exit;
+ }
+ }
+ unless (eval "require Socket") {
+ print "1..0 \# Skip: no Socket\n";
+ exit;
+ }
+ unless (getservbyname('echo', 'tcp')) {
+ print "1..0 \# Skip: no echo port\n";
+ exit;
+ }
+ unless (getservbyname('http', 'tcp')) {
+ print "1..0 \# Skip: no http port\n";
+ exit;
+ }
+}
+
+# Remote network test using syn protocol.
+#
+# NOTE:
+# Network connectivity will be required for all tests to pass.
+# Firewalls may also cause some tests to fail, so test it
+# on a clear network. If you know you do not have a direct
+# connection to remote networks, but you still want the tests
+# to pass, use the following:
+#
+# $ PERL_CORE=1 make test
+
+# Hopefully this is never a routeable host
+my $fail_ip = $ENV{NET_PING_FAIL_IP} || "172.29.249.249";
+
+# Try a few remote servers
+my %webs;
+my @hosts = (
+ $fail_ip,
+
+ # Hopefully all these http and https ports are open
+ "www.google.com",
+ "www.duckduckgo.com",
+ "www.microsoft.com",
+);
+
+use Test::More tests => 19;
+
+BEGIN {use_ok('Net::Ping')};
+
+my $can_alarm = eval {alarm 0; 1;};
+
+sub Alarm {
+ alarm(shift) if $can_alarm;
+}
+
+Alarm(50);
+$SIG{ALRM} = sub {
+ fail('Alarm timed out');
+ die "TIMED OUT!";
+};
+
+my $p = Net::Ping->new("syn", 10);
+
+isa_ok($p, 'Net::Ping', 'new() worked');
+
+# Change to use the more common web port.
+# (Make sure getservbyname works in scalar context.)
+cmp_ok(($p->{port_num} = getservbyname("http", "tcp")), '>', 0, 'valid port
for http/tcp');
+
+my %contacted;
+foreach my $host (@hosts) {
+ # ping() does dns resolution and
+ # only sends the SYN at this point
+ Alarm(50); # (Plenty for a DNS lookup)
+ foreach my $port (80, 443) {
+ $p->port_number($port);
+ is($p->ping($host), 1, "Sent SYN to $host at port $port [" .
($p->{bad}->{$host} || "") . "]");
+ $contacted{"$host:$port"} = 1;
+ }
+}
+
+Alarm(20);
+while (my @r = $p->ack()) {
+ my %res;
+ @res{qw(host ack_time ip port)} = @r;
+ my $answered = "$res{host}:$res{port}";
+ like($answered, qr/^[\w\.]+:\d+$/, "Supposed to be up:
$res{host}:$res{port}");
+ delete $contacted{$answered};
+}
+
+Alarm(0);
+# $fail_ip should not be reachable
+is keys %contacted, 2,
+ '2 servers did not acknowledge our ping'
+ or diag sort keys %contacted;
+delete $contacted{$_}
+ foreach ("$fail_ip:80","$fail_ip:443", 'www.about.com:443');
+is keys %contacted, 0,
+ 'The servers that did not acknowledge our ping were correct';
diff --git a/dist/Net-Ping/t/500_ping_icmp.t b/dist/Net-Ping/t/500_ping_icmp.t
index a9175bae7b..e3557115bc 100644
--- a/dist/Net-Ping/t/500_ping_icmp.t
+++ b/dist/Net-Ping/t/500_ping_icmp.t
@@ -1,12 +1,16 @@
# Test to perform icmp protocol testing.
# Root access is required.
+# In the core test suite it calls itself via sudo -n (no password) to test it.
use strict;
use Config;
use Test::More;
+use Net::Ping;
+use Cwd;
+use File::Spec;
BEGIN {
- unless (eval "require Socket") {
+ unless (eval "require Socket;") {
plan skip_all => 'no Socket';
}
unless ($Config{d_getpbyname}) {
@@ -14,19 +18,62 @@ BEGIN {
}
}
-BEGIN {use_ok('Net::Ping')};
+my $is_devel = $ENV{PERL_CORE} || -d ".git" ? 1 : 0;
+# Note this rawsocket test code is considered anti-social in p5p and was
removed in
+# their variant.
+# See http://nntp.perl.org/group/perl.perl5.porters/240707
+# Problem is that ping_icmp needs root perms, and previous bugs were
+# never caught. So I rather execute it via sudo in the core test suite
+# and on devel CPAN dirs, than not at all and risk further bitrot of this API.
+if ( 0 && !Net::Ping::_isroot()) { # disable in blead via 7bfdd8260c
+ my $file = __FILE__;
+ my $lib = $ENV{PERL_CORE} ? '-I../../lib' : '-Mblib';
+ if ($is_devel and $Config{ccflags} =~ /fsanitize=address/ and $^O eq
'linux') {
+ plan skip_all => 'asan leak detector';
+ }
+ # -n prevents from asking for a password. rather fail then
+ # A technical problem is with leak-detectors, like asan, which
+ # require PERL_DESTRUCT_LEVEL=2 to be set in the root env.
+ my $env = "PERL_DESTRUCT_LEVEL=2";
+ if ($ENV{TEST_PING_HOST}) {
+ $env .= " TEST_PING_HOST=$ENV{TEST_PING_HOST}";
+ }
+ if ($ENV{PERL_CORE} && $Config{ldlibpthname}) {
+ my $up = File::Spec->updir();
+ my $dir = Cwd::abs_path(File::Spec->catdir($up, $up));
+ $env .= " $Config{ldlibpthname}=\"$dir\"";
+ }
+ if ($is_devel and
+ system("sudo -n $env \"$^X\" $lib $file") == 0)
+ {
+ exit;
+ } else {
+ plan skip_all => 'no sudo/failed';
+ }
+}
SKIP: {
- skip "icmp ping requires root privileges.", 1
+ skip "icmp ping requires root privileges.", 2
if !Net::Ping::_isroot() or $^O eq 'MSWin32';
my $p = new Net::Ping "icmp";
+ is($p->message_type(), 'echo', "default icmp message type is 'echo'");
+ # message_type fails on wrong message type
+ eval {
+ $p->message_type('information');
+ };
+ like($@, qr/icmp message type are limited to 'echo' and 'timestamp'/,
"Failure on wrong message type");
my $result = $p->ping("127.0.0.1");
if ($result == 1) {
is($result, 1, "icmp ping 127.0.0.1");
} else {
TODO: {
- local $TODO = "icmp firewalled?";
- is($result, 1, "icmp ping 127.0.0.1");
+ local $TODO = "localhost icmp firewalled?";
+ if (exists $ENV{TEST_PING_HOST}) {
+ my $result = $p->ping($ENV{TEST_PING_HOST});
+ is($result, 1, "icmp ping $ENV{TEST_PING_HOST}");
+ } else {
+ is($result, 1, "icmp ping 127.0.0.1");
+ }
}
}
}
diff --git a/dist/Net-Ping/t/501_ping_icmpv6.t
b/dist/Net-Ping/t/501_ping_icmpv6.t
new file mode 100644
index 0000000000..7d89f01cc9
--- /dev/null
+++ b/dist/Net-Ping/t/501_ping_icmpv6.t
@@ -0,0 +1,73 @@
+# Test to perform ICMPv6 protocol testing.
+# Root access is required.
+# In the core test suite it calls itself via sudo -n (no password) to test it.
+
+use strict;
+use Config;
+use Net::Ping;
+use Test::More;
+use Cwd;
+use File::Spec;
+
+BEGIN {
+ unless (eval "require Socket") {
+ plan skip_all => 'no Socket';
+ }
+ unless ($Config{d_getpbyname}) {
+ plan skip_all => 'no getprotobyname';
+ }
+}
+
+my $is_devel = $ENV{PERL_CORE} || -d ".git" ? 1 : 0;
+if (0 && !Net::Ping::_isroot()) {
+ my $file = __FILE__;
+ my $lib = $ENV{PERL_CORE} ? '-I../../lib' : '-Mblib';
+ # -n prevents from asking for a password. rather fail then
+ # A technical problem is with leak-detectors, like asan, which
+ # require PERL_DESTRUCT_LEVEL=2 to be set in the root env.
+ my $env = "PERL_DESTRUCT_LEVEL=2";
+ if ($ENV{TEST_PING6_HOST}) {
+ $env .= " TEST_PING6_HOST=$ENV{TEST_PING6_HOST}";
+ }
+ if ($ENV{PERL_CORE} && $Config{ldlibpthname}) {
+ my $up = File::Spec->updir();
+ my $dir = Cwd::abs_path(File::Spec->catdir($up, $up));
+ $env .= " $Config{ldlibpthname}=\"$dir\"";
+ }
+ if ($is_devel and
+ system("sudo -n $env \"$^X\" $lib $file") == 0) {
+ exit;
+ } else {
+ plan skip_all => 'no sudo/failed';
+ }
+}
+
+
+SKIP: {
+ skip "icmpv6 ping requires root privileges.", 1
+ if !Net::Ping::_isroot() or $^O eq 'MSWin32';
+ my $p = new Net::Ping "icmpv6";
+ # message_type can't be used
+ eval {
+ $p->message_type();
+ };
+ like($@, qr/message type only supported on 'icmp' protocol/, "message_type()
API only concern 'icmp' protocol");
+ my $rightip = "2001:4860:4860::8888"; # pingable ip of google's dnsserver
+ # for a firewalled ipv6 network try an optional local ipv6 host
+ $rightip = $ENV{TEST_PING6_HOST} if $ENV{TEST_PING6_HOST};
+ my $wrongip = "2001:4860:4860::1234"; # non existing ip
+ # diag "Pinging existing IPv6 ";
+ my $result = $p->ping($rightip);
+ if ($result == 1) {
+ ok($result, "icmpv6 ping $rightip");
+ # diag "Pinging wrong IPv6 ";
+ ok(!$p->ping($wrongip), "icmpv6 ping $wrongip");
+ } else {
+ TODO: {
+ local $TODO = "icmpv6 firewalled?";
+ is($result, 1, "icmpv6 ping $rightip");
+ }
+ }
+}
+
+done_testing;
diff --git a/dist/Net-Ping/t/510_ping_udp.t b/dist/Net-Ping/t/510_ping_udp.t
index 025e980392..f974b40dfa 100644
--- a/dist/Net-Ping/t/510_ping_udp.t
+++ b/dist/Net-Ping/t/510_ping_udp.t
@@ -11,17 +11,21 @@ sub isWindowsVista {
#is this Vista or later?
my ($string, $major, $minor, $build, $id) = Win32::GetOSVersion();
return $build >= 6;
-
}
-use Test::More tests => 2;
+use Test::More tests => 3;
BEGIN {use_ok('Net::Ping')};
SKIP: {
- skip "No udp echo port", 1 unless getservbyname('echo', 'udp');
- skip "udp ping blocked by Window's default settings", 1 if
isWindowsVista();
- skip "No getprotobyname", 1 unless $Config{d_getpbyname};
- skip "Not allowed on $^O", 1 if $^O =~ /^(hpux|irix|aix)$/;
+ skip "No udp echo port", 2 unless getservbyname('echo', 'udp');
+ skip "udp ping blocked by Window's default settings", 2 if
isWindowsVista();
+ skip "No getprotobyname", 2 unless $Config{d_getpbyname};
+ skip "Not allowed on $^O", 2 if $^O =~ /^(hpux|irix|aix)$/;
my $p = new Net::Ping "udp";
+ # message_type can't be used
+ eval {
+ $p->message_type();
+ };
+ like($@, qr/message type only supported on 'icmp' protocol/,
"message_type() API only concern 'icmp' protocol");
is($p->ping("127.0.0.1"), 1);
}
diff --git a/t/porting/customized.dat b/t/porting/customized.dat
index 0f2503615b..bfc1b2a200 100644
--- a/t/porting/customized.dat
+++ b/t/porting/customized.dat
@@ -9,9 +9,10 @@ Math::Complex cpan/Math-Complex/t/Trig.t
2682526e23a161d54732c2a66393fe4a234d186
Memoize cpan/Memoize/Memoize.pm 902092ff91cdec9c7b4bd06202eb179e1ce26ca2
NEXT cpan/NEXT/lib/NEXT.pm 2c83d03ee361816e53ccb931137d314ab878d19f
NEXT cpan/NEXT/t/next.t 66fd60eb0f75b6f3eea95d1dee745f9a7a348146
+Net::Ping dist/Net-Ping/lib/Net/Ping.pm
e2e7053673ead1eff8f3ca8ecdd9b838598c1d8c
Net::Ping dist/Net-Ping/t/000_load.t deff5dc2ca54dae28cb19d3631427db127279ac2
-Net::Ping dist/Net-Ping/t/001_new.t 90c9d63509b3efc8941449fbd1ca8b807fa42040
-Net::Ping dist/Net-Ping/t/500_ping_icmp.t
a003daa5eaf215e58234786bb1fbfbebf669bf44
+Net::Ping dist/Net-Ping/t/500_ping_icmp.t
3eeb60181c01b85f876bd6658644548fdf2e24d4
+Net::Ping dist/Net-Ping/t/501_ping_icmpv6.t
54373de5858f8fb7e078e4998a4b3b8dbca91783
Pod::Checker cpan/Pod-Checker/t/pod/contains_bad_pod.xr
73538fd80dfe6e19ad561fe034009b44460208f6
Pod::Checker cpan/Pod-Checker/t/pod/selfcheck.t
8ce3cfd38e4b9bcf5bc7fe7f2a14195e49aed7d8
Pod::Checker cpan/Pod-Checker/t/pod/testcmp.pl
a0cd5c8eca775c7753f4464eee96fa916e3d8a16
diff --git a/t/porting/known_pod_issues.dat b/t/porting/known_pod_issues.dat
index 671f6c72be..d6e8b6af59 100644
--- a/t/porting/known_pod_issues.dat
+++ b/t/porting/known_pod_issues.dat
@@ -342,7 +342,7 @@ dist/devel-ppport/parts/inc/ppphdoc Unknown directive:
=dontwarn 1
dist/devel-ppport/parts/inc/ppphdoc Unknown directive: =implementation
1
dist/devel-ppport/parts/inc/ppphdoc Unknown directive: =provides 1
dist/exporter/lib/exporter.pm Verbatim line length including indents exceeds
79 by 2
-dist/net-ping/lib/net/ping.pm Apparent broken link 1
+dist/net-ping/lib/net/ping.pm Apparent broken link 2
ext/amiga-exec/exec.pm Verbatim line length including indents exceeds 79 by
1
ext/dynaloader/dynaloader.pm Verbatim line length including indents exceeds
79 by 1
ext/hash-util/lib/hash/util.pm Verbatim line length including indents exceeds
79 by 2
diff --git a/t/porting/manifest.t b/t/porting/manifest.t
index 57b4b3f28f..7bed600de5 100644
--- a/t/porting/manifest.t
+++ b/t/porting/manifest.t
@@ -60,11 +60,11 @@ while (<$m>) {
next;
} elsif ($separator !~ tr/ //c) {
# It's all spaces
- fail("Spaces in entry for $file");
+ fail("Spaces in entry for $file in MANIFEST at line $.");
} elsif ($separator =~ tr/\t//) {
- fail("Mixed tabs and spaces in entry for $file");
+ fail("Mixed tabs and spaces in entry for $file in MANIFEST at line $.");
} else {
- fail("Odd whitespace in entry for $file");
+ fail("Odd whitespace in entry for $file in MANIFEST at line $.");
}
}
--
Perl5 Master Repository
