op.c: Warnings cleanup.

diff --git a/MANIFEST b/MANIFEST
index 646fc80..cc185d6 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -5496,6 +5496,7 @@ t/uni/latin2.t                    See if Unicode in latin2 works
 t/uni/lex_utf8.t               See if Unicode in lexer works
 t/uni/lower.t                  See if Unicode casing works
 t/uni/method.t                 See if Unicode methods work
+t/uni/opcroak.t                        See if Unicode croaks from op.c work
 t/uni/overload.t               See if Unicode overloading works
 t/uni/package.t                        See if Unicode in package declarations works
 t/uni/parser.t                 See if Unicode in the parser works in edge cases.

diff --git a/embed.fnc b/embed.fnc
index 6337942..8e3527d 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1741,17 +1741,20 @@ sR      |OP*    |newDEFSVOP
 sR     |OP*    |search_const   |NN OP *o
 sR     |OP*    |new_logop      |I32 type|I32 flags|NN OP **firstp|NN OP **otherp
 s      |void   |simplify_sort  |NN OP *o
-s      |const char*    |gv_ename       |NN GV *gv
+s      |SV*    |gv_ename       |NN GV *gv
 sRn    |bool   |scalar_mod_type|NULLOK const OP *o|I32 type
 s      |OP *   |my_kid         |NULLOK OP *o|NULLOK OP *attrs|NN OP **imopsp
 s      |OP *   |dup_attrlist   |NN OP *o
 s      |void   |apply_attrs    |NN HV *stash|NN SV *target|NULLOK OP *attrs|bool for_my
 s      |void   |apply_attrs_my |NN HV *stash|NN OP *target|NULLOK OP *attrs|NN OP **imopsp
-s      |void   |bad_type       |I32 n|NN const char *t|NN const char *name|NN const OP *kid
+s      |void   |bad_type_pv    |I32 n|NN const char *t|NN const char *name|U32 flags|NN const OP *kid
+s      |void   |bad_type_sv    |I32 n|NN const char *t|NN SV *namesv|U32 flags|NN const OP *kid
 s      |void   |no_bareword_allowed|NN OP *o
 sR     |OP*    |no_fh_allowed|NN OP *o
-sR     |OP*    |too_few_arguments|NN OP *o|NN const char* name
-s      |OP*    |too_many_arguments|NN OP *o|NN const char* name
+sR     |OP*    |too_few_arguments_sv|NN OP *o|NN SV* namesv|U32 flags
+sR     |OP*    |too_few_arguments_pv|NN OP *o|NN const char* name|U32 flags
+s      |OP*    |too_many_arguments_pv|NN OP *o|NN const char* name|U32 flags
+sR     |OP*    |too_many_arguments_sv|NN OP *o|NN SV* namesv|U32 flags
 s      |bool   |looks_like_bool|NN const OP* o
 s      |OP*    |newGIVWHENOP   |NULLOK OP* cond|NN OP *block \
                                |I32 enter_opcode|I32 leave_opcode \

diff --git a/embed.h b/embed.h
index 6f13c91..24f1e4a 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1387,7 +1387,8 @@
 #define aassign_common_vars(a) S_aassign_common_vars(aTHX_ a)
 #define apply_attrs(a,b,c,d)   S_apply_attrs(aTHX_ a,b,c,d)
 #define apply_attrs_my(a,b,c,d)        S_apply_attrs_my(aTHX_ a,b,c,d)
-#define bad_type(a,b,c,d)      S_bad_type(aTHX_ a,b,c,d)
+#define bad_type_pv(a,b,c,d,e) S_bad_type_pv(aTHX_ a,b,c,d,e)
+#define bad_type_sv(a,b,c,d,e) S_bad_type_sv(aTHX_ a,b,c,d,e)
 #define cop_free(a)            S_cop_free(aTHX_ a)
 #define dup_attrlist(a)                S_dup_attrlist(aTHX_ a)
 #define finalize_op(a)         S_finalize_op(aTHX_ a)
@@ -1421,8 +1422,10 @@
 #define scalarseq(a)           S_scalarseq(aTHX_ a)
 #define search_const(a)                S_search_const(aTHX_ a)
 #define simplify_sort(a)       S_simplify_sort(aTHX_ a)
