The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use Test::More;
use Test::Exception;
use IO::Socket::INET;
use Moose::Meta::Class;

{
    package Hoge;
    use MooseX::WithCache;
}

BEGIN
{
    eval { require Cache::FastMmap };
    if ( $@ ) {
        plan(skip_all => "no Cache::FastMmap found");
    } else {
        plan(tests => 20);
    }
}

{
    my $class = Moose::Meta::Class->create_anon_class(
        superclasses => [ 'Moose::Object' ],
        roles => [ 'MooseX::WithCache' => { backend => 'Cache::FastMmap' } ]
    );

    my $object = $class->new_object(
        cache => Cache::FastMmap->new,
    );


    {
        my $value = time();
        my $key   = 'foo';
        lives_ok { $object->cache_del($key) }
            "delete key '$key' first to make sure";
        lives_ok { $object->cache_set($key => $value) }
            "set value '$key' to '$value'";
        lives_and { 
            my $v = $object->cache_get($key);
            is($v, $value, "value gotten from cache '$v' should match '$value'");
        } "get value '$key' to '$value' should live";
        lives_ok { $object->cache_del($key) }
            "delete key '$key' to purge";
    }

    {
        require MooseX::WithCache::KeyGenerator::DumpChecksum;
        $object->cache_key_generator(
            MooseX::WithCache::KeyGenerator::DumpChecksum->new
        );
        my $value = time();
        my $key   = [ qw(1 2 3), { foo => 'bar' } ];
        lives_ok { $object->cache_del($key) }
            "delete key '$key' first to make sure";
        lives_ok { $object->cache_set($key => $value) }
            "set value '$key' to '$value'";
        lives_and { 
            my $v = $object->cache_get($key);
            is($v, $value, "value gotten from cache '$v' should match '$value'");
        } "get value '$key' to '$value' should live";
        lives_and { 
            my $v = $object->cache_get([ qw(1 2 3), { foo => 'bar' } ]);
            is($v, $value, "value gotten from cache '$v' should match '$value' (same structure, different object)");
        } "get value '$key' to '$value' should live (same structure, different key object)";

        lives_and {
            $object->cache_disabled(1);
            ok( ! $object->cache_get($key), "cache disabled, fetch should fail" );
            $object->cache_set($key, "foo");
            ok( ! $object->cache_get($key), "cache disabled, fetch should fail (even if cache_set was called)" );
            $object->cache_set($key, "foo");
            ok( ! $object->cache_get($key), "cache disabled, fetch should fail (even if cache_set was called)" );

            $object->cache_set($key, "foo");
            $object->cache_disabled(0);
            is($object->cache_get($key), $value, "cache wasn't changed while it was disabled");

        } "no errors while testing cache disable";
        $object->cache_disabled(0);

        lives_ok { $object->cache_del($key) }
            "delete key '$key' to purge";
    }

    { # memcached specific
        my $value = time();
        my $key   = [ qw(incr decr test) ];

        $object->cache_set($key, $value);
        is( $object->cache_incr($key), $value + 1, "incr returns correct result");
        is( $object->cache_get($key), $value + 1, "effect of incr is saved" );
        is( $object->cache_decr($key), $value, "decr returns correct result");
        is( $object->cache_get($key), $value, "effect of decr is saved" );

        lives_and {
            $object->cache_disabled(1);

            ok( ! $object->cache_incr($key), "incr while cache disabled" );
            ok( ! $object->cache_decr($key), "decr while cache disabled" );
        } "no errors while testing cache disable";
        $object->cache_disabled(0);
        lives_ok { $object->cache_del($key) }
            "delete key '$key' to purge";
    }
}