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

###########################################################################
# File    - ExpireLRU.pm
#	    Created 12 Feb, 2000, Brent B. Powers
#
# Purpose - This package implements LRU expiration. It does this by
#	    using a bunch of different data structures. Tuning
#	    support is included, but costs performance.
#
# ToDo    - Test the further tie stuff
#
# Copyright(c) 2000 Brent B. Powers and B2Pi LLC
#
# You may copy and distribute this program under the same terms as
# Perl itself.
#
###########################################################################
package Memoize::ExpireLRU;
$Memoize::ExpireLRU::VERSION = '0.55_02'; # TRIAL
use 5.006;
use warnings;
use strict;
use AutoLoader qw(AUTOLOAD);
use Carp;

our $DEBUG = 0;

# Usage:  memoize func ,
# 		TIE => [
# 			Memoize::ExpireLRU,
# 			CACHESIZE => n,
# 			TUNECACHESIZE => m,
#			INSTANCE => IDString
# 			TIE => [...]
# 		       ]

#############################################
##
## This used to all be a bit more reasonable, but then it turns out
## that Memoize doesn't call FETCH if EXISTS returns true and it's in
## scalar context. Thus, everything really has to be done in the
## EXISTS code. Harumph.
##
#############################################

our @AllTies;
our $EndDebug = 0;

1;

sub TIEHASH {
    my ($package, %args, %cache, @index, @Tune, @Stats);
    ($package, %args)= @_;
    my($self) = bless \%args => $package;
    $self->{CACHESIZE} or
	    croak "Memoize::ExpireLRU: CACHESIZE must be specified >0; aborting";
    $self->{TUNECACHESIZE} ||= 0;
    delete($self->{TUNECACHESIZE}) unless $self->{TUNECACHESIZE};
    $self->{C} = \%cache;
    $self->{I} = \@index;
    defined($self->{INSTANCE}) or $self->{INSTANCE} = "$self";
    foreach (@AllTies) {
	if ($_->{INSTANCE} eq $self->{INSTANCE}) {
	    croak "Memoize::ExpireLRU: Attempt to register the same routine twice; aborting";
	}
    }
    if ($self->{TUNECACHESIZE}) {
	$EndDebug = 1;
	for (my $i = 0; $i < $args{TUNECACHESIZE}; $i++) {
	    $Stats[$i] = 0;
	}
	$self->{T} = \@Stats;
	$self->{TI} = \@Tune;
	$self->{cm} = $args{ch} = $args{th} = 0;

    }

    if ($self->{TIE}) {
	my($module, $modulefile, @opts, $rc, %tcache);
	($module, @opts) = @{$args{TIE}};
	$modulefile = $module . '.pm';
	$modulefile =~ s{::}{/}g;
	eval { require $modulefile };
	if ($@) {
	    croak "Memoize::ExpireLRU: Couldn't load hash tie module `$module': $@; aborting";
	}
	$rc = (tie %tcache => $module, @opts);
	unless ($rc) {
	    croak "Memoize::ExpireLRU: Couldn't tie hash to `$module': $@; aborting";
	}

	## Preload our cache
	foreach (keys %tcache) {
	    $self->{C}->{$_} = $tcache{$_}
	}
	$self->{TiC} = \%tcache;
    }

    push(@AllTies, $self);
    return $self;
}

