diff --git a/lib/CHI.pm b/lib/CHI.pm index 25b55f3..275c62c 100644 --- a/lib/CHI.pm +++ b/lib/CHI.pm @@ -6,6 +6,7 @@ use CHI::Stats; use String::RewritePrefix; use Module::Runtime qw(require_module); use Moo::Role (); +use Hash::MoreUtils qw(slice_grep); use strict; use warnings; @@ -36,6 +37,81 @@ sub _set_config { *{"$class\::_get_config"} = sub { $config }; } +sub _defaults { + my ( $class, $params, $config ) = @_; + + $params ||= {}; + $config ||= $class->config || {}; + + my $no_defaults_for; + if ( my $reftype = ref( $no_defaults_for = $params->{no_defaults_for} ) ) { + croak "'no_defaults_for' must be an array reference or string" + unless $reftype eq 'ARRAY'; + } + else { + $no_defaults_for = [ $no_defaults_for || () ]; + } + + # Create a hash that maps top-level constructor keys to '1' for each + # attribute that should not have a default value loaded from core, + # namespace, or storage defaults. + # + my %no_defaults_for_map = map { $_ => 1 } @$no_defaults_for; + + # Returns a hash reference containing each key => value pair from the + # provided hash reference for which '$no_defaults_for{$key}' does not + # evaluate to '1'. + # + my $filter_default_values = sub { + return {} unless defined $_[0]; + return { slice_grep { !$no_defaults_for_map{$_} } $_[0] }; + }; + + # Takes a key into the '$params' hash reference and an optional default + # value in case '$params' does not contain the provided key. Looks up the + # resolved key in the '$config' hash reference, returning a hash reference + # containing all key => value pairs for which '$no_defaults_for{$key}' + # does not evaluate to '1'. If the provided key cannot be found in + # '$params' and the default value is undefined, returns an empty hash + # reference. + # + # For example: + # + # $params = {namespace => 'Foo'}; + # $config = {namespace => {Foo => {storage => 'File'} + # $no_defaults_for => ['label']; + # $defaults = $extract_defaults->('namespace', 'Default'); + # # $defaults == {storage => 'File'} + # + my $extract_defaults = sub { + my ( $key, $fallback ) = @_; + + my $found = $params->{$key}; + $found ||= $fallback unless $no_defaults_for_map{$key}; + + return {} unless defined $found; + + return $filter_default_values->( $config->{$key}{$found} ); + }; + + my $core_defaults = $filter_default_values->( $config->{defaults} ); + + my $namespace_defaults = $extract_defaults->( 'namespace', 'Default' ); + + my $storage_defaults = $extract_defaults->( + 'storage', $namespace_defaults->{storage} || $core_defaults->{storage}, + ); + + return ( $core_defaults, $storage_defaults, $namespace_defaults ); +} + +# Merges the hash references returned by '_defaults', preferring namespace +# defaults to storage defaults and storage defaults to core defaults. +# +sub defaults { + return { map { %$_ } &_defaults }; +} + BEGIN { __PACKAGE__->config( {} ) } sub memoized_cache_objects { @@ -80,25 +156,15 @@ sub new { } } - # Gather defaults + # Combine passed-in arguments with 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'"; - } + my $defaults = $chi_root_class->defaults( \%params, $config ); + %params = ( %$defaults, %params ); - # Combine passed params with defaults - # - %params = - ( %$core_defaults, %$storage_defaults, %$namespace_defaults, %params ); + my $storage = $params{storage}; + if ( defined $storage && !exists $config->{storage}{$storage} ) { + croak "no config for storage type '$storage'"; + } # Get driver class from driver or driver_class parameters # @@ -200,7 +266,7 @@ CHI - Unified cache handling interface ); # Create your own driver - # + # my $cache = CHI->new( driver => '+My::Special::Driver', ... ); # Cache operations @@ -455,7 +521,30 @@ C unless preceded with a '+'. e.g. traits => ['StoresAccessedAt', '+My::CHI::Driver::Role'] -=back +=item no_defaults_for [LISTREF] + +List of one or more default settings (see L) +to ignore when instantiating the object. + + My::CHI->config({ + storage => { + local_file => { driver => 'File', root_dir => '/my/root' }, + }, + defaults => { + storage => 'local_file', + label => 'static-assets', + }, + }); + + My::CHI->new->label; # "static-assets" + My::CHI->new( no_defaults_for => ['label'] )->label; # "File" + +Duplicate values are removed upon assignment: + + my $cache = My::CHI->new(no_defaults_for => [qw(storage storage storage)]) + $cache->no_defaults_for; # ["storage"] + +=back =head1 INSTANCE METHODS @@ -823,6 +912,7 @@ e.g. namespace serializer + no_defaults_for =back @@ -1418,7 +1508,7 @@ from the logs and report a summary. See L for details. CHI is intended as an evolution of DeWitt Clinton's L package. It starts with the same basic API (which has proven durable over time) but addresses some implementation shortcomings -that cannot be fixed in Cache::Cache due to backward compatibility concerns. +that cannot be fixed in Cache::Cache due to backward compatibility concerns. In particular: =over diff --git a/lib/CHI/Driver.pm b/lib/CHI/Driver.pm index d21cd00..866453f 100644 --- a/lib/CHI/Driver.pm +++ b/lib/CHI/Driver.pm @@ -139,6 +139,11 @@ my @common_params; storage => { is => 'ro', }, + no_defaults_for => { + is => 'ro', + isa => ArrayRef [Str], + coerce => \&to_UniqArrayRef, + }, ); push @common_params, keys %attr; for my $attr ( keys %attr ) { diff --git a/lib/CHI/Driver/Role/HasSubcaches.pm b/lib/CHI/Driver/Role/HasSubcaches.pm index 2763672..5dbd152 100644 --- a/lib/CHI/Driver/Role/HasSubcaches.pm +++ b/lib/CHI/Driver/Role/HasSubcaches.pm @@ -3,7 +3,6 @@ package CHI::Driver::Role::HasSubcaches; use Moo::Role; use CHI::Types qw(:all); use MooX::Types::MooseLike::Base qw(:all); -use Hash::MoreUtils qw(slice_exists); use Log::Any qw($log); use Scalar::Util qw(weaken); use strict; @@ -31,7 +30,10 @@ sub _non_overridable { my @subcache_inherited_params = ( qw(expires_at expires_in expires_variance namespace on_get_error on_set_error serializer) ); -for my $type (qw(l1_cache mirror_cache)) { + +my @subcache_types = qw(l1_cache mirror_cache); + +for my $type (@subcache_types) { my $config_acc = "_${type}_config"; has $config_acc => ( is => 'ro', @@ -46,13 +48,21 @@ for my $type (qw(l1_cache mirror_cache)) { my %inherit = map { ( defined $self->$_ ) ? ( $_ => $self->$_ ) : () } @subcache_inherited_params; + + # Don't instantiate the subcache with another subcache that's defined + # using the core, namespace or storage defaults. + # + my @no_defaults_for = @{ $self->no_defaults_for || [] }; + push @no_defaults_for, @subcache_types; + my $build_config = { %inherit, label => $self->label . ":$type", %$config, - is_subcache => 1, - parent_cache => $self, - subcache_type => $type, + is_subcache => 1, + parent_cache => $self, + subcache_type => $type, + no_defaults_for => \@no_defaults_for, }; return $self->chi_root_class->new(%$build_config); diff --git a/lib/CHI/Types.pm b/lib/CHI/Types.pm index 2b8656d..1093e4a 100644 --- a/lib/CHI/Types.pm +++ b/lib/CHI/Types.pm @@ -2,6 +2,7 @@ package CHI::Types; use Carp; use CHI::Util qw(can_load parse_duration parse_memory_size); +use List::MoreUtils qw(uniq); use MooX::Types::MooseLike qw(exception_message); use MooX::Types::MooseLike::Base qw(:all); use MooX::Types::MooseLike::Numeric qw(:all); @@ -125,6 +126,25 @@ sub to_Digester { } push @EXPORT_OK, 'to_Digester'; +# Strip duplicates from an array reference. Also accepts a single string. +# Passes through any values other than array references so that they can be +# caught by 'isa' constraints. +# +sub to_UniqArrayRef { + my $from = shift; + + if ( is_ArrayRef($from) ) { + [ uniq @$from ]; + } + elsif ( is_Str($from) ) { + [$from]; + } + else { + return $from; + } +} +push @EXPORT_OK, 'to_UniqArrayRef'; + my $data_serializer_loaded = can_load('Data::Serializer'); sub _build_data_serializer { diff --git a/lib/CHI/t/Config.pm b/lib/CHI/t/Config.pm index 701b8bd..18af6d0 100644 --- a/lib/CHI/t/Config.pm +++ b/lib/CHI/t/Config.pm @@ -15,8 +15,9 @@ my %config = ( file => { driver => 'File', root_dir => $root_dir }, }, namespace => { - 'Foo' => { storage => 'file' }, - 'Bar' => { storage => 'file', depth => 3 }, + 'Foo' => { label => 'FooCache', storage => 'file' }, + 'Bar' => { label => 'BarCache', storage => 'file', depth => 3 }, + 'Default' => { label => 'JohnnyCache' }, }, defaults => { storage => 'memory' }, ); @@ -41,6 +42,23 @@ my %config = ( My::CHI::Memo->config( { %config, memoize_cache_objects => 1 } ); } +{ + package My::CHI::Subcaching; + + use base qw(CHI); + My::CHI::Subcaching->config( + { + %config, + defaults => { + storage => 'file', + l1_cache => { + storage => 'memory', + }, + }, + } + ); +} + sub _create { my ( $params, $checks ) = @_; @@ -56,10 +74,20 @@ sub _create { sub test_config : Tests { my $self = shift; + _create( + {}, + { + namespace => 'Default', + label => 'JohnnyCache', + storage => 'memory', + short_driver_name => 'Memory', + } + ); _create( { namespace => 'Foo' }, { namespace => 'Foo', + label => 'FooCache', storage => 'file', short_driver_name => 'File', root_dir => $root_dir, @@ -70,6 +98,7 @@ sub test_config : Tests { { namespace => 'Bar' }, { namespace => 'Bar', + label => 'BarCache', storage => 'file', short_driver_name => 'File', root_dir => $root_dir, @@ -80,6 +109,7 @@ sub test_config : Tests { { namespace => 'Foo', depth => 4 }, { namespace => 'Foo', + label => 'FooCache', storage => 'file', short_driver_name => 'File', root_dir => $root_dir, @@ -90,12 +120,31 @@ sub test_config : Tests { { namespace => 'Bar', depth => 4 }, { namespace => 'Bar', + label => 'BarCache', storage => 'file', short_driver_name => 'File', root_dir => $root_dir, depth => 4 } ); + _create( + { no_defaults_for => [qw(namespace)] }, + { + namespace => 'Default', + label => 'Memory', + storage => 'memory', + short_driver_name => 'Memory', + } + ); + _create( + { namespace => 'Foo', no_defaults_for => [qw(label)] }, + { + namespace => 'Foo', + label => 'File', + storage => 'file', + short_driver_name => 'File', + } + ); my %new_config = %config; $new_config{namespace}->{'Bar'}->{depth} = 5; @@ -104,6 +153,7 @@ sub test_config : Tests { { namespace => 'Bar' }, { namespace => 'Bar', + label => 'BarCache', storage => 'file', short_driver_name => 'File', root_dir => $root_dir, @@ -132,4 +182,26 @@ sub test_memoize : Tests { isnt( $cache7, $cache8, "different - namespace Foo - no memoization" ); } +sub test_subcache_constructor_args : Tests { + my $subcaching1 = My::CHI::Subcaching->new; + + is( $subcaching1->l1_cache->can('l1_cache'), + undef, 'l1_cache not automatically built with nested l1_cache' ); + + my $subcaching2 = My::CHI::Subcaching->new( + l1_cache => { + storage => 'memory', + l1_cache => { + driver => '+CHI::Driver::Null', + }, + }, + ); + + is( + $subcaching2->l1_cache->l1_cache->driver_class, + 'CHI::Driver::Null', + 'driver of nested subcache not overriden by default settings', + ); +} + 1; diff --git a/lib/CHI/t/Driver.pm b/lib/CHI/t/Driver.pm index 944e26d..4549469 100644 --- a/lib/CHI/t/Driver.pm +++ b/lib/CHI/t/Driver.pm @@ -222,6 +222,17 @@ sub test_driver_class : Tests { can_ok( $cache, 'get', 'set', 'remove', 'clear', 'expire' ); } +sub test_no_defaults_for : Tests { + my $self = shift; + + my $cache1 = $self->new_cache( no_defaults_for => [ qw(storage) x (3) ] ); + is_deeply( $cache1->no_defaults_for, [qw(storage)], 'duplicates removed' ); + + my $cache2 = $self->new_cache( no_defaults_for => 'label' ); + is_deeply( $cache2->no_defaults_for, [qw(label)], + 'coerces string to arrayref' ); +} + sub test_key_types : Tests { my $self = shift; my $cache = $self->{cache};