gistfile1.pl

package Cache::Balancer;

use strict;
use warnings;
use Carp;

use Scalar::Util;
use base qw(Class::Accessor::Fast);
__PACKAGE__->mk_accessors(qw(strict rules default debug));

our $VERSION = "0.01";

sub new {
    my ($class, $opt) = @_;
    $opt ||= {};
    my $self = {
        debug => 0,
        strict => 0,
        rules => [],
        %{$opt}
    };
    return bless $self, $class;
}

BEGIN {
    my @method = qw(get gets set add replace cas incr decr append prepend delete);
    my @method_multi = map { $_ . "_multi" } @method;
    for my $method_name ( @method ) {
        eval sprintf( <<'__SUB__', $method_name, $method_name);
        sub %s {
            my $self = shift;
            $self->_delegate("%s", @_);
        }
__SUB__
}
    for my $method_name (@method_multi) {
        eval sprintf(<<'__SUB__', $method_name, $method_name);
        sub %s {
            my $self = shift;
            $self->_delegate_multi("%s", @_);
        }
__SUB__
    }
}

sub add_rule {
    my $self = shift;
    my ($cond, $rule) = @_;
    push @{$self->{rules}}, [$cond, $rule];
}

sub _test {
    my ($self, $pattern, $key, $value) = @_;
    my $type = ref $pattern;
    return index($key, $pattern) == 0 unless $type;
    return $key =~m{$pattern} if (ref $pattern eq "Regexp");
    return $pattern->($key, $value) if (ref $pattern eq "CODE");
}

sub select_backend {
    my ($self, $key, $value) = @_;
    my @rules = @{$self->rules};
    for my $pair (@rules) {
        my ($pattern, $cache) = @{$pair};
        next unless $self->_test($pattern, $key, $value);
        return (ref $cache eq "CODE") ? $cache->($key, $value) : $cache;
    }
    # no match, use default cache
    my $cache = $self->default;
    return (ref $cache eq "CODE") ? $cache->($key, $value) : $cache;
}

sub _delegate {
    my $self = shift;
    my ($method, @args) = @_;
    my $cache = $self->select_backend(@args);
    if (!$cache) {
        carp "can't find usable cache object" if $self->debug;
        return
    }
    warn sprintf("select %s for %s:%s", ref $cache, $method, $args[0]) if $self->debug;
    $cache->$method(@args);
}

sub _delegate_multi {
    my $self = shift;
    my ($method, @args) = @_;
    if ($self->strict) {
        my %backend;
        my %request;
        for my $pair (@args) {
            my $cache = (ref $pair eq "ARRAY") ? $self->select_backend(@{$pair}) : $self->select_backend($pair);
            if ($cache) {
                my $id = Scalar::Util::refaddr($cache);
                $backend{$id} ||= $cache;
                $request{$id} ||= [];
                push @{$request{$id}}, $pair;
            }
        }
        my %result;
        while ( my($id, $cache) = each %backend ) {
            warn sprintf("select %s for %s", ref $cache, $method) if $self->debug;
            my @req = @{$request{$id}};
            my $got = $cache->$method(@req);
            %result = (%result, %{$got});
        }
        return \%result;
    } else {
        my $first = $args[0];
        my $cache = (ref $first eq "ARRAY") ? $self->select_backend(@{$first}) : $self->select_backend($first);
        if (!$cache) {
            carp "can't find usable cache object" if $self->debug;
            return +{};
        }
        warn sprintf("select %s for %s", ref $cache, $method) if $self->debug;
        return $cache->$method(@args);
    }
}

1;

__END__

=pod

=head1 NAME

Cache::Balancer

=head1 SYNOPSIS

 $cache = Cache::Balancer->new({
     default => $cache,
     # default => sub { return $cache }
 });

 $cache->add_rule($pattern, $cache);
 # pattern can: String, Regexp, Coderef
 # cache can: cache object or Coderef

 # example:
 $cache->add_rule('http', $http_cache); # cache for URI::Fetch, key start with "http"
 $cache->add_rule(qr/Data::/, sub { my $key = shift; return $cache_for{$key} }); # complex rule for cache
 $cache->add_rule(sub { my $key = shift; 1 }, sub { my $key = shift; return $cache_for{$key} });  # complex rule for key,cache