ljr/livejournal/cgi-bin/LJ/Cache.pm

#!/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