Gecko [ fernandoquevedodop.com ]

Name	Size	Permission
File	[ DIR ]	drwxr-xr-x
Memory	[ DIR ]	drwxr-xr-x
Null	[ DIR ]	drwxr-xr-x
RemovalStrategy	[ DIR ]	drwxr-xr-x
BaseCache.pm	14.73 KB	-rw-r--r--
BaseCacheTester.pm	2.76 KB	-rw-r--r--
Cache.pm	8.22 KB	-rw-r--r--
CacheMetaData.pm	5.73 KB	-rw-r--r--
CacheSizer.pm	3.94 KB	-rw-r--r--
CacheTester.pm	13.05 KB	-rw-r--r--
CacheUtils.pm	2.85 KB	-rw-r--r--
Entry.pm	8.37 KB	-rw-r--r--
File.pm	16.72 KB	-rw-r--r--
FileBackend.pm	14.06 KB	-rw-r--r--
FileCache.pm	7.17 KB	-rw-r--r--
IOString.pm	3.24 KB	-rw-r--r--
Memory.pm	9.64 KB	-rw-r--r--
MemoryBackend.pm	2.57 KB	-rw-r--r--
MemoryCache.pm	2.76 KB	-rw-r--r--
Null.pm	2.27 KB	-rw-r--r--
NullCache.pm	2.21 KB	-rw-r--r--
Object.pm	3.4 KB	-rw-r--r--
RemovalStrategy.pm	1.03 KB	-rw-r--r--
SharedMemoryBackend.pm	4.72 KB	-rw-r--r--
SharedMemoryCache.pm	3.4 KB	-rw-r--r--
SizeAwareCache.pm	3.04 KB	-rw-r--r--
SizeAwareCacheTester.pm	5.66 KB	-rw-r--r--
SizeAwareFileCache.pm	3.68 KB	-rw-r--r--
SizeAwareMemoryCache.pm	3.35 KB	-rw-r--r--
SizeAwareSharedMemoryCache.pm	2.55 KB	-rw-r--r--
Tester.pm	13.44 KB	-rw-r--r--

Code Editor : 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;
use Error qw( :try );

use vars qw( @ISA $EXPIRES_DELAY );

@ISA = qw ( Cache::BaseCacheTester );

$EXPIRES_DELAY = 2;
$Error::Debug = 1;

sub test
{
  my ( $self, $cache ) = @_;

try
  {
    $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 );
  }
  catch Error with
  {
    my $error = shift;

print STDERR "\nError:\n";
    print STDERR $error->stringify( ) . "\n";
    print STDERR $error->stacktrace( ) . "\n";
    print STDERR "\n";
  }
}

# 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';

my $start = time;
  $cache->set( $key, $value, $expires_in );

my $fetched_value = $cache->get( $key );

if (time - $start < $expires_in) {
    ( $fetched_value eq $value ) ?
      $self->ok( ) : $self->not_ok( '$fetched_value eq $value' );
  } else {
      $self->skip( '$fetched_value eq $value (not finished in ' .
        $expires_in . ' s)' );
  }

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 );

# 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';

my $start = time;
  $cache->set( $key, $value, $expires_in );

my $fetched_value = $cache->get( $key );

if (time - $start < $expires_in) {
    ( $fetched_value eq $value ) ?
      $self->ok( ) : $self->not_ok( '$fetched_value eq $value' );
  } else {
    $self->skip( '$fetched_value eq $value (not finished in ' .
      $expires_in . ' s)' );
  }

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';

my $start = time;
  $cache->set( $key, $value, $expires_in );

my $fetched_value = $cache->get( $key );

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;

my $ok = eval {
    $cache = $cache->new( { 'auto_purge_interval' => $expires_in } );
    1;
  };

$ok ? $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;
}

__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 $

=cut

${this.title}

Code Editor : CacheTester.pm