File Coverage

blib/lib/Cache/CacheFactory.pm

Criterion	Covered	Total	%
statement	213	346	61.5
branch	73	144	50.6
condition	8	32	25.0
subroutine	46	72	63.8
pod	54	54	100.0
total	394	648	60.8

###############################################################################
# Purpose : Generic Cache Factory with various policy factories.
# Author  : Sam Graham
# Created : 23 Jun 2008
# CVS     : $Id: CacheFactory.pm,v 1.25 2010-02-16 12:25:40 illusori Exp $
###############################################################################

package Cache::CacheFactory;

use warnings;
use strict;

use Carp;

use Cache::Cache;

use Cache::CacheFactory::Storage;
use Cache::CacheFactory::Expiry;
use Cache::CacheFactory::Object;

use base qw/Cache::Cache/;

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

$Cache::CacheFactory::NO_MAX_SIZE = -1;

@Cache::CacheFactory::EXPORT    = qw();
@Cache::CacheFactory::EXPORT_OK = qw(
    best_available_storage_policy
    best_available_pruning_policy
    best_available_validity_policy
    $NO_MAX_SIZE
    );
%Cache::CacheFactory::EXPORT_TAGS = (
    best_available => [ qw(
        best_available_storage_policy
        best_available_pruning_policy
        best_available_validity_policy
        ) ],
    );


