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.

diff --git a/embed.fnc b/embed.fnc
index 03bbfca..86447df 100644 (file)
--- 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 2f4744e..2e8d3ea 100644 (file)
--- 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 64cbcb7..b85e2de 100644 (file)
--- 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 7a5fab0..a586f38 100644 (file)
--- 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 742518a..e6323b9 100644 (file)
--- 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 12c38b9..f6f105d 100644 (file)
--- 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 200b9dc..a99868e 100644 (file)
--- 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