Commits

Toby Inkster committed ca896e7

pass most of Cache::Cache's tests

Comments (0)

Files changed (4)

lib/Cache/Moustache.pm

 sub new
 {
 	my ($class, %args) = @_;
+	return $class if ref $class && $class->isa(__PACKAGE__);
 	my %self = map { ;"~~~~$_" => $args{$_} } keys %args;
 	$self{'~~~~default_expires_in'} ||= 3600;
-	bless \%self, $class;
+	bless {%self}, $class;
 }
 
 my %multipliers = (
 	years    => 31536000,
 );
 
+sub _clone
+{
+	require Storable;
+	shift;
+	goto \&Storable::dclone;
+}
+
 sub set
 {
 	my ($cache, $key, $data, $expires_in) = @_;
 	return if $key =~ /^~~~~/;
 	
+	$data = $cache->_clone($data) if ref $data && $cache->{'~~~~clone_references'};
+	
 	$expires_in = $cache->{'~~~~default_expires_in'} if !defined $expires_in;
 	
 	if ($expires_in =~ /^(\d+)\s*([A-Za-z]+)$/)
 	return scalar(@keys);
 }
 
+sub get_keys
+{
+	my $cache = shift;
+	my @keys = grep { !/^~~~~/ } keys %$cache;
+	return @keys;
+}
+
+sub size
+{
+	scalar( my @keys = shift->get_keys );
+}
+
 sub AUTOLOAD
 {
 	return;
 dependencies"; I said no dependencies. This thing doesn't even
 C<use strict>. It's basically just a hashref with methods.
 
+I would have called it Cache::Tiny, but then people might have
+been tempted to actually use it.
+
 =head2 Constructor
 
 =over
 
 =item C<< new(%options) >>
 
-Only one option is supported: I<default_expires_in>, which is the
-length of time (in seconds) before a cached value should be
+Called as a class method returns a shiny new cache. Called as
+an object (instance) method, just returns C<< $self >>.
+
+Supported options:
+
+=over
+
+=item default_expires_in
+
+The length of time (in seconds) before a cached value should be
 considered expired. The default is an hour. If you specify -1,
 then things will never expire. If you specify 0, that's dumb, so
 Cache::Moustache will assume that you meant an hour.
 
+=item clone_references
+
+If true, then Cache::Moustache will clone any references you
+ask it to cache. This feature uses the C<dclone> function from
+L<Storable>, so violates Cache::Moustache's "no dependencies"
+rule. Yeah, we're so cool we don't even follow our own rules!
+
+This slows down the cache, so don't use it unless you have to.
+(I only added this feature to pass some test cases, I don't
+actually want to use it myself.)
+
+=back
+
 =back
 
 =head2 Methods
 Remove any expired key/value pairs from the cache. Returns the
 number of pairs removed.
 
+=item C<< size >>
+
+Returns the number of items in the cache (including expired items
+that have not been purged). Note that unlike L<Cache::Cache> and
+L<CHI>, it does not return the total size of all items in bytes.
+
+=item C<< size >>
+
+Returns the number of items in the cache (including expired items
+that have not been purged). Note that unlike L<Cache::Cache> and
+L<CHI>, it does not return the total size of all items in bytes.
+
+=item C<< get_keys >>
+
+Returns the keys of the items in the cache (including expired items
+that have not been purged). 
+
 =item C<< isa($class) >>
 
 Returns true if $class is one of 'Cache::Moustache', 'Cache',

t/02cachetester.t

+# Cache::Moustache passes the test suite from Cache::Cache, except
+# for namespace stuff, and class-wide methods.
+
+use lib "lib";
+use lib "t/lib";
+
+use Cache::CacheTester;
+use Cache::Moustache;
+
+print "1..24\n";
+Cache::CacheTester
+	-> new( 1 )
+	-> test( Cache::Moustache->new(clone_references => 1) );

t/lib/Cache/BaseCacheTester.pm

+######################################################################
+# $Id: BaseCacheTester.pm,v 1.7 2002/04/07 17:04:46 dclinton Exp $
+# Copyright (C) 2001-2003 DeWitt Clinton  All Rights Reserved
+#
+# Software distributed under the License is distributed on an "AS
+# IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or
+# implied. See the License for the specific language governing
+# rights and limitations under the License.
+######################################################################
+
+
+package Cache::BaseCacheTester;
+
+
+use strict;
+
+
+sub new
+{
+  my ( $proto, $base_test_count ) = @_;
+  my $class = ref( $proto ) || $proto;
+  my $self  = {};
+  bless ( $self, $class );
+
+  $base_test_count = defined $base_test_count ? $base_test_count : 0 ;
+
+  $self->_set_test_count( $base_test_count );
+
+  return $self;
+}
+
+
+sub ok
+{
+  my ( $self ) = @_;
+
+  my $test_count = $self->_get_test_count( );
+
+  print "ok $test_count\n";
+
+  $self->_increment_test_count( );
+}
+
+
+sub not_ok
+{
+  my ( $self, $message ) = @_;
+
+  my $test_count = $self->_get_test_count( );
+
+  print "not ok $test_count # failed '$message'\n";
+
+  $self->_increment_test_count( );
+}
+
+
+sub skip
+{
+  my ( $self, $message ) = @_;
+
+  my $test_count = $self->_get_test_count( );
+
+  print "ok $test_count # skipped $message \n";
+
+  $self->_increment_test_count( );
+}
+
+
+sub _set_test_count
+{
+  my ( $self, $test_count ) = @_;
+
+  $self->{_Test_Count} = $test_count;
+}
+
+
+sub _get_test_count
+{
+  my ( $self ) = @_;
+
+  return $self->{_Test_Count};
+}
+
+
+sub _increment_test_count
+{
+  my ( $self ) = @_;
+
+  $self->{_Test_Count}++;
+}
+
+
+1;
+
+
+__END__
+
+
+=pod
+
+=head1 NAME
+
+Cache::BaseCacheTester -- abstract cache tester base class
+
+=head1 DESCRIPTION
+
+BaseCacheTester provides functionality common to all instances of a
+class that will test cache implementations.
+
+=head1 SYNOPSIS
+
+BaseCacheTester provides functionality common to all instances of a
+class that will test cache implementations.
+
+  package Cache::MyCacheTester;
+
+  use vars qw( @ISA );
+  use Cache::BaseCacheTester;
+
+  @ISA = qw( Cache::BaseCacheTester );
+
+=head1 METHODS
+
+=over
+
+=item B<new( $base_test_count )>
+
+Construct a new BaseCacheTester and initialize the test count to
+I<$base_test_count>.
+
+=item B<ok( )>
+
+Print a message to stdout in the form "ok $test_count" and
+incremements the test count.
+
+=item B<not_ok( $message )>
+
+Print a message to stdout in the form "not ok $test_count # I<$message> "
+and incremements the test count.
+
+=item B<skip( $message )>
+
+Print a message to stdout in the form "ok $test_count # skipped I<$message> "
+and incremements the test count.
+
+=back
+
+=head1 SEE ALSO
+
+Cache::CacheTester, Cache::SizeAwareCacheTester
+
+=head1 AUTHOR
+
+Original author: DeWitt Clinton <dewitt@unto.net>
+
+Last author:     $Author: dclinton $
+
+Copyright (C) 2001-2003 DeWitt Clinton
+
+=cut
+
+

t/lib/Cache/CacheTester.pm

+######################################################################
+# $Id: CacheTester.pm,v 1.20 2002/04/07 17:04:46 dclinton Exp $
+# Copyright (C) 2001-2003 DeWitt Clinton  All Rights Reserved
+#
+# Software distributed under the License is distributed on an "AS
+# IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or
+# implied. See the License for the specific language governing
+# rights and limitations under the License.
+######################################################################
+
+package Cache::CacheTester;
+
+use strict;
+use Cache::BaseCacheTester;
+use Cache::Cache;
+
+our @ISA           = qw( Cache::BaseCacheTester );
+our $EXPIRES_DELAY = 2;
+
+sub test
+{
+  my ( $self, $cache ) = @_;
+
+  $cache->Clear( );
+  $self->_test_one( $cache );
+  $self->_test_two( $cache );
+  $self->_test_three( $cache );
+  $self->_test_four( $cache );
+  $self->_test_five( $cache );
+  $self->_test_six( $cache );
+  $self->_test_seven( $cache );
+  $self->_test_eight( $cache );
+  $self->_test_nine( $cache );
+#  $self->_test_ten( $cache );
+#  $self->_test_eleven( $cache );
+#  $self->_test_twelve( $cache );
+  $self->_test_thirteen( $cache );
+  $self->_test_fourteen( $cache );
+  $self->_test_fifteen( $cache );
+  $self->_test_sixteen( $cache );
+#  $self->_test_seventeen( $cache );
+}
+
+
+# Test the getting, setting, and removal of a scalar
+
+sub _test_one
+{
+  my ( $self, $cache ) = @_;
+
+  $cache or
+    croak( "cache required" );
+
+  my $key = 'Test Key';
+
+  my $value = 'Test Value';
+
+  $cache->set( $key, $value );
+
+  my $fetched_value = $cache->get( $key );
+
+  ( $fetched_value eq $value ) ?
+    $self->ok( ) : $self->not_ok( '$fetched_value eq $value' );
+
+  $cache->remove( $key );
+
+  my $fetched_removed_value = $cache->get( $key );
+
+  ( not defined $fetched_removed_value ) ?
+    $self->ok( ) : $self->not_ok( 'not defined $fetched_removed_value' );
+}
+
+
+# Test the getting, setting, and removal of a list
+
+sub _test_two
+{
+  my ( $self, $cache ) = @_;
+
+  $cache or
+    croak( "cache required" );
+
+  my $key = 'Test Key';
+
+  my @value_list = ( 'One', 'Two', 'Three' );
+
+  $cache->set( $key, \@value_list );
+
+  my $fetched_value_list_ref = $cache->get( $key );
+
+  if ( ( $fetched_value_list_ref->[0] eq 'One' ) and
+       ( $fetched_value_list_ref->[1] eq 'Two' ) and
+       ( $fetched_value_list_ref->[2] eq 'Three' ) )
+  {
+    $self->ok( );
+  }
+  else
+  {
+    $self->not_ok( 'fetched list does not match set list' );
+  }
+
+  $cache->remove( $key );
+
+  my $fetched_removed_value = $cache->get( $key );
+
+  ( not defined $fetched_removed_value ) ?
+    $self->ok( ) : $self->not_ok( 'not defined $fetched_removed_value' );
+}
+
+
+# Test the getting, setting, and removal of a blessed object
+
+sub _test_three
+{
+  my ( $self, $cache ) = @_;
+
+  $cache or
+    croak( "cache required" );
+
+  my $key = 'Test Key';
+
+  my $value = 'Test Value';
+
+  $cache->set( $key, $value );
+
+  my $cache_key = 'Cache Key';
+
+  $cache->set( $cache_key, $cache );
+
+  my $fetched_cache = $cache->get( $cache_key );
+
+  ( defined $fetched_cache ) ?
+    $self->ok( ) : $self->not_ok( 'defined $fetched_cache' );
+
+  my $fetched_value = $fetched_cache->get( $key );
+
+  ( $fetched_value eq $value ) ?
+    $self->ok( ) : $self->not_ok( '$fetched_value eq $value' );
+}
+
+
+# Test the expiration of an object
+
+sub _test_four
+{
+  my ( $self, $cache ) = @_;
+
+  my $expires_in = $EXPIRES_DELAY;
+
+  my $key = 'Test Key';
+
+  my $value = 'Test Value';
+
+  $cache->set( $key, $value, $expires_in );
+
+  my $fetched_value = $cache->get( $key );
+
+  ( $fetched_value eq $value ) ?
+    $self->ok( ) : $self->not_ok( '$fetched_value eq $value' );
+
+  sleep( $EXPIRES_DELAY + 1 );
+
+  my $fetched_expired_value = $cache->get( $key );
+
+  ( not defined $fetched_expired_value ) ?
+    $self->ok( ) : $self->not_ok( 'not defined $fetched_expired_value' );
+}
+
+
+
+# Test that caches make deep copies of values
+
+sub _test_five
+{
+  my ( $self, $cache ) = @_;
+
+  $cache or
+    croak( "cache required" );
+
+  my $key = 'Test Key';
+
+  my @value_list = ( 'One', 'Two', 'Three' );
+
+  $cache->set( $key, \@value_list );
+
+  @value_list = ( );
+
+  my $fetched_value_list_ref = $cache->get( $key );
+
+  if ( ( $fetched_value_list_ref->[0] eq 'One' ) and
+       ( $fetched_value_list_ref->[1] eq 'Two' ) and
+       ( $fetched_value_list_ref->[2] eq 'Three' ) )
+  {
+    $self->ok( );
+  }
+  else
+  {
+    $self->not_ok( 'fetched deep list does not match set deep list' );
+  }
+}
+
+
+
+# Test clearing a cache
+
+sub _test_six
+{
+  my ( $self, $cache ) = @_;
+
+  $cache or
+    croak( "cache required" );
+
+  my $key = 'Test Key';
+
+  my $value = 'Test Value';
+
+  $cache->set( $key, $value );
+
+  $cache->clear( );
+
+  my $fetched_cleared_value = $cache->get( $key );
+
+  ( not defined $fetched_cleared_value ) ?
+    $self->ok( ) : $self->not_ok( 'not defined $fetched_cleared_value' );
+}
+
+
+# Test sizing of the cache
+
+sub _test_seven
+{
+  my ( $self, $cache ) = @_;
+
+  my $empty_size = $cache->size( );
+
+  ( $empty_size == 0 ) ?
+    $self->ok( ) : $self->not_ok( '$empty_size == 0' );
+
+  my $first_key = 'First Test Key';
+
+  my $value = 'Test Value';
+
+  $cache->set( $first_key, $value );
+
+  my $first_size = $cache->size( );
+
+  ( $first_size > $empty_size ) ?
+    $self->ok( ) : $self->not_ok( '$first_size > $empty_size' );
+
+  my $second_key = 'Second Test Key';
+
+  $cache->set( $second_key, $value );
+
+  my $second_size = $cache->size( );
+
+  ( $second_size > $first_size ) ?
+    $self->ok( ) : $self->not_ok( '$second_size > $first_size' );
+}
+
+
+# Test purging the cache
+
+sub _test_eight
+{
+  my ( $self, $cache ) = @_;
+
+  $cache->clear( );
+
+  my $empty_size = $cache->size( );
+
+  ( $empty_size == 0 ) ?
+    $self->ok( ) : $self->not_ok( '$empty_size == 0' );
+
+  my $expires_in = $EXPIRES_DELAY;
+
+  my $key = 'Test Key';
+
+  my $value = 'Test Value';
+
+  $cache->set( $key, $value, $expires_in );
+
+  my $pre_purge_size = $cache->size( );
+
+  ( $pre_purge_size > $empty_size ) ?
+    $self->ok( ) : $self->not_ok( '$pre_purge_size > $empty_size' );
+
+  sleep( $EXPIRES_DELAY + 1 );
+
+  $cache->purge( );
+
+  my $post_purge_size = $cache->size( );
+
+  ( $post_purge_size == $empty_size ) ?
+    $self->ok( ) : $self->not_ok( '$post_purge_size == $empty_size' );
+}
+
+
+# Test the getting, setting, and removal of a scalar across cache instances
+
+sub _test_nine
+{
+  my ( $self, $cache1 ) = @_;
+
+  $cache1 or
+    croak( "cache required" );
+
+  my $cache2 = $cache1->new( ) or
+    croak( "Couldn't construct new cache" );
+
+  my $key = 'Test Key';
+
+  my $value = 'Test Value';
+
+  $cache1->set( $key, $value );
+
+  my $fetched_value = $cache2->get( $key );
+
+  ( $fetched_value eq $value ) ?
+    $self->ok( ) : $self->not_ok( '$fetched_value eq $value' );
+}
+
+
+# Test Clear() and Size() as instance methods
+
+sub _test_ten
+{
+  my ( $self, $cache ) = @_;
+
+  $cache or
+    croak( "cache required" );
+
+  my $key = 'Test Key';
+
+  my $value = 'Test Value';
+
+  $cache->set( $key, $value );
+
+  my $full_size = $cache->Size( );
+
+  ( $full_size > 0 ) ?
+    $self->ok( ) : $self->not_ok( '$full_size > 0' );
+
+  $cache->Clear( );
+
+  my $empty_size = $cache->Size( );
+
+  ( $empty_size == 0 ) ?
+    $self->ok( ) : $self->not_ok( '$empty_size == 0' );
+}
+
+
+# Test Purge(), Clear(), and Size() as instance methods
+
+sub _test_eleven
+{
+  my ( $self, $cache ) = @_;
+
+  $cache->Clear( );
+
+  my $empty_size = $cache->Size( );
+
+  ( $empty_size == 0 ) ?
+    $self->ok( ) : $self->not_ok( '$empty_size == 0' );
+
+  my $expires_in = $EXPIRES_DELAY;
+
+  my $key = 'Test Key';
+
+  my $value = 'Test Value';
+
+  $cache->set( $key, $value, $expires_in );
+
+  my $pre_purge_size = $cache->Size( );
+
+  ( $pre_purge_size > $empty_size ) ?
+    $self->ok( ) : $self->not_ok( '$pre_purge_size > $empty_size' );
+
+  sleep( $EXPIRES_DELAY + 1 );
+
+  $cache->Purge( );
+
+  my $purged_object = $cache->get_object( $key );
+
+  ( not defined $purged_object ) ?
+    $self->ok( ) : $self->not_ok( 'not defined $purged_object' );
+}
+
+
+# Test Purge(), Clear(), and Size() as static methods
+
+sub _test_twelve
+{
+  my ( $self, $cache ) = @_;
+
+  my $class = ref $cache or
+    croak( "Couldn't get ref \$cache" );
+
+  no strict 'refs';
+
+  &{"${class}::Clear"}( );
+
+  my $empty_size = &{"${class}::Size"}( );
+
+  ( $empty_size == 0 ) ?
+    $self->ok( ) : $self->not_ok( '$empty_size == 0' );
+
+  my $expires_in = $EXPIRES_DELAY;
+
+  my $key = 'Test Key';
+
+  my $value = 'Test Value';
+
+  $cache->set( $key, $value, $expires_in );
+
+  my $pre_purge_size = &{"${class}::Size"}( );
+
+  ( $pre_purge_size > $empty_size ) ?
+    $self->ok( ) : $self->not_ok( '$pre_purge_size > $empty_size' );
+
+  sleep( $EXPIRES_DELAY + 1 );
+
+  &{"${class}::Purge"}( );
+
+  my $purged_object = $cache->get_object( $key );
+
+  ( not defined $purged_object ) ?
+    $self->ok( ) : $self->not_ok( 'not defined $purged_object' );
+
+  use strict;
+}
+
+
+
+# Test the expiration of an object with extended syntax
+
+sub _test_thirteen
+{
+  my ( $self, $cache ) = @_;
+
+  my $expires_in = $EXPIRES_DELAY;
+
+  my $key = 'Test Key';
+
+  my $value = 'Test Value';
+
+  $cache->set( $key, $value, $expires_in );
+
+  my $fetched_value = $cache->get( $key );
+
+  ( $fetched_value eq $value ) ?
+    $self->ok( ) : $self->not_ok( '$fetched_value eq $value' );
+
+  sleep( $EXPIRES_DELAY + 1 );
+
+  my $fetched_expired_value = $cache->get( $key );
+
+  ( not defined $fetched_expired_value ) ?
+    $self->ok( ) : $self->not_ok( 'not defined $fetched_expired_value' );
+}
+
+
+# test the get_keys method
+
+sub _test_fourteen
+{
+  my ( $self, $cache ) = @_;
+
+  $cache->Clear( );
+
+  my $empty_size = $cache->Size( );
+
+  ( $empty_size == 0 ) ?
+    $self->ok( ) : $self->not_ok( '$empty_size == 0' );
+
+  my @keys = sort ( 'John', 'Paul', 'Ringo', 'George' );
+
+  my $value = 'Test Value';
+
+  foreach my $key ( @keys )
+  {
+    $cache->set( $key, $value );
+  }
+
+  my @cached_keys = sort $cache->get_keys( );
+
+  my $arrays_equal = Arrays_Are_Equal( \@keys, \@cached_keys );
+
+  ( $arrays_equal == 1 ) ?
+    $self->ok( ) : $self->not_ok( '$arrays_equal == 1' );
+}
+
+
+# test the auto_purge on set functionality
+
+sub _test_fifteen
+{
+  my ( $self, $cache ) = @_;
+
+  $cache->Clear( );
+
+  my $expires_in = $EXPIRES_DELAY;
+
+  $cache->set_auto_purge_interval( $expires_in );
+
+  $cache->set_auto_purge_on_set( 1 );
+
+  my $key = 'Test Key';
+
+  my $value = 'Test Value';
+
+  $cache->set( $key, $value, $expires_in );
+
+  my $fetched_value = $cache->get( $key );
+
+  ( $fetched_value eq $value ) ?
+    $self->ok( ) : $self->not_ok( '$fetched_value eq $value' );
+
+  sleep( $EXPIRES_DELAY + 1 );
+
+  $cache->set( "Trigger auto_purge", "Empty" );
+
+  my $fetched_expired_object = $cache->get_object( $key );
+
+  ( not defined $fetched_expired_object ) ?
+    $self->ok( ) : $self->not_ok( 'not defined $fetched_expired_object' );
+
+  $cache->Clear( );
+}
+
+
+
+# test the auto_purge_interval functionality
+
+sub _test_sixteen
+{
+  my ( $self, $cache ) = @_;
+
+  my $expires_in = $EXPIRES_DELAY;
+
+  eval
+  {
+    $cache = $cache->new( { 'auto_purge_interval' => $expires_in } );
+  };
+
+  ( not defined @$ ) ?
+    $self->ok( ) : $self->not_ok( "couldn't create autopurge cache" );
+}
+
+
+# test the get_namespaces method
+
+sub _test_seventeen
+{
+  my ( $self, $cache ) = @_;
+
+  $cache->set( 'a', '1' );
+  $cache->set_namespace( 'namespace' );
+  $cache->set( 'b', '2' );
+
+  if ( Arrays_Are_Equal( [ sort( $cache->get_namespaces( ) ) ],
+                         [ sort( 'Default', 'namespace' ) ] ) )
+  {
+    $self->ok( );
+  }
+  else
+  {
+    $self->not_ok( "get_namespaces returned the wrong namespaces" );
+  }
+  
+  $cache->Clear( );
+}
+
+
+
+sub Arrays_Are_Equal
+{
+  my ( $first_array_ref, $second_array_ref ) = @_;
+
+  local $^W = 0;  # silence spurious -w undef complaints
+
+  return 0 unless @$first_array_ref == @$second_array_ref;
+
+  for (my $i = 0; $i < @$first_array_ref; $i++)
+  {
+    return 0 if $first_array_ref->[$i] ne $second_array_ref->[$i];
+  }
+
+  return 1;
+}
+
+
+1;
+
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Cache::CacheTester -- a class for regression testing caches
+
+=head1 DESCRIPTION
+
+The CacheTester is used to verify that a cache implementation honors
+its contract.
+
+=head1 SYNOPSIS
+
+  use Cache::MemoryCache;
+  use Cache::CacheTester;
+
+  my $cache = new Cache::MemoryCache( );
+
+  my $cache_tester = new Cache::CacheTester( 1 );
+
+  $cache_tester->test( $cache );
+
+=head1 METHODS
+
+=over
+
+=item B<new( $initial_count )>
+
+Construct a new CacheTester object, with the counter starting at
+I<$initial_count>.
+
+=item B<test( )>
+
+Run the tests.
+
+=back
+
+=head1 SEE ALSO
+
+Cache::Cache, Cache::BaseCacheTester
+
+=head1 AUTHOR
+
+Original author: DeWitt Clinton <dewitt@unto.net>
+
+Last author:     $Author: dclinton $
+
+Copyright (C) 2001-2003 DeWitt Clinton
+
+=cut
+