sub new
{
    my $class = shift;
    my ( $self, %options );

    %options = ref( $_[ 0 ] ) ? %{$_[ 0 ]} : @_;

    $self = { policies => {}, compat => {}, };
    bless $self, ( ref( $class ) || $class );

    #
    #  Compat options with Cache::Cache subclasses.
    $self->{ namespace } = $options{ namespace } || 'Default';

    #
    #  Compat with Cache::Cache.
    $self->{ compat }->{ default_expires_in } = $options{ default_expires_in }
        if exists $options{ default_expires_in };

    #
    #  Cache-wide settings.
    $self->set_positional_set( $options{ positional_set } )
        if exists $options{ positional_set };

    #  Control first-run eligibility for auto-purging.
    $self->set_last_auto_purge( $options{ last_auto_purge } )
        if defined( $options{ last_auto_purge } );

    #  Auto-purge intervals.
    $self->set_auto_purge_interval( $options{ auto_purge_interval } )
        if exists $options{ auto_purge_interval };
    $self->set_auto_purge_on_set_interval(
        $options{ auto_purge_on_set_interval } )
        if exists $options{ auto_purge_on_set_interval };
    $self->set_auto_purge_on_get_interval(
        $options{ auto_purge_on_get_interval } )
        if exists $options{ auto_purge_on_get_interval };

    #  Auto-purge toggles.
    $self->set_auto_purge_on_set( $options{ auto_purge_on_set } )
        if exists $options{ auto_purge_on_set };
    $self->set_auto_purge_on_get( $options{ auto_purge_on_get } )
        if exists $options{ auto_purge_on_get };

    #  Do we quietly (or silently) fail on missing policies?
    $self->{ nonfatal_missing_policies } = 1
        if $options{ nonfatal_missing_policies };
    $self->{ nonwarning_missing_policies } = 1
        if $options{ nonwarning_missing_policies };

    #  Do we deeply clone our data when setting it?
    $self->{ no_deep_clone } = 1
        if $options{ no_deep_clone };

    #
    #  Grab our policies from the options.
    $self->set_storage_policies(  $options{ storage  } );
    $self->set_pruning_policies(  $options{ pruning  } )
        if $options{ pruning  };
    $self->set_validity_policies( $options{ validity } )
        if $options{ validity };

    if( $#{$self->{ policies }->{ storage }->{ order }} == -1 )
    {
        #  OK, we've got no storage policies, we only get this
        #  far if nonfatal_missing_policies has been set.
        #  Either way it's a fatal error for a cache, so we
        #  return an undef.
        $self->warning( "No valid storage policies supplied" )
            unless $self->{ nonwarning_missing_policies };
        return( undef );
    }

    return( $self );
}

sub new_cache_entry_object
{
#    my ( $self ) = @_;
    return( Cache::CacheFactory::Object->new() );
}

sub set
{
    my $self = shift;
    my ( $param, $object, $key, $data, $mode );

    #  Aiii, backwards-compat with Cache::Cache->set().
    if( $self->{ compat }->{ positional_set } and
        ( ( $self->{ compat }->{ positional_set } ne 'auto' ) or
          ( $_[ 0 ] ne 'key' ) ) )
    {
        my ( $next_arg, $expires_in );

        $key        = shift;
        $data       = shift;
        $expires_in = shift;
        $param = {};
        if( defined( $next_arg = shift ) )
        {
            #  Hackery to support mode from add()/replace().
            if( $next_arg eq 'mode' )
            {
                $mode = shift;
            }
            else
            {
                $param->{ expires_in } = $expires_in;
                #  TODO: warn if expires set and not time policy?
            }
        }
        $mode = shift if defined( $next_arg = shift ) and $next_arg eq 'mode';
    }
    else
    {
        $param = ref( $_[ 0 ] ) ? { %{$_[ 0 ]} } : { @_ };
        if( exists( $param->{ key } ) )
        {
            $key  = $param->{ key };
            delete $param->{ key };
        }
        else
        {
            warn "No key supplied to ${self}->set(), are you calling it " .
                "with compat-style positional parameters but haven't set " .
                "the positional_set option?";
            return;
        }
        if( exists( $param->{ data } ) )
        {
            $data = $param->{ data };
            delete $param->{ data };
        }
        else
        {
            warn "No data supplied to ${self}->set(), are you calling it " .
                "with compat-style positional parameters but haven't set " .
                "the positional_set option?";
            return;
        }
        if( exists( $param->{ mode } ) )
        {
            $mode = $param->{ mode };
            delete $param->{ mode };
        }
    }

    if( $mode )
    {
        if( $self->exists( $key ) )
        {
            return if $mode eq 'add';
        }
        else
        {
            return if $mode eq 'replace';
        }
    }

    $param->{ created_at }    = time() unless $param->{ created_at };
    $param->{ no_deep_clone } = 1      if $self->{ no_deep_clone };

    #  Create Cache::CacheFactory::Object instance.
    $object = $self->new_cache_entry_object();

    #  Initialize it from the param.
    $object->initialize( $key, $data, $param );

    $self->foreach_driver( 'validity', 'set_object_validity',
        $key, $object, $param );
    $self->foreach_driver( 'pruning',  'set_object_pruning',
        $key, $object, $param );
    if( $param->{ no_deep_clone } )
    {
        #  Since most Cache::Cache's do their own deep cloning
        #  we try a bit of a hack to try to bypass that.
        $self->foreach_policy( 'storage',
            sub
            {
                my ( $self, $policy, $storage ) = @_;

                #  Only try this hack on things that subclass behaviour
                #  we understand.
                if( $storage->isa( 'Cache::BaseCache' ) )
                {
                    my ( $backend );

                    if( $backend = $storage->_get_backend() )
                    {
                        $object->set_size( undef );
                        $object->set_key( undef );

                        $backend->store( $storage->get_namespace(),
                            $key, $object );
                        return;
                    }
                }

                #  Ok, we couldn't figure out how to do our dirty hack...
                $storage->set_object( $key, $object, $param );
            } );
    }
    else
    {
        $self->foreach_driver( 'storage',  'set_object',
            $key, $object, $param );
    }

    $self->auto_purge( 'set' );
}

sub get
{
    my ( $self, $key ) = @_;
    my ( $object );

    my $storage_policies  = $self->{ policies }->{ storage };
    my $validity_policies = $self->{ policies }->{ validity };
    foreach my $storage_policy ( @{$storage_policies->{ order }} )
    {
        my $storage = $storage_policies->{ drivers }->{ $storage_policy };
        next unless defined( $object = $storage->get_object( $key ) );

        foreach my $validity_policy ( @{$validity_policies->{ order }} )
        {
            next if $validity_policies->{ drivers }->{ $validity_policy }->is_valid( $self, $storage, $object );
            #  TODO: should remove from this storage. optionally?
            undef $object;
            last;
        }
        last if defined $object;
    }

    #  Check of auto_purge_on_get isn't strictly neccessary but
    #  it saves the cost of a method call in the failure case.
    $self->auto_purge( 'get' ) if $self->{ auto_purge_on_get };

    return( $object->get_data() ) if defined $object;
    return( undef );
}

sub get_object
{
    my ( $self, $key ) = @_;
    my ( $object );

    $self->foreach_policy( 'storage',
        sub
        {
            my ( $self, $policy, $storage ) = @_;

            $object = $storage->get_object( $key );
            $self->last() if defined $object;
        } );

    return( $object );
}

sub set_object
{
    my ( $self, $key, $object ) = @_;

    #  Backwards compat with Cache::Object objects.
    unless( $object->isa( 'Cache::CacheFactory::Object' ) )
    {
        my ( $param );

        $param = {};
        $param->{ no_deep_clone } = 1 if $self->{ no_deep_clone };
        $object = Cache::CacheFactory::Object->new_from_old( $object, $param );
        #  TODO: compat with expires_at
    }

    $self->foreach_driver( 'storage', 'set_object', $key, $object );
}

sub remove
{
    my ( $self, $key ) = @_;

    $self->foreach_driver( 'storage', 'remove', $key );
}

#
#  CacheFactory extensions.
sub exists
{
    my ( $self, $key ) = @_;
    my ( $exists );

    $self->foreach_policy( 'storage',
        sub
        {
            my ( $self, $policy, $storage ) = @_;

            #  If they've implemented an exists method, use it,
            #  otherwise just do it the slow way.
            if( $storage->can( 'exists' ) )
            {
                $exists = $storage->exists( $key );
            }
            else
            {
                $exists = defined( $storage->get_object( $key ) );
            }

            return $self->last() if $exists;
        } );

    return( $exists ? 1 : 0 );
}


#
#  These following provide Cache::Memcached style interface.
#    get_multi(), incr() and decr() cannot be "properly" implemented
#    to use underlying functions because our object wrapper prevents
#    the operations being single calls to the storage policy's
#    implementation (if they have one), this then directly negates
#    the purpose of these methods existing in the first place.
sub delete
{
    my ( $self, $key ) = @_;

    $self->remove( $key );
}

sub add
{
    my $self = shift;

    $self->set( @_, mode => 'add' );
}

sub replace
{
    my $self = shift;

    $self->set( @_, mode => 'replace' );
}

#
#sub get_multi
#{
#    my ( $self, @keys ) = @_;
#}

#sub incr
#{
#    my ( $self, $key, $value ) = @_;
#}

#sub decr
#{
#    my ( $self, $key, $value ) = @_;
#}

sub Clear
{
    my ( $self, @args ) = @_;

    $self->foreach_driver( 'storage', 'Clear', @args );
}

sub clear
{
    my ( $self, @args ) = @_;

    $self->foreach_driver( 'storage', 'clear', @args );
}

sub Purge
{
    my ( $self, @args ) = @_;

    $self->purge( @args );
}

sub purge
{
    my ( $self, @args ) = @_;

    $self->foreach_driver( 'pruning', 'purge', $self, @args );
}

sub auto_purge
{
    my ( $self, $set_or_get ) = @_;

    return unless $self->{ "auto_purge_on_${set_or_get}" };

    return if $self->{ last_auto_purge } >=
              time() - $self->{ "auto_purge_${set_or_get}_interval" };

    #  Set timestamp before purge in case we bomb out.
    #  Ideally we should do some manner of locking to prevent
    #  concurrent purges.
    #  Maybe that's the application's business instead.
    $self->{ last_auto_purge } = time();

    $self->purge();

    #  Update timestamp after purge so we don't spinlock if the purge
    #  takes longer than the interval.
    $self->{ last_auto_purge } = time();
}

sub Size
{
    my ( $self, @args ) = @_;
    my ( $size );

    $size = 0;
    $self->foreach_policy( 'storage',
        sub
        {
            my ( $self, $policy, $driver ) = @_;

            #  Cache::FastMemoryCache 0.01 dies on Size(), workaround.
            return if $driver->isa( 'Cache::FastMemoryCache' );
            $size += $driver->Size( @args );
        } );

    return( $size );
}

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

    $size = 0;
    $self->foreach_policy( 'storage',
        sub
        {
            my ( $self, $policy, $driver ) = @_;

            $size += $driver->size();
        } );

    return( $size );
}

