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

#!/usr/bin/perl

use strict;
use warnings;

use Test::More tests => 86;
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);    

    package Bar;
    use Moose; 
    
    has 'foo' => (
        is      => 'rw',
        default => sub { Foo->new },
        handles => { 'foo_bar' => 'bar' }
    );
}

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

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

# -------------------------------------------------------------------
# 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');
}
Commit	Line	Data
452bac1b	1	#!/usr/bin/perl
	2
	3	use strict;
	4	use warnings;
	5
01cd78f8	6	use Test::More tests => 86;
452bac1b	7	use Test::Exception;
452bac1b	8
7ff56534	9
452bac1b	10
f4f3e701	11	# -------------------------------------------------------------------
	12	# HASH handles
	13	# -------------------------------------------------------------------
452bac1b	14	# the canonical form of of the 'handles'
	15	# option is the hash ref mapping a
	16	# method name to the delegated method name
	17
	18	{
	19	package Foo;
452bac1b	20	use Moose;
	21
	22	has 'bar' => (is => 'rw', default => 10);
	23
	24	package Bar;
452bac1b	25	use Moose;
	26
	27	has 'foo' => (
	28	is => 'rw',
	29	default => sub { Foo->new },
	30	handles => { 'foo_bar' => 'bar' }
	31	);
	32	}
	33
	34	my $bar = Bar->new;
	35	isa_ok($bar, 'Bar');
	36
	37	ok($bar->foo, '... we have something in bar->foo');
	38	isa_ok($bar->foo, 'Foo');
	39
01cd78f8	40	my $meth = Bar->meta->get_method('foo_bar');
	41	isa_ok($meth, 'Moose::Meta::Method::Delegation');
	42	is($meth->associated_attribute->name, 'foo',
	43	'associated_attribute->name for this method is foo');
a05f85c1	44
452bac1b	45	is($bar->foo->bar, 10, '... bar->foo->bar returned the right default');
	46
	47	can_ok($bar, 'foo_bar');
	48	is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly');
	49
f4f3e701	50	# change the value ...
	51
	52	$bar->foo->bar(30);
	53
	54	# and make sure the delegation picks it up
	55
	56	is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
	57	is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
	58
	59	# change the value through the delegation ...
	60
	61	$bar->foo_bar(50);
	62
	63	# and make sure everyone sees it
	64
	65	is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
	66	is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
	67
	68	# change the object we are delegating too
	69
452bac1b	70	my $foo = Foo->new(bar => 25);
	71	isa_ok($foo, 'Foo');
	72
	73	is($foo->bar, 25, '... got the right foo->bar');
	74
	75	lives_ok {
	76	$bar->foo($foo);
	77	} '... assigned the new Foo to Bar->foo';
	78
	79	is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
	80
	81	is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
	82	is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
	83
f4f3e701	84	# -------------------------------------------------------------------
	85	# ARRAY handles
	86	# -------------------------------------------------------------------
452bac1b	87	# we also support an array based format
	88	# which assumes that the name is the same
	89	# on either end
	90
	91	{
	92	package Engine;
452bac1b	93	use Moose;
	94
	95	sub go { 'Engine::go' }
	96	sub stop { 'Engine::stop' }
	97
	98	package Car;
452bac1b	99	use Moose;
	100
	101	has 'engine' => (
	102	is => 'rw',
	103	default => sub { Engine->new },
	104	handles => [ 'go', 'stop' ]
	105	);
	106	}
	107
	108	my $car = Car->new;
	109	isa_ok($car, 'Car');
	110
	111	isa_ok($car->engine, 'Engine');
	112	can_ok($car->engine, 'go');
	113	can_ok($car->engine, 'stop');
	114
	115	is($car->engine->go, 'Engine::go', '... got the right value from ->engine->go');
	116	is($car->engine->stop, 'Engine::stop', '... got the right value from ->engine->stop');
	117
	118	can_ok($car, 'go');
	119	can_ok($car, 'stop');
	120
	121	is($car->go, 'Engine::go', '... got the right value from ->go');
	122	is($car->stop, 'Engine::stop', '... got the right value from ->stop');
	123
