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 | |
b430caa3 |
12 | =pod |
13 | |
14 | This test demonstrates two things: |
15 | |
16 | - cycles will not work in the default engine |
c2dae5d8 |
17 | - you can use a special metaclass to tell |
b430caa3 |
18 | MooseX::Storage to skip an attribute |
19 | |
20 | =cut |
21 | |
7eb5dc63 |
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'); |
c2dae5d8 |
36 | |
7eb5dc63 |
37 | $circular->cycle($circular); |
c2dae5d8 |
38 | |
9d3c60f5 |
39 | like(exception { |
7eb5dc63 |
40 | $circular->pack; |
9d3c60f5 |
41 | }, qr/^Basic Engine does not support cycles/, |
42 | '... cannot collapse a cycle with the basic engine'); |
7eb5dc63 |
43 | } |
44 | |
45 | { |
46 | my $packed_circular = { __CLASS__ => 'Circular' }; |
47 | $packed_circular->{cycle} = $packed_circular; |
48 | |
9d3c60f5 |
49 | like( exception { |
7eb5dc63 |
50 | Circular->unpack($packed_circular); |
9d3c60f5 |
51 | }, qr/^Basic Engine does not support cycles/, |
52 | '... cannot expand a cycle with the basic engine'); |
7eb5dc63 |
53 | } |
54 | |
b430caa3 |
55 | { |
56 | |
57 | package Tree; |
58 | use Moose; |
59 | use MooseX::Storage; |
60 | |
61 | with Storage; |
62 | |
63 | has 'node' => (is => 'rw'); |
c2dae5d8 |
64 | |
b430caa3 |
65 | has 'children' => ( |
c2dae5d8 |
66 | is => 'ro', |
67 | isa => 'ArrayRef', |
b430caa3 |
68 | default => sub {[]} |
69 | ); |
c2dae5d8 |
70 | |
b430caa3 |
71 | has 'parent' => ( |
eebcb6dc |
72 | metaclass => 'DoNotSerialize', |
c2dae5d8 |
73 | is => 'rw', |
b430caa3 |
74 | isa => 'Tree', |
75 | ); |
c2dae5d8 |
76 | |
b430caa3 |
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'); |
c2dae5d8 |
87 | |
619ab942 |
88 | cmp_deeply( |
c2dae5d8 |
89 | $t->pack, |
b430caa3 |
90 | { |
91 | __CLASS__ => 'Tree', |
92 | node => 100, |
93 | children => [], |
94 | }, |
95 | '... got the right packed version'); |
c2dae5d8 |
96 | |
b430caa3 |
97 | my $t2 = Tree->new(node => 200); |
c2dae5d8 |
98 | isa_ok($t2, 'Tree'); |
99 | |
b430caa3 |
100 | $t->add_child($t2); |
c2dae5d8 |
101 | |
619ab942 |
102 | cmp_deeply($t->children, [ $t2 ], '... got the right children in $t'); |
c2dae5d8 |
103 | |
b430caa3 |
104 | is($t2->parent, $t, '... created the cycle correctly'); |
c2dae5d8 |
105 | isa_ok($t2->parent, 'Tree'); |
106 | |
619ab942 |
107 | cmp_deeply( |
c2dae5d8 |
108 | $t->pack, |
b430caa3 |
109 | { |
110 | __CLASS__ => 'Tree', |
111 | node => 100, |
112 | children => [ |
113 | { |
114 | __CLASS__ => 'Tree', |
115 | node => 200, |
c2dae5d8 |
116 | children => [], |
117 | } |
b430caa3 |
118 | ], |
119 | }, |
c2dae5d8 |
120 | '... got the right packed version (with parent attribute skipped in child)'); |
121 | |
619ab942 |
122 | cmp_deeply( |
c2dae5d8 |
123 | $t2->pack, |
b430caa3 |
124 | { |
125 | __CLASS__ => 'Tree', |
126 | node => 200, |
c2dae5d8 |
127 | children => [], |
b430caa3 |
128 | }, |
129 | '... got the right packed version (with parent attribute skipped)'); |
130 | } |
7eb5dc63 |
131 | |
5b7ea1fd |
132 | ### this fails with cycle detection on |
133 | { package Double; |
134 | use Moose; |
135 | use MooseX::Storage; |
136 | with Storage; |
c2dae5d8 |
137 | |
5b7ea1fd |
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 |
1e1598d0 |
147 | ### a problem, pass an empty hashref to the 2nd test to make sure it |
148 | ### doesn't warn/die |
5b7ea1fd |
149 | TODO: { |
150 | local $TODO = "Cycle check is too naive"; |
151 | my $pack = eval { $double->pack; }; |
152 | ok( $pack, "Object with 2 references packed" ); |
1e1598d0 |
153 | ok( Double->unpack( $pack || {} ), |
5b7ea1fd |
154 | " And unpacked again" ); |
155 | } |
c2dae5d8 |
156 | |
3513de05 |
157 | my $pack = $double->pack( engine_traits => [qw/DisableCycleDetection/] ); |
5b7ea1fd |
158 | ok( $pack, " Object packs when cycle check is disabled"); |
159 | ok( Double->unpack( $pack ), |
160 | " And unpacked again" ); |
161 | |
c2dae5d8 |
162 | } |
5b7ea1fd |
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'] ); |
c2dae5d8 |
170 | |
5b7ea1fd |
171 | has 'x' => ( is => 'rw', isa => 'HashRef' ); |
172 | has 'y' => ( is => 'rw', isa => 'HashRef' ); |
173 | } |
174 | |
175 | { my $ref = {}; |
7eb5dc63 |
176 | |
5b7ea1fd |
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" ); |
c2dae5d8 |
182 | } |