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