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