lib/Catalyst/Plugin/Cache.pm

   1 #!/usr/bin/perl
   2
   3 package Catalyst::Plugin::Cache;
   4 use base qw/Class::Data::Inheritable Class::Accessor::Fast/;
   5
   6 use strict;
   7 use warnings;
   8
   9 use Scalar::Util ();
  10 use Carp ();
  11 use NEXT;
  12
  13 use Catalyst::Plugin::Cache::Curried;
  14
  15 __PACKAGE__->mk_classdata( "_cache_backends" );
  16 __PACKAGE__->mk_accessors( "_default_curried_cache" );
  17
  18 sub setup {
  19     my $app = shift;
  20
  21     # set it once per app, not once per plugin,
  22     # and don't overwrite if some plugin was wicked
  23     $app->_cache_backends({}) unless $app->_cache_backends;
  24
  25     my $ret = $app->NEXT::setup( @_ );
  26
  27     $app->setup_cache_backends;
  28
  29     $ret;
  30 }
  31
  32 # don't die even if we don't have cache backends
  33 sub setup_cache_backends { shift->NEXT::setup_cache_backends(@_) }
  34
  35 sub cache {
  36     my ( $c, @meta ) = @_;
  37
  38     if ( @meta == 1 ) {
  39         my $name = $meta[0];
  40         return ( $c->get_preset_curried($name) || $c->get_cache_backend($name) );
  41     } elsif ( !@meta ) {
  42         # be nice and always return the same one for the simplest case
  43         return ( $c->_default_curried_cache || $c->_default_curried_cache( $c->curry_cache( @meta ) ) );
  44     } else {
  45         return $c->curry_cache( @meta );
  46     }
  47 }
  48
  49 sub curry_cache {
  50     my ( $c, @meta ) = @_;
  51     return Catalyst::Plugin::Cache::Curried->new( $c, @meta );
  52 }
  53
  54 sub get_preset_curried {
  55     my ( $c, $name ) = @_;
  56
  57     if ( ref( my $preset = $c->config->{cache}{profiles}{$name} ) ) {
  58         return $preset if Scalar::Util::blessed($preset);
  59
  60         my @meta = ( ( ref $preset eq "HASH" ) ? %$preset : @$preset );
  61         return $c->curry_cache( @meta );
  62     }
  63
  64     return;
  65 }
  66
  67 sub get_cache_backend {
  68     my ( $c, $name ) = @_;
  69     $c->_cache_backends->{$name};
  70 }
  71
  72 sub register_cache_backend {
  73     my ( $c, $name, $backend ) = @_;
  74
  75     no warnings 'uninitialized';
  76     Carp::croak("$backend does not look like a cache backend - "
  77     . "it must be an object supporting get, set and delete")
  78         unless eval { $backend->can("get") && $backend->can("set") && $backend->can("delete") };
  79
  80     $c->_cache_backends->{$name} = $backend;
  81 }
  82
  83 sub unregister_cache_backend {
  84     my ( $c, $name ) = @_;
  85     delete $c->_cache_backends->{$name};
  86 }
  87
  88 sub default_cache_backend {
  89     my $c = shift;
  90     $c->get_cache_backend( "default" ) || $c->temporary_cache_backend;
  91 }
  92
  93 sub temporary_cache_backend {
  94     my $c = shift;
  95     die "FIXME - make up an in memory cache backend, that hopefully works well for the current engine";
  96 }
  97
  98 # this gets a shit name so that the plugins can override a good name
  99 sub choose_cache_backend_wrapper {
 100     my ( $c, @meta ) = @_;
 101
 102     Carp::croak("meta data must be an even sized list") unless @meta % 2 == 0;
 103
 104     my %meta = @meta;
 105
 106     # allow the cache client to specify who it wants to cache with (but loeave room for a hook)
 107     if ( exists $meta{backend} ) {
 108         if ( Scalar::Util::blessed($meta{backend}) ) {
 109             return $meta{backend};
 110         } else {
 111             return $c->get_cache_backend( $meta{backend} ) || $c->default_cache_backend;
 112         }
 113     };
 114
 115
 116     $meta{caller} = [ caller(2) ] unless exists $meta{caller}; # might be interesting
 117
 118     if ( my $chosen = $c->choose_cache_backend( %meta ) ) {
 119         $chosen = $c->get_cache_backend( $chosen ) unless Scalar::Util::blessed($chosen); # if it's a name find it
 120         return $chosen if Scalar::Util::blessed($chosen); # only return if it was an object or name lookup worked
 121
 122         # FIXME
 123         # die "no such backend"?
 124         # currently, we fall back to default
 125     }
 126
 127     return $c->default_cache_backend;
 128 }
 129
 130 sub choose_cache_backend { shift->NEXT::choose_cache_backend( @_ ) } # a convenient fallback
 131
 132 sub cache_set {
 133     my ( $c, $key, $value, @meta ) = @_;
 134     $c->choose_cache_backend_wrapper( key =>  $key, value => $value, @meta )->set( $key, $value );
 135 }
 136
 137 sub cache_get {
 138     my ( $c, $key, @meta ) = @_;
 139     $c->choose_cache_backend_wrapper( key => $key, @meta )->get( $key );
 140 }
 141
 142 sub cache_delete {
 143     my ( $c, $key, @meta ) = @_;
 144     $c->choose_cache_backend_wrapper( key => $key, @meta )->delete( $key );
 145 }
 146
 147 __PACKAGE__;
 148
 149 __END__
 150
 151 =pod
 152
 153 =head1 NAME
 154
 155 Catalyst::Plugin::Cache -
 156
 157 =head1 SYNOPSIS
 158
 159         use Catalyst::Plugin::Cache;
 160
 161 =head1 DESCRIPTION
 162
 163 =cut
 164
 165