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