view release on metacpan or  search on metacpan

lib/CHI/t/Driver.pm  view on Meta::CPAN

        is_between( $c->get_size, $max_size - 40,
            $max_size, "$label size = " . $c->get_size );
        is_between(
            scalar( $c->get_keys ),
            ( $max_size + 1 ) / 20 - 2,
            ( $max_size + 1 ) / 20,
            "$label keys = " . scalar( $c->get_keys )
        );
    };
    my $is_not_size_aware = sub {
        my $c     = shift;
        my $label = $c->label;

        ok( !$c->is_size_aware, "$label is not size aware" );
        is( $c->get_keys, 20, "$label keys = 20" );
    };

    $cache = $self->new_cleared_cache(
        l1_cache => { driver => 'Memory', datastore => {}, max_size => 99 } );
    $set_values->();
    $is_not_size_aware->($cache);
    $is_size_aware->($l1_cache);

    $cache = $self->new_cleared_cache(
        l1_cache => { driver => 'Memory', datastore => {}, max_size => 99 },
        max_size => 199
    );
    $set_values->();
    $is_size_aware->($cache);
    $is_size_aware->($l1_cache);

    $cache = $self->new_cleared_cache(
        l1_cache => { driver => 'Memory', datastore => {} },
        max_size => 199
    );
    $set_values->();
    $is_size_aware->($cache);

    # Cannot call is_not_size_aware because the get_keys check will
    # fail. Keys will be removed from the l1_cache when they are removed
    # from the main cache, even though l1_cache does not have a max
    # size. Not sure if this is the correct behavior, but for now, we're not
    # going to test it. Normally, l1 caches will be more size limited than
    # their parent caches.
    #
    ok( !$l1_cache->is_size_aware, $l1_cache->label . " is not size aware" );
}

sub is_about {
    my ( $value, $expected, $msg ) = @_;

    my $margin = int( $expected * 0.1 );
    if ( abs( $value - $expected ) <= $margin ) {
        pass($msg);
    }
    else {
        fail("$msg - got $value, expected $expected");
    }
}

sub test_busy_lock : Tests {
    my $self  = shift;
    my $cache = $self->{cache};

    my ( $key, $value ) = $self->kvpair();
    my @bl = ( busy_lock => '30 sec' );
    my $start_time = time();

    local $CHI::Driver::Test_Time = $start_time;
    $cache->set( $key, $value, 100 );
    local $CHI::Driver::Test_Time = $start_time + 90;
    is( $cache->get( $key, @bl ), $value, "hit before expiration" );
    is(
        $cache->get_expires_at($key),
        $start_time + 100,
        "expires_at before expiration"
    );
    local $CHI::Driver::Test_Time = $start_time + 110;
    ok( !defined( $cache->get( $key, @bl ) ), "miss after expiration" );
    is(
        $cache->get_expires_at($key),
        $start_time + 140,
        "expires_at after busy lock"
    );
    is( $cache->get( $key, @bl ), $value, "hit after busy lock" );
}

sub test_obj_ref : Tests {
    my $self = shift;

    # Make sure obj_ref works in conjunction with subcaches too
    my $cache =
      $self->new_cache( l1_cache => { driver => 'Memory', datastore => {} } );
    my $obj;
    my ( $key, $value ) = ( 'medium', [ a => 5, b => 6 ] );

    my $validate_obj = sub {
        isa_ok( $obj, 'CHI::CacheObject' );
        is( $obj->key, $key, "keys match" );
        cmp_deeply( $obj->value, $value, "values match" );
    };

    $cache->get( $key, obj_ref => \$obj );
    ok( !defined($obj), "obj not defined on miss" );
    $cache->set( $key, $value, { obj_ref => \$obj } );
    $validate_obj->();
    undef $obj;
    ok( !defined($obj), "obj not defined before get" );
    $cache->get( $key, obj_ref => \$obj );
    $validate_obj->();
}

sub test_metacache : Tests {
    my $self  = shift;
    my $cache = $self->{cache};

    ok( !defined( $cache->{metacache} ), "metacache is lazy" );
    $cache->metacache->set( 'foo', 5 );
    ok( defined( $cache->{metacache} ), "metacache autovivified" );
    is( $cache->metacache->get('foo'), 5 );
}

sub test_scalar_return_values : Tests {
    my $self  = shift;
    my $cache = $self->{cache};

    my $check = sub {
        my ($code)        = @_;
        my $scalar_result = $code->();
        my @list          = $code->();
        cmp_deeply( \@list, [$scalar_result] );
    };

    $check->( sub { $cache->fetch('a') } );
    $check->( sub { $cache->get('a') } );
    $check->( sub { $cache->set( 'a', 5 ) } );
    $check->( sub { $cache->fetch('a') } );
    $check->( sub { $cache->get('a') } );
}

sub test_no_leak : Tests {
    my ($self) = @_;

    my $weakref;
    {