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
CommitLineData
e122534c
TC
1#!perl
2
3# sanity tests for socket functions
4
5BEGIN {
6 chdir 't' if -d 't';
e122534c
TC
7
8 require "./test.pl";
624c42e2 9 set_up_inc( '../lib' ) if -d '../lib' && -d '../ext';
e122534c
TC
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
83461ff8
TR
26our $TODO;
27
e122534c
TC
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 # test it all in TCP
74df577f 49 $local or skip("No localhost", 3);
e122534c
TC
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")
74df577f 54 or skip("Couldn't bind to localhost", 4);
e122534c
TC
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
74df577f 66 $fork or skip("No fork", 2);
e122534c
TC
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: $!";
e91a8fe5 75 binmode $accept;
74df577f
Z
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 }
e122534c
TC
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) {
74df577f 101 curr_test(curr_test()+3);
e122534c
TC
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: $!";
e91a8fe5 110 binmode $child;
e122534c
TC
111 my $buf;
112 my $recv_peer = recv($child, $buf, 1000, 0);
3fdf66f3 113 {
83461ff8 114 local $TODO = "[perl #122657] Hurd doesn't populate sin_len correctly"
3fdf66f3
TC
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 }
e122534c 120 while(defined recv($child, my $tmp, 1000, 0)) {
9704d779
TC
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
138SKIP: {
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)) {
e122534c
TC
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 $!";
74df577f 223 skip("fork() failed", 2);
e122534c
TC
224 }
225 }
226}
227
3f6b66c1
TC
228SKIP:
229{
230 eval { require Errno; defined &Errno::EMFILE }
231 or skip "Can't load Errno or EMFILE not defined", 1;
428c1478
TC
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;
3f6b66c1
TC
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
c7784879
DC
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
74df577f
Z
262SKIP: {
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
e122534c
TC
272done_testing();
273
274my @child_tests;
275sub ok_child {
276 my ($ok, $note) = @_;
3fdf66f3
TC
277 push @child_tests, ( $ok ? "ok " : "not ok ") . curr_test() . " - $note "
278 . ( $TODO ? "# TODO $TODO" : "" ) . "\n";
e122534c
TC
279 curr_test(curr_test()+1);
280}
281
282sub is_child {
283 my ($got, $want, $note) = @_;
284 ok_child($got eq $want, $note);
285}
286
287sub end_child {
288 print @child_tests;
289}
c7784879 290