Commit | Line | Data |
---|---|---|
e122534c TC |
1 | #!perl |
2 | ||
3 | # sanity tests for socket functions | |
4 | ||
5 | BEGIN { | |
6 | chdir 't' if -d 't'; | |
e122534c TC |
7 | |
8 | require "./test.pl"; | |
624c42e2 | 9 | set_up_inc( '../lib' ) if -d '../lib' && -d '../ext'; |
802ca532 | 10 | require Config; Config->import; |
e122534c TC |
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 | ||
83461ff8 TR |
26 | our $TODO; |
27 | ||
e122534c TC |
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 | ||
2e51033c TC |
47 | SKIP: |
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 | ||
e122534c TC |
59 | SKIP: { |
60 | # test it all in TCP | |
74df577f | 61 | $local or skip("No localhost", 3); |
e122534c TC |
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") | |
74df577f | 66 | or skip("Couldn't bind to localhost", 4); |
e122534c TC |
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 | ||
74df577f | 78 | $fork or skip("No fork", 2); |
e122534c TC |
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: $!"; | |
e91a8fe5 | 87 | binmode $accept; |
74df577f Z |
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 | } | |
e122534c TC |
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) { | |
74df577f | 113 | curr_test(curr_test()+3); |
e122534c TC |
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: $!"; | |
e91a8fe5 | 122 | binmode $child; |
e122534c TC |
123 | my $buf; |
124 | my $recv_peer = recv($child, $buf, 1000, 0); | |
3fdf66f3 | 125 | { |
83461ff8 | 126 | local $TODO = "[perl #122657] Hurd doesn't populate sin_len correctly" |
3fdf66f3 TC |
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 | } | |
e122534c | 132 | while(defined recv($child, my $tmp, 1000, 0)) { |
9704d779 TC |
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 | ||
150 | SKIP: { | |
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)) { | |
e122534c TC |
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 $!"; | |
74df577f | 235 | skip("fork() failed", 2); |
e122534c TC |
236 | } |
237 | } | |
238 | } | |
239 | ||
3f6b66c1 TC |
240 | SKIP: |
241 | { | |
242 | eval { require Errno; defined &Errno::EMFILE } | |
243 | or skip "Can't load Errno or EMFILE not defined", 1; | |
428c1478 TC |
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; | |
3f6b66c1 TC |
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 | ||
c7784879 DC |
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 | ||
74df577f Z |
274 | SKIP: { |
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 | ||
2b96d013 TC |
284 | SKIP: |
285 | { | |
286 | my $val; | |
287 | { | |
288 | package SetsockoptMagic; | |
289 | sub TIESCALAR { bless {}, shift } | |
290 | sub FETCH { $val } | |
291 | } | |
292 | # setsockopt() magic | |
293 | socket(my $sock, PF_INET, SOCK_STREAM, $tcp); | |
294 | $val = 0; | |
295 | # set a known value | |
296 | ok(setsockopt($sock, SOL_SOCKET, SO_REUSEADDR, 1), | |
297 | "set known SO_REUSEADDR"); | |
298 | isnt(getsockopt($sock, SOL_SOCKET, SO_REUSEADDR), pack("i", 0), | |
299 | "check that worked"); | |
300 | tie my $m, "SetsockoptMagic"; | |
301 | # trigger the magic with the value 0 | |
302 | $val = pack("i", 0); | |
303 | my $temp = $m; | |
304 | ||
305 | $val = 1; | |
306 | ok(setsockopt($sock, SOL_SOCKET, SO_REUSEADDR, $m), | |
307 | "set SO_REUSEADDR from magic"); | |
308 | isnt(getsockopt($sock, SOL_SOCKET, SO_REUSEADDR), pack("i", 0), | |
309 | "check SO_REUSEADDR set correctly"); | |
b0460627 TK |
310 | |
311 | # test whether boolean value treated as a number | |
312 | ok(setsockopt($sock, SOL_SOCKET, SO_REUSEADDR, !1), | |
313 | "clear SO_REUSEADDR by a boolean false"); | |
314 | is(getsockopt($sock, SOL_SOCKET, SO_REUSEADDR), pack("i", 0), | |
315 | "check SO_REUSEADDR cleared correctly"); | |
316 | ok(setsockopt($sock, SOL_SOCKET, SO_REUSEADDR, !0), | |
317 | "set SO_REUSEADDR by a boolean true"); | |
318 | isnt(getsockopt($sock, SOL_SOCKET, SO_REUSEADDR), pack("i", 0), | |
319 | "check SO_REUSEADDR set correctly"); | |
2b96d013 TC |
320 | } |
321 | ||
0cb18e02 TK |
322 | # GH #18642 - test whether setsockopt works with a numeric OPTVAL which also |
323 | # has a cached stringified value | |
324 | SKIP: { | |
325 | defined(my $IPPROTO_IP = eval { Socket::IPPROTO_IP() }) | |
326 | or skip 'no IPPROTO_IP', 4; | |
327 | defined(my $IP_TTL = eval { Socket::IP_TTL() }) | |
328 | or skip 'no IP_TTL', 4; | |
329 | ||
330 | my $sock; | |
331 | socket($sock, PF_INET, SOCK_STREAM, $tcp) or BAIL_OUT "socket: $!"; | |
332 | ||
333 | my $ttl = 7; | |
334 | my $integer_only_ttl = 0 + $ttl; | |
335 | ok(setsockopt($sock, $IPPROTO_IP, $IP_TTL, $integer_only_ttl), | |
336 | 'setsockopt with an integer-only OPTVAL'); | |
337 | my $set_ttl = getsockopt($sock, $IPPROTO_IP, $IP_TTL); | |
338 | is(unpack('i', $set_ttl // ''), $ttl, 'TTL set to desired value'); | |
339 | ||
340 | my $also_string_ttl = $ttl; | |
341 | my $string = "$also_string_ttl"; | |
342 | ok(setsockopt($sock, $IPPROTO_IP, $IP_TTL, $also_string_ttl), | |
343 | 'setsockopt with an integer OPTVAL with stringified value'); | |
344 | $set_ttl = getsockopt($sock, $IPPROTO_IP, $IP_TTL); | |
345 | is(unpack('i', $set_ttl // ''), $ttl, 'TTL set to desired value'); | |
346 | } | |
347 | ||
f192c227 TK |
348 | # GH #19892 |
349 | SKIP: { | |
350 | eval { Socket::IPPROTO_TCP(); 1 } or skip 'no IPPROTO_TCP', 1; | |
351 | eval { Socket::SOL_SOCKET(); 1 } or skip 'no SOL_SOCKET', 1; | |
17e4de6a | 352 | eval { Socket::SO_SNDBUF(); 1 } or skip 'no SO_SNDBUF', 1; |
92ee38c4 | 353 | skip 'setting socket buffer size requires elevated privileges', 1 if $^O eq 'VMS'; |
f192c227 | 354 | |
17e4de6a | 355 | # The value of SNDBUF_SIZE constant below is changed from #19892 testcase; |
f192c227 TK |
356 | # original "262144" may be clamped on low-memory systems. |
357 | fresh_perl_is(<<'EOP', "Ok.\n", {}, 'setsockopt works for a constant that is once stringified'); | |
358 | use warnings; | |
359 | use strict; | |
360 | ||
17e4de6a | 361 | use Socket qw'PF_INET SOCK_STREAM IPPROTO_TCP SOL_SOCKET SO_SNDBUF'; |
f192c227 | 362 | |
17e4de6a | 363 | use constant { SNDBUF_SIZE => 32768 }; |
f192c227 TK |
364 | |
365 | socket(my $sock, PF_INET, SOCK_STREAM, IPPROTO_TCP) | |
366 | or die "Could not create socket - $!\n"; | |
367 | ||
17e4de6a B |
368 | setsockopt($sock,SOL_SOCKET,SO_SNDBUF,SNDBUF_SIZE) |
369 | or die "Could not set SO_SNDBUF on socket - $!\n"; | |
f192c227 | 370 | |
17e4de6a B |
371 | my $sndBuf=getsockopt($sock,SOL_SOCKET,SO_SNDBUF) |
372 | or die "Could not get SO_SNDBUF on socket - $!\n"; | |
f192c227 | 373 | |
17e4de6a | 374 | $sndBuf=unpack('i',$sndBuf); |
f192c227 | 375 | |
17e4de6a B |
376 | die "Unexpected SO_SNDBUF value: $sndBuf\n" |
377 | unless($sndBuf == SNDBUF_SIZE || $sndBuf == 2*SNDBUF_SIZE); | |
f192c227 TK |
378 | |
379 | print "Ok.\n"; | |
380 | exit; | |
381 | ||
17e4de6a | 382 | sub bug {SNDBUF_SIZE.''} |
f192c227 TK |
383 | EOP |
384 | } | |
385 | ||
e122534c TC |
386 | done_testing(); |
387 | ||
388 | my @child_tests; | |
389 | sub ok_child { | |
390 | my ($ok, $note) = @_; | |
3fdf66f3 TC |
391 | push @child_tests, ( $ok ? "ok " : "not ok ") . curr_test() . " - $note " |
392 | . ( $TODO ? "# TODO $TODO" : "" ) . "\n"; | |
e122534c TC |
393 | curr_test(curr_test()+1); |
394 | } | |
395 | ||
396 | sub is_child { | |
397 | my ($got, $want, $note) = @_; | |
398 | ok_child($got eq $want, $note); | |
399 | } | |
400 | ||
401 | sub end_child { | |
402 | print @child_tests; | |
403 | } | |
c7784879 | 404 |