[gitmo/Moose.git] / t / 044_basic_role_composition.t

#!/usr/bin/perl

use strict;
use warnings;

use Test::More tests => 60;
use Test::Exception;

BEGIN {
    use_ok('Moose');
    use_ok('Moose::Role');    
}

=pod

Mutually recursive roles.

=cut

{
    package Role::Foo;
    use strict;
    use warnings;
    use Moose::Role;

    requires 'foo';
    
    sub bar { 'Role::Foo::bar' }
    
    package Role::Bar;
    use strict;
    use warnings;
    use Moose::Role;
    
    requires 'bar';
    
    sub foo { 'Role::Bar::foo' }    
}

{
    package My::Test1;
    use strict;
    use warnings;
    use Moose;
    
    ::lives_ok {
        with 'Role::Foo', 'Role::Bar';
    } '... our mutually recursive roles combine okay';
    
    package My::Test2;
    use strict;
    use warnings;
    use Moose;
    
    ::lives_ok {
        with 'Role::Bar', 'Role::Foo';
    } '... our mutually recursive roles combine okay (no matter what order)';    
}

my $test1 = My::Test1->new;
isa_ok($test1, 'My::Test1');

ok($test1->does('Role::Foo'), '... $test1 does Role::Foo');
ok($test1->does('Role::Bar'), '... $test1 does Role::Bar');

can_ok($test1, 'foo');
can_ok($test1, 'bar');

is($test1->foo, 'Role::Bar::foo', '... $test1->foo worked');
is($test1->bar, 'Role::Foo::bar', '... $test1->bar worked');

my $test2 = My::Test2->new;
isa_ok($test2, 'My::Test2');

ok($test2->does('Role::Foo'), '... $test2 does Role::Foo');
ok($test2->does('Role::Bar'), '... $test2 does Role::Bar');

can_ok($test2, 'foo');
can_ok($test2, 'bar');

is($test2->foo, 'Role::Bar::foo', '... $test2->foo worked');
is($test2->bar, 'Role::Foo::bar', '... $test2->bar worked');

# check some meta-stuff

ok(Role::Foo->meta->has_method('bar'), '... it still has the bar method');
ok(Role::Foo->meta->requires_method('foo'), '... it still has the required foo method');

ok(Role::Bar->meta->has_method('foo'), '... it still has the foo method');
ok(Role::Bar->meta->requires_method('bar'), '... it still has the required bar method');

=pod

Role method conflicts

=cut

{
    package Role::Bling;
    use strict;
    use warnings;
    use Moose::Role;
    
    sub bling { 'Role::Bling::bling' }
    
    package Role::Bling::Bling;
    use strict;
    use warnings;
    use Moose::Role;
    
    sub bling { 'Role::Bling::Bling::bling' }    
}

{
    package My::Test3;
    use strict;
    use warnings;
    use Moose;
    
    ::throws_ok {
        with 'Role::Bling', 'Role::Bling::Bling';
    } qr/requires the method \'bling\' to be implemented/, '... role methods conflicted and method was required';
    
    package My::Test4;
    use strict;
    use warnings;
    use Moose;
    
    ::lives_ok {
        with 'Role::Bling';
        with 'Role::Bling::Bling';
    } '... role methods didnt conflict when manually combined';    
    
    package My::Test5;
    use strict;
    use warnings;
    use Moose;
    
    ::lives_ok {
        with 'Role::Bling::Bling';
        with 'Role::Bling';
    } '... role methods didnt conflict when manually combined (in opposite order)';    
    
    package My::Test6;
    use strict;
    use warnings;
    use Moose;
    
    ::lives_ok {
        with 'Role::Bling::Bling', 'Role::Bling';
    } '... role methods didnt conflict when manually resolved';    
    
    sub bling { 'My::Test6::bling' }
}

ok(!My::Test3->meta->has_method('bling'), '... we didnt get any methods in the conflict');
ok(My::Test4->meta->has_method('bling'), '... we did get the method when manually dealt with');
ok(My::Test5->meta->has_method('bling'), '... we did get the method when manually dealt with');
ok(My::Test6->meta->has_method('bling'), '... we did get the method when manually dealt with');

