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