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