sub get_namespaces
{
    my ( $self ) = @_;
    my ( %namespaces );

    %namespaces = ();
    $self->foreach_policy( 'storage',
        sub
        {
            my ( $self, $policy, $driver ) = @_;

            #  Cache::NullCache->get_namespaces() dies, workaround it.
            return $self->last() if $driver->isa( 'Cache::NullCache' );
            foreach my $namespace ( $driver->get_namespaces() )
            {
                $namespaces{ $namespace }++;
            }
        } );

    return( keys( %namespaces ) );
}

sub get_keys
{
    my ( $self ) = @_;
    my ( %keys );

    %keys = ();
    $self->foreach_policy( 'storage',
        sub
        {
            my ( $self, $policy, $driver ) = @_;

            foreach my $key ( $driver->get_keys() )
            {
                $keys{ $key }++;
            }
        } );

    return( keys( %keys ) );
}

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

    return( $self->get_keys() );
}



sub set_positional_set
{
    my ( $self, $positional_set ) = @_;

    $self->{ compat }->{ positional_set } = $positional_set;
}

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

    return( $self->{ compat }->{ positional_set } );
}

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

    $time_pruning  = $self->get_policy_driver( 'pruning', 'time' );
    $time_validity = $self->get_policy_driver( 'validity', 'time' );

    unless( $time_pruning or $time_validity )
    {
        carp "Cannot set_default_expires_in() when neither a pruning nor " .
            "a validity policy of 'time' is set.";
        return;
    }

    $time_pruning->set_default_expires_in( $default_expires_in )
        if $time_pruning;
    $time_validity->set_default_expires_in( $default_expires_in )
        if $time_validity;
}

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

    $time_pruning  = $self->get_policy_driver( 'pruning', 'time' );
    $time_validity = $self->get_policy_driver( 'validity', 'time' );

    unless( $time_pruning or $time_validity )
    {
        carp "Cannot get_default_expires_in() when neither a pruning nor " .
            "a validity policy of 'time' is set.";
        return( undef );
    }

    #  If they have both set, we go with the validity one since that's
    #  generally the one that has more immediate effect.
    #  If they're setting it via default_expires_in then both should
    #  be the same anyway...
    return( $time_validity->get_default_expires_in() ) if $time_validity;
    return( $time_pruning->get_default_expires_in() )  if $time_pruning;
}

