From: Matt S Trout <mst@shadowcat.co.uk>
Date: Thu, 19 Apr 2012 22:53:50 +0000 (+0000)
Subject: add an option to explicitly prohibit method shadowing
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=refs%2Fheads%2Fattic%2Frole-application-allow-shadow;p=gitmo%2FMoose.git

add an option to explicitly prohibit method shadowing
---

diff --git a/lib/Moose/Meta/Role/Application.pm b/lib/Moose/Meta/Role/Application.pm
index d9d4c2f..40c7e82 100644
--- a/lib/Moose/Meta/Role/Application.pm
+++ b/lib/Moose/Meta/Role/Application.pm
@@ -18,6 +18,13 @@ __PACKAGE__->meta->add_attribute('method_aliases' => (
     Class::MOP::_definition_context(),
 ));
 
+__PACKAGE__->meta->add_attribute('shadowing_prohibited' => (
+    init_arg => '-prohibit_shadowing',
+    reader => 'is_shadowing_prohibited',
+    default => sub { 0 },
+    Class::MOP::_definition_context(),
+));
+
 sub new {
     my ($class, %params) = @_;
     $class->_new(\%params);
diff --git a/lib/Moose/Meta/Role/Application/ToClass.pm b/lib/Moose/Meta/Role/Application/ToClass.pm
index 822d1e5..3e1dd8b 100644
--- a/lib/Moose/Meta/Role/Application/ToClass.pm
+++ b/lib/Moose/Meta/Role/Application/ToClass.pm
@@ -162,7 +162,15 @@ sub apply_methods {
 
             my $class_method = $class->get_method($method_name);
 
-            next if $class_method && $class_method->body != $method->body;
+            if ( $class_method && $class_method->body != $method->body ) {
+
+                if ( $self->is_shadowing_prohibited ) {
+                    $class->throw_error(
+                        "Shadowing is prohibited but both ".$class->name." and ".$role->name." have a method ${method_name}"
+                    );
+                }
+                next;
+            }
 
             $class->add_method(
                 $method_name,
diff --git a/lib/Moose/Meta/Role/Application/ToRole.pm b/lib/Moose/Meta/Role/Application/ToRole.pm
index 97ce038..5fd264b 100644
--- a/lib/Moose/Meta/Role/Application/ToRole.pm
+++ b/lib/Moose/Meta/Role/Application/ToRole.pm
@@ -87,7 +87,15 @@ sub apply_methods {
 
                 # method conflicts between roles used to result in the method
                 # becoming a requirement but now are permitted just like
-                # for classes, hence no code in this branch anymore.
+                # for classes, unless shadowing is explicitly prohibited
+
+                if ( $self->is_shadowing_prohibited ) {
+
+                     $role2->add_conflicting_method(
+                         name  => $method_name,
+                         roles => [ $role1->name, $role2->name ],
+                     );
+                }
             }
             else {
                 $role2->add_method(
diff --git a/t/roles/prohibit_shadowing.t b/t/roles/prohibit_shadowing.t
new file mode 100644
index 0000000..469301f
--- /dev/null
+++ b/t/roles/prohibit_shadowing.t
@@ -0,0 +1,51 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+{
+    package Role1;
+
+    use Moose::Role;
+
+    sub foo { }
+}
+
+{
+    package Role2;
+
+    use Moose::Role;
+
+    with 'Role1', { -prohibit_shadowing => 1 };
+
+    sub foo { }
+}
+
+{
+    package Class1;
+
+    use Moose;
+
+    ::ok(
+      ::exception { with 'Role1', { -prohibit_shadowing => 1 } },
+      'Shadowing prohibited role->class'
+    );
+
+    sub foo { }
+}
+
+{
+    package Class2;
+
+    use Moose;
+
+    ::ok(
+      ::exception { with 'Role2' },
+      'Shadowing prohibited role->role'
+    );
+}
+
+done_testing;