File Coverage

blib/lib/Tie/Hash/Expire.pm

Criterion	Covered	Total	%
statement	119	123	96.7
branch	28	34	82.3
condition	8	11	72.7
subroutine	18	18	100.0
pod	0	4	0.0
total	173	190	91.0

package Tie::Hash::Expire;

use strict;

use POSIX qw/ceil/;
use Carp;

use vars qw($VERSION $HI_RES_AVAILABLE);

$VERSION = '0.03';

BEGIN {
	eval "use Time::HiRes qw/time/";
	unless($@){
		$HI_RES_AVAILABLE = 1;
	}
}

$Tie::Hash::Expire::clean_int = 180; # Maybe later, the user can set this.

sub TIEHASH {
	my $class = shift;
	my $args = shift || {};

	# TODO: What do we do without $args->{expire_seconds}
	unless(exists $args->{expire_seconds}){
		carp "hash tied to Tie::Hash::Expire without specifying expire_seconds.  Hash keys will not expire.";
	}
	if(!$HI_RES_AVAILABLE and $args->{expire_seconds} =~ /\.\d+/){
		carp "expire_seconds appears to be a decimal number, but Time::HiRes is not available.";
	}

	my $self = {
		'last_clean'	=>	time,
		'clean_int'	=>	$Tie::Hash::Expire::clean_int,
		'hash'		=>	{},
		'array'		=>	[],
		'lifespan'	=>	$args->{expire_seconds},
	};
	bless $self, $class;
	return $self;
}

sub STORE {

	my $self = shift;
	my $key = shift;
	my $value = shift;

	my $time = time;

	$self->maybe_clean();

	$self->DELETE($key);

	# Insert it on the end.
	push @{$self->{array}}, [$time,$key,$value];
	$self->{hash}->{$key} = $#{$self->{array}};

}

sub FETCH {

	my $self = shift;
	my $key = shift;

	$self->maybe_clean();

	if(exists $self->{hash}->{$key}){
		# It exists, but may be expired.
		my $time = time;

		my $index = $self->{hash}->{$key};
		if((defined $self->{lifespan}) and $time - $self->{array}->[$index]->[0] >= $self->{lifespan}){
			# It is expired.
			$self->chop_hash($index);
			return undef;
		}
		# It is not expired.
		return $self->{array}->[$index]->[2];
	} else {
		return undef;
	}
}

sub EXISTS {

	my $self = shift;
	my $key = shift;

	$self->maybe_clean();

	if(exists $self->{hash}->{$key}){
		# It exists, but may be expired.
		my $time = time;

		my $index = $self->{hash}->{$key};
		if(defined $self->{lifespan} and $time - $self->{array}->[$index]->[0] >= $self->{lifespan}){
			# It is expired.
			$self->chop_hash($index);
		}
	}

	return exists $self->{hash}->{$key};

}

sub DELETE {

	my $self = shift;
	my $key = shift;

	$self->maybe_clean();

	if(exists($self->{hash}->{$key})){
		splice @{$self->{array}}, $self->{hash}->{$key},1;
		$self->rebuild_hash();
	}
}

sub CLEAR {

	my $self = shift;

	$self->{hash} = {};
	$self->{array} = [];
	$self->{last_clean} = time;

}

sub FIRSTKEY {

	my $self = shift;
	$self->clean_house();

	if(scalar @{$self->{array}}){
		my $key = $self->{array}->[0]->[1];
		$self->{curr_key} = 0;
		return $key;
	} else {
		return undef;
	}
}

sub NEXTKEY {

	my $self = shift;

	my $chopped = $self->clean_house();

	# First, update $self->{curr_key}
	$self->{curr_key}++;

	if(defined $chopped){	# The hash has changed while iterating.
		if($self->{curr_key} <= $chopped){	# Start over
			$self->{curr_key} = 0;
		} else {				# Adjust number
			$self->{curr_key} = ($self->{curr_key}-$chopped)-1;
		}
	}

	# Return the right thing:
	if($self->{curr_key} <= $#{$self->{array}}){
		return $self->{array}->[$self->{curr_key}]->[1];
	} else {
		return undef;
	}
}

sub clean_house {

	my $self = shift;

	# Locate the first expired datum and chop there.
	# Return the index of the first chopped key, or undef if no chop
	# occurred.

	unless(defined $self->{lifespan}){
		return undef;
	}

	my $max = $#{$self->{array}};
	my $min = -1;
	my $time = time;
 	$self->{last_clean} = $time;

	while($max > $min){
		my $try = ceil(($max+$min)/2);
		if($time - $self->{array}->[$try]->[0] >= $self->{lifespan}){
			$min = $try;
		} else {
			$max = $try-1;
		}
	}
	if($min>=0){
		$self->chop_hash($min);
		return $min;
	} else {
		return undef;
	}

}

sub maybe_clean {

	my $self = shift;

	my $time = time;
	if($time - $self->{last_clean} >= $self->{clean_int}){
		$self->clean_house();
	}
}

sub chop_hash {

	my $self = shift;
	my ($index) = @_;

	# Eliminate all entries from the array at $index and before.

	if($index >= $#{$self->{array}}){
		@{$self->{array}} = ();
	} else {
		@{$self->{array}} = @{$self->{array}}[($index+1) .. $#{$self->{array}}];
	}

	$self->rebuild_hash();
}

sub rebuild_hash {

	my $self = shift;

	$self->{hash} = {
		map {$self->{array}->[$_]->[1], $_} (0..$#{$self->{array}})
	};
}
1;

__END__