Commit | Line | Data |
4060c871 |
1 | #!/usr/bin/perl |
c47cf415 |
2 | # This is automatically generated by author/import-moose-test.pl. |
3 | # DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!! |
4 | use t::lib::MooseCompat; |
4060c871 |
5 | |
6 | use strict; |
7 | use warnings; |
8 | |
c47cf415 |
9 | use Test::More; |
10 | $TODO = q{Mouse is not yet completed}; |
4060c871 |
11 | use Test::Exception; |
12 | |
13 | |
4060c871 |
14 | # ------------------------------------------------------------------- |
15 | # HASH handles |
16 | # ------------------------------------------------------------------- |
17 | # the canonical form of of the 'handles' |
18 | # option is the hash ref mapping a |
19 | # method name to the delegated method name |
20 | |
21 | { |
22 | package Foo; |
23 | use Mouse; |
24 | |
25 | has 'bar' => (is => 'rw', default => 10); |
26 | |
27 | sub baz { 42 } |
28 | |
29 | package Bar; |
30 | use Mouse; |
31 | |
32 | has 'foo' => ( |
33 | is => 'rw', |
34 | default => sub { Foo->new }, |
35 | handles => { |
36 | 'foo_bar' => 'bar', |
37 | foo_baz => 'baz', |
38 | 'foo_bar_to_20' => [ bar => 20 ], |
39 | }, |
40 | ); |
41 | } |
42 | |
43 | my $bar = Bar->new; |
44 | isa_ok($bar, 'Bar'); |
45 | |
46 | ok($bar->foo, '... we have something in bar->foo'); |
47 | isa_ok($bar->foo, 'Foo'); |
48 | |
49 | my $meth = Bar->meta->get_method('foo_bar'); |
c47cf415 |
50 | isa_ok($meth, 'Mouse::Meta::Method'); |
4060c871 |
51 | is($meth->associated_attribute->name, 'foo', |
52 | 'associated_attribute->name for this method is foo'); |
53 | |
54 | is($bar->foo->bar, 10, '... bar->foo->bar returned the right default'); |
55 | |
56 | can_ok($bar, 'foo_bar'); |
57 | is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly'); |
58 | |
59 | # change the value ... |
60 | |
61 | $bar->foo->bar(30); |
62 | |
63 | # and make sure the delegation picks it up |
64 | |
65 | is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value'); |
66 | is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly'); |
67 | |
68 | # change the value through the delegation ... |
69 | |
70 | $bar->foo_bar(50); |
71 | |
72 | # and make sure everyone sees it |
73 | |
74 | is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value'); |
75 | is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly'); |
76 | |
77 | # change the object we are delegating too |
78 | |
79 | my $foo = Foo->new(bar => 25); |
80 | isa_ok($foo, 'Foo'); |
81 | |
82 | is($foo->bar, 25, '... got the right foo->bar'); |
83 | |
84 | lives_ok { |
85 | $bar->foo($foo); |
86 | } '... assigned the new Foo to Bar->foo'; |
87 | |
88 | is($bar->foo, $foo, '... assigned bar->foo with the new Foo'); |
89 | |
90 | is($bar->foo->bar, 25, '... bar->foo->bar returned the right result'); |
91 | is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again'); |
92 | |
93 | # curried handles |
94 | $bar->foo_bar_to_20; |
95 | is($bar->foo_bar, 20, '... correctly curried a single argument'); |
96 | |
97 | # ------------------------------------------------------------------- |
98 | # ARRAY handles |
99 | # ------------------------------------------------------------------- |
100 | # we also support an array based format |
101 | # which assumes that the name is the same |
102 | # on either end |
103 | |
104 | { |
105 | package Engine; |
106 | use Mouse; |
107 | |
108 | sub go { 'Engine::go' } |
109 | sub stop { 'Engine::stop' } |
110 | |
111 | package Car; |
112 | use Mouse; |
113 | |
114 | has 'engine' => ( |
115 | is => 'rw', |
116 | default => sub { Engine->new }, |
117 | handles => [ 'go', 'stop' ] |
118 | ); |
119 | } |
120 | |
121 | my $car = Car->new; |
122 | isa_ok($car, 'Car'); |
123 | |
124 | isa_ok($car->engine, 'Engine'); |
125 | can_ok($car->engine, 'go'); |
126 | can_ok($car->engine, 'stop'); |
127 | |
128 | is($car->engine->go, 'Engine::go', '... got the right value from ->engine->go'); |
129 | is($car->engine->stop, 'Engine::stop', '... got the right value from ->engine->stop'); |
130 | |
131 | can_ok($car, 'go'); |
132 | can_ok($car, 'stop'); |
133 | |
134 | is($car->go, 'Engine::go', '... got the right value from ->go'); |
135 | is($car->stop, 'Engine::stop', '... got the right value from ->stop'); |
136 | |
137 | # ------------------------------------------------------------------- |
138 | # REGEXP handles |
139 | # ------------------------------------------------------------------- |
140 | # and we support regexp delegation |
141 | |
142 | { |
143 | package Baz; |
144 | use Mouse; |
145 | |
146 | sub foo { 'Baz::foo' } |
147 | sub bar { 'Baz::bar' } |
148 | sub boo { 'Baz::boo' } |
149 | |
150 | package Baz::Proxy1; |
151 | use Mouse; |
152 | |
153 | has 'baz' => ( |
154 | is => 'ro', |
155 | isa => 'Baz', |
156 | default => sub { Baz->new }, |
157 | handles => qr/.*/ |
158 | ); |
159 | |
160 | package Baz::Proxy2; |
161 | use Mouse; |
162 | |
163 | has 'baz' => ( |
164 | is => 'ro', |
165 | isa => 'Baz', |
166 | default => sub { Baz->new }, |
167 | handles => qr/.oo/ |
168 | ); |
169 | |
170 | package Baz::Proxy3; |
171 | use Mouse; |
172 | |
173 | has 'baz' => ( |
174 | is => 'ro', |
175 | isa => 'Baz', |
176 | default => sub { Baz->new }, |
177 | handles => qr/b.*/ |
178 | ); |
179 | } |
180 | |
181 | { |
182 | my $baz_proxy = Baz::Proxy1->new; |
183 | isa_ok($baz_proxy, 'Baz::Proxy1'); |
184 | |
185 | can_ok($baz_proxy, 'baz'); |
186 | isa_ok($baz_proxy->baz, 'Baz'); |
187 | |
188 | can_ok($baz_proxy, 'foo'); |
189 | can_ok($baz_proxy, 'bar'); |
190 | can_ok($baz_proxy, 'boo'); |
191 | |
192 | is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value'); |
193 | is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value'); |
194 | is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value'); |
195 | } |
196 | { |
197 | my $baz_proxy = Baz::Proxy2->new; |
198 | isa_ok($baz_proxy, 'Baz::Proxy2'); |
199 | |
200 | can_ok($baz_proxy, 'baz'); |
201 | isa_ok($baz_proxy->baz, 'Baz'); |
202 | |
203 | can_ok($baz_proxy, 'foo'); |
204 | can_ok($baz_proxy, 'boo'); |
205 | |
206 | is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value'); |
207 | is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value'); |
208 | } |
209 | { |
210 | my $baz_proxy = Baz::Proxy3->new; |
211 | isa_ok($baz_proxy, 'Baz::Proxy3'); |
212 | |
213 | can_ok($baz_proxy, 'baz'); |
214 | isa_ok($baz_proxy->baz, 'Baz'); |
215 | |
216 | can_ok($baz_proxy, 'bar'); |
217 | can_ok($baz_proxy, 'boo'); |
218 | |
219 | is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value'); |
220 | is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value'); |
221 | } |
222 | |
223 | # ------------------------------------------------------------------- |
224 | # ROLE handles |
225 | # ------------------------------------------------------------------- |
226 | |
227 | { |
228 | package Foo::Bar; |
229 | use Mouse::Role; |
230 | |
231 | requires 'foo'; |
232 | requires 'bar'; |
233 | |
234 | package Foo::Baz; |
235 | use Mouse; |
236 | |
237 | sub foo { 'Foo::Baz::FOO' } |
238 | sub bar { 'Foo::Baz::BAR' } |
239 | sub baz { 'Foo::Baz::BAZ' } |
240 | |
241 | package Foo::Thing; |
242 | use Mouse; |
243 | |
244 | has 'thing' => ( |
245 | is => 'rw', |
246 | isa => 'Foo::Baz', |
247 | handles => 'Foo::Bar', |
248 | ); |
249 | |
c47cf415 |
250 | package Foo::OtherThing; |
251 | use Mouse; |
252 | use Mouse::Util::TypeConstraints; |
253 | |
254 | has 'other_thing' => ( |
255 | is => 'rw', |
256 | isa => 'Foo::Baz', |
257 | handles => Mouse::Util::TypeConstraints::find_type_constraint('Foo::Bar'), |
258 | ); |
4060c871 |
259 | } |
260 | |
261 | { |
262 | my $foo = Foo::Thing->new(thing => Foo::Baz->new); |
263 | isa_ok($foo, 'Foo::Thing'); |
264 | isa_ok($foo->thing, 'Foo::Baz'); |
265 | |
266 | ok($foo->meta->has_method('foo'), '... we have the method we expect'); |
267 | ok($foo->meta->has_method('bar'), '... we have the method we expect'); |
268 | ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect'); |
269 | |
270 | is($foo->foo, 'Foo::Baz::FOO', '... got the right value'); |
271 | is($foo->bar, 'Foo::Baz::BAR', '... got the right value'); |
272 | is($foo->thing->baz, 'Foo::Baz::BAZ', '... got the right value'); |
273 | } |
274 | |
c47cf415 |
275 | { |
276 | my $foo = Foo::OtherThing->new(other_thing => Foo::Baz->new); |
277 | isa_ok($foo, 'Foo::OtherThing'); |
278 | isa_ok($foo->other_thing, 'Foo::Baz'); |
279 | |
280 | ok($foo->meta->has_method('foo'), '... we have the method we expect'); |
281 | ok($foo->meta->has_method('bar'), '... we have the method we expect'); |
282 | ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect'); |
283 | |
284 | is($foo->foo, 'Foo::Baz::FOO', '... got the right value'); |
285 | is($foo->bar, 'Foo::Baz::BAR', '... got the right value'); |
286 | is($foo->other_thing->baz, 'Foo::Baz::BAZ', '... got the right value'); |
287 | } |
4060c871 |
288 | # ------------------------------------------------------------------- |
289 | # AUTOLOAD & handles |
290 | # ------------------------------------------------------------------- |
291 | |
292 | { |
293 | package Foo::Autoloaded; |
294 | use Mouse; |
295 | |
296 | sub AUTOLOAD { |
297 | my $self = shift; |
298 | |
299 | my $name = our $AUTOLOAD; |
300 | $name =~ s/.*://; # strip fully-qualified portion |
301 | |
302 | if (@_) { |
303 | return $self->{$name} = shift; |
304 | } else { |
305 | return $self->{$name}; |
306 | } |
307 | } |
308 | |
309 | package Bar::Autoloaded; |
310 | use Mouse; |
311 | |
312 | has 'foo' => ( |
313 | is => 'rw', |
314 | default => sub { Foo::Autoloaded->new }, |
315 | handles => { 'foo_bar' => 'bar' } |
316 | ); |
317 | |
318 | package Baz::Autoloaded; |
319 | use Mouse; |
320 | |
321 | has 'foo' => ( |
322 | is => 'rw', |
323 | default => sub { Foo::Autoloaded->new }, |
324 | handles => ['bar'] |
325 | ); |
326 | |
327 | package Goorch::Autoloaded; |
328 | use Mouse; |
329 | |
330 | ::dies_ok { |
331 | has 'foo' => ( |
332 | is => 'rw', |
333 | default => sub { Foo::Autoloaded->new }, |
334 | handles => qr/bar/ |
335 | ); |
336 | } '... you cannot delegate to AUTOLOADED class with regexp'; |
337 | } |
338 | |
339 | # check HASH based delegation w/ AUTOLOAD |
340 | |
341 | { |
342 | my $bar = Bar::Autoloaded->new; |
343 | isa_ok($bar, 'Bar::Autoloaded'); |
344 | |
345 | ok($bar->foo, '... we have something in bar->foo'); |
346 | isa_ok($bar->foo, 'Foo::Autoloaded'); |
347 | |
348 | # change the value ... |
349 | |
350 | $bar->foo->bar(30); |
351 | |
352 | # and make sure the delegation picks it up |
353 | |
354 | is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value'); |
355 | is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly'); |
356 | |
357 | # change the value through the delegation ... |
358 | |
359 | $bar->foo_bar(50); |
360 | |
361 | # and make sure everyone sees it |
362 | |
363 | is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value'); |
364 | is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly'); |
365 | |
366 | # change the object we are delegating too |
367 | |
368 | my $foo = Foo::Autoloaded->new; |
369 | isa_ok($foo, 'Foo::Autoloaded'); |
370 | |
371 | $foo->bar(25); |
372 | |
373 | is($foo->bar, 25, '... got the right foo->bar'); |
374 | |
375 | lives_ok { |
376 | $bar->foo($foo); |
377 | } '... assigned the new Foo to Bar->foo'; |
378 | |
379 | is($bar->foo, $foo, '... assigned bar->foo with the new Foo'); |
380 | |
381 | is($bar->foo->bar, 25, '... bar->foo->bar returned the right result'); |
382 | is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again'); |
383 | } |
384 | |
385 | # check ARRAY based delegation w/ AUTOLOAD |
386 | |
387 | { |
388 | my $baz = Baz::Autoloaded->new; |
389 | isa_ok($baz, 'Baz::Autoloaded'); |
390 | |
391 | ok($baz->foo, '... we have something in baz->foo'); |
392 | isa_ok($baz->foo, 'Foo::Autoloaded'); |
393 | |
394 | # change the value ... |
395 | |
396 | $baz->foo->bar(30); |
397 | |
398 | # and make sure the delegation picks it up |
399 | |
400 | is($baz->foo->bar, 30, '... baz->foo->bar returned the right (changed) value'); |
401 | is($baz->bar, 30, '... baz->foo_bar delegated correctly'); |
402 | |
403 | # change the value through the delegation ... |
404 | |
405 | $baz->bar(50); |
406 | |
407 | # and make sure everyone sees it |
408 | |
409 | is($baz->foo->bar, 50, '... baz->foo->bar returned the right (changed) value'); |
410 | is($baz->bar, 50, '... baz->foo_bar delegated correctly'); |
411 | |
412 | # change the object we are delegating too |
413 | |
414 | my $foo = Foo::Autoloaded->new; |
415 | isa_ok($foo, 'Foo::Autoloaded'); |
416 | |
417 | $foo->bar(25); |
418 | |
419 | is($foo->bar, 25, '... got the right foo->bar'); |
420 | |
421 | lives_ok { |
422 | $baz->foo($foo); |
423 | } '... assigned the new Foo to Baz->foo'; |
424 | |
425 | is($baz->foo, $foo, '... assigned baz->foo with the new Foo'); |
426 | |
427 | is($baz->foo->bar, 25, '... baz->foo->bar returned the right result'); |
428 | is($baz->bar, 25, '... and baz->foo_bar delegated correctly again'); |
429 | } |
430 | |
431 | # Check that removing attributes removes their handles methods also. |
432 | { |
433 | { |
434 | package Quux; |
435 | use Mouse; |
436 | has foo => ( |
437 | isa => 'Foo', |
438 | default => sub { Foo->new }, |
439 | handles => { 'foo_bar' => 'bar' } |
440 | ); |
441 | } |
442 | my $i = Quux->new; |
443 | ok($i->meta->has_method('foo_bar'), 'handles method foo_bar is present'); |
444 | $i->meta->remove_attribute('foo'); |
445 | ok(!$i->meta->has_method('foo_bar'), 'handles method foo_bar is removed'); |
446 | } |
447 | |
448 | # Make sure that a useful error message is thrown when the delegation target is |
449 | # not an object |
450 | { |
451 | my $i = Bar->new(foo => undef); |
452 | throws_ok { $i->foo_bar } qr/is not defined/, |
453 | 'useful error from unblessed reference'; |
454 | |
455 | my $j = Bar->new(foo => []); |
456 | throws_ok { $j->foo_bar } qr/is not an object \(got 'ARRAY/, |
457 | 'useful error from unblessed reference'; |
458 | |
459 | my $k = Bar->new(foo => "Foo"); |
460 | lives_ok { $k->foo_baz } "but not for class name"; |
461 | } |
c47cf415 |
462 | |
463 | done_testing; |