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