From: Yves Orton Date: Sun, 2 Apr 2006 11:07:19 +0000 (+0200) Subject: Re: Making IO::Socket pass test on Win32 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2f78ce11bc4a9355ade5d20a0825b10fbb177169;p=p5sagit%2Fp5-mst-13.2.git 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 --- diff --git a/ext/IO/lib/IO/Socket.pm b/ext/IO/lib/IO/Socket.pm index 1d7437b..fe887d4 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 3c8c4a6..d9355cf 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 7a45a7c..9b7d6f4 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 c7a7ccf..b743bf0 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 21b8a90..6d77062 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';