File Coverage

blib/lib/EV/cares.pm

Criterion	Covered	Total	%
statement	147	147	100.0
branch	79	80	98.7
condition	10	14	71.4
subroutine	22	22	100.0
pod	9	9	100.0
total	267	272	98.1

package EV::cares;
use 5.012;
use strict;
use warnings;
use EV;

BEGIN {
    our $VERSION = '0.02';
    use XSLoader;
    XSLoader::load __PACKAGE__, $VERSION;
}

use Exporter 'import';

our @EXPORT_OK;
our %EXPORT_TAGS;

$EXPORT_TAGS{status} = [qw(
    ARES_SUCCESS ARES_ENODATA ARES_EFORMERR ARES_ESERVFAIL ARES_ENOTFOUND
    ARES_ENOTIMP ARES_EREFUSED ARES_EBADQUERY ARES_EBADNAME ARES_EBADFAMILY
    ARES_EBADRESP ARES_ECONNREFUSED ARES_ETIMEOUT ARES_EOF ARES_EFILE
    ARES_ENOMEM ARES_EDESTRUCTION ARES_EBADSTR ARES_EBADFLAGS ARES_ENONAME
    ARES_EBADHINTS ARES_ENOTINITIALIZED ARES_ECANCELLED ARES_ESERVICE
    ARES_ENOSERVER
)];

$EXPORT_TAGS{types} = [qw(
    T_A T_NS T_CNAME T_SOA T_PTR T_MX T_TXT T_AAAA T_SRV T_NAPTR
    T_DS T_RRSIG T_DNSKEY T_TLSA T_SVCB T_HTTPS T_CAA T_ANY
)];

$EXPORT_TAGS{classes} = [qw(C_IN C_CHAOS C_HS C_ANY)];

$EXPORT_TAGS{flags} = [qw(
    ARES_FLAG_USEVC ARES_FLAG_PRIMARY ARES_FLAG_IGNTC ARES_FLAG_NORECURSE
    ARES_FLAG_STAYOPEN ARES_FLAG_NOSEARCH ARES_FLAG_NOALIASES ARES_FLAG_NOCHECKRESP
    ARES_FLAG_EDNS ARES_FLAG_NO_DFLT_SVR ARES_FLAG_DNS0x20
)];

$EXPORT_TAGS{ai} = [qw(
    ARES_AI_CANONNAME ARES_AI_NUMERICHOST ARES_AI_PASSIVE ARES_AI_NUMERICSERV
    ARES_AI_V4MAPPED ARES_AI_ALL ARES_AI_ADDRCONFIG ARES_AI_NOSORT
)];

$EXPORT_TAGS{ni} = [qw(
    ARES_NI_NOFQDN ARES_NI_NUMERICHOST ARES_NI_NAMEREQD ARES_NI_NUMERICSERV
    ARES_NI_DGRAM ARES_NI_TCP ARES_NI_UDP
)];

$EXPORT_TAGS{families} = [qw(AF_INET AF_INET6 AF_UNSPEC)];

{
    my %seen;
    @EXPORT_OK = grep { !$seen{$_}++ } map { @$_ } values %EXPORT_TAGS;
    $EXPORT_TAGS{all} = [@EXPORT_OK];
}

# ptr_name($ip) -> reverse-lookup name (.in-addr.arpa for IPv4, .ip6.arpa for IPv6)
# Pure-Perl, no resolver needed.
sub ptr_name {
    my ($ip) = @_;
    require Carp;
    Carp::croak("ptr_name: missing IP") unless defined $ip;
    if (my @oct = $ip =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})\z/) {
        for my $o (@oct) {
            Carp::croak("ptr_name: leading-zero octet '$o' is ambiguous (octal vs decimal)")
                if length($o) > 1 && $o =~ /^0/;
            Carp::croak("ptr_name: invalid IPv4 octet '$o'") if $o > 255;
        }
        return "$oct[3].$oct[2].$oct[1].$oct[0].in-addr.arpa";
    }
    if ($ip =~ /:/) {
        require Socket;
        my $packed = Socket::inet_pton(Socket::AF_INET6(), $ip)
            or Carp::croak("ptr_name: invalid IPv6 '$ip'");
        my @nibbles = CORE::reverse(split //, unpack 'H*', $packed);
        return join('.', @nibbles) . '.ip6.arpa';
    }
    Carp::croak("ptr_name: not a recognized IPv4/IPv6 address: '$ip'");
}

