/usr/share/perl5/CHI/t/Driver/RawMemory.pm is in libchi-perl 0.60-3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 | package CHI::t::Driver::RawMemory;
$CHI::t::Driver::RawMemory::VERSION = '0.60';
use strict;
use warnings;
use CHI::Test;
use CHI::Test::Util qw(is_between);
use base qw(CHI::t::Driver::Memory);
sub new_cache {
my $self = shift;
my %params = ( $self->new_cache_options(), @_, );
# If new_cache called with datastore, ignore global flag (otherwise would be an error)
#
if ( $params{datastore} ) {
delete $params{global};
}
my $cache = CHI->new(%params);
return $cache;
}
# Not applicable to raw memory
#
sub test_deep_copy { }
sub test_scalar_return_values { }
sub test_serialize { }
sub test_serializers { }
# Would need tweaking to pass
#
sub test_append { }
sub test_compress_threshold { }
sub test_custom_discard_policy { }
sub test_lru_discard { }
sub test_size_awareness_with_subcaches { }
sub test_stats { }
sub test_subcache_overridable_params { }
# Size of all items = 1 in this driver
#
sub test_size_awareness : Tests {
my $self = shift;
my ( $key, $value ) = $self->kvpair();
ok( !$self->new_cleared_cache()->is_size_aware(),
"not size aware by default" );
ok( $self->new_cleared_cache( is_size_aware => 1 )->is_size_aware(),
"is_size_aware turns on size awareness" );
ok( $self->new_cleared_cache( max_size => 10 )->is_size_aware(),
"max_size turns on size awareness" );
my $cache = $self->new_cleared_cache( is_size_aware => 1 );
is( $cache->get_size(), 0, "size is 0 for empty" );
$cache->set( $key, $value );
is( $cache->get_size, 1, "size is 1 with one value" );
$cache->set( $key, scalar( $value x 5 ) );
is( $cache->get_size, 1, "size is still 1 after override" );
$cache->set( $key, scalar( $value x 5 ) );
is( $cache->get_size, 1, "size is still 1 after same overwrite" );
$cache->set( $key, scalar( $value x 2 ) );
is( $cache->get_size, 1, "size is 1 after overwrite" );
$cache->set( $key . "2", $value );
is( $cache->get_size, 2, "size is 2 after second key" );
$cache->remove($key);
is( $cache->get_size, 1, "size is 1 again after removing key" );
$cache->remove( $key . "2" );
is( $cache->get_size, 0, "size is 0 again after removing keys" );
$cache->set( $key, $value );
is( $cache->get_size, 1, "size is 1 with one value" );
$cache->clear();
is( $cache->get_size, 0, "size is 0 again after clear" );
my $time = time() + 10;
$cache->set( $key, $value, { expires_at => $time } );
is( $cache->get_expires_at($key),
$time, "set options respected by size aware cache" );
}
sub test_max_size : Tests {
my $self = shift;
my $cache = $self->new_cleared_cache( max_size => 5 );
ok( $cache->is_size_aware, "is size aware when max_size specified" );
my $value = 'x';
for ( my $i = 0 ; $i < 5 ; $i++ ) {
$cache->set( "key$i", $value );
}
for ( my $i = 0 ; $i < 10 ; $i++ ) {
$cache->set( "key" . int( rand(10) ), $value );
is_between( $cache->get_size, 3, 5,
"after iteration $i, size = " . $cache->get_size );
is_between( scalar( $cache->get_keys ),
3, 5, "after iteration $i, keys = " . scalar( $cache->get_keys ) );
}
}
# Test that we're caching a reference, not a deep copy
#
sub test_cache_ref : Tests {
my $self = shift;
my $cache = $self->{cache};
my $lst = ['foo'];
$cache->set( 'key1' => $lst );
$cache->set( 'key2' => $lst );
is( $cache->get('key1'), $lst, "got same reference" );
is( $cache->get('key2'), $lst, "got same reference" );
$lst->[0] = 'bar';
is( $cache->get('key1')->[0], 'bar', "changed value in cache" );
}
sub test_short_driver_name : Tests {
my ($self) = @_;
my $cache = $self->{cache};
is( $cache->short_driver_name, 'RawMemory' );
}
1;
|