is(My::Test4->bling, 'Role::Bling::bling', '... and we got the first method that was added');
is(My::Test5->bling, 'Role::Bling::Bling::bling', '... and we got the first method that was added');
is(My::Test6->bling, 'My::Test6::bling', '... and we got the local method');

# check how this affects role compostion

{
    package Role::Bling::Bling::Bling;
    use strict;
    use warnings;
    use Moose::Role;
    
    with 'Role::Bling::Bling';
    
    sub bling { 'Role::Bling::Bling::Bling::bling' }    
}

ok(Role::Bling::Bling->meta->has_method('bling'), '... still got the bling method in Role::Bling::Bling');
ok(Role::Bling::Bling::Bling->meta->has_method('bling'), '... still got the bling method in Role::Bling::Bling::Bling');
is(Role::Bling::Bling::Bling->meta->get_method('bling')->(), 
    'Role::Bling::Bling::Bling::bling',
    '... still got the bling method in Role::Bling::Bling::Bling');

=pod

Role attribute conflicts

=cut

{
    package Role::Boo;
    use strict;
    use warnings;
    use Moose::Role;
    
    has 'ghost' => (is => 'ro', default => 'Role::Boo::ghost');
    
    package Role::Boo::Hoo;
    use strict;
    use warnings;
    use Moose::Role;
    
    has 'ghost' => (is => 'ro', default => 'Role::Boo::Hoo::ghost');
}

{
    package My::Test7;
    use strict;
    use warnings;
    use Moose;
    
    ::throws_ok {
        with 'Role::Boo', 'Role::Boo::Hoo';
    } qr/Role \'Role::Boo::Hoo\' has encountered an attribute conflict/, 
      '... role attrs conflicted and method was required';

    package My::Test8;
    use strict;
    use warnings;
    use Moose;

    ::lives_ok {
        with 'Role::Boo';
        with 'Role::Boo::Hoo';
    } '... role attrs didnt conflict when manually combined';
    
    package My::Test9;
    use strict;
    use warnings;
    use Moose;

    ::lives_ok {
        with 'Role::Boo::Hoo';
        with 'Role::Boo';
    } '... role attrs didnt conflict when manually combined';    

    package My::Test10;
    use strict;
    use warnings;
    use Moose;
    
    has 'ghost' => (is => 'ro', default => 'My::Test10::ghost');    
    
    ::throws_ok {
        with 'Role::Boo', 'Role::Boo::Hoo';
    } qr/Role \'Role::Boo::Hoo\' has encountered an attribute conflict/, 
      '... role attrs conflicted and cannot be manually disambiguted';  

}

ok(!My::Test7->meta->has_attribute('ghost'), '... we didnt get any attributes in the conflict');
ok(My::Test8->meta->has_attribute('ghost'), '... we did get an attributes when manually composed');
ok(My::Test9->meta->has_attribute('ghost'), '... we did get an attributes when manually composed');
ok(My::Test10->meta->has_attribute('ghost'), '... we did still have an attribute ghost (conflict does not mess with class)');

can_ok('My::Test8', 'ghost');
can_ok('My::Test9', 'ghost');
can_ok('My::Test10', 'ghost');

is(My::Test8->new->ghost, 'Role::Boo::ghost', '... got the expected default attr value');
is(My::Test9->new->ghost, 'Role::Boo::Hoo::ghost', '... got the expected default attr value');
is(My::Test10->new->ghost, 'My::Test10::ghost', '... got the expected default attr value');

=pod

Role override method conflicts

=cut

{
    package Role::Spliff;
    use strict;
    use warnings;
    use Moose::Role;
    
    override 'twist' => sub {
        super() . ' -> Role::Spliff::twist';
    };
    
    package Role::Blunt;
    use strict;
    use warnings;
    use Moose::Role;
    
    override 'twist' => sub {
        super() . ' -> Role::Blunt::twist';
    };
}

