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__

=head1 NAME

Tie::Hash::Expire - Hashes with keys that expire after a user-set period.

=head1 SYNOPSIS

  use Tie::Hash::Expire;

  my %test;
  tie %test, 'Tie::Hash::Expire', {'expire_seconds' => 10};

  $test{'dog'} = 'doghouse';
  sleep 5;
  $test{'bird'} = 'nest';
  sleep 6;

  print keys %test, "\n";	# The only key is 'bird'

  my %hi_res;
  tie %hi_res, 'Tie::Hash::Expire', {'expire_seconds' => 5.21};
	# Decimal number of seconds works if you have Time::HiRes

=head1 ABSTRACT

Hashes tied to Tie::Hash::Expire have keys that cease to exist 'expire_seconds' after their most recent modification or their creation.

=head1 DESCRIPTION

Hashes tied to Tie::Hash::Expire behave like normal hashes in all respects except that when a key is added or the value associated with a key is changed, the current time is stored, and after 'expire_seconds' the key and value are removed from the hash.

Resolutions finer than seconds are available if the module finds access to Time::HiRes.  If Time::HiRes is available, you can expect expiration to be accurate to 0.001 seconds.  You may specify 'expire_seconds' to be decimal numbers like 5.12 .  If Time::HiRes is available, this number will be used precisely.  If you specify a decimal number and don't have access to Time::HiRes, a warning is generated and the code will function as though you specified the next higher integer.

The number of seconds specified by 'expire_seconds' is taken to mean an absolute maximum lifespan for the key, at the resolution described above.  In other words, if you set 'expire_seconds' to 1 second, and do not have Time::HiRes, keys could expire as quickly as the next machine instruction, but will not last longer than 1 second.

=head1 AUTHOR

Jeff Yoak, E<lt>jeff@yoak.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2004 by Jeff Yoak

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. 

=cut