Check the right caller context for 'illegalproto' warnings in attributes.xs

Previously the XS code always checked its immediate caller for warnings.
This was fine when core perl invokes it directly in a `:prototype`
warning, but was checking the wrong layer when invoked indirectly via
`attributes::import`. In that case, it meant that it was sensitive to,
and printed warnings as it coming from attributes.pm itself, rather than
the intended caller; i.e. the location of the `use attributes ...`
statement.

This is fixed by using `caller_cx()` to walk up the caller stack looking
for a call frame not from the `attributes` package.

Author: leonerd

ext/attributes/attributes.xs

@@ -98,8 +98,32 @@ modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
 			subname = newSVhek_mortal(hek);
 		    else
 			subname=(SV *)CvGV((const CV *)sv);
-		    if (ckWARN(WARN_ILLEGALPROTO))
-			Perl_validate_proto(aTHX_ subname, proto, TRUE, 0);
+                    {
+                        /* Need to check if the caller has WARN_ILLEGALPROTO
+                         * set. That might be PL_curcop or it might be higher
+                         * up, we'll have to check
+                         */
+
+                        COP *cop = PL_curcop;
+                        int caller_level = 0;
+                        const char *stashname;
+                        while (cop && (stashname = HvNAME(CopSTASH(cop))) &&
+                                strEQ(stashname, "attributes")) {
+                            // skip caller frames from attributes.pm itself
+                            caller_level++;
+                            cop = caller_cx(caller_level, NULL)->blk_oldcop;
+                        }
+
+                        if (cop && cop_has_warning(cop, WARN_ILLEGALPROTO)) {
+                            ENTER;
+                            SAVESPTR(PL_curcop);
+                            PL_curcop = cop;
+
+                            Perl_validate_proto(aTHX_ subname, proto, TRUE, 0);
+
+                            LEAVE;
+                        }
+                    }
 		    Perl_cv_ckproto_len_flags(aTHX_ (const CV *)sv,
 		                                    (const GV *)subname,
 		                                    name+10,

t/op/attrproto.t

@@ -11,7 +11,7 @@ BEGIN {
 }
 use warnings;
 
-plan tests => 48;
+plan tests => 52;
 
 my @warnings;
 my ($attrs, $ret) = ("", "");
@@ -90,7 +90,7 @@ is @warnings, 0, "No more warnings"
 
 # Use attributes
 @warnings = ();
-eval 'package Q; use attributes __PACKAGE__, \&B, "prototype(new)";';
+eval 'package Q; no warnings "illegalproto"; use attributes __PACKAGE__, \&B, "prototype(new)";';
 $ret = prototype \&Q::B;
 is $ret, "new", "use attributes also sets the prototype";
 like shift @warnings, qr/Prototype mismatch: sub Q::B \(baz\) vs \(new\)/,
@@ -105,6 +105,18 @@ is $ret, "new", "A malformed prototype doesn't reset it";
 like $@, qr/Unterminated attribute parameter in attribute list/, "Malformed prototype croaked";
 is @warnings, 0, "Malformed prototype isn't just a warning";
 
+# Respects `use warnings 'illegalproto'` of the right caller
+@warnings = ();
+eval 'package Q; use warnings; sub C {}  use attributes __PACKAGE__, \&C, "prototype(bad)";';
+$ret = prototype \&Q::C;
+is $ret, "bad", "illegal prototype is still set via use attributes";
+like shift @warnings, qr/^Illegal character in prototype for \*Q::C : bad at /,
+    "Illegal prototype warning triggered";
+like shift @warnings, qr/^Prototype mismatch: sub Q::C: none vs \(bad\) at /,
+    "Prototype mismatch warning triggered";
+is @warnings, 0, "No more warnings" or
+    diag "More warning: $warnings[0]";
+
 @warnings = ();
 eval 'use attributes __PACKAGE__, \&foo, "prototype($$\x{100}";';
 $ret = prototype \&Q::B;