File Coverage

blib/lib/IPC/Cache.pm

Criterion	Covered	Total	%
statement	154	156	98.7
branch	30	48	62.5
condition	10	24	41.6
subroutine	22	22	100.0
pod	7	7	100.0
total	223	257	86.7

#!/usr/bin/perl -w

package IPC::Cache;

use strict;
use Carp;
use IPC::ShareLite;
use Storable qw(freeze thaw dclone);
use vars qw($VERSION);
use Fcntl ':flock';

$VERSION = '0.02';

my $sEXPIRES_NOW = 0;
my $sEXPIRES_NEVER = -1;
my $sSUCCESS = 1;
my $sTRUE = 1;
my $sFALSE = 0;


# IPC::ShareLite converts a four character text string to the shared memory key

my $sDEFAULT_CACHE_KEY = "IPCC";


# if a namespace is not specified, use this as a default

my $sDEFAULT_NAMESPACE = "_default";



# create a new Cache object that can be used to persist
# data across processes

sub new
{
    my ($proto, $options) = @_;
    my $class = ref($proto) || $proto;
    my $self  = {};
    bless ($self, $class);


    # this instance will use the namespace specified or the default

    my $namespace = $options->{namespace} || $sDEFAULT_NAMESPACE;

    $self->{_namespace} = $namespace;


    # remember the expiration delta to be used for all objects if specified

    $self->{_expires_in} = $options->{expires_in} || $sEXPIRES_NEVER;

    # create a new share associated with the cache key

    my $cache_key = $options->{cache_key} || $sDEFAULT_CACHE_KEY;

    my $share = new IPC::ShareLite( -key => $cache_key, -create => 1  ) or
	croak("Couldn't create new IPC::ShareLite");

    # store the share for this instance

    $self->{_share} = $share;


    # atomically initialize the segment as frozen data

    $self->_lock();

    my $frozen_data = $self->_get_frozen_data();

    if (not $frozen_data) {
	my %data;
	$frozen_data = freeze(\%data);
	$self->_set_frozen_data($frozen_data);
    }

    $self->_unlock();


    return $self;
}


# store an object in the cache associated with the identifier

sub set
{
    my ($self, $identifier, $object, $expires_in) = @_;

    $identifier or
	croak("identifier required");

    my $namespace = $self->{_namespace} or
	croak("namespace required");


    # expiration time is based on a delta from the current time
    # if expires_in is defined, the object will expire in that number of seconds from now
    #  else if expires_in is undefined, it will expire based on the global _expires_in

    my $expires_at;

    if (defined $expires_in) {
	$expires_at = time() + $expires_in;
    } elsif ($self->{_expires_in} ne $sEXPIRES_NEVER) {
	$expires_at = time() + $self->{_expires_in};
    } else {
	$expires_at = $sEXPIRES_NEVER;
    }

    # atomically add the new object to the cache in this instance's namespace

    $self->_lock();

    my $frozen_data = $self->_get_frozen_data();

    my %data = %{ thaw($frozen_data) };

    $data{$namespace}->{$identifier} = { object => $object, expires_at => $expires_at };

    $frozen_data = freeze(\%data);

    $self->_set_frozen_data($frozen_data);

    $self->_unlock();

    return $sSUCCESS;
}



# retrieve an object from the cache associated with the identifier

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

    $identifier or
	croak("identifier required");

    my $namespace = $self->{_namespace} or
	croak("namespace required");

    # atomically (necessary for read-only?) check the cache for the specified object

    my $cloned_object = undef;

    $self->_lock();

    my $frozen_data = $self->_get_frozen_data();

    my %data = %{ thaw($frozen_data) };

    if (exists $data{$namespace}->{$identifier}) {

	my $object = $data{$namespace}->{$identifier}->{object};

	my $expires_at = $data{$namespace}->{$identifier}->{expires_at};

	# if the object has expired, remove it from the cache

	if (_s_should_expire($expires_at)) {
	    delete $data{$namespace}->{$identifier};
	} else {
	    # if the object is a reference, clone it before returning it (may be unnecessary?)
	    $cloned_object = (ref $object) ? dclone($object) : $object;
	}
    }

    $self->_unlock();

    return $cloned_object;
}


# clear all objects in this instance's namespace

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

    my $namespace = $self->{_namespace};

    # atomically iterate over all of the key in this instance's namespace and delete them

    $self->_lock();

    my $frozen_data = $self->_get_frozen_data();

    my %data = %{ thaw($frozen_data) };

    foreach my $identifier (keys %{$data{$namespace}}) {
	delete $data{$namespace}->{$identifier};
    }

    $frozen_data = freeze(\%data);

    $self->_set_frozen_data($frozen_data);

    $self->_unlock();

    return $sSUCCESS;
}



