1#!perl 2 3# sanity tests for socket functions 4 5BEGIN { 6 chdir 't' if -d 't'; 7 @INC = '../lib' if -d '../lib' && -d '../ext'; 8 9 require "./test.pl"; 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 26$| = 1; # ensure test output is synchronous so processes don't conflict 27 28my $tcp = getprotobyname('tcp') 29 or skip_all("no tcp protocol available ($!)"); 30my $udp = getprotobyname('udp') 31 or note "getprotobyname('udp') failed: $!"; 32 33my $local = gethostbyname('localhost') 34 or note "gethostbyname('localhost') failed: $!"; 35 36my $fork = $Config{d_fork} || $Config{d_pseudofork}; 37 38{ 39 # basic socket creation 40 socket(my $sock, PF_INET, SOCK_STREAM, $tcp) 41 or skip_all('socket() for tcp failed ($!), nothing else will work'); 42 ok(close($sock), "close the socket"); 43} 44 45SKIP: { 46 # test it all in TCP 47 $local or skip("No localhost", 2); 48 49 ok(socket(my $serv, PF_INET, SOCK_STREAM, $tcp), "make a tcp socket"); 50 my $bind_at = pack_sockaddr_in(0, $local); 51 ok(bind($serv, $bind_at), "bind works") 52 or skip("Couldn't bind to localhost", 3); 53 my $bind_name = getsockname($serv); 54 ok($bind_name, "getsockname() on bound socket"); 55 my ($bind_port) = unpack_sockaddr_in($bind_name); 56 57 print "# port $bind_port\n"; 58 59 SKIP: 60 { 61 ok(listen($serv, 5), "listen() works") 62 or diag "listen error: $!"; 63 64 $fork or skip("No fork", 1); 65 my $pid = fork; 66 my $send_data = "test" x 50_000; 67 if ($pid) { 68 # parent 69 ok(socket(my $accept, PF_INET, SOCK_STREAM, $tcp), 70 "make accept tcp socket"); 71 ok(my $addr = accept($accept, $serv), "accept() works") 72 or diag "accept error: $!"; 73 74 my $sent_total = 0; 75 while ($sent_total < length $send_data) { 76 my $sent = send($accept, substr($send_data, $sent_total), 0); 77 defined $sent or last; 78 $sent_total += $sent; 79 } 80 my $shutdown = shutdown($accept, 1); 81 82 # wait for the remote to close so data isn't lost in 83 # transit on a certain broken implementation 84 <$accept>; 85 # child tests are printed once we hit eof 86 curr_test(curr_test()+5); 87 waitpid($pid, 0); 88 89 ok($shutdown, "shutdown() works"); 90 } 91 elsif (defined $pid) { 92 curr_test(curr_test()+2); 93 #sleep 1; 94 # child 95 ok_child(close($serv), "close server socket in child"); 96 ok_child(socket(my $child, PF_INET, SOCK_STREAM, $tcp), 97 "make child tcp socket"); 98 99 ok_child(connect($child, $bind_name), "connect() works") 100 or diag "connect error: $!"; 101 102 my $buf; 103 my $recv_peer = recv($child, $buf, 1000, 0); 104 # [perl #118843] 105 ok_child($recv_peer eq '' || $recv_peer eq $bind_name, 106 "peer from recv() should be empty or the remote name"); 107 while(defined recv($child, my $tmp, 1000, 0)) { 108 last if length $tmp == 0; 109 $buf .= $tmp; 110 } 111 is_child($buf, $send_data, "check we received the data"); 112 close($child); 113 end_child(); 114 115 exit(0); 116 } 117 else { 118 # failed to fork 119 diag "fork() failed $!"; 120 skip("fork() failed", 1); 121 } 122 } 123} 124 125done_testing(); 126 127my @child_tests; 128sub ok_child { 129 my ($ok, $note) = @_; 130 push @child_tests, ( $ok ? "ok " : "not ok ") . curr_test() . " - $note\n"; 131 curr_test(curr_test()+1); 132} 133 134sub is_child { 135 my ($got, $want, $note) = @_; 136 ok_child($got eq $want, $note); 137} 138 139sub end_child { 140 print @child_tests; 141} 142