cpan/Socket/t/getaddrinfo.t

   1 use strict;
   2 use warnings;
   3 use Test::More tests => 31;
   4
   5 use Socket qw(:addrinfo AF_INET SOCK_STREAM IPPROTO_TCP unpack_sockaddr_in inet_aton);
   6
   7 my ( $err, @res );
   8
   9 ( $err, @res ) = getaddrinfo( "127.0.0.1", "80", { socktype => SOCK_STREAM } );
  10 cmp_ok( $err, "==", 0, '$err == 0 for host=127.0.0.1/service=80/socktype=STREAM' );
  11 cmp_ok( $err, "eq", "", '$err eq "" for host=127.0.0.1/service=80/socktype=STREAM' );
  12 is( scalar @res, 1,
  13     '@res has 1 result' );
  14
  15 is( $res[0]->{family}, AF_INET,
  16     '$res[0] family is AF_INET' );
  17 is( $res[0]->{socktype}, SOCK_STREAM,
  18     '$res[0] socktype is SOCK_STREAM' );
  19 ok( $res[0]->{protocol} == 0 || $res[0]->{protocol} == IPPROTO_TCP,
  20     '$res[0] protocol is 0 or IPPROTO_TCP' );
  21 ok( defined $res[0]->{addr},
  22     '$res[0] addr is defined' );
  23 if (length $res[0]->{addr}) {
  24     is_deeply( [ unpack_sockaddr_in $res[0]->{addr} ],
  25                [ 80, inet_aton( "127.0.0.1" ) ],
  26                '$res[0] addr is {"127.0.0.1", 80}' );
  27 } else {
  28     fail( '$res[0] addr is empty: check $socksizetype' );
  29 }
  30
  31 # Check actual IV integers work just as well as PV strings
  32 ( $err, @res ) = getaddrinfo( "127.0.0.1", 80, { socktype => SOCK_STREAM } );
  33 cmp_ok( $err, "==", 0, '$err == 0 for host=127.0.0.1/service=80/socktype=STREAM' );
  34 is_deeply( [ unpack_sockaddr_in $res[0]->{addr} ],
  35            [ 80, inet_aton( "127.0.0.1" ) ],
  36            '$res[0] addr is {"127.0.0.1", 80}' );
  37
  38 ( $err, @res ) = getaddrinfo( "127.0.0.1", "" );
  39 cmp_ok( $err, "==", 0, '$err == 0 for host=127.0.0.1' );
  40 # Might get more than one; e.g. different socktypes
  41 ok( scalar @res > 0, '@res has results' );
  42
  43 ( $err, @res ) = getaddrinfo( "127.0.0.1", undef );
  44 cmp_ok( $err, "==", 0, '$err == 0 for host=127.0.0.1/service=undef' );
  45
  46 # Test GETMAGIC
  47 {
  48     "127.0.0.1" =~ /(.+)/;
  49     ( $err, @res ) = getaddrinfo($1, undef);
  50     cmp_ok( $err, "==", 0, '$err == 0 for host=$1' );
  51     ok( scalar @res > 0, '@res has results' );
  52     is( (unpack_sockaddr_in $res[0]->{addr})[1],
  53         inet_aton( "127.0.0.1" ),
  54         '$res[0] addr is {"127.0.0.1", ??}' );
  55 }
  56
  57 ( $err, @res ) = getaddrinfo( "", "80", { family => AF_INET, socktype => SOCK_STREAM, protocol => IPPROTO_TCP } );
  58 cmp_ok( $err, "==", 0, '$err == 0 for service=80/family=AF_INET/socktype=STREAM/protocol=IPPROTO_TCP' );
  59 is( scalar @res, 1, '@res has 1 result' );
  60
  61 # Just pick the first one
  62 is( $res[0]->{family}, AF_INET,
  63     '$res[0] family is AF_INET' );
  64 is( $res[0]->{socktype}, SOCK_STREAM,
  65     '$res[0] socktype is SOCK_STREAM' );
  66 ok( $res[0]->{protocol} == 0 || $res[0]->{protocol} == IPPROTO_TCP,
  67     '$res[0] protocol is 0 or IPPROTO_TCP' );
  68
  69 # Now some tests of a few well-known internet hosts
  70 my $goodhost = "cpan.perl.org";
  71
  72 SKIP: {
  73     skip "Resolver has no answer for $goodhost", 2 unless gethostbyname( $goodhost );
  74
  75     ( $err, @res ) = getaddrinfo( "cpan.perl.org", "ftp", { socktype => SOCK_STREAM } );
  76     cmp_ok( $err, "==", 0, '$err == 0 for host=cpan.perl.org/service=ftp/socktype=STREAM' );
  77     # Might get more than one; e.g. different families
  78     ok( scalar @res > 0, '@res has results' );
  79 }
  80
  81 # Now something I hope doesn't exist - we put it in a known-missing TLD
  82 my $missinghost = "TbK4jM2M0OS.lm57DWIyu4i";
  83
  84 # Some CPAN testing machines seem to have wildcard DNS servers that reply to
  85 # any request. We'd better check for them
  86
  87 SKIP: {
  88     skip "Resolver has an answer for $missinghost", 1 if gethostbyname( $missinghost );
  89
  90     # Some OSes return $err == 0 but no results
  91     ( $err, @res ) = getaddrinfo( $missinghost, "ftp", { socktype => SOCK_STREAM } );
  92     ok( $err != 0 || ( $err == 0 && @res == 0 ),
  93         '$err != 0 or @res == 0 for host=TbK4jM2M0OS.lm57DWIyu4i/service=ftp/socktype=SOCK_STREAM' );
  94     if( @res ) {
  95         # Diagnostic that might help
  96         while( my $r = shift @res ) {
  97             diag( "family=$r->{family} socktype=$r->{socktype} protocol=$r->{protocol} addr=[" . length( $r->{addr} ) . " bytes]" );
  98             diag( "  addr=" . join( ", ", map { sprintf '0x%02x', ord $_ } split m//, $r->{addr} ) );
  99         }
 100     }
 101 }
 102
 103 # Numeric addresses with AI_NUMERICHOST should pass (RT95758)
 104 AI_NUMERICHOST: {
 105     # Here we need a port that is open to the world. Not all places have all
 106     # the ports. For example Solaris by default doesn't have http/80 in
 107     # /etc/services, and that would fail. Let's try a couple of commonly open
 108     # ports, and hope one of them will succeed. Conversely this means that
 109     # sometimes this will fail.
 110     #
 111     # An alternative method would be to manually parse /etc/services and look
 112     # for enabled services but that's kind of yuck, too.
 113     my @port = (80, 7, 22, 25, 88, 123, 110, 389, 443, 445, 873, 2049, 3306);
 114     foreach my $port ( @port ) {
 115         ( $err, @res ) = getaddrinfo( "127.0.0.1", $port, { flags => AI_NUMERICHOST, socktype => SOCK_STREAM } );
 116         if( $err == 0 ) {
 117             ok( $err == 0, "\$err == 0 for 127.0.0.1/$port/flags=AI_NUMERICHOST" );
 118             last AI_NUMERICHOST;
 119         }
 120     }
 121     fail( "$err for 127.0.0.1/$port[-1]/flags=AI_NUMERICHOST (failed for ports @port)" );
 122 }
 123
 124 # Now check that names with AI_NUMERICHOST fail
 125
 126 SKIP: {
 127     skip "Resolver has no answer for $goodhost", 1 unless gethostbyname( $goodhost );
 128
 129     ( $err, @res ) = getaddrinfo( $goodhost, "ftp", { flags => AI_NUMERICHOST, socktype => SOCK_STREAM } );
 130     ok( $err != 0, "\$err != 0 for host=$goodhost/service=ftp/flags=AI_NUMERICHOST/socktype=SOCK_STREAM" );
 131 }
 132
 133 # Some sanity checking on the hints hash
 134 ok( defined eval { getaddrinfo( "127.0.0.1", "80", undef ); 1 },
 135     'getaddrinfo() with undef hints works' );
 136 ok( !defined eval { getaddrinfo( "127.0.0.1", "80", "hints" ); 1 },
 137     'getaddrinfo() with string hints dies' );
 138 ok( !defined eval { getaddrinfo( "127.0.0.1", "80", [] ); 1 },
 139     'getaddrinfo() with ARRAY hints dies' );
 140
 141 # Ensure it doesn't segfault if args are missing
 142
 143 ( $err, @res ) = getaddrinfo();
 144 ok( defined $err, '$err defined for getaddrinfo()' );
 145
 146 ( $err, @res ) = getaddrinfo( "127.0.0.1" );
 147 ok( defined $err, '$err defined for getaddrinfo("127.0.0.1")' );