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