File Coverage

blib/lib/Cache/Mmap.pm
Criterion Covered Total %
statement 335 386 86.8
branch 107 156 68.6
condition 26 47 55.3
subroutine 40 42 95.2
pod 14 14 100.0
total 522 645 80.9


line stmt bran cond sub pod time code
1             # $Id: Mmap.pm,v 1.13 2005/11/15 18:33:29 pmh Exp $
2              
3             =head1 NAME
4            
5             Cache::Mmap - Shared data cache using memory mapped files
6            
7             =head1 SYNOPSIS
8            
9             use Cache::Mmap;
10            
11             $cache=Cache::Mmap->new($filename,\%options);
12            
13             $val1=$cache->read($key1);
14             $cache->write($key2,$val2);
15             $cache->delete($key3);
16            
17             =head1 DESCRIPTION
18            
19             This module implements a shared data cache, using memory mapped files.
20             If routines are provided which interact with the underlying data, access to
21             the cache is completely transparent, and the module handles all the details of
22             refreshing cache contents, and updating underlying data, if necessary.
23            
24             Cache entries are assigned to "buckets" within the cache file, depending on
25             the key. Within each bucket, entries are stored approximately in order of last
26             access, so that frequently accessed entries will move to the head of the
27             bucket, thus decreasing access time. Concurrent accesses to the same bucket are
28             prevented by file locking of the relevant section of the cache file.
29            
30             =cut
31              
32             package Cache::Mmap;
33              
34             # Do we need to worry about UTF-8?
35 5   33 5   302 use constant has_utf8 => defined($^V) && $^V ge "\5\6\0";
  5         92  
  5         216  
36              
37 5     5   482 use Carp qw(croak);
  5         58  
  5         102  
38 5     5   268 use DynaLoader();
  5         44  
  5         46  
39 5     5   72 use Exporter;
  5         44  
  5         70  
40 5     5   81 use Fcntl;
  5         46  
  5         95  
41 5     5   263 use IO::Seekable qw(SEEK_SET SEEK_END);
  5         51  
  5         118  
42 5     5   84 use Storable qw(freeze thaw);
  5         53  
  5         97  
43 5     5   87 use Symbol();
  5         108  
  5         50  
44 5     5   21658 use integer;
  5         49  
  5         400  
45 5     5   80 use strict;
  5         42  
  5         70  
46 5         75 use vars qw(
47             $VERSION @ISA
48             @EXPORT_OK
49 5     5   71 );
  5         46  
50              
51             $VERSION='0.09';
52             @ISA=qw(DynaLoader Exporter);
53             @EXPORT_OK=qw(CMM_keep_expired CMM_keep_expired_refresh);
54              
55             __PACKAGE__->bootstrap($VERSION);
56              
57             # Default cache options
58             my %def_options=(
59               buckets => 13, # Number of buckets
60               bucketsize => 1024, # Size of each bucket
61               pagesize => 1024, # Bucket alignment
62               strings => 0, # Store strings, rather than refs
63               expiry => 0, # Number of seconds to hold values, 0==forever
64               context => undef, # Context to pass to read and write subs
65               permissions => 0600, # Permissions for new file creation
66             # read => sub called as ($found,$val)/$val=$read->($key,$context)
67               cachenegative => 0, # true: Cache not-found values
68             # false: Don't cache not-found values
69             # write => sub called as $write->($key,$oval,$context)
70             # Leave out for no writing to underlying data
71               writethrough => 1, # true: Write when value is added to cache
72             # false: Write when value expires or is pushed out
73             # delete => sub called as $delete->($key,$oval,$context)
74             # Leave out for no deleting of underlying data
75             );
76              
77             # Bit positions for cache-level flags
78 5     5   152 use constant flag_strings => 0x0001;
  5         46  
  5         75  
79             # Names for cache-level flags
80             my %bool_opts=(
81               strings => flag_strings,
82             );
83              
84             # Bit positions for element flags
85 5     5   387 use constant elem_dirty => 0x0001;
  5         235  
  5         100  
86              
87 5     5   254 use constant magic => 0x15ACACE;# Cache file magic number
  5         45  
  5         108  
88 5     5   72 use constant filevers => 1; # File format version number supported
  5         44  
  5         61  
89              
90              
91             my $headsize=4*10; # File: magic, buckets, bucketsize, pagesize, flags,
92             # file format version
93             my $bheadsize=4*10; # Bucket: filled
94             my $eheadsize=4*10; # Element: size, time, klen, vlen, flags
95             my $maxheadsize=$headsize > $bheadsize ? $headsize : $bheadsize;
96             $maxheadsize=$eheadsize if $eheadsize > $maxheadsize;
97              
98             # While these look random, the low word could be a bitmask
99 5     5   148 use constant CMM_keep_expired => 0xCACE0001; # Keep the expired value
  5         48  
  5         63  
100 5     5   107 use constant CMM_keep_expired_refresh => 0xCACE0003; # Keep the expired value, and unexpire it
  5         46  
  5         62  
