File Coverage

blib/lib/CHI/Driver/Role/IsSizeAware.pm
Criterion Covered Total %
statement 54 59 91.5
branch 9 14 64.2
condition 4 4 100.0
subroutine 14 15 93.3
pod 0 3 0.0
total 81 95 85.2


line stmt bran cond sub pod time code
1             package CHI::Driver::Role::IsSizeAware;
2             $CHI::Driver::Role::IsSizeAware::VERSION = '0.61';
3 20     20   9942 use Carp::Assert;
  20         27103  
  20         148  
4 20     20   2628 use Moo::Role;
  20         46  
  20         176  
5 20     20   7908 use MooX::Types::MooseLike::Base qw(:all);
  20         49  
  20         6567  
6 20     20   163 use CHI::Types qw(:all);
  20         46  
  20         3464  
7 20     20   161 use strict;
  20         42  
  20         504  
8 20     20   107 use warnings;
  20         56  
  20         2742  
9              
10             has 'discard_policy' => ( is => 'lazy', isa => Maybe[DiscardPolicy] );
11             has 'discard_timeout' => ( is => 'rw', isa => Num, default => sub { 10 } );
12             has 'max_size' => ( is => 'rw', isa => MemorySize, coerce => \&to_MemorySize );
13             has 'max_size_reduction_factor' => ( is => 'rw', isa => Num, default => sub { 0.8 } );
14              
15 20     20   159 use constant Size_Key => 'CHI_IsSizeAware_size';
  20         46  
  20         18932  
16              
17             sub _build_discard_policy {
18 46     46   1017 my $self = shift;
19              
20 46 100       1016 return $self->can('default_discard_policy')
21             ? $self->default_discard_policy
22             : 'arbitrary';
23             }
24              
25             after 'BUILD_roles' => sub {
26             my ( $self, $params ) = @_;
27              
28             $self->{is_size_aware} = 1;
29             };
30              
31             after 'clear' => sub {
32             my $self = shift;
33              
34             $self->_set_size(0);
35             };
36              
37             around 'remove' => sub {
38             my $orig = shift;
39             my $self = shift;
40             my ($key) = @_;
41              
42             my ( $size_delta, $obj );
43             if ( !$self->{_no_set_size_on_remove}
44             && ( $obj = $self->get_object($key) ) )
45             {
46             $size_delta = -1 * $obj->size;
47             }
48             $self->$orig(@_);
49             if ($size_delta) {
50             $self->_add_to_size($size_delta);
51             }
52             };
53              
54             around 'set_object' => sub {
55             my ( $orig, $self, $key, $obj ) = @_;
56              
57             # If item exists, record its size so we can subtract it below
58             #
59             my $size_delta = 0;
60             if ( my $obj = $self->get_object($key) ) {
61             $size_delta = -1 * $obj->size;
62             }
63              
64             my $result = $self->$orig( $key, $obj );
65              
66             # Add to size and reduce size if over the maximum
67             #
68             $size_delta += $obj->size;
69             my $namespace_size = $self->_add_to_size($size_delta);
70              
71             if ( defined( $self->max_size )
72             && $namespace_size > $self->max_size )
73             {
74             $self->discard_to_size(
75             $self->max_size * $self->max_size_reduction_factor );
76             }
77              
78             return $result;
79             };
80              
81             sub get_size {
82 2286     2286 0 4147 my ($self) = @_;
83              
84 2286   100     47757 my $size = $self->metacache->get(Size_Key) || 0;
85 2286         112510 return $size;
86             }
87              
88             sub _set_size {
89 1804     1804   4065 my ( $self, $new_size ) = @_;
90              
91 1804         36071 $self->metacache->set( Size_Key, $new_size );
92             }
93              
94             sub _add_to_size {
95 1337     1337   3078 my ( $self, $incr ) = @_;
96              
97             # Non-atomic, so may be inaccurate over time
98 1337   100     3000 my $new_size = ( $self->get_size || 0 ) + $incr;
99 1337         4298 $self->_set_size($new_size);
100 1337         115536 return $new_size;
101             }
102              
103             sub discard_to_size {
104 339     339 0 7949 my ( $self, $ceiling ) = @_;
105              
106             # Get an iterator that produces keys in the order they should be removed
107             #
108 339         6787 my $discard_iterator =
109             $self->_get_iterator_for_discard_policy( $self->discard_policy );
110              
111             # Remove keys until we are under $ceiling. Temporarily turn off size
112             # setting on remove because we will set size once at end. Check if
113             # we exceed discard timeout.
114             #
115 339         8042 my $end_time = time + $self->discard_timeout;
116 339         3042 local $self->{_no_set_size_on_remove} = 1;
117 339         1015 my $size = $self->get_size();
118 339         718 eval {
119 339         1304 while ( $size > $ceiling ) {
120 909 50       2483 if ( defined( my $key = $discard_iterator->() ) ) {
121 909 50       2702 if ( my $obj = $self->get_object($key) ) {
122 909         23114 $self->remove($key);
123 909         3667 $size -= $obj->size;
124             }
125             }
126             else {
127 0     0   0 affirm { $self->is_empty }
128 0         0 "iterator returned undef, cache should be empty";
129 0         0 last;
130             }
131 909 50       4576 if ( time > $end_time ) {
132 0         0 die sprintf( "discard timeout (%s sec) reached",
133             $self->discard_timeout );
134             }
135             }
136             };
137 339         1219 $self->_set_size($size);
138 339 50       28234 die $@ if $@;
139             }
140              
141             sub _get_iterator_for_discard_policy {
142 339     339   4688 my ( $self, $discard_policy ) = @_;
143              
144 339 100       1187 if ( ref($discard_policy) eq 'CODE' ) {
145 70         313 return $discard_policy->($self);
146             }
147             else {
148 269         771 my $discard_policy_sub = "discard_policy_" . $discard_policy;
149 269 50       1616 if ( $self->can($discard_policy_sub) ) {
150 269         990 return $self->$discard_policy_sub();
151             }
152             else {
153 0         0 die sprintf( "cannot get iterator for discard policy '%s' ('%s')",
154             $discard_policy, $discard_policy_sub );
155             }
156             }
157             }
158              
159             sub discard_policy_arbitrary {
160 60     60 0 148 my ($self) = @_;
161              
162 60         297 return $self->get_keys_iterator();
163             }
164              
165             1;