t/004_w_cycles.t

   1 use strict;
   2 use warnings;
   3
   4 use Test::More tests => 18;
   5 use Test::Deep;
   6 use Test::Fatal;
   7
   8 BEGIN {
   9     use_ok('MooseX::Storage');
  10 }
  11
  12 # This test demonstrates two things:
  13 #
  14 # - cycles will not work in the default engine
  15 # - you can use a special metaclass to tell MooseX::Storage to skip an attribute
  16
  17 {
  18
  19     package Circular;
  20     use Moose;
  21     use MooseX::Storage;
  22
  23     with Storage;
  24
  25     has 'cycle' => (is => 'rw', isa => 'Circular');
  26 }
  27
  28 {
  29     my $circular = Circular->new;
  30     isa_ok($circular, 'Circular');
  31
  32     $circular->cycle($circular);
  33
  34     like(exception {
  35         $circular->pack;
  36     }, qr/^Basic Engine does not support cycles/,
  37     '... cannot collapse a cycle with the basic engine');
  38 }
  39
  40 {
  41     my $packed_circular = { __CLASS__ => 'Circular' };
  42     $packed_circular->{cycle} = $packed_circular;
  43
  44     like( exception {
  45         Circular->unpack($packed_circular);
  46     }, qr/^Basic Engine does not support cycles/,
  47     '... cannot expand a cycle with the basic engine');
  48 }
  49
  50 {
  51
  52     package Tree;
  53     use Moose;
  54     use MooseX::Storage;
  55
  56     with Storage;
  57
  58     has 'node' => (is => 'rw');
  59
  60     has 'children' => (
  61         is      => 'ro',
  62         isa     => 'ArrayRef',
  63         default => sub {[]}
  64     );
  65
  66     has 'parent' => (
  67         metaclass => 'DoNotSerialize',
  68         is        => 'rw',
  69         isa       => 'Tree',
  70     );
  71
  72     sub add_child {
  73         my ($self, $child) = @_;
  74         $child->parent($self);
  75         push @{$self->children} => $child;
  76     }
  77 }
  78
  79 {
  80     my $t = Tree->new(node => 100);
  81     isa_ok($t, 'Tree');
  82
  83     cmp_deeply(
  84         $t->pack,
  85         {
  86             __CLASS__ => 'Tree',
  87             node      => 100,
  88             children  => [],
  89         },
  90     '... got the right packed version');
  91
  92     my $t2 = Tree->new(node => 200);
  93     isa_ok($t2, 'Tree');
  94
  95     $t->add_child($t2);
  96
  97     cmp_deeply($t->children, [ $t2 ], '... got the right children in $t');
  98
  99     is($t2->parent, $t, '... created the cycle correctly');
 100     isa_ok($t2->parent, 'Tree');
 101
 102     cmp_deeply(
 103         $t->pack,
 104         {
 105             __CLASS__ => 'Tree',
 106             node      => 100,
 107             children  => [
 108                {
 109                    __CLASS__ => 'Tree',
 110                    node      => 200,
 111                    children  => [],
 112                }
 113             ],
 114         },
 115     '... got the right packed version (with parent attribute skipped in child)');
 116
 117     cmp_deeply(
 118         $t2->pack,
 119         {
 120             __CLASS__ => 'Tree',
 121             node      => 200,
 122             children  => [],
 123         },
 124     '... got the right packed version (with parent attribute skipped)');
 125 }
 126
 127 ### this fails with cycle detection on
 128 {   package Double;
 129     use Moose;
 130     use MooseX::Storage;
 131     with Storage;
 132
 133     has 'x' => ( is => 'rw', isa => 'HashRef' );
 134     has 'y' => ( is => 'rw', isa => 'HashRef' );
 135 }
 136
 137 {   my $ref = {};
 138
 139     my $double = Double->new( 'x' => $ref, 'y' => $ref );
 140
 141     ### currently, the cycle checker's too naive to figure out this is not
 142     ### a problem, pass an empty hashref to the 2nd test to make sure it
 143     ### doesn't warn/die
 144     TODO: {
 145         local $TODO = "Cycle check is too naive";
 146         my $pack = eval { $double->pack; };
 147         ok( $pack,              "Object with 2 references packed" );
 148         ok( Double->unpack( $pack || {} ),
 149                                 "   And unpacked again" );
 150     }
 151
 152     my $pack = $double->pack( engine_traits => [qw/DisableCycleDetection/] );
 153     ok( $pack,                  "   Object packs when cycle check is disabled");
 154     ok( Double->unpack( $pack ),
 155                                 "   And unpacked again" );
 156
 157 }
 158
 159 ### the same as above, but now done with a trait
 160 ### this fails with cycle detection on
 161 {   package DoubleNoCycle;
 162     use Moose;
 163     use MooseX::Storage;
 164     with Storage( traits => ['DisableCycleDetection'] );
 165
 166     has 'x' => ( is => 'rw', isa => 'HashRef' );
 167     has 'y' => ( is => 'rw', isa => 'HashRef' );
 168 }
 169
 170 {   my $ref = {};
 171
 172     my $double = DoubleNoCycle->new( 'x' => $ref, 'y' => $ref );
 173     my $pack = $double->pack;
 174     ok( $pack,              "Object packs with DisableCycleDetection trait");
 175     ok( DoubleNoCycle->unpack( $pack ),
 176                             "   Unpacked again" );
 177 }