Integrate Net::Ping v2.26. (lib/Net/Ping/t/450_service.t should work now)

p4raw-id: //depot/perl@18317

5 files changed, 254 insertions, 122 deletions

diff --git a/MANIFEST b/MANIFEST
index 01dba28365..26e13bc26f 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1348,6 +1348,7 @@ lib/Net/Ping/t/250_ping_hires.t	Ping Net::Ping
 lib/Net/Ping/t/300_ping_stream.t	Ping Net::Ping
 lib/Net/Ping/t/300_ping_stream.t	Ping Net::Ping
 lib/Net/Ping/t/400_ping_syn.t	Ping Net::Ping
+lib/Net/Ping/t/410_syn_host.t	Ping Net::Ping
 lib/Net/Ping/t/450_service.t	Ping Net::Ping
 lib/Net/POP3.pm			libnet
 lib/Net/protoent.pm		By-name interface to Perl's builtin getproto*
diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm
index 1192663238..e27692f706 100644
--- a/lib/Net/Ping.pm
+++ b/lib/Net/Ping.pm
@@ -1,6 +1,6 @@
 package Net::Ping;
 
-# $Id: Ping.pm,v 1.33 2002/10/19 05:02:43 rob Exp $
+# $Id: Ping.pm,v 1.46 2002/12/02 19:17:09 rob Exp $
 
 require 5.002;
 require Exporter;
@@ -11,13 +11,13 @@ use vars qw(@ISA @EXPORT $VERSION
 use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK );
 use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET
                inet_aton inet_ntoa sockaddr_in );
-use POSIX qw( ECONNREFUSED EINPROGRESS WNOHANG );
+use POSIX qw( ECONNREFUSED EINPROGRESS EAGAIN WNOHANG );
 use FileHandle;
 use Carp;
 
 @ISA = qw(Exporter);
 @EXPORT = qw(pingecho);
-$VERSION = "2.23";
+$VERSION = "2.26";
 
 # Constants
 
@@ -157,6 +157,8 @@ sub new
       $self->{"fork_wr"} = FileHandle->new();
       pipe($self->{"fork_rd"}, $self->{"fork_wr"});
       $self->{"fh"} = FileHandle->new();
