File Coverage

blib/lib/Memoize/Expire.pm
Criterion Covered Total %
statement 54 67 80.6
branch 18 36 50.0
condition 15 15 100.0
subroutine 12 12 100.0
pod n/a
total 99 130 76.1


line stmt bran cond sub pod time code
1 2     2   1057 use strict; use warnings;
  2     2   4  
  2         60  
  2         10  
  2         2  
  2         136  
2              
3             package Memoize::Expire;
4             our $VERSION = '1.16';
5              
6 2     2   12 use Carp;
  2         3  
  2         258  
7             our $DEBUG;
8              
9             # The format of the metadata is:
10             # (4-byte number of last-access-time) (For LRU when I implement it)
11             # (4-byte expiration time: unsigned seconds-since-unix-epoch)
12             # (2-byte number-of-uses-before-expire)
13              
14             BEGIN {
15 2     2   7 eval {require Time::HiRes};
  2         2253  
16 2 50       3038 unless ($@) {
17 2         9 Time::HiRes->import('time');
18             }
19             }
20              
21             sub TIEHASH {
22 3     3   1223 my ($package, %args) = @_;
23 3         7 my %cache;
24 3 50       14 if ($args{TIE}) {
25 0         0 my ($module, @opts) = @{$args{TIE}};
  0         0  
26 0         0 my $modulefile = $module . '.pm';
27 0         0 $modulefile =~ s{::}{/}g;
28 0         0 eval { require $modulefile };
  0         0  
29 0 0       0 if ($@) {
30 0         0 croak "Memoize::Expire: Couldn't load hash tie module `$module': $@; aborting";
31             }
32 0         0 my $rc = (tie %cache => $module, @opts);
33 0 0       0 unless ($rc) {
34 0         0 croak "Memoize::Expire: Couldn't tie hash to `$module': $@; aborting";
35             }
36             }
37 3   100     17 $args{LIFETIME} ||= 0;
38 3   100     15 $args{NUM_USES} ||= 0;
39 3   100     15 $args{C} = delete $args{HASH} || \%cache;
40 3         14 bless \%args => $package;
41             }
42              
43             sub STORE {
44 14 50   14   1881 $DEBUG and print STDERR " >> Store $_[1] $_[2]\n";
45 14         48 my ($self, $key, $value) = @_;
46 14 100       97 my $expire_time = $self->{LIFETIME} > 0 ? $self->{LIFETIME} + time : 0;
47             # The call that results in a value to store into the cache is the
48             # first of the NUM_USES allowed calls.
49 14         81 my $header = _make_header(time, $expire_time, $self->{NUM_USES}-1);
50 14         53 @{$self->{C}}{"H$key", "V$key"} = ($header, $value);
  14         78  
51 14         55 $value;
52             }
53              
54             sub FETCH {
55 27 50   27   144 $DEBUG and print STDERR " >> Fetch cached value for $_[1]\n";
56 27         138 my ($last_access, $expire_time, $num_uses_left) = _get_header($_[0]{C}{"H$_[1]"});
57 27 50       94 $DEBUG and print STDERR " >> (ttl: ", ($expire_time-time()), ", nuses: $num_uses_left)\n";
58 27         155 $_[0]{C}{"H$_[1]"} = _make_header(time, $expire_time, --$num_uses_left);
59 27         272 $_[0]{C}{"V$_[1]"};
60             }
61              
62             sub EXISTS {
63 35 50   35   168 $DEBUG and print STDERR " >> Exists $_[1]\n";
64 35 100       342 unless (exists $_[0]{C}{"V$_[1]"}) {
65 7 50       57 $DEBUG and print STDERR " Not in underlying hash at all.\n";
66 7         45 return 0;
67             }
68 28         128 my $item = $_[0]{C}{"H$_[1]"};
69 28         203 my ($last_access, $expire_time, $num_uses_left) = _get_header($item);
70 28         295 my $ttl = $expire_time - time;
71 28 50       139 if ($DEBUG) {
72 0 0       0 $_[0]{LIFETIME} and print STDERR " Time to live for this item: $ttl\n";
73 0 0       0 $_[0]{NUM_USES} and print STDERR " Uses remaining: $num_uses_left\n";
74             }
75 28 100 100     464 if ( (! $_[0]{LIFETIME} || $expire_time > time)
      100        
      100        
76             && (! $_[0]{NUM_USES} || $num_uses_left > 0 )) {
77 23 50       70 $DEBUG and print STDERR " (Still good)\n";
78 23         386 return 1;
79             } else {
80 5 50       30 $DEBUG and print STDERR " (Expired)\n";
81 5         49 return 0;
82             }
83             }
84              
85             sub FIRSTKEY {
86 1     1   3 scalar keys %{$_[0]{C}};
  1         4  
87 1         4 &NEXTKEY;
88             }
89              
90             sub NEXTKEY {
91 3     3   4 while (defined(my $key = each %{$_[0]{C}})) {
  5         17  
92 4 100       18 return substr $key, 1 if 'V' eq substr $key, 0, 1;
93             }
94 1         4 undef;
95             }
96              
97             # Arguments: last access time, expire time, number of uses remaining
98             sub _make_header {
99 41     41   409 pack "N N n", @_;
100             }
101              
102             # Return last access time, expire time, number of uses remaining
103             sub _get_header {
104 55     55   481 unpack "N N n", substr($_[0], 0, 10);
105             }
106              
107             1;
108              
109             __END__