-#define too_few_arguments(a,b) S_too_few_arguments(aTHX_ a,b)
-#define too_many_arguments(a,b)        S_too_many_arguments(aTHX_ a,b)
+#define too_few_arguments_pv(a,b,c)    S_too_few_arguments_pv(aTHX_ a,b,c)
+#define too_few_arguments_sv(a,b,c)    S_too_few_arguments_sv(aTHX_ a,b,c)
+#define too_many_arguments_pv(a,b,c)   S_too_many_arguments_pv(aTHX_ a,b,c)
+#define too_many_arguments_sv(a,b,c)   S_too_many_arguments_sv(aTHX_ a,b,c)
 #  endif
 #  if defined(PERL_IN_OP_C) || defined(PERL_IN_SV_C)
 #define report_redefined_cv(a,b,c)     Perl_report_redefined_cv(aTHX_ a,b,c)

diff --git a/op.c b/op.c
index 3bbe4f1..49aa1e4 100644 (file)
--- a/op.c
+++ b/op.c
@@ -317,7 +317,7 @@ Perl_Slab_Free(pTHX_ void *op)
        o->op_ppaddr = PL_ppaddr[type];         \
     } STMT_END
 
-STATIC const char*
+STATIC SV*
 S_gv_ename(pTHX_ GV *gv)
 {
     SV* const tmpsv = sv_newmortal();
@@ -325,7 +325,7 @@ S_gv_ename(pTHX_ GV *gv)
     PERL_ARGS_ASSERT_GV_ENAME;
 
     gv_efullname3(tmpsv, gv, NULL);
-    return SvPV_nolen_const(tmpsv);
+    return tmpsv;
 }
 
 STATIC OP *
@@ -339,30 +339,57 @@ S_no_fh_allowed(pTHX_ OP *o)
 }
 
 STATIC OP *
-S_too_few_arguments(pTHX_ OP *o, const char *name)
+S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
 {
-    PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
+    PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
+    yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
+                                    SvUTF8(namesv) | flags);
+    return o;
+}
+
+STATIC OP *
+S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
+{
+    PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
+    yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
+    return o;
+}
+ 
+STATIC OP *
+S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
+{
+    PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 
-    yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
+    yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
     return o;
 }
 
 STATIC OP *
-S_too_many_arguments(pTHX_ OP *o, const char *name)
+S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
 {
-    PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
+    PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
 
-    yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
+    yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
+                SvUTF8(namesv) | flags);
     return o;
 }
 
 STATIC void
-S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
+S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
 {
-    PERL_ARGS_ASSERT_BAD_TYPE;
+    PERL_ARGS_ASSERT_BAD_TYPE_PV;
+
+    yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
+                (int)n, name, t, OP_DESC(kid)), flags);
+}
 
-    yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
-                (int)n, name, t, OP_DESC(kid)));
+STATIC void
+S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid)
+{
+    PERL_ARGS_ASSERT_BAD_TYPE_SV;
+ 
+    yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
+                (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
 }
 
 STATIC void
@@ -410,8 +437,8 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
                              name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
                              PL_parser->in_my == KEY_state ? "state" : "my"));
        } else {
-           yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
-                             PL_parser->in_my == KEY_state ? "state" : "my"));
+           yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
+                             PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
        }
     }
 
@@ -1625,9 +1652,10 @@ S_finalize_op(pTHX_ OP* o)
        key = SvPV_const(*svp, keylen);
        if (!hv_fetch(GvHV(*fields), key,
                SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
-           Perl_croak(aTHX_ "No such class field \"%s\" "
-               "in variable %s of type %s",
-               key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
+           Perl_croak(aTHX_ "No such class field \"%"SVf"\" " 
+                          "in variable %"SVf" of type %"SVf, 
+                     SVfARG(*svp), SVfARG(lexname),
+                      SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(lexname))))));
        }
        break;
     }
@@ -1680,9 +1708,10 @@ S_finalize_op(pTHX_ OP* o)
            key = SvPV_const(*svp, keylen);
            if (!hv_fetch(GvHV(*fields), key,
                    SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
-               Perl_croak(aTHX_ "No such class field \"%s\" "
-                   "in variable %s of type %s",
-                   key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
+               Perl_croak(aTHX_ "No such class field \"%"SVf"\" " 
+                          "in variable %"SVf" of type %"SVf, 
+                     SVfARG(*svp), SVfARG(lexname),
+                      SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(lexname))))));
            }
        }
        break;
