File Coverage

blib/lib/Cache/Weak.pm

Criterion	Covered	Total	%
statement	65	76	85.5
branch	11	26	42.3
condition	2	2	100.0
subroutine	20	20	100.0
pod	10	11	90.9
total	108	135	80.0

#
# $Id: Weak.pm 22 2008-04-22 13:28:19Z esobchenko $
package Cache::Weak;

use strict;
use warnings;

use version; our $VERSION = qv('1.0.3');

use Carp qw/carp croak/;
use Scalar::Util qw/weaken/;

use constant {
	DEFAULT_NAMESPACE => '_',
	DEFAULT_AUTO_PURGE_INTERVAL => 1000,
	DEFAULT_AUTO_PURGE => 1,
};

# data is stored in the form: $cache_data{$namespace}{$key} = $object
my %cache_data = ();
my %cache_meta = ();

# private method: used in constructor to get it's arguments
sub _get_args {
	my $proto = shift;

	my $args;
	if ( scalar(@_) > 1 ) {
		if ( @_ % 2 ) {
			croak "odd number of parameters";
		}
		$args = { @_ };
	} elsif ( ref $_[0] ) {
		unless ( eval { local $SIG{'__DIE__'}; %{ $_[0] } || 1 } ) {
			croak "not a hashref in args";
		}
		$args = $_[0];
	} else {
		$args = { namespace => shift };
	}

	return $args;
}

sub new {
	my $class = shift;
	my $self = $class->_get_args(@_);
	return bless $self, $class;
}

sub namespace {
	my $self = shift;
	if (@_) {
		$self->{namespace} = shift;
	}
	return $self->{namespace} || DEFAULT_NAMESPACE;
}

sub auto_purge_interval {
	my $self = shift;
	if (@_) {
		$self->{auto_purge_interval} = shift;
	}
	return $cache_meta{ $self->namespace }{auto_purge_interval}
		= defined $self->{auto_purge_interval} ?
		$self->{auto_purge_interval} : DEFAULT_AUTO_PURGE_INTERVAL;
}

sub auto_purge {
	my $self = shift;
	if (@_) {
		$self->{auto_purge} = shift;
	}
	return $cache_meta{ $self->namespace }{auto_purge}
		= defined $self->{auto_purge} ?
		$self->{auto_purge} : DEFAULT_AUTO_PURGE;
}

# private method: increment access counter for the given namespace and return it's value
sub _inc_count {
	my $self = shift;
	return $cache_meta{ $self->namespace }{count} += 1;
}

# private method: return actual keys for current namespace
sub _keys {
	my $self = shift;
	return keys %{ $cache_data{ $self->namespace } };
}

sub count {
	my $self = shift;
	return int scalar $self->_keys;
}

sub get {
	my ( $self, $key ) = @_;
	return $cache_data{ $self->namespace }{$key};
}

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

	croak "attempting to set non-reference value" unless ref $object;

	# is it time to purge cache from dead objects?
	if ( $self->auto_purge ) {
		$self->purge unless ( $self->_inc_count % $self->auto_purge_interval );
	}

	weaken ( $cache_data{ $self->namespace }{$key} = $object );
	return 1;
}

sub remove {
	my ( $self, $key ) = @_;
	delete $cache_data{ $self->namespace }{$key};
	return 1;
}

# XXX "exists" actually means "defined" in our case
sub exists {
	my ( $self, $key ) = @_;
	return defined $cache_data{ $self->namespace }{$key};
}

sub purge {
	my $self = shift;
	my $cache = $cache_data{ $self->namespace };
	delete @{ $cache }{ grep !$self->exists($_), $self->_keys };
	return 1;
}

sub clear {
	my $self = shift;
	delete $cache_data{ $self->namespace };
	delete $cache_meta{ $self->namespace };
	return 1;
}

1;

__END__