Commit | Line | Data |
0f24a39d |
1 | package SharedTests; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | use Scalar::Util qw( isweak ); |
54a288bd |
7 | use Test::More; |
8 | |
963254e0 |
9 | use vars qw($Lazy); |
0f24a39d |
10 | |
963254e0 |
11 | our %Attrs = ( |
12 | ObjectCount => { |
09f9282e |
13 | is => 'rw', |
14 | isa => 'Int', |
15 | default => 0, |
963254e0 |
16 | }, |
17 | WeakAttribute => { |
09f9282e |
18 | is => 'rw', |
19 | isa => 'Object', |
20 | weak_ref => 1, |
963254e0 |
21 | }, |
22 | LazyAttribute => { |
09f9282e |
23 | is => 'rw', |
24 | isa => 'Int', |
25 | lazy => 1, |
09f9282e |
26 | # The side effect is used to test that this was called |
27 | # lazily. |
28 | default => sub { $Lazy = 1 }, |
963254e0 |
29 | }, |
30 | ReadOnlyAttribute => { |
09f9282e |
31 | is => 'ro', |
32 | isa => 'Int', |
33 | default => 10, |
963254e0 |
34 | }, |
35 | ManyNames => { |
09f9282e |
36 | is => 'rw', |
37 | isa => 'Int', |
38 | reader => 'M', |
39 | writer => 'SetM', |
40 | clearer => 'ClearM', |
41 | predicate => 'HasM', |
963254e0 |
42 | }, |
43 | Delegatee => { |
09f9282e |
44 | is => 'rw', |
45 | isa => 'Delegatee', |
46 | handles => [ 'units', 'color' ], |
09f9282e |
47 | # if it's not lazy it makes a new object before we define |
48 | # Delegatee's attributes. |
49 | lazy => 1, |
50 | default => sub { Delegatee->new() }, |
963254e0 |
51 | }, |
52 | Mapping => { |
53 | traits => ['Hash'], |
54 | is => 'rw', |
55 | isa => 'HashRef[Str]', |
56 | default => sub { {} }, |
57 | handles => { |
58 | 'ExistsInMapping' => 'exists', |
59 | 'IdsInMapping' => 'keys', |
60 | 'GetMapping' => 'get', |
61 | 'SetMapping' => 'set', |
09f9282e |
62 | }, |
963254e0 |
63 | }, |
64 | Built => { |
09f9282e |
65 | is => 'ro', |
66 | builder => '_BuildIt', |
963254e0 |
67 | }, |
68 | LazyBuilt => { |
09f9282e |
69 | is => 'ro', |
70 | lazy => 1, |
71 | builder => '_BuildIt', |
963254e0 |
72 | }, |
73 | Triggerish => { |
09f9282e |
74 | is => 'rw', |
75 | trigger => sub { shift->_CallTrigger(@_) }, |
963254e0 |
76 | }, |
88b7f2c8 |
77 | TriggerRecord => { |
78 | is => 'ro', |
79 | default => sub { [] }, |
80 | }, |
963254e0 |
81 | ); |
82 | |
83 | { |
84 | package HasClassAttribute; |
85 | |
86 | use Moose qw( has ); |
87 | use MooseX::ClassAttribute; |
88 | |
89 | while ( my ( $name, $def ) = each %SharedTests::Attrs ) { |
90 | class_has $name => %{$def}; |
91 | } |
09f9282e |
92 | |
93 | has 'size' => ( |
94 | is => 'rw', |
95 | isa => 'Int', |
96 | default => 5, |
97 | ); |
0f24a39d |
98 | |
54a288bd |
99 | no Moose; |
54a288bd |
100 | |
09f9282e |
101 | sub BUILD { |
6b059c78 |
102 | my $self = shift; |
0f24a39d |
103 | |
6b059c78 |
104 | $self->ObjectCount( $self->ObjectCount() + 1 ); |
0f24a39d |
105 | } |
54a288bd |
106 | |
09f9282e |
107 | sub _BuildIt {42} |
6048a053 |
108 | |
09f9282e |
109 | sub _CallTrigger { |
88b7f2c8 |
110 | push @{ $_[0]->TriggerRecord() }, [@_]; |
8207dfe7 |
111 | } |
112 | |
09f9282e |
113 | sub make_immutable { |
54a288bd |
114 | my $class = shift; |
115 | |
116 | $class->meta()->make_immutable(); |
54a288bd |
117 | Delegatee->meta()->make_immutable(); |
118 | } |
119 | } |
120 | |
121 | { |
122 | package Delegatee; |
123 | |
124 | use Moose; |
125 | |
09f9282e |
126 | has 'units' => ( |
127 | is => 'ro', |
128 | default => 5, |
129 | ); |
54a288bd |
130 | |
09f9282e |
131 | has 'color' => ( |
132 | is => 'ro', |
133 | default => 'blue', |
134 | ); |
7a8e32bc |
135 | |
136 | no Moose; |
54a288bd |
137 | } |
138 | |
139 | { |
140 | package Child; |
141 | |
142 | use Moose; |
143 | use MooseX::ClassAttribute; |
144 | |
145 | extends 'HasClassAttribute'; |
146 | |
09f9282e |
147 | class_has '+ReadOnlyAttribute' => ( default => 30 ); |
7a8e32bc |
148 | |
09f9282e |
149 | class_has 'YetAnotherAttribute' => ( |
150 | is => 'ro', |
151 | default => 'thing', |
152 | ); |
7a4a3b1e |
153 | |
7a8e32bc |
154 | no Moose; |
0f24a39d |
155 | } |
156 | |
09f9282e |
157 | sub run_tests { |
88b7f2c8 |
158 | my $thing = shift || 'HasClassAttribute'; |
2840c8ab |
159 | |
0f24a39d |
160 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
161 | |
88b7f2c8 |
162 | $Lazy = 0; |
163 | |
164 | my $count = ref $thing ? 1 : 0; |
165 | |
0f24a39d |
166 | { |
09f9282e |
167 | is( |
88b7f2c8 |
168 | $thing->ObjectCount(), $count, |
09f9282e |
169 | 'ObjectCount() is 0' |
170 | ); |
0f24a39d |
171 | |
88b7f2c8 |
172 | unless ( ref $thing ) { |
173 | my $hca1 = $thing->new(); |
174 | is( |
175 | $hca1->size(), 5, |
176 | 'size is 5 - object attribute works as expected' |
177 | ); |
178 | is( |
179 | $thing->ObjectCount(), 1, |
180 | 'ObjectCount() is 1' |
181 | ); |
182 | |
183 | my $hca2 = $thing->new( size => 10 ); |
184 | is( |
185 | $hca2->size(), 10, |
186 | 'size is 10 - object attribute can be set via constructor' |
187 | ); |
188 | is( |
189 | $thing->ObjectCount(), 2, |
190 | 'ObjectCount() is 2' |
191 | ); |
192 | is( |
193 | $hca2->ObjectCount(), 2, |
194 | 'ObjectCount() is 2 - can call class attribute accessor on object' |
195 | ); |
196 | } |
0f24a39d |
197 | } |
198 | |
88b7f2c8 |
199 | unless ( ref $thing ) { |
200 | my $hca3 = $thing->new( ObjectCount => 20 ); |
09f9282e |
201 | is( |
202 | $hca3->ObjectCount(), 3, |
203 | 'class attributes passed to the constructor do not get set in the object' |
204 | ); |
205 | is( |
88b7f2c8 |
206 | $thing->ObjectCount(), 3, |
09f9282e |
207 | 'class attributes are not affected by constructor params' |
208 | ); |
0f24a39d |
209 | } |
210 | |
211 | { |
212 | my $object = bless {}, 'Thing'; |
213 | |
88b7f2c8 |
214 | $thing->WeakAttribute($object); |
0f24a39d |
215 | |
6b059c78 |
216 | undef $object; |
217 | |
09f9282e |
218 | ok( |
88b7f2c8 |
219 | !defined $thing->WeakAttribute(), |
09f9282e |
220 | 'weak class attributes are weak' |
221 | ); |
0f24a39d |
222 | } |
54a288bd |
223 | |
224 | { |
09f9282e |
225 | is( |
963254e0 |
226 | $SharedTests::Lazy, 0, |
227 | '$SharedTests::Lazy is 0' |
09f9282e |
228 | ); |
54a288bd |
229 | |
09f9282e |
230 | is( |
88b7f2c8 |
231 | $thing->LazyAttribute(), 1, |
232 | '$thing->LazyAttribute() is 1' |
09f9282e |
233 | ); |
54a288bd |
234 | |
09f9282e |
235 | is( |
963254e0 |
236 | $SharedTests::Lazy, 1, |
237 | '$SharedTests::Lazy is 1 after calling LazyAttribute' |
09f9282e |
238 | ); |
54a288bd |
239 | } |
240 | |
241 | { |
88b7f2c8 |
242 | eval { $thing->ReadOnlyAttribute(20) }; |
09f9282e |
243 | like( |
244 | $@, qr/\QCannot assign a value to a read-only accessor/, |
245 | 'cannot set read-only class attribute' |
246 | ); |
54a288bd |
247 | } |
248 | |
249 | { |
09f9282e |
250 | is( |
251 | Child->ReadOnlyAttribute(), 30, |
252 | q{Child class can extend parent's class attribute} |
253 | ); |
54a288bd |
254 | } |
255 | |
256 | { |
09f9282e |
257 | ok( |
88b7f2c8 |
258 | !$thing->HasM(), |
09f9282e |
259 | 'HasM() returns false before M is set' |
260 | ); |
54a288bd |
261 | |
88b7f2c8 |
262 | $thing->SetM(22); |
54a288bd |
263 | |
09f9282e |
264 | ok( |
88b7f2c8 |
265 | $thing->HasM(), |
09f9282e |
266 | 'HasM() returns true after M is set' |
267 | ); |
268 | is( |
88b7f2c8 |
269 | $thing->M(), 22, |
09f9282e |
270 | 'M() returns 22' |
271 | ); |
54a288bd |
272 | |
88b7f2c8 |
273 | $thing->ClearM(); |
54a288bd |
274 | |
09f9282e |
275 | ok( |
88b7f2c8 |
276 | !$thing->HasM(), |
09f9282e |
277 | 'HasM() returns false after M is cleared' |
278 | ); |
54a288bd |
279 | } |
280 | |
281 | { |
09f9282e |
282 | isa_ok( |
88b7f2c8 |
283 | $thing->Delegatee(), 'Delegatee', |
09f9282e |
284 | 'has a Delegetee object' |
285 | ); |
286 | is( |
88b7f2c8 |
287 | $thing->units(), 5, |
09f9282e |
288 | 'units() delegates to Delegatee and returns 5' |
289 | ); |
54a288bd |
290 | } |
291 | |
54a288bd |
292 | { |
88b7f2c8 |
293 | my @ids = $thing->IdsInMapping(); |
09f9282e |
294 | is( |
295 | scalar @ids, 0, |
296 | 'there are no keys in the mapping yet' |
297 | ); |
54a288bd |
298 | |
09f9282e |
299 | ok( |
88b7f2c8 |
300 | !$thing->ExistsInMapping('a'), |
09f9282e |
301 | 'key does not exist in mapping' |
302 | ); |
54a288bd |
303 | |
88b7f2c8 |
304 | $thing->SetMapping( a => 20 ); |
54a288bd |
305 | |
09f9282e |
306 | ok( |
88b7f2c8 |
307 | $thing->ExistsInMapping('a'), |
09f9282e |
308 | 'key does exist in mapping' |
309 | ); |
54a288bd |
310 | |
09f9282e |
311 | is( |
88b7f2c8 |
312 | $thing->GetMapping('a'), 20, |
09f9282e |
313 | 'value for a in mapping is 20' |
314 | ); |
54a288bd |
315 | } |
6048a053 |
316 | |
317 | { |
09f9282e |
318 | is( |
88b7f2c8 |
319 | $thing->Built(), 42, |
09f9282e |
320 | 'attribute with builder works' |
321 | ); |
6048a053 |
322 | |
09f9282e |
323 | is( |
88b7f2c8 |
324 | $thing->LazyBuilt(), 42, |
09f9282e |
325 | 'attribute with lazy builder works' |
326 | ); |
6048a053 |
327 | } |
8207dfe7 |
328 | |
329 | { |
88b7f2c8 |
330 | $thing->Triggerish(42); |
8207dfe7 |
331 | |
88b7f2c8 |
332 | is( scalar @{ $thing->TriggerRecord() }, 1, 'trigger was called' ); |
333 | is( $thing->Triggerish(), 42, 'Triggerish is now 42' ); |
334 | |
335 | $thing->Triggerish(84); |
336 | is( $thing->Triggerish(), 84, 'Triggerish is now 84' ); |
8207dfe7 |
337 | |
09f9282e |
338 | is_deeply( |
88b7f2c8 |
339 | $thing->TriggerRecord(), |
09f9282e |
340 | [ |
88b7f2c8 |
341 | [ $thing, qw( 42 ) ], |
342 | [ $thing, qw( 84 42 ) ], |
09f9282e |
343 | ], |
344 | 'trigger passes old value correctly' |
345 | ); |
8207dfe7 |
346 | } |
0f24a39d |
347 | } |
348 | |
0f24a39d |
349 | 1; |