@@ -7833,7 +7862,7 @@ Perl_ck_fun(pTHX_ OP *o)
                if (numargs == 1 && !(oa >> 4)
                    && kid->op_type == OP_LIST && type != OP_SCALAR)
                {
-                   return too_many_arguments(o,PL_op_desc[type]);
+                   return too_many_arguments_pv(o,PL_op_desc[type], 0);
                }
                scalar(kid);
                break;
@@ -7873,7 +7902,7 @@ Perl_ck_fun(pTHX_ OP *o)
                      && (  !SvROK(cSVOPx_sv(kid)) 
                         || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
                        )
-                   bad_type(numargs, "array", PL_op_desc[type], kid);
+                   bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
                /* Defer checks to run-time if we have a scalar arg */
                if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
                    op_lvalue(kid, type);
@@ -7898,7 +7927,7 @@ Perl_ck_fun(pTHX_ OP *o)
                    *tokid = kid;
                }
                else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
-                   bad_type(numargs, "hash", PL_op_desc[type], kid);
+                   bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
                op_lvalue(kid, type);
                break;
            case OA_CVREF:
@@ -7931,7 +7960,7 @@ Perl_ck_fun(pTHX_ OP *o)
                    }
                    else if (kid->op_type == OP_READLINE) {
                        /* neophyte patrol: open(<FH>), close(<FH>) etc. */
-                       bad_type(numargs, "HANDLE", OP_DESC(o), kid);
+                       bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
                    }
                    else {
                        I32 flags = OPf_SPECIAL;
@@ -8045,13 +8074,13 @@ Perl_ck_fun(pTHX_ OP *o)
        }
 #ifdef PERL_MAD
        if (kid && kid->op_type != OP_STUB)
-           return too_many_arguments(o,OP_DESC(o));
+           return too_many_arguments_pv(o,OP_DESC(o), 0);
        o->op_private |= numargs;
 #else
        /* FIXME - should the numargs move as for the PERL_MAD case?  */
        o->op_private |= numargs;
        if (kid)
-           return too_many_arguments(o,OP_DESC(o));
+           return too_many_arguments_pv(o,OP_DESC(o), 0);
 #endif
        listkids(o);
     }
@@ -8071,7 +8100,7 @@ Perl_ck_fun(pTHX_ OP *o)
        while (oa & OA_OPTIONAL)
            oa >>= 4;
        if (oa && oa != OA_LIST)
-           return too_few_arguments(o,OP_DESC(o));
+           return too_few_arguments_pv(o,OP_DESC(o), 0);
     }
     return o;
 }
@@ -8202,7 +8231,7 @@ Perl_ck_grep(pTHX_ OP *o)
 
     kid = cLISTOPo->op_first->op_sibling;
     if (!kid || !kid->op_sibling)
-       return too_few_arguments(o,OP_DESC(o));
+       return too_few_arguments_pv(o,OP_DESC(o), 0);
     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
        op_lvalue(kid, OP_GREPSTART);
 
@@ -8929,7 +8958,7 @@ Perl_ck_split(pTHX_ OP *o)
     scalar(kid);
 
     if (kid->op_sibling)
-       return too_many_arguments(o,OP_DESC(o));
+       return too_many_arguments_pv(o,OP_DESC(o), 0);
 
     return o;
 }
@@ -8944,11 +8973,13 @@ Perl_ck_join(pTHX_ OP *o)
     if (kid && kid->op_type == OP_MATCH) {
        if (ckWARN(WARN_SYNTAX)) {
             const REGEXP *re = PM_GETRE(kPMOP);
-           const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
-           const STRLEN len = re ? RX_PRELEN(re) : 6;
+            const SV *msg = re
+                    ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
+                                            SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
+                    : newSVpvs_flags( "STRING", SVs_TEMP );
            Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
-                       "/%.*s/ should probably be written as \"%.*s\"",
-                       (int)len, pmstr, (int)len, pmstr);
+                       "/%"SVf"/ should probably be written as \"%"SVf"\"",
+                       SVfARG(msg), SVfARG(msg));
        }
     }
     return ck_fun(o);
@@ -9135,7 +9166,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
            o3 = aop;
 
        if (proto >= proto_end)
