File Coverage

blib/lib/Perlbal/Cache.pm

Criterion	Covered	Total	%
statement	53	143	37.0
branch	7	62	11.2
condition	2	36	5.5
subroutine	11	18	61.1
pod	0	10	0.0
total	73	269	27.1

# (This is a copy of Cache::SimpleLRU.)
# License to use and redistribute this under the same terms as Perl itself.

package Perlbal::Cache;

use strict;
use fields qw(items size tail head maxsize);

use vars qw($VERSION);
use constant PREVREF => 0;  # ptr left, to newer item
use constant VALUE   => 1;
use constant NEXTREF => 2;  # ptr right, to older item
use constant KEY     => 3;  # copy of key for unlinking from namespace on fallout

$VERSION = '1.0';

sub new {
    my $class = shift;
    my $self = fields::new($class);
    my $args = @_ == 1 ? $_[0] : { @_ };

    $self->{head}    = undef,
    $self->{tail}    = undef,
    $self->{items}   = {}; # key -> arrayref, indexed by constants above
    $self->{size}    = 0;
    $self->{maxsize} = $args->{maxsize}+0;
    return $self;
}

# need to DESTROY to cleanup doubly-linked list (circular refs)
sub DESTROY {
    my $self = shift;
    $self->set_maxsize(0);
    $self->validate_list;
}

# calls $code->($val) for each value in cache.  $code must return true
# to continue walking.  foreach returns true if you hit the end.
sub foreach {
    my Perlbal::Cache $self = shift;
    my $code = shift;
    my $iter = $self->{head};
    while ($iter) {
        my $val = $iter->[VALUE];
        $iter = $iter->[NEXTREF];
        last unless $code->($val);
    }
    return $iter ? 0 : 1;
}

sub size {
    my Perlbal::Cache $self = shift;
    return $self->{size};
}

sub maxsize {
    my Perlbal::Cache $self = shift;
    return $self->{maxsize};
}

sub set_maxsize {
    my Perlbal::Cache $self = shift;
    my $maxsize = shift;
    $self->{maxsize} = $maxsize;
    $self->drop_tail while
        $self->{size} > $self->{maxsize};
}

# For debugging only
sub validate_list {
    my Perlbal::Cache $self = shift;

    die "no tail pointer\n" if $self->{size} && ! $self->{tail};
    die "no head pointer\n" if $self->{size} && ! $self->{head};
    die "unwanted tail pointer\n" if ! $self->{size} && $self->{tail};
    die "unwanted head pointer\n" if ! $self->{size} && $self->{head};

    my $iter = $self->{head};
    my $last = undef;
    my $count = 1;
    while ($count <= $self->{size}) {
        if (! defined $iter) {
            die "undefined iterator on element \#$count (trying to get to size $self->{size})\n";
        }
        my $key = $iter->[KEY];
        my $it_via_hash = $self->{items}->{$key} or
            die "item '$key' found in list, but not in hash\n";

        unless ($it_via_hash == $iter) {
            die "Hash value of '$key' maps to different node than we found.\n";
        }

        if ($count == 1 && $iter->[PREVREF]) {
            die "Head element shouldn't have previous pointer!\n";
        }
        if ($count == $self->{size} && $iter->[NEXTREF]) {
            die "Last element shouldn't have next pointer!\n";
        }
        if ($iter->[NEXTREF] && $iter->[NEXTREF]->[PREVREF] != $iter) {
            die "next's previous should be us.\n";
        }
        if ($last && $iter->[PREVREF] != $last) {
            die "defined \$last but its previous isn't us.\n";
        }
        if ($last && $last->[NEXTREF] != $iter) {
            die "defined \$last but our next isn't it\n";
        }
        if (!$last && $iter->[PREVREF]) {
            die "uh, we have a nextref but shouldn't\n";
        }

        $last = $iter;
        $iter = $iter->[NEXTREF];
        $count++;
    }
    return 1;
}

sub drop_tail {
    my Perlbal::Cache $self = shift;
    die "no tail (size)" unless $self->{size};

    ## who's going to die?
    my $to_die = $self->{tail} or die "no tail (key)";

    ## set the tail to the item before the one dying.
    $self->{tail} = $self->{tail}->[PREVREF];

    ## adjust the forward pointer on the tail to be undef
    if (defined $self->{tail}) {
        $self->{tail}->[NEXTREF] = undef;
    }

    ## kill the item
    delete $self->{items}->{$to_die->[KEY]};

    ## shrink the overall size
    $self->{size}--;

    if (!$self->{size}) {
        $self->{head} = undef;
    }
}

sub get {
    my Perlbal::Cache $self = shift;
    my ($key) = @_;

    my $item = $self->{items}{$key} or
        return undef;

    # promote this to the head
    unless ($self->{head} == $item) {
        if ($self->{tail} == $item) {
            $self->{tail} = $item->[PREVREF];
        }

        # remove this element from the linked list.
        my $next = $item->[NEXTREF];
        my $prev = $item->[PREVREF];
        if ($next) { $next->[PREVREF] = $prev; }
        if ($prev) { $prev->[NEXTREF] = $next; }

        # make current head point backwards to this item
        $self->{head}->[PREVREF] = $item;

        # make this item point forwards to current head, and backwards nowhere
        $item->[NEXTREF] = $self->{head};
        $item->[PREVREF] = undef;

        # make this the new head
        $self->{head} = $item;
    }

    return $item->[VALUE];
}

sub remove {
    my Perlbal::Cache $self = shift;
    my ($key) = @_;

    my $item = $self->{items}{$key} or
        return 0;
    delete $self->{items}{$key};
    $self->{size}--;

    if (!$self->{size}) {
        $self->{head} = undef;
        $self->{tail} = undef;
        return 1;
    }

    if ($self->{head} == $item) {
        $self->{head} = $item->[NEXTREF];
        $self->{head}->[PREVREF] = undef;
        return 1;
    }
    if ($self->{tail} == $item) {
        $self->{tail} = $item->[PREVREF];
        $self->{tail}->[NEXTREF] = undef;
        return 1;
    }

    # remove from middle
    $item->[PREVREF]->[NEXTREF] = $item->[NEXTREF];
    $item->[NEXTREF]->[PREVREF] = $item->[PREVREF];
    return 1;

}

sub set {
    my Perlbal::Cache $self = shift;
    my ($key, $value) = @_;

    $self->drop_tail while
        $self->{maxsize} &&
        $self->{size} >= $self->{maxsize} &&
        ! exists $self->{items}->{$key};

    if (exists $self->{items}->{$key}) {
        # update the value
        my $it = $self->{items}->{$key};
        $it->[VALUE] = $value;
    } else {
        # stick it at the end, for now
        my $it = $self->{items}->{$key} = [];
        $it->[PREVREF] = undef;
        $it->[NEXTREF] = undef;
        $it->[KEY]     = $key;
        $it->[VALUE] = $value;
        if ($self->{size}) {
            $self->{tail}->[NEXTREF] = $it;
            $it->[PREVREF] = $self->{tail};
        } else {
            $self->{head} = $it;
        }
        $self->{tail} = $it;
        $self->{size}++;
    }

    # this will promote it to the top:
    $self->get($key);
}

1;