6 use Test::More tests => 86;
11 # -------------------------------------------------------------------
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
22 has 'bar' => (is => 'rw', default => 10);
29 default => sub { Foo->new },
30 handles => { 'foo_bar' => 'bar' }
37 ok($bar->foo, '... we have something in bar->foo');
38 isa_ok($bar->foo, 'Foo');
40 my $meth = Bar->meta->get_method('foo_bar');
41 isa_ok($meth, 'Moose::Meta::Method::Delegation');
42 is($meth->associated_attribute->name, 'foo',
43 'associated_attribute->name for this method is foo');
45 is($bar->foo->bar, 10, '... bar->foo->bar returned the right default');
47 can_ok($bar, 'foo_bar');
48 is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly');
50 # change the value ...
54 # and make sure the delegation picks it up
56 is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
57 is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
59 # change the value through the delegation ...
63 # and make sure everyone sees it
65 is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
66 is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
68 # change the object we are delegating too
70 my $foo = Foo->new(bar => 25);
73 is($foo->bar, 25, '... got the right foo->bar');
77 } '... assigned the new Foo to Bar->foo';
79 is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
81 is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
82 is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
84 # -------------------------------------------------------------------
86 # -------------------------------------------------------------------
87 # we also support an array based format
88 # which assumes that the name is the same
95 sub go { 'Engine::go' }
96 sub stop { 'Engine::stop' }
103 default => sub { Engine->new },
104 handles => [ 'go', 'stop' ]
111 isa_ok($car->engine, 'Engine');
112 can_ok($car->engine, 'go');
113 can_ok($car->engine, 'stop');
115 is($car->engine->go, 'Engine::go', '... got the right value from ->engine->go');
116 is($car->engine->stop, 'Engine::stop', '... got the right value from ->engine->stop');
119 can_ok($car, 'stop');
121 is($car->go, 'Engine::go', '... got the right value from ->go');
122 is($car->stop, 'Engine::stop', '... got the right value from ->stop');
124 # -------------------------------------------------------------------
126 # -------------------------------------------------------------------
127 # and we support regexp delegation
133 sub foo { 'Baz::foo' }
134 sub bar { 'Baz::bar' }
135 sub boo { 'Baz::boo' }
143 default => sub { Baz->new },
153 default => sub { Baz->new },
163 default => sub { Baz->new },
169 my $baz_proxy = Baz::Proxy1->new;
170 isa_ok($baz_proxy, 'Baz::Proxy1');
172 can_ok($baz_proxy, 'baz');
173 isa_ok($baz_proxy->baz, 'Baz');
175 can_ok($baz_proxy, 'foo');
176 can_ok($baz_proxy, 'bar');
177 can_ok($baz_proxy, 'boo');
179 is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value');
180 is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
181 is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
184 my $baz_proxy = Baz::Proxy2->new;
185 isa_ok($baz_proxy, 'Baz::Proxy2');
187 can_ok($baz_proxy, 'baz');
188 isa_ok($baz_proxy->baz, 'Baz');
190 can_ok($baz_proxy, 'foo');
191 can_ok($baz_proxy, 'boo');
193 is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value');
194 is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
197 my $baz_proxy = Baz::Proxy3->new;
198 isa_ok($baz_proxy, 'Baz::Proxy3');
200 can_ok($baz_proxy, 'baz');
201 isa_ok($baz_proxy->baz, 'Baz');
203 can_ok($baz_proxy, 'bar');
204 can_ok($baz_proxy, 'boo');
206 is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
207 is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
210 # -------------------------------------------------------------------
212 # -------------------------------------------------------------------
224 sub foo { 'Foo::Baz::FOO' }
225 sub bar { 'Foo::Baz::BAR' }
226 sub baz { 'Foo::Baz::BAZ' }
234 handles => 'Foo::Bar',
240 my $foo = Foo::Thing->new(thing => Foo::Baz->new);
241 isa_ok($foo, 'Foo::Thing');
242 isa_ok($foo->thing, 'Foo::Baz');
244 ok($foo->meta->has_method('foo'), '... we have the method we expect');
245 ok($foo->meta->has_method('bar'), '... we have the method we expect');
246 ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect');
248 is($foo->foo, 'Foo::Baz::FOO', '... got the right value');
249 is($foo->bar, 'Foo::Baz::BAR', '... got the right value');
250 is($foo->thing->baz, 'Foo::Baz::BAZ', '... got the right value');
253 # -------------------------------------------------------------------
255 # -------------------------------------------------------------------
258 package Foo::Autoloaded;
264 my $name = our $AUTOLOAD;
265 $name =~ s/.*://; # strip fully-qualified portion
268 return $self->{$name} = shift;
270 return $self->{$name};
274 package Bar::Autoloaded;
279 default => sub { Foo::Autoloaded->new },
280 handles => { 'foo_bar' => 'bar' }
283 package Baz::Autoloaded;
288 default => sub { Foo::Autoloaded->new },
292 package Goorch::Autoloaded;
298 default => sub { Foo::Autoloaded->new },
301 } '... you cannot delegate to AUTOLOADED class with regexp';
304 # check HASH based delegation w/ AUTOLOAD
307 my $bar = Bar::Autoloaded->new;
308 isa_ok($bar, 'Bar::Autoloaded');
310 ok($bar->foo, '... we have something in bar->foo');
311 isa_ok($bar->foo, 'Foo::Autoloaded');
313 # change the value ...
317 # and make sure the delegation picks it up
319 is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
320 is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
322 # change the value through the delegation ...
326 # and make sure everyone sees it
328 is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
329 is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
331 # change the object we are delegating too
333 my $foo = Foo::Autoloaded->new;
334 isa_ok($foo, 'Foo::Autoloaded');
338 is($foo->bar, 25, '... got the right foo->bar');
342 } '... assigned the new Foo to Bar->foo';
344 is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
346 is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
347 is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
350 # check ARRAY based delegation w/ AUTOLOAD
353 my $baz = Baz::Autoloaded->new;
354 isa_ok($baz, 'Baz::Autoloaded');
356 ok($baz->foo, '... we have something in baz->foo');
357 isa_ok($baz->foo, 'Foo::Autoloaded');
359 # change the value ...
363 # and make sure the delegation picks it up
365 is($baz->foo->bar, 30, '... baz->foo->bar returned the right (changed) value');
366 is($baz->bar, 30, '... baz->foo_bar delegated correctly');
368 # change the value through the delegation ...
372 # and make sure everyone sees it
374 is($baz->foo->bar, 50, '... baz->foo->bar returned the right (changed) value');
375 is($baz->bar, 50, '... baz->foo_bar delegated correctly');
377 # change the object we are delegating too
379 my $foo = Foo::Autoloaded->new;
380 isa_ok($foo, 'Foo::Autoloaded');
384 is($foo->bar, 25, '... got the right foo->bar');
388 } '... assigned the new Foo to Baz->foo';
390 is($baz->foo, $foo, '... assigned baz->foo with the new Foo');
392 is($baz->foo->bar, 25, '... baz->foo->bar returned the right result');
393 is($baz->bar, 25, '... and baz->foo_bar delegated correctly again');