-           return too_many_arguments(entersubop, gv_ename(namegv));
+           return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
 
        switch (*proto) {
            case ';':
@@ -9160,9 +9191,9 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
                proto++;
                arg++;
                if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
-                   bad_type(arg,
+                   bad_type_sv(arg,
                            arg == 1 ? "block or sub {}" : "sub {}",
-                           gv_ename(namegv), o3);
+                           gv_ename(namegv), 0, o3);
                break;
            case '*':
                /* '*' allows any scalar type, including bareword */
@@ -9247,9 +9278,9 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
                                     OP_READ, /* not entersub */
                                     OP_LVALUE_NO_CROAK
                                    )) goto wrapref;
-                           bad_type(arg, Perl_form(aTHX_ "one of %.*s",
+                           bad_type_sv(arg, Perl_form(aTHX_ "one of %.*s",
                                        (int)(end - p), p),
-                                   gv_ename(namegv), o3);
+                                   gv_ename(namegv), 0, o3);
                        } else
                            goto oops;
                        break;
@@ -9257,13 +9288,13 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
                        if (o3->op_type == OP_RV2GV)
                            goto wrapref;
                        if (!contextclass)
-                           bad_type(arg, "symbol", gv_ename(namegv), o3);
+                           bad_type_sv(arg, "symbol", gv_ename(namegv), 0, o3);
                        break;
                    case '&':
                        if (o3->op_type == OP_ENTERSUB)
                            goto wrapref;
                        if (!contextclass)
-                           bad_type(arg, "subroutine entry", gv_ename(namegv),
+                           bad_type_sv(arg, "subroutine entry", gv_ename(namegv), 0,
                                    o3);
                        break;
                    case '$':
@@ -9279,7 +9310,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
                                    OP_READ,  /* not entersub */
                                    OP_LVALUE_NO_CROAK
                               )) goto wrapref;
-                           bad_type(arg, "scalar", gv_ename(namegv), o3);
+                           bad_type_sv(arg, "scalar", gv_ename(namegv), 0, o3);
                        }
                        break;
                    case '@':
@@ -9287,14 +9318,14 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
                                o3->op_type == OP_PADAV)
                            goto wrapref;
                        if (!contextclass)
-                           bad_type(arg, "array", gv_ename(namegv), o3);
+                           bad_type_sv(arg, "array", gv_ename(namegv), 0, o3);
                        break;
                    case '%':
                        if (o3->op_type == OP_RV2HV ||
                                o3->op_type == OP_PADHV)
                            goto wrapref;
                        if (!contextclass)
-                           bad_type(arg, "hash", gv_ename(namegv), o3);
+                           bad_type_sv(arg, "hash", gv_ename(namegv), 0, o3);
                        break;
                    wrapref:
                        {
@@ -9339,7 +9370,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
     }
     if (!optional && proto_end > proto &&
        (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
-       return too_few_arguments(entersubop, gv_ename(namegv));
+       return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
     return entersubop;
 }
 
@@ -9399,7 +9430,7 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
            aop = aop->op_sibling;
        }
        if (aop != cvop)
