10 # -------------------------------------------------------------------
12 # -------------------------------------------------------------------
13 # the canonical form of of the 'handles'
14 # option is the hash ref mapping a
15 # method name to the delegated method name
21 has 'bar' => (is => 'rw', default => 10);
30 default => sub { Foo->new },
34 'foo_bar_to_20' => [ bar => 20 ],
42 ok($bar->foo, '... we have something in bar->foo');
43 isa_ok($bar->foo, 'Foo');
45 my $meth = Bar->meta->get_method('foo_bar');
46 isa_ok($meth, 'Moose::Meta::Method::Delegation');
47 is($meth->associated_attribute->name, 'foo',
48 'associated_attribute->name for this method is foo');
50 is($bar->foo->bar, 10, '... bar->foo->bar returned the right default');
52 can_ok($bar, 'foo_bar');
53 is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly');
55 # change the value ...
59 # and make sure the delegation picks it up
61 is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
62 is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
64 # change the value through the delegation ...
68 # and make sure everyone sees it
70 is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
71 is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
73 # change the object we are delegating too
75 my $foo = Foo->new(bar => 25);
78 is($foo->bar, 25, '... got the right foo->bar');
82 }, undef, '... assigned the new Foo to Bar->foo' );
84 is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
86 is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
87 is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
91 is($bar->foo_bar, 20, '... correctly curried a single argument');
93 # -------------------------------------------------------------------
95 # -------------------------------------------------------------------
96 # we also support an array based format
97 # which assumes that the name is the same
104 sub go { 'Engine::go' }
105 sub stop { 'Engine::stop' }
112 default => sub { Engine->new },
113 handles => [ 'go', 'stop' ]
120 isa_ok($car->engine, 'Engine');
121 can_ok($car->engine, 'go');
122 can_ok($car->engine, 'stop');
124 is($car->engine->go, 'Engine::go', '... got the right value from ->engine->go');
125 is($car->engine->stop, 'Engine::stop', '... got the right value from ->engine->stop');
128 can_ok($car, 'stop');
130 is($car->go, 'Engine::go', '... got the right value from ->go');
131 is($car->stop, 'Engine::stop', '... got the right value from ->stop');
133 # -------------------------------------------------------------------
135 # -------------------------------------------------------------------
136 # and we support regexp delegation
142 sub foo { 'Baz::foo' }
143 sub bar { 'Baz::bar' }
144 sub boo { 'Baz::boo' }
152 default => sub { Baz->new },
162 default => sub { Baz->new },
172 default => sub { Baz->new },
178 my $baz_proxy = Baz::Proxy1->new;
179 isa_ok($baz_proxy, 'Baz::Proxy1');
181 can_ok($baz_proxy, 'baz');
182 isa_ok($baz_proxy->baz, 'Baz');
184 can_ok($baz_proxy, 'foo');
185 can_ok($baz_proxy, 'bar');
186 can_ok($baz_proxy, 'boo');
188 is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value');
189 is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
190 is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
193 my $baz_proxy = Baz::Proxy2->new;
194 isa_ok($baz_proxy, 'Baz::Proxy2');
196 can_ok($baz_proxy, 'baz');
197 isa_ok($baz_proxy->baz, 'Baz');
199 can_ok($baz_proxy, 'foo');
200 can_ok($baz_proxy, 'boo');
202 is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value');
203 is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
206 my $baz_proxy = Baz::Proxy3->new;
207 isa_ok($baz_proxy, 'Baz::Proxy3');
209 can_ok($baz_proxy, 'baz');
210 isa_ok($baz_proxy->baz, 'Baz');
212 can_ok($baz_proxy, 'bar');
213 can_ok($baz_proxy, 'boo');
215 is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
216 is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
219 # -------------------------------------------------------------------
221 # -------------------------------------------------------------------
233 sub foo { 'Foo::Baz::FOO' }
234 sub bar { 'Foo::Baz::BAR' }
235 sub baz { 'Foo::Baz::BAZ' }
243 handles => 'Foo::Bar',
246 package Foo::OtherThing;
248 use Moose::Util::TypeConstraints;
250 has 'other_thing' => (
253 handles => Moose::Util::TypeConstraints::find_type_constraint('Foo::Bar'),
258 my $foo = Foo::Thing->new(thing => Foo::Baz->new);
259 isa_ok($foo, 'Foo::Thing');
260 isa_ok($foo->thing, 'Foo::Baz');
262 ok($foo->meta->has_method('foo'), '... we have the method we expect');
263 ok($foo->meta->has_method('bar'), '... we have the method we expect');
264 ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect');
266 is($foo->foo, 'Foo::Baz::FOO', '... got the right value');
267 is($foo->bar, 'Foo::Baz::BAR', '... got the right value');
268 is($foo->thing->baz, 'Foo::Baz::BAZ', '... got the right value');
272 my $foo = Foo::OtherThing->new(other_thing => Foo::Baz->new);
273 isa_ok($foo, 'Foo::OtherThing');
274 isa_ok($foo->other_thing, 'Foo::Baz');
276 ok($foo->meta->has_method('foo'), '... we have the method we expect');
277 ok($foo->meta->has_method('bar'), '... we have the method we expect');
278 ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect');
280 is($foo->foo, 'Foo::Baz::FOO', '... got the right value');
281 is($foo->bar, 'Foo::Baz::BAR', '... got the right value');
282 is($foo->other_thing->baz, 'Foo::Baz::BAZ', '... got the right value');
284 # -------------------------------------------------------------------
286 # -------------------------------------------------------------------
289 package Foo::Autoloaded;
295 my $name = our $AUTOLOAD;
296 $name =~ s/.*://; # strip fully-qualified portion
299 return $self->{$name} = shift;
301 return $self->{$name};
305 package Bar::Autoloaded;
310 default => sub { Foo::Autoloaded->new },
311 handles => { 'foo_bar' => 'bar' }
314 package Baz::Autoloaded;
319 default => sub { Foo::Autoloaded->new },
323 package Goorch::Autoloaded;
326 ::isnt( ::exception {
329 default => sub { Foo::Autoloaded->new },
332 }, undef, '... you cannot delegate to AUTOLOADED class with regexp' );
335 # check HASH based delegation w/ AUTOLOAD
338 my $bar = Bar::Autoloaded->new;
339 isa_ok($bar, 'Bar::Autoloaded');
341 ok($bar->foo, '... we have something in bar->foo');
342 isa_ok($bar->foo, 'Foo::Autoloaded');
344 # change the value ...
348 # and make sure the delegation picks it up
350 is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
351 is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
353 # change the value through the delegation ...
357 # and make sure everyone sees it
359 is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
360 is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
362 # change the object we are delegating too
364 my $foo = Foo::Autoloaded->new;
365 isa_ok($foo, 'Foo::Autoloaded');
369 is($foo->bar, 25, '... got the right foo->bar');
373 }, undef, '... assigned the new Foo to Bar->foo' );
375 is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
377 is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
378 is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
381 # check ARRAY based delegation w/ AUTOLOAD
384 my $baz = Baz::Autoloaded->new;
385 isa_ok($baz, 'Baz::Autoloaded');
387 ok($baz->foo, '... we have something in baz->foo');
388 isa_ok($baz->foo, 'Foo::Autoloaded');
390 # change the value ...
394 # and make sure the delegation picks it up
396 is($baz->foo->bar, 30, '... baz->foo->bar returned the right (changed) value');
397 is($baz->bar, 30, '... baz->foo_bar delegated correctly');
399 # change the value through the delegation ...
403 # and make sure everyone sees it
405 is($baz->foo->bar, 50, '... baz->foo->bar returned the right (changed) value');
406 is($baz->bar, 50, '... baz->foo_bar delegated correctly');
408 # change the object we are delegating too
410 my $foo = Foo::Autoloaded->new;
411 isa_ok($foo, 'Foo::Autoloaded');
415 is($foo->bar, 25, '... got the right foo->bar');
419 }, undef, '... assigned the new Foo to Baz->foo' );
421 is($baz->foo, $foo, '... assigned baz->foo with the new Foo');
423 is($baz->foo->bar, 25, '... baz->foo->bar returned the right result');
424 is($baz->bar, 25, '... and baz->foo_bar delegated correctly again');
427 # Check that removing attributes removes their handles methods also.
434 default => sub { Foo->new },
435 handles => { 'foo_bar' => 'bar' }
439 ok($i->meta->has_method('foo_bar'), 'handles method foo_bar is present');
440 $i->meta->remove_attribute('foo');
441 ok(!$i->meta->has_method('foo_bar'), 'handles method foo_bar is removed');
444 # Make sure that a useful error message is thrown when the delegation target is
447 my $i = Bar->new(foo => undef);
448 like( exception { $i->foo_bar }, qr/is not defined/, 'useful error from unblessed reference' );
450 my $j = Bar->new(foo => []);
451 like( exception { $j->foo_bar }, qr/is not an object \(got 'ARRAY/, 'useful error from unblessed reference' );
453 my $k = Bar->new(foo => "Foo");
454 is( exception { $k->foo_baz }, undef, "but not for class name" );