File Coverage

blib/lib/Cache/CacheFactory/Expiry/Time.pm

Criterion	Covered	Total	%
statement	46	51	90.2
branch	15	30	50.0
condition	2	6	33.3
subroutine	10	12	83.3
pod	6	6	100.0
total	79	105	75.2

###############################################################################
# Purpose : Cache Time Expiry Policy Class.
# Author  : Sam Graham
# Created : 25 Jun 2008
# CVS     : $Id: Time.pm,v 1.8 2010-02-16 12:25:41 illusori Exp $
###############################################################################

package Cache::CacheFactory::Expiry::Time;

use warnings;
use strict;

use Cache::Cache;
use Cache::BaseCache;

use Cache::CacheFactory::Expiry::Base;

use base qw/Cache::CacheFactory::Expiry::Base/;

$Cache::CacheFactory::Expiry::Time::VERSION = '1.10';

sub read_startup_options
{
    my ( $self, $param ) = @_;

    $self->set_default_expires_in( $param->{ default_expires_in } )
        if exists( $param->{ default_expires_in } );

    $self->{ default_prune_after } = $param->{ default_prune_after }
        if exists( $param->{ default_prune_after } );
    $self->{ default_valid_until } =
        ( $param->{ default_valid_until } eq 'forever' ) ?
        $Cache::Cache::EXPIRES_NEVER : $param->{ default_valid_until }
        if exists( $param->{ default_valid_until } );
}

sub set_default_expires_in
{
    my ( $self, $default_expires_in ) = @_;

    #  Compat with Cache::Cache.
    $self->{ default_prune_after } = $default_expires_in;
    $self->{ default_valid_until } = $default_expires_in;
}

sub get_default_expires_in
{
    my ( $self ) = @_;

    return( $self->{ default_prune_after } || $self->{ default_valid_until } );
}

sub set_object_validity
{
    my ( $self, $key, $object, $param ) = @_;
    my ( $valid_until );

    #  Failover in order:
    #    supplied valid_until param
    #    supplied expires_in param
    #    default valid_until param (includes default expires_in)
    #    EXPIRES_NEVER as last resort.
    $valid_until = $self->{ default_valid_until }
        if exists( $self->{ default_valid_until } );
    $valid_until = $param->{ expires_in }
        if exists( $param->{ expires_in } );
    $valid_until =
        ( $param->{ valid_until } eq 'forever' ) ?
        $Cache::Cache::EXPIRES_NEVER : $param->{ valid_until }
        if exists( $param->{ valid_until } );

    $valid_until = Cache::BaseCache::Build_Expires_At(
        $object->get_created_at(),
        $Cache::Cache::EXPIRES_NEVER,
        $valid_until );

    $object->set_policy_metadata( 'validity', 'time',
        { valid_until => $valid_until, } );
}

sub set_object_pruning
{
    my ( $self, $key, $object, $param ) = @_;
    my ( $prune_after );

    #  Failover in order:
    #    supplied prune_after param
    #    supplied expires_in param
    #    default prune_after param (includes default expires_in)
    #    EXPIRES_NEVER as last resort.
    $prune_after = $self->{ default_prune_after }
        if exists( $self->{ default_prune_after } );
    $prune_after = $param->{ expires_in }
        if exists( $param->{ expires_in } );
    $prune_after = $param->{ prune_after }
        if exists( $param->{ prune_after } );

    $prune_after = Cache::BaseCache::Build_Expires_At(
        $object->get_created_at(),
        $Cache::Cache::EXPIRES_NEVER,
        $prune_after );

    $object->set_policy_metadata( 'pruning', 'time',
        { prune_after => $prune_after, } );
}

sub should_keep
{
    my ( $self, $cache, $storage, $policytype, $object ) = @_;
    my ( $metadata, $expires, $when );

    $metadata = $object->get_policy_metadata( $policytype, 'time' );
    $expires  = $metadata->{ valid_until } || $metadata->{ prune_after };
    $when     = time();

    return( 1 ) unless defined( $expires );
    return( 0 ) if $expires eq $Cache::Cache::EXPIRES_NOW;
    return( 1 ) if $expires eq $Cache::Cache::EXPIRES_NEVER;
    return( 0 ) if $when >= $expires;
    return( 1 );
}

1;

=pod

=head1 NAME

Cache::CacheFactory::Expiry::Time - Time-based expiry policy for Cache::CacheFactory.

=head1 DESCRIPTION

L
is a time-based expiry (pruning and validity) policy for
L.

It provides similar functionality and backwards-compatibility with
the C<$expires_in> and C<$default_expires_in> properties of
L.

=head1 INTERVAL SPECIFICATIONS

You can use any of the syntaxes provided by L to
specify an interval for expiry times, for example:

  $Cache::Cache::EXPIRES_NEVER
  $Cache::Cache::EXPIRES_NOW
  '4 seconds'
  '1 m'
  'now'
  'never'

For a full list take a look at the C section of the
L documentation.

=head1 STARTUP OPTIONS

The following startup options may be supplied to
L,
see the L documentation for
how to pass options to a policy.

=over

=item default_prune_after => $interval

For a pruning policy this sets the default interval after which an
item becomes eligible to be pruned.

=item default_valid_until => $interval

For a validity policy this sets the default time interval after
which an item should be considered invalid.

=item default_expires_in => $interval

This option provides backwards-compatibility with L,
it sets C for pruning policies and
C for validity policies.

=back

=head1 STORE OPTIONS

The following options may be set when storing a key, see the
L documentation for
details on how to do this.

=over

=item prune_after => $interval

For a pruning policy this sets the interval after which the
item becomes eligible to be pruned. If not supplied then
the value of C in the startup options
will be used.

=item valid_until => $interval

For a validity policy this sets the time interval after
which the item should be considered invalid. If not supplied then
the value of C in the startup options
will be used.

=item expires_in => $interval

This option provides backwards-compatibility with L,
it behaves as C for pruning policies and C
for validity policies.

=back

=head1 METHODS

You should generally call these via the L interface
rather than directly.

=over

=item $policy->set_default_expires_in( $default_expires_in );

=item $default_expires_in = $policy->get_default_expires_in();

Set or get the C option.

=back

=head1 SEE ALSO

L, L, L,
L

=head1 AUTHORS

Original author: Sam Graham

Last author:     $Author: illusori $

=head1 COPYRIGHT

Copyright 2008-2010 Sam Graham.

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

=cut