-           (void)too_many_arguments(entersubop, GvNAME(namegv));
+           (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
        
        op_free(entersubop);
        switch(GvNAME(namegv)[2]) {
@@ -9460,7 +9491,7 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
 #ifdef PERL_MAD
                if (!PL_madskills || seenarg)
 #endif
-                   (void)too_many_arguments(aop, GvNAME(namegv));
+                   (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
                op_free(aop);
            }
            return opnum == OP_RUNCV

diff --git a/proto.h b/proto.h
index 88c3378..781719b 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -5726,13 +5726,20 @@ STATIC void     S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp
 #define PERL_ARGS_ASSERT_APPLY_ATTRS_MY        \
        assert(stash); assert(target); assert(imopsp)
 
-STATIC void    S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
+STATIC void    S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
                        __attribute__nonnull__(pTHX_2)
                        __attribute__nonnull__(pTHX_3)
-                       __attribute__nonnull__(pTHX_4);
-#define PERL_ARGS_ASSERT_BAD_TYPE      \
+                       __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_BAD_TYPE_PV   \
        assert(t); assert(name); assert(kid)
 
+STATIC void    S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid)
+                       __attribute__nonnull__(pTHX_2)
+                       __attribute__nonnull__(pTHX_3)
+                       __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_BAD_TYPE_SV   \
+       assert(t); assert(namesv); assert(kid)
+
 STATIC void    S_cop_free(pTHX_ COP *cop)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_COP_FREE      \
@@ -5760,7 +5767,7 @@ STATIC OP*        S_fold_constants(pTHX_ OP *o)
 
 STATIC OP*     S_force_list(pTHX_ OP* arg);
 STATIC OP*     S_gen_constant_list(pTHX_ OP* o);
-STATIC const char*     S_gv_ename(pTHX_ GV *gv)
+STATIC SV*     S_gv_ename(pTHX_ GV *gv)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_GV_ENAME      \
        assert(gv)
@@ -5869,19 +5876,33 @@ STATIC void     S_simplify_sort(pTHX_ OP *o)
 #define PERL_ARGS_ASSERT_SIMPLIFY_SORT \
        assert(o)
 
-STATIC OP*     S_too_few_arguments(pTHX_ OP *o, const char* name)
+STATIC OP*     S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
                        __attribute__warn_unused_result__
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS     \
+#define PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV  \
        assert(o); assert(name)
 
-STATIC OP*     S_too_many_arguments(pTHX_ OP *o, const char* name)
+STATIC OP*     S_too_few_arguments_sv(pTHX_ OP *o, SV* namesv, U32 flags)
+                       __attribute__warn_unused_result__
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV  \
+       assert(o); assert(namesv)
+
+STATIC OP*     S_too_many_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS    \
+#define PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV \
        assert(o); assert(name)
 
+STATIC OP*     S_too_many_arguments_sv(pTHX_ OP *o, SV* namesv, U32 flags)
+                       __attribute__warn_unused_result__
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV \
+       assert(o); assert(namesv)
+
 #  if defined(USE_ITHREADS)
 STATIC void    S_forget_pmop(pTHX_ PMOP *const o, U32 flags)
                        __attribute__nonnull__(pTHX_1);

diff --git a/t/lib/warnings/op b/t/lib/warnings/op
index 8f57920..f2270dc 100644 (file)
--- a/t/lib/warnings/op
+++ b/t/lib/warnings/op
@@ -991,6 +991,14 @@ join /---/, 'x', 'y', 'z';
 EXPECT
 /---/ should probably be written as "---" at - line 3.
 ########
+# op.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings 'syntax' ;
+join /～～～/, 'x', 'y', 'z';
+EXPECT
+/～～～/ should probably be written as "～～～" at - line 5.
+########
 # op.c [Perl_peep]
 use warnings 'prototype' ;
 fred() ; 

diff --git a/t/uni/opcroak.t b/t/uni/opcroak.t
new file mode 100644 (file)
index 0000000..29909d7
--- /dev/null
+++ b/t/uni/opcroak.t
@@ -0,0 +1,44 @@
+#!./perl
+
+#
+# tests for op.c generated croaks
+#
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require './test.pl';
+}
+
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+
+plan( tests => 5 );
+
+eval qq!sub \x{30cb} (\$) {} \x{30cb}()!;
+like $@, qr/Not enough arguments for main::\x{30cb}/u, "Not enough arguments croak is UTF-8 clean";
+
+eval qq!sub \x{30cc} (\$) {} \x{30cc}(1, 2)!;
+like $@, qr/Too many arguments for main::\x{30cc}/u, "Too many arguments croak is UTF-8 clean";
+
+eval qq!sub \x{30cd} (\Q\%\E) { 1 } \x{30cd}(1);!;
+like $@, qr/Type of arg 1 to main::\x{30cd} must be/u, "bad type croak is UTF-8 clean";
+
+    eval <<'END_FIELDS';
+    {
+        package ＦŌŌ {
+            use fields qw( a b );
+            sub new { bless {}, shift }
+        }
+    }
+END_FIELDS
+
+for (
+        [ element => 'my ＦŌŌ $bàr = ＦŌŌ->new; $bàr->{クラス};' ],
+        [ slice => 'my ＦŌŌ $bàr = ＦŌŌ->new; @{$bàr}{ qw( a クラス ) };' ]
+    ) {
+    eval $_->[1];
+    
+    like $@, qr/No such class field "クラス" in variable \$bàr of type ＦŌŌ/, "$_->[0]: no such field error is UTF-8 clean";
+}