libcache-ref-perl 0.04-1 / usr / share / perl5 / Cache / Ref / CART.pm

package Cache::Ref::CART;
BEGIN {
  $Cache::Ref::CART::AUTHORITY = 'cpan:NUFFIN';
}
BEGIN {
  $Cache::Ref::CART::VERSION = '0.04';
}
# ABSTRACT: CAR with temporal filtering

use Moose;

use List::Util qw(max min);
use Cache::Ref::CAR::Base ();

use namespace::autoclean;

extends qw(Cache::Ref);

with qw(Cache::Ref::CAR::Base);

has _long_term_utility_size => ( # q
    is => "ro",
    writer => "_set_long_term_utility_size",
    default => 0,
);

has _mru_history_target_size => ( # q
    is => "ro",
    writer => "_set_mru_history_target_size",
    default => 0,
);

sub _inc_long_term_utility_size {
    my $self = shift;
    $self->_set_long_term_utility_size( $self->_long_term_utility_size + 1 );
}

sub _dec_long_term_utility_size {
    my $self = shift;
    $self->_set_long_term_utility_size( $self->_long_term_utility_size - 1 );
}

sub _reset_long_term_utility_size {
    my $self = shift;
    $self->_set_long_term_utility_size(0);
}

sub _reset_mru_history_target_size {
    my $self = shift;
    $self->_set_mru_history_target_size(0);
}

sub _mru_history_too_big {
    my $self = shift;

    # only if there's something to purge
    return unless $self->_mru_history_size;

    # only if we need to purge
    return unless $self->_mru_history_size + $self->_mfu_history_size == $self->size + 1;

    # purge from here if there's nothing to purge from mfu
    return 1 if $self->_mfu_history_size == 0;

    # or if the target size is too big
    return 1 if $self->_mru_history_size > $self->_mru_history_target_size;

    return;
}

sub _mfu_history_too_big {
    my $self = shift;

    return unless $self->_mfu_history_size;

    # only purge if we actually need to
    return 1 if $self->_mru_history_size + $self->_mfu_history_size == $self->size + 1;

    return;
}

sub _increase_mru_target_size {
    my $self = shift;

    my $adjustment = int( ( $self->_mru_size + $self->_mfu_size - $self->_long_term_utility_size ) / $self->_mru_history_size );
    $self->_set_mru_target_size( min( $self->size, $self->_mru_target_size + max(1, $adjustment) ) );
}

sub _decrease_mru_target_size {
    my $self = shift;

    my $adjustment = int( $self->_long_term_utility_size / $self->_mfu_history_size );
    $self->_set_mru_target_size( max( 0, $self->_mru_target_size - max(1, $adjustment) ) );
}

sub _increase_mru_history_target_size {
    my $self = shift;

    $self->_set_mru_history_target_size( min($self->_mru_history_target_size + 1, 2 * $self->size - $self->_mru_size ) );
}

sub _decrease_mru_history_target_size {
    my $self = shift;

    $self->_set_mru_history_target_size( max($self->_mru_history_target_size - 1, $self->size - $self->_mru_size) );
}

sub _restore_from_mfu_history {
    my ( $self, $e ) = @_;

    if ( $self->_mfu_history_size + $self->_long_term_utility_size >= $self->size ) {
        $self->_increase_mru_history_target_size();
    }

    die unless $e->[0] & Cache::Ref::CAR::Base::LONG_TERM_BIT();
    $self->_inc_long_term_utility_size();

    $self->_mru_push($e);
}

sub _restore_from_mru_history {
    my ( $self, $e ) = @_;

    $e->[0] |= Cache::Ref::CAR::Base::LONG_TERM_BIT();
    $self->_inc_long_term_utility_size();

    $self->_mru_push($e);
}

