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