File Coverage

blib/lib/CHI/Driver/Role/HasSubcaches.pm

Criterion	Covered	Total	%
statement	34	34	100.0
branch	4	4	100.0
condition			n/a
subroutine	11	11	100.0
pod			n/a
total	49	49	100.0

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'] ],
    );
}

has subcaches => (
    is       => 'lazy',
    init_arg => undef,
);

sub _build_subcaches {
    [ grep { defined $_ } $_[0]->l1_cache, $_[0]->mirror_cache ];
}

sub _build_has_subcaches { 1 }

# Call these methods first on the main cache, then on any subcaches.
#
foreach my $method (qw(clear expire purge remove set)) {
    after $method => sub {
        my $self      = shift;
        my $subcaches = $self->subcaches;
        foreach my $subcache (@$subcaches) {
            $subcache->$method(@_);
        }
    };
}

around 'get' => sub {
    my $orig = shift;
    my $self = shift;
    my ( $key, %params ) = @_;
    my $l1_cache = $self->l1_cache;

    if ( !defined($l1_cache) || $params{obj} ) {
        return $self->$orig(@_);
    }
    else {

        # Consult l1 cache first
        #
        if ( defined( my $value = $l1_cache->get(@_) ) ) {
            return $value;
        }
        else {
            my ( $key, %params ) = @_;
            $params{obj_ref} ||= \my $obj_store;
            my $value = $self->$orig( $key, %params );
            if ( defined($value) ) {

                # If found in primary cache, write back to l1 cache.
                #
                my $obj = ${ $params{obj_ref} };
                $l1_cache->set(
                    $key,
                    $obj->value,
                    {
                        expires_at       => $obj->expires_at,
                        early_expires_at => $obj->early_expires_at
                    }
                );
            }
            return $value;
        }
    }
};

around 'get_multi_arrayref' => sub {
    my $orig   = shift;
    my $self   = shift;
    my ($keys) = @_;

    my $l1_cache = $self->l1_cache;
    if ( !defined($l1_cache) ) {
        return $self->$orig(@_);
    }
    else {

        # Consult l1 cache first, then call on primary cache with remainder of keys,
        # and combine the arrays.
        #
        my $l1_values = $l1_cache->get_multi_arrayref($keys);
        my @indices   = ( 0 .. scalar(@$keys) - 1 );
        my @primary_keys =
          map { $keys->[$_] } grep { !defined( $l1_values->[$_] ) } @indices;
        my $primary_values = $self->$orig( \@primary_keys );
        my $values         = [
            map {
                defined( $l1_values->[$_] )
                  ? $l1_values->[$_]
                  : shift(@$primary_values)
            } @indices
        ];
        return $values;
    }
};

1;