lib/Catalyst/Plugin/Cache.pm

   1 #!/usr/bin/perl
   2
   3 package Catalyst::Plugin::Cache;
   4 use base qw(Class::Accessor::Fast Class::Data::Inheritable);
   5
   6 use strict;
   7 use warnings;
   8
   9 our $VERSION = "0.08";
  10
  11 use Scalar::Util ();
  12 use Catalyst::Utils ();
  13 use Carp ();
  14 use MRO::Compat;
  15
  16 use Catalyst::Plugin::Cache::Curried;
  17
  18 __PACKAGE__->mk_classdata( "_cache_backends" );
  19 __PACKAGE__->mk_accessors( "_default_curried_cache" );
  20
  21 sub setup {
  22     my $app = shift;
  23
  24     # set it once per app, not once per plugin,
  25     # and don't overwrite if some plugin was wicked
  26     $app->_cache_backends({}) unless $app->_cache_backends;
  27
  28     my $ret = $app->maybe::next::method( @_ );
  29
  30     $app->setup_cache_backends;
  31
  32     $ret;
  33 }
  34 {
  35     my %has_warned_for;
  36     sub _get_cache_plugin_config {
  37         my ($app) = @_;
  38         my $config = $app->config->{'Plugin::Cache'};
  39         if (!$config) {
  40             $config = $app->config->{cache};
  41             my $appname = ref($app);
  42             if (! $has_warned_for{$appname}++ ) {
  43                 $app->log->warn($config ?
  44                     'Catalyst::Plugin::Cache config found in deprecated $c->config->{cache}, please move to $c->config->{"Plugin::Cache"}.'
  45                     : 'Catalyst::Plugin::Cache config not found, using empty config!'
  46                 );
  47             }
  48         }
  49         return $config || {};
  50     }
  51 }
  52
  53 sub get_default_cache_backend_config {
  54     my ( $app, $name ) = @_;
  55     $app->_get_cache_plugin_config->{backend} || $app->get_cache_backend_config("default");
  56 }
  57
  58 sub get_cache_backend_config {
  59     my ( $app, $name ) = @_;
  60     $app->_get_cache_plugin_config->{backends}{$name};
  61 }
  62
  63 sub setup_cache_backends {
  64     my $app = shift;
  65
  66     # give plugins a chance to find things for themselves
  67     $app->maybe::next::method;
  68
  69     # FIXME - Don't know why the _get_cache_plugin_config method doesn't work here!
  70     my $conf = $app->_get_cache_plugin_config->{backends};
  71     foreach my $name ( keys %$conf ) {
  72         next if $app->get_cache_backend( $name );
  73         $app->setup_generic_cache_backend( $name, $app->get_cache_backend_config( $name ) || {} );
  74     }
  75
  76     if ( !$app->get_cache_backend("default") ) {
  77         ### XXX currently we dont have a fallback scenario
  78         ### so die here with the error message. Once we have
  79         ### an in memory fallback, we may consider silently
  80         ### logging the error and falling back to that.
  81         ### If we dont die here, the app will silently start
  82         ### up and then explode at the first cache->get or
  83         ### cache->set request with a FIXME error
  84         #local $@;
  85         #eval {
  86         $app->setup_generic_cache_backend( default => $app->get_default_cache_backend_config || {} );
  87         #};
  88
  89    }
  90 }
  91
  92 sub default_cache_store {
  93     my $app = shift;
  94     $app->_get_cache_plugin_config->{default_store} || $app->guess_default_cache_store;
  95 }
  96
  97 sub guess_default_cache_store {
  98     my $app = shift;
  99
 100     my @stores = map { /Cache::Store::(.*)$/ ? $1 : () } $app->registered_plugins;
 101
 102     if ( @stores == 1 ) {
 103         return $stores[0];
 104     } else {
 105         Carp::croak "You must configure a default store type unless you use exactly one store plugin.";
 106     }
 107 }
 108
 109 sub setup_generic_cache_backend {
 110     my ( $app, $name, $config ) = @_;
 111     my %config = %$config;
 112
 113     if ( my $class = delete $config{class} ) {
 114
 115         ### try as list and as hashref, collect the
 116         ### error if things go wrong
 117         ### if all goes well, exit the loop
 118         my @errors;
 119         for my $aref ( [%config], [\%config] ) {
 120             eval { $app->setup_cache_backend_by_class(
 121                         $name, $class, @$aref
 122                     );
 123             } ? do { @errors = (); last }
 124               : push @errors, "\t$@";
 125         }
 126
 127         ### and die with the errors if we have any
 128         die "Couldn't construct $class with either list style or hash ref style param passing:\n @errors" if @errors;
 129
 130     } elsif ( my $store = delete $config->{store} || $app->default_cache_store ) {
 131         my $method = lc("setup_${store}_cache_backend");
 132
 133         Carp::croak "You must load the $store cache store plugin (if it exists). ".
 134         "Please consult the Catalyst::Plugin::Cache documentation on how to configure hetrogeneous stores."
 135             unless $app->can($method);
 136
 137         $app->$method( $name, \%config );
 138     } else {
 139         $app->log->warn("Couldn't setup the cache backend named '$name'");
 140     }
 141 }
 142
 143 sub setup_cache_backend_by_class {
 144     my ( $app, $name, $class, @args ) = @_;
 145     Catalyst::Utils::ensure_class_loaded( $class );
 146     $app->register_cache_backend( $name => $class->new( @args ) );
 147 }
 148
 149 # end of spaghetti setup DWIM
 150
 151 sub cache {
 152     my ( $c, @meta ) = @_;
 153
 154     if ( @meta == 1 ) {
 155         my $name = $meta[0];
 156         return ( $c->get_preset_curried($name) || $c->get_cache_backend($name) );
 157     } elsif ( !@meta ) {
 158         # be nice and always return the same one for the simplest case
 159         return ( $c->_default_curried_cache || $c->_default_curried_cache( $c->curry_cache( @meta ) ) );
 160     } else {
 161         return $c->curry_cache( @meta );
 162     }
 163 }
 164
 165 sub construct_curried_cache {
 166     my ( $c, @meta ) = @_;
 167     return $c->curried_cache_class( @meta )->new( @meta );
 168 }
 169
 170 sub curried_cache_class {
 171     my ( $c, @meta ) = @_;
 172     $c->_get_cache_plugin_config->{curried_class} || "Catalyst::Plugin::Cache::Curried";
 173 }
 174
 175 sub curry_cache {
 176     my ( $c, @meta ) = @_;
 177     return $c->construct_curried_cache( $c, $c->_cache_caller_meta, @meta );
 178 }
 179
 180 sub get_preset_curried {
 181     my ( $c, $name ) = @_;
 182
 183     if ( ref( my $preset = $c->_get_cache_plugin_config->{profiles}{$name} ) ) {
 184         return $preset if Scalar::Util::blessed($preset);
 185
 186         my @meta = ( ( ref $preset eq "HASH" ) ? %$preset : @$preset );
 187         return $c->curry_cache( @meta );
 188     }
 189
 190     return;
 191 }
 192
 193 sub get_cache_backend {
 194     my ( $c, $name ) = @_;
 195     $c->_cache_backends->{$name};
 196 }
 197
 198 sub register_cache_backend {
 199     my ( $c, $name, $backend ) = @_;
 200
 201     no warnings 'uninitialized';
 202     Carp::croak("$backend does not look like a cache backend - "
 203     . "it must be an object supporting get, set and remove")
 204         unless eval { $backend->can("get") && $backend->can("set") && $backend->can("remove") };
 205
 206     $c->_cache_backends->{$name} = $backend;
 207 }
 208
 209 sub unregister_cache_backend {
 210     my ( $c, $name ) = @_;
 211     delete $c->_cache_backends->{$name};
 212 }
 213
 214 sub default_cache_backend {
 215     my $c = shift;
 216     $c->get_cache_backend( "default" ) || $c->temporary_cache_backend;
 217 }
 218
 219 sub temporary_cache_backend {
 220     my $c = shift;
 221     die "FIXME - make up an in memory cache backend, that hopefully works well for the current engine";
 222 }
 223
 224 sub _cache_caller_meta {
 225     my $c = shift;
 226
 227     my ( $caller, $component, $controller );
 228
 229     for my $i ( 0 .. 15 ) { # don't look to far
 230         my @info = caller(2 + $i) or last;
 231
 232         $caller     ||= \@info unless $info[0] =~ /Plugin::Cache/;
 233         $component  ||= \@info if $info[0]->isa("Catalyst::Component");
 234         $controller ||= \@info if $info[0]->isa("Catalyst::Controller");
 235
 236         last if $caller && $component && $controller;
 237     }
 238
 239     my ( $caller_pkg, $component_pkg, $controller_pkg ) =
 240         map { $_ ? $_->[0] : undef } $caller, $component, $controller;
 241
 242     return (
 243         'caller'   => $caller_pkg,
 244         component  => $component_pkg,
 245         controller => $controller_pkg,
 246         caller_frame     => $caller,
 247         component_frame  => $component,
 248         controller_frame => $controller,
 249     );
 250 }
 251
 252 # this gets a shit name so that the plugins can override a good name
 253 sub choose_cache_backend_wrapper {
 254     my ( $c, @meta ) = @_;
 255
 256     Carp::croak("metadata must be an even sized list") unless @meta % 2 == 0;
 257
 258     my %meta = @meta;
 259
 260     unless ( exists $meta{'caller'} ) {
 261         my %caller = $c->_cache_caller_meta;
 262         @meta{keys %caller} = values %caller;
 263     }
 264
 265     # allow the cache client to specify who it wants to cache with (but loeave room for a hook)
 266     if ( exists $meta{backend} ) {
 267         if ( Scalar::Util::blessed($meta{backend}) ) {
 268             return $meta{backend};
 269         } else {
 270             return $c->get_cache_backend( $meta{backend} ) || $c->default_cache_backend;
 271         }
 272     };
 273
 274     if ( my $chosen = $c->choose_cache_backend( %meta ) ) {
 275         $chosen = $c->get_cache_backend( $chosen ) unless Scalar::Util::blessed($chosen); # if it's a name find it
 276         return $chosen if Scalar::Util::blessed($chosen); # only return if it was an object or name lookup worked
 277
 278         # FIXME
 279         # die "no such backend"?
 280         # currently, we fall back to default
 281     }
 282
 283     return $c->default_cache_backend;
 284 }
 285
 286 sub choose_cache_backend { shift->maybe::next::method( @_ ) } # a convenient fallback
 287
 288 sub cache_set {
 289     my ( $c, $key, $value, %meta ) = @_;
 290     $c->choose_cache_backend_wrapper( key =>  $key, value => $value, %meta )
 291         ->set( $key, $value, exists $meta{expires} ? $meta{expires} : () );
 292 }
 293
 294 sub cache_get {
 295     my ( $c, $key, @meta ) = @_;
 296     $c->choose_cache_backend_wrapper( key => $key, @meta )->get( $key );
 297 }
 298
 299 sub cache_remove {
 300     my ( $c, $key, @meta ) = @_;
 301     $c->choose_cache_backend_wrapper( key => $key, @meta )->remove( $key );
 302 }
 303
 304 sub cache_compute {
 305     my ($c, $key, $code, %meta) = @_;
 306
 307     my $backend = $c->choose_cache_backend_wrapper( key =>  $key, %meta );
 308     if ($backend->can('compute')) {
 309         return $backend->compute( $key, $code, exists $meta{expires} ? $meta{expires} : () );
 310     }
 311
 312     Carp::croak "must specify key and code" unless defined($key) && defined($code);
 313
 314     my $value = $c->cache_get( $key, %meta );
 315     if ( !defined $value ) {
 316         $value = $code->();
 317         $c->cache_set( $key, $value, %meta );
 318     }
 319     return $value;
 320 }
 321
 322 __PACKAGE__;
 323
 324 __END__
 325
 326 =pod
 327
 328 =head1 NAME
 329
 330 Catalyst::Plugin::Cache - Flexible caching support for Catalyst.
 331
 332 =head1 SYNOPSIS
 333
 334         use Catalyst qw/
 335         Cache
 336     /;
 337
 338     # configure a backend or use a store plugin
 339     __PACKAGE__->config->{'Plugin::Cache'}{backend} = {
 340         class => "Cache::Bounded",
 341         # ... params for Cache::Bounded...
 342     };
 343
 344     # typical example for Cache::Memcached::libmemcached
 345     __PACKAGE__->config->{'Plugin::Cache'}{backend} = {
 346         class   => "Cache::Memcached::libmemcached",
 347         servers => ['127.0.0.1:11211'],
 348         debug   => 2,
 349     };
 350
 351
 352     # In a controller:
 353
 354     sub foo : Local {
 355         my ( $self, $c, $id ) = @_;
 356
 357         my $cache = $c->cache;
 358
 359         my $result;
 360
 361         unless ( $result = $cache->get( $id ) ) {
 362             # ... calculate result ...
 363             $c->cache->set( $id, $result );
 364         }
 365     };
 366
 367 =head1 DESCRIPTION
 368
 369 This plugin gives you access to a variety of systems for caching
 370 data. It allows you to use a very simple configuration API, while
 371 maintaining the possibility of flexibility when you need it later.
 372
 373 Among its features are support for multiple backends, segmentation based
 374 on component or controller, keyspace partitioning, and so more, in
 375 various subsidiary plugins.
 376
 377 =head1 METHODS
 378
 379 =over 4
 380
 381 =item cache $profile_name
 382
 383 =item cache %meta
 384
 385 Return a curried object with metadata from C<$profile_name> or as
 386 explicitly specified.
 387
 388 If a profile by the name C<$profile_name> doesn't exist, but a backend
 389 object by that name does exist, the backend will be returned instead,
 390 since the interface for curried caches and backends is almost identical.
 391
 392 This method can also be called without arguments, in which case is
 393 treated as though the C<%meta> hash was empty.
 394
 395 See L</METADATA> for details.
 396
 397 =item curry_cache %meta
 398
 399 Return a L<Catalyst::Plugin::Cache::Curried> object, curried with C<%meta>.
 400
 401 See L</METADATA> for details.
 402
 403 =item cache_set $key, $value, %meta
 404
 405 =item cache_get $key, %meta
 406
 407 =item cache_remove $key, %meta
 408
 409 =item cache_compute $key, $code, %meta
 410
 411 These cache operations will call L<choose_cache_backend> with %meta, and
 412 then call C<set>, C<get>, C<remove>, or C<compute> on the resulting backend
 413 object.
 414
 415 If the backend object does not support C<compute> then we emulate it by
 416 calling L<cache_get>, and if the returned value is undefined we call the passed
 417 code reference, stores the returned value with L<cache_set>, and then returns
 418 the value.  Inspired by L<CHI>.
 419
 420 =item choose_cache_backend %meta
 421
 422 Select a backend object. This should return undef if no specific backend
 423 was selected - its caller will handle getting C<default_cache_backend>
 424 on its own.
 425
 426 This method is typically used by plugins.
 427
 428 =item get_cache_backend $name
 429
 430 Get a backend object by name.
 431
 432 =item default_cache_backend
 433
 434 Return the default backend object.
 435
 436 =item temporary_cache_backend
 437
 438 When no default cache backend is configured this method might return a
 439 backend known to work well with the current L<Catalyst::Engine>. This is
 440 a stub.
 441
 442 =item
 443
 444 =back
 445
 446 =head1 METADATA
 447
 448 =head2 Introduction
 449
 450 Whenever you set or retrieve a key you may specify additional metadata
 451 that will be used to select a specific backend.
 452
 453 This metadata is very freeform, and the only key that has any meaning by
 454 default is the C<backend> key which can be used to explicitly choose a backend
 455 by name.
 456
 457 The C<choose_cache_backend> method can be overridden in order to
 458 facilitate more intelligent backend selection. For example,
 459 L<Catalyst::Plugin::Cache::Choose::KeyRegexes> overrides that method to
 460 select a backend based on key regexes.
 461
 462 Another example is a L<Catalyst::Plugin::Cache::ControllerNamespacing>,
 463 which wraps backends in objects that perform key mangling, in order to
 464 keep caches namespaced per controller.
 465
 466 However, this is generally left as a hook for larger, more complex
 467 applications. Most configurations should make due XXXX
 468
 469 The simplest way to dynamically select a backend is based on the
 470 L</Cache Profiles> configuration.
 471
 472 =head2 Meta Data Keys
 473
 474 C<choose_cache_backend> is called with some default keys.
 475
 476 =over 4
 477
 478 =item key
 479
 480 Supplied by C<cache_get>, C<cache_set>, and C<cache_remove>.
 481
 482 =item value
 483
 484 Supplied by C<cache_set>.
 485
 486 =item caller
 487
 488 The package name of the innermost caller that doesn't match
 489 C<qr/Plugin::Cache/>.
 490
 491 =item caller_frame
 492
 493 The entire C<caller($i)> frame of C<caller>.
 494
 495 =item component
 496
 497 The package name of the innermost caller who C<isa>
 498 L<Catalyst::Component>.
 499
 500 =item component_frame
 501
 502 This entire C<caller($i)> frame of C<component>.
 503
 504 =item controller
 505
 506 The package name of the innermost caller who C<isa>
 507 L<Catalyst::Controller>.
 508
 509 =item controller_frame
 510
 511 This entire C<caller($i)> frame of C<controller>.
 512
 513 =back
 514
 515 =head2 Metadata Currying
 516
 517 In order to avoid specifying C<%meta> over and over again you may call
 518 C<cache> or C<curry_cache> with C<%meta> once, and get back a B<curried
 519 cache object>. This object responds to the methods C<get>, C<set>, and
 520 C<remove>, by appending its captured metadata and delegating them to
 521 C<cache_get>, C<cache_set>, and C<cache_remove>.
 522
 523 This is simpler than it sounds.
 524
 525 Here is an example using currying:
 526
 527     my $cache = $c->cache( %meta ); # cache is curried
 528
 529     $cache->set( $key, $value );
 530
 531     $cache->get( $key );
 532
 533 And here is an example without using currying:
 534
 535     $c->cache_set( $key, $value, %meta );
 536
 537     $c->cache_get( $key, %meta );
 538
 539 See L<Catalyst::Plugin::Cache::Curried> for details.
 540
 541 =head1 CONFIGURATION
 542
 543     $c->config->{'Plugin::Cache'} = {
 544         ...
 545     };
 546
 547 All configuration parameters should be provided in a hash reference
 548 under the C<Plugin::Cache> key in the C<config> hash.
 549
 550 =head2 Backend Configuration
 551
 552 Configuring backend objects is done by adding hash entries under the
 553 C<backends> key in the main config.
 554
 555 A special case is that the hash key under the C<backend> (singular) key
 556 of the main config is assumed to be the backend named C<default>.
 557
 558 =over 4
 559
 560 =item class
 561
 562 Instantiate a backend from a L<Cache> compatible class. E.g.
 563
 564     $c->config->{'Plugin::Cache'}{backends}{small_things} = {
 565         class    => "Cache::Bounded",
 566         interval => 1000,
 567         size     => 10000,
 568     };
 569
 570     $c->config->{'Plugin::Cache'}{backends}{large_things} = {
 571         class => "Cache::Memcached",
 572         data  => '1.2.3.4:1234',
 573     };
 574
 575 The options in the hash are passed to the class's C<new> method.
 576
 577 The class will be C<required> as necessary during setup time.
 578
 579 =item store
 580
 581 Instantiate a backend using a store plugin, e.g.
 582
 583     $c->config->{'Plugin::Cache'}{backend} = {
 584         store => "FastMmap",
 585     };
 586
 587 Store plugins typically require less configuration because they are
 588 specialized for L<Catalyst> applications. For example
 589 L<Catalyst::Plugin::Cache::Store::FastMmap> will specify a default
 590 C<share_file>, and additionally use a subclass of L<Cache::FastMmap>
 591 that can also store non reference data.
 592
 593 The store plugin must be loaded.
 594
 595 =back
 596
 597 =head2 Cache Profiles
 598
 599 =over 4
 600
 601 =item profiles
 602
 603 Supply your own predefined profiles for cache metadata, when using the
 604 C<cache> method.
 605
 606 For example when you specify
 607
 608     $c->config->{'Plugin::Cache'}{profiles}{thumbnails} = {
 609         backend => "large_things",
 610     };
 611
 612 And then get a cache object like this:
 613
 614     $c->cache("thumbnails");
 615
 616 It is the same as if you had done:
 617
 618     $c->cache( backend => "large_things" );
 619
 620 =back
 621
 622 =head2 Miscellaneous Configuration
 623
 624 =over 4
 625
 626 =item default_store
 627
 628 When you do not specify a C<store> parameter in the backend
 629 configuration this one will be used instead. This configuration
 630 parameter is not necessary if only one store plugin is loaded.
 631
 632 =back
 633
 634 =head1 TERMINOLOGY
 635
 636 =over 4
 637
 638 =item backend
 639
 640 An object that responds to the methods detailed in
 641 L<Catalyst::Plugin::Cache::Backend> (or more).
 642
 643 =item store
 644
 645 A plugin that provides backends of a certain type. This is a bit like a
 646 factory.
 647
 648 =item cache
 649
 650 Stored key/value pairs of data for easy re-access.
 651
 652 =item metadata
 653
 654 "Extra" information about the item being stored, which can be used to
 655 locate an appropriate backend.
 656
 657 =item curried cache
 658
 659   my $cache = $c->cache(type => 'thumbnails');
 660   $cache->set('pic01', $thumbnaildata);
 661
 662 A cache which has been pre-configured with a particular set of
 663 namespacing data. In the example the cache returned could be one
 664 specifically tuned for storing thumbnails.
 665
 666 An object that responds to C<get>, C<set>, and C<remove>, and will
 667 automatically add metadata to calls to C<< $c->cache_get >>, etc.
 668
 669 =back
 670
 671 =head1 SEE ALSO
 672
 673 L<Cache> - the generic cache API on CPAN.
 674
 675 L<Catalyst::Plugin::Cache::Store> - how to write a store plugin.
 676
 677 L<Catalyst::Plugin::Cache::Curried> - the interface for curried caches.
 678
 679 L<Catalyst::Plugin::Cache::Choose::KeyRegexes> - choose a backend based on
 680 regex matching on the keys. Can be used to partition the keyspace.
 681
 682 L<Catalyst::Plugin::Cache::ControllerNamespacing> - wrap backend objects in a
 683 name mangler so that every controller gets its own keyspace.
 684
 685 =head1 AUTHOR
 686
 687 Yuval Kogman, C<nothingmuch@woobling.org>
 688
 689 Jos Boumans, C<kane@cpan.org>
 690
 691 =head1 COPYRIGHT & LICENSE
 692
 693 Copyright (c) Yuval Kogman, 2006. All rights reserved.
 694
 695 This library is free software, you can redistribute it and/or modify it under
 696 the same terms as Perl itself, as well as under the terms of the MIT license.
 697
 698 =cut
 699