Allow superclass to provide conflicting methods (RT#91054)

Conflicting methods are supposed to be treated as required by the
composed role, which can be satisfied by superclasses.

diff --git a/Changes b/Changes
index 045839c..06b8e8e 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,7 @@
 Revision history for Role-Tiny
 
+  - allow superclass to provide conflicting methods (RT#91054)
+
 1.003002 - 2013-09-04
   - abbreviate generated package names if they are longer than perl can handle
     (RT#83248)

diff --git a/lib/Role/Tiny.pm b/lib/Role/Tiny.pm
index a628cc7..a68e379 100644 (file)
--- a/lib/Role/Tiny.pm
+++ b/lib/Role/Tiny.pm
@@ -198,7 +198,9 @@ sub apply_roles_to_package {
   return $me->apply_role_to_package($to, $roles[0]) if @roles == 1;
 
   my %conflicts = %{$me->_composite_info_for(@roles)->{conflicts}};
-  delete $conflicts{$_} for keys %{ $me->_concrete_methods_of($to) };
+  my @have = grep $to->can($_), keys %conflicts;
+  delete @conflicts{@have};
+
   if (keys %conflicts) {
     my $fail = 
       join "\n",
@@ -210,6 +212,15 @@ sub apply_roles_to_package {
     die $fail;
   }
 
+  # conflicting methods are supposed to be treated as required by the
+  # composed role. we don't have an actual composed role, but because
+  # we know the target class already provides them, we can instead
+  # pretend that the roles don't do for the duration of application.
+  my @role_methods = map $me->_concrete_methods_of($_), @roles;
+  # separate loops, since local ..., delete ... for ...; creates a scope
+  local @{$_}{@have} for @role_methods;
+  delete @{$_}{@have} for @role_methods;
+
   # the if guard here is essential since otherwise we accidentally create
   # a $INFO for something that isn't a Role::Tiny (or Moo::Role) because
   # autovivification hates us and wants us to die()

diff --git a/t/role-basic-composition.t b/t/role-basic-composition.t
index a70fe4c..640dec7 100644 (file)
--- a/t/role-basic-composition.t
+++ b/t/role-basic-composition.t
@@ -201,4 +201,35 @@ SKIP: {
        is $success, 1, 'composed diamantly dependent roles successfully' or diag "Error: $@";
 }
 
+{
+    {
+        package My::Does::Conflict;
+        use Role::Tiny;
+
+        sub method {
+            return __PACKAGE__ . " method";
+        }
+    }
+    {
+        package My::Class::Base;
+
+        sub turbo_charger {
+            return __PACKAGE__ . " turbo charger";
+        }
+        sub method {
+            return __PACKAGE__ . " method";
+        }
+    }
+    my $success = eval q{
+        package My::Class::Child;
+        use base 'My::Class::Base';
+        use Role::Tiny::With;
+        with qw/My::Does::Basic1 My::Does::Conflict/;
+        1;
+    };
+    is $success, 1, 'role conflict resolved by superclass method' or diag "Error: $@";
+    can_ok 'My::Class::Child', 'method';
+    is My::Class::Child->method, 'My::Class::Base method', 'inherited method prevails';
+}
+
 done_testing;