File Coverage

blib/lib/Cache/Memory.pm
Criterion Covered Total %
statement 139 144 96.5
branch 33 48 68.7
condition 9 13 69.2
subroutine 24 26 92.3
pod 8 18 44.4
total 213 249 85.5


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Cache::Memory - Memory based implementation of the Cache interface
4              
5             =head1 SYNOPSIS
6              
7             use Cache::Memory;
8              
9             my $cache = Cache::Memory->new( namespace => 'MyNamespace',
10             default_expires => '600 sec' );
11              
12             See Cache for the usage synopsis.
13              
14             =head1 DESCRIPTION
15              
16             The Cache::Memory class implements the Cache interface. This cache stores
17             data on a per-process basis. This is the fastest of the cache
18             implementations, but is memory intensive and data can not be shared between
19             processes. It also does not persist after the process dies. However data will
20             remain in the cache until cleared or it expires. The data will be shared
21             between instances of the cache object, a cache object going out of scope will
22             not destroy the data.
23              
24             =cut
25             package Cache::Memory;
26              
27             require 5.006;
28 6     6   5778 use strict;
  6         14  
  6         234  
29 6     6   35 use warnings;
  6         13  
  6         182  
30 6     6   5911 use Heap::Fibonacci;
  6         13860  
  6         203  
31 6     6   3794 use Cache::Memory::HeapElem;
  6         20  
  6         176  
32 6     6   3756 use Cache::Memory::Entry;
  6         53  
  6         211  
33              
34 6     6   35 use base qw(Cache);
  6         12  
  6         774  
35 6     6   35 use fields qw(namespace);
  6         12  
  6         30  