f4f3e701	124	# -------------------------------------------------------------------
	125	# REGEXP handles
	126	# -------------------------------------------------------------------
452bac1b	127	# and we support regexp delegation
	128
	129	{
	130	package Baz;
452bac1b	131	use Moose;
	132
	133	sub foo { 'Baz::foo' }
	134	sub bar { 'Baz::bar' }
	135	sub boo { 'Baz::boo' }
	136
	137	package Baz::Proxy1;
452bac1b	138	use Moose;
	139
	140	has 'baz' => (
	141	is => 'ro',
	142	isa => 'Baz',
	143	default => sub { Baz->new },
	144	handles => qr/.*/
	145	);
	146
	147	package Baz::Proxy2;
452bac1b	148	use Moose;
	149
	150	has 'baz' => (
	151	is => 'ro',
	152	isa => 'Baz',
	153	default => sub { Baz->new },
	154	handles => qr/.oo/
	155	);
	156
	157	package Baz::Proxy3;
452bac1b	158	use Moose;
	159
	160	has 'baz' => (
	161	is => 'ro',
	162	isa => 'Baz',
	163	default => sub { Baz->new },
	164	handles => qr/b.*/
	165	);
	166	}
	167
	168	{
	169	my $baz_proxy = Baz::Proxy1->new;
	170	isa_ok($baz_proxy, 'Baz::Proxy1');
	171
	172	can_ok($baz_proxy, 'baz');
	173	isa_ok($baz_proxy->baz, 'Baz');
	174
	175	can_ok($baz_proxy, 'foo');
	176	can_ok($baz_proxy, 'bar');
	177	can_ok($baz_proxy, 'boo');
	178
	179	is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value');
	180	is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
	181	is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
	182	}
	183	{
	184	my $baz_proxy = Baz::Proxy2->new;
	185	isa_ok($baz_proxy, 'Baz::Proxy2');
	186
	187	can_ok($baz_proxy, 'baz');
	188	isa_ok($baz_proxy->baz, 'Baz');
	189
	190	can_ok($baz_proxy, 'foo');
	191	can_ok($baz_proxy, 'boo');
	192
	193	is($baz_proxy->foo, 'Baz::foo', '... 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::Proxy3->new;
	198	isa_ok($baz_proxy, 'Baz::Proxy3');
	199
	200	can_ok($baz_proxy, 'baz');
	201	isa_ok($baz_proxy->baz, 'Baz');
	202
	203	can_ok($baz_proxy, 'bar');
	204	can_ok($baz_proxy, 'boo');
	205
	206	is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
	207	is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
	208	}
	209
f4f3e701	210	# -------------------------------------------------------------------
	211	# ROLE handles
	212	# -------------------------------------------------------------------
	213
c84f324f	214	{
	215	package Foo::Bar;
	216	use Moose::Role;
	217
	218	requires 'foo';
	219	requires 'bar';
	220
	221	package Foo::Baz;
	222	use Moose;
	223
	224	sub foo { 'Foo::Baz::FOO' }
	225	sub bar { 'Foo::Baz::BAR' }
	226	sub baz { 'Foo::Baz::BAZ' }
	227
	228	package Foo::Thing;
	229	use Moose;
	230
	231	has 'thing' => (
	232	is => 'rw',
	233	isa => 'Foo::Baz',
	234	handles => 'Foo::Bar',
	235	);
	236
	237	}
	238
	239	{
	240	my $foo = Foo::Thing->new(thing => Foo::Baz->new);
	241	isa_ok($foo, 'Foo::Thing');
	242	isa_ok($foo->thing, 'Foo::Baz');
	243
	244	ok($foo->meta->has_method('foo'), '... we have the method we expect');
	245	ok($foo->meta->has_method('bar'), '... we have the method we expect');
	246	ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect');
	247
	248	is($foo->foo, 'Foo::Baz::FOO', '... got the right value');
	249	is($foo->bar, 'Foo::Baz::BAR', '... got the right value');
	250	is($foo->thing->baz, 'Foo::Baz::BAZ', '... got the right value');
	251	}
	252
e902b1a5	253	# -------------------------------------------------------------------
	254	# AUTOLOAD & handles
	255	# -------------------------------------------------------------------
	256
	257	{
	258	package Foo::Autoloaded;
	259	use Moose;
	260
	261	sub AUTOLOAD {
	262	my $self = shift;
	263
	264	my $name = our $AUTOLOAD;
	265	$name =~ s/.*://; # strip fully-qualified portion
	266
	267	if (@_) {
	268	return $self->{$name} = shift;
	269	} else {
	270	return $self->{$name};
	271	}
	272	}
	273
	274	package Bar::Autoloaded;
	275	use Moose;
	276
	277	has 'foo' => (
	278	is => 'rw',
	279	default => sub { Foo::Autoloaded->new },
	280	handles => { 'foo_bar' => 'bar' }
	281	);
	282
	283	package Baz::Autoloaded;
	284	use Moose;
	285
	286	has 'foo' => (
	287	is => 'rw',
	288	default => sub { Foo::Autoloaded->new },
	289	handles => ['bar']
	290	);
	291
	292	package Goorch::Autoloaded;
	293	use Moose;
	294
	295	::dies_ok {
	296	has 'foo' => (
	297	is => 'rw',
	298	default => sub { Foo::Autoloaded->new },
	299	handles => qr/bar/
	300	);
	301	} '... you cannot delegate to AUTOLOADED class with regexp';
	302	}
	303
	304	# check HASH based delegation w/ AUTOLOAD
	305
	306	{
	307	my $bar = Bar::Autoloaded->new;
	308	isa_ok($bar, 'Bar::Autoloaded');
	309
	310	ok($bar->foo, '... we have something in bar->foo');
	311	isa_ok($bar->foo, 'Foo::Autoloaded');
	312
	313	# change the value ...
	314
	315	$bar->foo->bar(30);
	316
317	# and make sure the delegation picks it up
318
319	is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
320	is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
321
322	# change the value through the delegation ...
323
324	$bar->foo_bar(50);
325
326	# and make sure everyone sees it
327
328	is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
329	is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
330
331	# change the object we are delegating too
332
333	my $foo = Foo::Autoloaded->new;
334	isa_ok($foo, 'Foo::Autoloaded');
335
336	$foo->bar(25);
337
338	is($foo->bar, 25, '... got the right foo->bar');
339
340	lives_ok {
341	$bar->foo($foo);
342	} '... assigned the new Foo to Bar->foo';
343
344	is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
345
346	is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
347	is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
348	}
349
350	# check ARRAY based delegation w/ AUTOLOAD
351
352	{
353	my $baz = Baz::Autoloaded->new;
354	isa_ok($baz, 'Baz::Autoloaded');
355
356	ok($baz->foo, '... we have something in baz->foo');
357	isa_ok($baz->foo, 'Foo::Autoloaded');
358
359	# change the value ...
360
361	$baz->foo->bar(30);
362
363	# and make sure the delegation picks it up
364
365	is($baz->foo->bar, 30, '... baz->foo->bar returned the right (changed) value');
366	is($baz->bar, 30, '... baz->foo_bar delegated correctly');
367
368	# change the value through the delegation ...
369
370	$baz->bar(50);
371
372	# and make sure everyone sees it
373
374	is($baz->foo->bar, 50, '... baz->foo->bar returned the right (changed) value');
375	is($baz->bar, 50, '... baz->foo_bar delegated correctly');
376
377	# change the object we are delegating too
378
379	my $foo = Foo::Autoloaded->new;
380	isa_ok($foo, 'Foo::Autoloaded');
381
382	$foo->bar(25);
383
384	is($foo->bar, 25, '... got the right foo->bar');
385
386	lives_ok {
387	$baz->foo($foo);
388	} '... assigned the new Foo to Baz->foo';
389
390	is($baz->foo, $foo, '... assigned baz->foo with the new Foo');
391
392	is($baz->foo->bar, 25, '... baz->foo->bar returned the right result');
393	is($baz->bar, 25, '... and baz->foo_bar delegated correctly again');
394	}