File Coverage

blib/lib/Tie/Hash/Cache/MRU.pm

Criterion	Covered	Total	%
statement	50	158	31.6
branch	15	74	20.2
condition	7	16	43.7
subroutine	11	24	45.8
pod	3	3	100.0
total	86	275	31.2

package Tie::Hash::Cache::MRU;

use 5.006001;
use strict;
use warnings;


our $VERSION = '0.02';

sub CURRENT(){0};
sub OLD(){1};
sub TIME(){2}
sub SIZE(){3};
sub LIFE(){4};
sub HASH(){5};
# FETCH, STORE, EXISTS, DELETE, FIRSTKEY, NEXTKEY, CLEAR. DESTROY
sub S(){6};
sub F(){7};
sub D(){8};
sub E(){9};
sub C(){10};
sub FK(){11};
sub NK(){12};
sub DE(){13};

sub TIEHASH {

	my $pack = shift;
	my %arg = @_;

	no warnings;
	my @obj = ( {}, {}, {},
	 @arg{qw/SIZE LIFE HASH
	STORE FETCH DELETE EXISTS CLEAR FIRSTKEY NEXTKEY DESTROY/});

	defined $obj[LIFE] or delete $obj[TIME];
	$obj[F] ||= sub($){$obj[HASH]->{$_[0]}};
	$obj[S] ||= sub($$){$obj[HASH]->{$_[0]} = $_[1]};
	$obj[D] ||= sub($){delete $obj[HASH]->{$_[0]}};
	$obj[E] ||= sub($){exists $obj[HASH]->{$_[0]}};
	defined $obj[C] or $obj[C] = sub(){%{$obj[HASH]} = () };


	bless \@obj, $pack;

}

my $NOTEXIST;

sub FETCH { # obj, key

	if($_[0]->[LIFE]){

	   if(exists $_[0]->[TIME]->{$_[1]}
	      and
	      (time() - $_[0]->[TIME]->{$_[1]}) > $_[0]->[LIFE] ){

	   	$_[0]->[CURRENT]->{$_[1]} =
		&{$_[0]->[E]}($_[1])?
		&{$_[0]->[F]}($_[1]):
		\$NOTEXIST;
	   };
	   $_[0]->[TIME]->{$_[1]} = time;
	};

	if (exists $_[0]->[CURRENT]->{$_[1]}){
	      $_[0]->[CURRENT]->{$_[1]} eq \$NOTEXIST
		and return undef;
	      return $_[0]->[CURRENT]->{$_[1]}
	};
	if (exists $_[0]->[OLD]->{$_[1]}){
	      $_[0]->[OLD]->{$_[1]} eq \$NOTEXIST
	       and $_[0]->[CURRENT]->{$_[1]} = \$NOTEXIST
		and return undef;
	      return
		   $_[0]->[CURRENT]->{$_[1]} =
		   delete $_[0]->[OLD]->{$_[1]}
	};
	no warnings;
	if (%{$_[0]->[CURRENT]} > $_[0]->[SIZE]){
		if($_[0]->[LIFE]){
			delete @{$_[0]->[TIME]}{
			   grep { ! exist $_[0]->[CURRENT]->{$_} }
			      keys %{ $_[0]->[OLD] }
			};
		};
		$_[0]->[OLD] = $_[0]->[CURRENT];
		$_[0]->[CURRENT] = {};
	};
	   $_[0]->[CURRENT]->{$_[1]} =
		&{$_[0]->[F]}($_[1]);
}

