Front page | perl.perl5.changes |
Postings from March 2012
[perl.git] branch blead, updated. v5.15.9-26-g84cf752
From:
Father Chrysostomos
Date:
March 23, 2012 09:30
Subject:
[perl.git] branch blead, updated. v5.15.9-26-g84cf752
Message ID:
E1SB7Nf-0006Um-Gl@camel.ams6.corp.booking.com
In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/84cf752cf4667896f0ad1025fbb58f1ddf04ecdc?hp=654dfe5293a435f777e47f6587931541a3006cbd>
- Log -----------------------------------------------------------------
commit 84cf752cf4667896f0ad1025fbb58f1ddf04ecdc
Author: Father Chrysostomos <sprout@cpan.org>
Date: Fri Mar 23 08:52:23 2012 -0700
Use HEKf in 2 places in op.c:S_finalize_op
The previous patch was written before HEKf existed.
HEKf with HEKfARG(...) is much faster than SVf with
SVfARG(sv_2mortal(newSVhek(...)))
M op.c
commit ce16c625ecbfe5ee0a74317b44ba90696fad6e5c
Author: Brian Fraser <fraserbn@gmail.com>
Date: Fri Mar 23 08:50:22 2012 -0700
op.c: Warnings cleanup.
M MANIFEST
M embed.fnc
M embed.h
M op.c
M proto.h
M t/lib/warnings/op
A t/uni/opcroak.t
-----------------------------------------------------------------------
Summary of changes:
MANIFEST | 1 +
embed.fnc | 11 +++--
embed.h | 9 +++-
op.c | 123 +++++++++++++++++++++++++++++++++--------------------
proto.h | 37 ++++++++++++---
t/lib/warnings/op | 8 +++
t/uni/opcroak.t | 44 +++++++++++++++++++
7 files changed, 172 insertions(+), 61 deletions(-)
create mode 100644 t/uni/opcroak.t
diff --git a/MANIFEST b/MANIFEST
index 646fc80..cc185d6 100644
--- 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
--- 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
--- 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..6410caf 100644
--- 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 %"HEKf,
+ SVfARG(*svp), SVfARG(lexname),
+ HEKfARG(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 %"HEKf,
+ SVfARG(*svp), SVfARG(lexname),
+ HEKfARG(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
--- 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
--- 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
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";
+}
--
Perl5 Master Repository
-
[perl.git] branch blead, updated. v5.15.9-26-g84cf752
by Father Chrysostomos