File Coverage

blib/lib/Cache/BaseCache.pm

Criterion	Covered	Total	%
statement	189	198	95.4
branch	35	44	79.5
condition	5	15	33.3
subroutine	53	54	98.1
pod	12	25	48.0
total	294	336	87.5

######################################################################
# $Id: BaseCache.pm,v 1.25 2003/04/15 14:46:14 dclinton Exp $
# Copyright (C) 2001-2003 DeWitt Clinton  All Rights Reserved
#
# Software distributed under the License is distributed on an "AS
# IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or
# implied. See the License for the specific language governing
# rights and limitations under the License.
######################################################################


package Cache::BaseCache;


use strict;
use vars qw( @ISA );
use Cache::Cache qw( $EXPIRES_NEVER $EXPIRES_NOW );
use Cache::CacheUtils qw( Assert_Defined Clone_Data );
use Cache::Object;
use Error;


@ISA = qw( Cache::Cache );


my $DEFAULT_EXPIRES_IN = $EXPIRES_NEVER;
my $DEFAULT_NAMESPACE = "Default";
my $DEFAULT_AUTO_PURGE_ON_SET = 0;
my $DEFAULT_AUTO_PURGE_ON_GET = 0;


# namespace that stores the keys used for the auto purge functionality

my $AUTO_PURGE_NAMESPACE = "__AUTO_PURGE__";


# map of expiration formats to their respective time in seconds

my %_Expiration_Units = ( map(($_,             1), qw(s second seconds sec)),
                          map(($_,            60), qw(m minute minutes min)),
                          map(($_,         60*60), qw(h hour hours)),
                          map(($_,      60*60*24), qw(d day days)),
                          map(($_,    60*60*24*7), qw(w week weeks)),
                          map(($_,   60*60*24*30), qw(M month months)),
                          map(($_,  60*60*24*365), qw(y year years)) );



# Takes the time the object was created, the default_expires_in and
# optionally the explicitly set expires_in and returns the time the
# object will expire. Calls _canonicalize_expiration to convert
# strings like "5m" into second values.

sub Build_Expires_At
{
  my ( $p_created_at, $p_default_expires_in, $p_explicit_expires_in ) = @_;

  my $expires_in = defined $p_explicit_expires_in ?
    $p_explicit_expires_in : $p_default_expires_in;

  return Sum_Expiration_Time( $p_created_at, $expires_in );
}


# Return a Cache::Object object

sub Build_Object
{
  my ( $p_key, $p_data, $p_default_expires_in, $p_expires_in ) = @_;

  Assert_Defined( $p_key );
  Assert_Defined( $p_default_expires_in );

  my $now = time( );

  my $object = new Cache::Object( );

  $object->set_key( $p_key );
  $object->set_data( $p_data );
  $object->set_created_at( $now );
  $object->set_accessed_at( $now );
  $object->set_expires_at( Build_Expires_At( $now,
                                             $p_default_expires_in,
                                             $p_expires_in ) );
  return $object;
}


# Compare the expires_at to the current time to determine whether or
# not an object has expired (the time parameter is optional)

sub Object_Has_Expired
{
  my ( $p_object, $p_time ) = @_;

  if ( not defined $p_object )
  {
    return 1;
  }

  $p_time = $p_time || time( );

  if ( $p_object->get_expires_at( ) eq $EXPIRES_NOW )
  {
    return 1;
  }
  elsif ( $p_object->get_expires_at( ) eq $EXPIRES_NEVER )
  {
    return 0;
  }
  elsif ( $p_time >= $p_object->get_expires_at( ) )
  {
    return 1;
  }
  else
  {
    return 0;
  }
}


# Returns the sum of the  base created_at time (in seconds since the epoch)
# and the canonical form of the expires_at string


sub Sum_Expiration_Time
{
  my ( $p_created_at, $p_expires_in ) = @_;

  Assert_Defined( $p_created_at );
  Assert_Defined( $p_expires_in );

  if ( $p_expires_in eq $EXPIRES_NEVER )
  {
    return $EXPIRES_NEVER;
  }
  else
  {
    return $p_created_at + Canonicalize_Expiration_Time( $p_expires_in );
  }
}


# turn a string in the form "[number] [unit]" into an explicit number
# of seconds from the present.  E.g, "10 minutes" returns "600"

