File Coverage

blib/lib/Cache/BaseCache.pm
Criterion Covered Total %
statement 188 197 95.4
branch 35 44 79.5
condition 5 15 33.3
subroutine 53 54 98.1
pod 12 25 48.0
total 293 335 87.5


line stmt bran cond sub pod time code
1             ######################################################################
2             # $Id: BaseCache.pm,v 1.26 2006/05/18 04:20:17 dclinton Exp $
3             # Copyright (C) 2001-2003 DeWitt Clinton All Rights Reserved
4             #
5             # Software distributed under the License is distributed on an "AS
6             # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or
7             # implied. See the License for the specific language governing
8             # rights and limitations under the License.
9             ######################################################################
10              
11              
12             package Cache::BaseCache;
13              
14              
15 4     4   63 use strict;
  4         85  
  4         60  
16 4     4   59 use vars qw( @ISA );
  4         39  
  4         58  
17 4     4   61 use Cache::Cache qw( $EXPIRES_NEVER $EXPIRES_NOW );
  4         36  
  4         75  
18 4     4   137 use Cache::CacheUtils qw( Assert_Defined Clone_Data );
  4         40  
  4         119  
19 4     4   203 use Cache::Object;
  4         46  
  4         80  
20 4     4   65 use Error;
  4         38  
  4         58  