sub limit_size
{
    my ( $self, $size ) = @_;
    my ( $size_policy );

    $size_policy = $self->get_policy_driver( 'pruning', 'size' );

    unless( $size_policy )
    {
        carp "Cannot limit_size() when no 'size' pruning policy is set.";
        return;
    }

    $size_policy->limit_size( $self, $size );
}

sub set_last_auto_purge
{
    my ( $self, $last_auto_purge ) = @_;

    $self->{ last_auto_purge } =
        ( $last_auto_purge eq 'now' ) ? time() : $last_auto_purge;
}

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

    return( $self->{ last_auto_purge } );
}

sub set_auto_purge_on_set
{
    my ( $self, $auto_purge_on_set ) = @_;

    $self->{ auto_purge_on_set } = $auto_purge_on_set;
}

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

    return( $self->{ auto_purge_on_set } );
}

sub set_auto_purge_on_get
{
    my ( $self, $auto_purge_on_get ) = @_;

    $self->{ auto_purge_on_get } = $auto_purge_on_get;
}

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

    return( $self->{ auto_purge_on_get } );
}

sub set_auto_purge_interval
{
    my ( $self, $auto_purge_interval ) = @_;

    $self->set_auto_purge_on_set_interval( $auto_purge_interval );
    $self->set_auto_purge_on_get_interval( $auto_purge_interval );
}

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

    return( $self->get_auto_purge_on_get_interval() ||
        $self->get_auto_purge_on_set_interval() );
}

sub set_auto_purge_on_set_interval
{
    my ( $self, $auto_purge_interval ) = @_;

    $self->{ auto_purge_on_set_interval } = $auto_purge_interval;
}

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

    return( $self->{ auto_purge_on_set_interval } );
}

sub set_auto_purge_on_get_interval
{
    my ( $self, $auto_purge_interval ) = @_;

    $self->{ auto_purge_on_get_interval } = $auto_purge_interval;
}

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

    return( $self->{ auto_purge_on_get_interval } );
}

sub set_namespace
{
    my ( $self, $namespace ) = @_;

    $self->{ namespace } = $namespace;
    $self->foreach_driver( 'storage', 'set_namespace', $namespace );
}

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

    return( $self->{ namespace } );
}

