view release on metacpan or  search on metacpan

lib/Socket/GetAddrInfo/Emul.pm  view on Meta::CPAN

# they're only used by our emulation, it doesn't matter if the real
# platform's values differ
BEGIN {
   my %constants = (
       AI_PASSIVE     => 1,
       AI_CANONNAME   => 2,
       AI_NUMERICHOST => 4,
       AI_V4MAPPED    => 8,
       AI_ALL         => 16,
       AI_ADDRCONFIG  => 32,
       # RFC 2553 doesn't define this but Linux does - lets be nice and
       # provide it since we can
       AI_NUMERICSERV => 1024,

       EAI_BADFLAGS   => -1,
       EAI_NONAME     => -2,
       EAI_NODATA     => -5,
       EAI_FAMILY     => -6,
       EAI_SERVICE    => -8,

       NI_NUMERICHOST => 1,
       NI_NUMERICSERV => 2,
       NI_NOFQDN      => 4,
       NI_NAMEREQD    => 8,
       NI_DGRAM       => 16,

       # These are not gni() constants; they're extensions for the perl API /*
       NIx_NOHOST     => 1,
       NIx_NOSERV     => 2,

       # Constants we don't support. Export them, but croak if anyone tries to
       # use them
       AI_IDN                      => 64,
       AI_CANONIDN                 => 128,
       AI_IDN_ALLOW_UNASSIGNED     => 256,
       AI_IDN_USE_STD3_ASCII_RULES => 512,
       NI_IDN                      => 32,
       NI_IDN_ALLOW_UNASSIGNED     => 64,
       NI_IDN_USE_STD3_ASCII_RULES => 128,

       # Error constants we'll never return, so it doesn't matter what value
       # these have, nor that we don't provide strings for them
       EAI_SYSTEM   => -11,
       EAI_BADHINTS => -1000,
       EAI_PROTOCOL => -1001
   );

   require constant;
   constant->import( $_ => $constants{$_} ) for keys %constants;
   push @EXPORT_OK, $_ for keys %constants;
}

push @EXPORT_OK, qw(
   getaddrinfo
   getnameinfo
);

my %errstr = (
   # These strings from RFC 2553
   EAI_BADFLAGS()   => "invalid value for ai_flags",
   EAI_NONAME()     => "nodename nor servname provided, or not known",
   EAI_NODATA()     => "no address associated with nodename",
   EAI_FAMILY()     => "ai_family not supported",
   EAI_SERVICE()    => "servname not supported for ai_socktype",
);

# Borrowed from Regexp::Common::net
my $REGEXP_IPv4_DECIMAL = qr/25[0-5]|2[0-4][0-9]|1?[0-9][0-9]{1,2}/;
my $REGEXP_IPv4_DOTTEDQUAD = qr/$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL/;

sub _makeerr
{
   my ( $errno ) = @_;
   my $errstr = $errno == 0 ? "" : ( $errstr{$errno} || $errno );
   return dualvar( $errno, $errstr );
}

=head2 getaddrinfo

=over 4

=item *

If the C<family> hint is supplied, it must be C<AF_INET>. Any other value will
result in an error thrown by C<croak>.

=item *

The only supported C<flags> hint values are C<AI_PASSIVE>, C<AI_CANONNAME>,
C<AI_NUMERICSERV> and C<AI_NUMERICHOST>.

The flags C<AI_V4MAPPED> and C<AI_ALL> are recognised but ignored, as they do
not apply to C<AF_INET> lookups.  Since this function only returns C<AF_INET>
addresses, it does not need to probe the system for configured addresses in
other families, so the C<AI_ADDRCONFIG> flag is also ignored.

Note that C<AI_NUMERICSERV> is an extension not defined by RFC 2553, but is
provided by most OSes. It is possible (though unlikely) that even the native
XS implementation does not recognise this constant.

=back

=cut

sub getaddrinfo
{
   my ( $node, $service, $hints ) = @_;
   
   $node = "" unless defined $node;

   $service = "" unless defined $service;

   my ( $family, $socktype, $protocol, $flags ) = @$hints{qw( family socktype protocol flags )};

   $family ||= AF_INET; # 0 == AF_UNSPEC, which we want too
   $family == AF_INET or return _makeerr( EAI_FAMILY );

   $socktype ||= 0;

   $protocol ||= 0;