report prototype change warnings from correct location

Author: haarg

lib/Class/Method/Modifiers.pm

@@ -78,6 +78,10 @@ sub install_modifier {
             unshift @{ $cache->{$type} }, $code;
         }
 
+        require Carp;
+        my $loc = Carp::short_error_loc();
+        my ($file, $line, $warnmask) = (caller($loc))[1,2,9];
+
         # wrap the method with another layer of around. much simpler than
         # the Moose equivalent. :)
         if ($type eq 'around') {
@@ -103,8 +107,13 @@ sub install_modifier {
 
             my $sig = _sub_sig($cache->{wrapped});
 
-            my $generated = "package $into;\n";
-            $generated .= "sub $name $sig {";
+            my $generated
+              = "BEGIN { \${^WARNING_BITS} = \$warnmask }\n"
+              . "no warnings 'redefine';\n"
+              . "no warnings 'closure';\n"
+              . "package $into;\n"
+              . "#line $line \"$file\"\n"
+              . "sub $name $sig {";
 
             # before is easy, it doesn't affect the return value(s)
             if (@$before) {
@@ -143,8 +152,6 @@ sub install_modifier {
             $generated .= '}';
 
             no strict 'refs';
-            no warnings 'redefine';
-            no warnings 'closure';
             eval $generated;
         };
     }

t/141-prototype.t

@@ -1,7 +1,7 @@
 use strict;
 use warnings;
 use Test::More 0.88;
-use Test::Warnings ($ENV{AUTHOR_TESTING} ? () : ':no_end_test'), 'warning';
+use Test::Warnings ($ENV{AUTHOR_TESTING} ? () : ':no_end_test'), 'warnings';
 use Test::Fatal;
 
 use Class::Method::Modifiers;
@@ -39,7 +39,7 @@ use Class::Method::Modifiers;
     sub bog ($) { scalar @_ }
 
     my $around;
-    my $warn = warning {
+    my ($warn) = warnings {
         around bog => sub ($$) {
             my $orig = shift;
             $around = @_;
@@ -53,6 +53,22 @@ use Class::Method::Modifiers;
         'around modifier applied';
     like $warn, qr/Prototype mismatch/,
         'changing prototype throws warning';
+    like $warn, qr/\Q${\__FILE__}\E/,
+        'warning is reported from correct location';
+}
+
+{
+    sub brog ($) { scalar @_ }
+    no warnings;
+    my @warn = warnings {
+        around brog => sub ($$) {
+            my $orig = shift;
+            $orig->(@_);
+        };
+    };
+
+    is 0+@warn, 0,
+        'warnings controllable via warning pragma';
 }
 
 done_testing;