#  Coerce the policy arg into a hashref and ordered param list.
sub _normalize_policies
{
    my ( $self, $policies ) = @_;

    return( {
        order => [ $policies ],
        param => { $policies => {} },
        } )
        unless ref( $policies );
    return( {
        order => [ keys( %{$policies} ) ],
        param => $policies,
        } )
        if ref( $policies ) eq 'HASH';
    if( ref( $policies ) eq 'ARRAY' )
    {
        my ( $ret );

        $self->error( "Policy arg wasn't even-sized arrayref" )
            unless $#{$policies} % 2;

        $ret = { order => [], param => {} };
        for( my $i = 0; $i <= $#{$policies}; $i += 2 )
        {
            push @{$ret->{ order }}, $policies->[ $i ];
            $ret->{ param }->{ $policies->[ $i ] } = $policies->[ $i + 1 ];
        }

        return( $ret );
    }
    $self->error( "Unknown policy format: " . ref( $policies ) );
}

sub set_policy
{
    my ( $self, $policytype, $policies ) = @_;
    my ( $factoryclass );

    $self->error( "No $policytype policy set" ) unless $policies;

    $policies = $self->_normalize_policies( $policies );
    $self->{ policies }->{ $policytype } = $policies;

    $factoryclass = 'Cache::CacheFactory::' .
        ( $policytype eq 'storage' ? 'Storage' : 'Expiry' );

    #  Handle compat param.
    $policies->{ param }->{ time }->{ default_expires_in } =
        $self->{ compat }->{ default_expires_in }
        if exists $self->{ compat }->{ default_expires_in } and
           $policies->{ param }->{ time } and
           not exists $policies->{ param }->{ time }->{ default_expires_in };

    $policies->{ drivers } = {};
    foreach my $policy ( @{$policies->{ order }} )
    {
        my ( $driver, $param );

        $param = $policies->{ param }->{ $policy };
        delete $policies->{ param }->{ $policy };

        #  Ensure we set the namespace if one isn't set explicitly.
        $param->{ namespace } = $self->{ namespace }
            if $policytype eq 'storage' and not exists $param->{ namespace };

        $driver = $factoryclass->new( $policy, $param );
        if( $driver )
        {
            $policies->{ drivers }->{ $policy } = $driver;
        }
        else
        {
            my ( $driver_module, $error );

            $driver_module = $factoryclass->get_registered_class( $policy );
            $error = "Unable to load driver for $policytype policy: $policy";
            if( $driver_module )
            {
                $error .= "; is $driver_module installed?";
            }
            else
            {
                $error .= "; is '$policy' a typo, or a custom policy that " .
                    "hasn't been registered with $factoryclass?";
            }
            if( $self->{ nonfatal_missing_policies } )
            {
                $self->warning( $error )
                    unless $self->{ nonwarning_missing_policies };
            }
            else
            {
                $self->error( $error );
            }
            #  Prune it from the policy run order.
            $policies->{ order } =
                [ grep { $_ ne $policy } @{$policies->{ order }} ];
        }

    }
}

sub get_policy_driver
{
    my ( $self, $policytype, $policy ) = @_;

    return( $self->{ policies }->{ $policytype }->{ drivers }->{ $policy } );
}
sub get_policy_drivers
{
    my ( $self, $policytype ) = @_;

    return( $self->{ policies }->{ $policytype }->{ drivers } );
}

#
#
#  Next few methods run a closure against each policy or invoke a
#  method against each policy's driver.  It's a bit inefficient but
#  saves on duplicating the same ordering and looping code everywhere
#  and keeps me sane(ish).  Oh for a native ordered-hashref.
sub last
{
#    my ( $self ) = @_;
    $_[ 0 ]->{ _last } = 1;
}

sub foreach_policy
{
    my ( $self, $policytype, $closure ) = @_;

    my $policies = $self->{ policies }->{ $policytype };
    foreach my $policy ( @{$policies->{ order }} )
    {
        $closure->( $self, $policy, $policies->{ drivers }->{ $policy } );
        next unless $self->{ _last };
        delete $self->{ _last };
        return;
    }
}

sub foreach_driver
{
    my ( $self, $policytype, $method, @args ) = @_;

    my $policies = $self->{ policies }->{ $policytype };
    foreach my $policy ( @{$policies->{ order }} )
    {
        $policies->{ drivers }->{ $policy }->$method( @args );
        next unless $self->{ _last };
        delete $self->{ _last };
        return;
    }
}

sub set_storage_policies
{
    my ( $self, $policies ) = @_;

    $self->set_policy( 'storage', $policies );
}

sub set_pruning_policies
{
    my ( $self, $policies ) = @_;

    $self->set_policy( 'pruning', $policies );
}

sub set_validity_policies
{
    my ( $self, $policies ) = @_;

    $self->set_policy( 'validity', $policies );
}

sub _error_message
{
    my $self = shift;
    my ( $error );

    $error = join( '', @_ );
    return( "Cache error: $error" );
}

sub error
{
    my $self = shift;
    die( $self->_error_message( @_ ) );
}

sub warning
{
    my $self = shift;
    warn( $self->_error_message( @_ ) );
}

#
#
#  Non-OO functions.
#

sub _best_available_policy
{
    my ( $policytype, @policies ) = @_;
    my ( $factoryclass );

    $factoryclass = 'Cache::CacheFactory::' .
        ( $policytype eq 'storage' ? 'Storage' : 'Expiry' );
    while( my $policy = shift( @policies ) )
    {
        return( $policy ) if $factoryclass->get_registered_class( $policy );
    }
    return( undef );
}

sub best_available_storage_policy
{
    return( _best_available_policy( 'storage', @_ ) );
}

sub best_available_pruning_policy
{
    return( _best_available_policy( 'pruning', @_ ) );
}

sub best_available_validity_policy
{
    return( _best_available_policy( 'validity', @_ ) );
}


1;

__END__