view release on metacpan or  search on metacpan

lib/CHI/Driver/Role/HasSubcaches.pm  view on Meta::CPAN

package CHI::Driver::Role::HasSubcaches;
$CHI::Driver::Role::HasSubcaches::VERSION = '0.61';
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;
use warnings;

my @subcache_nonoverride_params =
  qw(expires_at expires_in expires_variance serializer);

sub _non_overridable {
    my $params = shift;
    if ( is_HashRef($params) ) {
        if (
            my @nonoverride =
            grep { exists $params->{$_} } @subcache_nonoverride_params
          )
        {
            warn sprintf( "cannot override these keys in a subcache: %s",
                join( ", ", @nonoverride ) );
            delete( @$params{@nonoverride} );
        }
    }
    return $params;
}

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 $config_acc = "_${type}_config";
    has $config_acc => (
        is       => 'ro',
        init_arg => $type,
        isa      => HashRef,
        coerce   => \&_non_overridable,
    );

    my $default = sub {
        my $self = shift;
        my $config = $self->$config_acc or return undef;

        my %inherit = map { ( defined $self->$_ ) ? ( $_ => $self->$_ ) : () }
          @subcache_inherited_params;
        my $build_config = {
            %inherit,
            label => $self->label . ":$type",
            %$config,
            is_subcache   => 1,
            parent_cache  => $self,
            subcache_type => $type,
        };

        return $self->chi_root_class->new(%$build_config);
    };

    has $type => (
        is       => 'ro',
        lazy     => 1,
        init_arg => undef,
        default  => $default,
        isa      => Maybe [ InstanceOf ['CHI::Driver'] ],
    );
}