#!/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__