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