t/io/socket.t

   1 #!perl
   2
   3 # sanity tests for socket functions
   4
   5 BEGIN {
   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
  23 use strict;
  24 use Socket;
  25
  26 $| = 1; # ensure test output is synchronous so processes don't conflict
  27
  28 my $tcp = getprotobyname('tcp')
  29     or skip_all("no tcp protocol available ($!)");
  30 my $udp = getprotobyname('udp')
  31     or note "getprotobyname('udp') failed: $!";
  32
  33 my $local = gethostbyname('localhost')
  34     or note "gethostbyname('localhost') failed: $!";
  35
  36 my $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
  45 SKIP: {
  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             {
 105                 use vars '$TODO';
 106                 local $TODO;
 107                 $TODO = "[perl #122657] Hurd doesn't populate sin_len correctly"
 108                     if $^O eq "gnu";
 109                 # [perl #118843]
 110                 ok_child($recv_peer eq '' || $recv_peer eq getpeername $child,
 111                          "peer from recv() should be empty or the remote name");
 112             }
 113             while(defined recv($child, my $tmp, 1000, 0)) {
 114                 last if length $tmp == 0;
 115                 $buf .= $tmp;
 116             }
 117             is_child($buf, $send_data, "check we received the data");
 118             close($child);
 119             end_child();
 120
 121             exit(0);
 122         }
 123         else {
 124             # failed to fork
 125             diag "fork() failed $!";
 126             skip("fork() failed", 1);
 127         }
 128     }
 129 }
 130
 131 done_testing();
 132
 133 my @child_tests;
 134 sub ok_child {
 135     my ($ok, $note) = @_;
 136     push @child_tests, ( $ok ? "ok " : "not ok ") . curr_test() . " - $note "
 137         . ( $TODO ? "# TODO $TODO" : "" ) . "\n";
 138     curr_test(curr_test()+1);
 139 }
 140
 141 sub is_child {
 142     my ($got, $want, $note) = @_;
 143     ok_child($got eq $want, $note);
 144 }
 145
 146 sub end_child {
 147     print @child_tests;
 148 }