Test::Harness 2.22 -> 2.23

[p5sagit/p5-mst-13.2.git] / ext / Socket / socketpair.t

diff --git a/ext/Socket/socketpair.t b/ext/Socket/socketpair.t
index 639606a..fea1cb5 100644 (file)
--- a/ext/Socket/socketpair.t
+++ b/ext/Socket/socketpair.t
@@ -2,14 +2,18 @@
 
 my $child;
 my $can_fork;
+my $has_perlio;
 
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require Config; import Config;
-    $can_fork = $Config{d_fork} || ($^O eq 'MSWin32' && $Config{useithreads});
+    $can_fork = $Config{'d_fork'}
+               || ($^O eq 'MSWin32' && $Config{useithreads}
+                   && $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS\b/);
 
-    if ($^O eq "hpux" or $Config{'extensions'} !~ /\bSocket\b/ && 
+
+    if ($^O eq "hpux" or $Config{'extensions'} !~ /\bSocket\b/ &&
         !(($^O eq 'VMS') && $Config{d_socket})) {
        print "1..0\n";
        exit 0;
@@ -29,7 +33,7 @@ BEGIN {
         $SIG{INT} = sub {exit 0}; # You have 60 seconds. Your time starts now.
         my $must_finish_by = time + 60;
         my $remaining;
-        while ($remaining = time - $must_finish_by) {
+        while (($remaining = $must_finish_by - time) > 0) {
           sleep $remaining;
         }
         warn "Something unexpectedly hung during testing";
@@ -37,6 +41,11 @@ BEGIN {
         exit 1;
       }
     }
+    unless ($has_perlio = find PerlIO::Layer 'perlio') {
+       print <<EOF;
+# Since you don't have perlio you might get failures with UTF-8 locales.
+EOF
+    }
 }
 
 use Socket;
@@ -54,7 +63,8 @@ if( !$Config{d_alarm} ) {
 } else {
   # This should fail but not die if there is real socketpair
   eval {socketpair LEFT, RIGHT, -1, -1, -1};
-  if ($@ =~ /^Unsupported socket function "socketpair" called/) {
+  if ($@ =~ /^Unsupported socket function "socketpair" called/ ||
+      $! =~ /^The operation requested is not supported./) { # Stratus VOS
     plan skip_all => 'No socketpair (real or emulated)';
   } else {
     eval {AF_UNIX};
@@ -73,6 +83,11 @@ ok (socketpair (LEFT, RIGHT, AF_UNIX, SOCK_STREAM, PF_UNSPEC),
     "socketpair (LEFT, RIGHT, AF_UNIX, SOCK_STREAM, PF_UNSPEC)")
   or print "# \$\! = $!\n";
 
+if ($has_perlio) {
+    binmode(LEFT,  ":bytes");
+    binmode(RIGHT, ":bytes");
+}
+
 my @left = ("hello ", "world\n");
 my @right = ("perl ", "rules!"); # Not like I'm trying to bias any survey here.
 
@@ -102,7 +117,7 @@ ok (shutdown(LEFT, SHUT_WR), "shutdown left for writing");
 {
   local $SIG{ALRM} = sub { warn "EOF on right took over 3 seconds" };
   local $TODO = "Known problems with unix sockets on $^O"
-      if $^O eq 'hpux' || $^O eq 'unicosmk';
+      if $^O eq 'hpux' || $^O eq 'super-ux' || $^O eq 'unicosmk';
   alarm 3;
   $! = 0;
   ok (eof RIGHT, "right is at EOF");
@@ -110,18 +125,25 @@ ok (shutdown(LEFT, SHUT_WR), "shutdown left for writing");
   alarm 60;
 }
 
+my $err = $!;
 $SIG{PIPE} = 'IGNORE';
 {
   local $SIG{ALRM}
     = sub { warn "syswrite to left didn't fail within 3 seconds" };
   alarm 3;
-  is (syswrite (LEFT, "void"), undef, "syswrite to shutdown left should fail");
+  # Split the system call from the is() - is() does IO so
+  # (say) a flush may do a seek which on a pipe may disturb errno
+  my $ans = syswrite (LEFT, "void");
+  $err = $!;
+  is ($ans, undef, "syswrite to shutdown left should fail");
   alarm 60;
 }
 {
-  # This may need skipping on some OSes
+  # This may need skipping on some OSes - restoring value saved above
+  # should help
+  $! = $err;
   ok (($!{EPIPE} or $!{ESHUTDOWN}), '$! should be EPIPE or ESHUTDOWN')
-    or printf "\$\!=%d(%s)\n", $!, $!;
+    or printf "\$\!=%d(%s)\n", $err, $err;
 }
 
 my @gripping = (chr 255, chr 127);
@@ -145,13 +167,18 @@ ok (close RIGHT, "close right");
 # guarantee that the stack won't drop a UDP packet, even if it is for localhost.
 
 SKIP: {
-  skip "No usable SOCK_DGRAM", 24 if ($^O eq 'MSWin32');
-
+  skip "No usable SOCK_DGRAM for socketpair", 24 if ($^O =~ /^(MSWin32|os2)\z/);
+  local $TODO = "socketpair not supported on $^O" if $^O eq 'nto';
 
 ok (socketpair (LEFT, RIGHT, AF_UNIX, SOCK_DGRAM, PF_UNSPEC),
     "socketpair (LEFT, RIGHT, AF_UNIX, SOCK_DGRAM, PF_UNSPEC)")
   or print "# \$\! = $!\n";
 
+if ($has_perlio) {
+    binmode(LEFT,  ":bytes");
+    binmode(RIGHT, ":bytes");
+}
+
 foreach (@left) {
   # is (syswrite (LEFT, $_), length $_, "write " . _qq ($_) . " to left");
   is (syswrite (LEFT, $_), length $_, "syswrite to left");
@@ -177,10 +204,13 @@ foreach $expect (@left) {
 }
 
 ok (shutdown(LEFT, 1), "shutdown left for writing");
+
 # eof uses buffering. eof is indicated by a sysread of zero.
 # but for a datagram socket there's no way it can know nothing will ever be
 # sent
-{
+SKIP: {
+  skip "$^O does length 0 udp reads", 2 if ($^O eq 'os390');
+
   my $alarmed = 0;
   local $SIG{ALRM} = sub { $alarmed = 1; };
   print "# Approximate forever as 3 seconds. Wait 'forever'...\n";
@@ -190,6 +220,7 @@ ok (shutdown(LEFT, 1), "shutdown left for writing");
       "read on right should be interrupted");
   is ($alarmed, 1, "alarm should have fired");
 }
+
 alarm 30;
 
 #ok (eof RIGHT, "right is at EOF");