File Coverage

blib/lib/Tie/Cacher.pm

Criterion	Covered	Total	%
statement	243	255	95.2
branch	90	98	91.8
condition	5	8	62.5
subroutine	28	28	100.0
pod	21	21	100.0
total	387	410	94.3

package Tie::Cacher;
use 5.006;
use strict;
use warnings;

use AutoLoader qw(AUTOLOAD);

our $VERSION = "0.09";
use Carp;

use base qw(Tie::Hash);

# Object indices
sub TC_HEAD	() { 0 };
sub TC_NODES	() { 1 };
sub TC_HIT	() { 2 };
sub TC_MISSED	() { 3 };
# We could get the effect of count by using keys, but it would reset
# first_key/last_key
sub TC_COUNT	() { 4 };
sub TC_MAX_COUNT() { 5 };
sub TC_VALIDATE	() { 6 };
sub TC_LOAD	() { 7 };
sub TC_SAVE	() { 8 };
sub TC_USER_DATA() { 9 };

# Node indices
sub TC_DATA	() { 0 };	# Must be zero (documented accessmethod)
sub TC_KEY	() { 1 };
sub TC_PREVIOUS	() { 2 };
sub TC_NEXT	() { 3 };
sub TC_NODE_SIZE() { 4 };

# This should effectively give us +inf
sub INF	() { 1e5000000000 };

my %attributes = map {($_, 1)} qw(validate load save max_count user_data);
sub new {
    defined(my $class = shift) ||
        croak "Too few arguments. Usage: Tie::Cacher->new(key-val-pairs)";
    my $cacher = bless [], $class;
    my $head = [];
    $cacher->[TC_HEAD] = $head;
    $head->[TC_NEXT] = $head;
    $head->[TC_PREVIOUS] = $head;
    $cacher->[TC_HIT] = $cacher->[TC_MISSED] = $cacher->[TC_COUNT] = 0;
    $cacher->[TC_MAX_COUNT] = INF;
    $cacher->[TC_NODES] = {};

    if (@_ % 2) {
        if (@_ == 1) {
            if (ref($_[0])) {
                @_ = %{$_[0]};
            } else {
                @_ = (max_count => $_[0]);
            }
        }
        croak "Odd number of arguments. Usage: $class->new(key-val-pairs)" if
            @_ %2;
    }
    while (@_) {
        my $key = shift;
        $attributes{$key} || croak "Unknown key $key in $class->new, $class";
        $cacher->$key(shift);
    }
    $cacher->[TC_MAX_COUNT] ||= INF;	# Infinity really
    return $cacher;
}

sub keys : method {
    return CORE::keys %{shift->[TC_NODES]};
}

sub exists : method {
    my $cacher = shift;
    return exists $cacher->[TC_NODES]{shift()};
}

sub count {
    return shift->[TC_COUNT]
}

sub DESTROY {
    my $cacher = shift;

    # Make nodes single connected
    $cacher->[TC_NODES] = {};
    my $head = $cacher->[TC_HEAD];
    my $ptr = $head->[TC_PREVIOUS];
    undef $ptr->[TC_NEXT];
    $ptr = $head->[TC_NEXT];
    $head->[TC_NEXT] = $head->[TC_PREVIOUS] = $head;
    $cacher->[TC_COUNT] = 0;

    while ($ptr) {
        # We must remove both the forward and backward links, otherwise
        # perl will do a recursive free and might run out of stackspace
        undef $ptr->[TC_PREVIOUS];
        $ptr = delete $ptr->[TC_NEXT];
    }
}

*clear		= \&DESTROY;

# Tie interface aliasas
*STORE		= \&store;
*FETCH		= \&fetch;
*TIEHASH	= \&new;
*FIRSTKEY	= \&first_key;
*NEXTKEY	= \&next_key;
*EXISTS		= \&exists;
*DELETE		= \&delete;
*CLEAR		= \&clear;

1;

__END__