X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F004_w_cycles.t;h=aa92ad76ac5f048a5d7f89efbd5cafc26a245d6d;hb=719eb53ba7c5dd5b68737c3e341fd42c8055fa73;hp=cca0e22b954c49fb0bc3a0fa933cd22168ff462a;hpb=eebcb6dc421f51c455af1dc6b8aa3bb0ffc6f148;p=gitmo%2FMooseX-Storage.git

diff --git a/t/004_w_cycles.t b/t/004_w_cycles.t
index cca0e22..aa92ad7 100644
--- a/t/004_w_cycles.t
+++ b/t/004_w_cycles.t
@@ -1,24 +1,18 @@
-#!/usr/bin/perl
-
 use strict;
 use warnings;
 
-use Test::More no_plan => 1;
-use Test::Exception;
+use Test::More tests => 18;
+use Test::Deep;
+use Test::Fatal;
 
 BEGIN {
     use_ok('MooseX::Storage');
 }
 
-=pod
-
-This test demonstrates two things:
-
-- cycles will not work in the default engine
-- you can use a special metaclass to tell 
-  MooseX::Storage to skip an attribute
-
-=cut
+# This test demonstrates two things:
+#
+# - cycles will not work in the default engine
+# - you can use a special metaclass to tell MooseX::Storage to skip an attribute
 
 {
 
@@ -34,23 +28,23 @@ This test demonstrates two things:
 {
     my $circular = Circular->new;
     isa_ok($circular, 'Circular');
-    
+
     $circular->cycle($circular);
-    
-    throws_ok {
+
+    like(exception {
         $circular->pack;
-    } qr/^Basic Engine does not support cycles/, 
-    '... cannot collapse a cycle with the basic engine';
+    }, qr/^Basic Engine does not support cycles/,
+    '... cannot collapse a cycle with the basic engine');
 }
 
 {
     my $packed_circular = { __CLASS__ => 'Circular' };
     $packed_circular->{cycle} = $packed_circular;
 
-    throws_ok {
+    like( exception {
         Circular->unpack($packed_circular);
-    } qr/^Basic Engine does not support cycles/, 
-    '... cannot expand a cycle with the basic engine';
+    }, qr/^Basic Engine does not support cycles/,
+    '... cannot expand a cycle with the basic engine');
 }
 
 {
@@ -62,19 +56,19 @@ This test demonstrates two things:
     with Storage;
 
     has 'node' => (is => 'rw');
-    
+
     has 'children' => (
-        is      => 'ro', 
-        isa     => 'ArrayRef', 
+        is      => 'ro',
+        isa     => 'ArrayRef',
         default => sub {[]}
     );
-    
+
     has 'parent' => (
         metaclass => 'DoNotSerialize',
-        is        => 'rw', 
+        is        => 'rw',
         isa       => 'Tree',
     );
-    
+
     sub add_child {
         my ($self, $child) = @_;
         $child->parent($self);
@@ -85,28 +79,28 @@ This test demonstrates two things:
 {
     my $t = Tree->new(node => 100);
     isa_ok($t, 'Tree');
-    
-    is_deeply(
-        $t->pack, 
+
+    cmp_deeply(
+        $t->pack,
         {
             __CLASS__ => 'Tree',
             node      => 100,
             children  => [],
         },
     '... got the right packed version');
-    
+
     my $t2 = Tree->new(node => 200);
-    isa_ok($t2, 'Tree');    
-    
+    isa_ok($t2, 'Tree');
+
     $t->add_child($t2);
-    
-    is_deeply($t->children, [ $t2 ], '... got the right children in $t');
-    
+
+    cmp_deeply($t->children, [ $t2 ], '... got the right children in $t');
+
     is($t2->parent, $t, '... created the cycle correctly');
-    isa_ok($t2->parent, 'Tree');        
-    
-    is_deeply(
-        $t->pack, 
+    isa_ok($t2->parent, 'Tree');
+
+    cmp_deeply(
+        $t->pack,
         {
             __CLASS__ => 'Tree',
             node      => 100,
@@ -114,20 +108,70 @@ This test demonstrates two things:
                {
                    __CLASS__ => 'Tree',
                    node      => 200,
-                   children  => [],            
-               } 
+                   children  => [],
+               }
             ],
         },
-    '... got the right packed version (with parent attribute skipped in child)');    
-    
-    is_deeply(
-        $t2->pack, 
+    '... got the right packed version (with parent attribute skipped in child)');
+
+    cmp_deeply(
+        $t2->pack,
         {
             __CLASS__ => 'Tree',
             node      => 200,
-            children  => [],            
+            children  => [],
         },
     '... 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" );
+}