Catalyst::Plugin::Cache - Flexible caching support for Catalyst.

	use Catalyst qw/
        Cache
    /;

    # configure a backend or use a store plugin 
    __PACKAGE__->config->{'Plugin::Cache'}{backend} = {
        class => "Cache::Bounded",
        # ... params for Cache::Bounded...
    };

    # typical example for Cache::Memcached::libmemcached
    __PACKAGE__->config->{'Plugin::Cache'}{backend} = {
        class   => "Cache::Memcached::libmemcached",
        servers => ['127.0.0.1:11211'],
        debug   => 2,
    };




    # In a controller:

    sub foo : Local {
        my ( $self, $c, $id ) = @_;

        my $cache = $c->cache;

        my $result;

        unless ( $result = $cache->get( $id ) ) {
            # ... calculate result ...
            $c->cache->set( $id, $result );
        }
    };

    my $cache = $c->cache( %meta ); # cache is curried

    $cache->set( $key, $value );

    $cache->get( $key );

    $c->cache_set( $key, $value, %meta );

    $c->cache_get( $key, %meta );

    $c->config->{'Plugin::Cache'} = {
        ...
    };

#!/usr/bin/perl

package Catalyst::Plugin::Cache;
use base qw(Class::Accessor::Fast Class::Data::Inheritable);

use strict;
use warnings;

our $VERSION = "0.10";

use Scalar::Util ();
use Catalyst::Utils ();
use Carp ();
use MRO::Compat;
use Scalar::Util qw/ blessed /;
use Catalyst::Plugin::Cache::Curried;

__PACKAGE__->mk_classdata( "_cache_backends" );
__PACKAGE__->mk_accessors( "_default_curried_cache" );

sub setup {
    my $app = shift;

    # set it once per app, not once per plugin,
    # and don't overwrite if some plugin was wicked
    $app->_cache_backends({}) unless $app->_cache_backends;

    my $ret = $app->maybe::next::method( @_ );

    $app->setup_cache_backends;

    $ret;
}
{
    my %has_warned_for;
    sub _get_cache_plugin_config {
        my ($app) = @_;
        my $config = $app->config->{'Plugin::Cache'};
        if (!$config) {
            $config = $app->config->{cache};
            my $appname = ref($app);
            if (! $has_warned_for{$appname}++ ) {
                $app->log->warn($config ?
                    'Catalyst::Plugin::Cache config found in deprecated $c->config->{cache}, please move to $c->config->{"Plugin::Cache"}.'
                    : 'Catalyst::Plugin::Cache config not found, using empty config!'
                );
            }
        }
        return $config || {};
    }
}

sub get_default_cache_backend_config {
    my ( $app, $name ) = @_;
    $app->_get_cache_plugin_config->{backend} || $app->get_cache_backend_config("default");
}

sub get_cache_backend_config {
    my ( $app, $name ) = @_;
    $app->_get_cache_plugin_config->{backends}{$name};
}

sub setup_cache_backends {
    my $app = shift;

    # give plugins a chance to find things for themselves
    $app->maybe::next::method;

    # FIXME - Don't know why the _get_cache_plugin_config method doesn't work here!
    my $conf = $app->_get_cache_plugin_config->{backends};
    foreach my $name ( keys %$conf ) {
        next if $app->get_cache_backend( $name );
        $app->setup_generic_cache_backend( $name, $app->get_cache_backend_config( $name ) || {} );
    }

    if ( !$app->get_cache_backend("default") ) {
        ### XXX currently we dont have a fallback scenario
        ### so die here with the error message. Once we have
        ### an in memory fallback, we may consider silently
        ### logging the error and falling back to that.
        ### If we dont die here, the app will silently start
        ### up and then explode at the first cache->get or
        ### cache->set request with a FIXME error
        #local $@;
        #eval { 
        $app->setup_generic_cache_backend( default => $app->get_default_cache_backend_config || {} );
        #};
        
   }
}

sub default_cache_store {
    my $app = shift;
    $app->_get_cache_plugin_config->{default_store} || $app->guess_default_cache_store;
}

sub guess_default_cache_store {
    my $app = shift;

    my @stores = map { /Cache::Store::(.*)$/ ? $1 : () } $app->registered_plugins;

    if ( @stores == 1 ) {
        return $stores[0];
    } else {
        Carp::croak "You must configure a default store type unless you use exactly one store plugin.";
    }
}

sub setup_generic_cache_backend {
    my ( $app, $name, $config ) = @_;
    my %config = %$config;

    if ( my $class = delete $config{class} ) {
        
        ### try as list and as hashref, collect the
        ### error if things go wrong
        ### if all goes well, exit the loop
        my @errors;
        for my $aref ( [%config], [\%config] ) {
            eval { $app->setup_cache_backend_by_class( 
                        $name, $class, @$aref 
                    );
            } ? do { @errors = (); last }
              : push @errors, "\t$@";
        }
        
        ### and die with the errors if we have any
        die "Couldn't construct $class with either list style or hash ref style param passing:\n @errors" if @errors;
        
    } elsif ( my $store = delete $config->{store} || $app->default_cache_store ) {
        my $method = lc("setup_${store}_cache_backend");

        Carp::croak "You must load the $store cache store plugin (if it exists). ".
        "Please consult the Catalyst::Plugin::Cache documentation on how to configure hetrogeneous stores."
            unless $app->can($method);

        $app->$method( $name, \%config );
    } else {
        $app->log->warn("Couldn't setup the cache backend named '$name'");
    }
}

sub setup_cache_backend_by_class {
    my ( $app, $name, $class, @args ) = @_;
    Catalyst::Utils::ensure_class_loaded( $class );
    $app->register_cache_backend( $name => $class->new( @args ) );
}

