File Coverage

blib/lib/Cache/File.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Cache::File - Filesystem based implementation of the Cache interface
4              
5             =head1 SYNOPSIS
6              
7             use Cache::File;
8              
9             my $cache = Cache::File->new( cache_root => '/tmp/mycache',
10             default_expires => '600 sec' );
11              
12             See Cache for the usage synopsis.
13              
14             =head1 DESCRIPTION
15              
16             The Cache::File class implements the Cache interface. This cache stores
17             data in the filesystem so that it can be shared between processes and persists
18             between process invocations.
19              
20             =cut
21             package Cache::File;
22              
23             require 5.006;
24 5     5   17514 use strict;
  5         11  
  5         210  
25 5     5   28 use warnings;
  5         9  
  5         153  
26 5     5   12899 use Cache::File::Heap;
  0            
  0            
27             use Cache::File::Entry;
28             use Digest::SHA qw(sha1_hex);
29             use Fcntl qw(LOCK_EX LOCK_NB);
30             use Symbol ();
31             use File::Spec;
32             use File::Path;
33             use File::NFSLock;
34             use DB_File;
35             use Storable;
36             use Carp;
37              
38             use base qw(Cache);
39             use fields qw(
40             root depth umask locklevel
41             expheap ageheap useheap index lockfile
42             lock lockcount openexp openage openuse openidx);
43              
44             our $VERSION = '2.10';
45              
46             sub LOCK_NONE () { 0 }
47             sub LOCK_LOCAL () { 1 }
48             sub LOCK_NFS () { 2 }
49              
50              
51             my $DEFAULT_DEPTH = 2;
52             my $DEFAULT_UMASK = 077;
53             my $DEFAULT_LOCKLEVEL = LOCK_NFS;
54              
55             my $INDEX = 'index.db';
56             my $EXPIRY_HEAP = 'expheap.db';
57             my $AGE_HEAP = 'ageheap.db';
58             my $USE_HEAP = 'useheap.db';
59             my $LOCKFILE = 'lock';
60              
61             our $STALE_LOCK_TIMEOUT = 30; # 30 second timeout on lockfiles
62             our $LOCK_EXT = '.lock';
63              
64             # keys to store count and size in the index
65             my $SIZE_KEY = '__cache_size';
66             my $COUNT_KEY = '__cache_count';
67              
68              
69             =head1 CONSTRUCTOR
70              
71             my $cache = Cache::File->new( %options )
72              
73             The constructor takes cache properties as named arguments, for example:
74              
75             my $cache = Cache::File->new( cache_root => '/tmp/mycache',
76             lock_level => Cache::File::LOCK_LOCAL(),
77             default_expires => '600 sec' );
78              
79             Note that you MUST provide a cache_root property.
80              
81             See 'PROPERTIES' below and in the Cache documentation for a list of all
82             available properties that can be set.
83              
84             =cut
85              
86             sub new {
87             my Cache::File $self = shift;
88             my $args = $#_? { @_ } : shift;
89              
90             $self = fields::new($self) unless ref $self;
91             $self->SUPER::new($args);
92              
93             $self->_set_cache_lock_level($args->{lock_level});
94             $self->_set_cache_umask($args->{cache_umask});
95             $self->_set_cache_depth($args->{cache_depth});
96             $self->_set_cache_root($args->{cache_root});
97              
98             return $self;
99             }
100              
101             =head1 METHODS
102              
103             See 'Cache' for the API documentation.
104              
105             =cut
106              
107             sub entry {
108             my Cache::File $self = shift;
109             my ($key) = @_;
110             return Cache::File::Entry->new($self, $key);
111             }
112              
113             sub purge {
114             my Cache::File $self = shift;
115             my $time = time();
116              
117             # if it's locked, someone else will probably be doing a purge already
118             $self->trylock() or return;
119              
120             # open expiry index
121             my $expheap = $self->get_exp_heap();
122              
123             # check for expiry
124             my $minimum = $expheap->minimum();
125             if ($minimum and $minimum <= $time) {
126             # open other indexes
127             my $ageheap = $self->get_age_heap();
128             my $useheap = $self->get_use_heap();
129             my $index = $self->get_index();
130              
131             # loop removing minimums
132             do {
133             my $keys;
134             ($minimum, $keys) = $expheap->extract_minimum_dup();
135              
136             foreach (@$keys) {
137             # update all the indexes (remove references to this key)
138             my $path = $self->cache_file_path($_);
139              
140             my $index_entries = $self->get_index_entries($_)
141             or warnings::warnif('Cache', "missing index entry for $_");
142             delete $$index{$_};
143              
144             $ageheap->delete($$index_entries{age}, $_)
145             if $$index_entries{age};
146             $useheap->delete($$index_entries{lastuse}, $_)
147             if $$index_entries{lastuse};
148              
149             # reduce the cache size and count
150             $$index{$COUNT_KEY}--;
151             $$index{$SIZE_KEY} -= (-s $path);
152              
153             # remove data file
154             unlink($path);
155             }
156              
157             $minimum = $expheap->minimum();
158              
159             } while ($minimum and $minimum <= $time);
160             }
161              
162             $self->unlock();
163             }
164              
165             sub clear {
166             my Cache::File $self = shift;
167             my $fh = Symbol::gensym();
168              
169             $self->lock();
170              
171             # Find each directory entries are stored in and remove them
172             opendir($fh, $self->{root})
173             or die "Can't opendir ".$self->{root}.": $!";
174             my @stores =
175             grep { -d $_ }
176             map { File::Spec->catdir($self->{root}, $_) }
177             File::Spec->no_upwards(readdir($fh));
178             closedir($fh);
179              
180             rmtree(\@stores,0,1);
181              
182             # remove the index files
183             unlink($self->{expheap});
184             unlink($self->{ageheap});
185             unlink($self->{useheap});
186             unlink($self->{index});
187              
188             $self->unlock();
189             }
190              
191             sub count {
192             my Cache::File $self = shift;
193              
194             my $count;
195             $self->lock();
196             my $index = $self->get_index();
197             $count = $$index{$COUNT_KEY};
198             $self->unlock();
199              
200             return $count || 0;
201             }
202              
203             sub size {
204             my Cache::File $self = shift;
205              
206             my $size;
207             $self->lock();
208             my $index = $self->get_index();
209             $size = $$index{$SIZE_KEY};
210             $self->unlock();
211              
212             return $size || 0;
213             }
214              
215             sub sync {
216             my Cache::File $self = shift;
217             # TODO: check entries in cache root and rebuild heaps
218             }
219              
220              
221             =head1 PROPERTIES
222              
223             Cache::File adds the following properties in addition to those discussed in
224             the 'Cache' documentation.
225              
226             =over
227              
228             =item cache_root
229              
230             Used to specify the location of the cache store directory. All methods will
231             work ONLY data stored within this directory. This parameter is REQUIRED when
232             creating a Cache::File instance.
233              
234             my $ns = $c->cache_root();
235              
236             =cut
237              
238             sub cache_root {
239             my Cache::File $self = shift;
240             return $self->{root};
241             }
242              
243             sub _set_cache_root {
244             my Cache::File $self = shift;
245             my ($cache_root) = @_;
246             $cache_root or croak 'A cache root directory MUST be provided';
247             $self->{root} = File::Spec->canonpath(
248             File::Spec->rel2abs($cache_root, File::Spec->tmpdir()));
249              
250             # create root
251             unless (-d $self->{root}) {
252             my $oldmask = umask $self->cache_umask();
253             eval { mkpath($self->{root}) }
254             or die 'Failed to create cache root '.$self->{root}.": $@";
255             umask $oldmask;
256             }
257              
258             # set required file paths
259             $self->{expheap} = File::Spec->catfile($self->{root}, $EXPIRY_HEAP);
260             $self->{ageheap} = File::Spec->catfile($self->{root}, $AGE_HEAP);
261             $self->{useheap} = File::Spec->catfile($self->{root}, $USE_HEAP);
262             $self->{index} = File::Spec->catfile($self->{root}, $INDEX);
263             $self->{lockfile} = File::Spec->catfile($self->{root}, $LOCKFILE);
264             }
265              
266             =item cache_depth
267              
268             The number of subdirectories deep to store cache entires. This should be
269             large enough that no cache directory has more than a few hundred object.
270             Defaults to 2 unless explicitly set.
271              
272             my $depth = $c->cache_depth();
273              
274             =cut
275              
276             sub cache_depth {
277             my Cache::File $self = shift;
278             return $self->{depth};
279             }
280              
281             sub _set_cache_depth {
282             my Cache::File $self = shift;
283             my ($cache_depth) = @_;
284             $self->{depth} = (defined $cache_depth)? $cache_depth : $DEFAULT_DEPTH;
285             }
286              
287             =item cache_umask
288              
289             Specifies the umask to use when creating entries in the cache directory. By
290             default the umask is '077', indicating that only the same user may access
291             the cache files.
292              
293             my $umask = $c->cache_umask();
294              
295             =cut
296              
297             sub cache_umask {
298             my Cache::File $self = shift;
299             return $self->{umask};
300             }
301              
302             sub _set_cache_umask {
303             my Cache::File $self = shift;
304             my ($cache_umask) = @_;
305             $self->{umask} = (defined $cache_umask)? $cache_umask : $DEFAULT_UMASK;
306             }
307              
308             =item lock_level
309              
310             Specify the level of locking to be used. There are three different levels
311             available:
312              
313             =item Cache::File::LOCK_NONE()
314              
315             No locking is performed. Useful when you can guarantee only one process will
316             be accessing the cache at a time.
317              
318             =item Cache::File::LOCK_LOCAL()
319              
320             Locking is performed, but it is not suitable for use over NFS filesystems.
321             However it is more efficient.
322              
323             =item Cache::File::LOCK_NFS()
324              
325             Locking is performed in a way that is suitable for use on NFS filesystems.
326              
327             =back
328              
329             my $level = $c->cache_lock_level();
330              
331             =cut
332              
333             sub cache_lock_level {
334             my Cache::File $self = shift;
335             return $self->{locklevel};
336             }
337              
338             sub _set_cache_lock_level {
339             my Cache::File $self = shift;
340             my ($locklevel) = @_;
341              
342             if (defined $locklevel) {
343             croak "Unknown lock level requested"
344             unless ($locklevel =~ /^[0-9]+$/ &&
345             ($locklevel == LOCK_NONE ||
346             $locklevel == LOCK_LOCAL ||
347             $locklevel == LOCK_NFS));
348             } else {
349             $locklevel = $DEFAULT_LOCKLEVEL;
350             }
351              
352             $self->{locklevel} = $locklevel;
353             }
354              
355              
356             # REMOVAL STRATEGY METHODS
357              
358             sub remove_oldest {
359             my Cache::File $self = shift;
360              
361             # Only called from check_size (via change_size) when the lock is set
362             #$self->lock();
363             my $ageheap = $self->get_age_heap();
364              
365             my ($minimum, $key) = $ageheap->extract_minimum();
366             $key or return undef;
367             my $size = $self->remove($key);
368             #$self->unlock();
369             return $size;
370             }
371              
372             sub remove_stalest {
373             my Cache::File $self = shift;
374              
375             # Only called from check_size (via change_size) when the lock is set
376             #$self->lock();
377             my $useheap = $self->get_use_heap();
378              
379             my ($minimum, $key) = $useheap->extract_minimum();
380             $key or return undef;
381             my $size = $self->remove($key);
382             #$self->unlock();
383             return $size;
384             }
385              
386              
387             # UTILITY METHODS
388              
389             sub cache_file_path {
390             my Cache::File $self = shift;
391             my ($key) = @_;
392              
393             my $shakey = sha1_hex($key);
394             my (@path) = unpack('A2'x$self->{depth}.'A*', $shakey);
395              
396             if (wantarray) {
397             my $file = pop(@path);
398             return (File::Spec->catdir($self->{root}, @path), $file);
399             } else {
400             return File::Spec->catfile($self->{root}, @path);
401             }
402             }
403              
404             sub lock {
405             my Cache::File $self = shift;
406             my ($tryonly) = @_;
407              
408             # already have the lock?
409             if ($self->{lock}) {
410             $self->{lockcount}++;
411             return 1;
412             }
413              
414             if ($self->{locklevel} == LOCK_NONE) {
415             $self->{lock} = 1;
416             }
417             else {
418             # TODO: implement LOCK_LOCAL
419              
420             my $oldmask = umask $self->cache_umask();
421             my $lock = File::NFSLock->new({
422             file => $self->{lockfile},
423             lock_type => LOCK_EX | ($tryonly? LOCK_NB : 0),
424             stale_lock_timeout => $STALE_LOCK_TIMEOUT,
425             });
426             umask $oldmask;
427              
428             unless ($lock) {
429             $tryonly and return 0;
430             die "Failed to obtain lock on lockfile '".$self->{lockfile}."': ".
431             $File::NFSLock::errstr."\n";
432             }
433             $self->{lock} = $lock;
434             }
435              
436             $self->{lockcount} = 1;
437             return 1;
438             }
439              
440             sub trylock {
441             my Cache::File $self = shift;
442             return $self->lock(1);
443             }
444              
445             sub unlock {
446             my Cache::File $self = shift;
447             $self->{lock} or croak "not locked";
448             return unless --$self->{lockcount} == 0;
449              
450             # close heaps and save counts
451             $self->{openexp} = undef;
452             $self->{openage} = undef;
453             $self->{openuse} = undef;
454             $self->{openidx} = undef;
455              
456             # unlock
457             $self->{lock}->unlock unless $self->{locklevel} == LOCK_NONE;
458             $self->{lock} = undef;
459             }
460              
461             sub create_entry {
462             my Cache::File $self = shift;
463             my ($key, $time) = @_;
464              
465             my $ageheap = $self->get_age_heap();
466             $ageheap->add($time, $key);
467             my $useheap = $self->get_use_heap();
468             $useheap->add($time, $key);
469              
470             $self->set_index_entries($key, { age => $time, lastuse => $time });
471             }
472              
473             sub update_last_use {
474             my Cache::File $self = shift;
475             my ($key, $time) = @_;
476              
477             my $index_entries = $self->get_index_entries($key)
478             or warnings::warnif('Cache', "missing index entry for $key");
479              
480             my $useheap = $self->get_use_heap();
481             $useheap->delete($$index_entries{lastuse}, $key);
482             $useheap->add($time, $key);
483              
484             $$index_entries{lastuse} = $time;
485             $self->set_index_entries($key, $index_entries);
486             }
487              
488             sub change_count {
489             my Cache::File $self = shift;
490             my ($count) = @_;
491             my $index = $self->get_index();
492             my $oldcount = $$index{$COUNT_KEY};
493             $$index{$COUNT_KEY} = $oldcount? $oldcount + $count : $count;
494             }
495              
496             sub change_size {
497             my Cache::File $self = shift;
498             my ($size) = @_;
499             my $index = $self->get_index();
500             my $oldsize = $$index{$SIZE_KEY};
501             $$index{$SIZE_KEY} = $oldsize? $oldsize + $size : $size;
502             $self->check_size($$index{$SIZE_KEY}) if $size > 0;
503             }
504              
505             sub get_index_entries {
506             my Cache::File $self = shift;
507             my ($key) = @_;
508              
509             my $index = $self->get_index();
510             my $index_entry = $$index{$key}
511             or return undef;
512              
513             my $index_entries = Storable::thaw($index_entry);
514             $$index_entries{age} and $$index_entries{lastuse}
515             or warnings::warnif('Cache', "invalid index entry for $_");
516              
517             return $index_entries;
518             }
519              
520             sub set_index_entries {
521             my Cache::File $self = shift;
522             my $key = shift;
523             my $index_entries = $#_? { @_ } : shift;
524              
525             $$index_entries{age} and $$index_entries{lastuse}
526             or croak "failed to supply age and lastuse for index update on $key";
527              
528             my $index = $self->get_index();
529             $$index{$key} = Storable::nfreeze($index_entries);
530             }
531              
532             sub get_index {
533             my Cache::File $self = shift;
534             unless ($self->{openidx}) {
535             $self->{lock} or croak "not locked";
536              
537             my $indexfile = $self->{index};
538             File::NFSLock::uncache($indexfile) if $self->{locklevel} == LOCK_NFS;
539              
540             my $oldmask = umask $self->cache_umask();
541             my %indexhash;
542             my $index =
543             tie %indexhash, 'DB_File', $indexfile,O_CREAT|O_RDWR,0666,$DB_HASH;
544             umask $oldmask;
545              
546             $index or die "Failed to open index $indexfile: $!";
547              
548             $self->{openidx} = \%indexhash;
549             }
550             return $self->{openidx};
551             }
552              
553             sub get_exp_heap {
554             my Cache::File $self = shift;
555             return $self->{openexp} ||= $self->_open_heap($self->{expheap});
556             }
557              
558             sub get_age_heap {
559             my Cache::File $self = shift;
560             return $self->{openage} ||= $self->_open_heap($self->{ageheap});
561             }
562              
563             sub get_use_heap {
564             my Cache::File $self = shift;
565             return $self->{openuse} ||= $self->_open_heap($self->{useheap});
566             }
567              
568             sub _open_heap {
569             my Cache::File $self = shift;
570             my ($heapfile) = @_;
571             $self->{lock} or croak "not locked";
572              
573             File::NFSLock::uncache($heapfile) if $self->{locklevel} == LOCK_NFS;
574              
575             my $oldmask = umask $self->cache_umask();
576             my $heap = Cache::File::Heap->new($heapfile);
577             umask $oldmask;
578             $heap or die "Failed to open heap $heapfile: $!";
579             return $heap;
580             }
581              
582              
583             1;
584             __END__