21              
22              
23             @ISA = qw( Cache::Cache );
24              
25              
26             my $DEFAULT_EXPIRES_IN = $EXPIRES_NEVER;
27             my $DEFAULT_NAMESPACE = "Default";
28             my $DEFAULT_AUTO_PURGE_ON_SET = 0;
29             my $DEFAULT_AUTO_PURGE_ON_GET = 0;
30              
31              
32             # namespace that stores the keys used for the auto purge functionality
33              
34             my $AUTO_PURGE_NAMESPACE = "__AUTO_PURGE__";
35              
36              
37             # map of expiration formats to their respective time in seconds
38              
39             my %_Expiration_Units = ( map(($_, 1), qw(s second seconds sec)),
40                                       map(($_, 60), qw(m minute minutes min)),
41                                       map(($_, 60*60), qw(h hour hours)),
42                                       map(($_, 60*60*24), qw(d day days)),
43                                       map(($_, 60*60*24*7), qw(w week weeks)),
44                                       map(($_, 60*60*24*30), qw(M month months)),
45                                       map(($_, 60*60*24*365), qw(y year years)) );
46              
47              
48              
49             # Takes the time the object was created, the default_expires_in and
50             # optionally the explicitly set expires_in and returns the time the
51             # object will expire. Calls _canonicalize_expiration to convert
52             # strings like "5m" into second values.
53              
54             sub Build_Expires_At
55             {
56 126     126 0 1354   my ( $p_created_at, $p_default_expires_in, $p_explicit_expires_in ) = @_;
57              
58 126 100       1317   my $expires_in = defined $p_explicit_expires_in ?
59                 $p_explicit_expires_in : $p_default_expires_in;
60              
61 126         2407   return Sum_Expiration_Time( $p_created_at, $expires_in );
62             }
63              
64              
65             # Return a Cache::Object object
66              
67             sub Build_Object
68             {
69 126     126 0 1293   my ( $p_key, $p_data, $p_default_expires_in, $p_expires_in ) = @_;
70              
71 126         3243   Assert_Defined( $p_key );
72 126         1308   Assert_Defined( $p_default_expires_in );
73              
74 126         2362   my $now = time( );
75              
76 126         6932   my $object = new Cache::Object( );
77              
78 126         1457   $object->set_key( $p_key );
79 126         1523   $object->set_data( $p_data );
80 126         1422   $object->set_created_at( $now );
81 126         3240   $object->set_accessed_at( $now );
82 126         1273   $object->set_expires_at( Build_Expires_At( $now,
83                                                          $p_default_expires_in,
84                                                          $p_expires_in ) );
85 126         3085   return $object;
86             }
87              
88              
89             # Compare the expires_at to the current time to determine whether or
90             # not an object has expired (the time parameter is optional)
91              
92             sub Object_Has_Expired
93             {
94 118     118 0 1133   my ( $p_object, $p_time ) = @_;
95              
96 118 100       1251   if ( not defined $p_object )
97               {
98 2         28     return 1;
99               }
100              
101 116   33     2643   $p_time = $p_time || time( );
102              
103 116 50       1691   if ( $p_object->get_expires_at( ) eq $EXPIRES_NOW )
    100          
    100          
104               {
105 0         0     return 1;
106               }
107               elsif ( $p_object->get_expires_at( ) eq $EXPIRES_NEVER )
108               {
109 24         906     return 0;
110               }
111               elsif ( $p_time >= $p_object->get_expires_at( ) )
112               {
113 40         500     return 1;
114               }
115               else
116               {
117 52         800     return 0;
118               }
119             }
120              
121              
122             # Returns the sum of the base created_at time (in seconds since the epoch)
123             # and the canonical form of the expires_at string
124              
125              
126             sub Sum_Expiration_Time
127             {
128 126     126 0 1306   my ( $p_created_at, $p_expires_in ) = @_;
129              
130 126         1370   Assert_Defined( $p_created_at );
131 126         2082   Assert_Defined( $p_expires_in );
132              
133 126 100       2735   if ( $p_expires_in eq $EXPIRES_NEVER )
134               {
135 68         1762     return $EXPIRES_NEVER;
136               }
137               else
138               {
139 58         597     return $p_created_at + Canonicalize_Expiration_Time( $p_expires_in );
140               }
141             }
142              
143              
144             # turn a string in the form "[number] [unit]" into an explicit number
145             # of seconds from the present. E.g, "10 minutes" returns "600"
146              
147             sub Canonicalize_Expiration_Time
148             {
149 58     58 0 1518   my ( $p_expires_in ) = @_;
150              
151 58         723   Assert_Defined( $p_expires_in );
152              
153 58         540   my $secs;
154              
155 58 50 0     3111   if ( uc( $p_expires_in ) eq uc( $EXPIRES_NOW ) )
    50          
    50          
    0          
156               {
157 0         0     $secs = 0;
158               }
159               elsif ( uc( $p_expires_in ) eq uc( $EXPIRES_NEVER ) )
160               {
161 0         0     throw Error::Simple( "Internal error. expires_in eq $EXPIRES_NEVER" );
162               }
163               elsif ( $p_expires_in =~ /^\s*([+-]?(?:\d+|\d*\.\d*))\s*$/ )
164               {
165 58         519     $secs = $p_expires_in;
166               }
167               elsif ( $p_expires_in =~ /^\s*([+-]?(?:\d+|\d*\.\d*))\s*(\w*)\s*$/
168                       and exists( $_Expiration_Units{ $2 } ))
169               {
170 0         0     $secs = ( $_Expiration_Units{ $2 } ) * $1;
171               }
172               else
173               {
174 0         0     throw Error::Simple( "invalid expiration time '$p_expires_in'" );
175               }
176              
177 58         936   return $secs;
178             }
179              
180              
181              
182             sub clear
183             {
184 32     32 1 329   my ( $self ) = @_;
185              
186 32         1340   $self->_get_backend( )->delete_namespace( $self->get_namespace( ) );
187             }
188              
189              
190             sub get
191             {
192 106     106 1 1688   my ( $self, $p_key ) = @_;
193              
194 106         1259   Assert_Defined( $p_key );
195              
196 106 100       1341   $self->_conditionally_auto_purge_on_get( ) unless
197                 $self->get_namespace( ) eq $AUTO_PURGE_NAMESPACE;
198              
199 106 100       1261   my $object = $self->get_object( $p_key ) or
200                 return undef;
201              
202 82 100       12438   if ( Object_Has_Expired( $object ) )
203               {
204 32         349     $self->remove( $p_key );
205 32         747     return undef;
206               }
207              
208 50         627   return $object->get_data( );
209             }
210              
211              
212             sub get_keys
213             {
214 90     90 1 971   my ( $self ) = @_;
215              
216 90         2087   return $self->_get_backend( )->get_keys( $self->get_namespace( ) );
217             }
218              
219              
220             sub get_identifiers
221             {
222 0     0 1 0   my ( $self ) = @_;
223              
224 0         0   warn( "get_identifiers has been marked deprepricated. use get_keys" );
225              
226 0         0   return $self->get_keys( );
227             }
228              
229              
230             sub get_object
231             {
232 234     234 1 2570   my ( $self, $p_key ) = @_;
233              
234 234         2845   Assert_Defined( $p_key );
235              
236 234 100       4358   my $object =
237                 $self->_get_backend( )->restore( $self->get_namespace( ), $p_key ) or
238                   return undef;
239              
240 182         2480   $object->set_size( $self->_get_backend( )->
241                                  get_size( $self->get_namespace( ), $p_key ) );
242              
243 182         2621   $object->set_key( $p_key );
244              
245 182         3405   return $object;
246             }
247              
248              
249             sub purge
250             {
251 22     22 1 220   my ( $self ) = @_;
252              
253 22         240   foreach my $key ( $self->get_keys( ) )
254               {
255 28         353     $self->get( $key );
256               }
257             }
258              
259              
260             sub remove
261             {
262 54     54 1 576   my ( $self, $p_key ) = @_;
263              
264 54         8232   Assert_Defined( $p_key );
265              
266 54         566   $self->_get_backend( )->delete_key( $self->get_namespace( ), $p_key );
267             }
268              
269              
270             sub set
271             {
272 108     108 1 1132   my ( $self, $p_key, $p_data, $p_expires_in ) = @_;
273              
274 108         1377   Assert_Defined( $p_key );
275              
276 108         1266   $self->_conditionally_auto_purge_on_set( );
277              
278 108         1351   $self->set_object( $p_key,
279                                  Build_Object( $p_key,
280                                                $p_data,
281                                                $self->get_default_expires_in( ),
282                                                $p_expires_in ) );
283             }
284              
285              
286             sub set_object
287             {
288 172     172 1 1881   my ( $self, $p_key, $p_object ) = @_;
289              
290 172         3331   my $object = Clone_Data( $p_object );
291              
292 172         2271   $object->set_size( undef );
293 172         2125   $object->set_key( undef );
294              
295 172         1823   $self->_get_backend( )->store( $self->get_namespace( ), $p_key, $object );
296             }
297              
298              
299             sub size
300             {
301 58     58 1 540   my ( $self ) = @_;
302              
303 58         489   my $size = 0;
304              
305 58         661   foreach my $key ( $self->get_keys( ) )
306               {
307 56         647     $size += $self->_get_backend( )->get_size( $self->get_namespace( ), $key );
308               }
309              
310 58         838   return $size;
311             }
312              
313              
314             sub get_namespaces
315             {
316 4     4 1 41   my ( $self ) = @_;
317              
318 4         47   return $self->_get_backend( )->get_namespaces( );
319             }
320              
321              
322             sub _new
323             {
324 50     50   491   my ( $proto, $p_options_hash_ref ) = @_;
325 50   33     679   my $class = ref( $proto ) || $proto;
326 50         532   my $self = {};
327 50         782   bless( $self, $class );
328 50         696   $self->_initialize_base_cache( $p_options_hash_ref );
329 50         581   return $self;
330             }
331              
332              
333             sub _complete_initialization
334             {
335 50     50   451   my ( $self ) = @_;
336 50         562   $self->_initialize_auto_purge_interval( );
337             }
338              
339              
340             sub _initialize_base_cache
341             {
342 50     50   596   my ( $self, $p_options_hash_ref ) = @_;
343              
344 50         623   $self->_initialize_options_hash_ref( $p_options_hash_ref );
345 50         652   $self->_initialize_namespace( );
346 50         1445   $self->_initialize_default_expires_in( );
347 50         555   $self->_initialize_auto_purge_on_set( );
348 50         3142   $self->_initialize_auto_purge_on_get( );
349             }
350              
351              
352             sub _initialize_options_hash_ref
353             {
354 50     50   468   my ( $self, $p_options_hash_ref ) = @_;
355              
356 50 100       690   $self->_set_options_hash_ref( defined $p_options_hash_ref ?
357                                             $p_options_hash_ref :
358                                             { } );
359             }
360              
361              
362             sub _initialize_namespace
363             {
364 50     50   638   my ( $self ) = @_;
365              
366 50         637   my $namespace = $self->_read_option( 'namespace', $DEFAULT_NAMESPACE );
367              
368 50         700   $self->set_namespace( $namespace );
369             }
370              
371              
372             sub _initialize_default_expires_in
373             {
374 50     50   471   my ( $self ) = @_;
375              
376 50         498   my $default_expires_in =
377                 $self->_read_option( 'default_expires_in', $DEFAULT_EXPIRES_IN );
378              
379 50         619   $self->_set_default_expires_in( $default_expires_in );
380             }
381              
382              
383             sub _initialize_auto_purge_interval
384             {
385 50     50   427   my ( $self ) = @_;
386              
387 50         494   my $auto_purge_interval = $self->_read_option( 'auto_purge_interval' );
388              
389 50 100       754   if ( defined $auto_purge_interval )
390               {
391 4         50     $self->set_auto_purge_interval( $auto_purge_interval );
392 4         51     $self->_auto_purge( );
393               }
394             }
395              
396              
397             sub _initialize_auto_purge_on_set
398             {
399 50     50   2128   my ( $self ) = @_;
400              
401 50         515   my $auto_purge_on_set =
402                 $self->_read_option( 'auto_purge_on_set', $DEFAULT_AUTO_PURGE_ON_SET );
403              
404 50         5542   $self->set_auto_purge_on_set( $auto_purge_on_set );
405             }
406              
407              
408             sub _initialize_auto_purge_on_get
409             {
410 50     50   445   my ( $self ) = @_;
411              
412 50         850   my $auto_purge_on_get =
413                 $self->_read_option( 'auto_purge_on_get', $DEFAULT_AUTO_PURGE_ON_GET );
414              
415 50         561   $self->set_auto_purge_on_get( $auto_purge_on_get );
416             }
417              
418              
419              
420             # _read_option looks for an option named 'option_name' in the
421             # option_hash associated with this instance. If it is not found, then
422             # 'default_value' will be returned instead
423              
424             sub _read_option
425             {
426 358     358   3935   my ( $self, $p_option_name, $p_default_value ) = @_;
427              
428 358         13751   my $options_hash_ref = $self->_get_options_hash_ref( );
429              
430 358 100       6418   if ( defined $options_hash_ref->{ $p_option_name } )
431               {
432 42         2885     return $options_hash_ref->{ $p_option_name };
433               }
434               else
435               {
436 316         3880     return $p_default_value;
437               }
438             }
439              
440              
441              
442             # this method checks to see if the auto_purge property is set for a
443             # particular cache. If it is, then it switches the cache to the
444             # $AUTO_PURGE_NAMESPACE and stores that value under the name of the
445             # current cache namespace
446              
447             sub _reset_auto_purge_interval
448             {
449 18     18   309   my ( $self ) = @_;
450              
451 18 50       204   return if not $self->_should_auto_purge( );
452              
453 18         232   my $real_namespace = $self->get_namespace( );
454              
455 18         387   $self->set_namespace( $AUTO_PURGE_NAMESPACE );
456              
457 18 50       209   if ( not defined $self->get( $real_namespace ) )
458               {
459 18         234     $self->_insert_auto_purge_object( $real_namespace );
460               }
461              
462 18         450   $self->set_namespace( $real_namespace );
463             }
464              
465              
466             sub _should_auto_purge
467             {
468 54     54   1397   my ( $self ) = @_;
469              
470 54   33     559   return ( defined $self->get_auto_purge_interval( ) &&
471                        $self->get_auto_purge_interval( ) ne $EXPIRES_NEVER );
472             }
473              
474             sub _insert_auto_purge_object
475             {
476 18     18   171   my ( $self, $p_real_namespace ) = @_;
477              
478 18         282   my $object = Build_Object( $p_real_namespace,
479                                          1,
480                                          $self->get_auto_purge_interval( ),
481                                          undef );
482              
483 18         207   $self->set_object( $p_real_namespace, $object );
484             }
485              
486              
487              
488             # this method checks to see if the auto_purge property is set, and if
489             # it is, switches to the $AUTO_PURGE_NAMESPACE and sees if a value
490             # exists at the location specified by a key named for the current
491             # namespace. If that key doesn't exist, then the purge method is
492             # called on the cache
493              
494             sub _auto_purge
495             {
496 36     36   320   my ( $self ) = @_;
497              
498 36 100       384   if ( $self->_needs_auto_purge( ) )
499               {
500 10         131     $self->purge( );
501 10         141     $self->_reset_auto_purge_interval( );
502               }
503             }
504              
505              
506             sub _get_auto_purge_object
507             {
508 36     36   319   my ( $self ) = @_;
509              
510 36         369   my $real_namespace = $self->get_namespace( );
511 36         383   $self->set_namespace( $AUTO_PURGE_NAMESPACE );
512 36         424   my $auto_purge_object = $self->get_object( $real_namespace );
513 36         385   $self->set_namespace( $real_namespace );
514 36         411   return $auto_purge_object;
515             }
516              
517              
518             sub _needs_auto_purge
519             {
520 36     36   308   my ( $self ) = @_;
521              
522 36   66     374   return ( $self->_should_auto_purge( ) &&
523                        Object_Has_Expired( $self->_get_auto_purge_object( ) ) );
524             }
525              
526              
527             # call auto_purge if the auto_purge_on_set option is true
528              
529             sub _conditionally_auto_purge_on_set
530             {
531 108     108   963   my ( $self ) = @_;
532              
533 108 100       1315   if ( $self->get_auto_purge_on_set( ) )
534               {
535 32         400     $self->_auto_purge( );
536               }
537             }
538              
539              
540             # call auto_purge if the auto_purge_on_get option is true
541              
542             sub _conditionally_auto_purge_on_get
543             {
544 88     88   1734   my ( $self ) = @_;
545              
546 88 50       953   if ( $self->get_auto_purge_on_get( ) )
547               {
548 0         0     $self->_auto_purge( );
549               }
550             }
551              
552              
553             sub _get_options_hash_ref
554             {
555 358     358   3566   my ( $self ) = @_;
556              
557 358         3824   return $self->{_Options_Hash_Ref};
558             }
559              
560              
561             sub _set_options_hash_ref
562             {
563 50     50   742   my ( $self, $options_hash_ref ) = @_;
564              
565 50         612   $self->{_Options_Hash_Ref} = $options_hash_ref;
566             }
567              
568              
569             sub get_namespace
570             {
571 980     980 0 8823   my ( $self ) = @_;
572              
573 980         25017   return $self->{_Namespace};
574             }
575              
576              
577             sub set_namespace
578             {
579 158     158 0 1826   my ( $self, $namespace ) = @_;
580              
581 158         1795   $self->{_Namespace} = $namespace;
582             }
583              
584              
585             sub get_default_expires_in
586             {
587 108     108 1 3753   my ( $self ) = @_;
588              
589 108         1584   return $self->{_Default_Expires_In};
590             }
591              
592              
593             sub _set_default_expires_in
594             {
595 50     50   605   my ( $self, $default_expires_in ) = @_;
596              
597 50         604   $self->{_Default_Expires_In} = $default_expires_in;
598             }
599              
600              
601             sub get_auto_purge_interval
602             {
603 126     126 0 2272   my ( $self ) = @_;
604              
605 126         2172   return $self->{_Auto_Purge_Interval};
606             }
607              
608              
609             sub set_auto_purge_interval
610             {
611 8     8 0 82   my ( $self, $auto_purge_interval ) = @_;
612              
613 8         80   $self->{_Auto_Purge_Interval} = $auto_purge_interval;
614              
615 8         107   $self->_reset_auto_purge_interval( );
616             }
617              
618              
619             sub get_auto_purge_on_set
620             {
621 108     108 0 2728   my ( $self ) = @_;
622              
623 108         2862   return $self->{_Auto_Purge_On_Set};
624             }
625              
626              
627             sub set_auto_purge_on_set
628             {
629 54     54 0 522   my ( $self, $auto_purge_on_set ) = @_;
630              
631 54         604   $self->{_Auto_Purge_On_Set} = $auto_purge_on_set;
632             }
633              
634              
635             sub get_auto_purge_on_get
636             {
637 88     88 0 1802   my ( $self ) = @_;
638              
639 88         1007   return $self->{_Auto_Purge_On_Get};
640             }
641              
642              
643             sub set_auto_purge_on_get
644             {
645 50     50 0 484   my ( $self, $auto_purge_on_get ) = @_;
646              
647 50         1735   $self->{_Auto_Purge_On_Get} = $auto_purge_on_get;
648             }
649              
650              
651             sub _get_backend
652             {
653 824     824   10295   my ( $self ) = @_;
654              
655 824         14211   return $self->{ _Backend };
656             }
657              
658              
659             sub _set_backend
660             {
661 50     50   450   my ( $self, $p_backend ) = @_;
662              
663 50         916   $self->{ _Backend } = $p_backend;
664             }
665              
666              
667              
668             1;
669              
670              
671             __END__
672            
673            
674             =pod
675            
676             =head1 NAME
677            
678             Cache::BaseCache -- abstract cache base class
679            
680             =head1 DESCRIPTION
681            
682             BaseCache provides functionality common to all instances of a cache.
683             It differes from the CacheUtils package insofar as it is designed to
684             be used as superclass for cache implementations.
685            
686             =head1 SYNOPSIS
687            
688             Cache::BaseCache is to be used as a superclass for cache
689             implementations. The most effective way to use BaseCache is to use
690             the protected _set_backend method, which will be used to retrieve the
691             persistance mechanism. The subclass can then inherit the BaseCache's
692             implentation of get, set, etc. However, due to the difficulty
693             inheriting static methods in Perl, the subclass will likely need to
694             explicitly implement Clear, Purge, and Size. Also, a factory pattern
695             should be used to invoke the _complete_initialization routine after
696             the object is constructed.
697            
698            
699             package Cache::MyCache;
700            
701             use vars qw( @ISA );
702             use Cache::BaseCache;
703             use Cache::MyBackend;
704            
705             @ISA = qw( Cache::BaseCache );
706            
707             sub new
708             {
709             my ( $self ) = _new( @_ );
710            
711             $self->_complete_initialization( );
712            
713             return $self;
714             }
715            
716             sub _new
717             {
718             my ( $proto, $p_options_hash_ref ) = @_;
719             my $class = ref( $proto ) || $proto;
720             my $self = $class->SUPER::_new( $p_options_hash_ref );
721             $self->_set_backend( new Cache::MyBackend( ) );
722             return $self;
723             }
724            
725            
726             sub Clear
727             {
728             foreach my $namespace ( _Namespaces( ) )
729             {
730             _Get_Backend( )->delete_namespace( $namespace );
731             }
732             }
733            
734            
735             sub Purge
736             {
737             foreach my $namespace ( _Namespaces( ) )
738             {
739             _Get_Cache( $namespace )->purge( );
740             }
741             }
742            
743            
744             sub Size
745             {
746             my $size = 0;
747            
748             foreach my $namespace ( _Namespaces( ) )
749             {
750             $size += _Get_Cache( $namespace )->size( );
751             }
752            
753             return $size;
754             }
755            
756            
757             =head1 SEE ALSO
758            
759             Cache::Cache, Cache::FileCache, Cache::MemoryCache
760            
761             =head1 AUTHOR
762            
763             Original author: DeWitt Clinton <dewitt@unto.net>
764            
765             Last author: $Author: dclinton $
766            
767             Copyright (C) 2001-2003 DeWitt Clinton
768            
769             =cut
770