From: Shawn M Moore <sartak@gmail.com>
Date: Tue, 28 Apr 2009 10:00:32 +0000 (-0400)
Subject: RequireMethodModifiers policy
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FPerl-Critic-Dynamic-Moose.git;a=commitdiff_plain;h=fe41192466c7a391cf8f66159e52612fd2b4d51d

RequireMethodModifiers policy
---

diff --git a/lib/Perl/Critic/Policy/DynamicMoose/RequireMethodModifiers.pm b/lib/Perl/Critic/Policy/DynamicMoose/RequireMethodModifiers.pm
new file mode 100644
index 0000000..561b5c8
--- /dev/null
+++ b/lib/Perl/Critic/Policy/DynamicMoose/RequireMethodModifiers.pm
@@ -0,0 +1,76 @@
+package Perl::Critic::Policy::DynamicMoose::RequireMethodModifiers;
+use Moose;
+extends 'Perl::Critic::Policy::DynamicMoose';
+
+use Perl::Critic::Utils ':severities';
+use Perl::Critic::Utils::Moose 'meta_type';
+
+Readonly::Scalar my $EXPL => q{Method modifiers make it clear that you're overriding methods.};
+sub default_severity { $SEVERITY_LOW }
+
+sub violates_metaclass {
+    my $self = shift;
+    my $meta = shift;
+
+    my @violations;
+
+    my $map = $meta->get_method_map;
+
+    for my $name (keys %$map) {
+        my $method = $map->{$name};
+
+        # Modifiers are always fine.
+        next if $method->isa('Class::MOP::Method::Wrapped')
+             || $method->isa('Moose::Meta::Method::Overridden')
+             || $method->isa('Moose::Meta::Method::Augmented');
+
+        # Generated methods
+        next if $method->isa('Class::MOP::Method::Generated');
+
+        # XXX: this freaking sucks
+        next if $name eq 'meta' || $name eq 'BUILD' || $name eq 'DEMOLISH';
+
+        my $next = $meta->find_next_method_by_name($name);
+
+        # Adding new methods is always fine.
+        next if !$next;
+
+        push @violations, $self->violation("The '$name' method of class " . $meta->name . " does not use a method modifier to override its superclass implementation.", $EXPL);
+    }
+
+    return @violations;
+}
+
+no Moose;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Perl::Critic::Policy::DynamicMoose::RequireMethodModifiers
+
+=head1 DESCRIPTION
+
+
+=head1 WARNING
+
+B<VERY IMPORTANT:> Most L<Perl::Critic> Policies (including all the ones that
+ship with Perl::Critic> use pure static analysis -- they never compile nor
+execute any of the code that they analyze.  However, this policy is very
+different.  It actually attempts to compile your code and then compares the
+subroutines mentioned in your code to those found in the symbol table.
+Therefore you should B<not> use this Policy on any code that you do not trust,
+or may have undesirable side-effects at compile-time (such as connecting to the
+network or mutating files).
+
+For this Policy to work, all the modules included in your code must be
+installed locally, and must compile without error.
+
+=head1 AUTHOR
+
+Shawn M Moore, C<sartak@bestpractical.com>
+
+=cut
+
diff --git a/t/DynamicMoose/RequireMethodModifiers.run b/t/DynamicMoose/RequireMethodModifiers.run
new file mode 100644
index 0000000..78eed8b
--- /dev/null
+++ b/t/DynamicMoose/RequireMethodModifiers.run
@@ -0,0 +1,172 @@
+## name No superclass
+## failures 0
+## cut
+
+package Class;
+use Moose;
+
+sub foo {}
+sub bar {}
+
+#-----------------------------------------------------------------------------
+
+## name No overriding methods
+## failures 0
+## cut
+
+package Parent;
+
+sub parent {}
+
+package Child;
+use Moose;
+extends 'Parent';
+
+sub child {}
+
+#-----------------------------------------------------------------------------
+
+## name Implicitly overrides a method
+## failures 1
+## cut
+
+package Parent;
+
+sub parent {}
+
+package Child;
+use Moose;
+extends 'Parent';
+
+sub parent {}
+
+#-----------------------------------------------------------------------------
+
+## name Weirdly dispatching methods
+## failures 0
+## cut
+
+package Parent;
+use Moose;
+
+sub BUILD {}
+sub DEMOLISH {}
+
+package Child;
+use Moose;
+extends 'Parent';
+
+sub BUILD {}
+sub DEMOLISH {}
+
+#-----------------------------------------------------------------------------
+
+## name Make immutable
+## failures 0
+## cut
+
+package Parent;
+use Moose;
+
+__PACKAGE__->meta->make_immutable;
+
+package Child;
+use Moose;
+extends 'Parent';
+
+__PACKAGE__->meta->make_immutable;
+
+#-----------------------------------------------------------------------------
+
+## name Many modifiers
+## failures 0
+## cut
+
+package Parent;
+use Moose;
+
+sub foo {}
+
+sub ai { inner() }
+
+sub os {}
+
+package Child;
+use Moose;
+extends 'Parent';
+
+before foo => sub {};
+after  foo => sub {};
+around foo => sub {};
+
+augment ai => sub {};
+
+override os => sub { super };
+
+#-----------------------------------------------------------------------------
+
+## name Pull in a method from a role. Could go either way here.
+## failures 1
+## cut
+
+package Parent;
+use Moose;
+
+sub foo {}
+
+package Role;
+use Moose::Role;
+
+sub foo {}
+
+package Child;
+use Moose;
+extends 'Parent';
+with 'Role';
+
+#-----------------------------------------------------------------------------
+
+## name Grandparent
+## failures 1
+## cut
+
+package Grandparent;
+use Moose;
+
+sub foo {}
+
+package Parent;
+use Moose;
+extends 'Grandparent';
+
+sub bar {}
+
+package Child;
+use Moose;
+extends 'Parent';
+
+sub foo {}
+
+#-----------------------------------------------------------------------------
+
+## name Grandparent with modifiers
+## failures 0
+## cut
+
+package Grandparent;
+use Moose;
+
+sub foo {}
+
+package Parent;
+use Moose;
+extends 'Grandparent';
+
+before foo => sub {};
+
+package Child;
+use Moose;
+extends 'Parent';
+
+after foo => sub {};
+