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

@@ -34,18 +34,21 @@ use Class::Method::Modifiers;
 }
 
 {
-    sub bog ($) { scalar @_ }
-
     my $around;
 
+    sub bog ($) { scalar @_ }
+    my $wrap_bog = sub ($$) {
+        my $orig = shift;
+        $around = @_;
+        $orig->(@_);
+    };
+
+    my $warn_line;
     my @warn;
     {
         local $SIG{__WARN__} = sub { push @warn, @_ };
-        around bog => sub ($$) {
-            my $orig = shift;
-            $around = @_;
-            $orig->(@_);
-        };
+        $warn_line = __LINE__ + 1;
+        around bog => $wrap_bog;
     }
 
     is eval q{ bog( @{[5, 6]}, @{[10, 11]} ) }, 2,
@@ -55,6 +58,26 @@ use Class::Method::Modifiers;
     my $warn = join '', @warn;
     like $warn, qr/Prototype mismatch/,
         'changing prototype throws warning';
+    like $warn, qr/\Q${\__FILE__}\E line $warn_line\b/,
+        'warning is reported from correct location';
+}
+
+{
+    sub brog ($) { scalar @_ }
+    my $wrap_brog = sub ($$) {
+        my $orig = shift;
+        $orig->(@_);
+    };
+
+    my @warn;
+    {
+        local $SIG{__WARN__} = sub { push @warn, @_ };
+        no warnings;
+        around brog => $wrap_brog;
+    }
+
+    is 0+@warn, 0,
+        'warnings controllable via warning pragma';
 }
 
 done_testing;