TAINT_NOT; /* Each statement is presumed innocent */
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
FREETMPS;
+ PERL_ASYNC_CHECK();
return NORMAL;
}
PP(pp_and)
{
dVAR; dSP;
+ PERL_ASYNC_CHECK();
if (!SvTRUE(TOPs))
RETURN;
else {
PP(pp_cond_expr)
{
dVAR; dSP;
+ PERL_ASYNC_CHECK();
if (SvTRUEx(POPs))
RETURNOP(cLOGOP->op_other);
else
{
dVAR;
I32 oldsave;
+ PERL_ASYNC_CHECK();
TAINT_NOT; /* Each statement is presumed innocent */
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
FREETMPS;
PP(pp_or)
{
dVAR; dSP;
+ PERL_ASYNC_CHECK();
if (SvTRUE(TOPs))
RETURN;
else {
const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
if (is_dor) {
+ PERL_ASYNC_CHECK();
sv = TOPs;
if (!sv || !SvANY(sv)) {
if (op_type == OP_DOR)
SV** const svp = av_fetch(av, PL_op->op_private, lval);
SV *sv = (svp ? *svp : &PL_sv_undef);
EXTEND(SP, 1);
- if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
- sv = sv_mortalcopy(sv);
+ if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
+ mg_get(sv);
PUSHs(sv);
RETURN;
}
RETURN;
}
if (!(io = GvIO(gv))) {
- if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
+ if ((GvEGVx(gv)) && (io = GvIO(GvEGV(gv)))
&& (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
goto had_magic;
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
SV ** const svp = av_fetch(av, i, FALSE);
/* See note in pp_helem, and bug id #27839 */
SP[i+1] = svp
- ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
+ ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
: &PL_sv_undef;
}
}
SV * const rv = sv_newmortal();
SvUPGRADE(rv, SVt_IV);
- /* This RV is about to own a reference to the regexp. (In addition to the
- reference already owned by the PMOP. */
- ReREFCNT_inc(rx);
- SvRV_set(rv, MUTABLE_SV(rx));
+ /* For a subroutine describing itself as "This is a hacky workaround" I'm
+ loathe to use it here, but it seems to be the right fix. Or close.
+ The key part appears to be that it's essential for pp_qr to return a new
+ object (SV), which implies that there needs to be an effective way to
+ generate a new SV from the existing SV that is pre-compiled in the
+ optree. */
+ SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
SvROK_on(rv);
if (pkg) {
}
PUTBACK; /* EVAL blocks need stack_sp. */
- s = SvPV_const(TARG, len);
+ /* Skip get-magic if this is a qr// clone, because regcomp has
+ already done it. */
+ s = ((struct regexp *)SvANY(rx))->mother_re
+ ? SvPV_nomg_const(TARG, len)
+ : SvPV_const(TARG, len);
if (!s)
DIE(aTHX_ "panic: pp_match");
strend = s + len;
vivify_ref(*svp, PL_op->op_private & OPpDEREF);
}
sv = (svp ? *svp : &PL_sv_undef);
- /* This makes C<local $tied{foo} = $tied{foo}> possible.
- * Pushing the magical RHS on to the stack is useless, since
- * that magic is soon destined to be misled by the local(),
- * and thus the later pp_sassign() will fail to mg_get() the
- * old value. This should also cure problems with delayed
- * mg_get()s. GSAR 98-07-03 */
- if (!lval && SvGMAGICAL(sv))
- sv = sv_mortalcopy(sv);
+ /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
+ * was to make C<local $tied{foo} = $tied{foo}> possible.
+ * However, it seems no longer to be needed for that purpose, and
+ * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
+ * would loop endlessly since the pos magic is getting set on the
+ * mortal copy and lost. However, the copy has the effect of
+ * triggering the get magic, and losing it altogether made things like
+ * c<$tied{foo};> in void context no longer do get magic, which some
+ * code relied on. Also, delayed triggering of magic on @+ and friends
+ * meant the original regex may be out of scope by now. So as a
+ * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
+ * being called too many times). */
+ if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
+ mg_get(sv);
PUSHs(sv);
RETURN;
}
bool is_cow;
#endif
SV *nsv = NULL;
-
/* known replacement string? */
register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
+
+ PERL_ASYNC_CHECK();
+
if (PL_op->op_flags & OPf_STACKED)
TARG = POPs;
else if (PL_op->op_private & OPpTARGET_MY)
}
PUTBACK;
- LEAVE_with_name("sub");
+ LEAVE;
cxstack_ix--;
POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
PL_curpm = newpm; /* ... and pop $1 et al */
* the refcounts so the caller gets a live guy. Cannot set
* TEMP, so sv_2mortal is out of question. */
if (!CvLVALUE(cx->blk_sub.cv)) {
- LEAVE_with_name("sub");
+ LEAVE;
cxstack_ix--;
POPSUB(cx,sv);
PL_curpm = newpm;
* of a tied hash or array */
if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
!(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
- LEAVE_with_name("sub");
+ LEAVE;
cxstack_ix--;
POPSUB(cx,sv);
PL_curpm = newpm;
}
}
else { /* Should not happen? */
- LEAVE_with_name("sub");
+ LEAVE;
cxstack_ix--;
POPSUB(cx,sv);
PL_curpm = newpm;
&& SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
/* Might be flattened array after $#array = */
PUTBACK;
- LEAVE_with_name("sub");
+ LEAVE;
cxstack_ix--;
POPSUB(cx,sv);
PL_curpm = newpm;
}
PUTBACK;
- LEAVE_with_name("sub");
+ LEAVE;
cxstack_ix--;
POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
PL_curpm = newpm; /* ... and pop $1 et al */
cv = sv_2cv(sv, &stash, &gv, 0);
}
if (!cv) {
- ENTER_with_name("sub");
+ ENTER;
SAVETMPS;
goto try_autoload;
}
break;
}
- ENTER_with_name("sub");
+ ENTER;
SAVETMPS;
retry:
*(PL_stack_base + markix) = *PL_stack_sp;
PL_stack_sp = PL_stack_base + markix;
}
- LEAVE_with_name("sub");
+ LEAVE;
return NORMAL;
}
}
vivify_ref(*svp, PL_op->op_private & OPpDEREF);
}
sv = (svp ? *svp : &PL_sv_undef);
- if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
- sv = sv_mortalcopy(sv);
+ if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
+ mg_get(sv);
PUSHs(sv);
RETURN;
}
https://perl5.git.perl.org / perl5.git / blobdiff