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

#!/usr/bin/perl

use strict;
use warnings;

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

isa_ok(Bar->meta->get_method('foo_bar'), 'Moose::Meta::Method::Delegation');

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