# parse_header($buf) -> hashref of DNS header fields
# Useful for inspecting query() raw responses (AD/CD/AA/TC/RA/RD/QR + counts).
sub parse_header {
    my ($buf) = @_;
    require Carp;
    Carp::croak("parse_header: buffer too short") if length($buf) < 12;
    my ($id, $w, $qd, $an, $ns, $ar) = unpack 'nnnnnn', $buf;
    return {
        id      => $id,
        qr      => ($w >> 15) & 1,
        opcode  => ($w >> 11) & 0xf,
        aa      => ($w >> 10) & 1,
        tc      => ($w >>  9) & 1,
        rd      => ($w >>  8) & 1,
        ra      => ($w >>  7) & 1,
        z       => ($w >>  6) & 1,
        ad      => ($w >>  5) & 1,
        cd      => ($w >>  4) & 1,
        rcode   =>  $w        & 0xf,
        qdcount => $qd,
        ancount => $an,
        nscount => $ns,
        arcount => $ar,
    };
}

sub resolve_all {
    my ($self, $names, $cb) = @_;
    require Carp;
    Carp::croak("resolve_all: first argument must be an arrayref")
        unless ref $names eq 'ARRAY';
    Carp::croak("resolve_all: callback must be a CODE reference")
        unless ref $cb eq 'CODE';
    Carp::croak("resolve_all: resolver is destroyed") if $self->is_destroyed;
    return $cb->({}) unless @$names;
    my %seen;
    my @unique = grep { !$seen{$_}++ } @$names;
    my %res;
    my $pending = @unique;
    for my $name (@unique) {
        $self->resolve($name, sub {
            my ($status, @addrs) = @_;
            $res{$name} = { status => $status, addrs => \@addrs };
            $cb->(\%res) if --$pending == 0;
        });
    }
    return;
}

sub resolve_ttl_all {
    my ($self, $names, $cb) = @_;
    require Carp;
    Carp::croak("resolve_ttl_all: first argument must be an arrayref")
        unless ref $names eq 'ARRAY';
    Carp::croak("resolve_ttl_all: callback must be a CODE reference")
        unless ref $cb eq 'CODE';
    Carp::croak("resolve_ttl_all: resolver is destroyed") if $self->is_destroyed;
    return $cb->({}) unless @$names;
    my %seen;
    my @unique = grep { !$seen{$_}++ } @$names;
    my %res;
    my $pending = @unique;
    for my $name (@unique) {
        $self->resolve_ttl($name, sub {
            my ($status, @records) = @_;
            $res{$name} = { status => $status, records => \@records };
            $cb->(\%res) if --$pending == 0;
        });
    }
    return;
}

sub reverse_all {
    my ($self, $ips, $cb) = @_;
    require Carp;
    Carp::croak("reverse_all: first argument must be an arrayref")
        unless ref $ips eq 'ARRAY';
    Carp::croak("reverse_all: callback must be a CODE reference")
        unless ref $cb eq 'CODE';
    Carp::croak("reverse_all: resolver is destroyed") if $self->is_destroyed;
    return $cb->({}) unless @$ips;
    my %seen;
    my @unique = grep { !$seen{$_}++ } @$ips;
    # validate every IP upfront.  reverse() croaks on invalid input; if we
    # discovered that mid-loop we would have already dispatched queries 1..k
    # whose inner callbacks hold $cb and decrement $pending, but $pending
    # would never reach 0 (we never dispatched k+1..N) -- the completion
    # callback would be silently orphaned.
    require Socket;
    for my $ip (@unique) {
        Carp::croak("reverse_all: invalid IP '$ip'")
            unless Socket::inet_pton(Socket::AF_INET(),  $ip)
                || Socket::inet_pton(Socket::AF_INET6(), $ip);
    }
    my %res;
    my $pending = @unique;
    for my $ip (@unique) {
        $self->reverse($ip, sub {
            my ($status, @hosts) = @_;
            $res{$ip} = { status => $status, hosts => \@hosts };
            $cb->(\%res) if --$pending == 0;
        });
    }
    return;
}

