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