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