[gitmo/Mouse.git] / t-failing / 020_attributes / 010_attribute_delegation.t

#!/usr/bin/perl
# This is automatically generated by author/import-moose-test.pl.
# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
use t::lib::MooseCompat;

use strict;
use warnings;

use Test::More;
$TODO = q{Mouse is not yet completed};
use Test::Exception;


# -------------------------------------------------------------------
# HASH handles
# -------------------------------------------------------------------
# the canonical form of of the 'handles'
# option is the hash ref mapping a
# method name to the delegated method name

{
    package Foo;
    use Mouse;

    has 'bar' => (is => 'rw', default => 10);

    sub baz { 42 }

    package Bar;
    use Mouse;

    has 'foo' => (
        is      => 'rw',
        default => sub { Foo->new },
        handles => {
            'foo_bar' => 'bar',
            foo_baz => 'baz',
            'foo_bar_to_20' => [ bar => 20 ],
        },
    );
}

my $bar = Bar->new;
isa_ok($bar, 'Bar');

ok($bar->foo, '... we have something in bar->foo');
isa_ok($bar->foo, 'Foo');

my $meth = Bar->meta->get_method('foo_bar');
isa_ok($meth, 'Mouse::Meta::Method');
is($meth->associated_attribute->name, 'foo',
   'associated_attribute->name for this method is foo');

is($bar->foo->bar, 10, '... bar->foo->bar returned the right default');

can_ok($bar, 'foo_bar');
is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly');

# change the value ...

$bar->foo->bar(30);

# and make sure the delegation picks it up

is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');

# change the value through the delegation ...

$bar->foo_bar(50);

# and make sure everyone sees it

is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');

# change the object we are delegating too

my $foo = Foo->new(bar => 25);
isa_ok($foo, 'Foo');

is($foo->bar, 25, '... got the right foo->bar');

lives_ok {
    $bar->foo($foo);
} '... assigned the new Foo to Bar->foo';

is($bar->foo, $foo, '... assigned bar->foo with the new Foo');

is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');

# curried handles
$bar->foo_bar_to_20;
is($bar->foo_bar, 20, '... correctly curried a single argument');

# -------------------------------------------------------------------
# ARRAY handles
# -------------------------------------------------------------------
# we also support an array based format
# which assumes that the name is the same
# on either end

{
    package Engine;
    use Mouse;

    sub go   { 'Engine::go'   }
    sub stop { 'Engine::stop' }

    package Car;
    use Mouse;

    has 'engine' => (
        is      => 'rw',
        default => sub { Engine->new },
        handles => [ 'go', 'stop' ]
    );
}

my $car = Car->new;
isa_ok($car, 'Car');

isa_ok($car->engine, 'Engine');
can_ok($car->engine, 'go');
can_ok($car->engine, 'stop');

is($car->engine->go, 'Engine::go', '... got the right value from ->engine->go');
is($car->engine->stop, 'Engine::stop', '... got the right value from ->engine->stop');

can_ok($car, 'go');
can_ok($car, 'stop');

is($car->go, 'Engine::go', '... got the right value from ->go');
is($car->stop, 'Engine::stop', '... got the right value from ->stop');

# -------------------------------------------------------------------
# REGEXP handles
# -------------------------------------------------------------------
# and we support regexp delegation

{
    package Baz;
    use Mouse;

    sub foo { 'Baz::foo' }
    sub bar { 'Baz::bar' }
    sub boo { 'Baz::boo' }

    package Baz::Proxy1;
    use Mouse;

    has 'baz' => (
        is      => 'ro',
        isa     => 'Baz',
        default => sub { Baz->new },
        handles => qr/.*/
    );

    package Baz::Proxy2;
    use Mouse;

    has 'baz' => (
        is      => 'ro',
        isa     => 'Baz',
        default => sub { Baz->new },
        handles => qr/.oo/
    );

    package Baz::Proxy3;
    use Mouse;

    has 'baz' => (
        is      => 'ro',
        isa     => 'Baz',
        default => sub { Baz->new },
        handles => qr/b.*/
    );
}

