use strict;
use warnings;
-use Mouse::Util qw(not_supported);
+use Mouse::Util qw(not_supported english_list);
use base qw(Mouse::Meta::Module);
sub method_metaclass(){ 'Mouse::Meta::Role::Method' } # required for get_method()
sub combine_apply {
my(undef, $class, @roles) = @_;
+ # check conflicting
+ my %method_provided;
+ my @method_conflicts;
+ my %attr_provided;
+ my %override_provided;
+
+ foreach my $role_spec (@roles) {
+ my $role = $role_spec->[0]->meta;
+ my $role_name = $role->name;
+
+ # methods
+ foreach my $method_name($role->get_method_list){
+ next if $class->has_method($method_name); # manually resolved
+
+ my $code = do{ no strict 'refs'; \&{ $role_name . '::' . $method_name } };
+
+ my $c = $method_provided{$method_name};
+
+ if($c && $c->[0] != $code){
+ push @{$c}, $role;
+ push @method_conflicts, $c;
+ }
+ else{
+ $method_provided{$method_name} = [$code, $method_name, $role];
+ }
+ }
+
+ # attributes
+ foreach my $attr_name($role->get_attribute_list){
+ my $attr = $role->get_attribute($attr_name);
+ my $c = $attr_provided{$attr_name};
+ if($c && $c != $attr){
+ $class->throw_error("We have encountered an attribute conflict with '$attr_name' "\r
+ . "during composition. This is fatal error and cannot be disambiguated.")
+ }
+ else{
+ $attr_provided{$attr_name} = $attr;
+ }
+ }
+
+ # override modifiers
+ foreach my $method_name($role->get_method_modifier_list('override')){
+ my $override = $role->get_override_method_modifier($method_name);
+ my $c = $override_provided{$method_name};
+ if($c && $c != $override){
+ $class->throw_error( "We have encountered an 'override' method conflict with '$method_name' during "\r
+ . "composition (Two 'override' methods of the same name encountered). "\r
+ . "This is fatal error.")
+ }
+ else{
+ $override_provided{$method_name} = $override;
+ }
+ }
+ }
+ if(@method_conflicts){
+ my $error;
+
+ if(@method_conflicts == 1){
+ my($code, $method_name, @roles) = @{$method_conflicts[0]};
+ $class->throw_error(
+ sprintf q{Due to a method name conflict in roles %s, the method '%s' must be implemented or excluded by '%s'},
+ english_list(map{ sprintf q{'%s'}, $_->name } @roles), $method_name, $class->name
+ );
+ }
+ else{
+ @method_conflicts = sort { $a->[0] cmp $b->[0] } @method_conflicts; # to avoid hash-ordering bugs
+ my $methods = english_list(map{ sprintf q{'%s'}, $_->[1] } @method_conflicts);
+ my $roles = english_list(
+ map{ sprintf q{'%s'}, $_->name }
+ map{ my($code, $method_name, @roles) = @{$_}; @roles } @method_conflicts
+ );
+
+ $class->throw_error(
+ sprintf q{Due to method name conflicts in roles %s, the methods %s must be implemented or excluded by '%s'},
+ $roles, $methods, $class->name
+ );
+ }
+ }
+
foreach my $role_spec (@roles) {
my($role_name, $args) = @{$role_spec};
sub add_override_method_modifier{
my($self, $method_name, $method) = @_;
- (!$self->has_method($method_name))\r
- || $self->throw_error("Cannot add an override of method '$method_name' " .\r
- "because there is a local version of '$method_name'");
+ if($self->has_method($method_name)){
+ # This error happens in the override keyword or during role composition,
+ # so I added a message, "A local method of ...", only for compatibility (gfx)
+ $self->throw_error("Cannot add an override of method '$method_name' "\r
+ . "because there is a local version of '$method_name'"
+ . "(A local method of the same name as been found)");
+ }
$self->{override_method_modifiers}->{$method_name} = $method;
}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 88;
+use Test::Exception;
+
+=pod
+
+Mutually recursive roles.
+
+=cut
+
+{
+ package Role::Foo;
+ use Mouse::Role;
+
+ requires 'foo';
+
+ sub bar { 'Role::Foo::bar' }
+
+ package Role::Bar;
+ use Mouse::Role;
+
+ requires 'bar';
+
+ sub foo { 'Role::Bar::foo' }
+}
+
+{
+ package My::Test1;
+ use Mouse;
+
+ ::lives_ok {
+ with 'Role::Foo', 'Role::Bar';
+ } '... our mutually recursive roles combine okay';
+
+ package My::Test2;
+ use Mouse;
+
+ ::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 Mouse::Role;
+
+ sub bling { 'Role::Bling::bling' }
+
+ package Role::Bling::Bling;
+ use Mouse::Role;
+
+ sub bling { 'Role::Bling::Bling::bling' }
+}
+
+{
+ package My::Test3;
+ use Mouse;
+
+ ::throws_ok {
+ with 'Role::Bling', 'Role::Bling::Bling';
+ } qr/Due to a method name conflict in roles 'Role::Bling' and 'Role::Bling::Bling', the method 'bling' must be implemented or excluded by 'My::Test3'/, '... role methods conflict and method was required';
+
+ package My::Test4;
+ use Mouse;
+
+ ::lives_ok {
+ with 'Role::Bling';
+ with 'Role::Bling::Bling';
+ } '... role methods didnt conflict when manually combined';
+
+ package My::Test5;
+ use Mouse;
+
+ ::lives_ok {
+ with 'Role::Bling::Bling';
+ with 'Role::Bling';
+ } '... role methods didnt conflict when manually combined (in opposite order)';
+
+ package My::Test6;
+ use Mouse;
+
+ ::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');
+
+ok(!My::Test3->does('Role::Bling'), '... our class does() the correct roles');
+ok(!My::Test3->does('Role::Bling::Bling'), '... our class does() the correct roles');
+ok(My::Test4->does('Role::Bling'), '... our class does() the correct roles');
+ok(My::Test4->does('Role::Bling::Bling'), '... our class does() the correct roles');
+ok(My::Test5->does('Role::Bling'), '... our class does() the correct roles');
+ok(My::Test5->does('Role::Bling::Bling'), '... our class does() the correct roles');
+ok(My::Test6->does('Role::Bling'), '... our class does() the correct roles');
+ok(My::Test6->does('Role::Bling::Bling'), '... our class does() the correct roles');
+
+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 Mouse::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->meta->does_role('Role::Bling::Bling'), '... our role correctly does() the other role');
+ok(Role::Bling::Bling::Bling->meta->has_method('bling'), '... dont have 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 Mouse::Role;
+
+ has 'ghost' => (is => 'ro', default => 'Role::Boo::ghost');
+
+ package Role::Boo::Hoo;
+ use Mouse::Role;
+
+ has 'ghost' => (is => 'ro', default => 'Role::Boo::Hoo::ghost');
+}
+
+{
+ package My::Test7;
+ use Mouse;
+
+ ::throws_ok {
+ with 'Role::Boo', 'Role::Boo::Hoo';
+ } qr/We have encountered an attribute conflict/,
+ '... role attrs conflict and method was required';
+
+ package My::Test8;
+ use Mouse;
+
+ ::lives_ok {
+ with 'Role::Boo';
+ with 'Role::Boo::Hoo';
+ } '... role attrs didnt conflict when manually combined';
+
+ package My::Test9;
+ use Mouse;
+
+ ::lives_ok {
+ with 'Role::Boo::Hoo';
+ with 'Role::Boo';
+ } '... role attrs didnt conflict when manually combined';
+
+ package My::Test10;
+ use Mouse;
+
+ has 'ghost' => (is => 'ro', default => 'My::Test10::ghost');
+
+ ::throws_ok {
+ with 'Role::Boo', 'Role::Boo::Hoo';
+ } qr/We have encountered an attribute conflict/,
+ '... role attrs conflict 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)');
+
+ok(!My::Test7->does('Role::Boo'), '... our class does() the correct roles');
+ok(!My::Test7->does('Role::Boo::Hoo'), '... our class does() the correct roles');
+ok(My::Test8->does('Role::Boo'), '... our class does() the correct roles');
+ok(My::Test8->does('Role::Boo::Hoo'), '... our class does() the correct roles');
+ok(My::Test9->does('Role::Boo'), '... our class does() the correct roles');
+ok(My::Test9->does('Role::Boo::Hoo'), '... our class does() the correct roles');
+ok(!My::Test10->does('Role::Boo'), '... our class does() the correct roles');
+ok(!My::Test10->does('Role::Boo::Hoo'), '... our class does() the correct roles');
+
+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::Plot;
+ use Mouse::Role;
+
+ override 'twist' => sub {
+ super() . ' -> Role::Plot::twist';
+ };
+
+ package Role::Truth;
+ use Mouse::Role;
+
+ override 'twist' => sub {
+ super() . ' -> Role::Truth::twist';
+ };
+}
+
+{
+ package My::Test::Base;
+ use Mouse;
+
+ sub twist { 'My::Test::Base::twist' }
+
+ package My::Test11;
+ use Mouse;
+
+ extends 'My::Test::Base';
+
+ ::lives_ok {
+ with 'Role::Truth';
+ } '... composed the role with override okay';
+
+ package My::Test12;
+ use Mouse;
+
+ extends 'My::Test::Base';
+
+ ::lives_ok {
+ with 'Role::Plot';
+ } '... composed the role with override okay';
+
+ package My::Test13;
+ use Mouse;
+
+ ::dies_ok {
+ with 'Role::Plot';
+ } '... cannot compose it because we have no superclass';
+
+ package My::Test14;
+ use Mouse;
+
+ extends 'My::Test::Base';
+
+ ::throws_ok {
+ with 'Role::Plot', 'Role::Truth';
+ } 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');
+
+ok(!My::Test11->does('Role::Plot'), '... our class does() the correct roles');
+ok(My::Test11->does('Role::Truth'), '... our class does() the correct roles');
+ok(!My::Test12->does('Role::Truth'), '... our class does() the correct roles');
+ok(My::Test12->does('Role::Plot'), '... our class does() the correct roles');
+ok(!My::Test13->does('Role::Plot'), '... our class does() the correct roles');
+ok(!My::Test14->does('Role::Truth'), '... our class does() the correct roles');
+ok(!My::Test14->does('Role::Plot'), '... our class does() the correct roles');
+
+is(My::Test11->twist(), 'My::Test::Base::twist -> Role::Truth::twist', '... got the right method return');
+is(My::Test12->twist(), 'My::Test::Base::twist -> Role::Plot::twist', '... got the right method return');
+ok(!My::Test13->can('twist'), '... no twist method here at all');
+is(My::Test14->twist(), 'My::Test::Base::twist', '... got the right method return (from superclass)');
+
+{
+ package Role::Reality;
+ use Mouse::Role;
+
+ ::throws_ok {
+ with 'Role::Plot';
+ } qr/A local method of the same name as been found/,
+ '... could not compose roles here, it dies';
+
+ sub twist {
+ 'Role::Reality::twist';
+ }
+}
+
+ok(Role::Reality->meta->has_method('twist'), '... the twist method has not been added');
+#ok(!Role::Reality->meta->does_role('Role::Plot'), '... our role does() the correct roles');
+is(Role::Reality->meta->get_method('twist')->(),
+ 'Role::Reality::twist',
+ '... the twist method returns the right value');
+
+# Ovid's test case from rt.cpan.org #44
+{
+ package Role1;
+ use Mouse::Role;
+
+ sub foo {}
+}
+{
+ package Role2;
+ use Mouse::Role;
+
+ sub foo {}
+}
+{
+ package Conflicts;
+ use Mouse;
+
+ ::throws_ok {
+ with qw(Role1 Role2);
+ } qr/Due to a method name conflict in roles 'Role1' and 'Role2', the method 'foo' must be implemented or excluded by 'Conflicts'/;
+}
+
+=pod
+
+Role conflicts between attributes and methods
+
+[15:23] <kolibrie> when class defines method and role defines method, class wins
+[15:24] <kolibrie> when class 'has' method and role defines method, class wins
+[15:24] <kolibrie> when class defines method and role 'has' method, role wins
+[15:24] <kolibrie> when class 'has' method and role 'has' method, role wins
+[15:24] <kolibrie> which means when class 'has' method and two roles 'has' method, no tiebreak is detected
+[15:24] <perigrin> this is with role and has declaration in the exact same order in every case?
+[15:25] <kolibrie> yes
+[15:25] <perigrin> interesting
+[15:25] <kolibrie> that's what I thought
+[15:26] <kolibrie> does that sound like something I should write a test for?
+[15:27] <perigrin> stevan, ping?
+[15:27] <perigrin> I'm not sure what the right answer for composition is.
+[15:27] <perigrin> who should win
+[15:27] <perigrin> if I were to guess I'd say the class should always win.
+[15:27] <kolibrie> that would be my guess, but I thought I would ask to make sure
+[15:29] <stevan> kolibrie: please write a test
+[15:29] <stevan> I am not exactly sure who should win either,.. but I suspect it is not working correctly right now
+[15:29] <stevan> I know exactly why it is doing what it is doing though
+
+Now I have to decide actually what happens, and how to fix it.
+- SL
+
+{
+ package Role::Method;
+ use Mouse::Role;
+
+ sub ghost { 'Role::Method::ghost' }
+
+ package Role::Method2;
+ use Mouse::Role;
+
+ sub ghost { 'Role::Method2::ghost' }
+
+ package Role::Attribute;
+ use Mouse::Role;
+
+ has 'ghost' => (is => 'ro', default => 'Role::Attribute::ghost');
+
+ package Role::Attribute2;
+ use Mouse::Role;
+
+ has 'ghost' => (is => 'ro', default => 'Role::Attribute2::ghost');
+}
+
+{
+ package My::Test15;
+ use Mouse;
+
+ ::lives_ok {
+ with 'Role::Method';
+ } '... composed the method role into the method class';
+
+ sub ghost { 'My::Test15::ghost' }
+
+ package My::Test16;
+ use Mouse;
+
+ ::lives_ok {
+ with 'Role::Method';
+ } '... composed the method role into the attribute class';
+
+ has 'ghost' => (is => 'ro', default => 'My::Test16::ghost');
+
+ package My::Test17;
+ use Mouse;
+
+ ::lives_ok {
+ with 'Role::Attribute';
+ } '... composed the attribute role into the method class';
+
+ sub ghost { 'My::Test17::ghost' }
+
+ package My::Test18;
+ use Mouse;
+
+ ::lives_ok {
+ with 'Role::Attribute';
+ } '... composed the attribute role into the attribute class';
+
+ has 'ghost' => (is => 'ro', default => 'My::Test18::ghost');
+
+ package My::Test19;
+ use Mouse;
+
+ ::lives_ok {
+ with 'Role::Method', 'Role::Method2';
+ } '... composed method roles into class with method tiebreaker';
+
+ sub ghost { 'My::Test19::ghost' }
+
+ package My::Test20;
+ use Mouse;
+
+ ::lives_ok {
+ with 'Role::Method', 'Role::Method2';
+ } '... composed method roles into class with attribute tiebreaker';
+
+ has 'ghost' => (is => 'ro', default => 'My::Test20::ghost');
+
+ package My::Test21;
+ use Mouse;
+
+ ::lives_ok {
+ with 'Role::Attribute', 'Role::Attribute2';
+ } '... composed attribute roles into class with method tiebreaker';
+
+ sub ghost { 'My::Test21::ghost' }
+
+ package My::Test22;
+ use Mouse;
+
+ ::lives_ok {
+ with 'Role::Attribute', 'Role::Attribute2';
+ } '... composed attribute roles into class with attribute tiebreaker';
+
+ has 'ghost' => (is => 'ro', default => 'My::Test22::ghost');
+
+ package My::Test23;
+ use Mouse;
+
+ ::lives_ok {
+ with 'Role::Method', 'Role::Attribute';
+ } '... composed method and attribute role into class with method tiebreaker';
+
+ sub ghost { 'My::Test23::ghost' }
+
+ package My::Test24;
+ use Mouse;
+
+ ::lives_ok {
+ with 'Role::Method', 'Role::Attribute';
+ } '... composed method and attribute role into class with attribute tiebreaker';
+
+ has 'ghost' => (is => 'ro', default => 'My::Test24::ghost');
+
+ package My::Test25;
+ use Mouse;
+
+ ::lives_ok {
+ with 'Role::Attribute', 'Role::Method';
+ } '... composed attribute and method role into class with method tiebreaker';
+
+ sub ghost { 'My::Test25::ghost' }
+
+ package My::Test26;
+ use Mouse;
+
+ ::lives_ok {
+ with 'Role::Attribute', 'Role::Method';
+ } '... composed attribute and method role into class with attribute tiebreaker';
+
+ has 'ghost' => (is => 'ro', default => 'My::Test26::ghost');
+}
+
+my $test15 = My::Test15->new;
+isa_ok($test15, 'My::Test15');
+is($test15->ghost, 'My::Test15::ghost', '... we access the method from the class and ignore the role method');
+
+my $test16 = My::Test16->new;
+isa_ok($test16, 'My::Test16');
+is($test16->ghost, 'My::Test16::ghost', '... we access the attribute from the class and ignore the role method');
+
+my $test17 = My::Test17->new;
+isa_ok($test17, 'My::Test17');
+is($test17->ghost, 'My::Test17::ghost', '... we access the method from the class and ignore the role attribute');
+
+my $test18 = My::Test18->new;
+isa_ok($test18, 'My::Test18');
+is($test18->ghost, 'My::Test18::ghost', '... we access the attribute from the class and ignore the role attribute');
+
+my $test19 = My::Test19->new;
+isa_ok($test19, 'My::Test19');
+is($test19->ghost, 'My::Test19::ghost', '... we access the method from the class and ignore the role methods');
+
+my $test20 = My::Test20->new;
+isa_ok($test20, 'My::Test20');
+is($test20->ghost, 'My::Test20::ghost', '... we access the attribute from the class and ignore the role methods');
+
+my $test21 = My::Test21->new;
+isa_ok($test21, 'My::Test21');
+is($test21->ghost, 'My::Test21::ghost', '... we access the method from the class and ignore the role attributes');
+
+my $test22 = My::Test22->new;
+isa_ok($test22, 'My::Test22');
+is($test22->ghost, 'My::Test22::ghost', '... we access the attribute from the class and ignore the role attributes');
+
+my $test23 = My::Test23->new;
+isa_ok($test23, 'My::Test23');
+is($test23->ghost, 'My::Test23::ghost', '... we access the method from the class and ignore the role method and attribute');
+
+my $test24 = My::Test24->new;
+isa_ok($test24, 'My::Test24');
+is($test24->ghost, 'My::Test24::ghost', '... we access the attribute from the class and ignore the role method and attribute');
+
+my $test25 = My::Test25->new;
+isa_ok($test25, 'My::Test25');
+is($test25->ghost, 'My::Test25::ghost', '... we access the method from the class and ignore the role attribute and method');
+
+my $test26 = My::Test26->new;
+isa_ok($test26, 'My::Test26');
+is($test26->ghost, 'My::Test26::ghost', '... we access the attribute from the class and ignore the role attribute and method');
+
+=cut
projects / gitmo/Mouse.git / commitdiff