[gitmo/Moose.git] / t / attributes / attribute_delegation.t

#!/usr/bin/perl

use strict;
use warnings;

use Test::More;
use Test::Fatal;


# -------------------------------------------------------------------
# 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 }

    package Bar;
    use Moose;

    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, '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');

is( exception {
    $bar->foo($foo);
}, undef, '... 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 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',
    );

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

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

    ::isnt( ::exception {
        has 'foo' => (
            is      => 'rw',
            default => sub { Foo::Autoloaded->new },
            handles => qr/bar/
        );
    }, undef, '... 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');

    is( exception {
        $bar->foo($foo);
    }, undef, '... 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');

    is( exception {
        $baz->foo($foo);
    }, undef, '... 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);
    like( exception { $i->foo_bar }, qr/is not defined/, 'useful error from unblessed reference' );

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

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

{
    package Delegator;
    use Moose;

    sub full { 1 }
    sub stub;

    ::like(
        ::exception{ has d1 => (
                isa     => 'X',
                handles => ['full'],
            );
            },
        qr/\QYou cannot overwrite a locally defined method (full) with a delegation/,
        'got an error when trying to declare a delegation method that overwrites a local method'
    );

    ::is(
        ::exception{ has d2 => (
                isa     => 'X',
                handles => ['stub'],
            );
            },
        undef,
        'no error when trying to declare a delegation method that overwrites a stub method'
    );
}

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