101              
102              
103             =head1 CLASS METHODS
104            
105             =over
106            
107             =item new($filename,\%options)
108            
109             Creates a new cache object. If the file named by C<$filename> does not already
110             exist, it will be created. If the cache object cannot be created for any
111             reason, an exception will be thrown. Various options may be set in C<%options>,
112             which affect the behaviour of the cache (defaults in parentheses):
113            
114             =over 4
115            
116             =item permissions (0600)
117            
118             Sets the file permissions for the cache file if it doesn't already exist.
119            
120             =item buckets (13)
121            
122             Sets the number of buckets inside the cache file. A larger number of buckets
123             will give better performance for a cache with many accesses, as there will be
124             less chance of concurrent access to the same bucket.
125            
126             =item bucketsize (1024)
127            
128             Sets the size of each bucket, in bytes. A larger bucket size will be needed to
129             store large cache entries. If the bucketsize is not large enough to hold a
130             particular entry, it will still be passed between the underlying data and the
131             application in its entirety, but will not be stored in the cache.
132            
133             =item pagesize (1024)
134            
135             Sets the alignment of buckets within the file. The file header will be extended
136             to this size, and bucket sizes will be rounded up to the nearest multiple.
137             Choosing a pagesize equal to the virtual memory page size of the host system
138             should improve performance.
139            
140             =item strings (0)
141            
142             If true, cache entries are treated as strings, rather than references. This
143             will help performance for string-only caches, as no time will be taken to
144             serialize cache entries.
145            
146             =item expiry (0)
147            
148             If non-zero, sets the length of time, in seconds, which cache entries are
149             considered valid. A new entry will be fetched from the underlying data if
150             an expired cache entry would otherwise have been returned.
151            
152             =item context (undef)
153            
154             This value is passed to the read/write/delete routines below, to provide
155             context. This will typically be a database handle, used to fetch data from.
156            
157             =item read (undef)
158            
159             Provides a code reference to a routine which will fetch entries from the
160             underlying data. Called as C<$read-E<gt>($key,$context)>, this routine should
161             return a list C<($found,$value)>, where C<$found> is true if the entry could
162             be found in the underlying data, and C<$value> is the value to cache.
163            
164             If the routine only returns a single scalar, that will be taken as
165             the value, and C<$found> will be set to true if the value is defined.
166            
167             If this routine is not provided, only values already in the cache will ever
168             be returned.
169            
170             There are currently two special values of C<$found> which cause slightly
171             different behaviour. These are constants which may be imported in the
172             C<use> statement.
173            
174             =over 4
175            
176             =item C<Cache::Mmap::CMM_keep_expired>
177            
178             Use the previously cached value, even if it has expired. This is useful if
179             the underlying data source has become unavailable for some reason. Note that
180             even though the value returned will be ignored in this case, it must be
181             returned to avoid C<$found> being interpreted as a single scalar:
182            
183             return (Cache::Mmap::CMM_keep_expired, undef);
184            
185             =item C<Cache::Mmap::CMM_keep_expired_refresh>
186            
187             This causes the same behaviour as C<CMM_keep_expired>, but the cache entry's
188             expiry time will be reset as if a value had been successfully read from the
189             underlying data.
190            
191             =back
192            
193             =item cachenegative (0)
194            
195             If true, even unsuccessful fetches from the underlying data are cached. This
196             can be useful to only search the underlying data once for each required key.
197            
198             =item write (undef)
199            
200             Provides a code reference to a routine which will write cache entries into the
201             underlying data. This routine will be called by write(), to synchronise the
202             underlying data with the cache. Called as C<$write-E<gt>($key,$val,$context)>.
203             If the routine is not provided, the underlying data will not be synchronised
204             after cache writes.
205            
206             =item writethrough (1)
207            
208             If true, the C<write> routine above will be called as soon as
209             write() is called. This provides immediate synchronisation of
210             underlying data and cache contents.
211            
212             If false, the C<write> routine will
213             be called for each cache entry which no longer fits in its bucket after a
214             cache read or write. This provides a write-as-necessary behaviour, which may
215             be more efficient than the writethrough behaviour. However, only data fetched
216             through the cache will reflect these changes.
217            
218             =item delete (undef)
219            
220             Provides a code reference to a routine which will delete items from the
221             underlying data. This routine will be called by delete(),
222             to synchronise the underlying data with the cache. Called as
223             C<$delete-E<gt>($key,$cval,$context)>, where C<$cval> is the value
224             currently stored in the cache. If this routine is not provided, entries
225             deleted from the cache have no effect on the underlying data.
226            
227             =back
228            
229             An alternative to supplying a C<write> routine, is to call
230             delete() after updating the underlying data. Note however, that
231             in the case of databases, this should be done after committing the update, so
232             that a concurrent process doesn't reload the cache between being the entry
233             being deleted, and the database updates being committed.
234            
235             =cut
236              
237             sub new{
238 11     11 1 593   my($class,$filename,$options)=@_;
239 11 100       229   my $self={
240                 %def_options,
241 11         164     %{$options || {}},
242               };
243              
244             # Check options for sensible values
245 11         140   foreach(qw(buckets bucketsize pagesize permissions)){
246 44 50 33     951     defined($self->{$_}) && $self->{$_}=~/^[1-9]\d*$/s
247                   or croak "'$_' option for $class must be a positive integer";
248               }
249 11 50       254   $self->{pagesize}>=$maxheadsize
250                 or croak "'pagesize' option for $class must be at least $maxheadsize";
251 11         106   foreach(qw(read write delete)){
252 33 50 66     1256     !$self->{$_} || ref $self->{$_} eq 'CODE'
253                   or croak "'$_' option for $class must be a CODE ref or empty";
254               }
255              
256             # Align bucketsize
257               {
258 5     5   119     no integer;
  5         56  
  5         78  
  11         111  
259 11         129     my $n_pages=$self->{bucketsize}/$self->{pagesize};
260 11 50       151     if((my $i_pages=int $n_pages)!=$n_pages){
261 0         0       $self->{bucketsize}=($i_pages+1)*$self->{pagesize};
262                 }
263               }
264              
265             # Try to open a file
266 11         149   my $fh=Symbol::gensym;
267 11 50       453   sysopen($fh,$filename,O_RDWR|O_CREAT,$self->{permissions})
268                 or croak "Can't open cache file $filename: $!";
269              
270             # Create cache object
271 11         135   bless $self,$class;
272 11         141   $self->{_filename}=$filename;
273 11         108   $self->{_fh}=$fh;
274              
275             # Set options
276 11         140   $self->_set_options;
277              
278 9         155   $self;
279             }
280              
281             =back
282            
283             =head1 METHODS
284            
285             =head2 CACHE DATA METHODS
286            
287             These are the everyday methods used to access the data stored by the cache.
288            
289             =over 4
290            
291             =item read($key)
292            
293             Reads an entry from the cache, or from the underlying data if not cached.
294             Returns the value in scalar context, and C<($found,$value)> in list context,
295             where C<$found> is true if the item was found in either the cache or the
296             underlying data.
297            
298             =cut
299              
300             sub read{
301 49     49 1 538   my($self,$key)=@_;
302 49         518   my $bucket=$self->_bucket($key);
303 49         12317   my $ekey=$self->_encode($key,1);
304              
305             # Lock the bucket. This is a write lock, even for reading, since we may
306             # move items within the bucket
307 49         803   $self->_lock($bucket);
308              
309 49         423   my($found,$val,$err);
310 49 100       451   eval{
311 49         728     local $SIG{__DIE__};
312              
313 49         2320     ($found,my($expired,$poff,$off,$size,$klen,$vlen,$flags))
314                   =$self->_find($bucket,$key);
315              
316             # We need to read a new value if we don't have a value,
317             # or if that value is expired.
318 47         1864     my ($new_found, $new_val);
319 47 100 100     678     if (!$found or $expired) {
320 9 100       2529       my @_read=$self->{read}
321             ? $self->{read}->($key,$self->{context}) : ();
322 9 50       152       ($new_found,$new_val)=@_read==1 ? (defined($_read[0]),$_read[0]) : @_read;
323 9 100       98       $new_found=0 if !defined $new_found;
324 9 100       87       undef $new_val unless $new_found;
325              
326 9 100       111       if($new_found==CMM_keep_expired){
    100          
327             # Use the old value, even though it's expired
328 1         11         $found=$expired;
329 1         11 $expired=0;
330 1         10 $new_found=0;
331                   }elsif($new_found==CMM_keep_expired_refresh){
332             # Use the old value, and update its time so it's not expired anymore
333 1         9         $found=$expired;
334 1         10 $expired=0;
335 1         79 $new_found=0;
336              
337             # Modify the time field in a hideously unmaintainable way
338 1 50       26 substr($self->{_mmap},$off+4,4)=pack 'l',time
339             if $found;
340                   }
341                 }
342              
343 47 100       479     if($found){{
344             # Remove expired item, and pretend we didn't find it
345             # XXX What about dirty expired items???
346 42 100 66     349       if($expired && !($flags & elem_dirty)){
  42         490  
347             # No need to write underlying data, because it's not dirty
348 2         20 my $b_end=$bucket+$self->{bucketsize};
349 2         40 substr($self->{_mmap},$off,$b_end-$off)
350             =substr($self->{_mmap},$off+$size,$b_end-$off-$size).("\0" x $size);
351 2         22 my($filled)=unpack 'l',substr($self->{_mmap},$bucket,$bheadsize);
352 2         18 $filled-=$size;
353 2         31 substr($self->{_mmap},$bucket,$bheadsize)
354             =substr(pack("lx$bheadsize",$filled),0,$bheadsize);
355 2         17 $found=0; # it's expired, so pretend we didn't find anything
356 2         17 last;
357                   }
358             # Swap with previous item unless at head of bucket
359 40 100       672       if($poff){
360 6         58 my $psize=$off-$poff;
361 6         93 substr($self->{_mmap},$poff,$psize+$size)
362             =substr($self->{_mmap},$off,$size)
363             .substr($self->{_mmap},$poff,$psize);
364 6         54 $off=$poff;
365                   }
366 40         597       $val=$self->_decode(substr($self->{_mmap},$off+$eheadsize+$klen,$vlen),0);
367                 }}
368 47 100       480     if(!$found){
369             # go ahead and use the new data, read above
370 7         61       ($found,$val)=($new_found,$new_val);
371              
372             # Store value in cache
373 7 50 33     108       if($found || $self->{cachenegative}){
374 0         0 my $eval=$self->_encode($val,0);
375              
376 0         0 $self->_insert($bucket,$ekey,$eval,0);
377                   }
378                 }
379              
380 47         625     1;
381               } or $err=1;
382 49         570   $self->_unlock;
383              
384             # Propagate errors
385 49 100       979   die $@ if $err;
386              
387 47         792   return ($found,$val);
388             }
389              
390             =item write($key,$val)
391            
392             Writes an entry into the cache, and depending on the configuration, into the
393             underlying data.
394            
395             =cut
396              
397             sub write{
398 28     28 1 321   my($self,$key,$val)=@_;
399 28         301   my $ekey=$self->_encode($key,1);
400 28         316   my $klen=length $ekey;
401 28         279   my $eval=$self->_encode($val,0);
402 28         256   my $vlen=length $eval;
403 28         968   my $size=$eheadsize+$klen+$vlen;
404 28         269   my $bsize=$self->{bucketsize}-$bheadsize;
405              
406 28 50       266   if($size<=$bsize){
    0          
407             # The item will fit in a cache bucket, so store it
408 28         294     my $bucket=$self->_bucket($key);
409 28         304     $self->_lock($bucket);
410 28         224     my $err;
411 28 50       249     eval{
412 28         2536       local $SIG{__DIE__};
413 28         347       my($found,$expired,$poff,$off,$_size,$_klen,$_vlen,$flags)
414             =$self->_find($bucket,$key);
415              
416             # Remove the old version
417 28 100       290       if($found){
418 3         42 my($filled)=unpack 'l',substr($self->{_mmap},$bucket,$bheadsize);
419 3         35 my $pre=substr $self->{_mmap},
420             $bucket+$bheadsize,$off-($bucket+$bheadsize);
421 3         31 my $post=substr $self->{_mmap},
422             $off+$_size,$bucket+$bheadsize+$filled-$off-$_size;
423 3         30         my $new_filled=length($pre.$post);
424 3         65 my $bhead=substr(pack("lx$bheadsize",$new_filled),0,$bheadsize);
425              
426 3         41 substr($self->{_mmap},$bucket,$bheadsize+$new_filled)
427             =$bhead.$pre.$post;
428                   }
429              
430             # Generate new bucket contents
431 28         368       $self->_insert($bucket,$ekey,$eval,1);
432              
433             # Write to underlying data
434 28 50 33     1271       if($self->{writethrough} and my $write=$self->{write}){
435 0         0 $write->($key,$val,$self->{context});
436                   }
437              
438 28         368       1;
439                 } or $err=1;
440 28         417     $self->_unlock;
441 28 50       281     die $@ if $err;
442               }elsif(my $wsub=$self->{write}){
443             # It won't fit in a cache bucket, but we can update the underlying data
444 0         0     $self->delete($key);
445 0         0     $wsub->($key,$val,$self->{context});
446               }else{
447             # It won't fit, and we can't update the data
448             # XXX Should we blow up here?
449             # Probably not, since an item may be removed from the cache at any time
450               }
451              
452 28         372   1;
453             }
454              
455             =item delete($key)
456            
457             Deletes an entry from the cache, and depending on C<new()> options, from the
458             underlying data.
459             Returns the value in scalar context, and C<($found,$value)> in list context,
460             where C<$found> is true if the item was found in the cache.
461            
462             =cut
463              
464             sub delete{
465 3     3 1 30   my($self,$key)=@_;
466 3         35   my $bucket=$self->_bucket($key);
467              
468             # Lock the bucket
469 3         35   $self->_lock($bucket);
470              
471 3         26   my($found,$val,$err);
472 3 50       26   eval{
473 3         39     local $SIG{__DIE__};
474              
475 3         32     ($found,my($expired,$poff,$off,$size,$klen,$vlen,$flags))
476                   =$self->_find($bucket,$key);
477              
478 3 50       34     if($found){
479 3         37       $val=$self->_decode(substr($self->{_mmap},$off+$eheadsize+$klen,$vlen),0);
480 3 50 33     39       if(my $dsub=$self->{delete} and !($flags & elem_dirty)){
481 0         0 $dsub->($key,$val,$self->{context});
482                   }
483 3         35       my($filled)=unpack 'l',substr($self->{_mmap},$bucket,$bheadsize);
484 3         28       my $new_filled=$filled-$size;
485 3         51       substr($self->{_mmap},$bucket,$bheadsize)
486             =substr(pack("lx$bheadsize",$new_filled),0,$bheadsize);
487              
488 3         26       my $fill_end=$bucket+$bheadsize+$filled;
489 3         26       my $elem_end=$off+$size;
490 3         36       substr($self->{_mmap},$off,$fill_end-$elem_end)
491                     =substr($self->{_mmap},$elem_end,$fill_end-$elem_end);
492                 }
493              
494 3         39     1;
495               } or $err=1;
496 3         34   $self->_unlock;
497              
498             # Propagate errors
499 3 50       29   die $@ if $err;
500              
501 3         66   return ($found,$val);
502             }
503              
504             =item entries()
505            
506             =item entries(0)
507            
508             Returns a list of the keys of entries held in the cache. Note that this list
509             may be immediately out of date, due to the shared nature of the cache. Entries
510             may be added or removed by other processes between this list being generated
511             and when it is used.
512            
513             =item entries(1)
514            
515             Returns a list of hashrefs representing entries held in the cache. The
516             following keys are present in each hashref:
517            
518             key The key used to identify the entry
519             time The time the entry was stored (seconds since the epoch)
520             dirty Whether the entry needs writing to the underlying data
521            
522             The same caveat applies to the currency of this information as above.
523            
524             =item entries(2)
525            
526             As C<entries(1)>, with the addition of a C<value> element in each
527             hashref, holding the value stored in the cache entry.
528            
529             =cut
530              
531             sub entries{
532 5     5 1 98   my($self,$details)=@_;
533 5   66     64   $details=defined($details) && $details+0;
534              
535 5         97   my $buckets=$self->buckets;
536 5         49   my $bucketsize=$self->bucketsize;
537 5         52   my $pagesize=$self->pagesize;
538 5         49   my $expiry=$self->expiry;
539              
540 5         41   my @entries;
541 5         934   for(0..$buckets-1){
542 65         551     my $bucket=$pagesize+$bucketsize*$_;
543 65         807     $self->_lock($bucket);
544              
545 65         4451     my $err;
546 65 50       1019     eval{
547 65         903       local $SIG{__DIE__};
548              
549 65         947       my($filled)=unpack 'l',substr($self->{_mmap},$bucket,$bheadsize);
550 65         769       my $off=$bucket+$bheadsize;
551 65         830       my $end=$off+$filled;
552 65         570       my $size;
553 65         948       while($off<$end){
554 20         443 ($size,my($time,$klen,$vlen,$flags))
555             =unpack 'l5',substr $self->{_mmap},$off,$eheadsize;
556 20 50       198 if(!$size){
557 0         0 my $part=substr($self->{_mmap},$off,$end-$off);
558 0         0 $part=~s/\\/\\\\/g;
559 0         0 $part=~s/([^\040-\176])/sprintf '\\%02x',ord $1/ge;
  0         0  
560 0         0 die "Zero-sized entry in $self->{_filename}, offset $off! Remaining bucket contents: $part";
561             }
562 20 50 33     380 next if $expiry && time()-$time > $expiry;
563              
564 20         855 my $key=$self->_decode(substr($self->{_mmap},$off+$eheadsize,$klen),1);
565 20 100       180         if($details){
566 10 100       138 push @entries,{
567             key => $key,
568             'time' => $time,
569             dirty => $flags & elem_dirty,
570             $details>1 ? (
571             value => $self->_decode(
572             substr($self->{_mmap},$off+$eheadsize+$klen,$vlen),0
573             ),
574             ) : (),
575             };
576             }else{
577 10         99 push @entries,$key;
578             }
579                   }continue{
580 20         228 $off+=$size;
581                   }
582              
583 65         729       1;
584                 } or $err=1;
585 65         621     $self->_unlock;
586              
587 65 50       653     die $@ if $err;
588               }
589              
590 5         156   @entries;
591             }
592              
593             =item quick_clear()
594            
595             Forcefully delete the cache, with prejudice. Unwritten dirty elements are B<not>
596             written back to the underlying data source; they are simply thrown away.
597            
598             =cut
599              
600             sub quick_clear{
601 0     0 1 0   my($self)=@_;
602              
603 0 0       0   $self->_lock(0)
604                 or croak "Can't lock cache file: $!";
605              
606 0         0   my $err;
607 0 0       0   eval{
608 0         0     local $SIG{__DIE__};
609              
610 0         0     my $buckets=$self->buckets;
611 0         0     my $bucketsize=$self->bucketsize;
612 0         0     my $pagesize=$self->pagesize;
613 0         0     my $empty="\0" x $bucketsize;
614              
615 0         0     for(0..$buckets-1){
616 0         0       substr($self->{_mmap},$pagesize+$bucketsize*$_,$bucketsize)=$empty;
617                 }
618              
619 0         0     1;
620               } or $err=1;
621              
622 0         0   $self->_unlock;
623              
624 0 0       0   die $@ if $err;
625             }
626              
627             =back
628            
629             =head2 CONFIGURATION METHODS
630            
631             These methods are used to examine/update the configuration of a cache.
632             Most of these methods are read-only, and the value returned may be different
633             to that passed to the constructor, since the cache may have been created by
634             an earlier process which specified different parameters.
635            
636             =over
637            
638             =item buckets()
639            
640             Returns the number of buckets in the cache file.
641            
642             =cut
643              
644             sub buckets{
645 7     7 1 75   my($self)=@_;
646              
647 7         91   $self->{buckets};
648             }
649              
650             =item bucketsize()
651            
652             Returns the size of buckets (in bytes) in the cache file.
653            
654             =cut
655              
656             sub bucketsize{
657 87     87 1 1011   my($self)=@_;
658              
659 87         950   $self->{bucketsize};
660             }
661              
662             =item cachenegative()
663            
664             Returns true if items not found in the underlying data are cached anyway.
665            
666             =cut
667              
668             sub cachenegative{
669 1     1 1 12   my($self)=@_;
670              
671 1         17   $self->{cachenegative};
672             }
673              
674             =item context()
675            
676             Returns the context data for reads and writes to the underlying data.
677            
678             =item context($context)
679            
680             Provides new context data for reads and writes to the underlying data.
681            
682             =cut
683              
684             sub context{
685 0     0 1 0   my $self=shift;
686              
687 0 0       0   @_ ? ($self->{context}=$_[0]) : $self->{context};
688             }
689              
690             =item expiry()
691            
692             Returns the time in seconds cache entries are considered valid for, or zero
693             for indefinite validity.
694            
695             =cut
696              
697             sub expiry{
698 54     54 1 487   my($self)=@_;
699              
700 54         676   $self->{expiry};
701             }
702              
703             =item pagesize()
704            
705             Returns the page size (in bytes) of the cache file.
706            
707             =cut
708              
709             sub pagesize{
710 7     7 1 128   my($self)=@_;
711              
712 7         83   $self->{pagesize};
713             }
714              
715             =item strings()
716            
717             Returns true if the cache stores strings rather than references.
718            
719             =cut
720              
721             sub strings{
722 1     1 1 11   my($self)=@_;
723              
724 1         15   $self->{strings};
725             }
726              
727             =item writethrough()
728            
729             Returns true if items written to the cache are immediately written to the
730             underlying data.
731            
732             =cut
733              
734             sub writethrough{
735 1     1 1 9   my($self)=@_;
736              
737 1         15   $self->{writethrough};
738             }
739              
740             =back
741            
742             =begin private
743            
744             =head1 PRIVATE METHODS
745            
746             These methods are for internal use only, and are not for general consumption.
747            
748             =over
749            
750             =item _set_options()
751            
752             If the cache already exists, read its options. Otherwise, set them according
753             to the values passed to the constructor.
754            
755             This method should only be called by the constructor.
756            
757             =cut
758              
759             sub _set_options{
760 11     11   104   my($self)=@_;
761              
762             # Lock file, so only one process sets the size
763 11 50       127   $self->_lock(0)
764                 or croak "Can't lock cache file: $!";
765              
766 11         103   my $err;
767 11 100       103   eval{
768 11         169     local $SIG{__DIE__};
769              
770             # If the file is big enough to contain a header, attempt to read one
771 11         179     my $size_cur= -s $self->{_fh};
772 11         129     my $magic_ok;
773 11 100       169     if($size_cur>=$headsize){
774 3         281       my $head;
775 3 50       207       if((my $bytes=sysread($self->{_fh},$head,$headsize))!=$headsize){
776 0         0 croak "Expecting $headsize bytes, read $bytes from cache header\n";
777                   }
778 3         51       my($mg,$buckets,$bucketsize,$pagesize,$flags,$format)=unpack('l6',$head);
779 3 100       45       $mg==magic
780                     or croak "$self->{_filename} is not a Cache::Mmap file";
781 2 100       37       ($format+=0)==filevers
782                     or croak "$self->{_filename} uses v$format data structures. Cache::Mmap $VERSION only supports v".filevers." data structures";
783              
784 1         14       $self->{buckets}=$buckets;
785 1         10       $self->{bucketsize}=$bucketsize;
786 1         10       $self->{pagesize}=$pagesize;
787 1         17       while(my($opt,$bit)=each %bool_opts){
788 1         15 $self->{$opt}=!!($flags&$bit);
789                   }
790 1         10       $magic_ok=1;
791                 }
792              
793             # Make sure the file is big enough for the whole cache
794 9         253     my $size=$self->{pagesize}+$self->{buckets}*$self->{bucketsize};
795 9 100       110     if($size_cur < $size){
796 8         219       my $pad="\0" x 1024;
797 8 50       127       sysseek $self->{_fh},SEEK_END,0
798             or croak "Can't seek to end of file: $!\n";
799 8         151       while($size_cur < $size){
800 48 50       7560 my $len=syswrite($self->{_fh},$pad,1024)
801             or croak "Can't pad file: $!";
802 48         727 $size_cur+=$len;
803                   }
804 8 50       749       -s $self->{_fh} >= $size
805             or croak "Failed to set correct file size\n";
806                 }
807              
808             # Write file header if it's not already done
809 9 100       136     if(!$magic_ok){
810 8         75       my $flags=0;
811 8         170       while(my($opt,$bit)=each %bool_opts){
812 8 100       184 $flags|=$bit if $self->{$opt};
813                   }
814 8         332       my $head=pack("l6x$headsize",
815             magic,@$self{'buckets','bucketsize','pagesize'},$flags,filevers
816                   );
817 8 50       135       sysseek $self->{_fh},SEEK_SET,0
818             or croak "Can't seek to beginning: $!";
819 8 50       357       syswrite($self->{_fh},$head,$headsize)==$headsize
820             or croak "Can't write file header: $!";
821                 }
822              
823             # mmap() isn't supposed to work on locked files, so unlock
824 9         116     $self->_unlock;
825              
826                 mmap($self->{_mmap}='',$size,$self->{_fh})
827 9 50       268       or do{
828 0         0 delete $self->{_mmap};
829 0         0 croak "Can't mmap $self->{_filename}: $!";
830                   };
831                 length($self->{_mmap}) eq $size
832 9 50       121       or do{
833 0         0         delete $self->{_mmap};
834 0         0 croak "mmap() failed silently: $!";
835                   };
836              
837 9         139     1;
838               } or $err=1;
839              
840             # Unlock file before returning
841 11         120   $self->_unlock;
842              
843             # Propagate caught error if there was one
844 11 100       129   die $@ if $err;
845             }
846              
847             =item DESTROY()
848            
849             Unmap and close the file.
850            
851             =cut
852              
853             sub DESTROY{
854 11     11   116   my($self)=@_;
855              
856 11 100       706   munmap($self->{_mmap}) if exists $self->{_mmap};
857 11         3442   close $self->{_fh};
858             }
859              
860             =item _lock($offset)
861            
862             Lock the cache file. If $offset is zero, the file header is locked.
863             Otherwise, the bucket starting at $offset is locked.
864            
865             XXX This also needs to create an internal lock if threading is enabled.
866            
867             =cut
868              
869             sub _lock{
870 156     156   1441   my($self,$offset)=@_;
871 156 100       7147   my $length=$offset ? $self->{bucketsize} : $headsize;
872              
873 156         4812   _lock_xs($self->{_fh},$offset,$length,1);
874             }
875              
876             =item _unlock()
877            
878             Unlocks the entire cache file.
879            
880             XXX This needs to unlock internal lock and take an offset arg if threading
881            
882             =cut
883              
884             sub _unlock{
885 165     165   1969   my($self)=@_;
886              
887 165         4655   _lock_xs($self->{_fh},0,0,0);
888             }
889              
890             =item _insert($bucket,$ekey,$eval,$write)
891            
892             Inserts the key/value pair into the bucket. The item will be marked as dirty
893             if $write is true, and writethrough() is false.
894            
895             =cut
896              
897             sub _insert{
898 28     28   7481   my($self,$bucket,$ekey,$eval,$write)=@_;
899 28         398   my $klen=length $ekey;
900 28         250   my $vlen=length $eval;
901 28         239   my $size=$eheadsize+$klen+$vlen;
902 28         261   my $bsize=$self->{bucketsize}-$bheadsize;
903 28 50       318   return if $size>$bsize;
904              
905 28   33     2936   my $ehead=substr(pack("l5x$eheadsize",
      50        
906                 $size,time(),$klen,$vlen,($write && !$self->{writethrough} && elem_dirty),
907               ),0,$eheadsize);
908 28         390   my($filled)=unpack 'l',substr($self->{_mmap},$bucket,4);
909 28         475   my $content=$ehead.$ekey.$eval
910                 .substr($self->{_mmap},$bucket+$bheadsize,$filled);
911 28         225   $filled=length $content;
912              
913             # Trim down to fit into bucket
914 28 100       269   if($filled > $bsize){
915             # Find all items which fit in the bucket
916 1         9     my $poff=my $off=$size;
917 1         14     while($off<=$bsize){
918 1         10       $poff=$off;
919 1 50       45       last if $poff>=$filled;
920 1         11       my($size)=unpack 'l',substr($content,$off,4);
921 1         12       $off+=$size;
922                 }
923              
924             # Write remaining items back to underlying data if dirty
925 1 50 33     16     if(my $wsub=$self->{write} && !$self->{writethrough}){
926                   for($off=$poff;$off<$filled;){
927 0         0 my($size,$time,$vlen,$klen,$flags)
928             =unpack 'l5',substr($content,$off,$eheadsize);
929 0 0       0 if(!$size){
930 0         0 my $part=substr($content,$off,length($content)-$off);
931 0         0 my $off=$bucket+$off;
932 0         0 $part=~s/\\/\\\\/g;
933 0         0 $part=~s/([^\040-\176])/sprintf '\\%02x',ord $1/ge;
  0         0  
934 0         0 die "Zero-size entry in $self->{_filename}, offset $off! [ekey=$ekey] Remaining bucket contents: $part";
935 0         0 return;
936             }
937 0 0       0 if($flags & elem_dirty){
938 0         0 my $key=$self->_decode(substr($content,$off+$eheadsize,$klen),1);
939 0         0 my $val=$self->_decode(
940             substr($content,$off+$eheadsize+$klen,$vlen),0);
941 0         0 $wsub->($key,$val,$self->{content});
942             }
943 0         0 $off+=$size;
944 0         0       }
945                 }
946              
947             # Remove dead items
948 1         9     $filled=$poff;
949 1         12     substr($content,$filled)=''; # Chop off the end of the string
950               }
951              
952             # Write the bucket
953 28         331   my $bhead=substr(pack("lx$bheadsize",$filled),0,$bheadsize);
954 28         691   substr($self->{_mmap},$bucket,$bheadsize+$filled)=$bhead.$content;
955             }
956              
957             =item _bucket($key)
958            
959             Returns the offset of the bucket which would hold $key.
960            
961             =cut
962              
963             sub _bucket{
964 80     80   1551   my($self,$key)=@_;
965              
966 80         753   my $hash=0;
967 80         2075   while($key=~/(.)/gs){
968 155         1317     $hash*=33;
969 155         2035     $hash+=ord $1;
970               }
971              
972 5     5   130   my $bucket=do{ no integer; $hash % $self->{buckets}; };
  5         60  
  5         100  
  80         3176  
  80         1035  
973 80         2787   return $self->{pagesize}+$bucket*$self->{bucketsize};
974             }
975              
976             =item _find($bucket,$key)
977            
978             Locate the item keyed by $key in the bucket starting at $bucket.
979            
980             Returns: ($found,$expired,$poff,$off,$size,$klen,$vlen,$flags)
981            
982             =cut
983              
984             sub _find{
985 80     80   2672   my($self,$bucket,$key)=@_;
986 80         1760   my($filled)=unpack 'l',substr($self->{_mmap},$bucket,$bheadsize);
987 80         1128   my $off=$bucket+$bheadsize;
988 80         838   my $end=$off+$filled;
989 80         925   my $b_end=$bucket+$self->bucketsize;
990              
991 80         710   my($found,$size,$time,$klen,$vlen,$flags,$poff);
992 80         1000   while($off<$end){
993 72 100       706     if($off>=$b_end){
994 1         14       die "Super-sized entry in $self->{_filename}, offset $poff! [size=$size, finding key=$key]";
995                 }
996 71         904     ($size,$time,$klen,$vlen,$flags)
997                   =unpack 'l5',substr $self->{_mmap},$off,$eheadsize;
998 71 100       1216     if(!$size){
999 1         12       my $part=substr($self->{_mmap},$off,$end-$off);
1000 1         10       $part=~s/\\/\\\\/g;
1001 1         15       $part=~s/([^\040-\176])/sprintf '\\%02x',ord $1/ge;
  60         715  
1002 1         11       my $prev;
1003 1 50       12       if($poff){
1004 0         0 $prev=" [poff=$poff]";
1005                   }
1006 1         39       local $^W;
1007 1         16       die "Zero-sized entry in $self->{_filename}, offset $off! [bucket=$bucket][key=$key]$prev Remaining bucket contents: $part";
1008                 }
1009 70 100       897     if($self->_decode(substr($self->{_mmap},$off+$eheadsize,$klen),1) eq $key){
1010 48         461       $found=1;
1011 48         504       last;
1012                 }
1013 22         194     $poff=$off;
1014 22         241     $off+=$size;
1015               }
1016              
1017 78 100       2836   return unless $found;
1018              
1019 48         2862   my $expired;
1020 48 100 66     599   if($found and my $exp=$self->expiry){
1021 8         137     $expired=time-$time>$exp;
1022               }
1023              
1024 48         2908   return ($found,$expired,$poff,$off,$size,$klen,$vlen,$flags);
1025             }
1026              
1027             =item _encode($value,$is_key)
1028            
1029             Encodes the given value into a string
1030            
1031             =cut
1032              
1033             sub _encode{
1034 105     105   1256   my($self,$value,$is_key)=@_;
1035              
1036 105 50 100     5660   if(!defined $value){
    100          
1037 0         0     return '';
1038               }elsif($self->{strings} || $is_key){
1039 92         761     if(has_utf8){
1040 92         1009       my $eval=pack 'a*',$value;
1041 92 100       1148       if($eval eq $value){
1042 89         1102         return " $eval";
1043                   }else{
1044 3         46         return "U$eval";
1045                   }
1046                 }else{
1047                   return " $value";
1048                 }
1049               }else{
1050 13         140     return ' '.freeze($value);
1051               }
1052             }
1053              
1054             =item _decode($value,$is_key)
1055            
1056             Decodes the given string value
1057            
1058             =cut
1059              
1060             sub _decode{
1061 138     138   3281   my($self,$value,$is_key)=@_;
1062              
1063 138 50       2312   if($value eq ''){
1064 0         0     return undef;
1065               }else{
1066 138         2872     $value=~s/^(.)//s;
1067 138         3951     my $code=$1;
1068 138 100 100     4836     if($code eq 'U'){
    100          
1069 3         27       if(has_utf8){
1070 3         80         utf8::decode($value);
1071 3         36 return $value;
1072                   }else{
1073                     croak "UTF8 encoded value in $self->{_filename} detected\n";
1074                   }
1075                 }elsif($self->{strings} || $is_key){
1076 105         1240       return $value;
1077                 }else{
1078 30         559       return thaw($value);
1079                 }
1080               }
1081             }
1082              
1083              
1084              
1085             # Return true to require
1086             1;
1087              
1088              
1089             =back
1090            
1091             =end private
1092            
1093             =head1 AUTHOR
1094            
1095             Copyright (C) Institute of Physics Publishing 2002-2005
1096            
1097             Peter Haworth <pmh@edison.ioppublishing.com>
1098            
1099             You may distribute under the terms of the GPL or the Artistic License,
1100             as distributed with Perl.
1101            
1102