X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f9692056a8a7d0d25b58e9087606cf7ae5c3559c..778a861bb0a8d42e4be677cc40a39d1fac0babe5:/op.c diff --git a/op.c b/op.c index 59e2b29..a9296f3 100644 --- a/op.c +++ b/op.c @@ -837,7 +837,8 @@ Perl_op_contextualize(pTHX_ OP *o, I32 context) case G_ARRAY: return list(o); case G_VOID: return scalarvoid(o); default: - Perl_croak(aTHX_ "panic: op_contextualize bad context"); + Perl_croak(aTHX_ "panic: op_contextualize bad context %ld", + (long) context); return o; } } @@ -1166,14 +1167,6 @@ Perl_scalarvoid(pTHX_ OP *o) no_bareword_allowed(o); else { if (ckWARN(WARN_VOID)) { - if (SvOK(sv)) { - SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_ - "a constant (%"SVf")", sv)); - useless = SvPV_nolen(msv); - useless_is_utf8 = SvUTF8(msv); - } - else - useless = "a constant (undef)"; /* don't warn on optimised away booleans, eg * use constant Foo, 5; Foo || print; */ if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) @@ -1195,7 +1188,24 @@ Perl_scalarvoid(pTHX_ OP *o) strnEQ(maybe_macro, "ds", 2) || strnEQ(maybe_macro, "ig", 2)) useless = NULL; + else { + SV * const dsv = newSVpvs(""); + SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_ + "a constant (%s)", + pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL, + PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT ))); + SvREFCNT_dec(dsv); + useless = SvPV_nolen(msv); + useless_is_utf8 = SvUTF8(msv); + } } + else if (SvOK(sv)) { + SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_ + "a constant (%"SVf")", sv)); + useless = SvPV_nolen(msv); + } + else + useless = "a constant (undef)"; } } op_null(o); /* don't execute or even remember it */ @@ -2392,6 +2402,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) OP *kid; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) my_kid(kid, attrs, imopsp); + return o; } else if (type == OP_UNDEF #ifdef PERL_MAD || type == OP_STUB @@ -2534,7 +2545,9 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) && (gv = cGVOPx_gv(cUNOPx(left)->op_first)) ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1) : NULL - : varname(NULL, isary ? '@' : '%', left->op_targ, NULL, 0, 1); + : varname( + (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1 + ); if (name) Perl_warner(aTHX_ packWARN(WARN_MISC), "Applying %s to %"SVf" will act on scalar(%"SVf")", @@ -2933,7 +2946,7 @@ S_fold_constants(pTHX_ register OP *o) case OP_SCMP: case OP_SPRINTF: /* XXX what about the numeric ops? */ - if (PL_hints & HINT_LOCALE) + if (IN_LOCALE_COMPILETIME) goto nope; break; } @@ -4096,10 +4109,13 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) if (PL_hints & HINT_RE_TAINT) pmop->op_pmflags |= PMf_RETAINT; - if (PL_hints & HINT_LOCALE) { + if (IN_LOCALE_COMPILETIME) { set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET); } - else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) { + else if ((! (PL_hints & HINT_BYTES)) + /* Both UNI_8_BIT and locale :not_characters imply Unicode */ + && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS))) + { set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET); } if (PL_hints & HINT_RE_FLAGS) { @@ -6439,6 +6455,13 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CV * Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { + return newATTRSUB_flags(floor, o, proto, attrs, block, 0); +} + +CV * +Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, + OP *block, U32 flags) +{ dVAR; GV *gv; const char *ps; @@ -6456,9 +6479,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) || PL_madskills) ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; STRLEN namlen = 0; - const char * const name = o ? SvPV_const(cSVOPo->op_sv, namlen) : NULL; + const bool o_is_gv = flags & 1; + const char * const name = + o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL; bool has_name; - bool name_is_utf8 = o ? (SvUTF8(cSVOPo->op_sv) ? 1 : 0) : 0; + bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv); if (proto) { assert(proto->op_type == OP_CONST); @@ -6468,10 +6493,12 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else ps = NULL; - if (name) { - gv = isGV(cSVOPo->op_sv) - ? (GV *)cSVOPo->op_sv - : gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV); + if (o_is_gv) { + gv = (GV*)o; + o = NULL; + has_name = TRUE; + } else if (name) { + gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV); has_name = TRUE; } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) { SV * const sv = sv_newmortal(); @@ -7320,8 +7347,12 @@ Perl_ck_cmp(pTHX_ OP *o) if (ckWARN(WARN_SYNTAX)) { const OP *kid = cUNOPo->op_first; if (kid && ( - is_dollar_bracket(aTHX_ kid) - || ((kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid)) + ( + is_dollar_bracket(aTHX_ kid) + && kid->op_sibling && kid->op_sibling->op_type == OP_CONST + ) + || ( kid->op_type == OP_CONST + && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid)) )) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "$[ used in %s (did you mean $] ?)", OP_DESC(o)); @@ -7720,6 +7751,11 @@ Perl_ck_ftst(pTHX_ OP *o) && kidtype != OP_STAT && kidtype != OP_LSTAT) { o->op_private |= OPpFT_STACKED; kid->op_private |= OPpFT_STACKING; + if (kidtype == OP_FTTTY && ( + !(kid->op_private & OPpFT_STACKED) + || kid->op_private & OPpFT_AFTER_t + )) + o->op_private |= OPpFT_AFTER_t; } } else { @@ -8145,7 +8181,7 @@ Perl_ck_grep(pTHX_ OP *o) return o; kid = cLISTOPo->op_first->op_sibling; if (kid->op_type != OP_NULL) - Perl_croak(aTHX_ "panic: ck_grep"); + Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type); kid = kUNOP->op_first; if (!gwop) @@ -8211,11 +8247,6 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ if ((o->op_flags & OPf_KIDS)) { switch (cUNOPo->op_first->op_type) { case OP_RV2AV: - /* This is needed for - if (defined %stash::) - to work. Do not break Tk. - */ - break; /* Globals via GV can be undef */ case OP_PADAV: case OP_AASSIGN: /* Is this a good idea? */ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), @@ -8858,7 +8889,7 @@ Perl_ck_split(pTHX_ OP *o) kid = cLISTOPo->op_first; if (kid->op_type != OP_NULL) - Perl_croak(aTHX_ "panic: ck_split"); + Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type); kid = kid->op_sibling; op_free(cLISTOPo->op_first); if (kid) @@ -9082,7 +9113,8 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) const char *e = NULL; PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO; if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv)) - Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto"); + Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, " + "flags=%lx", (unsigned long) SvFLAGS(protosv)); if (SvTYPE(protosv) == SVt_PVCV) proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv); else proto = SvPV(protosv, proto_len); @@ -9114,7 +9146,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) continue; case '_': /* _ must be at the end */ - if (proto[1] && proto[1] != ';') + if (proto[1] && !strchr(";@%", proto[1])) goto oops; case '$': proto++; @@ -9719,7 +9751,8 @@ Perl_ck_length(pTHX_ OP *o) case OP_PADHV: case OP_PADAV: name = varname( - NULL, hash ? '%' : '@', kid->op_targ, NULL, 0, 1 + (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ, + NULL, 0, 1 ); break; case OP_RV2HV: @@ -9807,7 +9840,7 @@ S_inplace_aassign(pTHX_ OP *o) { return; assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK); - oright = cUNOPx(modop)->op_first->op_sibling; + if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return; if (modop->op_flags & OPf_STACKED) { /* skip sort subroutine/block */