# end of spaghetti setup DWIM

sub cache {
    my ( $c, @meta ) = @_;

    if ( @meta == 1 ) {
        my $name = $meta[0];
        return ( $c->get_preset_curried($name) || $c->get_cache_backend($name) );
    } elsif ( !@meta && blessed $c ) {
        # be nice and always return the same one for the simplest case
        return ( $c->_default_curried_cache || $c->_default_curried_cache( $c->curry_cache( @meta ) ) );
    } else {
        return $c->curry_cache( @meta );
    }
}

sub construct_curried_cache {
    my ( $c, @meta ) = @_;
    return $c->curried_cache_class( @meta )->new( @meta );
}

sub curried_cache_class {
    my ( $c, @meta ) = @_;
    $c->_get_cache_plugin_config->{curried_class} || "Catalyst::Plugin::Cache::Curried";
}

sub curry_cache {
    my ( $c, @meta ) = @_;
    return $c->construct_curried_cache( $c, $c->_cache_caller_meta, @meta );
}

sub get_preset_curried {
    my ( $c, $name ) = @_;

    if ( ref( my $preset = $c->_get_cache_plugin_config->{profiles}{$name} ) ) {
        return $preset if Scalar::Util::blessed($preset);

        my @meta = ( ( ref $preset eq "HASH" ) ? %$preset : @$preset );
        return $c->curry_cache( @meta );
    }

    return;
}

sub get_cache_backend {
    my ( $c, $name ) = @_;
    $c->_cache_backends->{$name};
}

sub register_cache_backend {
    my ( $c, $name, $backend ) = @_;

    no warnings 'uninitialized';
    Carp::croak("$backend does not look like a cache backend - "
    . "it must be an object supporting get, set and remove")
        unless eval { $backend->can("get") && $backend->can("set") && $backend->can("remove") };

    $c->_cache_backends->{$name} = $backend;
}

sub unregister_cache_backend {
    my ( $c, $name ) = @_;
    delete $c->_cache_backends->{$name};
}

sub default_cache_backend {
    my $c = shift;
    $c->get_cache_backend( "default" ) || $c->temporary_cache_backend;
}

sub temporary_cache_backend {
    my $c = shift;
    die "FIXME - make up an in memory cache backend, that hopefully works well for the current engine";
}

sub _cache_caller_meta {
    my $c = shift;

    my ( $caller, $component, $controller );
    
    for my $i ( 0 .. 15 ) { # don't look to far
        my @info = caller(2 + $i) or last;

        $caller     ||= \@info unless $info[0] =~ /Plugin::Cache/;
        $component  ||= \@info if $info[0]->isa("Catalyst::Component");
        $controller ||= \@info if $info[0]->isa("Catalyst::Controller");
    
        last if $caller && $component && $controller;
    }

    my ( $caller_pkg, $component_pkg, $controller_pkg ) =
        map { $_ ? $_->[0] : undef } $caller, $component, $controller;

    return (
        'caller'   => $caller_pkg,
        component  => $component_pkg,
        controller => $controller_pkg,
        caller_frame     => $caller,
        component_frame  => $component,
        controller_frame => $controller,
    );
}

# this gets a shit name so that the plugins can override a good name
sub choose_cache_backend_wrapper {
    my ( $c, @meta ) = @_;

    Carp::croak("metadata must be an even sized list") unless @meta % 2 == 0;

    my %meta = @meta;

    unless ( exists $meta{'caller'} ) {
        my %caller = $c->_cache_caller_meta;
        @meta{keys %caller} = values %caller;
    }
    
    # allow the cache client to specify who it wants to cache with (but loeave room for a hook)
    if ( exists $meta{backend} ) {
        if ( Scalar::Util::blessed($meta{backend}) ) {
            return $meta{backend};
        } else {
            return $c->get_cache_backend( $meta{backend} ) || $c->default_cache_backend;
        }
    };
    
    if ( my $chosen = $c->choose_cache_backend( %meta ) ) {
        $chosen = $c->get_cache_backend( $chosen ) unless Scalar::Util::blessed($chosen); # if it's a name find it
        return $chosen if Scalar::Util::blessed($chosen); # only return if it was an object or name lookup worked

        # FIXME
        # die "no such backend"?
        # currently, we fall back to default
    }
    
    return $c->default_cache_backend;
}

sub choose_cache_backend { shift->maybe::next::method( @_ ) } # a convenient fallback

sub cache_set {
    my ( $c, $key, $value, %meta ) = @_;
    $c->choose_cache_backend_wrapper( key =>  $key, value => $value, %meta )
        ->set( $key, $value, exists $meta{expires} ? $meta{expires} : () );
}

sub cache_get {
    my ( $c, $key, @meta ) = @_;
    $c->choose_cache_backend_wrapper( key => $key, @meta )->get( $key );
}

sub cache_remove {
    my ( $c, $key, @meta ) = @_;
    $c->choose_cache_backend_wrapper( key => $key, @meta )->remove( $key );
}

sub cache_compute {
    my ($c, $key, $code, %meta) = @_;

    my $backend = $c->choose_cache_backend_wrapper( key =>  $key, %meta );
    if ($backend->can('compute')) {
        return $backend->compute( $key, $code, exists $meta{expires} ? $meta{expires} : () );
    }

    Carp::croak "must specify key and code" unless defined($key) && defined($code);

    my $value = $c->cache_get( $key, %meta );
    if ( !defined $value ) {
        $value = $code->();
        $c->cache_set( $key, $value, %meta );
    }
    return $value;
}

__PACKAGE__;

__END__