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; Config->import; 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 284SKIP: 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"); 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"); 320} 321 322# GH #18642 - test whether setsockopt works with a numeric OPTVAL which also 323# has a cached stringified value 324SKIP: { 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 348# GH #19892 349SKIP: { 350 eval { Socket::IPPROTO_TCP(); 1 } or skip 'no IPPROTO_TCP', 1; 351 eval { Socket::SOL_SOCKET(); 1 } or skip 'no SOL_SOCKET', 1; 352 eval { Socket::SO_SNDBUF(); 1 } or skip 'no SO_SNDBUF', 1; 353 skip 'setting socket buffer size requires elevated privileges', 1 if $^O eq 'VMS'; 354 355 # The value of SNDBUF_SIZE constant below is changed from #19892 testcase; 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'); 358use warnings; 359use strict; 360 361use Socket qw'PF_INET SOCK_STREAM IPPROTO_TCP SOL_SOCKET SO_SNDBUF'; 362 363use constant { SNDBUF_SIZE => 32768 }; 364 365socket(my $sock, PF_INET, SOCK_STREAM, IPPROTO_TCP) 366 or die "Could not create socket - $!\n"; 367 368setsockopt($sock,SOL_SOCKET,SO_SNDBUF,SNDBUF_SIZE) 369 or die "Could not set SO_SNDBUF on socket - $!\n"; 370 371my $sndBuf=getsockopt($sock,SOL_SOCKET,SO_SNDBUF) 372 or die "Could not get SO_SNDBUF on socket - $!\n"; 373 374$sndBuf=unpack('i',$sndBuf); 375 376die "Unexpected SO_SNDBUF value: $sndBuf\n" 377 unless($sndBuf == SNDBUF_SIZE || $sndBuf == 2*SNDBUF_SIZE); 378 379print "Ok.\n"; 380exit; 381 382sub bug {SNDBUF_SIZE.''} 383EOP 384} 385 386done_testing(); 387 388my @child_tests; 389sub ok_child { 390 my ($ok, $note) = @_; 391 push @child_tests, ( $ok ? "ok " : "not ok ") . curr_test() . " - $note " 392 . ( $TODO ? "# TODO $TODO" : "" ) . "\n"; 393 curr_test(curr_test()+1); 394} 395 396sub is_child { 397 my ($got, $want, $note) = @_; 398 ok_child($got eq $want, $note); 399} 400 401sub end_child { 402 print @child_tests; 403} 404 405