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###########################################################################
17package Memoize::ExpireLRU;
18$Memoize::ExpireLRU::VERSION = '0.56';
19use 5.006;
20use warnings;
21use strict;
22use AutoLoader qw(AUTOLOAD);
23use Carp;
24
25our $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
45our @AllTies;
46our $EndDebug = 0;
47
481;
49
50sub TIEHASH {
51    my ($package, %args, %cache, @index, @Tune, @Stats);
52    ($package, %args)= @_;
53    my($self) = bless \%args => $package;
54    $self->{CACHESIZE} or
55	    croak "Memoize::ExpireLRU: CACHESIZE must be specified >0; aborting";
56    $self->{TUNECACHESIZE} ||= 0;
57    delete($self->{TUNECACHESIZE}) unless $self->{TUNECACHESIZE};
58    $self->{C} = \%cache;
59    $self->{I} = \@index;
60    defined($self->{INSTANCE}) or $self->{INSTANCE} = "$self";
61    foreach (@AllTies) {
62	if ($_->{INSTANCE} eq $self->{INSTANCE}) {
63	    croak "Memoize::ExpireLRU: Attempt to register the same routine twice; aborting";
64	}
65    }
66    if ($self->{TUNECACHESIZE}) {
67	$EndDebug = 1;
68	for (my $i = 0; $i < $args{TUNECACHESIZE}; $i++) {
69	    $Stats[$i] = 0;
70	}
71	$self->{T} = \@Stats;
72	$self->{TI} = \@Tune;
73	$self->{cm} = $args{ch} = $args{th} = 0;
74
75    }
76
77    if ($self->{TIE}) {
78	my($module, $modulefile, @opts, $rc, %tcache);
79	($module, @opts) = @{$args{TIE}};
80	$modulefile = $module . '.pm';
81	$modulefile =~ s{::}{/}g;
82	eval { require $modulefile };
83	if ($@) {
84	    croak "Memoize::ExpireLRU: Couldn't load hash tie module `$module': $@; aborting";
85	}
86	$rc = (tie %tcache => $module, @opts);
87	unless ($rc) {
88	    croak "Memoize::ExpireLRU: Couldn't tie hash to `$module': $@; aborting";
89	}
90
91	## Preload our cache
92	foreach (keys %tcache) {
93	    $self->{C}->{$_} = $tcache{$_}
94	}
95	$self->{TiC} = \%tcache;
96    }
97
98    push(@AllTies, $self);
99    return $self;
100}
101
102sub EXISTS {
103    my($self, $key) = @_;
104
105    $DEBUG and print STDERR " >> $self->{INSTANCE} >> EXISTS: $key\n";
106
107    if (exists $self->{C}->{$key}) {
108	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	$i = _find($self->{I}, $self->{C}->{$key}->{t}, $key);
113	if (!defined($i)) {
114	    print STDERR "Cache trashed (unable to find $key)\n";
115	    DumpCache($self->{INSTANCE});
116	    ShowStats();
117	    die "Aborting...";
118	}
119
120	##    2. Remove the old entry from the array
121	$t = splice(@{$self->{I}}, $i, 1);
122
123	##    3. Update the timestamp of the new array entry, as
124	##  well as that in the cache
125	$self->{C}->{$key}->{t} = $t->{t} = time;
126
127	##    4. Store the updated entry back into the array as the MRU
128	unshift(@{$self->{I}}, $t);
129
130	##    5. Adjust stats
131	if (defined($self->{T})) {
132	    $self->{T}->[$i]++ if defined($self->{T});
133	    $self->{ch}++;
134	}
135
136	if ($DEBUG) {
137	    print STDERR "    Cache hit at $i";
138	    print STDERR " ($self->{ch})" if defined($self->{T});
139	    print STDERR ".\n";
140	}
141
142	return 1;
143    } else {
144	if (exists($self->{TUNECACHESIZE})) {
145	    $self->{cm}++;
146	    $DEBUG and print STDERR "    Cache miss ($self->{cm}).\n";
147 	    ## Ughhh. A linear search
148	    my($i, $j);
149	    for ($i = $j = $self->{CACHESIZE}; $i <= $#{$self->{T}}; $i++) {
150		next unless defined($self->{TI})
151			&& defined($self->{TI}->[$i- $j])
152			&& defined($self->{TI}->[$i - $j]->{k})
153			&& $self->{TI}->[$i - $j]->{k} eq $key;
154		$self->{T}->[$i]++;
155		$self->{th}++;
156		$DEBUG and print STDERR "    TestCache hit at $i. ($self->{th})\n";
157		splice(@{$self->{TI}}, $i - $j, 1);
158		return 0;
159	    }
160	} else {
161	    $DEBUG and print STDERR "    Cache miss.\n";
162	}
163	return 0;
164    }
165}
166
167sub STORE {
168    my ($self, $key, $value) = @_;
169    $DEBUG and print STDERR " >> $self->{INSTANCE} >> STORE: $key $value\n";
170
171    my(%r, %t);
172    $t{t} = $r{t} = time;
173    $r{v} = $value;
174    $t{k} = $key;
175
176    # Store the value into the hash
177    $self->{C}->{$key} = \%r;
178    ## As well as the tied cache, if it exists
179    $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    unshift(@{$self->{I}}, \%t);
185    ## Update the tied cache
186    $self->{TC}->{$key} = $value if defined($self->{TC});
187
188    ## Do we have too many entries?
189    while (scalar(@{$self->{I}}) > $self->{CACHESIZE}) {
190	## Chop off whatever is at the end
191	## Get the key
192	$key = pop(@{$self->{I}});
193	delete($self->{C}->{$key->{k}});
194	delete($self->{TC}->{$key->{k}}) if defined($self->{TC});
195	## Throw it to the beginning of the test cache
196	unshift(@{$self->{TI}}, $key) if defined($self->{T});
197    }
198
199    ## Now, what about the Tuning Index
200    if (defined($self->{T})) {
201	if (scalar(@{$self->{TI}}) > $self->{TUNECACHESIZE} - $self->{CACHESIZE}) {
202	    $#{$self->{TI}} = $self->{TUNECACHESIZE} - $self->{CACHESIZE} - 1;
203	}
204    }
205
206    $value;
207}
208
209sub FETCH {
210    my($self, $key) = @_;
211
212    $DEBUG and print STDERR " >> $self->{INSTANCE} >> FETCH: $key\n";
213
214    return $self->{C}->{$key}->{v};
215}
216
217sub _find ( $$$ ) {
218    my($Aref, $time, $key) = @_;
219    my($t, $b, $n, $l);
220
221    $t = $#{$Aref};
222    $n = $b = 0;
223    $l = -2;
224
225    while ($time != $Aref->[$n]->{t}) {
226	if ($time < $Aref->[$n]->{t}) {
227	    $b = $n;
228	} else {
229	    $t = $n;
230	}
231	if ($t <= $b) {
232	    ## Trouble, we're out.
233	    if ($Aref->[$t]->{t} == $time) {
234		$n = $t;
235	    } elsif ($Aref->[$b]->{t} == $time) {
236		$n = $b;
237	    } else {
238		## Really big trouble
239		## Complain loudly
240		print "Trouble\n";
241		return undef;
242	    }
243	} else {
244	    $n = $b + (($t - $b) >> 1);
245	    $n++ if $l == $n;
246	    $l = $n;
247	}
248    }
249    ## Drop down in the array until the time isn't the time
250    while (($n > 0) && ($time == $Aref->[$n-1]->{t})) {
251	$n--;
252    }
253    while (($time == $Aref->[$n]->{t}) && ($key ne $Aref->[$n]->{k})) {
254	$n++;
255    }
256    if ($key ne $Aref->[$n]->{k}) {
257	## More big trouble
258	print "More trouble\n";
259	return undef;
260    }
261    return $n;
262}
263
264END {
265    print STDERR ShowStats() if $EndDebug;
266}
267
268__END__
269
270sub DumpCache ( $ ) {
271    ## Utility routine to display the caches of the given instance
272    my($Instance, $self, $p) = shift;
273    foreach $self (@AllTies) {
274
275	next unless $self->{INSTANCE} eq $Instance;
276
277	$p = "$Instance:\n    Cache Keys:\n";
278
279	foreach my $x (@{$self->{I}}) {
280	    ## The cache is at $self->{C} (->{$key})
281	    $p .= "        '$x->{k}'\n";
282	}
283	$p .= "    Test Cache Keys:\n";
284	foreach my $x (@{$self->{TI}}) {
285	    $p .= "        '$x->{k}'\n";
286	}
287	return $p;
288    }
289    return "Instance $Instance not found\n";
290}
291
292
293sub ShowStats () {
294    ## Utility routine to show statistics
295    my($k) = 0;
296    my($p) = '';
297    foreach my $self (@AllTies) {
298	next unless defined($self->{T});
299	$p .= "ExpireLRU Statistics:\n" unless $k;
300	$k++;
301
302	$p .= <<EOS;
303
304                   ExpireLRU instantiation: $self->{INSTANCE}
305                                Cache Size: $self->{CACHESIZE}
306                   Experimental Cache Size: $self->{TUNECACHESIZE}
307                                Cache Hits: $self->{ch}
308                              Cache Misses: $self->{cm}
309Additional Cache Hits at Experimental Size: $self->{th}
310                             Distribution : Hits
311EOS
312	for (my $i = 0; $i < $self->{TUNECACHESIZE}; $i++) {
313	    if ($i == $self->{CACHESIZE}) {
314		$p .= "                                     ----   -----\n";
315	    }
316	    $p .= sprintf("                                      %3d : %s\n",
317			  $i, $self->{T}->[$i]);
318	}
319    }
320    return $p;
321}
322
323=head1 NAME
324
325Memoize::ExpireLRU - Expiry plug-in for Memoize that adds LRU cache expiration
326
327=head1 SYNOPSIS
328
329    use Memoize;
330
331    memoize('slow_function',
332	    TIE => [Memoize::ExpireLRU,
333		    CACHESIZE => n,
334	           ]);
335
336Note that one need not C<use> this module.
337It will be found by the L<Memoize> module.
338
339The argument to C<CACHESIZE> must be an integer.
340Normally, this is all that is needed.
341Additional options are available:
342
343	TUNECACHESIZE => m,
344	INSTANCE      => 'descriptive_name',
345	TIE           => '[DB_File, $filename, O_RDWR | O_CREATE, 0666]'
346
347=head1 DESCRIPTION
348
349For the theory of Memoization, please see the Memoize module
350documentation. This module implements an expiry policy for Memoize
351that follows LRU semantics, that is, the last n results, where n is
352specified as the argument to the C<CACHESIZE> parameter, will be
353cached.
354
355=head1 PERFORMANCE TUNING
356
357It is often quite difficult to determine what size cache will give
358optimal results for a given function. To aid in determining this,
359ExpireLRU includes cache tuning support. Enabling this causes a
360definite performance hit, but it is often useful before code is
361released to production.
362
363To enable cache tuning support, simply specify the optional
364C<TUNECACHESIZE> parameter with a size greater than that of the
365C<CACHESIZE> parameter.
366
367When the program exits, a set of statistics will be printed to
368stderr. If multiple routines have been memoized, separate sets of
369statistics are printed for each routine. The default names are
370somewhat cryptic: this is the purpose of the C<INSTANCE>
371parameter. The value of this parameter will be used as the identifier
372within the statistics report.
373
374=head1 DIAGNOSTIC METHODS
375
376Two additional routines are available but not
377exported. Memoize::ExpireLRU::ShowStats returns a string identical to
378the statistics report printed to STDERR at the end of the program if
379test caches have been enabled; Memoize::ExpireLRU::DumpCache takes the
380instance name of a memoized function as a parameter, and returns a
381string describing the current state of that instance.
382
383
384=head1 SEE ALSO
385
386L<Memoize>
387
388
389=head1 REPOSITORY
390
391L<https://github.com/neilb/Memoize-ExpireLRU>
392
393
394=head1 AUTHOR
395
396Brent B. Powers (B2Pi), Powers@B2Pi.com
397
398
399=head1 COPYRIGHT AND LICENSE
400
401This software is copyright (c) 1999 by Brent B. Powers.
402
403This is free software; you can redistribute it and/or modify it under
404the same terms as the Perl 5 programming language system itself.
405
406=cut
407