[gitmo/Moose.git] / t / 020_attributes / 010_attribute_delegation.t

#!/usr/bin/perl

use strict;
use warnings;

use Test::More;
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 Moose;

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

    sub baz { 42 }

    sub quux { confess }

    package Bar;
    use Moose;

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

sub test_hash_handles {
    my $bar = shift;
    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, 'Moose::Meta::Method::Delegation');
    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');
}

# Works with a mutable class

{
    test_hash_handles(Bar->new);
}

# Works with an immutable class and provides a meaningful backtrace

{
    Bar->meta->make_immutable;
    my $filename = __FILE__;
    my $bar = Bar->new;
    test_hash_handles($bar);
    throws_ok { $bar->foo_quux } qr/delegation of foo_quux to foo->quux/,
        'error location describes the delegation';
    throws_ok { $bar->foo_quux } qr/defined at $filename line \d+/,
        '... and points at where the handler is defined';
}

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

{
    package Engine;
    use Moose;

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

    package Car;
    use Moose;

    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 Moose;

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

    package Baz::Proxy1;
    use Moose;

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

    package Baz::Proxy2;
    use Moose;

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

    package Baz::Proxy3;
    use Moose;

    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 Moose::Role;

    requires 'foo';
    requires 'bar';

    package Foo::Baz;
    use Moose;

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

    package Foo::Thing;
    use Moose;

    has 'thing' => (
        is      => 'rw',
        isa     => 'Foo::Baz',
        handles => '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');
}

# -------------------------------------------------------------------
# AUTOLOAD & handles
# -------------------------------------------------------------------

{
    package Foo::Autoloaded;
    use Moose;

    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 Moose;

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

    package Baz::Autoloaded;
    use Moose;

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

    package Goorch::Autoloaded;
    use Moose;

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