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 TERMINOLIGY
 299
 300 =over 4
 301
 302 =item backend
 303
 304 An object that responds to the methods detailed in
 305 L<Catalyst::Plugin::Cache::Backend> (or more).
 306
 307 =item store
 308
 309 A plugin that provides backends of a certain type. This is a bit like a factory.
 310
 311 =item curried cache
 312
 313 An object that responds to C<get>, C<set> and C<remove>, and will automatically
 314 add meta data to calls to C<< $c->cache_get >>, etc.
 315
 316 =back
 317
 318 =cut
 319
 320