File Coverage

blib/lib/DBIx/DSN/Resolver/Cached.pm

Criterion	Covered	Total	%
statement	41	45	91.1
branch	14	24	58.3
condition	2	3	66.6
subroutine	8	8	100.0
pod	1	2	50.0
total	66	82	80.4

package DBIx::DSN::Resolver::Cached;

use strict;
use warnings;
use parent qw/DBIx::DSN::Resolver Exporter/;
use Cache::Memory::Simple;
use Carp;

our $VERSION = '0.04';
our @EXPORT = qw/dsn_resolver/;
my %RR;

sub new {
    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 $resolver = sub {
        my $host = shift;
        if ( my $cached = $cache->get($host) ) {
            return if @$cached == 0;
            if ( exists $RR{$host} ) {
                $RR{$host}++;
                $RR{$host} = 0 if $RR{$host} >= scalar @$cached;
            } else {
                $RR{$host} = 0;
            }
            return $cached->[$RR{$host}]
        }
        my ($name,$aliases,$addrtype,$length,@addrs)= gethostbyname($host);
        if ( ! defined $name ) {
            $cache->set($host,[],$negative_ttl);
            return;
        }
        my @ipaddr = map { Socket::inet_ntoa($_) } @addrs;
        $cache->set($host,\@ipaddr,$ttl);
        $RR{$host} = int(rand(scalar @ipaddr));
        return $ipaddr[$RR{$host}];
    };
    $class->SUPER::new(
        resolver => $resolver
    );
}


our $RESOLVER;
sub dsn_resolver {
    my $dsn = shift;
    return unless $dsn;
    $RESOLVER ||= DBIx::DSN::Resolver::Cached->new();
    my $resolved = $RESOLVER->resolv($dsn)
        or croak "Can't resolv dsn: $dsn";
    return @_ ? ($resolved,@_) : $resolved;
}

1;

__END__