#include "EXTERN.h"
#define PERL_IN_PP_CTL_C
#include "perl.h"
+#include "feature.h"
#define RUN_PP_CATCHABLY(thispp) \
STMT_START { if (CATCH_GET) return docatch(thispp); } STMT_END
+#define dopopto_cursub() \
+ (PL_curstackinfo->si_cxsubix >= 0 \
+ ? PL_curstackinfo->si_cxsubix \
+ : dopoptosub_at(cxstack, cxstack_ix))
+
#define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
PP(pp_wantarray)
if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
}
else {
- cxix = dopoptosub(cxstack_ix);
+ cxix = dopopto_cursub();
if (cxix < 0)
RETPUSHUNDEF;
cx = &cxstack[cxix];
cBOOL(cx->sb_rxtainted &
(SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
);
+
+ /* sv_magic(), when adding magic (e.g.taint magic), also
+ * recalculates any pos() magic, converting any byte offset
+ * to utf8 offset. Make sure pos() is reset before this
+ * happens rather than using the now invalid value (since
+ * we've just replaced targ's pvx buffer with the
+ * potentially shorter dstr buffer). Normally (i.e. in
+ * non-taint cases), pos() gets removed a few lines later
+ * with the SvSETMAGIC().
+ */
+ {
+ MAGIC *mg;
+ mg = mg_find_mglob(targ);
+ if (mg) {
+ MgBYTEPOS_set(mg, targ, SvPVX(targ), -1);
+ }
+ }
+
SvTAINT(TARG);
}
/* PL_tainted must be correctly set for this mg_set */
* 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. */
arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
#ifdef USE_QUADMATH
{
- const char* qfmt = quadmath_format_single(fmt);
int len;
- if (!qfmt)
+ if (!quadmath_format_valid(fmt))
Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
- len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
+ len = quadmath_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
if (len == -1)
- Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
- if (qfmt != fmt)
- Safefree(fmt);
+ Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", fmt);
}
#else
/* we generate fmt ourselves so it is safe */
}
/* 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)
return (gimme == G_VOID) ? G_SCALAR : gimme;
}
+/* note that this function has mostly been superseded by Perl_gimme_V */
+
U8
Perl_block_gimme(pTHX)
{
- const I32 cxix = dopoptosub(cxstack_ix);
+ const I32 cxix = dopopto_cursub();
U8 gimme;
if (cxix < 0)
return G_VOID;
I32
Perl_is_lvalue_sub(pTHX)
{
- const I32 cxix = dopoptosub(cxstack_ix);
+ const I32 cxix = dopopto_cursub();
assert(cxix >= 0); /* We should only be called from inside subs */
if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
* 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,
*/
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);
const PERL_CONTEXT *
Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
{
- I32 cxix = dopoptosub(cxstack_ix);
+ I32 cxix = dopopto_cursub();
const PERL_CONTEXT *cx;
const PERL_CONTEXT *ccstack = cxstack;
const PERL_SI *top_si = PL_curstackinfo;
{
dSP; dMARK;
PERL_CONTEXT *cx;
- const I32 cxix = dopoptosub(cxstack_ix);
+ const I32 cxix = dopopto_cursub();
assert(cxstack_ix >= 0);
if (cxix < cxstack_ix) {
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)
{
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) {
}
}
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;
/* 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");
OP *retop = NULL;
I32 ix;
PERL_CONTEXT *cx;
-#define GOTO_DEPTH 64
OP *enterops[GOTO_DEPTH];
const char *label = NULL;
STRLEN label_len = 0;
DIE(aTHX_ "Goto undefined subroutine");
}
- cxix = dopoptosub(cxstack_ix);
+ cxix = dopopto_cursub();
if (cxix < 0) {
DIE(aTHX_ "Can't goto subroutine outside a subroutine");
}
* this is a cx_popblock(), less all the stuff we already did
* for cx_topblock() earlier */
PL_curcop = cx->blk_oldcop;
+ /* this is cx_popsub, less all the stuff we already did */
+ PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix;
+
CX_POP(cx);
/* Push a mark for the start of arglist */
}
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");
}
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];
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;
if (clear_hints) {
PL_hints = 0;
hv_clear(GvHV(PL_hintgv));
+ CLEARFEATUREBITS();
}
else {
PL_hints = saveop->op_private & OPpEVAL_COPHH
/* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
SvREFCNT_dec(GvHV(PL_hintgv));
GvHV(PL_hintgv) = hh;
+ FETCHFEATUREBITSHH(hh);
}
}
SAVECOMPILEWARNINGS();
if (op_is_require) {
/* can optimize to only perform one single lookup */
svp_cached = hv_fetch(GvHVn(PL_incgv), (char*) name, len, 0);
- if ( svp_cached && *svp_cached != &PL_sv_undef ) RETPUSHYES;
+ if ( svp_cached && (SvGETMAGIC(*svp_cached), SvOK(*svp_cached)) ) RETPUSHYES;
}
#endif
/* reuse the previous hv_fetch result if possible */
SV * const * const svp = svp_cached ? svp_cached : hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
if ( svp ) {
- if (*svp != &PL_sv_undef)
+ /* we already did a get magic if this was cached */
+ if (!svp_cached)
+ SvGETMAGIC(*svp);
+ if (SvOK(*svp))
RETPUSHYES;
else
DIE(aTHX_ "Attempt to reload %s aborted.\n"
}
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, "::");
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 */
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);
https://perl5.git.perl.org / perl5.git / blobdiff