File Coverage

blib/lib/KiokuDB/Test/Fixture/CAS.pm

Criterion	Covered	Total	%
statement	57	63	90.4
branch	9	10	90.0
condition	0	2	0.0
subroutine	12	13	92.3
pod	0	2	0.0
total	78	90	86.6

#!/usr/bin/perl

package KiokuDB::Test::Fixture::CAS;
use Moose;

use Test::More;
use Scalar::Util qw(weaken);

use KiokuDB::Test::Digested;

use namespace::clean -except => 'meta';

with qw(KiokuDB::Test::Fixture);

sub create {
    my $self = shift;

    KiokuDB::Test::Digested->new(
        foo => "pizza",
    );
}

sub verify {
    my $self = shift;

    $self->no_live_objects;

    my $l = $self->directory->live_objects;

    my $cache = $l->cache;

    my $old_value = $l->leak_tracker;

    my $reset = Scope::Guard->new(sub {
        if ( $old_value ) {
            $l->leak_tracker($old_value);
        } else {
            $l->clear_leak_tracker;
        }
    });

    $l->leak_tracker(sub {
        my $i = $Test::Builder::Level || 1;
        $i++ until (caller($i))[1] eq __FILE__;
        local $Test::Builder::Level = $i + 2;
        fail("no leaks");
        diag("leaked @_"),
    });

    my $id = $self->populate_ids->[0];

    $self->txn_lives(sub {
        my $obj = $self->lookup_ok($id);

        is( $obj->digest, $id, "id is object digest" );

        is( $obj->foo, "pizza", "field retained" );
    });

    if ( $cache ) {
        isa_ok( my $cached = $cache->get($id), "KiokuDB::Test::Digested", "cached object" );
        $self->live_objects_are($cached);
        $cache->clear;
    }

    $self->no_live_objects();

    $self->txn_lives(sub {
        # test idempotent insertions
        $self->insert_ok( KiokuDB::Test::Digested->new( foo => "pizza" ) );
    });

    $cache->clear if $cache;
    $self->no_live_objects();

    $self->txn_lives(sub {
        my $obj = $self->lookup_ok($id);

        my $new_id = $self->insert_ok( $obj->clone );

        local $TODO = "ID not yet returned";
        is( $new_id, $id, "idempotent add when instance already live" );
    });

    $cache->clear if $cache;
    $self->no_live_objects();

    $self->txn_lives(sub {
        my $obj = $self->lookup_ok($id);

        my $new_id = $self->insert_ok( $obj->clone( bar => "blah" ) );

        ok( $new_id, "got a new ID" );
        isnt( $new_id, $id, "idempotent add when instance already live" );
    });

    if ( $cache ) {
        isa_ok( my $cached = $cache->get($id), "KiokuDB::Test::Digested", "cached object" );
        $self->live_objects_are($cached);
        $cache->clear;
    }

    $self->no_live_objects();
}

__PACKAGE__->meta->make_immutable;

__PACKAGE__

__END__