sub Canonicalize_Expiration_Time
{
  my ( $p_expires_in ) = @_;

  Assert_Defined( $p_expires_in );

  my $secs;

  if ( uc( $p_expires_in ) eq uc( $EXPIRES_NOW ) )
  {
    $secs = 0;
  }
  elsif ( uc( $p_expires_in ) eq uc( $EXPIRES_NEVER ) )
  {
    throw Error::Simple( "Internal error.  expires_in eq $EXPIRES_NEVER" );
  }
  elsif ( $p_expires_in =~ /^\s*([+-]?(?:\d+|\d*\.\d*))\s*$/ )
  {
    $secs = $p_expires_in;
  }
  elsif ( $p_expires_in =~ /^\s*([+-]?(?:\d+|\d*\.\d*))\s*(\w*)\s*$/
          and exists( $_Expiration_Units{ $2 } ))
  {
    $secs = ( $_Expiration_Units{ $2 } ) * $1;
  }
  else
  {
    throw Error::Simple( "invalid expiration time '$p_expires_in'" );
  }

  return $secs;
}



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

  $self->_get_backend( )->delete_namespace( $self->get_namespace( ) );
}


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

  Assert_Defined( $p_key );

  $self->_conditionally_auto_purge_on_get( ) unless
    $self->get_namespace( ) eq $AUTO_PURGE_NAMESPACE;

  my $object = $self->get_object( $p_key ) or
    return undef;

  if ( Object_Has_Expired( $object ) )
  {
    $self->remove( $p_key );
    return undef;
  }

  return $object->get_data( );
}


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

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


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

  warn( "get_identifiers has been marked deprepricated.  use get_keys" );

  return $self->get_keys( );
}


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

  Assert_Defined( $p_key );

  my $object =
    $self->_get_backend( )->restore( $self->get_namespace( ), $p_key ) or
      return undef;

  $object->set_size( $self->_get_backend( )->
                     get_size( $self->get_namespace( ), $p_key ) );

  $object->set_key( $p_key );

  return $object;
}


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

  foreach my $key ( $self->get_keys( ) )
  {
    $self->get( $key );
  }
}


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

  Assert_Defined( $p_key );

  $self->_get_backend( )->delete_key( $self->get_namespace( ), $p_key );
}


sub set
{
  my ( $self, $p_key, $p_data, $p_expires_in ) = @_;

  Assert_Defined( $p_key );

  $self->_conditionally_auto_purge_on_set( );

  $self->set_object( $p_key,
                     Build_Object( $p_key,
                                   $p_data,
                                   $self->get_default_expires_in( ),
                                   $p_expires_in ) );
}


sub set_object
{
  my ( $self, $p_key, $p_object ) = @_;

  my $object = Clone_Data( $p_object );

  $object->set_size( undef );
  $object->set_key( undef );

  $self->_get_backend( )->store( $self->get_namespace( ), $p_key, $object );
}


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

  my $size = 0;

  foreach my $key ( $self->get_keys( ) )
  {
    $size += $self->_get_backend( )->get_size( $self->get_namespace( ), $key );
  }

  return $size;
}


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

  return grep {!/$AUTO_PURGE_NAMESPACE/} $self->_get_backend( )->get_namespaces( );
}


sub _new
{
  my ( $proto, $p_options_hash_ref ) = @_;
  my $class = ref( $proto ) || $proto;
  my $self  = {};
  bless( $self, $class );
  $self->_initialize_base_cache( $p_options_hash_ref );
  return $self;
}


sub _complete_initialization
{
  my ( $self ) = @_;
  $self->_initialize_auto_purge_interval( );
}


sub _initialize_base_cache
{
  my ( $self, $p_options_hash_ref ) = @_;

  $self->_initialize_options_hash_ref( $p_options_hash_ref );
  $self->_initialize_namespace( );
  $self->_initialize_default_expires_in( );
  $self->_initialize_auto_purge_on_set( );
  $self->_initialize_auto_purge_on_get( );
}


