2 # This is automatically generated by author/import-moose-test.pl.
3 # DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
4 use t::lib::MooseCompat;
10 $TODO = q{Mouse is not yet completed};
14 # -------------------------------------------------------------------
16 # -------------------------------------------------------------------
17 # the canonical form of of the 'handles'
18 # option is the hash ref mapping a
19 # method name to the delegated method name
25 has 'bar' => (is => 'rw', default => 10);
34 default => sub { Foo->new },
38 'foo_bar_to_20' => [ bar => 20 ],
46 ok($bar->foo, '... we have something in bar->foo');
47 isa_ok($bar->foo, 'Foo');
49 my $meth = Bar->meta->get_method('foo_bar');
50 isa_ok($meth, 'Mouse::Meta::Method');
51 is($meth->associated_attribute->name, 'foo',
52 'associated_attribute->name for this method is foo');
54 is($bar->foo->bar, 10, '... bar->foo->bar returned the right default');
56 can_ok($bar, 'foo_bar');
57 is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly');
59 # change the value ...
63 # and make sure the delegation picks it up
65 is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
66 is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
68 # change the value through the delegation ...
72 # and make sure everyone sees it
74 is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
75 is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
77 # change the object we are delegating too
79 my $foo = Foo->new(bar => 25);
82 is($foo->bar, 25, '... got the right foo->bar');
86 } '... assigned the new Foo to Bar->foo';
88 is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
90 is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
91 is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
95 is($bar->foo_bar, 20, '... correctly curried a single argument');
97 # -------------------------------------------------------------------
99 # -------------------------------------------------------------------
100 # we also support an array based format
101 # which assumes that the name is the same
108 sub go { 'Engine::go' }
109 sub stop { 'Engine::stop' }
116 default => sub { Engine->new },
117 handles => [ 'go', 'stop' ]
124 isa_ok($car->engine, 'Engine');
125 can_ok($car->engine, 'go');
126 can_ok($car->engine, 'stop');
128 is($car->engine->go, 'Engine::go', '... got the right value from ->engine->go');
129 is($car->engine->stop, 'Engine::stop', '... got the right value from ->engine->stop');
132 can_ok($car, 'stop');
134 is($car->go, 'Engine::go', '... got the right value from ->go');
135 is($car->stop, 'Engine::stop', '... got the right value from ->stop');
137 # -------------------------------------------------------------------
139 # -------------------------------------------------------------------
140 # and we support regexp delegation
146 sub foo { 'Baz::foo' }
147 sub bar { 'Baz::bar' }
148 sub boo { 'Baz::boo' }
156 default => sub { Baz->new },
166 default => sub { Baz->new },
176 default => sub { Baz->new },
182 my $baz_proxy = Baz::Proxy1->new;
183 isa_ok($baz_proxy, 'Baz::Proxy1');
185 can_ok($baz_proxy, 'baz');
186 isa_ok($baz_proxy->baz, 'Baz');
188 can_ok($baz_proxy, 'foo');
189 can_ok($baz_proxy, 'bar');
190 can_ok($baz_proxy, 'boo');
192 is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value');
193 is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
194 is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
197 my $baz_proxy = Baz::Proxy2->new;
198 isa_ok($baz_proxy, 'Baz::Proxy2');
200 can_ok($baz_proxy, 'baz');
201 isa_ok($baz_proxy->baz, 'Baz');
203 can_ok($baz_proxy, 'foo');
204 can_ok($baz_proxy, 'boo');
206 is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value');
207 is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
210 my $baz_proxy = Baz::Proxy3->new;
211 isa_ok($baz_proxy, 'Baz::Proxy3');
213 can_ok($baz_proxy, 'baz');
214 isa_ok($baz_proxy->baz, 'Baz');
216 can_ok($baz_proxy, 'bar');
217 can_ok($baz_proxy, 'boo');
219 is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
220 is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
223 # -------------------------------------------------------------------
225 # -------------------------------------------------------------------
237 sub foo { 'Foo::Baz::FOO' }
238 sub bar { 'Foo::Baz::BAR' }
239 sub baz { 'Foo::Baz::BAZ' }
247 handles => 'Foo::Bar',
250 package Foo::OtherThing;
252 use Mouse::Util::TypeConstraints;
254 has 'other_thing' => (
257 handles => Mouse::Util::TypeConstraints::find_type_constraint('Foo::Bar'),
262 my $foo = Foo::Thing->new(thing => Foo::Baz->new);
263 isa_ok($foo, 'Foo::Thing');
264 isa_ok($foo->thing, 'Foo::Baz');
266 ok($foo->meta->has_method('foo'), '... we have the method we expect');
267 ok($foo->meta->has_method('bar'), '... we have the method we expect');
268 ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect');
270 is($foo->foo, 'Foo::Baz::FOO', '... got the right value');
271 is($foo->bar, 'Foo::Baz::BAR', '... got the right value');
272 is($foo->thing->baz, 'Foo::Baz::BAZ', '... got the right value');
276 my $foo = Foo::OtherThing->new(other_thing => Foo::Baz->new);
277 isa_ok($foo, 'Foo::OtherThing');
278 isa_ok($foo->other_thing, 'Foo::Baz');
280 ok($foo->meta->has_method('foo'), '... we have the method we expect');
281 ok($foo->meta->has_method('bar'), '... we have the method we expect');
282 ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect');
284 is($foo->foo, 'Foo::Baz::FOO', '... got the right value');
285 is($foo->bar, 'Foo::Baz::BAR', '... got the right value');
286 is($foo->other_thing->baz, 'Foo::Baz::BAZ', '... got the right value');
288 # -------------------------------------------------------------------
290 # -------------------------------------------------------------------
293 package Foo::Autoloaded;
299 my $name = our $AUTOLOAD;
300 $name =~ s/.*://; # strip fully-qualified portion
303 return $self->{$name} = shift;
305 return $self->{$name};
309 package Bar::Autoloaded;
314 default => sub { Foo::Autoloaded->new },
315 handles => { 'foo_bar' => 'bar' }
318 package Baz::Autoloaded;
323 default => sub { Foo::Autoloaded->new },
327 package Goorch::Autoloaded;
333 default => sub { Foo::Autoloaded->new },
336 } '... you cannot delegate to AUTOLOADED class with regexp';
339 # check HASH based delegation w/ AUTOLOAD
342 my $bar = Bar::Autoloaded->new;
343 isa_ok($bar, 'Bar::Autoloaded');
345 ok($bar->foo, '... we have something in bar->foo');
346 isa_ok($bar->foo, 'Foo::Autoloaded');
348 # change the value ...
352 # and make sure the delegation picks it up
354 is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
355 is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
357 # change the value through the delegation ...
361 # and make sure everyone sees it
363 is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
364 is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
366 # change the object we are delegating too
368 my $foo = Foo::Autoloaded->new;
369 isa_ok($foo, 'Foo::Autoloaded');
373 is($foo->bar, 25, '... got the right foo->bar');
377 } '... assigned the new Foo to Bar->foo';
379 is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
381 is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
382 is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
385 # check ARRAY based delegation w/ AUTOLOAD
388 my $baz = Baz::Autoloaded->new;
389 isa_ok($baz, 'Baz::Autoloaded');
391 ok($baz->foo, '... we have something in baz->foo');
392 isa_ok($baz->foo, 'Foo::Autoloaded');
394 # change the value ...
398 # and make sure the delegation picks it up
400 is($baz->foo->bar, 30, '... baz->foo->bar returned the right (changed) value');
401 is($baz->bar, 30, '... baz->foo_bar delegated correctly');
403 # change the value through the delegation ...
407 # and make sure everyone sees it
409 is($baz->foo->bar, 50, '... baz->foo->bar returned the right (changed) value');
410 is($baz->bar, 50, '... baz->foo_bar delegated correctly');
412 # change the object we are delegating too
414 my $foo = Foo::Autoloaded->new;
415 isa_ok($foo, 'Foo::Autoloaded');
419 is($foo->bar, 25, '... got the right foo->bar');
423 } '... assigned the new Foo to Baz->foo';
425 is($baz->foo, $foo, '... assigned baz->foo with the new Foo');
427 is($baz->foo->bar, 25, '... baz->foo->bar returned the right result');
428 is($baz->bar, 25, '... and baz->foo_bar delegated correctly again');
431 # Check that removing attributes removes their handles methods also.
438 default => sub { Foo->new },
439 handles => { 'foo_bar' => 'bar' }
443 ok($i->meta->has_method('foo_bar'), 'handles method foo_bar is present');
444 $i->meta->remove_attribute('foo');
445 ok(!$i->meta->has_method('foo_bar'), 'handles method foo_bar is removed');
448 # Make sure that a useful error message is thrown when the delegation target is
451 my $i = Bar->new(foo => undef);
452 throws_ok { $i->foo_bar } qr/is not defined/,
453 'useful error from unblessed reference';
455 my $j = Bar->new(foo => []);
456 throws_ok { $j->foo_bar } qr/is not an object \(got 'ARRAY/,
457 'useful error from unblessed reference';
459 my $k = Bar->new(foo => "Foo");
460 lives_ok { $k->foo_baz } "but not for class name";