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