X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d1ac83c4011b4bf51ca3fb070737a97a6c6ac545..665ac6aded4b9694283d373a0f127f32a3e75b26:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 7581b37..8d3097b 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -213,9 +213,9 @@ PP(pp_substcont) SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */ /* See "how taint works" above pp_subst() */ - if (SvTAINTED(TOPs)) - cx->sb_rxtainted |= SUBST_TAINT_REPL; sv_catsv_nomg(dstr, POPs); + if (UNLIKELY(TAINT_get)) + cx->sb_rxtainted |= SUBST_TAINT_REPL; if (CxONCE(cx) || s < orig || !CALLREGEXEC(rx, s, cx->sb_strend, orig, (s == m), cx->sb_targ, NULL, @@ -781,7 +781,8 @@ PP(pp_formline) * for safety */ grow = linemax; while (linemark--) - s += UTF8SKIP(s); + s += UTF8_SAFE_SKIP(s, + (U8 *) SvEND(PL_formtarget)); linemark = s - (U8*)SvPVX(PL_formtarget); } /* Easy. They agree. */ @@ -868,9 +869,9 @@ PP(pp_formline) } #else /* we generate fmt ourselves so it is safe */ - GCC_DIAG_IGNORE(-Wformat-nonliteral); + GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value); - GCC_DIAG_RESTORE; + GCC_DIAG_RESTORE_STMT; #endif PERL_MY_SNPRINTF_POST_GUARD(len, max); RESTORE_LC_NUMERIC(); @@ -1177,14 +1178,18 @@ PP(pp_flip) } /* This code tries to decide if "$left .. $right" should use the - magical string increment, or if the range is numeric (we make - an exception for .."0" [#18165]). AMS 20021031. */ + magical string increment, or if the range is numeric. Initially, + an exception was made for *any* string beginning with "0" (see + [#18165], AMS 20021031), but now that is only applied when the + string's length is also >1 - see the rules now documented in + perlop [#133695] */ #define RANGE_IS_NUMERIC(left,right) ( \ SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \ SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \ (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \ - looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \ + looks_like_number(left)) && SvPOKp(left) \ + && !(*SvPVX_const(left) == '0' && SvCUR(left)>1 ) )) \ && (!SvOK(right) || looks_like_number(right)))) PP(pp_flop) @@ -1719,9 +1724,13 @@ Perl_die_unwind(pTHX_ SV *msv) * perls 5.13.{1..7} which had late setting of $@ without this * early-setting hack. */ - if (!(in_eval & EVAL_KEEPERR)) + if (!(in_eval & EVAL_KEEPERR)) { + /* remove any read-only/magic from the SV, so we don't + get infinite recursion when setting ERRSV */ + SANE_ERRSV(); sv_setsv_flags(ERRSV, exceptsv, (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL)); + } if (in_eval & EVAL_KEEPERR) { Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf, @@ -1783,8 +1792,10 @@ Perl_die_unwind(pTHX_ SV *msv) */ S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2); - if (!(in_eval & EVAL_KEEPERR)) + if (!(in_eval & EVAL_KEEPERR)) { + SANE_ERRSV(); sv_setsv(ERRSV, exceptsv); + } PL_restartjmpenv = restartjmpenv; PL_restartop = restartop; JMPENV_JUMP(3); @@ -2007,16 +2018,7 @@ PP(pp_caller) mask = &PL_sv_undef ; else if (old_warnings == pWARN_ALL || (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) { - /* Get the bit mask for $warnings::Bits{all}, because - * it could have been extended by warnings::register */ - SV **bits_all; - HV * const bits = get_hv("warnings::Bits", 0); - if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) { - mask = newSVsv(*bits_all); - } - else { - mask = newSVpvn(WARN_ALLstring, WARNsize) ; - } + mask = newSVpvn(WARN_ALLstring, WARNsize) ; } else mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]); @@ -2653,6 +2655,9 @@ PP(pp_redo) return redo_op; } +#define UNENTERABLE (OP *)1 +#define GOTO_DEPTH 64 + STATIC OP * S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit) { @@ -2667,15 +2672,34 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac o->op_type == OP_SCOPE || o->op_type == OP_LEAVELOOP || o->op_type == OP_LEAVESUB || - o->op_type == OP_LEAVETRY) + o->op_type == OP_LEAVETRY || + o->op_type == OP_LEAVEGIVEN) { *ops++ = cUNOPo->op_first; - if (ops >= oplimit) - Perl_croak(aTHX_ "%s", too_deep); } + else if (oplimit - opstack < GOTO_DEPTH) { + if (o->op_flags & OPf_KIDS + && cUNOPo->op_first->op_type == OP_PUSHMARK) { + *ops++ = UNENTERABLE; + } + else if (o->op_flags & OPf_KIDS && PL_opargs[o->op_type] + && OP_CLASS(o) != OA_LOGOP + && o->op_type != OP_LINESEQ + && o->op_type != OP_SREFGEN + && o->op_type != OP_ENTEREVAL + && o->op_type != OP_GLOB + && o->op_type != OP_RV2CV) { + OP * const kid = cUNOPo->op_first; + if (OP_GIMME(kid, 0) != G_SCALAR || OpHAS_SIBLING(kid)) + *ops++ = UNENTERABLE; + } + } + if (ops >= oplimit) + Perl_croak(aTHX_ "%s", too_deep); *ops = 0; if (o->op_flags & OPf_KIDS) { OP *kid; + OP * const kid1 = cUNOPo->op_first; /* First try all the kids at this level, since that's likeliest. */ for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { @@ -2698,19 +2722,27 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac } } for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { + bool first_kid_of_binary = FALSE; if (kid == PL_lastgotoprobe) continue; if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { if (ops == opstack) *ops++ = kid; - else if (ops[-1]->op_type == OP_NEXTSTATE || - ops[-1]->op_type == OP_DBSTATE) + else if (ops[-1] != UNENTERABLE + && (ops[-1]->op_type == OP_NEXTSTATE || + ops[-1]->op_type == OP_DBSTATE)) ops[-1] = kid; else *ops++ = kid; } + if (kid == kid1 && ops != opstack && ops[-1] == UNENTERABLE) { + first_kid_of_binary = TRUE; + ops--; + } if ((o = dofindlabel(kid, label, len, flags, ops, oplimit))) return o; + if (first_kid_of_binary) + *ops++ = UNENTERABLE; } } *ops = 0; @@ -2718,6 +2750,23 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac } +static void +S_check_op_type(pTHX_ OP * const o) +{ + /* Eventually we may want to stack the needed arguments + * for each op. For now, we punt on the hard ones. */ + /* XXX This comment seems to me like wishful thinking. --sprout */ + if (o == UNENTERABLE) + Perl_croak(aTHX_ + "Can't \"goto\" into a binary or list expression"); + if (o->op_type == OP_ENTERITER) + Perl_croak(aTHX_ + "Can't \"goto\" into the middle of a foreach loop"); + if (o->op_type == OP_ENTERGIVEN) + Perl_croak(aTHX_ + "Can't \"goto\" into a \"given\" block"); +} + /* also used for: pp_dump() */ PP(pp_goto) @@ -2726,7 +2775,6 @@ PP(pp_goto) OP *retop = NULL; I32 ix; PERL_CONTEXT *cx; -#define GOTO_DEPTH 64 OP *enterops[GOTO_DEPTH]; const char *label = NULL; STRLEN label_len = 0; @@ -3059,12 +3107,14 @@ PP(pp_goto) if (leaving_eval && *enterops && enterops[1]) { I32 i; for (i = 1; enterops[i]; i++) - if (enterops[i]->op_type == OP_ENTERITER) - DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); + S_check_op_type(aTHX_ enterops[i]); } if (*enterops && enterops[1]) { - I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; + I32 i = enterops[1] != UNENTERABLE + && enterops[1]->op_type == OP_ENTER && in_block + ? 2 + : 1; if (enterops[i]) deprecate("\"goto\" to jump into a construct"); } @@ -3083,13 +3133,15 @@ PP(pp_goto) if (*enterops && enterops[1]) { OP * const oldop = PL_op; - ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; + ix = enterops[1] != UNENTERABLE + && enterops[1]->op_type == OP_ENTER && in_block + ? 2 + : 1; for (; enterops[ix]; ix++) { PL_op = enterops[ix]; - /* Eventually we may want to stack the needed arguments - * for each op. For now, we punt on the hard ones. */ - if (PL_op->op_type == OP_ENTERITER) - DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); + S_check_op_type(aTHX_ PL_op); + DEBUG_l( Perl_deb(aTHX_ "pp_goto: Entering %s\n", + OP_NAME(PL_op))); PL_op->op_ppaddr(aTHX); } PL_op = oldop; @@ -4177,7 +4229,7 @@ S_require_file(pTHX_ SV *sv) } if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) { - sv_catpv(msg, " (you may need to install the "); + sv_catpvs(msg, " (you may need to install the "); for (c = name; c < e; c++) { if (*c == '/') { sv_catpvs(msg, "::"); @@ -4186,14 +4238,14 @@ S_require_file(pTHX_ SV *sv) sv_catpvn(msg, c, 1); } } - sv_catpv(msg, " module)"); + sv_catpvs(msg, " module)"); } } else if (memENDs(name, len, ".h")) { - sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)"); + sv_catpvs(msg, " (change .h to .ph maybe?) (did you run h2ph?)"); } else if (memENDs(name, len, ".ph")) { - sv_catpv(msg, " (did you run h2ph?)"); + sv_catpvs(msg, " (did you run h2ph?)"); } /* diag_listed_as: Can't locate %s */ @@ -5185,8 +5237,11 @@ PP(pp_enterwhen) to the op that follows the leavewhen. RETURNOP calls PUTBACK which restores the stack pointer after the POPs. */ - if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs)) + if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs)) { + if (gimme == G_SCALAR) + PUSHs(&PL_sv_undef); RETURNOP(cLOGOP->op_other->op_next); + } cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix); cx_pushwhen(cx);