{
    package My::Test::Base;
    use strict;
    use warnings;
    use Moose;
    
    sub twist { 'My::Test::Base::twist' }
        
    package My::Test11;
    use strict;
    use warnings;
    use Moose;
    
    extends 'My::Test::Base';

    ::lives_ok {
        with 'Role::Blunt';
    } '... composed the role with override okay';
       
    package My::Test12;
    use strict;
    use warnings;
    use Moose;

    extends 'My::Test::Base';

    ::lives_ok {    
       with 'Role::Spliff';
    } '... composed the role with override okay';
              
    package My::Test13;
    use strict;
    use warnings;
    use Moose;

    ::dies_ok {
        with 'Role::Spliff';       
    } '... cannot compose it because we have no superclass';
    
    package My::Test14;
    use strict;
    use warnings;
    use Moose;

    extends 'My::Test::Base';

    ::throws_ok {
        with 'Role::Spliff', 'Role::Blunt';       
    } qr/Two \'override\' methods of the same name encountered/, 
      '... cannot compose it because we have no superclass';    
}

ok(My::Test11->meta->has_method('twist'), '... the twist method has been added');
ok(My::Test12->meta->has_method('twist'), '... the twist method has been added');
ok(!My::Test13->meta->has_method('twist'), '... the twist method has not been added');
ok(!My::Test14->meta->has_method('twist'), '... the twist method has not been added');

is(My::Test11->twist(), 'My::Test::Base::twist -> Role::Blunt::twist', '... got the right method return');
is(My::Test12->twist(), 'My::Test::Base::twist -> Role::Spliff::twist', '... got the right method return');
Commit	Line	Data
db1ab48d	1	#!/usr/bin/perl
	2
	3	use strict;
	4	use warnings;
	5
d05cd563	6	use Test::More tests => 60;
db1ab48d	7	use Test::Exception;
	8
	9	BEGIN {
	10	use_ok('Moose');
	11	use_ok('Moose::Role');
	12	}
	13
	14	=pod
	15
	16	Mutually recursive roles.
	17
	18	=cut
	19
	20	{
	21	package Role::Foo;
	22	use strict;
	23	use warnings;
	24	use Moose::Role;
	25
	26	requires 'foo';
	27
	28	sub bar { 'Role::Foo::bar' }
	29
	30	package Role::Bar;
	31	use strict;
	32	use warnings;
	33	use Moose::Role;
	34
	35	requires 'bar';
	36
	37	sub foo { 'Role::Bar::foo' }
	38	}
	39
	40	{
	41	package My::Test1;
	42	use strict;
	43	use warnings;
	44	use Moose;
	45
	46	::lives_ok {
	47	with 'Role::Foo', 'Role::Bar';
	48	} '... our mutually recursive roles combine okay';
	49
	50	package My::Test2;
	51	use strict;
	52	use warnings;
	53	use Moose;
	54
	55	::lives_ok {
	56	with 'Role::Bar', 'Role::Foo';
	57	} '... our mutually recursive roles combine okay (no matter what order)';
	58	}
	59
	60	my $test1 = My::Test1->new;
	61	isa_ok($test1, 'My::Test1');
	62
	63	ok($test1->does('Role::Foo'), '... $test1 does Role::Foo');
	64	ok($test1->does('Role::Bar'), '... $test1 does Role::Bar');
	65
	66	can_ok($test1, 'foo');
	67	can_ok($test1, 'bar');
	68
	69	is($test1->foo, 'Role::Bar::foo', '... $test1->foo worked');
	70	is($test1->bar, 'Role::Foo::bar', '... $test1->bar worked');
