The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Autocache::Strategy::Eviction::LRU;

use Any::Moose;

extends 'Autocache::Strategy';

use Autocache::Strategy::Eviction::LRU::Entry;
use Carp qw( confess );
use Devel::Size qw( total_size );
use Heap::Binary;
use Heap::Elem::Ref qw( RefElem );
use Autocache::Logger qw(get_logger);

has 'size' => (
    is => 'rw',
    isa => 'Int',
    default => 0,
);

has 'max_size' => (
    is => 'ro',
    isa => 'Int',
    default => 1024,
);

has '_heap' => (
    is => 'rw',
    lazy_build => 1,
);

#
# maps keys onto heap elements
#
has '_map' => (
    is => 'rw',
    lazy_build => 1,
);

#
# base_strategy : underlying strategy that handles storage and expiry -
# defaults
#
has 'base_strategy' => (
    is => 'ro',
    isa => 'Autocache::Strategy',
    lazy_build => 1,
);

#
# get REQ
#
sub get
{
    my ($self,$req) = @_;
    get_logger()->debug( 'get: '.$req->key );

    my $rec = $self->base_strategy->get( $req );

    unless( $rec )
    {
        # check that we don't have an entry for the key that exists in our
        # base strategy
        confess "base strategy contains more records than we are aware of"
            if exists $self->_map->{$req->key};

        return undef;
    }

    my $elem = $self->_map->{$req->key};

    confess "base strategy contains record but our map is unaware of it"
        unless $elem;

    # remove from heap, modify atime and re-add
    $self->_heap->delete( $elem );
    $elem->val->touch;
    $self->_heap->add( $elem );

    return $rec;
}

#
# set REQ REC
#
sub set
{
    my ($self,$req,$rec) = @_;
    get_logger()->debug( "set: $req->key" );
    my $elem = RefElem( Autocache::Strategy::Eviction::LRU::Entry->new(
        key => $req->key,
        size => total_size( $rec ) ) );

    my $size = $self->size + $elem->val->size;

    # remove current entry from heap if we already have one for
    # this key
    if( my $tmp = delete $self->_map->{$req->key} )
    {
        get_logger()->debug( "removing existing value for key" );
        $self->_heap->delete( $tmp );
        $size -= $tmp->val->size;
    }

    while( $size > $self->max_size )
    {
        get_logger()->debug( "cache size: $size" );

        my $lru = $self->_heap->extract_top;

        get_logger()->debug( "LRU key: " . $lru->val->key );

        $size -= $lru->val->size;
        delete $self->_map->{$lru->val->key};
        $self->base_strategy->delete( $lru->val->key );
    }

    $self->size( $size );
    $self->_heap->add( $elem );
    $self->_map->{$req->key} = $elem;
    return $self->base_strategy->set( $req, $rec );
}

#
# delete KEY
#
sub delete
{
    my ($self,$key) = @_;
    get_logger()->debug( "delete: $key" );

    my $elem = delete $self->_map->{$key};

    if( $elem )
    {
        $self->heap->delete( $elem );
        $self->size( $self->size - $elem->val->size );
        my $rec = $self->base_strategy->delete( $key );
        confess "delete found element in LRU but not in base strategy"
            unless $rec;
        return $rec;
    }
    else
    {
        my $rec = $self->base_strategy->delete( $key );
        confess "delete did not find element in LRU but did find it in the base strategy"
            unless $rec;
        return $rec;
    }
}

#
# clear
#
sub clear
{
    my ($self,$key) = @_;
    get_logger()->debug( "clear" );
    $self->base_strategy->clear;
    $self->_heap = Heap::Binary->new;
    $self->_map = {};
    $self->size( 0 );
}

sub _build__heap
{
    return Heap::Binary->new;
}

sub _build__map
{
    return {};
}

around BUILDARGS => sub
{
    my $orig = shift;
    my $class = shift;

    get_logger()->debug( __PACKAGE__ . " - BUILDARGS" );

    if( ref $_[0] )
    {
        my $config = $_[0];
        my %args;
        my $node;

        if( $node = $config->get_node( 'max_size' ) )
        {
            get_logger()->debug( "max_size node found" );
            $args{max_size} = $node->value;
        }

        if( $node = $config->get_node( 'base_strategy' ) )
        {
            get_logger()->debug( "base strategy node found" );
            $args{base_strategy} = Autocache->singleton->get_strategy( $node->value );
        }

        return $class->$orig( %args );
    }
    else
    {
        return $class->$orig(@_);
    }
};

no Any::Moose;
__PACKAGE__->meta->make_immutable;

1;