{
    my $baz_proxy = Baz::Proxy1->new;
    isa_ok($baz_proxy, 'Baz::Proxy1');

    can_ok($baz_proxy, 'baz');
    isa_ok($baz_proxy->baz, 'Baz');

    can_ok($baz_proxy, 'foo');
    can_ok($baz_proxy, 'bar');
    can_ok($baz_proxy, 'boo');

    is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value');
    is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
    is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
}
{
    my $baz_proxy = Baz::Proxy2->new;
    isa_ok($baz_proxy, 'Baz::Proxy2');

    can_ok($baz_proxy, 'baz');
    isa_ok($baz_proxy->baz, 'Baz');

    can_ok($baz_proxy, 'foo');
    can_ok($baz_proxy, 'boo');

    is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value');
    is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
}
{
    my $baz_proxy = Baz::Proxy3->new;
    isa_ok($baz_proxy, 'Baz::Proxy3');

    can_ok($baz_proxy, 'baz');
    isa_ok($baz_proxy->baz, 'Baz');

    can_ok($baz_proxy, 'bar');
    can_ok($baz_proxy, 'boo');

    is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
    is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
}

# -------------------------------------------------------------------
# ROLE handles
# -------------------------------------------------------------------

{
    package Foo::Bar;
    use Mouse::Role;

    requires 'foo';
    requires 'bar';

    package Foo::Baz;
    use Mouse;

    sub foo { 'Foo::Baz::FOO' }
    sub bar { 'Foo::Baz::BAR' }
    sub baz { 'Foo::Baz::BAZ' }

    package Foo::Thing;
    use Mouse;

    has 'thing' => (
        is      => 'rw',
        isa     => 'Foo::Baz',
        handles => 'Foo::Bar',
    );

    package Foo::OtherThing;
    use Mouse;
    use Mouse::Util::TypeConstraints;

    has 'other_thing' => (
        is      => 'rw',
        isa     => 'Foo::Baz',
        handles => Mouse::Util::TypeConstraints::find_type_constraint('Foo::Bar'),
    );
}

{
    my $foo = Foo::Thing->new(thing => Foo::Baz->new);
    isa_ok($foo, 'Foo::Thing');
    isa_ok($foo->thing, 'Foo::Baz');

    ok($foo->meta->has_method('foo'), '... we have the method we expect');
    ok($foo->meta->has_method('bar'), '... we have the method we expect');
    ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect');

    is($foo->foo, 'Foo::Baz::FOO', '... got the right value');
    is($foo->bar, 'Foo::Baz::BAR', '... got the right value');
    is($foo->thing->baz, 'Foo::Baz::BAZ', '... got the right value');
}

{
    my $foo = Foo::OtherThing->new(other_thing => Foo::Baz->new);
    isa_ok($foo, 'Foo::OtherThing');
    isa_ok($foo->other_thing, 'Foo::Baz');

    ok($foo->meta->has_method('foo'), '... we have the method we expect');
    ok($foo->meta->has_method('bar'), '... we have the method we expect');
    ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect');

    is($foo->foo, 'Foo::Baz::FOO', '... got the right value');
    is($foo->bar, 'Foo::Baz::BAR', '... got the right value');
    is($foo->other_thing->baz, 'Foo::Baz::BAZ', '... got the right value');
}
# -------------------------------------------------------------------
# AUTOLOAD & handles
# -------------------------------------------------------------------

