The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
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;