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


line stmt bran cond sub pod time code
1             package CHI::Driver::Role::HasSubcaches;
2             $CHI::Driver::Role::HasSubcaches::VERSION = '0.60';
3 20     20   91 use Moo::Role;
  20         28  
  20         163  
4 20     20   15674 use CHI::Types qw(:all);
  20         49  
  20         4342  
5 20     20   132 use MooX::Types::MooseLike::Base qw(:all);
  20         29  
  20         6449  
6 20     20   10759 use Hash::MoreUtils qw(slice_exists);
  20         22834  
  20         1347  
7 20     20   125 use Log::Any qw($log);
  20         34  
  20         194  
8 20     20   1751 use Scalar::Util qw(weaken);
  20         34  
  20         1031  
9 20     20   97 use strict;
  20         38  
  20         689  
10 20     20   81 use warnings;
  20         31  
  20         15738  
11              
12             my @subcache_nonoverride_params =
13             qw(expires_at expires_in expires_variance serializer);
14              
15             sub _non_overridable {
16 138     138   90535 my $params = shift;
17 138 100       676 if ( is_HashRef($params) ) {
18 137 100       1927 if (
19 548         1808 my @nonoverride =
20             grep { exists $params->{$_} } @subcache_nonoverride_params
21             )
22             {
23 6         97 warn sprintf( "cannot override these keys in a subcache: %s",
24             join( ", ", @nonoverride ) );
25 6         376 delete( @$params{@nonoverride} );
26             }
27             }
28 138         3637 return $params;
29             }
30              
31             my @subcache_inherited_params = (
32             qw(expires_at expires_in expires_variance namespace on_get_error on_set_error serializer)
33             );
34             for my $type (qw(l1_cache mirror_cache)) {
35             my $config_acc = "_${type}_config";
36             has $config_acc => (
37             is => 'ro',
38             init_arg => $type,
39             isa => HashRef,
40             coerce => \&_non_overridable,
41             );
42              
43             my $default = sub {
44             my $self = shift;
45             my $config = $self->$config_acc or return undef;
46              
47             my %inherit = map { ( defined $self->$_ ) ? ( $_ => $self->$_ ) : () }
48             @subcache_inherited_params;
49             my $build_config = {
50             %inherit,
51             label => $self->label . ":$type",
52             %$config,
53             is_subcache => 1,
54             parent_cache => $self,
55             subcache_type => $type,
56             };
57              
58             return $self->chi_root_class->new(%$build_config);
59             };
60              
61             has $type => (
62             is => 'ro',
63             lazy => 1,
64             init_arg => undef,
65             default => $default,
66             isa => Maybe [ InstanceOf ['CHI::Driver'] ],
67             );
68             }
69              
70             has subcaches => (
71             is => 'lazy',
72             init_arg => undef,
73             );
74              
75             sub _build_subcaches {
76 121     121   8613 [ grep { defined $_ } $_[0]->l1_cache, $_[0]->mirror_cache ];
  242         10055  
77             }
78              
79 20     20   4180 sub _build_has_subcaches { 1 }
80              
81             # Call these methods first on the main cache, then on any subcaches.
82             #
83             foreach my $method (qw(clear expire purge remove set)) {
84             after $method => sub {
85             my $self = shift;
86             my $subcaches = $self->subcaches;
87             foreach my $subcache (@$subcaches) {
88             $subcache->$method(@_);
89             }
90             };
91             }
92              
93             around 'get' => sub {
94             my $orig = shift;
95             my $self = shift;
96             my ( $key, %params ) = @_;
97             my $l1_cache = $self->l1_cache;
98              
99             if ( !defined($l1_cache) || $params{obj} ) {
100             return $self->$orig(@_);
101             }
102             else {
103              
104             # Consult l1 cache first
105             #
106             if ( defined( my $value = $l1_cache->get(@_) ) ) {
107             return $value;
108             }
109             else {
110             my ( $key, %params ) = @_;
111             $params{obj_ref} ||= \my $obj_store;
112             my $value = $self->$orig( $key, %params );
113             if ( defined($value) ) {
114              
115             # If found in primary cache, write back to l1 cache.
116             #
117             my $obj = ${ $params{obj_ref} };
118             $l1_cache->set(
119             $key,
120             $obj->value,
121             {
122             expires_at => $obj->expires_at,
123             early_expires_at => $obj->early_expires_at
124             }
125             );
126             }
127             return $value;
128             }
129             }
130             };
131              
132             around 'get_multi_arrayref' => sub {
133             my $orig = shift;
134             my $self = shift;
135             my ($keys) = @_;
136              
137             my $l1_cache = $self->l1_cache;
138             if ( !defined($l1_cache) ) {
139             return $self->$orig(@_);
140             }
141             else {
142              
143             # Consult l1 cache first, then call on primary cache with remainder of keys,
144             # and combine the arrays.
145             #
146             my $l1_values = $l1_cache->get_multi_arrayref($keys);
147             my @indices = ( 0 .. scalar(@$keys) - 1 );
148             my @primary_keys =
149             map { $keys->[$_] } grep { !defined( $l1_values->[$_] ) } @indices;
150             my $primary_values = $self->$orig( \@primary_keys );
151             my $values = [
152             map {
153             defined( $l1_values->[$_] )
154             ? $l1_values->[$_]
155             : shift(@$primary_values)
156             } @indices
157             ];
158             return $values;
159             }
160             };
161              
162             1;