t/004_w_cycles.t

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