File Coverage

blib/lib/AnyEvent/DNS/Cache/Simple.pm

Criterion	Covered	Total	%
statement	57	63	90.4
branch	15	22	68.1
condition	1	2	50.0
subroutine	12	12	100.0
pod	2	2	100.0
total	87	101	86.1

package AnyEvent::DNS::Cache::Simple;

use 5.008005;
use strict;
use warnings;
use base qw/AnyEvent::DNS/;
use Cache::Memory::Simple;
use List::Util qw//;
use Time::HiRes qw//;

our $VERSION = "0.01";

sub request($$) {
   my ($self, $req, $cb) = @_;
   my ($name, $qtype, $class) = @{$req->{qd}[0]};
   my $cache_key = "$class $qtype $name"; #compatibility with Net::DNS::Lite
   if ( my $cached = $self->{adcs_cache}->get($cache_key) ) {
        my ($res,$expires_at) = @$cached;
        if ( $expires_at < Time::HiRes::time ) {
            undef $res;
            $self->{adcs_cache}->remove($cache_key)
        }
        if ( !defined $res ) {
            $cb->();
            return;
        }
        return $cb->($res);
    }

    # request
    $self->SUPER::request($req, sub {
        my ($res) = @_;
        if ( !@_ ) {
            $self->{adcs_cache}->set($cache_key, [undef, $self->{adcs_negative_ttl} + Time::HiRes::time() ], $self->{adcs_negative_ttl});
            return $cb->();
        }
        my $ttl = List::Util::min(
            $self->{adcs_ttl},
            map {
                $_->[3]
            } (@{$res->{an}} ? @{$res->{an}} : @{$res->{ns}}),
        );
        $self->{adcs_cache}->set($cache_key, [$res, $ttl + Time::HiRes::time ], $ttl);
        $cb->($res);
    });
}

sub register {
    my $class = shift;
    my %args = @_ == 1 ? %{$_[0]} : @_;
    my $ttl = exists $args{ttl} ? delete $args{ttl} : 5;
    my $negative_ttl = exists $args{negative_ttl} ? delete $args{negative_ttl} : 1;
    my $cache = exists $args{cache} ? delete $args{cache} : Cache::Memory::Simple->new;

    my $old = $AnyEvent::DNS::RESOLVER;
    $AnyEvent::DNS::RESOLVER = do {
        no warnings 'uninitialized';
        my $resolver = AnyEvent::DNS::Cache::Simple->new(
            untaint         => 1,
            max_outstanding => $ENV{PERL_ANYEVENT_MAX_OUTSTANDING_DNS}*1 || 1,
            adcs_ttl => $ttl,
            adcs_negative_ttl => $negative_ttl,
            adcs_cache => $cache,
            %args
        );
        if ( !$args{server} ) {
            $ENV{PERL_ANYEVENT_RESOLV_CONF}
                ? $resolver->_load_resolv_conf_file ($ENV{PERL_ANYEVENT_RESOLV_CONF})
                : $resolver->os_config;
        }
        $resolver;
    };
    AnyEvent::Util::guard {
        $AnyEvent::DNS::RESOLVER = $old;
    };
}

1;
__END__