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