File Coverage

blib/lib/Cache.pm
Criterion Covered Total %
statement 86 133 64.6
branch 17 30 56.6
condition 3 5 60.0
subroutine 24 41 58.5
pod 19 26 73.0
total 149 235 63.4


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Cache - the Cache interface
4              
5             =head1 DESCRIPTION
6              
7             The Cache modules are designed to assist a developer in persisting data for a
8             specified period of time. Often these modules are used in web applications to
9             store data locally to save repeated and redundant expensive calls to remote
10             machines or databases.
11              
12             The Cache interface is implemented by derived classes that store cached data
13             in different manners (such as files on a filesystem, or in memory).
14              
15             =head1 USAGE
16              
17             To use the Cache system, a cache implementation must be chosen to suit your
18             needs. The most common is Cache::File, which is suitable for sharing data
19             between multiple invocations and even between concurrent processes.
20              
21             Using a cache is simple. Here is some very simple sample code for
22             instantiating and using a file system based cache.
23              
24             use Cache::File;
25              
26             my $cache = Cache::File->new( cache_root => '/tmp/cacheroot' );
27             my $customer = $cache->get( $name );
28              
29             unless ($customer) {
30             $customer = get_customer_from_db( $name );
31             $cache->set( $name, $customer, '10 minutes' );
32             }
33              
34             return $customer;
35              
36             Of course, far more powerful methods are available for accessing cached data.
37             Also see the TIE INTERFACE below.
38              
39             =head1 METHODS
40              
41             =over
42              
43             =cut
44             package Cache;
45              
46             require 5.006;
47 7     7   735 use strict;
  7         10  
  7         233  
48 7     7   28 use warnings;
  7         8  
  7         150  
49 7     7   34 use Carp;
  7         8  
  7         482  
50 7     7   3334 use Date::Parse;
  7         44952  
  7         808  
51              
52             # For registering the 'Cache' category. See:
53             # https://rt.cpan.org/Public/Bug/Display.html?id=95608
54 7     7   47 use warnings::register;
  7         11  
  7         943  
55              
56 7     7   45 use base qw(Tie::Hash);
  7         7  
  7         3876  
57 7         35 use fields qw(
58             default_expires removal_strategy size_limit
59 7     7   8487 load_callback validate_callback);
  7         8227  
