From b54d603d2b0409d931d988215873268c9de799d1 Mon Sep 17 00:00:00 2001
From: Peter Martini <PeterCMartini@GMail.com>
Date: Tue, 9 Jul 2013 00:29:48 -0400
Subject: [PATCH 1/1] 'Prototype after' and 'Illegal character' warnings should
 both pretty print the prototype text.

For example, prior to this patch,
eval "sub foo (@\0) {}"
would give two warnings:

Prototype after '@' for main::foo : @ at (eval 1) line 1.
Illegal character in prototype for main::foo : @\0 at (eval 1) line 1.

In both cases, the representation which makes a NULL visible
is useful, and of course since we're printing the same warning twice,
it doesn't hurt to display it consistently.
---
 t/lib/warnings/op | 32 +++++++++++++++++++-------------
 toke.c            | 20 ++++++++------------
 2 files changed, 27 insertions(+), 25 deletions(-)

diff --git a/t/lib/warnings/op b/t/lib/warnings/op
index 5696ed4..c38bcde 100644
--- a/t/lib/warnings/op
+++ b/t/lib/warnings/op
@@ -933,48 +933,54 @@ Prototype mismatch: sub main::frèd () vs ($) at - line 5.
 use utf8;
 use open qw( :utf8 :std );
 use warnings;
-eval "sub fòò (\$\0) {}";
+eval "sub fòò (@\$\0) {}";
 EXPECT
-Illegal character in prototype for main::fòò : $\0 at (eval 1) line 1.
+Prototype after '@' for main::fòò : @$\0 at (eval 1) line 1.
+Illegal character in prototype for main::fòò : @$\0 at (eval 1) line 1.
 ########
 # op.c
 use utf8;
 use open qw( :utf8 :std );
 use warnings;
-eval "sub foo (\0) {}";
+eval "sub foo (@\0) {}";
 EXPECT
-Illegal character in prototype for main::foo : \0 at (eval 1) line 1.
+Prototype after '@' for main::foo : @\0 at (eval 1) line 1.
+Illegal character in prototype for main::foo : @\0 at (eval 1) line 1.
 ########
 # op.c
 use utf8;
 use open qw( :utf8 :std );
 use warnings;
-BEGIN { $::{"foo"} = "\$\0L\351on" }
-BEGIN { eval "sub foo (\$\0L\x{c3}\x{a9}on) {}"; }
+BEGIN { $::{"foo"} = "\@\$\0L\351on" }
+BEGIN { eval "sub foo (@\$\0L\x{c3}\x{a9}on) {}"; }
 EXPECT
-Illegal character in prototype for main::foo : $\x{0}L... at (eval 1) line 1.
+Prototype after '@' for main::foo : @$\x{0}L... at (eval 1) line 1.
+Illegal character in prototype for main::foo : @$\x{0}L... at (eval 1) line 1.
 ########
 # op.c
 use utf8;
 use open qw( :utf8 :std );
 use warnings;
-BEGIN { eval "sub foo (\0) {}"; }
+BEGIN { eval "sub foo (@\0) {}"; }
 EXPECT
-Illegal character in prototype for main::foo : \0 at (eval 1) line 1.
+Prototype after '@' for main::foo : @\0 at (eval 1) line 1.
+Illegal character in prototype for main::foo : @\0 at (eval 1) line 1.
 ########
 # op.c
 use warnings;
-eval "sub foo (\xAB) {}";
+eval "sub foo (@\xAB) {}";
 EXPECT
-Illegal character in prototype for main::foo : \x{ab} at (eval 1) line 1.
+Prototype after '@' for main::foo : @\x{ab} at (eval 1) line 1.
+Illegal character in prototype for main::foo : @\x{ab} at (eval 1) line 1.
 ########
 # op.c
 use utf8;
 use open qw( :utf8 :std );
 use warnings;
-BEGIN { eval "sub foo (\x{30cb}) {}"; }
+BEGIN { eval "sub foo (@\x{30cb}) {}"; }
 EXPECT
-Illegal character in prototype for main::foo : \x{30cb} at (eval 1) line 1.
+Prototype after '@' for main::foo : @\x{30cb} at (eval 1) line 1.
+Illegal character in prototype for main::foo : @\x{30cb} at (eval 1) line 1.
 ########
 # op.c
 use utf8;
diff --git a/toke.c b/toke.c
index 878b084..11b235f 100644
--- a/toke.c
+++ b/toke.c
@@ -1651,25 +1651,21 @@ Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
     }
 
     if (warn) {
+	SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
 	p -= origlen;
+	p = SvUTF8(proto)
+	    ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
+	                     origlen, UNI_DISPLAY_ISPRINT)
+	    : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
+
 	if (proto_after_greedy_proto)
 	    Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
 			"Prototype after '%c' for %"SVf" : %s",
 			greedy_proto, SVfARG(name), p);
-	if (bad_proto) {
-	    SV *dsv = newSVpvs_flags("", SVs_TEMP);
+	if (bad_proto)
 	    Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
 			"Illegal character %sin prototype for %"SVf" : %s",
-			seen_underscore ? "after '_' " : "",
-			SVfARG(PL_subname),
-			SvUTF8(PL_lex_stuff)
-			    ? sv_uni_display(dsv,
-				newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
-				origlen,
-				UNI_DISPLAY_ISPRINT)
-			    : pv_pretty(dsv, p, origlen, 60, NULL, NULL,
-				PERL_PV_ESCAPE_NONASCII));
-	}
+			seen_underscore ? "after '_' " : "", SVfARG(name), p);
     }
 
     return (! (proto_after_greedy_proto || bad_proto) );
-- 
1.8.3.1