36              
37             our $VERSION = '2.10';
38              
39              
40             # storage for all data
41             # data is stored in the form:
42             # $Store{ns}{key}{data,exp_elem,age_elem,use_elem,rc,validity,handlelock}
43             #
44             # Cache::Memory::Entry elements will be passed the final hash as a reference
45             # when they are constructed. This reference MUST point to the SAME hash for
46             # all entries (and also must be the hash in Store{ns}{key}) or data
47             # inconsistency will occur. However this means that the key has to persist in
48             # the store whilst entries exist - regardless of whether there is data stored
49             # in it or not. In order to allow the Store{ns}{key} to be safely removed, a
50             # 'rc' field is used to track the number of entries that have been created for
51             # the key.
52             my %Store;
53              
54             # store sizes
55             my %Store_Sizes;
56              
57             # heaps for all the different orderings
58             # Expiry_Heap is shared between all namespaces
59             my Heap $Expiry_Heap = Heap::Fibonacci->new();
60             # In the form $Age_Heaps{namespace} and $Use_Heaps{namespace}
61             my %Age_Heaps;
62             my %Use_Heaps;
63              
64              
65             my $DEFAULT_NAMESPACE = '_';
66              
67              
68             =head1 CONSTRUCTOR
69              
70             my $cache = Cache::Memory->new( %options )
71              
72             The constructor takes cache properties as named arguments, for example:
73              
74             my $cache = Cache::Memory->new( namespace => 'MyNamespace',
75             default_expires => '600 sec' );
76              
77             See 'PROPERTIES' below and in the Cache documentation for a list of all
78             available properties that can be set.
79              
80             =cut
81              
82             sub _init_ns_heaps {
83 11     11   24 my ($self, $ns) = @_;
84              
85 11   66     87 $Age_Heaps{$ns} ||= Heap::Fibonacci->new();
86 11   66     172 $Use_Heaps{$ns} ||= Heap::Fibonacci->new();
87              
88 11         55 return;
89             }
90              
91             sub new {
92 6     6 0 3124 my Cache::Memory $self = shift;
93 6 100       39 my $args = $#_? { @_ } : shift;
94              
95 6 50       54 $self = fields::new($self) unless ref $self;
96 6         36336 $self->SUPER::new($args);
97              
98 6   33     46 my $ns = $args->{namespace} || $DEFAULT_NAMESPACE;
99 6         15 $self->{namespace} = $ns;
100              
101 6         29 $self->_init_ns_heaps($ns);
102              
103 6         25 return $self;
104             }
105              
106             =head1 METHODS
107              
108             See 'Cache' for the API documentation.
109              
110             =cut
111              
112             sub entry {
113 241     241 1 512 my Cache::Memory $self = shift;
114 241         357 my ($key) = @_;
115 241         599 my $ns = $self->{namespace};
116              
117 241   100     2303 $Store{$ns}{$key} ||= {};
118 241         1029 return Cache::Memory::Entry->new($self, $key, $Store{$ns}{$key});
119             }
120              
121             sub purge {
122             #my Cache::Memory $self = shift;
123 321     321 1 420 my $time = time();
124 321         1454 while (my $minimum = $Expiry_Heap->minimum) {
125 8 100       80 $minimum->val() <= $time
126             or last;
127 1         11 $Expiry_Heap->extract_minimum;
128              
129 1         14 my $min_key = $minimum->key();
130 1         6 my $min_ns = $minimum->namespace();
131              
132 1         4 my $store_entry = $Store{$min_ns}{$min_key};
133              
134 1 50       8 $minimum == delete $store_entry->{exp_elem}
135             or die 'Cache::Memory data structure(s) corrupted';
136              
137             # there should always be an age element
138 1 50       7 my $age_elem = delete $store_entry->{age_elem}
139             or die 'Cache::Memory data structure(s) corrupted';
140 1         6 $Age_Heaps{$min_ns}->delete($age_elem);
141              
142             # there should always be a last use element
143 1 50       10 my $use_elem = delete $store_entry->{use_elem}
144             or die 'Cache::Memory data structure(s) corrupted';
145 1         6 $Use_Heaps{$min_ns}->delete($use_elem);
146              
147             # remove data & decrease store size
148 1         7 $Store_Sizes{$min_ns} -= length(${delete $store_entry->{data}});
  1         3  
149              
150             # remove entire entry if there are no active Entry objects
151 1 50       10 delete $Store{$min_ns}{$min_key} unless $store_entry->{rc};
152             }
153             }
154              
155             sub clear {
156 4     4 1 11 my Cache::Memory $self = shift;
157 4         10 my $ns = $self->{namespace};
158              
159             # empty store & remove elements from expiry heap
160 4         9 my $nsstore = $Store{$ns};
161 4         16 foreach my $key (keys %$nsstore) {
162 2         4 my $store_entry = $nsstore->{$key};
163              
164             # simplified form of remove (doesn't deal with heaps)
165 2         6 my $exp_elem = delete $store_entry->{exp_elem};
166 2 50       7 $Expiry_Heap->delete($exp_elem) if $exp_elem;
167 2         5 delete $store_entry->{age_elem};
168 2         5 delete $store_entry->{use_elem};
169 2         5 delete $store_entry->{data};
170              
171             # remove entire entry if there are no active Entry objects
172 2 50       20 delete $nsstore->{$key} unless $store_entry->{rc};
173             }
174              
175             # reset store size
176 4         10 $Store_Sizes{$ns} = 0;
177              
178             # recreate age and used heaps (thus emptying them)
179 4         15 $self->_init_ns_heaps($ns);
180              
181 4         10 return;
182             }
183              
184             sub count {
185 7     7 1 12 my Cache::Memory $self = shift;
186 7         11 my $count = 0;
187 7         12 my $nsstore = $Store{$self->{namespace}};
188 7         55 foreach my $key (keys %$nsstore) {
189 106 50       259 $count++ if defined $nsstore->{$key}->{data};
190             }
191 7         39 return $count;
192             }
193              
194             sub size {
195 35     35 1 69 my Cache::Memory $self = shift;
196 35   100     493 return $Store_Sizes{$self->{namespace}} || 0;
197             }
198              
199              
200             =head1 PROPERTIES
201              
202             Cache::Memory adds the property 'namespace', which allows you to specify a
203             different caching store area to use from the default. All methods will work
204             ONLY on the namespace specified.
205              
206             my $ns = $c->namespace();
207             $c->set_namespace( $namespace );
208              
209             For additional properties, see the 'Cache' documentation.
210              
211             =cut
212              
213             sub namespace {
214 0     0 0 0 my Cache::Memory $self = shift;
215 0         0 return $self->{namespace};
216             }
217              
218             sub set_namespace {
219 1     1 0 1 my Cache::Memory $self = shift;
220 1         2 my ($namespace) = @_;
221              
222 1         7 $self->_init_ns_heaps($namespace);
223              
224 1         2 $self->{namespace} = $namespace;
225             }
226              
227              
228             # REMOVAL STRATEGY METHODS
229              
230             sub remove_oldest {
231 4     4 1 5 my Cache::Memory $self = shift;
232 4 50       14 my $minimum = $Age_Heaps{$self->{namespace}}->minimum
233             or return undef;
234 4 50       33 $minimum == $Store{$minimum->namespace()}{$minimum->key()}{age_elem}
235             or die 'Cache::Memory data structure(s) corrupted';
236 4         11 return $self->remove($minimum->key());
237             }
238              
239             sub remove_stalest {
240 4     4 1 9 my Cache::Memory $self = shift;
241 4 50       16 my $minimum = $Use_Heaps{$self->{namespace}}->minimum
242             or return undef;
243 4 50       116 $minimum == $Store{$minimum->namespace()}{$minimum->key()}{use_elem}
244             or die 'Cache::Memory data structure(s) corrupted';
245 4         13 return $self->remove($minimum->key());
246             }
247              
248              
249             # SHORTCUT METHODS
250              
251             sub remove {
252 241     241 1 355 my Cache::Memory $self = shift;
253 241         714 my ($key) = @_;
254              
255 241         348 my $ns = $self->{namespace};
256              
257 241 100       856 my $store_entry = $Store{$ns}{$key}
258             or return undef;
259              
260 240 100       641 defined $store_entry->{data}
261             or return undef;
262              
263             # remove from heap
264 230         293 my $exp_elem = delete $store_entry->{exp_elem};
265 230 100       447 $Expiry_Heap->delete($exp_elem) if $exp_elem;
266              
267 230 50       576 my $age_elem = delete $store_entry->{age_elem}
268             or die 'Cache::Memory data structure(s) corrupted';
269 230         653 $Age_Heaps{$ns}->delete($age_elem);
270              
271 230 50       1712 my $use_elem = delete $store_entry->{use_elem}
272             or die 'Cache::Memory data structure(s) corrupted';
273 230         773 $Use_Heaps{$ns}->delete($use_elem);
274              
275             # reduce size of cache iff there is no active handle
276 230         1559 my $size = 0;
277 230         654 my $dataref = delete $store_entry->{data};
278 230 100       593 unless (exists $store_entry->{handlelock}) {
279 229         263 $size = length($$dataref);
280 229         335 $Store_Sizes{$ns} -= $size;
281             }
282              
283 230         619 delete $store_entry->{handlelock};
284              
285             # remove entire entry if there are no active Entry objects
286 230 100       742 delete $Store{$ns}{$key} unless $store_entry->{rc};
287              
288 230         1149 return $size;
289             }
290              
291              
292             # UTILITY METHODS
293              
294             sub add_expiry_to_heap {
295 3     3 0 4 my Cache::Memory $self = shift;
296 3         7 my ($key, $time) = @_;
297              
298 3         14 my $exp_elem = Cache::Memory::HeapElem->new($self->{namespace},$key,$time);
299 3         10 $Expiry_Heap->add($exp_elem);
300 3         23 return $exp_elem;
301             }
302              
303             sub del_expiry_from_heap {
304 0     0 0 0 my Cache::Memory $self = shift;
305 0         0 my ($key, $exp_elem) = @_;
306              
307 0         0 $Expiry_Heap->delete($exp_elem);
308             }
309              
310             sub add_age_to_heap {
311 244     244 0 490 my Cache::Memory $self = shift;
312 244         314 my ($key, $time) = @_;
313 244         347 my $ns = $self->{namespace};
314              
315 244         1248 my $age_elem = Cache::Memory::HeapElem->new($ns,$key,$time);
316 244         843 $Age_Heaps{$ns}->add($age_elem);
317 244         4795 return $age_elem;
318             }
319              
320             sub add_use_to_heap {
321 244     244 0 373 my Cache::Memory $self = shift;
322 244         586 my ($key, $time) = @_;
323 244         932 my $ns = $self->{namespace};
324              
325 244         675 my $use_elem = Cache::Memory::HeapElem->new($ns,$key,$time);
326 244         919 $Use_Heaps{$ns}->add($use_elem);
327 244         1506 return $use_elem;
328             }
329              
330             sub update_last_used {
331 22     22 0 46 my Cache::Memory $self = shift;
332 22         45 my ($key) = @_;
333 22         45 my $ns = $self->{namespace};
334              
335 22 50       249 my $use_elem = $Store{$ns}{$key}{use_elem}
336             or die 'Cache::Memory data structure(s) corrupted';
337              
338 22         90 $Use_Heaps{$ns}->delete($use_elem);
339 22         449 $use_elem->val(time());
340 22         86 $Use_Heaps{$ns}->add($use_elem);
341             }
342              
343             sub change_size {
344 251     251 0 458 my Cache::Memory $self = shift;
345 251         398 my ($size) = @_;
346 251         471 my $ns = $self->{namespace};
347              
348 251         437 $Store_Sizes{$ns} += $size;
349 251 100       1120 $self->check_size($Store_Sizes{$ns}) if $size > 0;
350             }
351              
352             sub entry_dropped_final_rc {
353 238     238 0 506 my Cache::Memory $self = shift;
354 238         338 my ($key) = @_;
355 238         645 my $ns = $self->{namespace};
356              
357 238 100       2472 delete $Store{$ns}{$key} unless defined $Store{$ns}{$key}{data};
358             }
359              
360              
361             1;
362             __END__