sub getaddrinfo_all {
    my ($self, $nodes, $service, $hints, $cb) = @_;
    require Carp;
    Carp::croak("getaddrinfo_all: first argument must be an arrayref")
        unless ref $nodes eq 'ARRAY';
    Carp::croak("getaddrinfo_all: callback must be a CODE reference")
        unless ref $cb eq 'CODE';
    Carp::croak("getaddrinfo_all: resolver is destroyed") if $self->is_destroyed;
    return $cb->({}) unless @$nodes;
    my %seen;
    my @unique = grep { !$seen{$_}++ } @$nodes;
    my %res;
    my $pending = @unique;
    for my $node (@unique) {
        $self->getaddrinfo($node, $service, $hints, sub {
            my ($status, @addrs) = @_;
            $res{$node} = { status => $status, addrs => \@addrs };
            $cb->(\%res) if --$pending == 0;
        });
    }
    return;
}

# is_busy: true iff there are pending queries on this resolver.  Cheap
# wrapper for the most common active_queries comparison.
sub is_busy { $_[0]->active_queries > 0 }

# wait_idle($timeout_seconds): pump the EV loop until either all of this
# resolver's pending queries complete or the timeout elapses.  Returns
# true if the channel drained, false on timeout.  Useful in mostly-
# synchronous scripts that want to ensure callbacks have run before
# proceeding.  Returns immediately if the resolver is already idle.
#
# Picks up a custom EV::Loop passed to new(loop => $loop): the timer and
# the run() call are dispatched on the same loop the resolver's watchers
# are armed on.  Without this, custom-loop resolvers would hang because
# EV::run/EV::timer always target the default loop.
sub wait_idle {
    my ($self, $timeout) = @_;
    require Carp;
    Carp::croak("wait_idle: resolver is destroyed") if $self->is_destroyed;
    return 1 unless $self->active_queries;
    $timeout //= 30;
    my $expired;
    my $loop = $self->loop // EV::default_loop;
    my $timer = $loop->timer($timeout, 0, sub { $expired = 1 });
    while ($self->active_queries && !$expired) {
        $loop->run(EV::RUN_ONCE);
    }
    # Look at the resolver's state rather than $expired: if the timer and
    # the last query callback both fire in the same RUN_ONCE iteration,
    # $expired is set but the channel did drain.  Don't lie about that.
    return $self->active_queries ? 0 : 1;
}

sub search_all {
    my ($self, $names, $type, $class_or_cb, $cb) = @_;
    require Carp;
    # search_all($names, $type, $cb)         -> 4 args (class default C_IN)
    # search_all($names, $type, $class, $cb) -> 5 args
    my $class;
    if (@_ == 4) {
        $cb = $class_or_cb;
    } elsif (@_ == 5) {
        $class = $class_or_cb;
        require Scalar::Util;
        Carp::croak("search_all: class must be an integer (C_IN, C_CHAOS, ...)")
            unless Scalar::Util::looks_like_number($class);
    } else {
        Carp::croak("search_all: usage: \$r->search_all(\\\@names, \$type, [\$class,] \$cb)");
    }
    Carp::croak("search_all: first argument must be an arrayref")
        unless ref $names eq 'ARRAY';
    Carp::croak("search_all: callback must be a CODE reference")
        unless ref $cb eq 'CODE';
    Carp::croak("search_all: resolver is destroyed") if $self->is_destroyed;
    return $cb->({}) unless @$names;
    my %seen;
    my @unique = grep { !$seen{$_}++ } @$names;
    my %res;
    my $pending = @unique;
    for my $name (@unique) {
        my $inner = sub {
            my ($status, @records) = @_;
            $res{$name} = { status => $status, records => \@records };
            $cb->(\%res) if --$pending == 0;
        };
        defined $class
            ? $self->search($name, $type, $class, $inner)
            : $self->search($name, $type, $inner);
    }
    return;
}

1;

__END__