{
    package Foo::Autoloaded;
    use Mouse;

    sub AUTOLOAD {
        my $self = shift;

        my $name = our $AUTOLOAD;
        $name =~ s/.*://; # strip fully-qualified portion

        if (@_) {
            return $self->{$name} = shift;
        } else {
            return $self->{$name};
        }
    }

    package Bar::Autoloaded;
    use Mouse;

    has 'foo' => (
        is      => 'rw',
        default => sub { Foo::Autoloaded->new },
        handles => { 'foo_bar' => 'bar' }
    );

    package Baz::Autoloaded;
    use Mouse;

    has 'foo' => (
        is      => 'rw',
        default => sub { Foo::Autoloaded->new },
        handles => ['bar']
    );

    package Goorch::Autoloaded;
    use Mouse;

    ::dies_ok {
        has 'foo' => (
            is      => 'rw',
            default => sub { Foo::Autoloaded->new },
            handles => qr/bar/
        );
    } '... you cannot delegate to AUTOLOADED class with regexp';
}

# check HASH based delegation w/ AUTOLOAD

{
    my $bar = Bar::Autoloaded->new;
    isa_ok($bar, 'Bar::Autoloaded');

    ok($bar->foo, '... we have something in bar->foo');
    isa_ok($bar->foo, 'Foo::Autoloaded');

    # change the value ...

    $bar->foo->bar(30);

    # and make sure the delegation picks it up

    is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
    is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');

    # change the value through the delegation ...

    $bar->foo_bar(50);

    # and make sure everyone sees it

    is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
    is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');

    # change the object we are delegating too

    my $foo = Foo::Autoloaded->new;
    isa_ok($foo, 'Foo::Autoloaded');

    $foo->bar(25);

    is($foo->bar, 25, '... got the right foo->bar');

    lives_ok {
        $bar->foo($foo);
    } '... assigned the new Foo to Bar->foo';

    is($bar->foo, $foo, '... assigned bar->foo with the new Foo');

    is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
    is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
}

# check ARRAY based delegation w/ AUTOLOAD

{
    my $baz = Baz::Autoloaded->new;
    isa_ok($baz, 'Baz::Autoloaded');

    ok($baz->foo, '... we have something in baz->foo');
    isa_ok($baz->foo, 'Foo::Autoloaded');

    # change the value ...

    $baz->foo->bar(30);

    # and make sure the delegation picks it up

    is($baz->foo->bar, 30, '... baz->foo->bar returned the right (changed) value');
    is($baz->bar, 30, '... baz->foo_bar delegated correctly');

    # change the value through the delegation ...

    $baz->bar(50);

    # and make sure everyone sees it

    is($baz->foo->bar, 50, '... baz->foo->bar returned the right (changed) value');
    is($baz->bar, 50, '... baz->foo_bar delegated correctly');

    # change the object we are delegating too

    my $foo = Foo::Autoloaded->new;
    isa_ok($foo, 'Foo::Autoloaded');

    $foo->bar(25);

    is($foo->bar, 25, '... got the right foo->bar');

    lives_ok {
        $baz->foo($foo);
    } '... assigned the new Foo to Baz->foo';

    is($baz->foo, $foo, '... assigned baz->foo with the new Foo');

    is($baz->foo->bar, 25, '... baz->foo->bar returned the right result');
    is($baz->bar, 25, '... and baz->foo_bar delegated correctly again');
}

# Check that removing attributes removes their handles methods also.
{
    {
        package Quux;
        use Mouse;
        has foo => (
            isa => 'Foo',
            default => sub { Foo->new },
            handles => { 'foo_bar' => 'bar' }
        );
    }
    my $i = Quux->new;
    ok($i->meta->has_method('foo_bar'), 'handles method foo_bar is present');
    $i->meta->remove_attribute('foo');
    ok(!$i->meta->has_method('foo_bar'), 'handles method foo_bar is removed');
}

