view release on metacpan or  search on metacpan

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

package CHI::t::Driver;
$CHI::t::Driver::VERSION = '0.61';
use strict;
use warnings;
use CHI::Test;
use CHI::Test::Util
  qw(activate_test_logger cmp_bool is_between random_string skip_until);
use CHI::Util qw(can_load dump_one_line write_file);
use Encode;
use File::Spec::Functions qw(tmpdir);
use File::Temp qw(tempdir);
use List::Util qw(shuffle);
use Scalar::Util qw(weaken);
use Storable qw(dclone);
use Test::Warn;
use Time::HiRes qw(usleep);
use base qw(CHI::Test::Class);

# Flags indicating what each test driver supports
sub supports_clear              { 1 }
sub supports_expires_on_backend { 0 }
sub supports_get_namespaces     { 1 }

sub standard_keys_and_values : Test(startup) {
    my ($self) = @_;

    my ( $keys_ref, $values_ref ) = $self->set_standard_keys_and_values();
    $self->{keys}          = $keys_ref;
    $self->{values}        = $values_ref;
    $self->{keynames}      = [ keys( %{$keys_ref} ) ];
    $self->{key_count}     = scalar( @{ $self->{keynames} } );
    $self->{all_test_keys} = [ values(%$keys_ref), $self->extra_test_keys() ];
    my $cache = $self->new_cache();
    push(
        @{ $self->{all_test_keys} },
        $self->process_keys( $cache, @{ $self->{all_test_keys} } )
    );
    $self->{all_test_keys_hash} =
      { map { ( $_, 1 ) } @{ $self->{all_test_keys} } };
}

sub kvpair {
    my $self = shift;
    my $count = shift || 1;

    return map {
        (
            $self->{keys}->{medium} .   ( $_ == 1 ? '' : $_ ),
            $self->{values}->{medium} . ( $_ == 1 ? '' : $_ )
          )
    } ( 1 .. $count );
}

sub setup : Test(setup) {
    my $self = shift;

    $self->{cache} = $self->new_cache();
    $self->{cache}->clear() if $self->supports_clear();
}

sub testing_driver_class {
    my $self  = shift;
    my $class = ref($self);

    # By default, take the last part of the classname and use it as driver
    my $driver_class = 'CHI::Driver::' . ( split( '::', $class ) )[-1];
    return $driver_class;
}

sub testing_chi_root_class {
    return 'CHI';
}

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

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;
    {
        my $cache = $self->new_cache();
        $weakref = $cache;
        weaken($weakref);
        ok( defined($weakref) && $weakref->isa('CHI::Driver'),
            "weakref is defined" );
    }
    ok( !defined($weakref), "weakref is no longer defined - cache was freed" );
}

{
    package My::CHI;
$My::CHI::VERSION = '0.61';
our @ISA = qw(CHI);
}

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

    is( $cache->chi_root_class, 'CHI', 'chi_root_class=CHI' );
    my $cache2 = My::CHI->new( $self->new_cache_options() );
    is( $cache2->chi_root_class, 'My::CHI', 'chi_root_class=My::CHI' );
}

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

    # These methods require a key
    foreach my $method (
        qw(get get_object get_expires_at exists_and_is_expired is_valid set expire compute get_multi_arrayref get_multi_hashref set_multi remove_multi)
      )
    {
        throws_ok(
            sub { $cache->$method() },
            qr/must specify key/,
            "$method throws error when no key passed"
        );
    }
}

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

    # Test current arg order and pre-0.40 arg order
    foreach my $iter ( 0 .. 1 ) {
        my $count       = 5;
        my $expire_time = time + 10;
        my @args1       = ( { expires_at => $expire_time }, sub { $count++ } );
        my @args2       = (
            {
                expire_if => sub { 1 }
            },
            sub { $count++ }
        );
        if ($iter) {
            @args1 = reverse(@args1);
            @args2 = reverse(@args2);
        }
        $cache->clear;
        is( $cache->get('foo'), undef, "miss" );
        is( $cache->compute( 'foo', @args1 ), 5, "compute - 5" );