package DBIx::DSN::Resolver::Cached;
use strict;
use warnings;
use parent qw/DBIx::DSN::Resolver/;
use Cache::Memory::Simple;
our $VERSION = '0.02';
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,$negative_ttl);
$RR{$host} = int(rand(scalar @ipaddr));
return $ipaddr[$RR{$host}];
};
$class->SUPER::new(
resolver => $resolver
);
}
1;
__END__
=head1 NAME
DBIx::DSN::Resolver::Cached - Cached resolver for DBIx::DSN::Resolver
=head1 SYNOPSIS
use 5.10.0;
use DBIx::DSN::Resolver::Cached;
sub connect_db {
state $resolver = DBIx::DSN::Resolver::Cached->new(
ttl => 30,
negative_ttl => 5,
);
my $dsn = $resolver->resolv('dbi:mysql:database=mytbl;host=myserver.example');
DBI->connect($dsn,'user','password');
}
=head1 DESCRIPTION
DBIx::DSN::Resolver::Cached is extension module of DBIx::DSN::Resolver.
This module allows CACHE resolver response, useful for reduce load of DNS.
DBIx::DSN::Resolver::Cached also supports DNS-RR
=head1 OPTIONS
=over 4
=item ttl: Int
positive cache ttl in seconds. (default: 5)
=item negative_ttl: Int
negative cache ttl in seconds. (default: 1)
=item cache: Object
Cache object, requires support get and set methods.
default: Cache::Memory::Simple is used
=back
=head1 AUTHOR
Masahiro Nagano E<lt>kazeburo {at} gmail.comE<gt>
=head1 SEE ALSO
L<DBIx::DSN::Resolver>, L<Cache::Memory::Simple>
=head1 LICENSE
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut