lib/Catalyst/Plugin/Cache.pm

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