toke.c, op.c, sv.c: Prototype parsing and checking are nul-and-UTF8 clean.

This means that eval "sub foo ($;\0whoops) { say @_  }" will correctly
include \0whoops in the CV's prototype (while complaining about illegal
characters), and that

use utf8;
BEGIN { $::{"foo"} = "\$\0L\351on" }
BEGIN { eval "sub foo (\$\0L\x{c3}\x{a9}on) {};"; }

will not warn about a mismatched prototype.

7 files changed, 91 insertions, 19 deletions

diff --git a/embed.fnc b/embed.fnc
index 03bbfcab09..86447df24c 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -272,6 +272,9 @@ p	|OP *	|coresub_op	|NN SV *coreargssv|const int code \
 : Used in sv.c
 p	|void	|cv_ckproto_len	|NN const CV* cv|NULLOK const GV* gv\
 				|NULLOK const char* p|const STRLEN len
+p	|void	|cv_ckproto_len_flags	|NN const CV* cv|NULLOK const GV* gv\
+				|NULLOK const char* p|const STRLEN len \
+                                |const U32 flags
 : Used in pp.c and pp_sys.c
 ApdR	|SV*	|gv_const_sv	|NN GV* gv
 ApdR	|SV*	|cv_const_sv	|NULLOK const CV *const cv
diff --git a/embed.h b/embed.h
index 2f4744e914..2e8d3ea9a4 100644
--- a/embed.h
+++ b/embed.h
@@ -1030,6 +1030,7 @@
 #define coresub_op(a,b,c)	Perl_coresub_op(aTHX_ a,b,c)
 #define create_eval_scope(a)	Perl_create_eval_scope(aTHX_ a)
 #define cv_ckproto_len(a,b,c,d)	Perl_cv_ckproto_len(aTHX_ a,b,c,d)
+#define cv_ckproto_len_flags(a,b,c,d,e)	Perl_cv_ckproto_len_flags(aTHX_ a,b,c,d,e)
 #define cvgv_set(a,b)		Perl_cvgv_set(aTHX_ a,b)
 #define cvstash_set(a,b)	Perl_cvstash_set(aTHX_ a,b)
 #define deb_stack_all()		Perl_deb_stack_all(aTHX)
diff --git a/op.c b/op.c
index 64cbcb79b2..b85e2de151 100644
--- a/op.c
+++ b/op.c
@@ -6247,14 +6247,12 @@ Perl_newWHENOP(pTHX_ OP *cond, OP *block)
 }
 
 void
-Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
-		    const STRLEN len)
+Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
+		    const STRLEN len, const U32 flags)
 {
-    PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
-
+    PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
     if (((!p != !SvPOK(cv)) /* One has prototype, one has not.  */
-	 || (p && (len != SvCUR(cv) /* Not the same length.  */
-		   || memNE(p, SvPVX_const(cv), len))))
+        || (p && !sv_eq((SV*)cv, newSVpvn_flags(p, len, flags | SVs_TEMP))))
 	 && ckWARN_d(WARN_PROTOTYPE)) {
 	SV* const msg = sv_newmortal();
 	SV* name = NULL;
@@ -6270,13 +6268,21 @@ Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
 	    sv_catpvs(msg, ": none");
 	sv_catpvs(msg, " vs ");
 	if (p)
-	    Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
+	    Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
 	else
 	    sv_catpvs(msg, "none");
 	Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
     }
 }
 
+void
+Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
+		    const STRLEN len)
+{
+    PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
+    cv_ckproto_len_flags(cv, gv, p, len, 0);
+}
+
 static void const_sv_xsub(pTHX_ CV* cv);
 
 /*
@@ -6480,7 +6486,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	    {
 		Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
 	    }
-	    cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
+	    cv_ckproto_len_flags((const CV *)gv, NULL, ps, ps_len, ps_utf8);
 	}
 	if (ps) {
 	    sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
@@ -6514,7 +6520,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
          * skipping the prototype check
          */
         if (exists || SvPOK(cv))