71
72	my $test2 = My::Test2->new;
73	isa_ok($test2, 'My::Test2');
74
75	ok($test2->does('Role::Foo'), '... $test2 does Role::Foo');
76	ok($test2->does('Role::Bar'), '... $test2 does Role::Bar');
77
78	can_ok($test2, 'foo');
79	can_ok($test2, 'bar');
80
81	is($test2->foo, 'Role::Bar::foo', '... $test2->foo worked');
82	is($test2->bar, 'Role::Foo::bar', '... $test2->bar worked');
83
84	# check some meta-stuff
85
86	ok(Role::Foo->meta->has_method('bar'), '... it still has the bar method');
87	ok(Role::Foo->meta->requires_method('foo'), '... it still has the required foo method');
88
89	ok(Role::Bar->meta->has_method('foo'), '... it still has the foo method');
90	ok(Role::Bar->meta->requires_method('bar'), '... it still has the required bar method');
91
92	=pod
93
94	Role method conflicts
95
96	=cut
97
98	{
99	package Role::Bling;
100	use strict;
101	use warnings;
102	use Moose::Role;
103
104	sub bling { 'Role::Bling::bling' }
105
106	package Role::Bling::Bling;
107	use strict;
108	use warnings;
109	use Moose::Role;
110
111	sub bling { 'Role::Bling::Bling::bling' }
112	}
113
114	{
115	package My::Test3;
116	use strict;
117	use warnings;
118	use Moose;
119
120	::throws_ok {
121	with 'Role::Bling', 'Role::Bling::Bling';
122	} qr/requires the method \'bling\' to be implemented/, '... role methods conflicted and method was required';
123
124	package My::Test4;
125	use strict;
126	use warnings;
127	use Moose;
128
129	::lives_ok {
130	with 'Role::Bling';
131	with 'Role::Bling::Bling';
132	} '... role methods didnt conflict when manually combined';
133
134	package My::Test5;
135	use strict;
136	use warnings;
137	use Moose;
138
139	::lives_ok {
140	with 'Role::Bling::Bling';
141	with 'Role::Bling';
142	} '... role methods didnt conflict when manually combined (in opposite order)';
143
144	package My::Test6;
145	use strict;
146	use warnings;
147	use Moose;
148
149	::lives_ok {
150	with 'Role::Bling::Bling', 'Role::Bling';
151	} '... role methods didnt conflict when manually resolved';
152
153	sub bling { 'My::Test6::bling' }
154	}
155
156	ok(!My::Test3->meta->has_method('bling'), '... we didnt get any methods in the conflict');
157	ok(My::Test4->meta->has_method('bling'), '... we did get the method when manually dealt with');
158	ok(My::Test5->meta->has_method('bling'), '... we did get the method when manually dealt with');
159	ok(My::Test6->meta->has_method('bling'), '... we did get the method when manually dealt with');
160
161	is(My::Test4->bling, 'Role::Bling::bling', '... and we got the first method that was added');
162	is(My::Test5->bling, 'Role::Bling::Bling::bling', '... and we got the first method that was added');
163	is(My::Test6->bling, 'My::Test6::bling', '... and we got the local method');
164
165	# check how this affects role compostion
166
167	{
168	package Role::Bling::Bling::Bling;
169	use strict;
170	use warnings;
171	use Moose::Role;
172
173	with 'Role::Bling::Bling';
174
175	sub bling { 'Role::Bling::Bling::Bling::bling' }
176	}
177
178	ok(Role::Bling::Bling->meta->has_method('bling'), '... still got the bling method in Role::Bling::Bling');
179	ok(Role::Bling::Bling::Bling->meta->has_method('bling'), '... still got the bling method in Role::Bling::Bling::Bling');
d05cd563	180	is(Role::Bling::Bling::Bling->meta->get_method('bling')->(),
	181	'Role::Bling::Bling::Bling::bling',
	182	'... still got the bling method in Role::Bling::Bling::Bling');
