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