-	    cv_ckproto_len(cv, gv, ps, ps_len);
+            cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
 	/* already defined (or promised)? */
 	if (exists || GvASSUMECV(gv)) {
 	    if ((!block
diff --git a/proto.h b/proto.h
index 7a5fab0d38..a586f38701 100644
--- a/proto.h
+++ b/proto.h
@@ -638,6 +638,11 @@ PERL_CALLCONV void	Perl_cv_ckproto_len(pTHX_ const CV* cv, const GV* gv, const c
 #define PERL_ARGS_ASSERT_CV_CKPROTO_LEN	\
 	assert(cv)
 
+PERL_CALLCONV void	Perl_cv_ckproto_len_flags(pTHX_ const CV* cv, const GV* gv, const char* p, const STRLEN len, const U32 flags)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS	\
+	assert(cv)
+
 PERL_CALLCONV CV*	Perl_cv_clone(pTHX_ CV* proto)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_CV_CLONE	\
diff --git a/sv.c b/sv.c
index 742518ac67..e6323b9135 100644
--- a/sv.c
+++ b/sv.c
@@ -3853,9 +3853,10 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
 			}
 		    }
 		if (!intro)
-		    cv_ckproto_len(cv, (const GV *)dstr,
+		    cv_ckproto_len_flags(cv, (const GV *)dstr,
 				   SvPOK(sref) ? SvPVX_const(sref) : NULL,
-				   SvPOK(sref) ? SvCUR(sref) : 0);
+				   SvPOK(sref) ? SvCUR(sref)  : 0,
+                                   SvPOK(sref) ? SvUTF8(sref) : 0);
 	    }
 	    GvCVGEN(dstr) = 0; /* Switch off cacheness. */
 	    GvASSUMECV_on(dstr);
diff --git a/t/lib/warnings/op b/t/lib/warnings/op
index 12c38b9956..f6f105d222 100644
--- a/t/lib/warnings/op
+++ b/t/lib/warnings/op
@@ -812,6 +812,56 @@ EXPECT
 Prototype mismatch: sub main::fred () vs ($) at - line 3.
 ########
 # op.c
+use utf8;
+use open qw( :utf8 :std );
+sub frèd();
+sub frèd($) {}
+EXPECT
+Prototype mismatch: sub main::frèd () vs ($) at - line 5.
+########
+# op.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+eval "sub fòò (\$\0) {}";
+EXPECT
+Illegal character in prototype for main::fòò : $\x{0} at (eval 1) line 1.
+########
+# op.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+eval "sub foo (\0) {}";
+EXPECT
+Illegal character in prototype for main::foo : \x{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) {}"; }
+EXPECT
+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) {}"; }
+EXPECT
+Illegal character in prototype for main::foo : \x{0} at (eval 1) line 1.
+########
+# op.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+BEGIN { $::{"foo"} = "\x{30cb}" }
+BEGIN { eval "sub foo {}"; }
+EXPECT
+Prototype mismatch: sub main::foo (ニ) vs none at (eval 1) line 1.
+########
+# op.c
 $^W = 0 ;
 sub fred() ;
 sub fred($) {}
diff --git a/toke.c b/toke.c
index 200b9dc646..a99868e437 100644
--- a/toke.c
+++ b/toke.c
@@ -8024,21 +8024,22 @@ Perl_yylex(pTHX)
 		    bool underscore = FALSE;
 		    bool seen_underscore = FALSE;
 		    const bool warnillegalproto = ckWARN(WARN_ILLEGALPROTO);
+                    STRLEN tmplen;
 
 		    s = scan_str(s,!!PL_madskills,FALSE);
 		    if (!s)
 			Perl_croak(aTHX_ "Prototype not terminated");
 		    /* strip spaces and check for bad characters */
-		    d = SvPVX(PL_lex_stuff);
+		    d = SvPV(PL_lex_stuff, tmplen);
 		    tmp = 0;
-		    for (p = d; *p; ++p) {
+		    for (p = d; tmplen; tmplen--, ++p) {
 			if (!isSPACE(*p)) {
-			    d[tmp++] = *p;
+                            d[tmp++] = *p;
 
 			    if (warnillegalproto) {
 				if (must_be_last)
 				    proto_after_greedy_proto = TRUE;
-				if (!strchr("$@%*;[]&\\_+", *p)) {
+				if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
 				    bad_proto = TRUE;
 				}
 				else {
@@ -8066,17 +8067,22 @@ Perl_yylex(pTHX)
 			    }
 			}
 		    }
-		    d[tmp] = '\0';
+                    d[tmp] = '\0';
 		    if (proto_after_greedy_proto)
 			Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
 				    "Prototype after '%c' for %"SVf" : %s",
 				    greedy_proto, SVfARG(PL_subname), d);
-		    if (bad_proto)
+		    if (bad_proto) {
+                        SV *dsv = newSVpvs_flags("", SVs_TEMP);
 			Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
 				    "Illegal character %sin prototype for %"SVf" : %s",
 				    seen_underscore ? "after '_' " : "",
-				    SVfARG(PL_subname), d);
-		    SvCUR_set(PL_lex_stuff, tmp);
+				    SVfARG(PL_subname),
+                                    sv_uni_display(dsv,
+                                         newSVpvn_flags(d, tmp, SVs_TEMP | SvUTF8(PL_lex_stuff)),
+                                         tmp, UNI_DISPLAY_ISPRINT));
+                    }
+                    SvCUR_set(PL_lex_stuff, tmp);
 		    have_proto = TRUE;
 
 #ifdef PERL_MAD