sub expire {
    my ( $self, $how_many ) = @_;

    $how_many ||= 1;

    if ( my $mfu = $self->_mfu ) {
        my $cur = $self->_next($mfu);

        # mru pool is too big
        while ( $cur and $cur->[0] & Cache::Ref::CAR::Base::REF_BIT ) {
            $self->_circular_splice($cur);

            $cur->[0] &= ~Cache::Ref::CAR::Base::REF_BIT; # turn off reference bit

            # move to t1 (mru)
            $self->_mru_push($cur);
            $cur = $self->_next($cur);

            if ( $self->_mfu_history_size + $self->_long_term_utility_size >= $self->size ) {
                $self->_increase_mru_history_target_size;
            }
        }
    }

    if ( my $mru = $self->_mru ) {
        my $cur = $self->_next($mru);

        while ( $cur ) {
            if ( $cur->[0] & Cache::Ref::CAR::Base::REF_BIT ) {
                $cur->[0] &= ~Cache::Ref::CAR::Base::REF_BIT;

                if ( $self->_mru_size >= max($self->_mru_history_size, $self->_mru_target_size + 1)
                        and
                    not( $cur->[0] & Cache::Ref::CAR::Base::LONG_TERM_BIT )
                ) {
                    # FIXME spec says 'x', is this the same as 'head'?
                    $cur->[0] |= Cache::Ref::CAR::Base::LONG_TERM_BIT;
                    $self->_inc_long_term_utility_size;
                }

                # $hand++
                $self->_mru($cur);
                $cur = $self->_next($cur);
            } elsif ( $cur->[0] & Cache::Ref::CAR::Base::LONG_TERM_BIT ) {
                my $next = $self->_next($cur);
                $self->_circular_splice($cur);
                $self->_mfu_push($cur);
                $cur = $self->_next($self->_mru);;

                $self->_decrease_mru_history_target_size();
            } else {
                # found a candidate page for removal
                last;
            }
        }
    }

    for ( 1 .. $how_many ) {
        if ( $self->_mru_size >= max(1, $self->_mru_target_size) ) {
            my $head = $self->_next($self->_mru);
            $self->_circular_splice($head);

            if ( $self->_mru_history_head ) {
                $self->_set_next($head, $self->_mru_history_head);
                $self->_set_prev($self->_mru_history_head, $head);
            }

            $self->_mru_history_head($head);
            $self->_mru_history_tail($head) unless $self->_mru_history_tail;
            $self->_inc_mru_history_size;

            delete $head->[2]; # delete the value
        } else {
            my $tail = $self->_mfu || last;
            my $head = $self->_next($tail) || last;
            $self->_circular_splice($head);

            $self->_dec_long_term_utility_size; # entries in mfu *always* have long term set

            if ( $self->_mfu_history_head ) {
                $self->_set_next($head, $self->_mfu_history_head);
                $self->_set_prev($self->_mfu_history_head, $head);
            }

            $self->_mfu_history_head($head);
            $self->_mfu_history_tail($head) unless $self->_mfu_history_tail;
            $self->_inc_mfu_history_size;

            delete $head->[2]; # delete the value
            $head->[0] |= Cache::Ref::CAR::Base::MFU_BIT;
        }
    }

    return;
}

sub _clear_additional {
    my $self = shift;

    $self->_reset_long_term_utility_size;
    $self->_reset_mru_history_target_size;
}

__PACKAGE__->meta->make_immutable;

__PACKAGE__;


# ex: set sw=4 et:


__END__
=pod

=encoding utf-8

=head1 NAME

Cache::Ref::CART - CAR with temporal filtering

=head1 SYNOPSIS

    my $c = Cache::Ref::CART->new(
        size => $n,
    );

=head1 DESCRIPTION

This algorithm is an extension to L<Cache::Ref::CAR> that has temporal
filtering on the upgrading from MRU to MFU pool.

This means that two subsequent accesses to the same key do not automatically
make it viable for long term caching, to get upgraded to MFU status a key must
be expired but known in the history.

This is probably the most general purpose caching algorithm.

=head1 ATTRIBUTES

=over 4

=item size

The size of the live entries.

Note that the cache also remembers this many expired keys, and keeps some
metadata about those keys, so for memory usage the overhead is probably around
double what L<Cache::Ref::LRU> requires.

=back

=head1 AUTHOR

Yuval Kogman

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by Yuval Kogman.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut