File Coverage

blib/lib/Memoize/ExpireLRU.pm
Criterion Covered Total %
statement 131 170 77.0
branch 44 78 56.4
condition 12 17 70.5
subroutine 13 13 100.0
pod 0 2 0.0
total 200 280 71.4


line stmt bran cond sub pod time code
1             ###########################################################################
2             # File - ExpireLRU.pm
3             # Created 12 Feb, 2000, Brent B. Powers
4             #
5             # Purpose - This package implements LRU expiration. It does this by
6             # using a bunch of different data structures. Tuning
7             # support is included, but costs performance.
8             #
9             # ToDo - Test the further tie stuff
10             #
11             # Copyright(c) 2000 Brent B. Powers and B2Pi LLC
12             #
13             # You may copy and distribute this program under the same terms as
14             # Perl itself.
15             #
16             ###########################################################################
17             package Memoize::ExpireLRU;
18             $Memoize::ExpireLRU::VERSION = '0.56';
19 1     1   2675 use 5.006;
  1         2  
20 1     1   3 use warnings;
  1         1  
  1         19  
21 1     1   3 use strict;
  1         3  
  1         16  
22 1     1   461 use AutoLoader qw(AUTOLOAD);
  1         1014  
  1         6  
23 1     1   25 use Carp;
  1         1  
  1         1058  