db1ab48d	183
	184	=pod
	185
	186	Role attribute conflicts
	187
	188	=cut
	189
	190	{
	191	package Role::Boo;
	192	use strict;
	193	use warnings;
	194	use Moose::Role;
	195
	196	has 'ghost' => (is => 'ro', default => 'Role::Boo::ghost');
	197
	198	package Role::Boo::Hoo;
	199	use strict;
	200	use warnings;
	201	use Moose::Role;
	202
	203	has 'ghost' => (is => 'ro', default => 'Role::Boo::Hoo::ghost');
	204	}
	205
	206	{
	207	package My::Test7;
	208	use strict;
	209	use warnings;
	210	use Moose;
	211
	212	::throws_ok {
	213	with 'Role::Boo', 'Role::Boo::Hoo';
	214	} qr/Role \'Role::Boo::Hoo\' has encountered an attribute conflict/,
	215	'... role attrs conflicted and method was required';
	216
	217	package My::Test8;
	218	use strict;
	219	use warnings;
	220	use Moose;
	221
	222	::lives_ok {
	223	with 'Role::Boo';
	224	with 'Role::Boo::Hoo';
	225	} '... role attrs didnt conflict when manually combined';
	226
	227	package My::Test9;
	228	use strict;
	229	use warnings;
	230	use Moose;
	231
	232	::lives_ok {
	233	with 'Role::Boo::Hoo';
	234	with 'Role::Boo';
	235	} '... role attrs didnt conflict when manually combined';
	236
	237	package My::Test10;
	238	use strict;
	239	use warnings;
	240	use Moose;
	241
	242	has 'ghost' => (is => 'ro', default => 'My::Test10::ghost');
	243
	244	::throws_ok {
	245	with 'Role::Boo', 'Role::Boo::Hoo';
	246	} qr/Role \'Role::Boo::Hoo\' has encountered an attribute conflict/,
247	'... role attrs conflicted and cannot be manually disambiguted';
248
249	}
250
251	ok(!My::Test7->meta->has_attribute('ghost'), '... we didnt get any attributes in the conflict');
252	ok(My::Test8->meta->has_attribute('ghost'), '... we did get an attributes when manually composed');
253	ok(My::Test9->meta->has_attribute('ghost'), '... we did get an attributes when manually composed');
254	ok(My::Test10->meta->has_attribute('ghost'), '... we did still have an attribute ghost (conflict does not mess with class)');
255
256	can_ok('My::Test8', 'ghost');
257	can_ok('My::Test9', 'ghost');
258	can_ok('My::Test10', 'ghost');
259
260	is(My::Test8->new->ghost, 'Role::Boo::ghost', '... got the expected default attr value');
261	is(My::Test9->new->ghost, 'Role::Boo::Hoo::ghost', '... got the expected default attr value');
262	is(My::Test10->new->ghost, 'My::Test10::ghost', '... got the expected default attr value');
263
d05cd563	264	=pod
	265
	266	Role override method conflicts
	267
	268	=cut
	269
	270	{
	271	package Role::Spliff;
	272	use strict;
	273	use warnings;
	274	use Moose::Role;
	275
	276	override 'twist' => sub {
	277	super() . ' -> Role::Spliff::twist';
	278	};
	279
	280	package Role::Blunt;
	281	use strict;
	282	use warnings;
	283	use Moose::Role;
	284
	285	override 'twist' => sub {
	286	super() . ' -> Role::Blunt::twist';
	287	};
	288	}
	289
	290	{
	291	package My::Test::Base;
	292	use strict;
	293	use warnings;
	294	use Moose;
	295
	296	sub twist { 'My::Test::Base::twist' }
	297
	298	package My::Test11;
	299	use strict;
	300	use warnings;
	301	use Moose;
	302
	303	extends 'My::Test::Base';
	304
	305	::lives_ok {
	306	with 'Role::Blunt';
	307	} '... composed the role with override okay';
	308
	309	package My::Test12;
	310	use strict;
	311	use warnings;
	312	use Moose;
	313
	314	extends 'My::Test::Base';
	315
	316	::lives_ok {
	317	with 'Role::Spliff';
	318	} '... composed the role with override okay';
	319
	320	package My::Test13;
	321	use strict;
	322	use warnings;
	323	use Moose;
	324
	325	::dies_ok {
	326	with 'Role::Spliff';
	327	} '... cannot compose it because we have no superclass';
328
329	package My::Test14;
330	use strict;
331	use warnings;
332	use Moose;
333
334	extends 'My::Test::Base';
335
336	::throws_ok {
337	with 'Role::Spliff', 'Role::Blunt';
338	} qr/Two \'override\' methods of the same name encountered/,
339	'... cannot compose it because we have no superclass';
340	}
341
342	ok(My::Test11->meta->has_method('twist'), '... the twist method has been added');
343	ok(My::Test12->meta->has_method('twist'), '... the twist method has been added');
344	ok(!My::Test13->meta->has_method('twist'), '... the twist method has not been added');
345	ok(!My::Test14->meta->has_method('twist'), '... the twist method has not been added');
346
347	is(My::Test11->twist(), 'My::Test::Base::twist -> Role::Blunt::twist', '... got the right method return');
348	is(My::Test12->twist(), 'My::Test::Base::twist -> Role::Spliff::twist', '... got the right method return');
349
350
db1ab48d	351
db1ab48d	352