--- /dev/null
+#!/usr/bin/perl
+
+package Catalyst::Plugin::Cache;
+use base qw/Class::Data::Inheritable/;
+
+use strict;
+use warnings;
+
+use Scalar::Util ();
+use Carp ();
+use NEXT;
+
+__PACKAGE__->mk_classdata( "_cache_backends" );
+
+sub setup {
+ my $app = shift;
+
+ # set it once per app, not once per plugin,
+ # and don't overwrite if some plugin was wicked
+ $app->_cache_backends({}) unless $app->_cache_backends;
+
+ my $ret = $app->NEXT::setup( @_ );
+
+ $app->setup_cache_backends;
+
+ $ret;
+}
+
+sub setup_cache_backends { shift->NEXT::setup_cache_backends(@_) }
+
+sub cache {
+ my $c = shift;
+
+ if ( @_ ) {
+ my $name = shift;
+ $c->get_cache_backend($name);
+ } else {
+ $c->default_cache_backend;
+ }
+}
+
+sub get_cache_backend {
+ my ( $c, $name ) = @_;
+ $c->_cache_backends->{$name};
+}
+
+sub register_cache_backend {
+ my ( $c, $name, $backend ) = @_;
+
+ no warnings 'uninitialized';
+ Carp::croak("$backend does not look like a cache backend - "
+ . "it must be an object supporting get, set and delete")
+ unless eval { $backend->can("get") && $backend->can("set") && $backend->can("delete") };
+
+ $c->_cache_backends->{$name} = $backend;
+}
+
+sub unregister_cache_backend {
+ my ( $c, $name ) = @_;
+ delete $c->_cache_backends->{$name};
+}
+
+sub default_cache_backend {
+ my $c = shift;
+ $c->get_cache_backend( "default" ) || $c->temporary_cache_backend;
+}
+
+sub temporary_cache_backend {
+ my $c = shift;
+ die "FIXME - make up an in memory cache backend, that hopefully works well for the current engine";
+}
+
+# this gets a shit name so that the plugins can override a good name
+sub choose_cache_backend_wrapper {
+ my ( $c, @meta ) = @_;
+
+ Carp::croak("meta data must be an even sized list") unless @meta % 2 == 0;
+
+ my %meta = @meta;
+
+ # allow the cache client to specify who it wants to cache with (but loeave room for a hook)
+ if ( exists $meta{backend} ) {
+ if ( Scalar::Util::blessed($meta{backend}) ) {
+ return $meta{backend};
+ } else {
+ return $c->get_cache_backend( $meta{backend} ) || $c->default_cache_backend;
+ }
+ };
+
+
+ $meta{caller} = [ caller(2) ] unless exists $meta{caller}; # might be interesting
+
+ if ( my $chosen = $c->choose_cache_backend( %meta ) ) {
+ $chosen = $c->get_cache_backend( $chosen ) unless Scalar::Util::blessed($chosen); # if it's a name find it
+ return $chosen if Scalar::Util::blessed($chosen); # only return if it was an object or name lookup worked
+
+ # FIXME
+ # die "no such backend"?
+ # currently, we fall back to default
+ }
+
+ return $c->default_cache_backend;
+}
+
+sub choose_cache_backend { shift->NEXT::choose_cache_backend( @_ ) } # a convenient fallback
+
+sub cache_set {
+ my ( $c, $key, $value, @meta ) = @_;
+ $c->choose_cache_backend_wrapper( key => $key, value => $value, @meta )->set( $key, $value );
+}
+
+sub cache_get {
+ my ( $c, $key, @meta ) = @_;
+ $c->choose_cache_backend_wrapper( key => $key, @meta )->get( $key );
+}
+
+sub cache_delete {
+ my ( $c, $key, @meta ) = @_;
+ $c->choose_cache_backend_wrapper( key => $key, @meta )->delete( $key );
+}
+
+__PACKAGE__;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Catalyst::Plugin::Cache -
+
+=head1 SYNOPSIS
+
+ use Catalyst::Plugin::Cache;
+
+=head1 DESCRIPTION
+
+=cut
+
+
--- /dev/null
+#!/usr/bin/perl
+
+package Catalyst::Plugin::Cache::Backend;
+
+use strict;
+use warnings;
+
+sub set {
+ my ( $self, $key, $value ) = @_;
+}
+
+sub get {
+ my ( $self, $key ) = @_;
+}
+
+sub delete {
+ my ( $self, $key ) = @_;
+}
+
+__PACKAGE__;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Catalyst::Plugin::Cache::Backend - Bare minimum backend interface.
+
+=head1 SYNOPSIS
+
+ use Catalyst::Plugin::Cache::Backend;
+
+=head1 DESCRIPTION
+
+=cut
+
+
--- /dev/null
+#!/usr/bin/perl
+
+package Catalyst::Plugin::Cache::Backend::Util;
+
+use strict;
+use warnings;
+
+sub default_ttl {
+ my ( $self, $key ) = @_;
+ 2 * 60 * 60; # 2 hours
+}
+
+sub expires {
+ my ( $self, $key ) = @_;
+ time() + $self->default_ttl( $key );
+}
+
+sub serialize_value {
+
+}
+
+sub deserialize_value {
+
+}
+
+__PACKAGE__;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Catalyst::Plugin::Cache::Backend::Util - Useful base class methods for cache
+backends.
+
+=head1 SYNOPSIS
+
+ use Catalyst::Plugin::Cache::Backend::Util;
+
+=head1 DESCRIPTION
+
+=cut
+
+
--- /dev/null
+#!/usr/bin/perl
+
+package Catalyst::Plugin::Cache::Choose::KeyRegexes;
+
+use strict;
+use warnings;
+
+sub setup {
+ my $app = shift;
+ my $ret = $app->NEXT::setup( @_ );
+
+ my $regexes = $app->config->{cache}{key_regexes} ||= [];
+
+ die "the regex list must be an array containing regexex/backend pairs" unless ref $regexes eq "ARRAY";
+
+ $ret;
+}
+
+sub get_cache_key_regexes {
+ my ( $c, %meta ) = @_;
+ @{ $c->config->{cache}{key_regexes} };
+}
+
+sub choose_cache_backend {
+ my ( $c, %meta ) = @_;
+
+ my @regexes = $c->get_cache_key_regexes( %meta );
+
+ while ( @regexes and my ( $re, $backend ) = splice( @regexes, 0, 2 ) ) {
+ return $backend if $meta{key} =~ $re;
+ }
+
+ $c->NEXT::choose_cache_backend( %meta );
+}
+
+__PACKAGE__;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Catalyst::Plugin::Cache::Choose::KeyRegex - Choose a cache backend based on key regexes.
+
+=head1 SYNOPSIS
+
+ use Catalyst::Plugin::Cache::Choose::KeyRegex;
+
+=head1 DESCRIPTION
+
+=cut
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+use Test::Exception;
+
+use ok "Catalyst::Plugin::Cache";
+
+{
+ package MockApp;
+ use base qw/Catalyst::Plugin::Cache/;
+
+ package MemoryCache;
+ use Storable qw/freeze thaw/;
+
+ sub new { bless {}, shift }
+ sub get { ${thaw($_[0]{$_[1]}) || return} };
+ sub set { $_[0]{$_[1]} = freeze(\$_[2]) };
+ sub delete { delete $_[0]{$_[1]} };
+}
+
+MockApp->setup;
+my $c = bless {}, "MockApp";
+
+can_ok( $c, "register_cache_backend" );
+can_ok( $c, "unregister_cache_backend" );
+
+MockApp->register_cache_backend( default => MemoryCache->new );
+MockApp->register_cache_backend( moose => MemoryCache->new );
+
+can_ok( $c, "cache" );
+
+ok( $c->cache, "->cache returns a value" );
+
+can_ok( $c->cache, "get" ); #, "rv from cache" );
+can_ok( $c->cache("default"), "get" ); #, "default backend" );
+can_ok( $c->cache("moose"), "get" ); #, "moose backend" );
+
+ok( !$c->cache("lalalala"), "no lalala backend");
+
+MockApp->unregister_cache_backend( "moose" );
+
+ok( !$c->cache("moose"), "moose backend unregistered");
+
+
+dies_ok {
+ MockApp->register_cache_backend( ding => undef );
+} "can't register invalid backend";
+
+dies_ok {
+ MockApp->register_cache_backend( ding => bless {}, "SomeClass" );
+} "can't register invalid backend";
+
+
+
+can_ok( $c, "default_cache_backend" );
+is( $c->default_cache_backend, $c->cache, "cache with no args retrurns default" );
+
+can_ok( $c, "choose_cache_backend_wrapper" );
+can_ok( $c, "choose_cache_backend" );
+
+can_ok( $c, "cache_set" );
+can_ok( $c, "cache_get" );
+can_ok( $c, "cache_delete" );
+
+$c->cache_set( foo => "bar" );
+is( $c->cache_get("foo"), "bar", "set" );
+
+$c->cache_delete( "foo" );
+is( $c->cache_get("foo"), undef, "delete" );
+
+MockApp->register_cache_backend( elk => MemoryCache->new );
+
+is( $c->choose_cache_backend_wrapper( key => "foo" ), $c->default_cache_backend, "choose default" );
+is( $c->choose_cache_backend_wrapper( key => "foo", backend => "elk" ), $c->get_cache_backend("elk"), "override choice" );
+
+
+$c->cache_set( foo => "gorch", backend => "elk" );
+is( $c->cache_get("foo"), undef, "set to custom backend (get from non custom)" );
+is( $c->cache_get("foo", backend => "elk"), "gorch", "set to custom backend (get from custom)" );
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+use ok "Catalyst::Plugin::Cache";
+use ok "Catalyst::Plugin::Cache::Choose::KeyRegexes";
+
+{
+ package MockApp;
+ use base qw/Catalyst::Plugin::Cache Catalyst::Plugin::Cache::Choose::KeyRegexes/;
+
+ our %config = (
+ cache => {
+ key_regexes => [
+ qr/^foo/ => "foo_store",
+ qr/^bar/ => "bar_store",
+ ],
+ },
+ );
+ sub config { \%config }
+
+ package MemoryCache;
+ use Storable qw/freeze thaw/;
+
+ sub new { bless {}, shift }
+ sub get { ${thaw($_[0]{$_[1]}) || return} };
+ sub set { $_[0]{$_[1]} = freeze(\$_[2]) };
+ sub delete { delete $_[0]{$_[1]} };
+}
+
+
+MockApp->setup;
+my $c = bless {}, "MockApp";
+
+MockApp->register_cache_backend( default => MemoryCache->new );
+MockApp->register_cache_backend( foo_store => MemoryCache->new );
+MockApp->register_cache_backend( bar_store => MemoryCache->new );
+
+is( $c->choose_cache_backend_wrapper( key => "baz" ), $c->cache, "chose default" );
+is( $c->choose_cache_backend_wrapper( key => "foo" ), $c->cache("foo_store"), "chose foo" );
+is( $c->choose_cache_backend_wrapper( key => "bar" ), $c->cache("bar_store"), "chose bar" );
+
+$c->cache_set( foo_laa => "laa" );
+$c->cache_set( bar_laa => "laa" );
+$c->cache_set( baz_laa => "laa" );
+
+is( $c->cache->get("baz_laa"), "laa", "non match stored in default" );
+is( $c->cache->get("foo_laa"), undef, "no foo key" );
+is( $c->cache->get("bar_laa"), undef, "no bar key" );
+
+
+is( $c->cache("foo_store")->get("baz_laa"), undef, "no non match in foo store" );
+is( $c->cache("foo_store")->get("foo_laa"), "laa", "has foo key" );
+is( $c->cache("foo_store")->get("bar_laa"), undef, "no bar key" );
+
+
+is( $c->cache("bar_store")->get("baz_laa"), undef, "no non match in bar store" );
+is( $c->cache("bar_store")->get("foo_laa"), undef, "no foo key" );
+is( $c->cache("bar_store")->get("bar_laa"), "laa", "has bar key" );
+
+
projects / catagits/Catalyst-Plugin-Cache.git / commitdiff