Tie-Hash-Expire-0.03/0040755000100400010030000000000010027667161012724 5ustar jeffydevTie-Hash-Expire-0.03/Expire.pm0100644000100400010030000001403310027667000014504 0ustar jeffydevpackage 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, Ejeff@yoak.comE =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 Tie-Hash-Expire-0.03/MANIFEST0100644000100400010030000000007210017015257014041 0ustar jeffydevChanges Expire.pm Makefile.PL MANIFEST README t/1.t t/2.t Tie-Hash-Expire-0.03/t/0040755000100400010030000000000010027667161013167 5ustar jeffydevTie-Hash-Expire-0.03/t/1.t0100644000100400010030000000522510026702214013501 0ustar jeffydev use Test::More tests => 28; BEGIN { warn "\n\n###################################################################\n"; warn "##### Tests take some time because of testing expirations. #####\n"; warn "##### Tests may hang for up to 10 seconds with nothing wrong. #####\n"; warn "###################################################################\n\n"; use_ok('Tie::Hash::Expire'); }; my %test; tie %test, 'Tie::Hash::Expire', {'expire_seconds' => 3}; ### Test assignment (STORE), fetch (FETCH) and expiration. $test{'fred'} = 'barney'; sleep 1; is($test{fred}, 'barney', 'value storage and retrieval'); sleep 3; is($test{fred}, undef, 'basic expiration'); ### Test slicing @test{'fred','lone ranger'} = ('barney','tonto'); is($test{'fred'}, 'barney', 'hash slice'); is($test{'lone ranger'}, 'tonto', 'hash slice 2'); ### Test DELETE delete $test{'fred'}; is($test{fred}, undef, 'delete'); is($test{'lone ranger'}, 'tonto', 'delete 2'); ### Test CLEAR %test = (); is($test{'lone ranger'}, undef, 'clear'); is(scalar keys(%test), 0, 'clear 2'); ### Test EXISTS, defined, etc. %test = ( true => 'Hello', false => 0, undefined => undef, ); ok($test{true}, 'exists 1'); ok(defined($test{false}), 'exists 2'); ok(exists($test{undefined}), 'exists 3'); ok(!defined($test{undefined}), 'exists 4'); ### Test FIRSTKEY and NEXTKEY and expiration while iterating %test = ( 'one' => 1, 'two' => 2, 'three' => 3, ); ok(eq_set([keys %test], [qw/one two three/]), 'keys 1'); ok(eq_set([values %test], [1,2,3,]), 'keys 2'); sleep 2; $test{three} = 'three'; $test{four} = 4; ok(eq_set([keys %test], [qw/one two three four/]), 'keys 3'); ok(eq_set([values %test], [1,2,'three',4,]), 'keys 4'); sleep 2; ok(eq_set([keys %test], [qw/three four/]), 'keys 5'); ok(eq_set([values %test], ['three',4,]), 'keys 6'); my %zero_test; tie %zero_test, 'Tie::Hash::Expire', {'expire_seconds' => 0}; $zero_test{foo} = 'bar'; ok(!exists($zero_test{foo}), 'zero'); my %undef_test; tie %undef_test, 'Tie::Hash::Expire'; $undef_test{foo} = 'bar'; is($undef_test{foo}, 'bar', 'no expire 1'); sleep 2; is($undef_test{foo}, 'bar', 'no expire 2'); # Test for NEXTKEY bug when expirations happen mid-iteration my %exp; tie %exp, 'Tie::Hash::Expire', { 'expire_seconds' => 5 }; $exp{'foo'} = 'bar'; sleep 2; $exp{'biz'} = 'baz'; sleep 2; $exp{'kate'} = 'jeffy'; my ($key, $value) = each %exp; is($key, 'foo', 'NEXTKEY expire 1'); is($value, 'bar', 'NEXTKEY expire 2'); sleep 2; ($key, $value) = each %exp; is($key, 'biz', 'NEXTKEY expire 1'); is($value, 'baz', 'NEXTKEY expire 2'); ($key, $value) = each %exp; is($key, 'kate', 'NEXTKEY expire 1'); is($value, 'jeffy', 'NEXTKEY expire 2'); Tie-Hash-Expire-0.03/t/2.t0100644000100400010030000000206310017017511013476 0ustar jeffydev use Test::More; BEGIN{ eval "use Time::HiRes qw/time sleep/"; # TODO: It is theoretically possible, though unlikely, that you can get # Time::HiRes::time() without getting Time::HiRes::sleep(), and in # order to use the HiRes functionality you only need time(), so # this is a little sloppy. OTOH, I don't really see a good way to # test without a finer grain sleep. (I know you can get finer grain # sleep with a three-argument select, but Time::HiRes knows this and # will provide you with sleep() if you have select(). Presumably, # it knows the tricks better than I do.) So... if you can think of # a good way to test without getting sleep, testing patches are # welcome. if($@){ plan skip_all => "Time::HiRes isn't available on this system."; } else { plan tests => 3; } } use_ok('Tie::Hash::Expire'); my %res; tie %res, 'Tie::Hash::Expire', {'expire_seconds' => 1.5}; $res{foo} = 'bar'; sleep 1.2; is($res{foo}, 'bar', 'fractional sleep lower than expiration'); sleep 0.4; ok(!defined $res{foo}, 'fractional sleep higher than expiration'); Tie-Hash-Expire-0.03/Changes0100644000100400010030000000135610027667102014214 0ustar jeffydevRevision history for Perl extension Tie::Hash::Expire. 0.01 Thu Jan 29 16:27:58 PST 2004 - original version 0.02 - If "expire_seconds" is set to zero all hash keys will expire immediately. If "expire_seconds" is omitted or set to undef hash keys will not expire at all. - Support for Time::HiRes included. If Time::HiRes is available, expiration will occur at the highest resolution available through that module. Decimal expiration times are now available. If decimal expirations are specified and Time::HiRes is not available, a warning is generated, but the code will function as though the next larger integer was specified. 0.03 - Bug Fix: Fixed problem with keys expire during iteration with FIRSTKEY / NEXTKEY Tie-Hash-Expire-0.03/README0100644000100400010030000000325210027667014013600 0ustar jeffydevTie/Hash/Expire version 0.03 =============================== 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. If you have problems with this module, or even simply find it useful, feel free to send mail to the author, Jeff Yoak, at jeff@yoak.com . INSTALLATION To install this module type the following: perl Makefile.PL make make test make install DEPENDENCIES This module requires these other modules and libraries: Test::More (only for testing during installation) POSIX Carp COPYRIGHT AND LICENSE Copyright (C) 2004 Jeff Yoak This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Tie-Hash-Expire-0.03/Makefile.PL0100644000100400010030000000064510006325457014674 0ustar jeffydevuse ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Tie::Hash::Expire', 'VERSION_FROM' => 'Expire.pm', # finds $VERSION 'PREREQ_PM' => { 'Test::More' => 0, 'POSIX' => 0, 'Carp' => 0, }, ($] >= 5.005 ? ## Add these new keywords supported since 5.005 (ABSTRACT_FROM => 'Expire.pm', # retrieve abstract from module AUTHOR => 'Jeff Yoak ') : ()), );