sub STORE { # obj, key, value
	no warnings;
	if (%{$_[0]->[CURRENT]} > $_[0]->[SIZE]){
		if($_[0]->[LIFE]){
			delete @{$_[0]->[TIME]}{
			   grep { ! exist $_[0]->[CURRENT]->{$_} }
			      keys %{ $_[0]->[OLD] }
			};
		};
		$_[0]->[OLD] = $_[0]->[CURRENT];
		$_[0]->[CURRENT] = {};
	};
	$_[0]->[LIFE] and $_[0]->[TIME]->{$_[1]} = time;
	$_[0]->[CURRENT]->{$_[1]} = $_[2];
	&{$_[0]->[S]}(@_[1,2]);
}
sub EXISTS {
	if($_[0]->[LIFE]){

	   if(exists $_[0]->[TIME]->{$_[1]}
	      and
	      (time() - $_[0]->[TIME]->{$_[1]}) > $_[0]->[LIFE] ){

	   	$_[0]->[CURRENT]->{$_[1]} =
		&{$_[0]->[E]}($_[1])?
		&{$_[0]->[F]}($_[1]):
		\$NOTEXIST;
	   };
	   $_[0]->[TIME]->{$_[1]} = time;
	};
	if (exists $_[0]->[CURRENT]->{$_[1]}){
	   $_[0]->[CURRENT]->{$_[1]} eq \$NOTEXIST
		and return undef;

	   return 1
	};
	if (exists $_[0]->[OLD]->{$_[1]}){
	   $_[0]->[CURRENT]->{$_[1]} =
		delete $_[0]->[OLD]->{$_[1]};
	   $_[0]->[CURRENT]->{$_[1]} eq \$NOTEXIST
		and return undef;
	   return 1;
	};
	no warnings;
	if (%{$_[0]->[CURRENT]} > $_[0]->[SIZE]){
		if($_[0]->[LIFE]){
			delete @{$_[0]->[TIME]}{
			   grep { ! exist $_[0]->[CURRENT]->{$_} }
			      keys %{ $_[0]->[OLD] }
			};
		};
		$_[0]->[OLD] = $_[0]->[CURRENT];
		$_[0]->[CURRENT] = {};
	};
	if(&{$_[0]->[E]}($_[1])){
	   $_[0]->[CURRENT]->{$_[1]} =
		&{$_[0]->[F]}($_[1]);
	   return 1;
	}else{
	   $_[0]->[CURRENT]->{$_[1]} = \$NOTEXIST;
	   return undef;
	}
}

sub DELETE {
	$_[0]->[CURRENT]->{$_[1]} = \$NOTEXIST;
	$_[0]->[LIFE] and $_[0]->[TIME]->{$_[1]} = time;
	&{$_[0]->[D]}($_[1]);

}

sub FIRSTKEY {
	defined $_[0]->[FK] and return &{$_[0]->[FK]}();
	my $t = tied % { $_[0]->[HASH] };
	$t and return $t->FIRSTKEY();
	keys %{$_[0]->[HASH]};
	return each %{$_[0]->[HASH]};

}

sub NEXTKEY {
	defined $_[0]->[NK] and return &{$_[0]->[NK]}();
	my $t = tied % { $_[0]->[HASH] };
	$t and return $t->NEXTKEY($_[1]);
	return each % { $_[0]->[HASH] };
}

sub CLEAR {
	%{$_[0]->[CURRENT]} =
	%{$_[0]->[OLD]} = ();
	$_[0]->[LIFE] and %{$_[0]->[TIME]} = ();

	ref( $_[0]->[C]) =~ /CODE/ and
		&{$_[0]->[C]}();

}

sub DESTROY {
	defined $_[0]->[DE] and &{$_[0]->[DE]}();

}



sub CACHE {
	my $obj = shift;

	%{ $obj->[CURRENT] } =
	( %{ $obj->[CURRENT] } , @_ );
	if($_[0]->[LIFE]){
		$_[0]->[TIME]->{$_} = time foreach @_;
	};


}
sub UNCACHE {
	my $obj = shift;
	delete @{$obj->[CURRENT]}{@_};
	delete @{$obj->[OLD]}{@_};
	$obj->[LIFE] and delete @{$obj->[TIME]}{@_};

}
sub UPDATE {
	my $obj = shift;
	my %update = @_;
	my ($k,$v);
	while(($k,$v) = each %update){
	   if(exists $obj->[CURRENT]->{$k}
	   ){
	     	$obj->[CURRENT]->{$k} = $v;
	        next;
	   };
	   if(exists $obj->[OLD]->{$k}
	   ){
	     	$obj->[CURRENT]->{$k} = $v;
		delete $obj->[OLD]->{$k};
	   };
	};
	if($obj->[LIFE]){
		foreach( grep { exists $obj->[CURRENT]->{$_} } keys %update){
			$obj->[TIME]->{$_} = time;

}	}	}


1;
__END__