X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F004_w_cycles.t;h=f7e60c1a8191c87730bbeca97c123f2e35737dac;hb=9566cef29cefd7e3571a8dc4c8fc75d88e395b2a;hp=92fc210c8c1eecd7b9a4dd6320276cfc8f6e567d;hpb=8d8356bb0a96c1c4e909b56c812b16fc82c7bbd2;p=gitmo%2FMooseX-Storage.git diff --git a/t/004_w_cycles.t b/t/004_w_cycles.t index 92fc210..f7e60c1 100644 --- a/t/004_w_cycles.t +++ b/t/004_w_cycles.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 12; +use Test::More tests => 18; use Test::Exception; BEGIN { @@ -130,4 +130,54 @@ This test demonstrates two things: '... got the right packed version (with parent attribute skipped)'); } +### this fails with cycle detection on +{ package Double; + use Moose; + use MooseX::Storage; + with Storage; + + has 'x' => ( is => 'rw', isa => 'HashRef' ); + has 'y' => ( is => 'rw', isa => 'HashRef' ); +} + +{ my $ref = {}; + + my $double = Double->new( 'x' => $ref, 'y' => $ref ); + + ### currently, the cycle checker's too naive to figure out this is not + ### a problem, pass an empty hashref to the 2nd test to make sure it + ### doesn't warn/die + TODO: { + local $TODO = "Cycle check is too naive"; + my $pack = eval { $double->pack; }; + ok( $pack, "Object with 2 references packed" ); + ok( Double->unpack( $pack || {} ), + " And unpacked again" ); + } + + my $pack = $double->pack( engine_traits => [qw/DisableCycleDetection/] ); + ok( $pack, " Object packs when cycle check is disabled"); + ok( Double->unpack( $pack ), + " And unpacked again" ); + +} + +### the same as above, but now done with a trait +### this fails with cycle detection on +{ package DoubleNoCycle; + use Moose; + use MooseX::Storage; + with Storage( traits => ['DisableCycleDetection'] ); + + has 'x' => ( is => 'rw', isa => 'HashRef' ); + has 'y' => ( is => 'rw', isa => 'HashRef' ); +} + +{ my $ref = {}; + my $double = DoubleNoCycle->new( 'x' => $ref, 'y' => $ref ); + my $pack = $double->pack; + ok( $pack, "Object packs with DisableCycleDetection trait"); + ok( DoubleNoCycle->unpack( $pack ), + " Unpacked again" ); +}