Re: Making IO::Socket pass test on Win32

Message-ID: <9b18b3110604020107o6a0b594cwfc2344a172c360b0@mail.gmail.com>

plus extra $Config{d_fork} changes to io_pipe.t and io_multihomed.t

p4raw-id: //depot/perl@27710

5 files changed, 105 insertions, 40 deletions

diff --git a/ext/IO/lib/IO/Socket.pm b/ext/IO/lib/IO/Socket.pm
index 1d7437b03c..fe887d491b 100644
--- a/ext/IO/lib/IO/Socket.pm
+++ b/ext/IO/lib/IO/Socket.pm
@@ -23,7 +23,7 @@ require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian');
 
 @ISA = qw(IO::Handle);
 
-$VERSION = "1.30";
+$VERSION = "1.30_01";
 
 @EXPORT_OK = qw(sockatmark);
 
@@ -112,7 +112,7 @@ sub connect {
 
     $blocking = $sock->blocking(0) if $timeout;
     if (!connect($sock, $addr)) {
-	if (defined $timeout && $!{EINPROGRESS}) {
+	if (defined $timeout && ($!{EINPROGRESS} || $!{EWOULDBLOCK})) {
 	    require IO::Select;
 
 	    my $sel = new IO::Select $sock;
@@ -121,14 +121,17 @@ sub connect {
 		$err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
 		$@ = "connect: timeout";
 	    }
-	    elsif (!connect($sock,$addr) && not $!{EISCONN}) {
+	    elsif (!connect($sock,$addr) &&
+                not ($!{EISCONN} || ($! == 10022 && $^O eq 'MSWin32'))
+            ) {
 		# Some systems refuse to re-connect() to
 		# an already open socket and set errno to EISCONN.
+		# Windows sets errno to WSAEINVAL (10022)
 		$err = $!;
 		$@ = "connect: $!";
 	    }
 	}
-        elsif ($blocking || !$!{EINPROGRESS})  {
+        elsif ($blocking || !($!{EINPROGRESS} || $!{EWOULDBLOCK}))  {
 	    $err = $!;
 	    $@ = "connect: $!";
 	}
@@ -141,6 +144,34 @@ sub connect {
     $err ? undef : $sock;
 }
 
+
+sub blocking {
+    my $sock = shift;
+
+    return $sock->SUPER::blocking(@_)
+        if $^O ne 'MSWin32';
+
+    # Windows handles blocking differently
+    #
+    # http://groups.google.co.uk/group/perl.perl5.porters/browse_thread/
+    #   thread/b4e2b1d88280ddff/630b667a66e3509f?#630b667a66e3509f
+    # http://msdn.microsoft.com/library/default.asp?url=/library/en-us/
+    #   winsock/winsock/ioctlsocket_2.asp
+    #
+    # 0x8004667e is FIONBIO
+    # By default all sockets are blocking
+
+    return !${*$sock}{io_sock_nonblocking}
+        unless @_;
+
+    my $block = shift;
+
+    ${*$sock}{io_sock_nonblocking} = $block ? "0" : "1";
+
+    return ioctl($sock, 0x8004667e, \${*$sock}{io_sock_nonblocking});
+}
+
+
 sub close {
     @_ == 1 or croak 'usage: $sock->close()';
     my $sock = shift;
diff --git a/ext/IO/t/io_multihomed.t b/ext/IO/t/io_multihomed.t
index 3c8c4a6723..d9355cf424 100644
--- a/ext/IO/t/io_multihomed.t
+++ b/ext/IO/t/io_multihomed.t
@@ -17,8 +17,15 @@ BEGIN {
     elsif ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bIO\b/) {
 	$reason = 'IO extension unavailable';
     }
-    elsif (! $Config{'d_fork'}) {
-	$reason = 'no fork';
+    elsif (
+        ! eval {
+            my $pid= fork();
+            ! defined($pid) and die "Fork failed!";
+            ! $pid and exit;
+            defined waitpid($pid, 0);
+        }
+    ) {
+        $reason = "no fork: $@";
     }
     if ($reason) {
 	print "1..0 # Skip: $reason\n";
diff --git a/ext/IO/t/io_pipe.t b/ext/IO/t/io_pipe.t
index 7a45a7c298..9b7d6f401a 100755
--- a/ext/IO/t/io_pipe.t
+++ b/ext/IO/t/io_pipe.t
@@ -20,8 +20,18 @@ BEGIN {
     if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bIO\b/) {
 	$reason = 'IO extension unavailable';
     }
-    elsif (! $Config{'d_fork'}) {
-	$reason = 'no fork';
+    elsif (
+        ! eval {
+            my $pid= fork();
+            ! defined($pid) and die "Fork failed!";
+            ! $pid and exit;
+            defined waitpid($pid, 0);
+        }
+    ) {
+        $reason = "no fork: $@";
+    }
+    elsif ($^O eq 'MSWin32' && !$ENV{TEST_IO_PIPE}) {
+	$reason = 'Win32 testing environment not set';
     }
     if ($reason) {
 	print "1..0 # Skip: $reason\n";
@@ -31,23 +41,27 @@ BEGIN {
 
 use IO::Pipe;
 
+my $is_win32=$^O eq 'MSWin32' ? "MSWin32 has broken pipes" : "";
 
 $| = 1;
 print "1..10\n";
 
-$pipe = new IO::Pipe->reader($perl, '-e', 'print "not ok 1\n"');
-while (<$pipe>) {
-  s/^not //;
-  print;
+if ($is_win32) {
+    print "ok $_ # skipped: $is_win32\n" for 1..4;
+} else {
+    $pipe = new IO::Pipe->reader($perl, '-e', 'print qq(not ok 1)\n"');
+    while (<$pipe>) {
+      s/^not //;
+      print;
+    }
+    $pipe->close or print "# \$!=$!\nnot ";
+    print "ok 2\n";
+    $cmd = 'BEGIN{$SIG{ALRM} = sub {print qq(not ok 4\n); exit}; alarm 10} s/not //';
+    $pipe = new IO::Pipe->writer($perl, '-pe', $cmd);
+    print $pipe "not ok 3\n" ;
+    $pipe->close or print "# \$!=$!\nnot ";
+    print "ok 4\n";
 }
-$pipe->close or print "# \$!=$!\nnot ";
-print "ok 2\n";
-
-$cmd = 'BEGIN{$SIG{ALRM} = sub {print "not ok 4\n"; exit}; alarm 10} s/not //';
-$pipe = new IO::Pipe->writer($perl, '-pe', $cmd);
-print $pipe "not ok 3\n" ;
-$pipe->close or print "# \$!=$!\nnot ";
-print "ok 4\n";
 
 # Check if can fork with dynamic extensions (bug in CRT):
 if ($^O eq 'os2' and
@@ -73,17 +87,20 @@ elsif(defined $pid)
   $pipe->reader;
   $stdin = bless \*STDIN, "IO::Handle";
   $stdin->fdopen($pipe,"r");
-  exec 'tr', 'YX', 'ko';
+  exec $^X, '-pne', 'tr/YX/ko/';
  }
 else
  {
   die "# error = $!";
  }
 
-$pipe = new IO::Pipe;
-$pid = fork();
+if ($is_win32) {
+    print "ok $_ # skipped: $is_win32\n" for 7..8;
+} else {
+    $pipe = new IO::Pipe;
+    $pid = fork();
 
-if($pid)
+    if($pid)
  {
   $pipe->reader;
   while(<$pipe>) {
@@ -93,7 +110,7 @@ if($pid)
   $pipe->close;
   wait;
  }
-elsif(defined $pid)
+    elsif(defined $pid)
  {
   $pipe->writer;
 
@@ -102,24 +119,27 @@ elsif(defined $pid)
   print STDOUT "not ok 7\n";
   exec 'echo', 'not ok 8';
  }
-else
+    else
  {
   die;
  }
+}
+if ($is_win32) {
+    print "ok $_ # skipped: $is_win32\n" for 9;
+} else {
+    $pipe = new IO::Pipe;
+    $pipe->writer;
 
-$pipe = new IO::Pipe;
-$pipe->writer;
-
-$SIG{'PIPE'} = 'broken_pipe';
+    $SIG{'PIPE'} = 'broken_pipe';
 
-sub broken_pipe {
+    sub broken_pipe {
     print "ok 9\n";
-}
-
-print $pipe "not ok 9\n";
-$pipe->close;
+    }
 
-sleep 1;
+    print $pipe "not ok 9\n";
+    $pipe->close;
 
+    sleep 1;
+}
 print "ok 10\n";
 
diff --git a/ext/IO/t/io_sock.t b/ext/IO/t/io_sock.t
index c7a7ccf235..b743bf0700 100755
--- a/ext/IO/t/io_sock.t
+++ b/ext/IO/t/io_sock.t
@@ -17,8 +17,15 @@ BEGIN {
     elsif ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bIO\b/) {
 	$reason = 'IO extension unavailable';
     }
-    elsif (! $Config{'d_fork'}) {
-	$reason = 'no fork';
+    elsif (
+        ! eval {
+            my $pid= fork();
+            ! defined($pid) and die "Fork failed!";
+            ! $pid and exit;
+            defined waitpid($pid, 0);
+        }
+    ) {
+        $reason = "no fork: $@";
     }
     if ($reason) {
 	print "1..0 # Skip: $reason\n";
diff --git a/ext/IO/t/io_unix.t b/ext/IO/t/io_unix.t
index 21b8a904a2..6d77062a64 100644
--- a/ext/IO/t/io_unix.t
+++ b/ext/IO/t/io_unix.t
@@ -24,8 +24,8 @@ BEGIN {
 	  or $@ !~ /not implemented/ or
 	    $reason = 'compiled without TCP/IP stack v4';
     }
-    elsif ($^O =~ m/^(?:qnx|nto|vos)$/ ) {
-	$reason = 'Not implemented';
+    elsif ($^O =~ m/^(?:qnx|nto|vos|MSWin32)$/ ) {
+	$reason = "UNIX domain sockets not implemented on $^O";
     }
     elsif (! $Config{'d_fork'}) {
 	$reason = 'no fork';