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