Commit | Line | Data |
---|---|---|
02fc2eee NC |
1 | #!./perl -w |
2 | ||
8bb05de3 N |
3 | use v5.6.1; |
4 | use strict; | |
5 | use warnings; | |
6 | ||
b4023995 | 7 | my $child; |
26bf1728 | 8 | my $can_fork; |
47520729 | 9 | my $has_perlio; |
b4023995 | 10 | |
8bb05de3 | 11 | our %Config; |
02fc2eee | 12 | BEGIN { |
02fc2eee | 13 | require Config; import Config; |
2b09c5a8 | 14 | $can_fork = $Config{'d_fork'} || $Config{'d_pseudofork'}; |
26bf1728 | 15 | |
b5d2fea7 | 16 | if ($^O eq "hpux" or $Config{'extensions'} !~ /\bSocket\b/ && |
02fc2eee | 17 | !(($^O eq 'VMS') && $Config{d_socket})) { |
1004cf1c SH |
18 | print "1..0\n"; |
19 | exit 0; | |
2b09c5a8 | 20 | } |
850d6073 NC |
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. | |
b4023995 NC |
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 | ||
26bf1728 | 30 | if( $can_fork) { |
1004cf1c SH |
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 | } | |
02fc2eee | 50 | } |
9dea6244 | 51 | unless ($has_perlio = PerlIO::Layer->can("find") && PerlIO::Layer->find('perlio')) { |
1004cf1c | 52 | print <<EOF; |
47520729 JH |
53 | # Since you don't have perlio you might get failures with UTF-8 locales. |
54 | EOF | |
55 | } | |
02fc2eee | 56 | } |
b4023995 | 57 | |
02fc2eee NC |
58 | use Socket; |
59 | use Test::More; | |
60 | use strict; | |
61 | use warnings; | |
5ec8c883 | 62 | use Errno; |
02fc2eee NC |
63 | |
64 | my $skip_reason; | |
65 | ||
66 | if( !$Config{d_alarm} ) { | |
c2654555 | 67 | plan skip_all => "alarm() not implemented on this platform"; |
26bf1728 | 68 | } elsif( !$can_fork ) { |
c2654555 | 69 | plan skip_all => "fork() not implemented on this platform"; |
02fc2eee | 70 | } else { |
b1846e36 | 71 | my ($lefth, $righth); |
c2654555 | 72 | # This should fail but not die if there is real socketpair |
b1846e36 | 73 | eval {socketpair $lefth, $righth, -1, -1, -1}; |
c2654555 | 74 | if ($@ =~ /^Unsupported socket function "socketpair" called/ || |
1004cf1c SH |
75 | $! =~ /^The operation requested is not supported./) { # Stratus VOS |
76 | plan skip_all => 'No socketpair (real or emulated)'; | |
02fc2eee | 77 | } else { |
1004cf1c SH |
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 | } | |
02fc2eee | 84 | } |
02fc2eee NC |
85 | } |
86 | ||
b4023995 NC |
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"}; | |
02fc2eee | 89 | |
02fc2eee NC |
90 | my @left = ("hello ", "world\n"); |
91 | my @right = ("perl ", "rules!"); # Not like I'm trying to bias any survey here. | |
92 | ||
b1846e36 | 93 | my @gripping = (chr 255, chr 127); |
c5f49a01 | 94 | |
26bf1728 | 95 | { |
b1846e36 | 96 | my ($lefth, $righth); |
02fc2eee | 97 | |
b1846e36 | 98 | ok (socketpair ($lefth, $righth, AF_UNIX, SOCK_STREAM, PF_UNSPEC), |
1004cf1c SH |
99 | "socketpair (\$lefth, \$righth, AF_UNIX, SOCK_STREAM, PF_UNSPEC)") |
100 | or print STDERR "# \$\! = $!\n"; | |
b1846e36 RL |
101 | |
102 | if ($has_perlio) { | |
1004cf1c SH |
103 | binmode($lefth, ":bytes"); |
104 | binmode($righth, ":bytes"); | |
b1846e36 RL |
105 | } |
106 | ||
107 | foreach (@left) { | |
1004cf1c SH |
108 | # is (syswrite ($lefth, $_), length $_, "write " . _qq ($_) . " to left"); |
109 | is (syswrite ($lefth, $_), length $_, "syswrite to left"); | |
b1846e36 RL |
110 | } |
111 | foreach (@right) { | |
1004cf1c SH |
112 | # is (syswrite ($righth, $_), length $_, "write " . _qq ($_) . " to right"); |
113 | is (syswrite ($righth, $_), length $_, "syswrite to right"); | |
b1846e36 RL |
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: { | |
1004cf1c SH |
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; | |
b1846e36 RL |
142 | } |
143 | ||
144 | my $err = $!; | |
145 | $SIG{PIPE} = 'IGNORE'; | |
146 | { | |
1004cf1c SH |
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; | |
b1846e36 RL |
156 | } |
157 | { | |
1004cf1c SH |
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; | |
b1846e36 RL |
163 | } |
164 | ||
165 | foreach (@gripping) { | |
1004cf1c | 166 | is (syswrite ($righth, $_), length $_, "syswrite to right"); |
b1846e36 | 167 | } |
02fc2eee | 168 | |
b1846e36 | 169 | ok (!eof $lefth, "left is not at EOF"); |
02fc2eee | 170 | |
b1846e36 RL |
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?"); | |
02fc2eee | 175 | |
b1846e36 RL |
176 | ok (close $lefth, "close left"); |
177 | ok (close $righth, "close right"); | |
178 | } | |
02fc2eee | 179 | |
26bf1728 | 180 | |
02fc2eee NC |
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 | ||
26bf1728 | 185 | SKIP: { |
9dea6244 | 186 | skip "alarm doesn't interrupt I/O on this Perl", 24 if "$]" < 5.008; |
b1846e36 RL |
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 | |
1004cf1c | 191 | ($!{EAFNOSUPPORT} or $!{EOPNOTSUPP} or $!{EPROTONOSUPPORT} or $!{EPROTOTYPE}); |
b1846e36 RL |
192 | # Maybe this test is redundant now? |
193 | skip "No usable SOCK_DGRAM for socketpair", 24 if ($^O =~ /^(MSWin32|os2)\z/); | |
c2654555 | 194 | local $TODO = "socketpair not supported on $^O" if $^O eq 'nto'; |
26bf1728 | 195 | |
b1846e36 | 196 | ok ($success, "socketpair (\$left, \$righth, AF_UNIX, SOCK_DGRAM, PF_UNSPEC)") |
1004cf1c | 197 | or print STDERR "# \$\! = $!\n"; |
02fc2eee | 198 | |
c2654555 | 199 | if ($has_perlio) { |
1004cf1c SH |
200 | binmode($lefth, ":bytes"); |
201 | binmode($righth, ":bytes"); | |
c2654555 | 202 | } |
02fc2eee | 203 | |
c2654555 | 204 | foreach (@left) { |
1004cf1c SH |
205 | # is (syswrite ($lefth, $_), length $_, "write " . _qq ($_) . " to left"); |
206 | is (syswrite ($lefth, $_), length $_, "syswrite to left"); | |
c2654555 CBW |
207 | } |
208 | foreach (@right) { | |
1004cf1c SH |
209 | # is (syswrite ($righth, $_), length $_, "write " . _qq ($_) . " to right"); |
210 | is (syswrite ($righth, $_), length $_, "syswrite to right"); | |
c2654555 | 211 | } |
10b9e826 | 212 | |
c2654555 | 213 | # stream socket, so our writes will become joined: |
b1846e36 | 214 | my ($total, $buffer); |
c2654555 | 215 | $total = join '', @right; |
b1846e36 | 216 | foreach my $expect (@right) { |
1004cf1c SH |
217 | undef $buffer; |
218 | is (sysread ($lefth, $buffer, length $total), length $expect, "read on left"); | |
219 | is ($buffer, $expect, "content what we expected?"); | |
c2654555 CBW |
220 | } |
221 | $total = join '', @left; | |
b1846e36 | 222 | foreach my $expect (@left) { |
1004cf1c SH |
223 | undef $buffer; |
224 | is (sysread ($righth, $buffer, length $total), length $expect, "read on right"); | |
225 | is ($buffer, $expect, "content what we expected?"); | |
c2654555 | 226 | } |
10b9e826 | 227 | |
b1846e36 | 228 | ok (shutdown($lefth, 1), "shutdown left for writing"); |
c2654555 CBW |
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: { | |
1004cf1c SH |
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"); | |
c2654555 | 244 | } |
02fc2eee | 245 | |
c2654555 | 246 | alarm 30; |
02fc2eee | 247 | |
c2654555 | 248 | foreach (@gripping) { |
1004cf1c | 249 | is (syswrite ($righth, $_), length $_, "syswrite to right"); |
c2654555 | 250 | } |
02fc2eee | 251 | |
c2654555 | 252 | $total = join '', @gripping; |
b1846e36 | 253 | foreach my $expect (@gripping) { |
1004cf1c SH |
254 | undef $buffer; |
255 | is (sysread ($lefth, $buffer, length $total), length $expect, "read on left"); | |
256 | is ($buffer, $expect, "content what we expected?"); | |
c2654555 | 257 | } |
02fc2eee | 258 | |
b1846e36 RL |
259 | ok (close $lefth, "close left"); |
260 | ok (close $righth, "close right"); | |
b4023995 | 261 | |
26bf1728 NIS |
262 | } # end of DGRAM SKIP |
263 | ||
b4023995 NC |
264 | kill "INT", $child or warn "Failed to kill child process $child: $!"; |
265 | exit 0; |