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