24              
25             our $DEBUG = 0;
26              
27             # Usage: memoize func ,
28             # TIE => [
29             # Memoize::ExpireLRU,
30             # CACHESIZE => n,
31             # TUNECACHESIZE => m,
32             # INSTANCE => IDString
33             # TIE => [...]
34             # ]
35              
36             #############################################
37             ##
38             ## This used to all be a bit more reasonable, but then it turns out
39             ## that Memoize doesn't call FETCH if EXISTS returns true and it's in
40             ## scalar context. Thus, everything really has to be done in the
41             ## EXISTS code. Harumph.
42             ##
43             #############################################
44              
45             our @AllTies;
46             our $EndDebug = 0;
47              
48             1;
49              
50             sub TIEHASH {
51 3     3   408 my ($package, %args, %cache, @index, @Tune, @Stats);
52 3         9 ($package, %args)= @_;
53 3         4 my($self) = bless \%args => $package;
54             $self->{CACHESIZE} or
55 3 50       9 croak "Memoize::ExpireLRU: CACHESIZE must be specified >0; aborting";
56 3   100     7 $self->{TUNECACHESIZE} ||= 0;
57 3 100       6 delete($self->{TUNECACHESIZE}) unless $self->{TUNECACHESIZE};
58 3         4 $self->{C} = \%cache;
59 3         2 $self->{I} = \@index;
60 3 50       6 defined($self->{INSTANCE}) or $self->{INSTANCE} = "$self";
61 3         6 foreach (@AllTies) {
62 3 50       8 if ($_->{INSTANCE} eq $self->{INSTANCE}) {
63 0         0 croak "Memoize::ExpireLRU: Attempt to register the same routine twice; aborting";
64             }
65             }
66 3 100       5 if ($self->{TUNECACHESIZE}) {
67 2         3 $EndDebug = 1;
68 2         4 for (my $i = 0; $i < $args{TUNECACHESIZE}; $i++) {
69 11         16 $Stats[$i] = 0;
70             }
71 2         2 $self->{T} = \@Stats;
72 2         1 $self->{TI} = \@Tune;
73 2         5 $self->{cm} = $args{ch} = $args{th} = 0;
74            
75             }
76              
77 3 50       6 if ($self->{TIE}) {
78 0         0 my($module, $modulefile, @opts, $rc, %tcache);
79 0         0 ($module, @opts) = @{$args{TIE}};
  0         0  
80 0         0 $modulefile = $module . '.pm';
81 0         0 $modulefile =~ s{::}{/}g;
82 0         0 eval { require $modulefile };
  0         0  
83 0 0       0 if ($@) {
84 0         0 croak "Memoize::ExpireLRU: Couldn't load hash tie module `$module': $@; aborting";
85             }
86 0         0 $rc = (tie %tcache => $module, @opts);
87 0 0       0 unless ($rc) {
88 0         0 croak "Memoize::ExpireLRU: Couldn't tie hash to `$module': $@; aborting";
89             }
90              
91             ## Preload our cache
92 0         0 foreach (keys %tcache) {
93 0         0 $self->{C}->{$_} = $tcache{$_}
94             }
95 0         0 $self->{TiC} = \%tcache;
96             }
97              
98 3         4 push(@AllTies, $self);
99 3         8 return $self;
100             }
101              
102             sub EXISTS {
103 46     46   2298 my($self, $key) = @_;
104              
105 46 50       89 $DEBUG and print STDERR " >> $self->{INSTANCE} >> EXISTS: $key\n";
106              
107 46 100       82 if (exists $self->{C}->{$key}) {
108 24         32 my($t, $i);#, %t, %r);
109              
110             ## Adjust the positions in the index cache
111             ## 1. Find the old entry in the array (and do the stat's)
112 24         44 $i = _find($self->{I}, $self->{C}->{$key}->{t}, $key);
113 24 50       38 if (!defined($i)) {
114 0         0 print STDERR "Cache trashed (unable to find $key)\n";
115 0         0 DumpCache($self->{INSTANCE});
116 0         0 ShowStats();
117 0         0 die "Aborting...";
118             }
119              
120             ## 2. Remove the old entry from the array
121 24         18 $t = splice(@{$self->{I}}, $i, 1);
  24         44  
122              
123             ## 3. Update the timestamp of the new array entry, as
124             ## well as that in the cache
125 24         34 $self->{C}->{$key}->{t} = $t->{t} = time;
126              
127             ## 4. Store the updated entry back into the array as the MRU
128 24         18 unshift(@{$self->{I}}, $t);
  24         34  
129              
130             ## 5. Adjust stats
131 24 100       38 if (defined($self->{T})) {
132 21 50       37 $self->{T}->[$i]++ if defined($self->{T});
133 21         58 $self->{ch}++;
134             }
135              
136 24 50       35 if ($DEBUG) {
137 0         0 print STDERR " Cache hit at $i";
138 0 0       0 print STDERR " ($self->{ch})" if defined($self->{T});
139 0         0 print STDERR ".\n";
140             }
141              
142 24         52 return 1;
143             } else {
144 22 100       34 if (exists($self->{TUNECACHESIZE})) {
145 16         14 $self->{cm}++;
146 16 50       24 $DEBUG and print STDERR " Cache miss ($self->{cm}).\n";
147             ## Ughhh. A linear search
148 16         15 my($i, $j);
149 16         15 for ($i = $j = $self->{CACHESIZE}; $i <= $#{$self->{T}}; $i++) {
  56         118  
150             next unless defined($self->{TI})
151             && defined($self->{TI}->[$i- $j])
152             && defined($self->{TI}->[$i - $j]->{k})
153 45 100 66     301 && $self->{TI}->[$i - $j]->{k} eq $key;
      66        
      100        
154 5         7 $self->{T}->[$i]++;
155 5         3 $self->{th}++;
156 5 50       10 $DEBUG and print STDERR " TestCache hit at $i. ($self->{th})\n";
157 5         6 splice(@{$self->{TI}}, $i - $j, 1);
  5         12  
158 5         19 return 0;
159             }
160             } else {
161 6 50       13 $DEBUG and print STDERR " Cache miss.\n";
162             }
163 17         35 return 0;
164             }
165             }
166              
167             sub STORE {
168 22     22   251 my ($self, $key, $value) = @_;
169 22 50       37 $DEBUG and print STDERR " >> $self->{INSTANCE} >> STORE: $key $value\n";
170              
171 22         18 my(%r, %t);
172 22         45 $t{t} = $r{t} = time;
173 22         38 $r{v} = $value;
174 22         28 $t{k} = $key;
175              
176             # Store the value into the hash
177 22         30 $self->{C}->{$key} = \%r;
178             ## As well as the tied cache, if it exists
179 22 50       40 $self->{TC}->{$key} = $value if defined($self->{TC});
180              
181             # By definition, this item is the MRU, so add it to the beginning
182             # of the LRU queue. Since this is a STORE, we know it doesn't already
183             # exist.
184 22         22 unshift(@{$self->{I}}, \%t);
  22         41  
185             ## Update the tied cache
186 22 50       38 $self->{TC}->{$key} = $value if defined($self->{TC});
187              
188             ## Do we have too many entries?
189 22         20 while (scalar(@{$self->{I}}) > $self->{CACHESIZE}) {
  35         78  
190             ## Chop off whatever is at the end
191             ## Get the key
192 13         13 $key = pop(@{$self->{I}});
  13         18  
193 13         35 delete($self->{C}->{$key->{k}});
194 13 50       23 delete($self->{TC}->{$key->{k}}) if defined($self->{TC});
195             ## Throw it to the beginning of the test cache
196 13 100       27 unshift(@{$self->{TI}}, $key) if defined($self->{T});
  11         20  
197             }
198              
199             ## Now, what about the Tuning Index
200 22 100       40 if (defined($self->{T})) {
201 16 100       14 if (scalar(@{$self->{TI}}) > $self->{TUNECACHESIZE} - $self->{CACHESIZE}) {
  16         39  
202 1         2 $#{$self->{TI}} = $self->{TUNECACHESIZE} - $self->{CACHESIZE} - 1;
  1         4  
203             }
204             }
205              
206 22         63 $value;
207             }
208              
209             sub FETCH {
210 24     24   133 my($self, $key) = @_;
211              
212 24 50       34 $DEBUG and print STDERR " >> $self->{INSTANCE} >> FETCH: $key\n";
213              
214 24         110 return $self->{C}->{$key}->{v};
215             }
216              
217             sub _find ( $$$ ) {
218 24     24   24 my($Aref, $time, $key) = @_;
219 24         19 my($t, $b, $n, $l);
220              
221 24         17 $t = $#{$Aref};
  24         30  
222 24         24 $n = $b = 0;
223 24         19 $l = -2;
224              
225 24         72 while ($time != $Aref->[$n]->{t}) {
226 0 0       0 if ($time < $Aref->[$n]->{t}) {
227 0         0 $b = $n;
228             } else {
229 0         0 $t = $n;
230             }
231 0 0       0 if ($t <= $b) {
232             ## Trouble, we're out.
233 0 0       0 if ($Aref->[$t]->{t} == $time) {
    0          
234 0         0 $n = $t;
235             } elsif ($Aref->[$b]->{t} == $time) {
236 0         0 $n = $b;
237             } else {
238             ## Really big trouble
239             ## Complain loudly
240 0         0 print "Trouble\n";
241 0         0 return undef;
242             }
243             } else {
244 0         0 $n = $b + (($t - $b) >> 1);
245 0 0       0 $n++ if $l == $n;
246 0         0 $l = $n;
247             }
248             }
249             ## Drop down in the array until the time isn't the time
250 24   33     50 while (($n > 0) && ($time == $Aref->[$n-1]->{t})) {
251 0         0 $n--;
252             }
253 24   66     98 while (($time == $Aref->[$n]->{t}) && ($key ne $Aref->[$n]->{k})) {
254 45         138 $n++;
255             }
256 24 50       41 if ($key ne $Aref->[$n]->{k}) {
257             ## More big trouble
258 0         0 print "More trouble\n";
259 0         0 return undef;
260             }
261 24         29 return $n;
262             }
263              
264             END {
265 1 50   1   49 print STDERR ShowStats() if $EndDebug;
266             }
267              
268             __END__