292 lines
7.5 KiB
Perl
Executable File
292 lines
7.5 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
#
|
|
# LJ::Cache class
|
|
# See perldoc documentation at the end of this file.
|
|
#
|
|
# -------------------------------------------------------------------------
|
|
#
|
|
# This package is released under the LGPL (GNU Library General Public License)
|
|
#
|
|
# A copy of the license has been included with the software as LGPL.txt.
|
|
# If not, the license is available at:
|
|
# http://www.gnu.org/copyleft/library.txt
|
|
#
|
|
# -------------------------------------------------------------------------
|
|
#
|
|
|
|
package LJ::Cache;
|
|
|
|
use strict;
|
|
use fields qw(items size tail head bytes maxsize maxbytes);
|
|
|
|
use vars qw($VERSION);
|
|
use constant PREVKEY => 0;
|
|
use constant VALUE => 1;
|
|
use constant NEXTKEY => 2;
|
|
use constant BYTES => 3;
|
|
use constant INSTIME => 4;
|
|
use constant FLAGS => 5; # caller-defined metadata
|
|
|
|
$VERSION = '1.0';
|
|
|
|
sub new {
|
|
my ($class, $args) = @_;
|
|
my $self = fields::new($class);
|
|
|
|
$self->init($args);
|
|
return $self;
|
|
}
|
|
|
|
sub walk_items {
|
|
my LJ::Cache $self = shift;
|
|
my $code = shift;
|
|
|
|
my $iter = $self->{'head'};
|
|
while ($iter) {
|
|
my $it = $self->{'items'}->{$iter};
|
|
$code->($iter, $it->[BYTES], $it->[INSTIME]);
|
|
$iter = $it->[NEXTKEY];
|
|
}
|
|
}
|
|
|
|
sub init {
|
|
my LJ::Cache $self = shift;
|
|
my $args = shift;
|
|
|
|
$self->{'head'} = 0;
|
|
$self->{'tail'} = 0;
|
|
$self->{'items'} = {}; # key -> arrayref, indexed by constants above
|
|
$self->{'size'} = 0;
|
|
$self->{'bytes'} = 0;
|
|
$self->{'maxsize'} = $args->{'maxsize'}+0;
|
|
$self->{'maxbytes'} = $args->{'maxbytes'}+0;
|
|
}
|
|
|
|
sub get_item_count {
|
|
my LJ::Cache $self = shift;
|
|
$self->{'size'};
|
|
}
|
|
|
|
sub get_byte_count {
|
|
my LJ::Cache $self = shift;
|
|
$self->{'bytes'};
|
|
}
|
|
|
|
sub get_max_age {
|
|
my LJ::Cache $self = shift;
|
|
return undef unless $self->{'tail'};
|
|
return $self->{'items'}->{$self->{'tail'}}->[INSTIME];
|
|
}
|
|
|
|
sub validate_list
|
|
{
|
|
my ($self, $source) = @_;
|
|
print "Validate list: $self->{'size'} (max: $self->{'maxsize'})\n";
|
|
|
|
my $count = 1;
|
|
if ($self->{'size'} && ! defined $self->{'head'}) {
|
|
die "$source: no head pointer\n";
|
|
}
|
|
if ($self->{'size'} && ! defined $self->{'tail'}) {
|
|
die "$source: no tail pointer\n";
|
|
}
|
|
if ($self->{'size'}) {
|
|
print " head: $self->{'head'}\n";
|
|
print " tail: $self->{'tail'}\n";
|
|
}
|
|
|
|
my $iter = $self->{'head'};
|
|
my $last = undef;
|
|
while ($count <= $self->{'size'}) {
|
|
if (! defined $iter) {
|
|
die "$source: undefined iterator\n";
|
|
}
|
|
my $item = $self->{'items'}->{$iter};
|
|
unless (defined $item) {
|
|
die "$source: item '$iter' isn't in items\n";
|
|
}
|
|
my $prevtext = $item->[PREVKEY] || "--";
|
|
my $nexttext = $item->[NEXTKEY] || "--";
|
|
print " #$count ($iter): [$prevtext, $item->[VALUE], $nexttext]\n";
|
|
if ($count == 1 && defined($item->[0])) {
|
|
die "$source: Head element shouldn't have previous pointer!\n";
|
|
}
|
|
if ($count == $self->{'size'} && defined($item->[NEXTKEY])) {
|
|
die "$source: Last element shouldn't have next pointer!\n";
|
|
}
|
|
if (defined $last && ! defined $item->[PREVKEY]) {
|
|
die "$source: defined \$last but not defined previous pointer.\n";
|
|
}
|
|
if (! defined $last && defined $item->[PREVKEY]) {
|
|
die "$source: not defined \$last but previous pointer defined.\n";
|
|
}
|
|
if (defined $item->[PREVKEY] && defined $last && $item->[PREVKEY] ne $last)
|
|
{
|
|
die "$source: Previous pointer is wrong.\n";
|
|
}
|
|
|
|
$last = $iter;
|
|
$iter = defined $item->[NEXTKEY] ? $item->[NEXTKEY] : undef;
|
|
$count++;
|
|
}
|
|
}
|
|
|
|
sub drop_tail
|
|
{
|
|
my LJ::Cache $self = shift;
|
|
|
|
## who's going to die?
|
|
my $to_die = $self->{'tail'};
|
|
|
|
## set the tail to the item before the one dying.
|
|
$self->{'tail'} = $self->{'items'}->{$to_die}->[PREVKEY];
|
|
|
|
## adjust the forward pointer on the tail to be undef
|
|
if (defined $self->{'tail'}) {
|
|
undef $self->{'items'}->{$self->{'tail'}}->[NEXTKEY];
|
|
}
|
|
|
|
## kill the item
|
|
my $bytes = $self->{'items'}->{$to_die}->[BYTES];
|
|
delete $self->{'items'}->{$to_die};
|
|
|
|
## shrink the overall size
|
|
$self->{'size'}--;
|
|
$self->{'bytes'} -= $bytes;
|
|
}
|
|
|
|
sub print_list {
|
|
my LJ::Cache $self = shift;
|
|
|
|
print "Size: $self->{'size'} (max: $self->{'maxsize'})\n";
|
|
|
|
my $count = 1;
|
|
my $iter = $self->{'head'};
|
|
while (defined $iter) { #$count <= $self->{'size'}) {
|
|
my $item = $self->{'items'}->{$iter};
|
|
print "$count: $iter = $item->[VALUE]\n";
|
|
$iter = $item->[NEXTKEY];
|
|
$count++;
|
|
}
|
|
}
|
|
|
|
sub get {
|
|
my LJ::Cache $self = shift;
|
|
my ($key, $out_flags) = @_;
|
|
|
|
if (exists $self->{'items'}->{$key})
|
|
{
|
|
my $item = $self->{'items'}->{$key};
|
|
|
|
# promote this to the head
|
|
unless ($self->{'head'} eq $key)
|
|
{
|
|
if ($self->{'tail'} eq $key) {
|
|
$self->{'tail'} = $item->[PREVKEY];
|
|
}
|
|
# remove this element from the linked list.
|
|
my $next = $item->[NEXTKEY];
|
|
my $prev = $item->[PREVKEY];
|
|
if (defined $next) { $self->{'items'}->{$next}->[PREVKEY] = $prev; }
|
|
if (defined $prev) { $self->{'items'}->{$prev}->[NEXTKEY] = $next; }
|
|
|
|
# make current head point backwards to this item
|
|
$self->{'items'}->{$self->{'head'}}->[PREVKEY] = $key;
|
|
|
|
# make this item point forwards to current head, and backwards nowhere
|
|
$item->[NEXTKEY] = $self->{'head'};
|
|
undef $item->[PREVKEY];
|
|
|
|
# make this the new head
|
|
$self->{'head'} = $key;
|
|
}
|
|
|
|
$$out_flags = $item->[FLAGS] if $out_flags;
|
|
return $item->[VALUE];
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
# bytes is optional
|
|
sub set {
|
|
my LJ::Cache $self = shift;
|
|
my ($key, $value, $bytes, $flags) = @_;
|
|
|
|
$self->drop_tail() while ($self->{'maxsize'} &&
|
|
$self->{'size'} >= $self->{'maxsize'} &&
|
|
! exists $self->{'items'}->{$key}) ||
|
|
($self->{'maxbytes'} && $self->{'size'} &&
|
|
$self->{'bytes'} + $bytes >= $self->{'maxbytes'} &&
|
|
! exists $self->{'items'}->{$key});
|
|
|
|
|
|
if (exists $self->{'items'}->{$key}) {
|
|
# update the value
|
|
my $it = $self->{'items'}->{$key};
|
|
$it->[VALUE] = $value;
|
|
my $bytedelta = $bytes - $it->[BYTES];
|
|
$self->{'bytes'} += $bytedelta;
|
|
$it->[BYTES] = $bytes;
|
|
$it->[FLAGS] = $flags;
|
|
} else {
|
|
# stick it at the end, for now
|
|
my $it = $self->{'items'}->{$key} = [];
|
|
$it->[PREVKEY] = undef;
|
|
$it->[NEXTKEY] = undef;
|
|
$it->[VALUE] = $value;
|
|
$it->[BYTES] = $bytes;
|
|
$it->[INSTIME] = time();
|
|
$it->[FLAGS] = $flags;
|
|
if ($self->{'size'}) {
|
|
$self->{'items'}->{$self->{'tail'}}->[NEXTKEY] = $key;
|
|
$self->{'items'}->{$key}->[PREVKEY] = $self->{'tail'};
|
|
} else {
|
|
$self->{'head'} = $key;
|
|
}
|
|
$self->{'tail'} = $key;
|
|
$self->{'size'}++;
|
|
$self->{'bytes'} += $bytes;
|
|
}
|
|
|
|
# this will promote it to the top:
|
|
$self->get($key);
|
|
}
|
|
|
|
1;
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
LJ::Cache - LRU Cache
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use LJ::Cache;
|
|
my $cache = new LJ::Cache { 'maxsize' => 20 };
|
|
my $value = $cache->get($key);
|
|
unless (defined $value) {
|
|
$val = "load some value";
|
|
$cache->set($key, $value);
|
|
}
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This class implements an LRU dictionary cache. The two operations on it
|
|
are get() and set(), both of which promote the key being referenced to
|
|
the "top" of the cache, so it will stay alive longest.
|
|
|
|
When the cache is full and and a new item needs to be added, the oldest
|
|
one is thrown away.
|
|
|
|
You should be able to regenerate the data at any time, if get()
|
|
returns undef.
|
|
|
|
This class is useful for caching information from a slower data source
|
|
while also keeping a bound on memory usage.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Brad Fitzpatrick, bradfitz@bradfitz.com
|
|
|
|
=cut
|