60              
61             our $VERSION = '2.11';
62              
63             our $EXPIRES_NOW = 'now';
64             our $EXPIRES_NEVER = 'never';
65              
66             # map of expiration formats to their respective time in seconds
67             my %_Expiration_Units = ( map(($_, 1), qw(s second seconds sec)),
68             map(($_, 60), qw(m minute minutes min)),
69             map(($_, 60*60), qw(h hour hours)),
70             map(($_, 60*60*24), qw(d day days)),
71             map(($_, 60*60*24*7), qw(w week weeks)),
72             map(($_, 60*60*24*30), qw(M month months)),
73             map(($_, 60*60*24*365), qw(y year years)) );
74              
75              
76             sub new {
77 7     7 0 15 my Cache $self = shift;
78 7 50       23 my $args = $#_? { @_ } : shift;
79              
80 7 50       21 ref $self or croak 'Must use a subclass of Cache';
81              
82 7         44 $self->set_default_expires($args->{default_expires});
83              
84             # set removal strategy
85 7   100     55 my $strategy = $args->{removal_strategy} || 'Cache::RemovalStrategy::LRU';
86 7 50       20 unless (ref($strategy)) {
87 7 50       394 eval "require $strategy" or die @_;
88 7         50 $strategy = $strategy->new();
89             }
90 7         17 $self->{removal_strategy} = $strategy;
91              
92             # set size limit
93 7         16 $self->{size_limit} = $args->{size_limit};
94              
95             # set load callback
96 7         51 $self->set_load_callback($args->{load_callback});
97              
98             # set load callback
99 7         42 $self->set_validate_callback($args->{validate_callback});
100              
101 7         15 return $self;
102             }
103              
104             =item my $cache_entry = $c->entry( $key )
105              
106             Return a 'Cache::Entry' object for the given key. This object can then be
107             used to manipulate the cache entry in various ways. The key can be any scalar
108             string that will uniquely identify an entry in the cache.
109              
110             =cut
111              
112             sub entry;
113              
114             =item $c->purge()
115              
116             Remove all expired data from the cache.
117              
118             =cut
119              
120             sub purge;
121              
122             =item $c->clear()
123              
124             Remove all entries from the cache - regardless of their expiry time.
125              
126             =cut
127              
128             sub clear;
129              
130             =item my $num = $c->count()
131              
132             Returns the number of entries in the cache.
133              
134             =cut
135              
136             sub count;
137              
138             =item my $size = $c->size()
139              
140             Returns the size (in bytes) of the cache.
141              
142             =cut
143              
144             # if an argument is provided, then the target is the 'shortcut' method set($key)
145             sub size {
146 0     0 1 0 my Cache $self = shift;
147 0 0       0 return @_? $self->entry_size(@_) : $self->cache_size();
148             }
149              
150             # implement this method instead
151             sub cache_size;
152              
153              
154             =back
155              
156             =head1 PROPERTIES
157              
158             When a cache is constructed these properties can be supplied as options to the
159             new() method.
160              
161             =over
162              
163             =item default_expires
164              
165             The current default expiry time for new entries into the cache. This property
166             can also be reset at any time.
167              
168             my $time = $c->default_expires();
169             $c->set_default_expires( $expiry );
170              
171             =cut
172              
173             sub default_expires {
174 255     255 1 237 my Cache $self = shift;
175 255         432 return Canonicalize_Expiration_Time($self->{default_expires});
176             }
177              
178             sub set_default_expires {
179 7     7 0 12 my Cache $self = shift;
180 7         17 my ($time) = @_;
181             # This could be made more efficient by converting to unix time here,
182             # except that special handling would be required for relative times.
183             # For now default_expires() does all the conversion.
184 7         17 $self->{default_expires} = $time;
185             }
186              
187             =item removal_strategy
188              
189             The removal strategy object for the cache. This is used to remove
190             object from the cache in order to maintain the cache size limit.
191              
192             When setting the removal strategy in new(), the name of a strategy package or
193             a blessed strategy object reference should be provided (in the former case an
194             object is constructed by calling the new() method of the named package).
195              
196             The strategies 'Cache::RemovalStrategy::LRU' and
197             'Cache::RemovalStrategy::FIFO' are available by default.
198              
199             my $strategy = $c->removal_strategy();
200              
201             =cut
202              
203             sub removal_strategy {
204 2     2 1 14 my Cache $self = shift;
205 2         14 return $self->{removal_strategy};
206             }
207              
208             =item size_limit
209              
210             The size limit for the cache.
211              
212             my $limit = $c->size_limit();
213              
214             =cut
215              
216             sub size_limit {
217 0     0 1 0 my Cache $self = shift;
218 0         0 return $self->{size_limit};
219             }
220              
221             =item load_callback
222              
223             The load callback for the cache. This may be set to a function that will get
224             called anytime a 'get' is issued for data that does not exist in the cache.
225              
226             my $limit = $c->load_callback();
227             $c->set_load_callback($callback_func);
228              
229             =cut
230              
231             sub load_callback {
232 1     1 1 2 my Cache $self = shift;
233 1         4 return $self->{load_callback};
234             }
235              
236             sub set_load_callback {
237 9     9 0 17 my Cache $self = shift;
238 9         18 my ($load_callback) = @_;
239 9         19 $self->{load_callback} = $load_callback;
240             }
241              
242             =item validate_callback
243              
244             The validate callback for the cache. This may be set to a function that will
245             get called anytime a 'get' is issued for data that does not exist in the
246             cache.
247              
248             my $limit = $c->validate_callback();
249             $c->set_validate_callback($callback_func);
250              
251             =cut
252              
253             sub validate_callback {
254 1     1 1 3 my Cache $self = shift;
255 1         4 return $self->{validate_callback};
256             }
257              
258             sub set_validate_callback {
259 9     9 0 15 my Cache $self = shift;
260 9         18 my ($validate_callback) = @_;
261 9         73 $self->{validate_callback} = $validate_callback;
262             }
263              
264              
265             =back
266              
267             =head1 SHORTCUT METHODS
268              
269             These methods all have counterparts in the Cache::Entry package, but are
270             provided here as shortcuts. They all default to just wrappers that do
271             '$c->entry($key)->method_name()'. For documentation, please refer to
272             Cache::Entry.
273              
274             =over
275              
276             =item my $bool = $c->exists( $key )
277              
278             =cut
279              
280             sub exists {
281 5     5 1 19 my Cache $self = shift;
282 5         6 my $key = shift;
283 5         10 return $self->entry($key)->exists();
284             }
285              
286             =item $c->set( $key, $data, [ $expiry ] )
287              
288             =cut
289              
290             sub set {
291 211     211 1 196 my Cache $self = shift;
292 211         203 my $key = shift;
293 211         358 return $self->entry($key)->set(@_);
294             }
295              
296             =item my $data = $c->get( $key )
297              
298             =cut
299              
300             sub get {
301 5     5 1 6 my Cache $self = shift;
302 5         6 my $key = shift;
303 5         30 return $self->entry($key)->get();
304             }
305              
306             =item my $data = $c->size( $key )
307              
308             =cut
309              
310             # method is called 'entry_size' as the size() method is also a normal Cache
311             # method for returning the size of the entire cache. It calls this instead if
312             # given an argument.
313             sub entry_size {
314 0     0 0 0 my Cache $self = shift;
315 0         0 my $key = shift;
316 0         0 return $self->entry($key)->size();
317             }
318              
319             =item $c->remove( $key )
320              
321             =cut
322              
323             sub remove {
324 0     0 1 0 my Cache $self = shift;
325 0         0 my $key = shift;
326 0         0 return $self->entry($key)->remove();
327             }
328              
329             =item $c->expiry( $key )
330              
331             =cut
332              
333             sub expiry {
334 0     0 1 0 my Cache $self = shift;
335 0         0 my $key = shift;
336 0         0 return $self->entry($key)->expiry();
337             }
338 0     0 0 0 sub get_expiry { shift->expiry(@_); }
339              
340             =item $c->set_expiry( $key, $time )
341              
342             =cut
343              
344             sub set_expiry {
345 0     0 1 0 my Cache $self = shift;
346 0         0 my $key = shift;
347 0         0 return $self->entry($key)->set_expiry(@_);
348             }
349              
350             =item $c->handle( $key, [$mode, [$expiry] ] )
351              
352             =cut
353              
354             sub handle {
355 0     0 1 0 my Cache $self = shift;
356 0         0 my $key = shift;
357 0         0 return $self->entry($key)->handle();
358             }
359              
360             =item $c->validity( $key )
361              
362             =cut
363              
364             sub validity {
365 0     0 1 0 my Cache $self = shift;
366 0         0 my $key = shift;
367 0         0 return $self->entry($key)->validity();
368             }
369 0     0 0 0 sub get_validity { shift->validity(@_); }
370              
371             =item $c->set_validity( $key, $data )
372              
373             =cut
374              
375             sub set_validity {
376 0     0 1 0 my Cache $self = shift;
377 0         0 my $key = shift;
378 0         0 return $self->entry($key)->set_validity(@_);
379             }
380              
381             =item $c->freeze( $key, $data, [ $expiry ] )
382              
383             =cut
384              
385             sub freeze {
386 0     0 1 0 my Cache $self = shift;
387 0         0 my $key = shift;
388 0         0 return $self->entry($key)->freeze(@_);
389             }
390              
391             =item $c->thaw( $key )
392              
393             =cut
394              
395             sub thaw {
396 0     0 1 0 my Cache $self = shift;
397 0         0 my $key = shift;
398 0         0 return $self->entry($key)->thaw();
399             }
400              
401              
402             =back
403              
404             =head1 TIE INTERFACE
405              
406             tie %hash, 'Cache::File', { cache_root => $tempdir };
407              
408             $hash{'key'} = 'some data';
409             $data = $hash{'key'};
410              
411             The Cache classes can be used via the tie interface, as shown in the synopsis.
412             This allows the cache to be accessed via a hash. All the standard methods
413             for accessing the hash are supported , with the exception of the 'keys' or
414             'each' call.
415              
416             The tie interface is especially useful with the load_callback to automatically
417             populate the hash.
418              
419             =head1 REMOVAL STRATEGY METHODS
420              
421             These methods are only for use internally (by concrete Cache implementations).
422              
423             These methods define the interface by which the removal strategy object can
424             manipulate the cache (the Cache is the 'context' of the strategy). By
425             default, methods need to be provided to remove the oldest or stalest objects
426             in the cache - thus allowing support for the default FIFO and LRU removal
427             strategies. All derived Cache implementations should support these methods
428             and may also introduce additional methods (and additional removal strategies
429             to match).
430              
431             =over
432              
433             =item my $size = $c->remove_oldest()
434              
435             Removes the oldest entry in the cache and returns its size.
436              
437             =cut
438              
439             sub remove_oldest;
440              
441             =item my $size = $c->remove_stalest()
442              
443             Removes the 'stalest' (least used) object in the cache and returns its
444             size.
445              
446             =cut
447              
448             sub stalest;
449              
450             =item $c->check_size( $size )
451              
452             This method isn't actually part of the strategy interface, nor does it need
453             to be defined by Cache implementations. Instead it should be called by
454             implementations whenever the size of the cache increases. It will take care
455             of checking the size limit and invoking the removal strategy if required. The
456             size argument should be the new size of the cache.
457              
458             =cut
459              
460             sub check_size {
461 246     246 1 215 my Cache $self = shift;
462 246         224 my ($size) = @_;
463              
464 246 100       663 defined $self->{size_limit} or return;
465              
466 18 100       40 if ($size > $self->{size_limit}) {
467 8         25 $self->{removal_strategy}->remove_size(
468             $self, $size - $self->{size_limit});
469             }
470             }
471              
472              
473             =back
474              
475             =head1 UTILITY METHODS
476              
477             These methods are only for use internally (by concrete Cache implementations).
478              
479             =over
480              
481             =item my $time = Cache::Canonicalize_Expiration_Time($timespec)
482              
483             Converts a timespec as described for Cache::Entry::set_expiry() into a unix
484             time.
485              
486             =back
487              
488             =cut
489              
490             sub Canonicalize_Expiration_Time {
491 260     260 1 210 my $timespec;
492              
493 260         415 my $timespec_param = shift(@_);
494 260 100       368 if (! $timespec_param)
495             {
496 255         543 return undef;
497             }
498 5         20 $timespec = lc($timespec_param);
499              
500 5         5 my $time;
501              
502 5 50 33     72 if ($timespec =~ /^\s*\d+\s*$/) {
    100          
    50          
    50          
    50          
    50          
503 0         0 $time = $timespec;
504             }
505             elsif ($timespec eq $EXPIRES_NOW) {
506 2         3 $time = 0;
507             }
508             elsif ($timespec eq $EXPIRES_NEVER) {
509 0         0 $time = undef;
510             }
511             elsif ($timespec =~ /^\s*-/) {
512             # negative time?
513 0         0 $time = 0;
514             }
515             elsif ($timespec =~ /^\s*\+(\d+)\s*$/) {
516 0         0 $time = $1 + time();
517             }
518             elsif ($timespec =~ /^\s*(\+?\d+)\s*(\w*)\s*$/
519             and exists($_Expiration_Units{$2}))
520             {
521 3         14 $time = $_Expiration_Units{$2} * $1 + time();
522             }
523             else {
524 0 0       0 $time = str2time($timespec)
525             or croak "invalid expiration time '$timespec'";
526             }
527              
528 5         11 return $time;
529             }
530              
531              
532             # Hash tie methods
533              
534             sub TIEHASH {
535 2     2   379 my Cache $class = shift;
536 2         7 return $class->new(@_);
537             }
538              
539             sub STORE {
540 1     1   25 my Cache $self = shift;
541 1         2 my ($key, $value) = @_;
542 1         5 return $self->set($key, $value);
543             }
544              
545             sub FETCH {
546 2     2   26 my Cache $self = shift;
547 2         3 my ($key) = @_;
548 2         5 return $self->get($key);
549             }
550              
551             # NOT SUPPORTED
552             sub FIRSTKEY {
553 0     0   0 my Cache $self = shift;
554 0         0 return undef;
555             }
556              
557             # NOT SUPPORTED
558             sub NEXTKEY {
559 0     0   0 my Cache $self = shift;
560             #my ($lastkey) = @_;
561 0         0 return undef;
562             }
563              
564             sub EXISTS {
565 0     0   0 my Cache $self = shift;
566 0         0 my ($key) = @_;
567 0         0 return $self->exists($key);
568             }
569              
570             sub DELETE {
571 2     2   4 my Cache $self = shift;
572 2         3 my ($key) = @_;
573 2         7 return $self->remove($key);
574             }
575              
576             sub CLEAR {
577 0     0     my Cache $self = shift;
578 0           return $self->clear();
579             }
580              
581              
582             1;
583             __END__