X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FPerl%2FCritic%2FPolicy%2FDynamicMoose%2FClassOverridesRole.pm;h=3b5d040bf4077ee8d9885be6cf2134c1a4da98e6;hb=refs%2Fheads%2Fmaster;hp=361b55f2c9d77f8de7bbf0c3fab4bdc9e31c7913;hpb=042287b0ebb0be52677063e39cfb9ba5b5d2abd7;p=gitmo%2FPerl-Critic-Dynamic-Moose.git

diff --git a/lib/Perl/Critic/Policy/DynamicMoose/ClassOverridesRole.pm b/lib/Perl/Critic/Policy/DynamicMoose/ClassOverridesRole.pm
index 361b55f..3b5d040 100644
--- a/lib/Perl/Critic/Policy/DynamicMoose/ClassOverridesRole.pm
+++ b/lib/Perl/Critic/Policy/DynamicMoose/ClassOverridesRole.pm
@@ -1,17 +1,43 @@
 package Perl::Critic::Policy::DynamicMoose::ClassOverridesRole;
 use Moose;
-extends 'Perl::Critic::Policy::DynamicMoose';
+extends 'Perl::Critic::DynamicMoosePolicy';
 
 use Perl::Critic::Utils ':severities';
 
-Readonly::Scalar my $EXPL => q{};
+Readonly::Scalar my $EXPL => q{Explicitly exclude overriden methods};
 sub default_severity { $SEVERITY_MEDIUM }
 
+# Class::MOP::Class has no roles
+sub applies_to_metaclass { 'Moose::Meta::Class' }
+
 sub violates_metaclass {
-    my $self = shift;
-    my $meta = shift;
+    my $self  = shift;
+    my $class = shift;
+
+    my @violations;
+
+    for my $application ($class->role_applications) {
+        my $role = $application->role;
+        for my $method ($role->get_method_list) {
+            next if $application->is_method_excluded($method);
+            next if $application->is_method_aliased($method);
+
+            my $method_object = $class->get_method($method)
+                or next;
+
+            if ($method_object->isa('Moose::Meta::Role::Method')) {
+                next if $method_object->body == $role->get_method($method)->body;
+            }
+
+            my $class_name = $class->name;
+            my $role_name  = $role->name;
+
+            my $desc = "Class '$class_name' method '$method' implicitly overrides the same method from role '$role_name'";
+            push @violations, $self->violation($desc, $EXPL);
+        }
+    }
 
-    return;
+    return @violations;
 }
 
 no Moose;