6 use Test::More tests => 92;
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);
31 default => sub { Foo->new },
35 'foo_bar_to_20' => [ bar => 20 ],
43 ok($bar->foo, '... we have something in bar->foo');
44 isa_ok($bar->foo, 'Foo');
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');
51 is($bar->foo->bar, 10, '... bar->foo->bar returned the right default');
53 can_ok($bar, 'foo_bar');
54 is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly');
56 # change the value ...
60 # and make sure the delegation picks it up
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');
65 # change the value through the delegation ...
69 # and make sure everyone sees it
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');
74 # change the object we are delegating too
76 my $foo = Foo->new(bar => 25);
79 is($foo->bar, 25, '... got the right foo->bar');
83 } '... assigned the new Foo to Bar->foo';
85 is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
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');
92 is($bar->foo_bar, 20, '... correctly curried a single argument');
94 # -------------------------------------------------------------------
96 # -------------------------------------------------------------------
97 # we also support an array based format
98 # which assumes that the name is the same
105 sub go { 'Engine::go' }
106 sub stop { 'Engine::stop' }
113 default => sub { Engine->new },
114 handles => [ 'go', 'stop' ]
121 isa_ok($car->engine, 'Engine');
122 can_ok($car->engine, 'go');
123 can_ok($car->engine, 'stop');
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');
129 can_ok($car, 'stop');
131 is($car->go, 'Engine::go', '... got the right value from ->go');
132 is($car->stop, 'Engine::stop', '... got the right value from ->stop');
134 # -------------------------------------------------------------------
136 # -------------------------------------------------------------------
137 # and we support regexp delegation
143 sub foo { 'Baz::foo' }
144 sub bar { 'Baz::bar' }
145 sub boo { 'Baz::boo' }
153 default => sub { Baz->new },
163 default => sub { Baz->new },
173 default => sub { Baz->new },
179 my $baz_proxy = Baz::Proxy1->new;
180 isa_ok($baz_proxy, 'Baz::Proxy1');
182 can_ok($baz_proxy, 'baz');
183 isa_ok($baz_proxy->baz, 'Baz');
185 can_ok($baz_proxy, 'foo');
186 can_ok($baz_proxy, 'bar');
187 can_ok($baz_proxy, 'boo');
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');
194 my $baz_proxy = Baz::Proxy2->new;
195 isa_ok($baz_proxy, 'Baz::Proxy2');
197 can_ok($baz_proxy, 'baz');
198 isa_ok($baz_proxy->baz, 'Baz');
200 can_ok($baz_proxy, 'foo');
201 can_ok($baz_proxy, 'boo');
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');
207 my $baz_proxy = Baz::Proxy3->new;
208 isa_ok($baz_proxy, 'Baz::Proxy3');
210 can_ok($baz_proxy, 'baz');
211 isa_ok($baz_proxy->baz, 'Baz');
213 can_ok($baz_proxy, 'bar');
214 can_ok($baz_proxy, 'boo');
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');
220 # -------------------------------------------------------------------
222 # -------------------------------------------------------------------
234 sub foo { 'Foo::Baz::FOO' }
235 sub bar { 'Foo::Baz::BAR' }
236 sub baz { 'Foo::Baz::BAZ' }
244 handles => 'Foo::Bar',
250 my $foo = Foo::Thing->new(thing => Foo::Baz->new);
251 isa_ok($foo, 'Foo::Thing');
252 isa_ok($foo->thing, 'Foo::Baz');
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');
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');
263 # -------------------------------------------------------------------
265 # -------------------------------------------------------------------
268 package Foo::Autoloaded;
274 my $name = our $AUTOLOAD;
275 $name =~ s/.*://; # strip fully-qualified portion
278 return $self->{$name} = shift;
280 return $self->{$name};
284 package Bar::Autoloaded;
289 default => sub { Foo::Autoloaded->new },
290 handles => { 'foo_bar' => 'bar' }
293 package Baz::Autoloaded;
298 default => sub { Foo::Autoloaded->new },
302 package Goorch::Autoloaded;
308 default => sub { Foo::Autoloaded->new },
311 } '... you cannot delegate to AUTOLOADED class with regexp';
314 # check HASH based delegation w/ AUTOLOAD
317 my $bar = Bar::Autoloaded->new;
318 isa_ok($bar, 'Bar::Autoloaded');
320 ok($bar->foo, '... we have something in bar->foo');
321 isa_ok($bar->foo, 'Foo::Autoloaded');
323 # change the value ...
327 # and make sure the delegation picks it up
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');
332 # change the value through the delegation ...
336 # and make sure everyone sees it
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');
341 # change the object we are delegating too
343 my $foo = Foo::Autoloaded->new;
344 isa_ok($foo, 'Foo::Autoloaded');
348 is($foo->bar, 25, '... got the right foo->bar');
352 } '... assigned the new Foo to Bar->foo';
354 is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
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');
360 # check ARRAY based delegation w/ AUTOLOAD
363 my $baz = Baz::Autoloaded->new;
364 isa_ok($baz, 'Baz::Autoloaded');
366 ok($baz->foo, '... we have something in baz->foo');
367 isa_ok($baz->foo, 'Foo::Autoloaded');
369 # change the value ...
373 # and make sure the delegation picks it up
375 is($baz->foo->bar, 30, '... baz->foo->bar returned the right (changed) value');
376 is($baz->bar, 30, '... baz->foo_bar delegated correctly');
378 # change the value through the delegation ...
382 # and make sure everyone sees it
384 is($baz->foo->bar, 50, '... baz->foo->bar returned the right (changed) value');
385 is($baz->bar, 50, '... baz->foo_bar delegated correctly');
387 # change the object we are delegating too
389 my $foo = Foo::Autoloaded->new;
390 isa_ok($foo, 'Foo::Autoloaded');
394 is($foo->bar, 25, '... got the right foo->bar');
398 } '... assigned the new Foo to Baz->foo';
400 is($baz->foo, $foo, '... assigned baz->foo with the new Foo');
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');
406 # Check that removing attributes removes their handles methods also.
413 default => sub { Foo->new },
414 handles => { 'foo_bar' => 'bar' }
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');
423 # Make sure that a useful error message is thrown when the delegation target is
426 my $i = Bar->new(foo => undef);
427 throws_ok { $i->foo_bar } qr/is not defined/,
428 'useful error from unblessed reference';
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';
434 my $k = Bar->new(foo => "Foo");
435 lives_ok { $k->foo_baz } "but not for class name";