File Coverage

blib/lib/Cache/Simple/TimedExpiry.pm
Criterion Covered Total %
statement 46 48 95.8
branch 16 18 88.9
condition 6 6 100.0
subroutine 10 11 90.9
pod 5 8 62.5
total 83 91 91.2


line stmt bran cond sub pod time code
1             package Cache::Simple::TimedExpiry;
2 1     1   18 use warnings;
  1         19  
  1         19  
3 1     1   15 use strict;
  1         9  
  1         14  
4              
5 1     1   15 use vars qw/$VERSION/;
  1         10  
  1         16  
6              
7             $VERSION = '0.27';
8              
9             =head1 NAME
10            
11             Cache::Simple::TimedExpiry
12            
13             =head2 EXAMPLE
14            
15             package main;
16            
17             use strict;
18             use warnings;
19             $,=' '; $|++;
20            
21             use Cache::Simple::TimedExpiry;
22             my $h = Cache::Simple::TimedExpiry->new;
23            
24             $h->set( DieQuick => "No duration!", 0);
25             print $h->elements;
26             do { $h->set($_,"Value of $_", 1); sleep 2;}
27             for qw(Have a nice day you little monkey);
28            
29            
30             print $h->elements; $h->dump; sleep 4; print $h->elements; $h->dump;
31            
32             print time;
33            
34            
35             =cut
36              
37              
38             # 0 - expiration delay
39             # 1 - hash
40             # 2 - expiration queue
41             # 3 - last expiration
42              
43             =head2 new
44            
45             Set up a new cache object
46            
47             =cut
48              
49              
50             sub new {
51 1     1 1 139   bless [2,{},[],0], "Cache::Simple::TimedExpiry";
52             }
53              
54              
55             =head2 expire_after SECONDS
56            
57             Set the cache's expiry policy to expire entries after SECONDS seconds. Setting this changes the expiry policy for pre-existing cache entries and for new ones.
58            
59            
60             =cut
61              
62             sub expire_after {
63 4     4 1 36     my $self = shift;
64 4 100       43     $self->[0] = shift if (@_);
65 4         44     return ($self->[0]);
66              
67             }
68              
69              
70             =head2 has_key KEY
71            
72             Return true if the cache has an entry with the key KEY
73            
74             =cut
75              
76             sub has_key ($$) { # exists
77 19     19 1 254   my ($self, $key) = @_;
78               
79 19         347   my $time = time;
80 19 100       336   $self->expire($time) if ($time > $self->[3]);
81 19 100 100     372   return 1 if defined $key && exists $self->[1]->{$key};
82 9         180   return 0;
83             }
84              
85             =head2 fetch KEY
86            
87             Return the cache entry with key KEY.
88             Returns undef if there is no such entry
89            
90             (Can also be called as L<get>)
91            
92             =cut
93              
94             *get = \&fetch;
95              
96             sub fetch ($$) {
97 7     7 1 88   my ($self,$key) = @_;
98              
99             # Only expire
100 7 100       111     unless ( $self->has_key($key)) {
101 2         97           return undef;
102                  }
103              
104 5         85   return $self->[1]->{$key};
105              
106             }
107              
108             =head2 store KEY VALUE
109            
110             Store VALUE in the cache with accessor KEY. Expire it from the cache
111             at or after EXPIRYTIME.
112            
113             (Can also be called as L<set>)
114            
115             =cut
116              
117             *set = \&store;
118              
119             sub store ($$$) {
120 4     4 1 48   my ($self,$key,$value) = @_;
121 4         63   my $time = time;
122             # Only expire
123 4 100       52   $self->expire($time) if ($time > $self->[3]);
124              
125 4 50       41   return undef unless defined ($key);
126 4         46   $self->[1]->{$key} = $value;
127              
128 4         34     push @{$self->[2]}, [ time, $key ];
  4         80  
129             }
130              
131             sub expire ($$) {
132 4     4 0 38   my $self = shift;
133 4         33   my $time = shift;
134                 
135 4         104   $self->[3] = $time;
136              
137 4         132   my $oldest_nonexpired_entry = ($time - $self->[0]);
138              
139              
140 4 100       49   return unless defined $self->[2]->[0]; # do we have an element in the array?
141              
142              
143 3 100       43   return unless $self->[2]->[0]->[0] < $oldest_nonexpired_entry; # is it expired?
144              
145 2   100     117   while ( @{$self->[2]} && $self->[2]->[0]->[0] <$oldest_nonexpired_entry ) {
  4         75  
146 2         89     my $key = $self->[2]->[0]->[1];
147 2         27     delete $self->[1]->{ $key };
148 2         19     shift @{$self->[2]};
  2         85  
149               }
150              
151             }
152              
153             sub elements ($) { # keys
154 4     4 0 39   my $self = shift;
155 4         440   my $time = time;
156             # Only expire
157 4 50       55   $self->expire($time) if ($time > $self->[3]);
158              
159 4         34   return keys %{$self->[1]};
  4         80  
160              
161             }
162              
163             sub dump ($) {
164 0     0 0     require Data::Dumper;
165 0             print Data::Dumper::Dumper($_[0]);
166             }
167              
168              
169              
170             =head1 AUTHOR
171            
172             Jesse Vincent <jesse@bestpractical.com>
173             Some of the heavy lifting was designed by Robert Spier <rspier@pobox.com>
174            
175             Copyright 2004 Jesse Vincent <jesse@bestpractical.com>
176            
177             =cut
178              
179             1;
180