gistfile1.pl

#!/usr/bin/perl

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

use strict;
use warnings;
use base qw/AnyEvent::DNS/;
use Cache::Memory::Simple;
use Data::Dumper;

sub serialize_opt {
    my $value = shift;
    if ( defined $value && ref($value) ) {
        local $Data::Dumper::Terse = 1;
        local $Data::Dumper::Indent = 0; 
        local $Data::Dumper::Sortkeys = 1; 
        $value = Data::Dumper::Dumper($value);
    }
    $value;
}

sub resolve {
    my $cb = pop @_;
    my ($self, $qname, $qtype, %opt) = @_;
    my $cache_key = $qtype .':'. $qname . ':' . serialize_opt(\%opt);
    if ( my $cached = $self->{adcs_cache}->get($cache_key) ) {
        if ( @$cached == 0 ) {
            $cb->();
            return;
        }
        my @cached = @$cached; #copy
        if ( exists $self->{adcs_rr}{$cache_key} ) {
            $self->{adcs_rr}{$cache_key}++;
            $self->{adcs_rr}{$cache_key} = 0 if $self->{adcs_rr}{$cache_key} >= scalar @cached;
        } else {
            $self->{adcs_rr}{$cache_key} = 0;
        }
        my @spliced = splice @cached, 0, $self->{adcs_rr}{$cache_key};
        push @cached, @spliced;
        $cb->(@cached);
        return;
    }
    
    # request
    $self->SUPER::resolve($qname, $qtype, %opt, sub {
        if ( !@_ ) {
            $self->{adcs_cache}->set($cache_key, [], $self->{adcs_negative_ttl});
            $cb->();
            return;
        }
        $self->{adcs_cache}->set($cache_key, \@_, $self->{adcs_ttl});
        $self->{adcs_rr}{$cache_key} = 0;
        $cb->(@_);
    });
}

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,
            adcs_rr => {},
        );
        $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;
    };
}

package main;

use strict;
use warnings;
use AnyEvent::HTTP;

my $guard = AnyEvent::DNS::Cache::Simple->register;

for my $i ( 1..3 ) {
    my $cv = AE::cv;
    http_get "http://mixi.jp/", sub {
        warn "$i";
        $cv->send;
    };
    $cv->recv;
}