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