File Coverage

blib/lib/HTML/Mason/Cache/BaseCache.pm
Criterion Covered Total %
statement 34 35 97.1
branch 16 20 80.0
condition 1 3 33.3
subroutine 5 5 100.0
pod 3 3 100.0
total 59 66 89.3


line stmt bran cond sub pod time code
1             # Copyright (c) 1998-2005 by Jonathan Swartz. All rights reserved.
2             # This program is free software; you can redistribute it and/or modify it
3             # under the same terms as Perl itself.
4              
5             package HTML::Mason::Cache::BaseCache;
6             $HTML::Mason::Cache::BaseCache::VERSION = '1.58';
7 32     32   213 use strict;
  32         56  
  32         808  
8 32     32   170 use warnings;
  32         55  
  32         11599  
9              
10             #
11             # Override to handle busy_lock and expire_if.
12             #
13             sub get
14             {
15 66     66 1 166 my ($self, $key, %params) = @_;
16 66 50       166 die "must specify key" unless defined($key);
17              
18 66         176 foreach my $param (keys(%params)) {
19 10 50       63 unless ($param =~ /^(busy_lock|expire_if)$/) {
20 0         0 die "unknown param '$param'";
21             }
22             }
23              
24 66         240 $self->_conditionally_auto_purge_on_get();
25              
26 66 100       622 if (my $sub = $params{expire_if}) {
27 6         30 $self->expire_if($key, $sub);
28             }
29              
30 66 100       206 my $object = $self->get_object($key) or
31             return undef;
32              
33 45 100       20849 if (Cache::BaseCache::Object_Has_Expired($object))
34             {
35 13 100       362 if ($params{busy_lock}) {
36             # If busy_lock value provided, set a new "temporary"
37             # expiration time that many seconds forward, and return
38             # undef so that this process will start recomputing.
39 4         20 my $busy_lock_time = Cache::BaseCache::Canonicalize_Expiration_Time($params{busy_lock});
40 4         127 $object->set_expires_at(time + $busy_lock_time);
41 4         32 $self->set_object($key, $object);
42             } else {
43 9         47 $self->remove($key);
44             }
45 13         6167 return undef;
46             }
47              
48 32         665 return $object->get_data( );
49             }
50              
51             sub expire
52             {
53 5     5 1 15 my ($self, $key) = @_;
54              
55 5 50       15 if (my $obj = $self->get_object($key)) {
56 5         1918 $obj->set_expires_at(time-1);
57 5         30 $self->set_object($key, $obj);
58             }
59             }
60              
61             sub expire_if
62             {
63 6     6 1 15 my ($self, $key, $sub) = @_;
64 6 50 33     30 die "must specify subroutine" unless defined($sub) and ref($sub) eq 'CODE';
65              
66 6 100       17 if (my $obj = $self->get_object($key)) {
67 5         2004 my $retval = $sub->($obj);
68 5 100       23 if ($retval) {
69 2         12 $self->expire($key);
70             }
71 5         1316 return $retval;
72             } else {
73 1         123 return 1;
74             }
75             }
76              
77              
78             1;
79              
80             __END__