improve the implementation of Net::Ping on windows by avoiding

fork(), which is pretty heavy-weight for this kind of
application; use non-blocking sockets instead

has been verified to work on Win2k but will need testing on
other flavors of windows

there is a single known failure on windows in 450_service.t (test 18)
due to what appears to be bugs in the ping_syn()/ack() code

p4raw-id: //depot/perl@19535

1 files changed, 68 insertions, 14 deletions

diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm
index 74c5cfc2f2..f50967cd94 100644
--- a/lib/Net/Ping.pm
+++ b/lib/Net/Ping.pm
@@ -8,9 +8,9 @@ use vars qw(@ISA @EXPORT $VERSION
             $def_timeout $def_proto $def_factor
             $max_datasize $pingstring $hires $source_verify $syn_forking);
 use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK );
-use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET
+use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET SO_ERROR
                inet_aton inet_ntoa sockaddr_in );
-use POSIX qw( ECONNREFUSED ECONNRESET EINPROGRESS EAGAIN WNOHANG );
+use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN WNOHANG );
 use FileHandle;
 use Carp;
 
@@ -33,7 +33,11 @@ if ($^O =~ /Win32/i) {
   # Hack to avoid this Win32 spewage:
   # Your vendor has not defined POSIX macro ECONNREFUSED
   *ECONNREFUSED = sub {10061;}; # "Unknown Error" Special Win32 Response?
-  $syn_forking = 1;
+  *ENOTCONN     = sub {10057;};
+  *ECONNRESET   = sub {10054;};
+  *EINPROGRESS  = sub {10036;};
+  *EWOULDBLOCK  = sub {10035;};
+#  $syn_forking = 1;    # XXX possibly useful in < Win2K ?
 };
 
 # h2ph "asm/socket.h"
@@ -207,6 +211,32 @@ sub bind
   return 1;
 }
 
+# Description: A select() wrapper that compensates for platform
+# peculiarities.
+sub mselect
+{
+    if ($_[3] > 0 and $^O eq 'MSWin32') {
+	# On windows, select() doesn't process the message loop,
+	# but sleep() will, allowing alarm() to interrupt the latter.
+	# So we chop up the timeout into smaller pieces and interleave
+	# select() and sleep() calls.
+	my $t = $_[3];
+	my $gran = 0.5;  # polling granularity in seconds
+	my @args = @_;
+	while (1) {
+	    $gran = $t if $gran > $t;
+	    my $nfound = select($_[0], $_[1], $_[2], $gran);
+	    $t -= $gran;
+	    return $nfound if $nfound or !defined($nfound) or $t <= 0;
+
+	    sleep(0);
+	    ($_[0], $_[1], $_[2]) = @args;
+	}
+    }
+    else {
+	return select($_[0], $_[1], $_[2], $_[3]);
+    }
+}
 
 # Description: Allow UDP source endpoint comparision to be
 #              skipped for those remote interfaces that do
@@ -272,6 +302,14 @@ sub socket_blocking_mode
                         # set the non-blocking mode (set O_NONBLOCK)
 
   my $flags;