sub _initialize_options_hash_ref
{
  my ( $self, $p_options_hash_ref ) = @_;

  $self->_set_options_hash_ref( defined $p_options_hash_ref ?
                                $p_options_hash_ref :
                                { } );
}


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

  my $namespace = $self->_read_option( 'namespace', $DEFAULT_NAMESPACE );

  $self->set_namespace( $namespace );
}


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

  my $default_expires_in =
    $self->_read_option( 'default_expires_in', $DEFAULT_EXPIRES_IN );

  $self->_set_default_expires_in( $default_expires_in );
}


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

  my $auto_purge_interval = $self->_read_option( 'auto_purge_interval' );

  if ( defined $auto_purge_interval )
  {
    $self->set_auto_purge_interval( $auto_purge_interval );
    $self->_auto_purge( );
  }
}


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

  my $auto_purge_on_set =
    $self->_read_option( 'auto_purge_on_set', $DEFAULT_AUTO_PURGE_ON_SET );

  $self->set_auto_purge_on_set( $auto_purge_on_set );
}


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

  my $auto_purge_on_get =
    $self->_read_option( 'auto_purge_on_get', $DEFAULT_AUTO_PURGE_ON_GET );

  $self->set_auto_purge_on_get( $auto_purge_on_get );
}



# _read_option looks for an option named 'option_name' in the
# option_hash associated with this instance.  If it is not found, then
# 'default_value' will be returned instead

sub _read_option
{
  my ( $self, $p_option_name, $p_default_value ) = @_;

  my $options_hash_ref = $self->_get_options_hash_ref( );

  if ( defined $options_hash_ref->{ $p_option_name } )
  {
    return $options_hash_ref->{ $p_option_name };
  }
  else
  {
    return $p_default_value;
  }
}



# this method checks to see if the auto_purge property is set for a
# particular cache.  If it is, then it switches the cache to the
# $AUTO_PURGE_NAMESPACE and stores that value under the name of the
# current cache namespace

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

  return if not $self->_should_auto_purge( );

  my $real_namespace = $self->get_namespace( );

  $self->set_namespace( $AUTO_PURGE_NAMESPACE );

  if ( not defined $self->get( $real_namespace ) )
  {
    $self->_insert_auto_purge_object( $real_namespace );
  }

  $self->set_namespace( $real_namespace );
}


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

  return ( defined $self->get_auto_purge_interval( ) &&
           $self->get_auto_purge_interval( ) ne $EXPIRES_NEVER );
}

sub _insert_auto_purge_object
{
  my ( $self, $p_real_namespace ) = @_;

  my $object = Build_Object( $p_real_namespace,
                             1,
                             $self->get_auto_purge_interval( ),
                             undef );

  $self->set_object( $p_real_namespace, $object );
}



# this method checks to see if the auto_purge property is set, and if
# it is, switches to the $AUTO_PURGE_NAMESPACE and sees if a value
# exists at the location specified by a key named for the current
# namespace.  If that key doesn't exist, then the purge method is
# called on the cache

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

  if ( $self->_needs_auto_purge( ) )
  {
    $self->purge( );
    $self->_reset_auto_purge_interval( );
  }
}


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

  my $real_namespace = $self->get_namespace( );
  $self->set_namespace( $AUTO_PURGE_NAMESPACE );
  my $auto_purge_object = $self->get_object( $real_namespace );
  $self->set_namespace( $real_namespace );
  return $auto_purge_object;
}


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

  return ( $self->_should_auto_purge( ) &&
           Object_Has_Expired( $self->_get_auto_purge_object( ) ) );
}


# call auto_purge if the auto_purge_on_set option is true

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

  if ( $self->get_auto_purge_on_set( ) )
  {
    $self->_auto_purge( );
  }
}


# call auto_purge if the auto_purge_on_get option is true

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

  if ( $self->get_auto_purge_on_get( ) )
  {
    $self->_auto_purge( );
  }
}


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

  return $self->{_Options_Hash_Ref};
}


sub _set_options_hash_ref
{
  my ( $self, $options_hash_ref ) = @_;

  $self->{_Options_Hash_Ref} = $options_hash_ref;
}


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

  return $self->{_Namespace};
}


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

  $self->{_Namespace} = $namespace;
}


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

  return $self->{_Default_Expires_In};
}


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

  $self->{_Default_Expires_In} = $default_expires_in;
}


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

  return $self->{_Auto_Purge_Interval};
}


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

  $self->{_Auto_Purge_Interval} = $auto_purge_interval;

  $self->_reset_auto_purge_interval( );
}


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

  return $self->{_Auto_Purge_On_Set};
}


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_get
{
  my ( $self ) = @_;

  return $self->{_Auto_Purge_On_Get};
}


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

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


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

  return $self->{ _Backend };
}


sub _set_backend
{
  my ( $self, $p_backend ) = @_;

  $self->{ _Backend } = $p_backend;
}



1;


__END__