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 Catalyst::Utils ();
  11 use Carp ();
  12 use NEXT;
  13
  14 use Catalyst::Plugin::Cache::Curried;
  15
  16 __PACKAGE__->mk_classdata( "_cache_backends" );
  17 __PACKAGE__->mk_accessors( "_default_curried_cache" );
  18
  19 sub setup {
  20     my $app = shift;
  21
  22     # set it once per app, not once per plugin,
  23     # and don't overwrite if some plugin was wicked
  24     $app->_cache_backends({}) unless $app->_cache_backends;
  25
  26     my $ret = $app->NEXT::setup( @_ );
  27
  28     $app->setup_cache_backends;
  29
  30     $ret;
  31 }
  32
  33 sub get_default_cache_backend_config {
  34     my ( $app, $name ) = @_;
  35     $app->config->{cache}{backend} || $app->get_cache_backend_config("default");
  36 }
  37
  38 sub get_cache_backend_config {
  39     my ( $app, $name ) = @_;
  40     $app->config->{cache}{backends}{$name};
  41 }
  42
  43 sub setup_cache_backends {
  44     my $app = shift;
  45
  46     # give plugins a chance to find things for themselves
  47     $app->NEXT::setup_cache_backends;
  48
  49     foreach my $name ( keys %{ $app->config->{cache}{backends} } ) {
  50         next if $app->get_cache_backend( $name );
  51         $app->setup_generic_cache_backend( $name, $app->get_cache_backend_config( $name ) || {} );
  52     }
  53
  54     if ( !$app->get_cache_backend("default") and my $default_config = $app->get_default_cache_backend_config) {
  55         $app->setup_generic_cache_backend( default => $default_config );
  56     }
  57 }
  58
  59 sub default_cache_store {
  60     my $app = shift;
  61     $app->config->{cache}{default_store} || $app->guess_default_cache_store;
  62 }
  63
  64 sub guess_default_cache_store {
  65     my $app = shift;
  66
  67     my @stores = map { /Cache::Store::(.*)$/ ? $1 : () } $app->registered_plugins;
  68
  69     if ( @stores == 1 ) {
  70         return $stores[0];
  71     } else {
  72         Carp::croak "You must configure a default store type unless you use exactly one store plugin.";
  73     }
  74 }
  75
  76 sub setup_generic_cache_backend {
  77     my ( $app, $name, $config ) = @_;
  78     my %config = %$config;
  79
  80     if ( my $class = delete $config{class} ) {
  81         $app->setup_cache_backend_by_class( $name, $class, %config );
  82     } elsif ( my $store = delete $config->{store} || $app->default_cache_store ) {
  83         my $method = lc("setup_${store}_cache_backend");
  84
  85         Carp::croak "You must load the $store cache store plugin (if it exists). ".
  86         "Please consult the Catalyst::Plugin::Cache documentation on how to configure hetrogeneous stores."
  87             unless $app->can($method);
  88
  89         $app->$method( $name, %config );
  90     } else {
  91         $app->log->warn("Couldn't setup the cache backend named '$name'");
  92     }
  93 }
  94
  95 sub setup_cache_backend_by_class {
  96     my ( $app, $name, $class, @args ) = @_;
  97     Catalyst::Utils::ensure_class_loaded( $class );
  98     $app->register_cache_backend( $name => $class->new( @args ) );
  99 }
 100
 101 # end of spaghetti setup DWIM
 102
 103 sub cache {
 104     my ( $c, @meta ) = @_;
 105
 106     if ( @meta == 1 ) {
 107         my $name = $meta[0];
 108         return ( $c->get_preset_curried($name) || $c->get_cache_backend($name) );
 109     } elsif ( !@meta ) {
 110         # be nice and always return the same one for the simplest case
 111         return ( $c->_default_curried_cache || $c->_default_curried_cache( $c->curry_cache( @meta ) ) );
 112     } else {
 113         return $c->curry_cache( @meta );
 114     }
 115 }
 116
 117 sub curry_cache {
 118     my ( $c, @meta ) = @_;
 119     return Catalyst::Plugin::Cache::Curried->new( $c, @meta );
 120 }
 121
 122 sub get_preset_curried {
 123     my ( $c, $name ) = @_;
 124
 125     if ( ref( my $preset = $c->config->{cache}{profiles}{$name} ) ) {
 126         return $preset if Scalar::Util::blessed($preset);
 127
 128         my @meta = ( ( ref $preset eq "HASH" ) ? %$preset : @$preset );
 129         return $c->curry_cache( @meta );
 130     }
 131
 132     return;
 133 }
 134
 135 sub get_cache_backend {
 136     my ( $c, $name ) = @_;
 137     $c->_cache_backends->{$name};
 138 }
 139
 140 sub register_cache_backend {
 141     my ( $c, $name, $backend ) = @_;
 142
 143     no warnings 'uninitialized';
 144     Carp::croak("$backend does not look like a cache backend - "
 145     . "it must be an object supporting get, set and remove")
 146         unless eval { $backend->can("get") && $backend->can("set") && $backend->can("remove") };
 147
 148     $c->_cache_backends->{$name} = $backend;
 149 }
 150
 151 sub unregister_cache_backend {
 152     my ( $c, $name ) = @_;
 153     delete $c->_cache_backends->{$name};
 154 }
 155
 156 sub default_cache_backend {
 157     my $c = shift;
 158     $c->get_cache_backend( "default" ) || $c->temporary_cache_backend;
 159 }
 160
 161 sub temporary_cache_backend {
 162     my $c = shift;
 163     die "FIXME - make up an in memory cache backend, that hopefully works well for the current engine";
 164 }
 165
 166 # this gets a shit name so that the plugins can override a good name
 167 sub choose_cache_backend_wrapper {
 168     my ( $c, @meta ) = @_;
 169
 170     Carp::croak("meta data must be an even sized list") unless @meta % 2 == 0;
 171
 172     my %meta = @meta;
 173
 174     # allow the cache client to specify who it wants to cache with (but loeave room for a hook)
 175     if ( exists $meta{backend} ) {
 176         if ( Scalar::Util::blessed($meta{backend}) ) {
 177             return $meta{backend};
 178         } else {
 179             return $c->get_cache_backend( $meta{backend} ) || $c->default_cache_backend;
 180         }
 181     };
 182
 183
 184     $meta{caller} = [ caller(2) ] unless exists $meta{caller}; # might be interesting
 185
 186     if ( my $chosen = $c->choose_cache_backend( %meta ) ) {
 187         $chosen = $c->get_cache_backend( $chosen ) unless Scalar::Util::blessed($chosen); # if it's a name find it
 188         return $chosen if Scalar::Util::blessed($chosen); # only return if it was an object or name lookup worked
 189
 190         # FIXME
 191         # die "no such backend"?
 192         # currently, we fall back to default
 193     }
 194
 195     return $c->default_cache_backend;
 196 }
 197
 198 sub choose_cache_backend { shift->NEXT::choose_cache_backend( @_ ) } # a convenient fallback
 199
 200 sub cache_set {
 201     my ( $c, $key, $value, @meta ) = @_;
 202     $c->choose_cache_backend_wrapper( key =>  $key, value => $value, @meta )->set( $key, $value );
 203 }
 204
 205 sub cache_get {
 206     my ( $c, $key, @meta ) = @_;
 207     $c->choose_cache_backend_wrapper( key => $key, @meta )->get( $key );
 208 }
 209
 210 sub cache_remove {
 211     my ( $c, $key, @meta ) = @_;
 212     $c->choose_cache_backend_wrapper( key => $key, @meta )->remove( $key );
 213 }
 214
 215 __PACKAGE__;
 216
 217 __END__
 218
 219 =pod
 220
 221 =head1 NAME
 222
 223 Catalyst::Plugin::Cache -
 224
 225 =head1 SYNOPSIS
 226
 227         use Catalyst::Plugin::Cache;
 228
 229 =head1 DESCRIPTION
 230
 231 =head1 TERMINOLIGY
 232
 233 =over 4
 234
 235 =item backend
 236
 237 An object that responds to the methods detailed in
 238 L<Catalyst::Plugin::Cache::Backend> (or more).
 239
 240 =item store
 241
 242 A generic "type" of backend. Typically a plugin used to construct backends.
 243
 244 =item curried cache
 245
 246 An object that responds to C<get>, C<set> and C<remove>, and will automatically
 247 add meta data to calls to C<< $c->cache_get >>, etc.
 248
 249 =back
 250
 251 =cut
 252
 253