+  if ($^O eq 'MSWin32') {
+      # FIONBIO enables non-blocking sockets on windows.
+      # FIONBIO is (0x80000000|(4<<16)|(ord('f')<<8)|126), as per winsock.h.
+      my $f = 0x8004667e;
+      my $v = pack("L", $block ? 0 : 1);
+      ioctl($fh, $f, $v) or croak("ioctl failed: $!");
+      return;
+  }
   if ($flags = fcntl($fh, F_GETFL, 0)) {
     $flags = $block ? ($flags & ~O_NONBLOCK) : ($flags | O_NONBLOCK);
     if (!fcntl($fh, F_SETFL, $flags)) {
@@ -399,7 +437,7 @@ sub ping_icmp
   $finish_time = &time() + $timeout;      # Must be done by this time
   while (!$done && $timeout > 0)          # Keep trying if we have time
   {
-    $nfound = select((my $rout=$rbits), undef, undef, $timeout); # Wait for packet
+    $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for packet
     $timeout = $finish_time - &time();    # Get remaining time
     if (!defined($nfound))                # Hmm, a strange error
     {
@@ -537,7 +575,7 @@ sub tcp_connect
     if (!connect($self->{"fh"}, $saddr)) {
       if ($! == ECONNREFUSED) {
         $ret = 1 unless $self->{"econnrefused"};
-      } elsif ($! != EINPROGRESS) {
+      } elsif ($! != EINPROGRESS && ($^O ne 'MSWin32' || $! != EWOULDBLOCK)) {
         # EINPROGRESS is the expected error code after a connect()
         # on a non-blocking socket.  But if the kernel immediately
         # determined that this connect() will never work,
@@ -548,11 +586,14 @@ sub tcp_connect
       } else {
         # Got the expected EINPROGRESS.
         # Just wait for connection completion...
-        my ($wbits, $wout);
-        $wout = $wbits = "";
+        my ($wbits, $wout, $wexc);
+        $wout = $wexc = $wbits = "";
         vec($wbits, $self->{"fh"}->fileno, 1) = 1;
 
-        my $nfound = select(undef, ($wout = $wbits), undef, $timeout);
+        my $nfound = mselect(undef,
+			    ($wout = $wbits),
+			    ($^O eq 'MSWin32' ? ($wexc = $wbits) : undef),
+			    $timeout);
         warn("select: $!") unless defined $nfound;
 
         if ($nfound && vec($wout, $self->{"fh"}->fileno, 1)) {
@@ -576,7 +617,18 @@ sub tcp_connect
                          && $! == ECONNREFUSED);
           }
         } else {
-          # the connection attempt timed out
+          # the connection attempt timed out (or there were connect
+	  # errors on Windows)
+	  if ($^O =~ 'MSWin32') {
+	      # If the connect will fail on a non-blocking socket,
+	      # winsock reports ECONNREFUSED as an exception, and we
+	      # need to fetch the socket-level error code via getsockopt()
+	      # instead of using the thread-level error code that is in $!.
+	      if ($nfound && vec($wexc, $self->{"fh"}->fileno, 1)) {
+		  $! = unpack("i", getsockopt($self->{"fh"}, SOL_SOCKET,
+			                      SO_ERROR));
+	      }
+	  }
         }
       }
     } else {
@@ -594,6 +646,8 @@ sub tcp_connect
     # Buggy Winsock API doesn't allow nonblocking connect.
     # Hence, if our OS is Windows, we need to create a separate
     # process to do the blocking connect attempt.
+    # XXX Above comments are not true at least for Win2K, where
+    # nonblocking connect works.
 
     $| = 1; # Clear buffer prior to fork to prevent duplicate flushing.
     $self->{'tcp_chld'} = fork;
@@ -694,7 +748,7 @@ sub tcp_echo
         vec($rout, $self->{"fh"}->fileno(), 1) = 1;
       }
 
-      if(select($rin, $rout, undef, ($time + $timeout) - &time())) {
+      if(mselect($rin, $rout, undef, ($time + $timeout) - &time())) {
 
         if($rout && vec($rout,$self->{"fh"}->fileno(),1)) {
           my $num = syswrite($self->{"fh"}, $wrstr, length $wrstr);
@@ -853,7 +907,7 @@ sub ping_udp
       $timeout = $retrans if $timeout > $retrans;
       $retrans*= $factor; # Exponential backoff
     }
-    $nfound  = select((my $rout=$rbits), undef, undef, $timeout); # Wait for response
+    $nfound  = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for response
     my $why = $!;
     $timeout = $finish_time - &time();   # Get remaining time
 
@@ -956,7 +1010,7 @@ sub ping_syn
     #warn "WARNING: Nonblocking connect connected anyway? ($^O)";
   } else {
     # Error occurred connecting.
-    if ($! == EINPROGRESS) {
+    if ($! == EINPROGRESS || ($^O eq 'MSWin32' && $! == EWOULDBLOCK)) {
       # The connection is just still in progress.
       # This is the expected condition.
     } else {
@@ -1100,7 +1154,7 @@ sub ack
         $fd++;
       }
 
-      if (defined($winner_fd) or my $nfound = select(undef, ($wout=$wbits), undef, $timeout)) {
+      if (defined($winner_fd) or my $nfound = mselect(undef, ($wout=$wbits), undef, $timeout)) {
         if (defined $winner_fd) {
           $fd = $winner_fd;
         } else {
@@ -1204,7 +1258,7 @@ sub ack_unfork {
   if ($timeout > 0) {
     my $nfound;
     while ( keys %{ $self->{"syn"} } and
-           $nfound = select((my $rout=$rbits), undef, undef, $timeout)) {
+           $nfound = mselect((my $rout=$rbits), undef, undef, $timeout)) {
       # Done waiting for one of the ACKs
       if (!sysread($self->{"fork_rd"}, $_, 16)) {
         # Socket closed, which means all children are done.