Commit | Line | Data |
7eb5dc63 |
1 | use strict; |
2 | use warnings; |
3 | |
1e1598d0 |
4 | use Test::More tests => 18; |
619ab942 |
5 | use Test::Deep; |
9d3c60f5 |
6 | use Test::Fatal; |
7eb5dc63 |
7 | |
8 | BEGIN { |
9 | use_ok('MooseX::Storage'); |
10 | } |
11 | |
719eb53b |
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 |
b430caa3 |
16 | |
7eb5dc63 |
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'); |
c2dae5d8 |
31 | |
7eb5dc63 |
32 | $circular->cycle($circular); |
c2dae5d8 |
33 | |
9d3c60f5 |
34 | like(exception { |
7eb5dc63 |
35 | $circular->pack; |
9d3c60f5 |
36 | }, qr/^Basic Engine does not support cycles/, |
37 | '... cannot collapse a cycle with the basic engine'); |
7eb5dc63 |
38 | } |
39 | |
40 | { |
41 | my $packed_circular = { __CLASS__ => 'Circular' }; |
42 | $packed_circular->{cycle} = $packed_circular; |
43 | |
9d3c60f5 |
44 | like( exception { |
7eb5dc63 |
45 | Circular->unpack($packed_circular); |
9d3c60f5 |
46 | }, qr/^Basic Engine does not support cycles/, |
47 | '... cannot expand a cycle with the basic engine'); |
7eb5dc63 |
48 | } |
49 | |
b430caa3 |
50 | { |
51 | |
52 | package Tree; |
53 | use Moose; |
54 | use MooseX::Storage; |
55 | |
56 | with Storage; |
57 | |
58 | has 'node' => (is => 'rw'); |
c2dae5d8 |
59 | |
b430caa3 |
60 | has 'children' => ( |
c2dae5d8 |
61 | is => 'ro', |
62 | isa => 'ArrayRef', |
b430caa3 |
63 | default => sub {[]} |
64 | ); |
c2dae5d8 |
65 | |
b430caa3 |
66 | has 'parent' => ( |
eebcb6dc |
67 | metaclass => 'DoNotSerialize', |
c2dae5d8 |
68 | is => 'rw', |
b430caa3 |
69 | isa => 'Tree', |
70 | ); |
c2dae5d8 |
71 | |
b430caa3 |
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'); |
c2dae5d8 |
82 | |
619ab942 |
83 | cmp_deeply( |
c2dae5d8 |
84 | $t->pack, |
b430caa3 |
85 | { |
86 | __CLASS__ => 'Tree', |
87 | node => 100, |
88 | children => [], |
89 | }, |
90 | '... got the right packed version'); |
c2dae5d8 |
91 | |
b430caa3 |
92 | my $t2 = Tree->new(node => 200); |
c2dae5d8 |
93 | isa_ok($t2, 'Tree'); |
94 | |
b430caa3 |
95 | $t->add_child($t2); |
c2dae5d8 |
96 | |
619ab942 |
97 | cmp_deeply($t->children, [ $t2 ], '... got the right children in $t'); |
c2dae5d8 |
98 | |
b430caa3 |
99 | is($t2->parent, $t, '... created the cycle correctly'); |
c2dae5d8 |
100 | isa_ok($t2->parent, 'Tree'); |
101 | |
619ab942 |
102 | cmp_deeply( |
c2dae5d8 |
103 | $t->pack, |
b430caa3 |
104 | { |
105 | __CLASS__ => 'Tree', |
106 | node => 100, |
107 | children => [ |
108 | { |
109 | __CLASS__ => 'Tree', |
110 | node => 200, |
c2dae5d8 |
111 | children => [], |
112 | } |
b430caa3 |
113 | ], |
114 | }, |
c2dae5d8 |
115 | '... got the right packed version (with parent attribute skipped in child)'); |
116 | |
619ab942 |
117 | cmp_deeply( |
c2dae5d8 |
118 | $t2->pack, |
b430caa3 |
119 | { |
120 | __CLASS__ => 'Tree', |
121 | node => 200, |
c2dae5d8 |
122 | children => [], |
b430caa3 |
123 | }, |
124 | '... got the right packed version (with parent attribute skipped)'); |
125 | } |
7eb5dc63 |
126 | |
5b7ea1fd |
127 | ### this fails with cycle detection on |
128 | { package Double; |
129 | use Moose; |
130 | use MooseX::Storage; |
131 | with Storage; |
c2dae5d8 |
132 | |
5b7ea1fd |
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 |
1e1598d0 |
142 | ### a problem, pass an empty hashref to the 2nd test to make sure it |
143 | ### doesn't warn/die |
5b7ea1fd |
144 | TODO: { |
145 | local $TODO = "Cycle check is too naive"; |
146 | my $pack = eval { $double->pack; }; |
147 | ok( $pack, "Object with 2 references packed" ); |
1e1598d0 |
148 | ok( Double->unpack( $pack || {} ), |
5b7ea1fd |
149 | " And unpacked again" ); |
150 | } |
c2dae5d8 |
151 | |
3513de05 |
152 | my $pack = $double->pack( engine_traits => [qw/DisableCycleDetection/] ); |
5b7ea1fd |
153 | ok( $pack, " Object packs when cycle check is disabled"); |
154 | ok( Double->unpack( $pack ), |
155 | " And unpacked again" ); |
156 | |
c2dae5d8 |
157 | } |
5b7ea1fd |
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'] ); |
c2dae5d8 |
165 | |
5b7ea1fd |
166 | has 'x' => ( is => 'rw', isa => 'HashRef' ); |
167 | has 'y' => ( is => 'rw', isa => 'HashRef' ); |
168 | } |
169 | |
170 | { my $ref = {}; |
7eb5dc63 |
171 | |
5b7ea1fd |
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" ); |
c2dae5d8 |
177 | } |