File Coverage

blib/lib/Net/DNS/Native.pm

Criterion	Covered	Total	%
statement	71	71	100.0
branch	17	20	85.0
condition	11	18	61.1
subroutine	23	24	95.8
pod	7	7	100.0
total	129	140	92.1

package Net::DNS::Native;

use strict;
use warnings;
use DynaLoader;
use Socket ();
use Symbol ();
use POSIX ();
use Config;

our $VERSION = '0.20';

use constant {
    INET_ATON     => 0,
    INET_PTON     => 1,
    GETHOSTBYNAME => 2,
    GETADDRINFO   => 3,
    NEED_RTLD_GLOBAL => $Config{osname} =~ /linux/i &&
       !($Config{usethreads} || $Config{libs} =~ /-l?pthread\b/ || $Config{ldflags} =~ /-l?pthread\b/)
};

our @ISA = 'DynaLoader';
sub dl_load_flags {
    if (NEED_RTLD_GLOBAL) {
        return 0x01;
    }

    return 0;
}
DynaLoader::bootstrap('Net::DNS::Native');
if (NEED_RTLD_GLOBAL && &_is_non_safe_symbols_loaded) {
    die sprintf(
"***********************************************************************
Some package defined non thread safe symbols which %s uses internally
Please make sure you are not placed loading of modules like IO::Socket::IP
before this one and not called functions like getaddrinfo(), gethostbyname(),
inet_aton() before loading of %s
************************************************************************", __PACKAGE__, __PACKAGE__);
}

sub _fd2socket($$) {
    my $sock = Symbol::gensym();
    tie *$sock, 'Net::DNS::Native::Handle', $_[1], $_[0];
    $sock;
}

sub getaddrinfo {
    my $self = shift;
    _fd2socket $self, $self->_getaddrinfo($_[0], $_[1], $_[2], GETADDRINFO);
}

sub inet_aton {
    my $self = shift;
    _fd2socket $self, $self->_getaddrinfo($_[0], undef, {family => Socket::AF_INET, socktype => Socket::SOCK_STREAM}, INET_ATON);
}

sub inet_pton {
    my $self = shift;
    _fd2socket $self, $self->_getaddrinfo($_[1], undef, {family => $_[0], socktype => Socket::SOCK_STREAM}, INET_PTON);
}

sub gethostbyname {
    my $self = shift;
    _fd2socket $self, $self->_getaddrinfo($_[0], undef, {family => Socket::AF_INET, flags => Socket::AI_CANONNAME, socktype => Socket::SOCK_STREAM}, GETHOSTBYNAME);
}

sub get_result {
    my ($self, $sock) = @_;

    my ($type, $err, @res) =  $self->_get_result(fileno($sock));

    tied(*$sock)->need_result(0);

    if ($type == GETADDRINFO) {
        return ($err, @res);
    }

    if ($type == INET_ATON || $type == INET_PTON || (!wantarray() && $type == GETHOSTBYNAME)) {
        return
          $err ? undef :
          ( $res[0]{family} == Socket::AF_INET ?
             Socket::unpack_sockaddr_in($res[0]{addr}) :
             Net::DNS::Native::unpack_sockaddr_in6($res[0]{addr}) )[1];
    }

    if ($type == GETHOSTBYNAME) {
        return
          $err ? () :
          ($res[0]{canonname}, undef, Socket::AF_INET, length($res[0]{addr}), map { (Socket::unpack_sockaddr_in($_->{addr}))[1] } @res);
    }
}

sub timedout {
    my ($self, $sock) = @_;

    return if defined ${^GLOBAL_PHASE} && ${^GLOBAL_PHASE} eq 'DESTRUCT';

    if (ref $sock) {
        tied(*$sock)->need_result(0);
        $sock = fileno $sock;
    }

    $self->_timedout($sock);
}

package Net::DNS::Native::Handle;

use strict;
use warnings;

sub TIEHANDLE {
    my ($class, $fd, $resolver) = @_;
    bless { fd => $fd, rs => $resolver, need_result => 1 }, $class;
}

sub FILENO {
    return $_[0]->{fd};
}

sub READ {
    my $self = shift;
    POSIX::read( $self->{fd}, $_[0], $_[1] );
}

sub CLOSE {}

sub DESTROY {
    my $self = shift;

    if ($self->need_result && $self->{rs}) {
        $self->{rs}->timedout($self->{fd});
    }
}

sub need_result {
    my $self = shift;

    unless (@_) {
        return $self->{need_result};
    }

    $self->{need_result} = $_[0];
}

1;

__END__