# iterate over all the objects in this instance's namespace and delete those that have expired

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

    my $namespace = $self->{_namespace};

    my $time = time();

    # atomically iterate over all of the keys in this instance's namespace and delete those that have expired

    $self->_lock();

    my $frozen_data = $self->_get_frozen_data();

    my %data = %{ thaw($frozen_data) };

    my $namespace_ref = $data{$namespace};

    _s_purge_namespace($namespace_ref, $time);

    $frozen_data = freeze(\%data);

    $self->_set_frozen_data($frozen_data);

    $self->_unlock();

    return $sSUCCESS;
}



# purge expired objects from all namespaces associated with this cache key

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

    my $time = time();

    # atomically iterate over all of the keys in all of this instance's namespaces and delete those that have expired

    $self->_lock();

    my $frozen_data = $self->_get_frozen_data();

    my %data = %{ thaw($frozen_data) };

    foreach my $namespace (keys %data) {

	my $namespace_ref = $data{$namespace};

	_s_purge_namespace($namespace_ref, $time);

    }

    $frozen_data = freeze(\%data);

    $self->_set_frozen_data($frozen_data);

    $self->_unlock();

    return $sSUCCESS;
}


# iterate over all the objects in the specified namespace and delete those that have expired

sub _s_purge_namespace
{
    my ($namespace_ref, $time) = @_;

    foreach my $identifier (keys %{$namespace_ref}) {

	my $expires_at = $namespace_ref->{$identifier}->{expires_at};

	# if the object has expired, remove it from the cache

	if (_s_should_expire($expires_at, $time)) {
	    delete $namespace_ref->{$identifier};
	}
    }

    return $sSUCCESS;
}


# determine whether an object should expire

sub _s_should_expire
{
    my ($expires_at, $time) = @_;

    # time is optional

    $time = $time || time();

    if ($expires_at == $sEXPIRES_NOW) {
	return $sTRUE;
    } elsif ($expires_at == $sEXPIRES_NEVER) {
	return $sFALSE;
    } elsif ($time >= $expires_at) {
	return $sTRUE;
    } else {
	return $sFALSE;
    }
}


# use this cache instance's frozen data to get an estimate of the memory consumption

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

    $self->_lock();

    my $frozen_data = $self->_get_frozen_data();

    my $size = length $frozen_data;

    $self->_unlock();

    return $size;
}

# set the frozen data in the share

sub _set_frozen_data
{
    my ($self, $frozen_data) = @_;

    my $share = $self->{_share} or
	croak("Couldn't get share");

    $share->store($frozen_data);

    return $sSUCCESS;
}


# get the frozen data from the share

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

    my $share = $self->{_share} or
	croak("Couldn't get share");

    return $share->fetch();
}


# lock on the shared memory

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

    my $share = $self->{_share} or
	croak("Couldn't get share");

    $share->lock(LOCK_EX) or
	croak("Couldn't lock");

    return $sSUCCESS;
}


# unlock on the shared memory

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

    my $share = $self->{_share} or
	croak("Couldn't get share");

    $share->unlock() or
	croak("Couldn't unlock");

    return $sSUCCESS;
}



# clear all objects in all namespaces and release the shared memory

sub CLEAR
{
    my ($cache_key) = @_;

    $cache_key = $cache_key || $sDEFAULT_CACHE_KEY;

    my $tmp_share = new IPC::ShareLite( -key => $cache_key, -create => 1, -destroy => 1 ) or
	croak("Couldn't create new IPC::ShareLite");

    return $sSUCCESS;
}



# purge all objects in all namespaces that have expired

sub PURGE
{
    my ($cache_key) = @_;

    $cache_key = $cache_key || $sDEFAULT_CACHE_KEY;

    # note that this will not destroy the shared memory segment when it finishes

    my $tmp_cache = new IPC::Cache( { cache_key => $cache_key } ) or
	croak("Couldn't instantiate new cache");

    $tmp_cache->_purge_all();

    return $sSUCCESS;
}


# get an estimate of the total memory consumption of the cache

sub SIZE
{
    my ($cache_key) = @_;

    $cache_key = $cache_key || $sDEFAULT_CACHE_KEY;

    my $tmp_cache = new IPC::Cache( { cache_key => $cache_key } ) or
	croak("Couldn't instantiate new cache");

    return $tmp_cache->_size();
}


1;


__END__