1#!./perl -w 2 3use v5.6.1; 4use strict; 5use warnings; 6 7my $child; 8my $can_fork; 9my $has_perlio; 10 11our %Config; 12BEGIN { 13 require Config; import Config; 14 $can_fork = $Config{'d_fork'} || $Config{'d_pseudofork'}; 15 16 if ($^O eq "hpux" or $Config{'extensions'} !~ /\bSocket\b/ && 17 !(($^O eq 'VMS') && $Config{d_socket})) { 18 print "1..0\n"; 19 exit 0; 20 } 21} 22 23{ 24 # This was in the BEGIN block, but since Test::More 0.47 added support to 25 # detect forking, we don't need to fork before Test::More initialises. 26 27 # Too many things in this test will hang forever if something is wrong, 28 # so we need a self destruct timer. And IO can hang despite an alarm. 29 30 if( $can_fork) { 31 my $parent = $$; 32 $child = fork; 33 die "Fork failed" unless defined $child; 34 if (!$child) { 35 $SIG{INT} = sub {exit 0}; # You have 60 seconds. Your time starts now. 36 my $must_finish_by = time + 60; 37 my $remaining; 38 while (($remaining = $must_finish_by - time) > 0) { 39 sleep $remaining; 40 } 41 warn "Something unexpectedly hung during testing"; 42 kill "INT", $parent or die "Kill failed: $!"; 43 if( $^O eq "cygwin" ) { 44 # sometimes the above isn't enough on cygwin 45 sleep 1; # wait a little, it might have worked after all 46 system( "/bin/kill -f $parent; echo die $parent" ); 47 } 48 exit 1; 49 } 50 } 51 unless ($has_perlio = PerlIO::Layer->can("find") && PerlIO::Layer->find('perlio')) { 52 print <<EOF; 53# Since you don't have perlio you might get failures with UTF-8 locales. 54EOF 55 } 56} 57 58use Socket; 59use Test::More; 60use strict; 61use warnings; 62use Errno; 63 64my $skip_reason; 65 66if( !$Config{d_alarm} ) { 67 plan skip_all => "alarm() not implemented on this platform"; 68} elsif( !$can_fork ) { 69 plan skip_all => "fork() not implemented on this platform"; 70} else { 71 my ($lefth, $righth); 72 # This should fail but not die if there is real socketpair 73 eval {socketpair $lefth, $righth, -1, -1, -1}; 74 if ($@ =~ /^Unsupported socket function "socketpair" called/ || 75 $! =~ /^The operation requested is not supported./) { # Stratus VOS 76 plan skip_all => 'No socketpair (real or emulated)'; 77 } else { 78 eval {AF_UNIX}; 79 if ($@ =~ /^Your vendor has not defined Socket macro AF_UNIX/) { 80 plan skip_all => 'No AF_UNIX'; 81 } else { 82 plan tests => 45; 83 } 84 } 85} 86 87# But we'll install an alarm handler in case any of the races below fail. 88$SIG{ALRM} = sub {die "Unexpected alarm during testing"}; 89 90my @left = ("hello ", "world\n"); 91my @right = ("perl ", "rules!"); # Not like I'm trying to bias any survey here. 92 93my @gripping = (chr 255, chr 127); 94 95{ 96 my ($lefth, $righth); 97 98 ok (socketpair ($lefth, $righth, AF_UNIX, SOCK_STREAM, PF_UNSPEC), 99 "socketpair (\$lefth, \$righth, AF_UNIX, SOCK_STREAM, PF_UNSPEC)") 100 or print STDERR "# \$\! = $!\n"; 101 102 if ($has_perlio) { 103 binmode($lefth, ":bytes"); 104 binmode($righth, ":bytes"); 105 } 106 107 foreach (@left) { 108 # is (syswrite ($lefth, $_), length $_, "write " . _qq ($_) . " to left"); 109 is (syswrite ($lefth, $_), length $_, "syswrite to left"); 110 } 111 foreach (@right) { 112 # is (syswrite ($righth, $_), length $_, "write " . _qq ($_) . " to right"); 113 is (syswrite ($righth, $_), length $_, "syswrite to right"); 114 } 115 116 # stream socket, so our writes will become joined: 117 my ($buffer, $expect); 118 $expect = join '', @right; 119 undef $buffer; 120 is (read ($lefth, $buffer, length $expect), length $expect, "read on left"); 121 is ($buffer, $expect, "content what we expected?"); 122 $expect = join '', @left; 123 undef $buffer; 124 is (read ($righth, $buffer, length $expect), length $expect, "read on right"); 125 is ($buffer, $expect, "content what we expected?"); 126 127 ok (shutdown($lefth, SHUT_WR), "shutdown left for writing"); 128 # This will hang forever if eof is buggy, and alarm doesn't interrupt system 129 # Calls. Hence the child process minder. 130 SKIP: { 131 skip "SCO Unixware / OSR have a bug with shutdown",2 if $^O =~ /^(?:svr|sco)/; 132 local $SIG{ALRM} = sub { warn "EOF on right took over 3 seconds" }; 133 local $TODO = "Known problems with unix sockets on $^O" 134 if $^O eq 'hpux' || $^O eq 'super-ux'; 135 alarm 3; 136 $! = 0; 137 ok (eof $righth, "right is at EOF"); 138 local $TODO = "Known problems with unix sockets on $^O" 139 if $^O eq 'unicos' || $^O eq 'unicosmk'; 140 is ($!, '', 'and $! should report no error'); 141 alarm 60; 142 } 143 144 my $err = $!; 145 $SIG{PIPE} = 'IGNORE'; 146 { 147 local $SIG{ALRM} = 148 sub { warn "syswrite to left didn't fail within 3 seconds" }; 149 alarm 3; 150 # Split the system call from the is() - is() does IO so 151 # (say) a flush may do a seek which on a pipe may disturb errno 152 my $ans = syswrite ($lefth, "void"); 153 $err = $!; 154 is ($ans, undef, "syswrite to shutdown left should fail"); 155 alarm 60; 156 } 157 { 158 # This may need skipping on some OSes - restoring value saved above 159 # should help 160 $! = $err; 161 ok (($!{EPIPE} or $!{ESHUTDOWN}), '$! should be EPIPE or ESHUTDOWN') 162 or printf STDERR "# \$\! = %d (%s)\n", $err, $err; 163 } 164 165 foreach (@gripping) { 166 is (syswrite ($righth, $_), length $_, "syswrite to right"); 167 } 168 169 ok (!eof $lefth, "left is not at EOF"); 170 171 $expect = join '', @gripping; 172 undef $buffer; 173 is (read ($lefth, $buffer, length $expect), length $expect, "read on left"); 174 is ($buffer, $expect, "content what we expected?"); 175 176 ok (close $lefth, "close left"); 177 ok (close $righth, "close right"); 178} 179 180 181# And now datagrams 182# I suspect we also need a self destruct time-bomb for these, as I don't see any 183# guarantee that the stack won't drop a UDP packet, even if it is for localhost. 184 185SKIP: { 186 skip "alarm doesn't interrupt I/O on this Perl", 24 if "$]" < 5.008; 187 188 my $success = socketpair my $lefth, my $righth, AF_UNIX, SOCK_DGRAM, PF_UNSPEC; 189 190 skip "No useable SOCK_DGRAM for socketpair", 24 if !$success and 191 ($!{EAFNOSUPPORT} or $!{EOPNOTSUPP} or $!{EPROTONOSUPPORT} or $!{EPROTOTYPE}); 192 # Maybe this test is redundant now? 193 skip "No usable SOCK_DGRAM for socketpair", 24 if ($^O =~ /^(MSWin32|os2)\z/); 194 local $TODO = "socketpair not supported on $^O" if $^O eq 'nto'; 195 196 ok ($success, "socketpair (\$left, \$righth, AF_UNIX, SOCK_DGRAM, PF_UNSPEC)") 197 or print STDERR "# \$\! = $!\n"; 198 199 if ($has_perlio) { 200 binmode($lefth, ":bytes"); 201 binmode($righth, ":bytes"); 202 } 203 204 foreach (@left) { 205 # is (syswrite ($lefth, $_), length $_, "write " . _qq ($_) . " to left"); 206 is (syswrite ($lefth, $_), length $_, "syswrite to left"); 207 } 208 foreach (@right) { 209 # is (syswrite ($righth, $_), length $_, "write " . _qq ($_) . " to right"); 210 is (syswrite ($righth, $_), length $_, "syswrite to right"); 211 } 212 213 # stream socket, so our writes will become joined: 214 my ($total, $buffer); 215 $total = join '', @right; 216 foreach my $expect (@right) { 217 undef $buffer; 218 is (sysread ($lefth, $buffer, length $total), length $expect, "read on left"); 219 is ($buffer, $expect, "content what we expected?"); 220 } 221 $total = join '', @left; 222 foreach my $expect (@left) { 223 undef $buffer; 224 is (sysread ($righth, $buffer, length $total), length $expect, "read on right"); 225 is ($buffer, $expect, "content what we expected?"); 226 } 227 228 ok (shutdown($lefth, 1), "shutdown left for writing"); 229 230 # eof uses buffering. eof is indicated by a sysread of zero. 231 # but for a datagram socket there's no way it can know nothing will ever be 232 # sent 233 SKIP: { 234 skip "$^O does length 0 udp reads", 2 if ($^O eq 'os390'); 235 236 my $alarmed = 0; 237 local $SIG{ALRM} = sub { $alarmed = 1; }; 238 print "# Approximate forever as 3 seconds. Wait 'forever'...\n"; 239 alarm 3; 240 undef $buffer; 241 is (sysread ($righth, $buffer, 1), undef, 242 "read on right should be interrupted"); 243 is ($alarmed, 1, "alarm should have fired"); 244 } 245 246 alarm 30; 247 248 foreach (@gripping) { 249 is (syswrite ($righth, $_), length $_, "syswrite to right"); 250 } 251 252 $total = join '', @gripping; 253 foreach my $expect (@gripping) { 254 undef $buffer; 255 is (sysread ($lefth, $buffer, length $total), length $expect, "read on left"); 256 is ($buffer, $expect, "content what we expected?"); 257 } 258 259 ok (close $lefth, "close left"); 260 ok (close $righth, "close right"); 261 262} # end of DGRAM SKIP 263 264kill "INT", $child or warn "Failed to kill child process $child: $!"; 265exit 0; 266