view release on metacpan or  search on metacpan

cpan/Socket/Socket.pm  view on Meta::CPAN

if( defined &getaddrinfo ) {
    # These are not part of the API, nothing uses them, and deleting them
    # reduces the size of %Socket:: by about 12K
    delete $Socket::{fake_getaddrinfo};
    delete $Socket::{fake_getnameinfo};
} else {
    require Scalar::Util;

    *getaddrinfo = \&fake_getaddrinfo;
    *getnameinfo = \&fake_getnameinfo;

    # These numbers borrowed from GNU libc's implementation, but since
    # they're only used by our emulation, it doesn't matter if the real
    # platform's values differ
    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,

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

        # 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
    );

    foreach my $name ( keys %constants ) {
        my $value = $constants{$name};

        no strict 'refs';
        defined &$name or *$name = sub () { $value };
    }

    %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",
    );
}

# The following functions are used if the system does not have a
# getaddrinfo(3) function in libc; and are used to emulate it for the AF_INET
# family

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

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

sub fake_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 ||= Socket::AF_INET(); # 0 == AF_UNSPEC, which we want too
    $family == Socket::AF_INET() or return fake_makeerr( EAI_FAMILY() );

    $socktype ||= 0;

    $protocol ||= 0;

    $flags ||= 0;

    my $flag_passive     = $flags & AI_PASSIVE();     $flags &= ~AI_PASSIVE();
    my $flag_canonname   = $flags & AI_CANONNAME();   $flags &= ~AI_CANONNAME();
    my $flag_numerichost = $flags & AI_NUMERICHOST(); $flags &= ~AI_NUMERICHOST();
    my $flag_numericserv = $flags & AI_NUMERICSERV(); $flags &= ~AI_NUMERICSERV();

    # These constants don't apply to AF_INET-only lookups, so we might as well
    # just ignore them. For AI_ADDRCONFIG we just presume the host has ability
    # to talk AF_INET. If not we'd have to return no addresses at all. :)
    $flags &= ~(AI_V4MAPPED()|AI_ALL()|AI_ADDRCONFIG());

    $flags & (AI_IDN()|AI_CANONIDN()) and
        croak "Socket::getaddrinfo() does not support IDN";

    $flags == 0 or return fake_makeerr( EAI_BADFLAGS() );

    $node eq "" and $service eq "" and return fake_makeerr( EAI_NONAME() );

    my $canonname;
    my @addrs;
    if( $node ne "" ) {