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 construct_curried_cache {
 119     my ( $c, @meta ) = @_;
 120     return $c->curried_cache_class( @meta )->new( @meta );
 121 }
 122
 123 sub curried_cache_class {
 124     my ( $c, @meta ) = @_;
 125     $c->config->{cache}{curried_class} || "Catalyst::Plugin::Cache::Curried";
 126 }
 127
 128 sub curry_cache {
 129     my ( $c, @meta ) = @_;
 130     return $c->construct_curried_cache( $c, $c->_cache_caller_meta, @meta );
 131 }
 132
 133 sub get_preset_curried {
 134     my ( $c, $name ) = @_;
 135
 136     if ( ref( my $preset = $c->config->{cache}{profiles}{$name} ) ) {
 137         return $preset if Scalar::Util::blessed($preset);
 138
 139         my @meta = ( ( ref $preset eq "HASH" ) ? %$preset : @$preset );
 140         return $c->curry_cache( @meta );
 141     }
 142
 143     return;
 144 }
 145
 146 sub get_cache_backend {
 147     my ( $c, $name ) = @_;
 148     $c->_cache_backends->{$name};
 149 }
 150
 151 sub register_cache_backend {
 152     my ( $c, $name, $backend ) = @_;
 153
 154     no warnings 'uninitialized';
 155     Carp::croak("$backend does not look like a cache backend - "
 156     . "it must be an object supporting get, set and remove")
 157         unless eval { $backend->can("get") && $backend->can("set") && $backend->can("remove") };
 158
 159     $c->_cache_backends->{$name} = $backend;
 160 }
 161
 162 sub unregister_cache_backend {
 163     my ( $c, $name ) = @_;
 164     delete $c->_cache_backends->{$name};
 165 }
 166
 167 sub default_cache_backend {
 168     my $c = shift;
 169     $c->get_cache_backend( "default" ) || $c->temporary_cache_backend;
 170 }
 171
 172 sub temporary_cache_backend {
 173     my $c = shift;
 174     die "FIXME - make up an in memory cache backend, that hopefully works well for the current engine";
 175 }
 176
 177 sub _cache_caller_meta {
 178     my $c = shift;
 179
 180     my ( $caller, $component, $controller );
 181
 182     for my $i ( 0 .. 15 ) { # don't look to far
 183         my @info = caller(2 + $i) or last;
 184
 185         $caller     ||= \@info unless $info[0] =~ /Catalyst::Plugin::Cache/;
 186         $component  ||= \@info if $info[0]->isa("Catalyst::Component");
 187         $controller ||= \@info if $info[0]->isa("Catalyst::Controller");
 188
 189         last if $caller && $component && $controller;
 190     }
 191
 192     return (
 193         'caller'   => $caller,
 194         component  => $component,
 195         controller => $controller,
 196     );
 197 }
 198
 199 # this gets a shit name so that the plugins can override a good name
 200 sub choose_cache_backend_wrapper {
 201     my ( $c, @meta ) = @_;
 202
 203     Carp::croak("meta data must be an even sized list") unless @meta % 2 == 0;
 204
 205     my %meta = @meta;
 206
 207     unless ( exists $meta{'caller'} ) {
 208         my %caller = $c->_cache_caller_meta;
 209         @meta{keys %caller} = values %caller;
 210     }
 211
 212     # allow the cache client to specify who it wants to cache with (but loeave room for a hook)
 213     if ( exists $meta{backend} ) {
 214         if ( Scalar::Util::blessed($meta{backend}) ) {
 215             return $meta{backend};
 216         } else {
 217             return $c->get_cache_backend( $meta{backend} ) || $c->default_cache_backend;
 218         }
 219     };
 220
 221     if ( my $chosen = $c->choose_cache_backend( %meta ) ) {
 222         $chosen = $c->get_cache_backend( $chosen ) unless Scalar::Util::blessed($chosen); # if it's a name find it
 223         return $chosen if Scalar::Util::blessed($chosen); # only return if it was an object or name lookup worked
 224
 225         # FIXME
 226         # die "no such backend"?
 227         # currently, we fall back to default
 228     }
 229
 230     return $c->default_cache_backend;
 231 }
 232
 233 sub choose_cache_backend { shift->NEXT::choose_cache_backend( @_ ) } # a convenient fallback
 234
 235 sub cache_set {
 236     my ( $c, $key, $value, @meta ) = @_;
 237     $c->choose_cache_backend_wrapper( key =>  $key, value => $value, @meta )->set( $key, $value );
 238 }
 239
 240 sub cache_get {
 241     my ( $c, $key, @meta ) = @_;
 242     $c->choose_cache_backend_wrapper( key => $key, @meta )->get( $key );
 243 }
 244
 245 sub cache_remove {
 246     my ( $c, $key, @meta ) = @_;
 247     $c->choose_cache_backend_wrapper( key => $key, @meta )->remove( $key );
 248 }
 249
 250 __PACKAGE__;
 251
 252 __END__
 253
 254 =pod
 255
 256 =head1 NAME
 257
 258 Catalyst::Plugin::Cache -
 259
 260 =head1 SYNOPSIS
 261
 262         use Catalyst qw/
 263         Cache
 264     /;
 265
 266     # configure a backend or use a store plugin
 267     __PACKAGE__->config( cache => {
 268         backend => {
 269             class => "Cache::Bounded",
 270             # ... params ...
 271         },
 272     });
 273
 274     # ... in a controller
 275
 276     sub foo : Local {
 277         my ( $self, $c, $id ) = @_;
 278
 279         my $cache = $c->cache;
 280
 281         my $result;
 282
 283         unless ( $result = $cache->get( $id ) ) {
 284             # ... calulate result ...
 285             $c->cache->set( $id, $result );
 286         }
 287     };
 288
 289 =head1 DESCRIPTION
 290
 291 This plugin allows you to use a very simple configuration API without losing
 292 the possibility of flexibility when you need it later.
 293
 294 Amongst it's features are support for multiple backends, segmentation based on
 295 component or controller, keyspace partitioning and so forth, in various sub
 296 plugins.
 297
 298 =head1 CONFIGURATION
 299
 300   $c->config->{cache} = {
 301     backend => '',
 302   };
 303
 304 All configuration parameters should be provided in a hash reference under the
 305 C<cache> key in the C<config> hash.
 306
 307 =over 4
 308
 309 =item class
 310
 311 Load an entire set of Caching modules.
 312
 313 =item backend
 314
 315 The specific backend you want to use.
 316
 317 =item backends
 318
 319 A hashref with backend names as keys, and module names as values. One of these
 320 should have the key "default" to indicate the default backend.
 321
 322 =item default_store
 323
 324 The store you are using. This must be supplied if you have loaded multiple
 325 store plugins.
 326
 327 =item curried_class
 328
 329 The currying class you are using, defaults to L<Catalyst::Plugin::Cache::Curried>.
 330
 331 =item profiles
 332
 333 Supply your own predefined profiles for cache namespacing.
 334
 335
 336 =back
 337
 338 =head1 TERMINOLOGY
 339
 340 =over 4
 341
 342 =item backend
 343
 344 An object that responds to the methods detailed in
 345 L<Catalyst::Plugin::Cache::Backend> (or more).
 346
 347 =item store
 348
 349 A plugin that provides backends of a certain type. This is a bit like a factory.
 350
 351 =item cache
 352
 353 Stored key/value pairs of data for easy re-access.
 354
 355 =item curried cache
 356
 357   my $cache = $c->cache(type => 'thumbnails');
 358   $cache->set('pic01', $thumbnaildata);
 359
 360 A cache which has been pre-configured with a particular set of namespacing
 361 data. In the example the cache returned could be one specifically tuned
 362 for storing thumbnails.
 363
 364 An object that responds to C<get>, C<set> and C<remove>, and will automatically
 365 add meta data to calls to C<< $c->cache_get >>, etc.
 366
 367 =back
 368
 369 =cut
 370
 371