1#!perl
2
3# sanity tests for socket functions
4
5BEGIN {
6    chdir 't' if -d 't';
7
8    require "./test.pl";
9    set_up_inc( '../lib' ) if -d '../lib' && -d '../ext';
10    require Config; import Config;
11
12    skip_all_if_miniperl();
13    for my $needed (qw(d_socket d_getpbyname)) {
14	if ($Config{$needed} ne 'define') {
15	    skip_all("-- \$Config{$needed} undefined");
16	}
17    }
18    unless ($Config{extensions} =~ /\bSocket\b/) {
19	skip_all('-- Socket not available');
20    }
21}
22
23use strict;
24use Socket;
25
26our $TODO;
27
28$| = 1; # ensure test output is synchronous so processes don't conflict
29
30my $tcp = getprotobyname('tcp')
31    or skip_all("no tcp protocol available ($!)");
32my $udp = getprotobyname('udp')
33    or note "getprotobyname('udp') failed: $!";
34
35my $local = gethostbyname('localhost')
36    or note "gethostbyname('localhost') failed: $!";
37
38my $fork = $Config{d_fork} || $Config{d_pseudofork};
39
40{
41    # basic socket creation
42    socket(my $sock, PF_INET, SOCK_STREAM, $tcp)
43	or skip_all('socket() for tcp failed ($!), nothing else will work');
44    ok(close($sock), "close the socket");
45}
46
47SKIP:
48{
49    $udp
50        or skip "No udp", 1;
51    # [perl #133853] failed socket creation didn't set error
52    # for bad parameters on Win32
53    $! = 0;
54    socket(my $sock, PF_INET, SOCK_STREAM, $udp)
55        and skip "managed to make a UDP stream socket", 1;
56    ok(0+$!, "error set on failed socket()");
57}
58
59SKIP: {
60    # test it all in TCP
61    $local or skip("No localhost", 3);
62
63    ok(socket(my $serv, PF_INET, SOCK_STREAM, $tcp), "make a tcp socket");
64    my $bind_at = pack_sockaddr_in(0, $local);
65    ok(bind($serv, $bind_at), "bind works")
66	or skip("Couldn't bind to localhost", 4);
67    my $bind_name = getsockname($serv);
68    ok($bind_name, "getsockname() on bound socket");
69    my ($bind_port) = unpack_sockaddr_in($bind_name);
70
71    print "# port $bind_port\n";
72
73  SKIP:
74    {
75	ok(listen($serv, 5), "listen() works")
76	  or diag "listen error: $!";
77
78	$fork or skip("No fork", 2);
79	my $pid = fork;
80	my $send_data = "test" x 50_000;
81	if ($pid) {
82	    # parent
83	    ok(socket(my $accept, PF_INET, SOCK_STREAM, $tcp),
84	       "make accept tcp socket");
85	    ok(my $addr = accept($accept, $serv), "accept() works")
86		or diag "accept error: $!";
87            binmode $accept;
88	    SKIP: {
89		skip "no fcntl", 1 unless $Config{d_fcntl};
90		my $acceptfd = fileno($accept);
91		fresh_perl_is(qq(
92		    print open(F, "+<&=$acceptfd") ? 1 : 0, "\\n";
93		), "0\n", {}, "accepted socket not inherited across exec");
94	    }
95	    my $sent_total = 0;
96	    while ($sent_total < length $send_data) {
97		my $sent = send($accept, substr($send_data, $sent_total), 0);
98		defined $sent or last;
99		$sent_total += $sent;
100	    }
101	    my $shutdown = shutdown($accept, 1);
102
103	    # wait for the remote to close so data isn't lost in
104	    # transit on a certain broken implementation
105	    <$accept>;
106	    # child tests are printed once we hit eof
107	    curr_test(curr_test()+5);
108	    waitpid($pid, 0);
109
110	    ok($shutdown, "shutdown() works");
111	}
112	elsif (defined $pid) {
113	    curr_test(curr_test()+3);
114	    #sleep 1;
115	    # child
116	    ok_child(close($serv), "close server socket in child");
117	    ok_child(socket(my $child, PF_INET, SOCK_STREAM, $tcp),
118	       "make child tcp socket");
119
120	    ok_child(connect($child, $bind_name), "connect() works")
121		or diag "connect error: $!";
122            binmode $child;
123	    my $buf;
124	    my $recv_peer = recv($child, $buf, 1000, 0);
125	    {
126        local $TODO = "[perl #122657] Hurd doesn't populate sin_len correctly"
127		    if $^O eq "gnu";
128		# [perl #118843]
129		ok_child($recv_peer eq '' || $recv_peer eq getpeername $child,
130			 "peer from recv() should be empty or the remote name");
131	    }
132	    while(defined recv($child, my $tmp, 1000, 0)) {
133		last if length $tmp == 0;
134		$buf .= $tmp;
135	    }
136	    is_child($buf, $send_data, "check we received the data");
137	    close($child);
138	    end_child();
139
140	    exit(0);
141	}
142	else {
143	    # failed to fork
144	    diag "fork() failed $!";
145	    skip("fork() failed", 2);
146	}
147    }
148}
149
150SKIP: {
151    # test recv/send handling with :utf8
152    # this doesn't appear to have been tested previously, this is
153    # separate to avoid interfering with the data expected above
154    $local or skip("No localhost", 1);
155    $fork or skip("No fork", 1);
156
157    note "recv/send :utf8 tests";
158    ok(socket(my $serv, PF_INET, SOCK_STREAM, $tcp), "make a tcp socket (recv/send :utf8 handling)");
159    my $bind_at = pack_sockaddr_in(0, $local);
160    ok(bind($serv, $bind_at), "bind works")
161	or skip("Couldn't bind to localhost", 1);
162    my $bind_name = getsockname($serv);
163    ok($bind_name, "getsockname() on bound socket");
164    my ($bind_port) = unpack_sockaddr_in($bind_name);
165
166    print "# port $bind_port\n";
167
168  SKIP:
169    {
170	ok(listen($serv, 5), "listen() works")
171	  or diag "listen error: $!";
172
173	my $pid = fork;
174	my $send_data = "test\x80\xFF" x 50_000;
175	if ($pid) {
176	    # parent
177	    ok(socket(my $accept, PF_INET, SOCK_STREAM, $tcp),
178	       "make accept tcp socket");
179	    ok(my $addr = accept($accept, $serv), "accept() works")
180		or diag "accept error: $!";
181            binmode $accept, ':raw:utf8';
182            ok(!eval { send($accept, "ABC", 0); 1 },
183               "should die on send to :utf8 socket");
184            binmode $accept;
185            # check bytes will be sent
186            utf8::upgrade($send_data);
187	    my $sent_total = 0;
188	    while ($sent_total < length $send_data) {
189		my $sent = send($accept, substr($send_data, $sent_total), 0);
190		defined $sent or last;
191		$sent_total += $sent;
192	    }
193	    my $shutdown = shutdown($accept, 1);
194
195	    # wait for the remote to close so data isn't lost in
196	    # transit on a certain broken implementation
197	    <$accept>;
198	    # child tests are printed once we hit eof
199	    curr_test(curr_test()+6);
200	    waitpid($pid, 0);
201
202	    ok($shutdown, "shutdown() works");
203	}
204	elsif (defined $pid) {
205	    curr_test(curr_test()+3);
206	    #sleep 1;
207	    # child
208	    ok_child(close($serv), "close server socket in child");
209	    ok_child(socket(my $child, PF_INET, SOCK_STREAM, $tcp),
210	       "make child tcp socket");
211
212	    ok_child(connect($child, $bind_name), "connect() works")
213		or diag "connect error: $!";
214            binmode $child, ':raw:utf8';
215	    my $buf;
216
217            ok_child(!eval { recv($child, $buf, 1000, 0); 1 },
218                     "recv on :utf8 should die");
219            is_child($buf, "", "buf shouldn't contain anything");
220            binmode $child;
221	    my $recv_peer = recv($child, $buf, 1000, 0);
222	    while(defined recv($child, my $tmp, 1000, 0)) {
223		last if length $tmp == 0;
224		$buf .= $tmp;
225	    }
226	    is_child($buf, $send_data, "check we received the data");
227	    close($child);
228	    end_child();
229
230	    exit(0);
231	}
232	else {
233	    # failed to fork
234	    diag "fork() failed $!";
235	    skip("fork() failed", 2);
236	}
237    }
238}
239
240SKIP:
241{
242    eval { require Errno; defined &Errno::EMFILE }
243      or skip "Can't load Errno or EMFILE not defined", 1;
244    # stdio might return strange values in errno if it runs
245    # out of FILE entries, and does on darwin
246    $^O eq "darwin" && exists $ENV{PERLIO} && $ENV{PERLIO} =~ /stdio/
247      and skip "errno values from stdio are unspecified", 1;
248    my @socks;
249    my $sock_limit = 1000; # don't consume every file in the system
250    # Default limits on various systems I have:
251    #  65536 - Linux
252    #    256 - Solaris
253    #    128 - NetBSD
254    #    256 - Cygwin
255    #    256 - darwin
256    while (@socks < $sock_limit) {
257        socket my $work, PF_INET, SOCK_STREAM, $tcp
258          or last;
259        push @socks, $work;
260    }
261    @socks == $sock_limit
262      and skip "Didn't run out of open handles", 1;
263    is(0+$!, Errno::EMFILE(), "check correct errno for too many files");
264}
265
266{
267    my $sock;
268    my $proto = getprotobyname('tcp');
269    socket($sock, PF_INET, SOCK_STREAM, $proto);
270    accept($sock, $sock);
271    ok('RT #7614: still alive after accept($sock, $sock)');
272}
273
274SKIP: {
275    skip "no fcntl", 1 unless $Config{d_fcntl};
276    my $sock;
277    socket($sock, PF_INET, SOCK_STREAM, $tcp) or die "socket: $!";
278    my $sockfd = fileno($sock);
279    fresh_perl_is(qq(
280	print open(F, "+<&=$sockfd") ? 1 : 0, "\\n";
281    ), "0\n", {}, "fresh socket not inherited across exec");
282}
283
284done_testing();
285
286my @child_tests;
287sub ok_child {
288    my ($ok, $note) = @_;
289    push @child_tests, ( $ok ? "ok " : "not ok ") . curr_test() . " - $note "
290	. ( $TODO ? "# TODO $TODO" : "" ) . "\n";
291    curr_test(curr_test()+1);
292}
293
294sub is_child {
295    my ($got, $want, $note) = @_;
296    ok_child($got eq $want, $note);
297}
298
299sub end_child {
300    print @child_tests;
301}
302
303