sub EXISTS {
    my($self, $key) = @_;

    $DEBUG and print STDERR " >> $self->{INSTANCE} >> EXISTS: $key\n";

    if (exists $self->{C}->{$key}) {
	my($t, $i);#, %t, %r);

	## Adjust the positions in the index cache
	##    1. Find the old entry in the array (and do the stat's)
	$i = _find($self->{I}, $self->{C}->{$key}->{t}, $key);
	if (!defined($i)) {
	    print STDERR "Cache trashed (unable to find $key)\n";
	    DumpCache($self->{INSTANCE});
	    ShowStats();
	    die "Aborting...";
	}

	##    2. Remove the old entry from the array
	$t = splice(@{$self->{I}}, $i, 1);

	##    3. Update the timestamp of the new array entry, as
	##  well as that in the cache
	$self->{C}->{$key}->{t} = $t->{t} = time;

	##    4. Store the updated entry back into the array as the MRU
	unshift(@{$self->{I}}, $t);

	##    5. Adjust stats
	if (defined($self->{T})) {
	    $self->{T}->[$i]++ if defined($self->{T});
	    $self->{ch}++;
	}

	if ($DEBUG) {
	    print STDERR "    Cache hit at $i";
	    print STDERR " ($self->{ch})" if defined($self->{T});
	    print STDERR ".\n";
	}

	return 1;
    } else {
	if (exists($self->{TUNECACHESIZE})) {
	    $self->{cm}++;
	    $DEBUG and print STDERR "    Cache miss ($self->{cm}).\n";
 	    ## Ughhh. A linear search
	    my($i, $j);
	    for ($i = $j = $self->{CACHESIZE}; $i <= $#{$self->{T}}; $i++) {
		next unless defined($self->{TI})
			&& defined($self->{TI}->[$i- $j])
			&& defined($self->{TI}->[$i - $j]->{k})
			&& $self->{TI}->[$i - $j]->{k} eq $key;
		$self->{T}->[$i]++;
		$self->{th}++;
		$DEBUG and print STDERR "    TestCache hit at $i. ($self->{th})\n";
		splice(@{$self->{TI}}, $i - $j, 1);
		return 0;
	    }
	} else {
	    $DEBUG and print STDERR "    Cache miss.\n";
	}
	return 0;
    }
}

sub STORE {
    my ($self, $key, $value) = @_;
    $DEBUG and print STDERR " >> $self->{INSTANCE} >> STORE: $key $value\n";

    my(%r, %t);
    $t{t} = $r{t} = time;
    $r{v} = $value;
    $t{k} = $key;

    # Store the value into the hash
    $self->{C}->{$key} = \%r;
    ## As well as the tied cache, if it exists
    $self->{TC}->{$key} = $value if defined($self->{TC});

    # By definition, this item is the MRU, so add it to the beginning
    # of the LRU queue. Since this is a STORE, we know it doesn't already
    # exist.
    unshift(@{$self->{I}}, \%t);
    ## Update the tied cache
    $self->{TC}->{$key} = $value if defined($self->{TC});

    ## Do we have too many entries?
    while (scalar(@{$self->{I}}) > $self->{CACHESIZE}) {
	## Chop off whatever is at the end
	## Get the key
	$key = pop(@{$self->{I}});
	delete($self->{C}->{$key->{k}});
	delete($self->{TC}->{$key->{k}}) if defined($self->{TC});
	## Throw it to the beginning of the test cache
	unshift(@{$self->{TI}}, $key) if defined($self->{T});
    }

    ## Now, what about the Tuning Index
    if (defined($self->{T})) {
	if (scalar(@{$self->{TI}}) > $self->{TUNECACHESIZE} - $self->{CACHESIZE}) {
	    $#{$self->{TI}} = $self->{TUNECACHESIZE} - $self->{CACHESIZE} - 1;
	}
    }

    $value;
}

sub FETCH {
    my($self, $key) = @_;

    $DEBUG and print STDERR " >> $self->{INSTANCE} >> FETCH: $key\n";

    return $self->{C}->{$key}->{v};
}

sub _find ( $$$ ) {
    my($Aref, $time, $key) = @_;
    my($t, $b, $n, $l);

    $t = $#{$Aref};
    $n = $b = 0;
    $l = -2;

    while ($time != $Aref->[$n]->{t}) {
	if ($time < $Aref->[$n]->{t}) {
	    $b = $n;
	} else {
	    $t = $n;
	}
	if ($t <= $b) {
	    ## Trouble, we're out.
	    if ($Aref->[$t]->{t} == $time) {
		$n = $t;
	    } elsif ($Aref->[$b]->{t} == $time) {
		$n = $b;
	    } else {
		## Really big trouble
		## Complain loudly
		print "Trouble\n";
		return undef;
	    }
	} else {
	    $n = $b + (($t - $b) >> 1);
	    $n++ if $l == $n;
	    $l = $n;
	}
    }
    ## Drop down in the array until the time isn't the time
    while (($n > 0) && ($time == $Aref->[$n-1]->{t})) {
	$n--;
    }
    while (($time == $Aref->[$n]->{t}) && ($key ne $Aref->[$n]->{k})) {
	$n++;
    }
    if ($key ne $Aref->[$n]->{k}) {
	## More big trouble
	print "More trouble\n";
	return undef;
    }
    return $n;
}

END {
    print STDERR ShowStats() if $EndDebug;
}

__END__