view release on metacpan or  search on metacpan

lib/AnyEvent/CacheDNS.pm  view on Meta::CPAN

package AnyEvent::CacheDNS;

use strict;
use warnings;
use base 'AnyEvent::DNS';

use Data::Dumper;

our $VERSION = '0.08';

# Detect AnyEvent >= 6.0.1
my $IS_AE_6X = version->can("parse")
	? version->parse(AnyEvent->VERSION()) >= version->parse('v6.0.1')
	: AnyEvent->VERSION !~ /^ (?: [0-5]\. | 6\.0(?:\.0)? $ )/x;

# Default TTL for AnyEvent < 6.0.1
my $DEFAULT_TTL = undef;

sub import {
	my $package = shift;
	my @options = @_;

	while (@options) {
		my $key = shift @options;
		if ($key eq ':register') {
			$package->register();
		}
	}
}


sub resolve {
	my $cb = pop @_;
	my ($self, $qname, $qtype, %opt) = @_;

	# If we have the value cached then we serve it from there
	my $cache = $self->{_cache}{$qtype} ||= {};
	if (exists $cache->{$qname}) {
		my $response = $cache->{$qname};
		$cb->($response ? ($response) : ());
		return;
	}

	# Perform a request and cache the value
	$self->SUPER::resolve(
		$qname,
		$qtype,
		%opt,
		sub{
			# Note that it could be possible that multiple DNS request are done
			# for a new qname. For instance if an application is doing multiple
			# concurrent HTTP request to the same host then there will be at
			# least one DNS request per HTTP request. That's why we only cache
			# the results of the first DNS request that's successful.
			$cache->{$qname} ||= @_ ? $_[0] : undef;

			# Respect TTL and be backwards compatible with AnyEvent < 6.x
			my $ttl = defined $DEFAULT_TTL
				? $DEFAULT_TTL
				: ($IS_AE_6X && @_ ? int($_[0]->[3] || 0) : 0)
			;

			if ($ttl > 0) {
				# Create expire timer
				my $wt;
				$wt  = AE::timer($ttl, 0, sub {
					$wt = undef;
					delete($cache->{$qname});
				});
			}

			$cb->(@_);
		}
	);
}


sub register {
	my $class = shift;

	my @args = (
		untaint => 1,
	);

	my $key = 'PERL_ANYEVENT_MAX_OUTSTANDING_DNS';
	push @args, max_outstanding => $ENV{$key} * 1 || 1 if exists $ENV{$key};

	my $resolver = $class->new(@args);

	if (exists $ENV{PERL_ANYEVENT_RESOLV_CONF}) {
		my $conf = $ENV{PERL_ANYEVENT_RESOLV_CONF};
		$resolver->_parse_resolv_conf_file($conf) if length $conf;
	}
	else {
		$resolver->os_config();
	}

	$DEFAULT_TTL = abs(int($ENV{PERL_ANYEVENT_DNS_TTL} || 0)) if exists $ENV{PERL_ANYEVENT_DNS_TTL};

	$AnyEvent::DNS::RESOLVER = $resolver;
}


1;