# Make sure that a useful error message is thrown when the delegation target is
# not an object
{
    my $i = Bar->new(foo => undef);
    throws_ok { $i->foo_bar } qr/is not defined/,
        'useful error from unblessed reference';

    my $j = Bar->new(foo => []);
    throws_ok { $j->foo_bar } qr/is not an object \(got 'ARRAY/,
        'useful error from unblessed reference';

    my $k = Bar->new(foo => "Foo");
    lives_ok { $k->foo_baz } "but not for class name";
}

done_testing;
Commit	Line	Data
4060c871	1	#!/usr/bin/perl
fde8e43f	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;
4060c871	5
	6	use strict;
	7	use warnings;
	8
fde8e43f	9	use Test::More;
fde8e43f	10	$TODO = q{Mouse is not yet completed};
4060c871	11	use Test::Exception;
	12
	13
4060c871	14	# -------------------------------------------------------------------
	15	# HASH handles
	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
	20
	21	{
	22	package Foo;
	23	use Mouse;
	24
	25	has 'bar' => (is => 'rw', default => 10);
	26
	27	sub baz { 42 }
	28
	29	package Bar;
	30	use Mouse;
	31
	32	has 'foo' => (
	33	is => 'rw',
	34	default => sub { Foo->new },
	35	handles => {
	36	'foo_bar' => 'bar',
	37	foo_baz => 'baz',
	38	'foo_bar_to_20' => [ bar => 20 ],
	39	},
	40	);
	41	}
	42
	43	my $bar = Bar->new;
	44	isa_ok($bar, 'Bar');
	45
	46	ok($bar->foo, '... we have something in bar->foo');
	47	isa_ok($bar->foo, 'Foo');
	48
	49	my $meth = Bar->meta->get_method('foo_bar');
fde8e43f	50	isa_ok($meth, 'Mouse::Meta::Method');
4060c871	51	is($meth->associated_attribute->name, 'foo',
	52	'associated_attribute->name for this method is foo');
	53
	54	is($bar->foo->bar, 10, '... bar->foo->bar returned the right default');
	55
	56	can_ok($bar, 'foo_bar');
	57	is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly');
	58
	59	# change the value ...
	60
	61	$bar->foo->bar(30);
	62
	63	# and make sure the delegation picks it up
	64
	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');
	67
	68	# change the value through the delegation ...
	69
	70	$bar->foo_bar(50);
	71
	72	# and make sure everyone sees it
	73
	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');
	76
	77	# change the object we are delegating too
	78
	79	my $foo = Foo->new(bar => 25);
	80	isa_ok($foo, 'Foo');
	81
	82	is($foo->bar, 25, '... got the right foo->bar');
	83
	84	lives_ok {
	85	$bar->foo($foo);
	86	} '... assigned the new Foo to Bar->foo';
	87
	88	is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
	89
	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');
	92
	93	# curried handles
	94	$bar->foo_bar_to_20;
	95	is($bar->foo_bar, 20, '... correctly curried a single argument');
	96
	97	# -------------------------------------------------------------------
	98	# ARRAY handles
	99	# -------------------------------------------------------------------
	100	# we also support an array based format
	101	# which assumes that the name is the same
	102	# on either end
	103
	104	{
	105	package Engine;
	106	use Mouse;
	107
	108	sub go { 'Engine::go' }
	109	sub stop { 'Engine::stop' }
	110
	111	package Car;
	112	use Mouse;
	113
	114	has 'engine' => (
115	is => 'rw',
116	default => sub { Engine->new },
117	handles => [ 'go', 'stop' ]
118	);
119	}
120
121	my $car = Car->new;
122	isa_ok($car, 'Car');
123
124	isa_ok($car->engine, 'Engine');
125	can_ok($car->engine, 'go');
126	can_ok($car->engine, 'stop');
127
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');
130
131	can_ok($car, 'go');
132	can_ok($car, 'stop');
133
134	is($car->go, 'Engine::go', '... got the right value from ->go');
135	is($car->stop, 'Engine::stop', '... got the right value from ->stop');
136
137	# -------------------------------------------------------------------
138	# REGEXP handles
139	# -------------------------------------------------------------------
140	# and we support regexp delegation
141
142	{
143	package Baz;
144	use Mouse;
145
146	sub foo { 'Baz::foo' }
147	sub bar { 'Baz::bar' }
148	sub boo { 'Baz::boo' }
149
150	package Baz::Proxy1;
151	use Mouse;
152
153	has 'baz' => (
154	is => 'ro',
155	isa => 'Baz',
156	default => sub { Baz->new },
157	handles => qr/.*/
158	);
159
160	package Baz::Proxy2;
161	use Mouse;
162
163	has 'baz' => (
164	is => 'ro',
165	isa => 'Baz',
166	default => sub { Baz->new },
167	handles => qr/.oo/
168	);
169
170	package Baz::Proxy3;
171	use Mouse;
172
173	has 'baz' => (
174	is => 'ro',
175	isa => 'Baz',
176	default => sub { Baz->new },
177	handles => qr/b.*/
178	);
179	}
180
181	{
182	my $baz_proxy = Baz::Proxy1->new;
183	isa_ok($baz_proxy, 'Baz::Proxy1');
184
185	can_ok($baz_proxy, 'baz');
186	isa_ok($baz_proxy->baz, 'Baz');
187
188	can_ok($baz_proxy, 'foo');
189	can_ok($baz_proxy, 'bar');
190	can_ok($baz_proxy, 'boo');
191
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');
195	}
196	{
197	my $baz_proxy = Baz::Proxy2->new;
198	isa_ok($baz_proxy, 'Baz::Proxy2');
199
200	can_ok($baz_proxy, 'baz');
201	isa_ok($baz_proxy->baz, 'Baz');
202
203	can_ok($baz_proxy, 'foo');
204	can_ok($baz_proxy, 'boo');
205
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');
208	}
209	{
210	my $baz_proxy = Baz::Proxy3->new;
211	isa_ok($baz_proxy, 'Baz::Proxy3');
212
213	can_ok($baz_proxy, 'baz');
214	isa_ok($baz_proxy->baz, 'Baz');
215
216	can_ok($baz_proxy, 'bar');
217	can_ok($baz_proxy, 'boo');
218
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');
221	}
222
223	# -------------------------------------------------------------------
224	# ROLE handles
225	# -------------------------------------------------------------------
226
227	{
228	package Foo::Bar;
229	use Mouse::Role;
230
231	requires 'foo';
232	requires 'bar';
233
234	package Foo::Baz;
235	use Mouse;
236
237	sub foo { 'Foo::Baz::FOO' }
238	sub bar { 'Foo::Baz::BAR' }
239	sub baz { 'Foo::Baz::BAZ' }
240
241	package Foo::Thing;
242	use Mouse;
243
244	has 'thing' => (
245	is => 'rw',
246	isa => 'Foo::Baz',
247	handles => 'Foo::Bar',
248	);
249
fde8e43f	250	package Foo::OtherThing;
	251	use Mouse;
	252	use Mouse::Util::TypeConstraints;
	253
	254	has 'other_thing' => (
	255	is => 'rw',
	256	isa => 'Foo::Baz',
	257	handles => Mouse::Util::TypeConstraints::find_type_constraint('Foo::Bar'),
	258	);
4060c871	259	}
	260
	261	{
	262	my $foo = Foo::Thing->new(thing => Foo::Baz->new);
	263	isa_ok($foo, 'Foo::Thing');
	264	isa_ok($foo->thing, 'Foo::Baz');
	265
	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');
	269
	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');
	273	}
	274
fde8e43f	275	{
	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');
	279
	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');
	283
	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');
	287	}
4060c871	288	# -------------------------------------------------------------------
	289	# AUTOLOAD & handles
	290	# -------------------------------------------------------------------
	291
	292	{
	293	package Foo::Autoloaded;
	294	use Mouse;
	295
	296	sub AUTOLOAD {
	297	my $self = shift;
	298
	299	my $name = our $AUTOLOAD;
	300	$name =~ s/.*://; # strip fully-qualified portion
	301
	302	if (@_) {
	303	return $self->{$name} = shift;
	304	} else {
	305	return $self->{$name};
	306	}
	307	}
	308
	309	package Bar::Autoloaded;
	310	use Mouse;
	311
	312	has 'foo' => (
	313	is => 'rw',
	314	default => sub { Foo::Autoloaded->new },
	315	handles => { 'foo_bar' => 'bar' }
	316	);
	317
	318	package Baz::Autoloaded;
	319	use Mouse;
	320
	321	has 'foo' => (
	322	is => 'rw',
	323	default => sub { Foo::Autoloaded->new },
	324	handles => ['bar']
	325	);
	326
	327	package Goorch::Autoloaded;
	328	use Mouse;
	329
	330	::dies_ok {
	331	has 'foo' => (
	332	is => 'rw',
	333	default => sub { Foo::Autoloaded->new },
	334	handles => qr/bar/
	335	);
	336	} '... you cannot delegate to AUTOLOADED class with regexp';
	337	}
	338
	339	# check HASH based delegation w/ AUTOLOAD
	340
	341	{
	342	my $bar = Bar::Autoloaded->new;
	343	isa_ok($bar, 'Bar::Autoloaded');
	344
	345	ok($bar->foo, '... we have something in bar->foo');
	346	isa_ok($bar->foo, 'Foo::Autoloaded');
	347
	348	# change the value ...
	349
	350	$bar->foo->bar(30);
	351
352	# and make sure the delegation picks it up
353
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');
356
357	# change the value through the delegation ...
358
359	$bar->foo_bar(50);
360
361	# and make sure everyone sees it
362
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');
365
366	# change the object we are delegating too
367
368	my $foo = Foo::Autoloaded->new;
369	isa_ok($foo, 'Foo::Autoloaded');
370
371	$foo->bar(25);
372
373	is($foo->bar, 25, '... got the right foo->bar');
374
375	lives_ok {
376	$bar->foo($foo);
377	} '... assigned the new Foo to Bar->foo';
378
379	is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
380
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');
383	}
384
385	# check ARRAY based delegation w/ AUTOLOAD
386
387	{
388	my $baz = Baz::Autoloaded->new;
389	isa_ok($baz, 'Baz::Autoloaded');
390
391	ok($baz->foo, '... we have something in baz->foo');
392	isa_ok($baz->foo, 'Foo::Autoloaded');
393
394	# change the value ...
395
396	$baz->foo->bar(30);
397
398	# and make sure the delegation picks it up
399
400	is($baz->foo->bar, 30, '... baz->foo->bar returned the right (changed) value');
401	is($baz->bar, 30, '... baz->foo_bar delegated correctly');
402
403	# change the value through the delegation ...
404
405	$baz->bar(50);
406
407	# and make sure everyone sees it
408
409	is($baz->foo->bar, 50, '... baz->foo->bar returned the right (changed) value');
410	is($baz->bar, 50, '... baz->foo_bar delegated correctly');
411
412	# change the object we are delegating too
413
414	my $foo = Foo::Autoloaded->new;
415	isa_ok($foo, 'Foo::Autoloaded');
416
417	$foo->bar(25);
418
419	is($foo->bar, 25, '... got the right foo->bar');
420
421	lives_ok {
422	$baz->foo($foo);
423	} '... assigned the new Foo to Baz->foo';
424
425	is($baz->foo, $foo, '... assigned baz->foo with the new Foo');
426
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');
429	}
430
431	# Check that removing attributes removes their handles methods also.
432	{
433	{
434	package Quux;
435	use Mouse;
436	has foo => (
437	isa => 'Foo',
438	default => sub { Foo->new },
439	handles => { 'foo_bar' => 'bar' }
440	);
441	}
442	my $i = Quux->new;
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');
446	}
447
448	# Make sure that a useful error message is thrown when the delegation target is
449	# not an object
450	{
451	my $i = Bar->new(foo => undef);
452	throws_ok { $i->foo_bar } qr/is not defined/,
453	'useful error from unblessed reference';
454
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';
458
459	my $k = Bar->new(foo => "Foo");
460	lives_ok { $k->foo_baz } "but not for class name";
461	}
fde8e43f	462
fde8e43f	463	done_testing;