Update Net::Ping to upstream version 2.71
authorNicolas R <atoomic@cpan.org>
Thu, 14 Feb 2019 00:32:46 +0000 (18:32 -0600)
committerNicolas R <atoomic@cpan.org>
Thu, 14 Feb 2019 16:48:45 +0000 (10:48 -0600)
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

16 files changed:
MANIFEST
Porting/Maintainers.pl
dist/Net-Ping/Changes
dist/Net-Ping/lib/Net/Ping.pm
dist/Net-Ping/t/001_new.t
dist/Net-Ping/t/190_alarm.t
dist/Net-Ping/t/200_ping_tcp.t
dist/Net-Ping/t/300_ping_stream.t
dist/Net-Ping/t/400_ping_syn.t
dist/Net-Ping/t/410_syn_host.t
dist/Net-Ping/t/420_ping_syn_port.t [new file with mode: 0644]
dist/Net-Ping/t/500_ping_icmp.t
dist/Net-Ping/t/501_ping_icmpv6.t [new file with mode: 0644]
dist/Net-Ping/t/510_ping_udp.t
t/porting/customized.dat
t/porting/known_pod_issues.dat

index 793cdb4..08d7df6 100644 (file)
--- 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
index e851149..af3a68f 100755 (executable)
@@ -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,11 @@ 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
+                ),
         ],
 
     },
index 2da51e7..228663f 100644 (file)
@@ -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: nikolas@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)
index 5aa3242..dce735a 100644 (file)
@@ -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.
index a51279e..6b097d7 100644 (file)
@@ -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';
index addfa9e..65276a2 100644 (file)
@@ -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;
   }
 };
index a26b2f1..47168b0 100644 (file)
@@ -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.
index f3b4ee4..8750dd3 100644 (file)
@@ -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) {
index edad0fc..1ccec9f 100644 (file)
@@ -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/) {
index 8e89e32..d84a7eb 100644 (file)
@@ -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 (file)
index 0000000..55ee88a
--- /dev/null
@@ -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';
index a9175ba..e355711 100644 (file)
@@ -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 (file)
index 0000000..f29e16c
--- /dev/null
@@ -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 (!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;
index 025e980..f974b40 100644 (file)
@@ -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);
 }
index 0f25036..f649384 100644 (file)
@@ -9,9 +9,9 @@ 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
 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
index 671f6c7..d6e8b6a 100644 (file)
@@ -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