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