Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

add CHI root class configuration and subclassing

  • Loading branch information...
commit 66c8f75cee10633868e81eb8271aeadde83c7daf 1 parent d97abbf
@jonswar authored
Showing with 392 additions and 2 deletions.
  1. +269 −2 lib/CHI.pm
  2. +1 −0  lib/CHI/Driver.pm
  3. +119 −0 lib/CHI/t/Config.pm
  4. +3 −0  t/Config.t
View
271 lib/CHI.pm
@@ -5,13 +5,48 @@ use CHI::Stats;
use strict;
use warnings;
-my ( %final_class_seen, %stats );
+my ( %final_class_seen, %config, %memoized_cache_objects, %stats );
+
+my %valid_config_keys =
+ map { ( $_, 1 ) } qw(defaults memoize_cache_objects namespace storage);
sub logger {
warn
"CHI now uses Log::Any for logging - see Log::Any documentation for details";
}
+sub config {
+ my ( $class, $config ) = @_;
+
+ # Each CHI root class gets its own config hash
+ #
+ if ( defined($config) ) {
+ if ( my @bad_keys = grep { !$valid_config_keys{$_} } keys(%$config) ) {
+ croak "unknown keys in config hash: " . join( ", ", @bad_keys );
+ }
+ $config{$class} = $config;
+ }
+ else {
+ $config{$class} ||= {};
+ }
+ return $config{$class};
+}
+
+sub memoized_cache_objects {
+ my ($class) = @_;
+
+ # Each CHI root class gets its hash of memoized objects
+ #
+ $memoized_cache_objects{$class} ||= {};
+ return $memoized_cache_objects{$class};
+}
+
+sub clear_memoized_cache_objects {
+ my ($class) = @_;
+
+ $memoized_cache_objects{$class} = {};
+}
+
sub stats {
my ($class) = @_;
@@ -24,6 +59,41 @@ sub stats {
sub new {
my ( $chi_root_class, %params ) = @_;
+ my $config = $chi_root_class->config;
+
+ # Cache object memoization: See if cache object with these parameters
+ # has already been created, and return it if so. Only for parameters
+ # with 0 or 1 keys.
+ #
+ my ( $cache_object_key, $cache_objects );
+ if ( $config->{memoize_cache_objects} && keys(%params) <= 1 ) {
+ $cache_object_key = join chr(28), %params;
+ $cache_objects = $chi_root_class->memoized_cache_objects;
+ if ( my $cache_object = $cache_objects->{$cache_object_key} ) {
+ return $cache_object;
+ }
+ }
+
+ # Gather defaults
+ #
+ my $core_defaults = $config->{defaults} || {};
+ my $namespace_defaults =
+ $config->{namespace}->{ $params{namespace} || 'Default' } || {};
+ my $storage =
+ $params{storage}
+ || $namespace_defaults->{storage}
+ || $core_defaults->{storage};
+ my $storage_defaults = {};
+ if ( defined($storage) ) {
+ $storage_defaults = $config->{storage}->{$storage}
+ or croak "no config for storage type '$storage'";
+ }
+
+ # Combine passed params with defaults
+ #
+ %params =
+ ( %$core_defaults, %$storage_defaults, %$namespace_defaults, %params );
+
# Get driver class from driver or driver_class parameters
#
my $driver_class;
@@ -71,11 +141,21 @@ sub new {
$meta->add_method( 'meta' => sub { $meta } )
if !$final_class_seen{$final_class}++;
- return $final_class->new(
+ # Finally create the object
+ #
+ my $cache_object = $final_class->new(
chi_root_class => $chi_root_class,
driver_class => $driver_class,
%params
);
+
+ # Memoize if appropriate
+ #
+ if ($cache_object_key) {
+ $cache_objects->{$cache_object_key} = $cache_object;
+ }
+
+ return $cache_object;
}
1;
@@ -665,6 +745,11 @@ cache.
=over
+=item chi_root_class( )
+
+Returns the name of the root class under which this object was created, e.g.
+C<CHI> or C<My::CHI>. See L</SUBCLASSING AND CONFIGURING CHI>.
+
=item driver_class( )
Returns the full name of the driver class. e.g.
@@ -1013,6 +1098,188 @@ that can cause the size to grow inaccurate over time.
=for readme continue
+=head1 SUBCLASSING AND CONFIGURING CHI
+
+You can subclass CHI for your own application and configure it in a variety of
+ways, e.g. pre-defining storage types and defaults for new cache objects. Your
+configuration will be independent of the main CHI class and other CHI
+subclasses.
+
+Start with a trivial subclass:
+
+ package My::CHI;
+ use base qw(CHI);
+ 1;
+
+Then, just use your subclass in place of CHI:
+
+ my $cache = My::CHI->new( ... );
+
+ print $cache->chi_root_class;
+ ==> 'My::CHI'
+
+This obviously doesn't change any behavior by itself. Here's an example with
+actual config:
+
+ package My::CHI;
+ use base qw(CHI);
+
+ __PACKAGE__->config({
+ storage => {
+ local_file => { driver => 'File', root_dir => '/my/root' },
+ memcached => {
+ driver => 'Memcached::libmemcached',
+ servers => [ '10.0.0.15:11211', '10.0.0.15:11212' ]
+ },
+ },
+ namespace => {
+ 'Foo' => { storage => 'local_file' },
+ 'Bar' => { storage => 'local_file', depth => 3 },
+ 'Baz' => { storage => 'memcached' },
+ }
+ defaults => { storage => 'local_file' },
+ memoize_cache_objects => 1,
+ });
+
+ 1;
+
+Each of these config keys is explained in the next section.
+
+=head2 Configuration keys
+
+=over
+
+=item storage
+
+A map of names to parameter hashrefs. This provides a way to encapsulate common
+sets of parameters that might be used in many caches. e.g. if you define
+
+ storage => {
+ local_file => { driver => 'File', root_dir => '/my/root' },
+ ...
+ }
+
+then
+
+ my $cache = My::CHI->new
+ (namespace => 'Foo', storage => 'local_file');
+
+is equivalent to
+
+ my $cache = My::CHI->new
+ (namespace => 'Foo', driver => 'File', root_dir => '/my/root');
+
+=item namespace
+
+A map of namespace names to parameter hashrefs. When you create a cache object
+with the specified namespace, the hashref of parameters will be applied as
+defaults. e.g. if you define
+
+ namespace => {
+ 'Foo' => { driver => 'File', root_dir => '/my/root' },
+ 'Bar' => { storage => 'database' },
+ ...
+ }
+
+then
+
+ my $cache1 = My::CHI->new
+ (namespace => 'Foo');
+ my $cache2 = My::CHI->new
+ (namespace => 'Bar');
+
+is equivalent to
+
+ my $cache1 = My::CHI->new
+ (namespace => 'Foo', driver => 'File', root_dir => '/my/root');
+ my $cache2 = My::CHI->new
+ (namespace => 'Bar', storage => 'database');
+
+=item defaults
+
+A hash of parameters that will be used as core defaults for all cache objects
+created under this root class. e.g.
+
+ defaults => {
+ on_get_error => 'die',
+ expires_variance => 0.2,
+ }
+
+These can be overriden by namespace defaults, storage settings, or C<new>
+parameters.
+
+=item memoize_cache_objects
+
+True or false, indicates whether C<My::CHI-E<gt>new> should memoize and return
+the same cache object if given the same parameters. This can speed things up if
+you create cache objects frequently. Will currently only work for 0- or 1- key
+parameter hashes. e.g.
+
+ My::CHI->config({
+ memoize_cache_objects => 1,
+ });
+
+then
+
+ # $cache1 and $cache2 will be the same object, regardless of what
+ # namespace and storage defaults are associated with 'Foo'
+ #
+ my $cache1 = My::CHI->new(namespace => 'Foo');
+ my $cache2 = My::CHI->new(namespace => 'Foo');
+
+ # $cache3 and $cache4 will be different objects
+ #
+ my $cache3 = My::CHI->new
+ (namespace => 'Bar', driver => 'File', root_dir => '/my/root');
+ my $cache4 = My::CHI->new
+ (namespace => 'Bar', driver => 'File', root_dir => '/my/root');
+
+To clear the memoized cache objects, call
+
+ My::CHI->clear_memoized_cache_objects;
+
+=back
+
+=head2 How defaults are combined
+
+Defaults are applied in the following order, from highest to lowest precedence:
+
+=over
+
+=item *
+
+Parameters passed in C<new>
+
+=item *
+
+Namespace defaults, if any
+
+=item *
+
+Storage settings, if any
+
+=item *
+
+Core defaults defined under 'defaults'
+
+=back
+
+=head2 Initialization and inheritance of config
+
+Config starts out as an empty hash for each subclass. Config settings are not
+automatically inherited, but you can merge in the parent's config manually:
+
+ __PACKAGE__->config({
+ ...,
+ %{ __PACKAGE__->SUPER::config },
+ });
+
+=head2 Reading config from a file
+
+ use YAML::XS qw(LoadFile);
+
+ __PACKAGE__->config(LoadFile("/path/to/cache.yml"));
+
=head1 AVAILABILITY OF DRIVERS
The following drivers are currently available as part of this distribution:
View
1  lib/CHI/Driver.pm
@@ -47,6 +47,7 @@ has 'on_get_error' => ( is => 'rw', isa => 'CHI::Types::OnError', default
has 'on_set_error' => ( is => 'rw', isa => 'CHI::Types::OnError', default => 'log' );
has 'serializer' => ( is => 'ro', isa => 'CHI::Types::Serializer', coerce => 1, default => sub { $default_serializer } );
has 'short_driver_name' => ( is => 'ro', lazy_build => 1 );
+has 'storage' => ( is => 'ro' );
# These methods must be implemented by subclass
foreach my $method (qw(fetch store remove get_keys get_namespaces)) {
View
119 lib/CHI/t/Config.pm
@@ -0,0 +1,119 @@
+package CHI::t::Config;
+use CHI::Util qw(dump_one_line);
+use CHI::Test;
+use File::Temp qw(tempdir);
+use strict;
+use warnings;
+use base qw(CHI::Test::Class);
+
+my $root_dir = tempdir( 'CHI-t-Config-XXXX', TMPDIR => 1, CLEANUP => 1 );
+
+my %config = (
+ storage => {
+ memory => { driver => 'Memory', global => 1 },
+ file => { driver => 'File', root_dir => $root_dir },
+ memcached => {
+ driver => 'Memcached::libmemcached',
+ servers => [ '10.0.0.15:11211', '10.0.0.15:11212' ]
+ },
+ },
+ namespace => {
+ 'Foo' => { storage => 'file' },
+ 'Bar' => { storage => 'file', depth => 3 },
+ 'Baz' => { storage => 'memcached' },
+ },
+ defaults => { storage => 'memory' },
+);
+
+{
+ package My::CHI;
+ use base qw(CHI);
+ My::CHI->config( {%config} );
+}
+
+{
+ package Other::CHI;
+ use base qw(CHI);
+ My::CHI->config( { %config, memoize_cache_objects => 1 } );
+}
+
+sub _create {
+ my ( $params, $checks ) = @_;
+
+ my $desc = dump_one_line($params);
+ my $cache = My::CHI->new(%$params);
+ while ( my ( $key, $value ) = each(%$checks) ) {
+ is( $cache->$key, $value, "$key == $value ($desc)" );
+ }
+}
+
+sub test_memoize : Tests {
+ my $cache1 = My::CHI->new( namespace => 'Foo' );
+ my $cache2 = My::CHI->new( namespace => 'Foo' );
+ is( $cache1, $cache2, "same - namespace Foo" );
+
+ my $cache3 = My::CHI->new( namespace => 'Bar', depth => 4 );
+ my $cache4 = My::CHI->new( namespace => 'Bar', depth => 4 );
+ isnt( $cache3, $cache4, "different - namespace Bar" );
+
+ My::CHI->clear_memoized_cache_objects();
+ my $cache5 = My::CHI->new( namespace => 'Foo' );
+ my $cache6 = My::CHI->new( namespace => 'Foo' );
+ is( $cache5, $cache6, "same - namespace Foo" );
+ isnt( $cache1, $cache3, "different - post-clear" );
+}
+
+sub test_config : Tests {
+ my $self = shift;
+
+ _create(
+ { namespace => 'Foo' },
+ {
+ namespace => 'Foo',
+ storage => 'file',
+ short_driver_name => 'File',
+ root_dir => $root_dir,
+ depth => 2
+ },
+ );
+ _create(
+ { namespace => 'Bar' },
+ {
+ namespace => 'Bar',
+ storage => 'file',
+ short_driver_name => 'File',
+ root_dir => $root_dir,
+ depth => 3
+ }
+ );
+ _create(
+ { namespace => 'Foo', depth => 4 },
+ {
+ namespace => 'Foo',
+ storage => 'file',
+ short_driver_name => 'File',
+ root_dir => $root_dir,
+ depth => 4
+ }
+ );
+ _create(
+ { namespace => 'Bar', depth => 4 },
+ {
+ namespace => 'Bar',
+ storage => 'file',
+ short_driver_name => 'File',
+ root_dir => $root_dir,
+ depth => 4
+ }
+ );
+ _create(
+ { namespace => 'Baz' },
+ {
+ namespace => 'Baz',
+ storage => 'memcached',
+ short_driver_name => 'Memcached::libmemcached'
+ }
+ );
+}
+
+1;
View
3  t/Config.t
@@ -0,0 +1,3 @@
+#!perl -w
+use CHI::t::Config;
+CHI::t::Config->runtests;
Please sign in to comment.
Something went wrong with that request. Please try again.