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

#!/usr/bin/perl

use strict;
use warnings;

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

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