+      $self->{"good"} = {};
+      $self->{"bad"} = {};
     } else {
       $self->{"wbits"} = "";
       $self->{"bad"} = {};
@@ -665,7 +667,8 @@ sub open
 # of time.  Return the result of our efforts.
 
 use constant UDP_FLAGS => 0; # Nothing special on send or recv
-
+# XXX - Use concept by rdw @ perlmonks
+# http://perlmonks.thepen.com/42898.html
 sub ping_udp
 {
   my ($self,
@@ -761,8 +764,11 @@ sub ping_syn
   }
 
   # Set O_NONBLOCK property on filehandle
-  if (my $flags = fcntl($fh, F_GETFL, 0)) {
-    fcntl($fh, F_SETFL, $flags | O_NONBLOCK);
+  my $flags = 0;
+  if (fcntl($fh, F_GETFL, $flags)) {
+    if (!fcntl($fh, F_SETFL, $flags | O_NONBLOCK)) {
+      croak("fcntl F_SETFL: $!");
+    }
   } else {
     croak("fcntl F_GETFL: $!");
   }
@@ -771,16 +777,18 @@ sub ping_syn
   # by just sending the TCP SYN packet
   if (connect($fh, $saddr)) {
     # Non-blocking, yet still connected?
-    # Must have connected very quickly.
-    # Can this ever really happen?
-  }
-  else {
+    # Must have connected very quickly,
+    # or else it wasn't very non-blocking.
+    #warn "WARNING: Nonblocking connect connected anyway? ($^O)";
+  } else {
     # Error occurred connecting.
-    # Hopefully the connection is just still in progress.
-    if ($! != EINPROGRESS) {
-      # If not, then it really is something bad.
+    if ($! == EINPROGRESS) {
+      # The connection is just still in progress.
+      # This is the expected condition.
+    } else {
+      # Just save the error and continue on.
+      # The ack() can check the status later.
       $self->{"bad"}->{$host} = $!;
-      return undef;
     }
   }
 
@@ -863,7 +871,16 @@ sub ack
     if (my $host = shift) {
       # Host passed as arg
       if (exists $self->{"bad"}->{$host}) {
-        return ();
+        if (!$self->{"tcp_econnrefused"} &&
+            $self->{"bad"}->{ $host } &&
+            (($! = ECONNREFUSED)>0) &&
+            $self->{"bad"}->{ $host } eq "$!") {
+          # "Connection refused" means reachable
+          # Good, continue
+        } else {
+          # ECONNREFUSED means no good
+          return ();
+        }
       }
       my $host_fd = undef;
       foreach my $fd (keys %{ $self->{"syn"} }) {
@@ -889,46 +906,75 @@ sub ack
     while ($wbits !~ /^\0*$/) {
       my $timeout = $stop_time - &time();
       # Force a minimum of 10 ms timeout.
-      $timeout = 0.01 if $timeout <= .01;
-      if (my $nfound = select(undef, (my $wout=$wbits), undef, $timeout)) {
-        # Done waiting for one of the ACKs
-        my $fd = 0;
-        # Determine which one
-        while (length $wout &&
-               !vec($wout, $fd, 1)) {
-          $fd++;
+      $timeout = 0.01 if $timeout <= 0.01;
+
+      my $winner_fd = undef;
+      my $wout = $wbits;
+      my $fd = 0;
+      # Do "bad" fds from $wbits first
+      while ($wout !~ /^\0*$/) {
+        if (vec($wout, $fd, 1)) {
+          # Wipe it from future scanning.
+          vec($wout, $fd, 1) = 0;
+          if (my $entry = $self->{"syn"}->{$fd}) {
+            if ($self->{"bad"}->{ $entry->[0] }) {
+              $winner_fd = $fd;
+              last;
+            }
+          }
+        }
+        $fd++;
+      }
+
+      if (defined($winner_fd) or my $nfound = select(undef, ($wout=$wbits), undef, $timeout)) {
+        if (defined $winner_fd) {
+          $fd = $winner_fd;
+        } else {
+          # Done waiting for one of the ACKs
+          $fd = 0;
+          # Determine which one
+          while ($wout !~ /^\0*$/ &&
+                 !vec($wout, $fd, 1)) {
+            $fd++;
+          }
         }
         if (my $entry = $self->{"syn"}->{$fd}) {
-          if (getpeername($entry->[2])) {
+          # Wipe it from future scanning.
+          delete $self->{"syn"}->{$fd};
+          vec($self->{"wbits"}, $fd, 1) = 0;
+          vec($wbits, $fd, 1) = 0;
+          if (!$self->{"tcp_econnrefused"} &&
+              $self->{"bad"}->{ $entry->[0] } &&
+              (($! = ECONNREFUSED)>0) &&
+              $self->{"bad"}->{ $entry->[0] } eq "$!") {
+            # "Connection refused" means reachable
+            # Good, continue
+          } elsif (getpeername($entry->[2])) {
             # Connection established to remote host
-            delete $self->{"syn"}->{$fd};
-            vec($self->{"wbits"}, $fd, 1) = 0;
-            return wantarray ?
-              ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]))
-              : $entry->[0];
+            # Good, continue
           } else {
             # TCP ACK will never come from this host
             # because there was an error connecting.
 
-            # Wipe it from future scanning.
-            delete $self->{"syn"}->{$fd};
-            vec($self->{"wbits"}, $fd, 1) = 0;
-            vec($wbits, $fd, 1) = 0;
-
             # This should set $! to the correct error.
             my $char;
             read($entry->[2],$char,1);
             # Store the excuse why the connection failed.
             $self->{"bad"}->{$entry->[0]} = $!;
             if (!$self->{"tcp_econnrefused"} &&
-                $! == ECONNREFUSED) {
+                (($! == ECONNREFUSED) ||
+                 ($! == EAGAIN && $^O =~ /cygwin/i))) {
               # "Connection refused" means reachable
-              return wantarray ?
-                ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]))
-                : $entry->[0];
+              # Good, continue
+            } else {
+              # No good, try the next socket...
+              next;
             }
-            # Try another socket...
           }
+          # Everything passed okay, return the answer
+          return wantarray ?
+            ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]))
+            : $entry->[0];
         } else {
           warn "Corrupted SYN entry: unknown fd [$fd] ready!";
           vec($wbits, $fd, 1) = 0;
@@ -957,26 +1003,34 @@ sub ack
 }
 
 sub ack_unfork {
-  my $self = shift;
+  my ($self,$host) = @_;
   my $stop_time = $self->{"stop_time"};
-  if (my $host = shift) {
+  if ($host) {
     # Host passed as arg
-    warn "Cannot specify host for ack on win32\n";
+    if (my $entry = $self->{"good"}->{$host}) {
+      delete $self->{"good"}->{$host};
+      return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]));
+    }
   }
 
   my $rbits = "";
   my $timeout;
+
   if (keys %{ $self->{"syn"} }) {
     # Scan all hosts that are left
     vec($rbits, fileno($self->{"fork_rd"}), 1) = 1;
     $timeout = $stop_time - &time();
+    # Force a minimum of 10 ms timeout.
+    $timeout = 0.01 if $timeout < 0.01;
   } else {
     # No hosts left to wait for
     $timeout = 0;
   }
 
   if ($timeout > 0) {
-    if (my $nfound = select((my $rout=$rbits), undef, undef, $timeout)) {
+    my $nfound;
+    while ( keys %{ $self->{"syn"} } and
+           $nfound = select((my $rout=$rbits), undef, undef, $timeout)) {
       # Done waiting for one of the ACKs
       if (!sysread($self->{"fork_rd"}, $_, 10)) {
         # Socket closed, which means all children are done.
@@ -992,6 +1046,13 @@ sub ack_unfork {
           if (!$how || # If there was no error connecting
               (!$self->{"tcp_econnrefused"} &&
                $how == ECONNREFUSED)) {  # "Connection refused" means reachable
+            if ($host && $entry->[0] ne $host) {
+              # A good connection, but not the host we need.
+              # Move it from the "syn" hash to the "good" hash.
+              $self->{"good"}->{$entry->[0]} = $entry;
+              # And wait for the next winner
+              next;
+            }
             return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]));
           }
         } else {
@@ -1001,7 +1062,8 @@ sub ack_unfork {
       } else {
         die "Empty response from status socket?";
       }
-    } elsif (defined $nfound) {
+    }
+    if (defined $nfound) {
       # Timed out waiting for ACK status
     } else {
       # Weird error occurred with select()
@@ -1051,7 +1113,7 @@ __END__
 
 Net::Ping - check a remote host for reachability
 
-$Id: Ping.pm,v 1.33 2002/10/19 05:02:43 rob Exp $
+$Id: Ping.pm,v 1.46 2002/12/02 19:17:09 rob Exp $
 
 =head1 SYNOPSIS
 
diff --git a/lib/Net/Ping/t/400_ping_syn.t b/lib/Net/Ping/t/400_ping_syn.t
index 3b84af78b1..29022d2d09 100644
--- a/lib/Net/Ping/t/400_ping_syn.t
+++ b/lib/Net/Ping/t/400_ping_syn.t
@@ -37,13 +37,14 @@ my $webs = {
   # Hopefully this is never a routeable host
   "172.29.249.249" => 0,
 
-  # Hopefully all these web servers are on
+  # Hopefully all these web ports are open
   "www.geocities.com." => 1,
   "www.freeservers.com." => 1,
   "yahoo.com." => 1,
   "www.yahoo.com." => 1,
   "www.about.com." => 1,
   "www.microsoft.com." => 1,
+  "127.0.0.1" => 1,
 };
 
 use strict;
@@ -54,6 +55,12 @@ plan tests => ((keys %{ $webs }) * 2 + 3);
 # Everything loaded fine
 ok 1;
 
+alarm(50);
+$SIG{ALRM} = sub {
+  ok 0;
+  die "TIMED OUT!";
+};
+
 my $p = new Net::Ping "syn", 10;
 
 # new() worked?
@@ -66,29 +73,23 @@ ok ($p -> {port_num} = getservbyname("http", "tcp"));
 foreach my $host (keys %{ $webs }) {
   # ping() does dns resolution and
   # only sends the SYN at this point
-  if ($p -> ping($host)) {
-    ok 1;
-  } else {
-    print STDERR "CANNOT RESOLVE $host\n";
-    ok 0;
+  alarm(50); # (Plenty for a DNS lookup)
+  if (!ok $p -> ping($host)) {
+    print STDERR "CANNOT RESOLVE $host $p->{bad}->{$host}\n";
   }
 }
 
+alarm(20);
 while (my $host = $p->ack()) {
-  if ($webs->{$host}) {
-    ok 1;
-  } else {
+  if (!ok $webs->{$host}) {
     print STDERR "SUPPOSED TO BE DOWN: http://$host/\n";
-    ok 0;
   }
   delete $webs->{$host};
 }
 
+alarm(0);
 foreach my $host (keys %{ $webs }) {
-  if ($webs->{$host}) {
-    print STDERR "DOWN: http://$host/\n";
-    ok 0;
-  } else {
-    ok 1;
+  if (!ok !$webs->{$host}) {
+    print STDERR "DOWN: http://$host/ [$p->{bad}->{$host}]\n";
   }
 }
diff --git a/lib/Net/Ping/t/410_syn_host.t b/lib/Net/Ping/t/410_syn_host.t
new file mode 100644
index 0000000000..38bc7f2909
--- /dev/null
+++ b/lib/Net/Ping/t/410_syn_host.t
@@ -0,0 +1,99 @@
+# Same as 400_ping_syn.t but testing ack( $host ) instead of ack( ).
+
+BEGIN {
+  if ($ENV{PERL_CORE}) {
+    unless ($ENV{PERL_TEST_Net_Ping}) {
+      print "1..0 # Skip: network dependent test\n";
+        exit;
+    }
+    chdir 't' if -d 't';
+    @INC = qw(../lib);
+  }
+  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
+
+# Try a few remote servers
+my $webs = {
+  # Hopefully this is never a routeable host
+  "172.29.249.249" => 0,
+
+  # Hopefully all these web ports are open
+  "www.geocities.com." => 1,
+  "www.freeservers.com." => 1,
+  "yahoo.com." => 1,
+  "www.yahoo.com." => 1,
+  "www.about.com." => 1,
+  "www.microsoft.com." => 1,
+  "127.0.0.1" => 1,
+};
+
+use strict;
+use Test;
+use Net::Ping;
+plan tests => ((keys %{ $webs }) * 2 + 3);
+
+# Everything loaded fine
+ok 1;
+
+alarm(50);
+$SIG{ALRM} = sub {
+  ok 0;
+  die "TIMED OUT!";
+};
+
+my $p = new Net::Ping "syn", 10;
+
+# new() worked?
+ok !!$p;
+
+# Change to use the more common web port.
+# (Make sure getservbyname works in scalar context.)
+ok ($p -> {port_num} = getservbyname("http", "tcp"));
+
+foreach my $host (keys %{ $webs }) {
+  # ping() does dns resolution and
+  # only sends the SYN at this point
+  alarm(50); # (Plenty for a DNS lookup)
+  if (!ok($p -> ping($host))) {
+    print STDERR "CANNOT RESOLVE $host $p->{bad}->{$host}\n";
+  }
+}
+
+alarm(20);
+foreach my $host (sort keys %{ $webs }) {
+  my $on = $p->ack($host);
+  if (!ok (($on && $webs->{$host}) ||
+           (!$on && !$webs->{$host}))) {
+    if ($on) {
+      print STDERR "SUPPOSED TO BE DOWN: http://$host/\n";
+    } else {
+      print STDERR "DOWN: http://$host/ $p->{bad}->{$host}\n";
+    }
+  }
+  delete $webs->{$host};
+  alarm(20);
+}
+
+alarm(0);
diff --git a/lib/Net/Ping/t/450_service.t b/lib/Net/Ping/t/450_service.t
index 2ee856c41c..97d3cafee9 100644
--- a/lib/Net/Ping/t/450_service.t
+++ b/lib/Net/Ping/t/450_service.t
@@ -9,50 +9,37 @@ BEGIN {
     print "1..0 \# Skip: no echo port\n";
     exit;
   }
-  unless (0) {
-    print "1..0 \# Skip: too many problems right now\n";
-    exit;
-  }
 }
 
 use strict;
 use Test;
 use Net::Ping;
-use IO::Socket;
 
 # I'm lazy so I'll just use IO::Socket
 # for the TCP Server stuff instead of doing
 # all that direct socket() junk manually.
 
-plan tests => 37;
+plan tests => 26;
 
 # Everything loaded fine
 ok 1;
 
-"0" =~ /(0)/; # IO::Socket::INET ephemeral buttwag hack
-
 # Start a tcp listen server on ephemeral port
 my $sock1 = new IO::Socket::INET
-  LocalAddr => "127.1.1.1",
+  LocalAddr => "127.0.0.1",
   Proto => "tcp",
   Listen => 8,
-  Reuse => 1,
-  Type => SOCK_STREAM,
-  ;
+  or warn "bind: $!";
 
 # Make sure it worked.
 ok !!$sock1;
 
-"0" =~ /(0)/; # IO::Socket::INET ephemeral buttwag hack
-
 # Start listening on another ephemeral port
 my $sock2 = new IO::Socket::INET
-  LocalAddr => "127.2.2.2",
+  LocalAddr => "127.0.0.1",
   Proto => "tcp",
   Listen => 8,
-  Reuse => 1,
-  Type => SOCK_STREAM,
-  ;
+  or warn "bind: $!";
 
 # Make sure it worked too.
 ok !!$sock2;
@@ -66,11 +53,11 @@ ok $port2;
 # Make sure the sockets are listening on different ports.
 ok ($port1 != $port2);
 
+$sock2->close;
+
 # This is how it should be:
-# 127.1.1.1:$port1 - service ON
-# 127.2.2.2:$port2 - service ON
-# 127.1.1.1:$port2 - service OFF
-# 127.2.2.2:$port1 - service OFF
+# 127.0.0.1:$port1 - service ON
+# 127.0.0.1:$port2 - service OFF
 
 #####
 # First, we test using the "tcp" protocol.
@@ -86,20 +73,15 @@ $p->tcp_service_check(0);
 # Try on the first port
 $p->{port_num} = $port1;
 
-# Make sure IP1 is reachable
-ok $p -> ping("127.1.1.1");
-
-# Make sure IP2 is reachable
-ok $p -> ping("127.2.2.2");
+# Make sure it is reachable
+ok $p -> ping("127.0.0.1");
 
 # Try on the other port
 $p->{port_num} = $port2;
 
-# Make sure IP1 is reachable
-ok $p -> ping("127.1.1.1");
+# Make sure it is reachable
+ok $p -> ping("127.0.0.1");
 
-# Make sure IP2 is reachable
-ok $p -> ping("127.2.2.2");
 
 
 # Enable service checking
@@ -108,21 +90,16 @@ $p->tcp_service_check(1);
 # Try on the first port
 $p->{port_num} = $port1;
 
-# Make sure service on IP1 
-ok $p -> ping("127.1.1.1");
-
-# Make sure not service on IP2
-ok !$p -> ping("127.2.2.2");
+# Make sure service is on
+ok $p -> ping("127.0.0.1");
 
 # Try on the other port
 $p->{port_num} = $port2;
 
-# Make sure not service on IP1
-ok !$p -> ping("127.1.1.1");
-
-# Make sure service on IP2
-ok $p -> ping("127.2.2.2");
+# Make sure service is off
+ok !$p -> ping("127.0.0.1");
 
+# test 11 just finished.
 
 #####
 # Lastly, we test using the "syn" protocol.
@@ -137,12 +114,10 @@ $p->tcp_service_check(0);
 # Try on the first port
 $p->{port_num} = $port1;
 
-# Send SYN to both IPs
-ok $p -> ping("127.1.1.1");
-ok $p -> ping("127.2.2.2");
+# Send SYN
+if (!ok $p -> ping("127.0.0.1")) {warn "ERRNO: $!";}
 
-# Both IPs should be reachable
-ok $p -> ack();
+# IP should be reachable
 ok $p -> ack();
 # No more sockets?
 ok !$p -> ack();
@@ -160,12 +135,10 @@ $p->tcp_service_check(0);
 # Try on the other port
 $p->{port_num} = $port2;
 
-# Send SYN to both IPs
-ok $p -> ping("127.1.1.1");
-ok $p -> ping("127.2.2.2");
+# Send SYN
+if (!ok $p -> ping("127.0.0.1")) {warn "ERRNO: $!";}
 
-# Both IPs should be reachable
-ok $p -> ack();
+# IP should still be reachable
 ok $p -> ack();
 # No more sockets?
 ok !$p -> ack();
@@ -184,12 +157,11 @@ $p->tcp_service_check(1);
 # Try on the first port
 $p->{port_num} = $port1;
 
-# Send SYN to both IPs
-ok $p -> ping("127.1.1.1");
-ok $p -> ping("127.2.2.2");
+# Send SYN
+ok $p -> ping("127.0.0.1");
 
-# Only IP1 should have service
-ok "127.1.1.1",$p -> ack();
+# Should have service on
+ok ($p -> ack(),"127.0.0.1");
 # No more good sockets?
 ok !$p -> ack();
 
@@ -207,11 +179,8 @@ $p->tcp_service_check(1);
 # Try on the other port
 $p->{port_num} = $port2;
 
-# Send SYN to both IPs
-ok $p -> ping("127.1.1.1");
-ok $p -> ping("127.2.2.2");
+# Send SYN
+if (!ok $p -> ping("127.0.0.1")) {warn "ERRNO: $!";}
 
-# Only IP2 should have service
-ok "127.2.2.2",$p -> ack();
-# No more good sockets?
+# No sockets should have service on
 ok !$p -> ack();