PP(pp_regcreset)
{
dVAR;
- /* XXXX Should store the old value to allow for tie/overload - and
- restore in regcomp, where marked with XXXX. */
- PL_reginterp_cnt = 0;
TAINT_NOT;
return NORMAL;
}
{
dVAR;
dSP;
- register PMOP *pm = (PMOP*)cLOGOP->op_other;
- SV *tmpstr;
+ PMOP *pm = (PMOP*)cLOGOP->op_other;
+ SV **args;
+ int nargs;
REGEXP *re = NULL;
+ REGEXP *new_re;
+ const regexp_engine *eng;
+ bool is_bare_re;
+
+ if (PL_op->op_flags & OPf_STACKED) {
+ dMARK;
+ nargs = SP - MARK;
+ args = ++MARK;
+ }
+ else {
+ nargs = 1;
+ args = SP;
+ }
/* prevent recompiling under /o and ithreads. */
#if defined(USE_ITHREADS)
if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
- if (PL_op->op_flags & OPf_STACKED) {
- dMARK;
- SP = MARK;
- }
- else
- (void)POPs;
+ SP = args-1;
RETURN;
}
#endif
-#define tryAMAGICregexp(rx) \
- STMT_START { \
- SvGETMAGIC(rx); \
- if (SvROK(rx) && SvAMAGIC(rx)) { \
- SV *sv = AMG_CALLunary(rx, regexp_amg); \
- if (sv) { \
- if (SvROK(sv)) \
- sv = SvRV(sv); \
- if (SvTYPE(sv) != SVt_REGEXP) \
- Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
- rx = sv; \
- } \
- } \
- } STMT_END
-
-
- if (PL_op->op_flags & OPf_STACKED) {
- /* multiple args; concatenate them */
- dMARK; dORIGMARK;
- tmpstr = PAD_SV(ARGTARG);
- sv_setpvs(tmpstr, "");
- while (++MARK <= SP) {
- SV *msv = *MARK;
- SV *sv;
-
- tryAMAGICregexp(msv);
-
- if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
- (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
- {
- sv_setsv(tmpstr, sv);
- continue;
- }
-
- if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP) {
- msv = SvRV(msv);
- PL_reginterp_cnt +=
- RX_SEEN_EVALS((REGEXP *)MUTABLE_PTR(msv));
- }
-
- sv_catsv_nomg(tmpstr, msv);
+ re = PM_GETRE(pm);
+ assert (re != (REGEXP*) &PL_sv_undef);
+ eng = re ? RX_ENGINE(re) : current_re_engine();
+
+ new_re = (eng->op_comp
+ ? eng->op_comp
+ : &Perl_re_op_compile
+ )(aTHX_ args, nargs, pm->op_code_list, eng, re,
+ &is_bare_re,
+ (pm->op_pmflags & RXf_PMf_COMPILETIME),
+ pm->op_pmflags |
+ (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
+ if (pm->op_pmflags & PMf_HAS_CV)
+ ReANY(new_re)->qr_anoncv
+ = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
+
+ if (is_bare_re) {
+ REGEXP *tmp;
+ /* The match's LHS's get-magic might need to access this op's regexp
+ (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
+ get-magic now before we replace the regexp. Hopefully this hack can
+ be replaced with the approach described at
+ http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
+ some day. */
+ if (pm->op_type == OP_MATCH) {
+ SV *lhs;
+ const bool was_tainted = TAINT_get;
+ if (pm->op_flags & OPf_STACKED)
+ lhs = args[-1];
+ else if (pm->op_private & OPpTARGET_MY)
+ lhs = PAD_SV(pm->op_targ);
+ else lhs = DEFSV;
+ SvGETMAGIC(lhs);
+ /* Restore the previous value of PL_tainted (which may have been
+ modified by get-magic), to avoid incorrectly setting the
+ RXf_TAINTED flag with RX_TAINT_on further down. */
+ TAINT_set(was_tainted);
}
- SvSETMAGIC(tmpstr);
- SP = ORIGMARK;
+ tmp = reg_temp_copy(NULL, new_re);
+ ReREFCNT_dec(new_re);
+ new_re = tmp;
}
- else {
- tmpstr = POPs;
- tryAMAGICregexp(tmpstr);
- }
-
-#undef tryAMAGICregexp
-
- if (SvROK(tmpstr)) {
- SV * const sv = SvRV(tmpstr);
- if (SvTYPE(sv) == SVt_REGEXP)
- re = (REGEXP*) sv;
- }
- else if (SvTYPE(tmpstr) == SVt_REGEXP)
- re = (REGEXP*) tmpstr;
-
- if (re) {
- /* The match's LHS's get-magic might need to access this op's reg-
- exp (as is sometimes the case with $'; see bug 70764). So we
- must call get-magic now before we replace the regexp. Hopeful-
- ly this hack can be replaced with the approach described at
- http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
- /msg122415.html some day. */
- if(pm->op_type == OP_MATCH) {
- SV *lhs;
- const bool was_tainted = PL_tainted;
- if (pm->op_flags & OPf_STACKED)
- lhs = TOPs;
- else if (pm->op_private & OPpTARGET_MY)
- lhs = PAD_SV(pm->op_targ);
- else lhs = DEFSV;
- SvGETMAGIC(lhs);
- /* Restore the previous value of PL_tainted (which may have been
- modified by get-magic), to avoid incorrectly setting the
- RXf_TAINTED flag further down. */
- PL_tainted = was_tainted;
- }
-
- re = reg_temp_copy(NULL, re);
- ReREFCNT_dec(PM_GETRE(pm));
- PM_SETRE(pm, re);
+ if (re != new_re) {
+ ReREFCNT_dec(re);
+ PM_SETRE(pm, new_re);
}
- else {
- STRLEN len = 0;
- const char *t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : "";
-
- re = PM_GETRE(pm);
- assert (re != (REGEXP*) &PL_sv_undef);
-
- /* Check against the last compiled regexp. */
- if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
- memNE(RX_PRECOMP(re), t, len))
- {
- const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
- U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
- if (re) {
- ReREFCNT_dec(re);
-#ifdef USE_ITHREADS
- PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
-#else
- PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
-#endif
- } else if (PL_curcop->cop_hints_hash) {
- SV *ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
- if (ptr && SvIOK(ptr) && SvIV(ptr))
- eng = INT2PTR(regexp_engine*,SvIV(ptr));
- }
-
- if (PL_op->op_flags & OPf_SPECIAL)
- PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
-
- if (!DO_UTF8(tmpstr) && SvUTF8(tmpstr)) {
- /* Not doing UTF-8, despite what the SV says. Is this only if
- we're trapped in use 'bytes'? */
- /* Make a copy of the octet sequence, but without the flag on,
- as the compiler now honours the SvUTF8 flag on tmpstr. */
- STRLEN len;
- const char *const p = SvPV(tmpstr, len);
- tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
- }
- else if (SvAMAGIC(tmpstr) || SvGMAGICAL(tmpstr)) {
- /* make a copy to avoid extra stringifies */
- tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr));
- }
-
- if (eng)
- PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
- else
- PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
-
- PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
- inside tie/overload accessors. */
- }
- }
-
- re = PM_GETRE(pm);
#ifndef INCOMPLETE_TAINTS
- if (PL_tainting) {
- if (PL_tainted) {
- SvTAINTED_on((SV*)re);
- RX_EXTFLAGS(re) |= RXf_TAINTED;
- }
+ if (TAINTING_get && TAINT_get) {
+ SvTAINTED_on((SV*)new_re);
+ RX_TAINT_on(new_re);
}
#endif
- if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
- pm = PL_curpm;
-
-
#if !defined(USE_ITHREADS)
/* can't change the optree at runtime either */
/* PMf_KEEP is handled differently under threads to avoid these problems */
+ if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
+ pm = PL_curpm;
if (pm->op_pmflags & PMf_KEEP) {
pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
cLOGOP->op_first->op_next = PL_op->op_next;
}
#endif
+
+ SP = args-1;
RETURN;
}
+
PP(pp_substcont)
{
dVAR;
dSP;
- register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
- register PMOP * const pm = (PMOP*) cLOGOP->op_other;
- register SV * const dstr = cx->sb_dstr;
- register char *s = cx->sb_s;
- register char *m = cx->sb_m;
+ PERL_CONTEXT *cx = &cxstack[cxstack_ix];
+ PMOP * const pm = (PMOP*) cLOGOP->op_other;
+ SV * const dstr = cx->sb_dstr;
+ char *s = cx->sb_s;
+ char *m = cx->sb_m;
char *orig = cx->sb_orig;
- register REGEXP * const rx = cx->sb_rx;
+ REGEXP * const rx = cx->sb_rx;
SV *nsv = NULL;
REGEXP *old = PM_GETRE(pm);
s -= RX_GOFS(rx);
/* Are we done */
- /* I believe that we can't set REXEC_SCREAM here if
- SvSCREAM(cx->sb_targ) is true because SvPVX(cx->sb_targ) isn't always
- equal to s. [See the comment before Perl_re_intuit_start(), which is
- called from Perl_regexec_flags(), which says that it should be when
- SvSCREAM() is true.] s, cx->sb_strend and orig will be consistent
- with SvPVX(cx->sb_targ), as substconst doesn't modify cx->sb_targ
- during the match. */
if (CxONCE(cx) || s < orig ||
!CALLREGEXEC(rx, s, cx->sb_strend, orig,
(s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
- ((cx->sb_rflags & REXEC_COPY_STR)
- ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
- : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
+ (REXEC_IGNOREPOS|REXEC_NOT_FIRST)))
{
SV *targ = cx->sb_targ;
assert(cx->sb_strend >= s);
if(cx->sb_strend > s) {
if (DO_UTF8(dstr) && !SvUTF8(targ))
- sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
+ sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
else
- sv_catpvn(dstr, s, cx->sb_strend - s);
+ sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
}
if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
cx->sb_rxtainted |= SUBST_TAINT_PAT;
SvUTF8_on(targ);
SvPV_set(dstr, NULL);
+ PL_tainted = 0;
mPUSHi(saviters - 1);
(void)SvPOK_only_UTF8(targ);
/* update the taint state of various various variables in
* preparation for final exit.
* See "how taint works" above pp_subst() */
- if (PL_tainting) {
+ if (TAINTING_get) {
if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
== (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
)
SvTAINTED_on(TOPs); /* taint return value */
/* needed for mg_set below */
- PL_tainted = cBOOL(cx->sb_rxtainted &
- (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
+ TAINT_set(
+ cBOOL(cx->sb_rxtainted &
+ (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
+ );
SvTAINT(TARG);
}
/* PL_tainted must be correctly set for this mg_set */
LEAVE_SCOPE(cx->sb_oldsave);
POPSUBST(cx);
RETURNOP(pm->op_next);
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
}
cx->sb_iters = saviters;
}
if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
m = s;
s = orig;
+ assert(!RX_SUBOFFSET(rx));
cx->sb_orig = orig = RX_SUBBEG(rx);
s = orig + (m - s);
cx->sb_strend = s + (cx->sb_strend - m);
cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
if (m > s) {
if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
- sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
+ sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
else
- sv_catpvn(dstr, s, m-s);
+ sv_catpvn_nomg(dstr, s, m-s);
}
cx->sb_s = RX_OFFS(rx)[0].end + orig;
{ /* Update the pos() information. */
/* update the taint state of various various variables in preparation
* for calling the code block.
* See "how taint works" above pp_subst() */
- if (PL_tainting) {
+ if (TAINTING_get) {
if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
cx->sb_rxtainted |= SUBST_TAINT_PAT;
PERL_UNUSED_CONTEXT;
if (!p || p[1] < RX_NPARENS(rx)) {
-#ifdef PERL_OLD_COPY_ON_WRITE
- i = 7 + RX_NPARENS(rx) * 2;
+#ifdef PERL_ANY_COW
+ i = 7 + (RX_NPARENS(rx)+1) * 2;
#else
- i = 6 + RX_NPARENS(rx) * 2;
+ i = 6 + (RX_NPARENS(rx)+1) * 2;
#endif
if (!p)
Newx(p, i, UV);
*rsp = (void*)p;
}
+ /* what (if anything) to free on croak */
*p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
RX_MATCH_COPIED_off(rx);
+ *p++ = RX_NPARENS(rx);
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
*p++ = PTR2UV(RX_SAVED_COPY(rx));
RX_SAVED_COPY(rx) = NULL;
#endif
- *p++ = RX_NPARENS(rx);
-
*p++ = PTR2UV(RX_SUBBEG(rx));
*p++ = (UV)RX_SUBLEN(rx);
+ *p++ = (UV)RX_SUBOFFSET(rx);
+ *p++ = (UV)RX_SUBCOFFSET(rx);
for (i = 0; i <= RX_NPARENS(rx); ++i) {
*p++ = (UV)RX_OFFS(rx)[i].start;
*p++ = (UV)RX_OFFS(rx)[i].end;
RX_MATCH_COPY_FREE(rx);
RX_MATCH_COPIED_set(rx, *p);
*p++ = 0;
+ RX_NPARENS(rx) = *p++;
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
if (RX_SAVED_COPY(rx))
SvREFCNT_dec (RX_SAVED_COPY(rx));
RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
*p++ = 0;
#endif
- RX_NPARENS(rx) = *p++;
-
RX_SUBBEG(rx) = INT2PTR(char*,*p++);
RX_SUBLEN(rx) = (I32)(*p++);
+ RX_SUBOFFSET(rx) = (I32)*p++;
+ RX_SUBCOFFSET(rx) = (I32)*p++;
for (i = 0; i <= RX_NPARENS(rx); ++i) {
RX_OFFS(rx)[i].start = (I32)(*p++);
RX_OFFS(rx)[i].end = (I32)(*p++);
PERL_UNUSED_CONTEXT;
if (p) {
-#ifdef PERL_POISON
void *tmp = INT2PTR(char*,*p);
- Safefree(tmp);
- if (*p)
- PoisonFree(*p, 1, sizeof(*p));
+#ifdef PERL_POISON
+#ifdef PERL_ANY_COW
+ U32 i = 9 + p[1] * 2;
#else
- Safefree(INT2PTR(char*,*p));
+ U32 i = 8 + p[1] * 2;
#endif
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (p[1]) {
- SvREFCNT_dec (INT2PTR(SV*,p[1]));
- }
#endif
+
+#ifdef PERL_ANY_COW
+ SvREFCNT_dec (INT2PTR(SV*,p[2]));
+#endif
+#ifdef PERL_POISON
+ PoisonFree(p, i, sizeof(UV));
+#endif
+
+ Safefree(tmp);
Safefree(p);
*rsp = NULL;
}
PP(pp_formline)
{
dVAR; dSP; dMARK; dORIGMARK;
- register SV * const tmpForm = *++MARK;
+ SV * const tmpForm = *++MARK;
SV *formsv; /* contains text of original format */
- register U32 *fpc; /* format ops program counter */
- register char *t; /* current append position in target string */
+ U32 *fpc; /* format ops program counter */
+ char *t; /* current append position in target string */
const char *f; /* current position in format string */
- register I32 arg;
- register SV *sv = NULL; /* current item */
+ I32 arg;
+ SV *sv = NULL; /* current item */
const char *item = NULL;/* string value of current item */
I32 itemsize = 0; /* length of current item, possibly truncated */
I32 fieldsize = 0; /* width of current field */
SvGETMAGIC(right);
if (RANGE_IS_NUMERIC(left,right)) {
- register IV i, j;
+ IV i, j;
IV max;
if ((SvOK(left) && SvNV_nomg(left) < IV_MIN) ||
(SvOK(right) && SvNV_nomg(right) > IV_MAX))
S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
{
dVAR;
- register I32 i;
+ I32 i;
PERL_ARGS_ASSERT_DOPOPTOLABEL;
for (i = cxstack_ix; i >= 0; i--) {
- register const PERL_CONTEXT * const cx = &cxstack[i];
+ const PERL_CONTEXT * const cx = &cxstack[i];
switch (CxTYPE(cx)) {
case CXt_SUBST:
case CXt_SUB:
return G_ARRAY;
default:
Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
return 0;
}
}
PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
for (i = startingblock; i >= 0; i--) {
- register const PERL_CONTEXT * const cx = &cxstk[i];
+ const PERL_CONTEXT * const cx = &cxstk[i];
switch (CxTYPE(cx)) {
default:
continue;
dVAR;
I32 i;
for (i = startingblock; i >= 0; i--) {
- register const PERL_CONTEXT *cx = &cxstack[i];
+ const PERL_CONTEXT *cx = &cxstack[i];
switch (CxTYPE(cx)) {
default:
continue;
dVAR;
I32 i;
for (i = startingblock; i >= 0; i--) {
- register const PERL_CONTEXT * const cx = &cxstack[i];
+ const PERL_CONTEXT * const cx = &cxstack[i];
switch (CxTYPE(cx)) {
case CXt_SUBST:
case CXt_SUB:
dVAR;
I32 i;
for (i = startingblock; i >= 0; i--) {
- register const PERL_CONTEXT *cx = &cxstack[i];
+ const PERL_CONTEXT *cx = &cxstack[i];
switch (CxTYPE(cx)) {
default:
continue;
dVAR;
I32 i;
for (i = startingblock; i >= 0; i--) {
- register const PERL_CONTEXT *cx = &cxstack[i];
+ const PERL_CONTEXT *cx = &cxstack[i];
switch (CxTYPE(cx)) {
default:
continue;
while (cxstack_ix > cxix) {
SV *sv;
- register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
+ PERL_CONTEXT *cx = &cxstack[cxstack_ix];
DEBUG_CX("UNWIND"); \
/* Note: we don't need to restore the base context info till the end. */
switch (CxTYPE(cx)) {
if (cxix >= 0) {
I32 optype;
SV *namesv;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
SV **newsp;
COP *oldcop;
JMPENV *restartjmpenv;
PL_restartjmpenv = restartjmpenv;
PL_restartop = restartop;
JMPENV_JUMP(3);
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
}
}
write_to_stderr(exceptsv);
my_failure_exit();
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
}
PP(pp_xor)
const PERL_CONTEXT *
Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
{
- register I32 cxix = dopoptosub(cxstack_ix);
- register const PERL_CONTEXT *cx;
- register const PERL_CONTEXT *ccstack = cxstack;
+ I32 cxix = dopoptosub(cxstack_ix);
+ const PERL_CONTEXT *cx;
+ const PERL_CONTEXT *ccstack = cxstack;
const PERL_SI *top_si = PL_curstackinfo;
for (;;) {
{
dVAR;
dSP;
- register const PERL_CONTEXT *cx;
+ const PERL_CONTEXT *cx;
const PERL_CONTEXT *dbcx;
I32 gimme;
const HEK *stash_hek;
RETURN;
}
- stash_hek = HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop));
+ DEBUG_CX("CALLER");
+ assert(CopSTASH(cx->blk_oldcop));
+ stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
+ ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
+ : NULL;
if (GIMME != G_ARRAY) {
EXTEND(SP, 1);
if (!stash_hek)
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
GV * const cvgv = CvGV(dbcx->blk_sub.cv);
/* So is ccstack[dbcxix]. */
- if (isGV(cvgv)) {
+ if (cvgv && isGV(cvgv)) {
SV * const sv = newSV(0);
gv_efullname3(sv, cvgv, NULL);
mPUSHs(sv);
if (CxTYPE(cx) == CXt_EVAL) {
/* eval STRING */
if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
- PUSHs(cx->blk_eval.cur_text);
+ PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text),
+ SvCUR(cx->blk_eval.cur_text)-2,
+ SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP));
PUSHs(&PL_sv_no);
}
/* require */
Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
}
- /* XXX only hints propagated via op_private are currently
- * visible (others are not easily accessible, since they
- * use the global PL_hints) */
mPUSHi(CopHINTS_get(cx->blk_oldcop));
{
SV * mask ;
STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
- if (old_warnings == pWARN_NONE ||
- (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
+ if (old_warnings == pWARN_NONE)
mask = newSVpvn(WARN_NONEstring, WARNsize) ;
+ else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
+ 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
{
dVAR;
dSP;
- const char * const tmps =
- (MAXARG < 1 || (!TOPs && !POPs)) ? (const char *)"" : POPpconstx;
- sv_reset(tmps, CopSTASH(PL_curcop));
+ const char * tmps;
+ STRLEN len = 0;
+ if (MAXARG < 1 || (!TOPs && !POPs))
+ tmps = NULL, len = 0;
+ else
+ tmps = SvPVx_const(POPs, len);
+ sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
PUSHs(&PL_sv_yes);
RETURN;
}
|| SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
{
dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
const I32 gimme = G_ARRAY;
U8 hasargs;
GV * const gv = PL_DBgv;
- register CV * const cv = GvCV(gv);
+ CV * cv = NULL;
- if (!cv)
+ if (gv && isGV_with_GP(gv))
+ cv = GvCV(gv);
+
+ if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
DIE(aTHX_ "No DB::DB routine defined");
if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
SPAGAIN;
if (CvISXSUB(cv)) {
- CvDEPTH(cv)++;
PUSHMARK(SP);
(void)(*CvXSUB(cv))(aTHX_ cv);
- CvDEPTH(cv)--;
FREETMPS;
LEAVE;
return NORMAL;
PUSHSUB_DB(cx);
cx->blk_sub.retop = PL_op->op_next;
CvDEPTH(cv)++;
+ if (CvDEPTH(cv) >= 2) {
+ PERL_STACK_OVERFLOW_CHECK();
+ pad_push(CvPADLIST(cv), CvDEPTH(cv));
+ }
SAVECOMPPAD();
- PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
+ PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
RETURNOP(CvSTART(cv));
}
}
PP(pp_enter)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
I32 gimme = GIMME_V;
ENTER_with_name("block");
PP(pp_leave)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
SV **newsp;
PMOP *newpm;
I32 gimme;
PP(pp_enteriter)
{
dVAR; dSP; dMARK;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
void *itervar; /* location of the iteration variable */
U8 cxtype = CXt_LOOP_FOR;
PP(pp_enterloop)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
ENTER_with_name("loop1");
PP(pp_leaveloop)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
PMOP *newpm;
if (MARK < SP) {
copy_sv:
if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
+ if (!SvPADTMP(*SP)) {
*++newsp = SvREFCNT_inc(*SP);
FREETMPS;
sv_2mortal(*newsp);
+ }
+ else {
+ /* FREETMPS could clobber it */
+ SV *sv = SvREFCNT_inc(*SP);
+ FREETMPS;
+ *++newsp = sv_mortalcopy(sv);
+ SvREFCNT_dec(sv);
+ }
}
else
*++newsp =
- !SvTEMP(*SP)
+ SvPADTMP(*SP)
+ ? sv_mortalcopy(*SP)
+ : !SvTEMP(*SP)
? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
: *SP;
}
if (ref || !CxLVAL(cx))
while (++MARK <= SP)
*++newsp =
- SvTEMP(*MARK)
- ? *MARK
- : ref && SvFLAGS(*MARK) & SVs_PADTMP
+ SvFLAGS(*MARK) & SVs_PADTMP
? sv_mortalcopy(*MARK)
+ : SvTEMP(*MARK)
+ ? *MARK
: sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
else while (++MARK <= SP) {
if (*MARK != &PL_sv_undef
PP(pp_return)
{
dVAR; dSP; dMARK;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
bool popsub2 = FALSE;
bool clear_errsv = FALSE;
bool lval = FALSE;
SV **newsp;
PMOP *newpm;
I32 gimme;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
SV *sv;
if (CxMULTICALL(&cxstack[cxstack_ix]))
return cx->blk_sub.retop;
}
-PP(pp_last)
+static I32
+S_unwind_loop(pTHX_ const char * const opname)
{
- dVAR; dSP;
+ dVAR;
I32 cxix;
- register PERL_CONTEXT *cx;
- I32 pop2 = 0;
- I32 gimme;
- I32 optype;
- OP *nextop = NULL;
- SV **newsp;
- PMOP *newpm;
- SV **mark;
- SV *sv = NULL;
-
-
if (PL_op->op_flags & OPf_SPECIAL) {
cxix = dopoptoloop(cxstack_ix);
if (cxix < 0)
- DIE(aTHX_ "Can't \"last\" outside a loop block");
+ /* diag_listed_as: Can't "last" outside a loop block */
+ Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
}
else {
- cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv),
- (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0);
+ dSP;
+ STRLEN label_len;
+ const char * const label =
+ PL_op->op_flags & OPf_STACKED
+ ? SvPV(TOPs,label_len)
+ : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
+ const U32 label_flags =
+ PL_op->op_flags & OPf_STACKED
+ ? SvUTF8(POPs)
+ : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
+ PUTBACK;
+ cxix = dopoptolabel(label, label_len, label_flags);
if (cxix < 0)
- DIE(aTHX_ "Label not found for \"last %"SVf"\"",
- SVfARG(newSVpvn_flags(cPVOP->op_pv,
- strlen(cPVOP->op_pv),
- ((cPVOP->op_private & OPpPV_IS_UTF8)
- ? SVf_UTF8 : 0) | SVs_TEMP)));
+ /* diag_listed_as: Label not found for "last %s" */
+ Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
+ opname,
+ SVfARG(PL_op->op_flags & OPf_STACKED
+ && !SvGMAGICAL(TOPp1s)
+ ? TOPp1s
+ : newSVpvn_flags(label,
+ label_len,
+ label_flags | SVs_TEMP)));
}
if (cxix < cxstack_ix)
dounwind(cxix);
+ return cxix;
+}
+
+PP(pp_last)
+{
+ dVAR;
+ PERL_CONTEXT *cx;
+ I32 pop2 = 0;
+ I32 gimme;
+ I32 optype;
+ OP *nextop = NULL;
+ SV **newsp;
+ PMOP *newpm;
+ SV **mark;
+ SV *sv = NULL;
+
+ S_unwind_loop(aTHX_ "last");
POPBLOCK(cx,newpm);
cxstack_ix++; /* temporarily protect top context */
}
TAINT_NOT;
- SP = adjust_stack_on_leave(newsp, SP, MARK, gimme,
+ PL_stack_sp = adjust_stack_on_leave(newsp, PL_stack_sp, MARK, gimme,
pop2 == CXt_SUB ? SVs_TEMP : 0);
- PUTBACK;
LEAVE;
cxstack_ix--;
PP(pp_next)
{
dVAR;
- I32 cxix;
- register PERL_CONTEXT *cx;
- I32 inner;
+ PERL_CONTEXT *cx;
+ const I32 inner = PL_scopestack_ix;
- if (PL_op->op_flags & OPf_SPECIAL) {
- cxix = dopoptoloop(cxstack_ix);
- if (cxix < 0)
- DIE(aTHX_ "Can't \"next\" outside a loop block");
- }
- else {
- cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv),
- (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0);
- if (cxix < 0)
- DIE(aTHX_ "Label not found for \"next %"SVf"\"",
- SVfARG(newSVpvn_flags(cPVOP->op_pv,
- strlen(cPVOP->op_pv),
- ((cPVOP->op_private & OPpPV_IS_UTF8)
- ? SVf_UTF8 : 0) | SVs_TEMP)));
- }
- if (cxix < cxstack_ix)
- dounwind(cxix);
+ S_unwind_loop(aTHX_ "next");
/* clear off anything above the scope we're re-entering, but
* save the rest until after a possible continue block */
- inner = PL_scopestack_ix;
TOPBLOCK(cx);
if (PL_scopestack_ix < inner)
leave_scope(PL_scopestack[PL_scopestack_ix]);
PP(pp_redo)
{
dVAR;
- I32 cxix;
- register PERL_CONTEXT *cx;
+ const I32 cxix = S_unwind_loop(aTHX_ "redo");
+ PERL_CONTEXT *cx;
I32 oldsave;
- OP* redo_op;
-
- if (PL_op->op_flags & OPf_SPECIAL) {
- cxix = dopoptoloop(cxstack_ix);
- if (cxix < 0)
- DIE(aTHX_ "Can't \"redo\" outside a loop block");
- }
- else {
- cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv),
- (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0);
- if (cxix < 0)
- DIE(aTHX_ "Label not found for \"redo %"SVf"\"",
- SVfARG(newSVpvn_flags(cPVOP->op_pv,
- strlen(cPVOP->op_pv),
- ((cPVOP->op_private & OPpPV_IS_UTF8)
- ? SVf_UTF8 : 0) | SVs_TEMP)));
- }
- if (cxix < cxstack_ix)
- dounwind(cxix);
+ OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
- redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
if (redo_op->op_type == OP_ENTER) {
/* pop one less context to avoid $x being freed in while (my $x..) */
cxstack_ix++;
{
dVAR;
OP **ops = opstack;
- static const char too_deep[] = "Target of goto is too deeply nested";
+ static const char* const too_deep = "Target of goto is too deeply nested";
PERL_ARGS_ASSERT_DOFINDLABEL;
dVAR; dSP;
OP *retop = NULL;
I32 ix;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
#define GOTO_DEPTH 64
OP *enterops[GOTO_DEPTH];
const char *label = NULL;
STRLEN label_len = 0;
U32 label_flags = 0;
const bool do_dump = (PL_op->op_type == OP_DUMP);
- static const char must_have_label[] = "goto must have label";
+ static const char* const must_have_label = "goto must have label";
if (PL_op->op_flags & OPf_STACKED) {
SV * const sv = POPs;
+ SvGETMAGIC(sv);
/* This egregious kludge implements goto &subroutine */
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
I32 cxix;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
CV *cv = MUTABLE_CV(SvRV(sv));
- SV** mark;
- I32 items = 0;
+ AV *arg = GvAV(PL_defgv);
I32 oldsave;
- bool reified = 0;
retry:
if (!CvROOT(cv) && !CvXSUB(cv)) {
SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
FREETMPS;
cxix = dopoptosub(cxstack_ix);
- if (cxix < 0)
- DIE(aTHX_ "Can't goto subroutine outside a subroutine");
- if (cxix < cxstack_ix)
+ if (cxix < cxstack_ix) {
+ if (cxix < 0) {
+ SvREFCNT_dec(cv);
+ DIE(aTHX_ "Can't goto subroutine outside a subroutine");
+ }
dounwind(cxix);
+ }
TOPBLOCK(cx);
SPAGAIN;
/* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
if (CxTYPE(cx) == CXt_EVAL) {
+ SvREFCNT_dec(cv);
if (CxREALEVAL(cx))
/* diag_listed_as: Can't goto subroutine from an eval-%s */
DIE(aTHX_ "Can't goto subroutine from an eval-string");
DIE(aTHX_ "Can't goto subroutine from an eval-block");
}
else if (CxMULTICALL(cx))
+ {
+ SvREFCNT_dec(cv);
DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
+ }
if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
- /* put @_ back onto stack */
AV* av = cx->blk_sub.argarray;
- items = AvFILLp(av) + 1;
- EXTEND(SP, items+1); /* @_ could have been extended. */
- Copy(AvARRAY(av), SP + 1, items, SV*);
- SvREFCNT_dec(GvAV(PL_defgv));
- GvAV(PL_defgv) = cx->blk_sub.savearray;
- CLEAR_ARGARRAY(av);
- /* abandon @_ if it got reified */
- if (AvREAL(av)) {
- reified = 1;
+ /* abandon the original @_ if it got reified or if it is
+ the same as the current @_ */
+ if (AvREAL(av) || av == arg) {
SvREFCNT_dec(av);
av = newAV();
- av_extend(av, items-1);
AvREIFY_only(av);
PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
}
+ else CLEAR_ARGARRAY(av);
}
- else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
- AV* const av = GvAV(PL_defgv);
- items = AvFILLp(av) + 1;
- EXTEND(SP, items+1); /* @_ could have been extended. */
- Copy(AvARRAY(av), SP + 1, items, SV*);
- }
- mark = SP;
- SP += items;
+ /* We donate this refcount later to the callee’s pad. */
+ SvREFCNT_inc_simple_void(arg);
if (CxTYPE(cx) == CXt_SUB &&
!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
SvREFCNT_dec(cx->blk_sub.cv);
* our precious cv. See bug #99850. */
if (!CvROOT(cv) && !CvXSUB(cv)) {
const GV * const gv = CvGV(cv);
+ SvREFCNT_dec(arg);
if (gv) {
SV * const tmpstr = sv_newmortal();
gv_efullname3(tmpstr, gv, NULL);
SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
if (CvISXSUB(cv)) {
OP* const retop = cx->blk_sub.retop;
- SV **newsp PERL_UNUSED_DECL;
- I32 gimme PERL_UNUSED_DECL;
- if (reified) {
+ SV **newsp;
+ I32 gimme;
+ const SSize_t items = AvFILLp(arg) + 1;
+ SV** mark;
+
+ PERL_UNUSED_VAR(newsp);
+ PERL_UNUSED_VAR(gimme);
+
+ /* put GvAV(defgv) back onto stack */
+ EXTEND(SP, items+1); /* @_ could have been extended. */
+ Copy(AvARRAY(arg), SP + 1, items, SV*);
+ mark = SP;
+ SP += items;
+ if (AvREAL(arg)) {
I32 index;
for (index=0; index<items; index++)
- sv_2mortal(SP[-index]);
+ SvREFCNT_inc_void(sv_2mortal(SP[-index]));
+ }
+ SvREFCNT_dec(arg);
+ if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
+ /* Restore old @_ */
+ arg = GvAV(PL_defgv);
+ GvAV(PL_defgv) = cx->blk_sub.savearray;
+ SvREFCNT_dec(arg);
}
/* XS subs don't have a CxSUB, so pop it */
return retop;
}
else {
- AV* const padlist = CvPADLIST(cv);
- if (CxTYPE(cx) == CXt_EVAL) {
- PL_in_eval = CxOLD_IN_EVAL(cx);
- PL_eval_root = cx->blk_eval.old_eval_root;
- cx->cx_type = CXt_SUB;
- }
+ PADLIST * const padlist = CvPADLIST(cv);
cx->blk_sub.cv = cv;
cx->blk_sub.olddepth = CvDEPTH(cv);
PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
if (CxHASARGS(cx))
{
- AV *const av = MUTABLE_AV(PAD_SVl(0));
-
- cx->blk_sub.savearray = GvAV(PL_defgv);
- GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
CX_CURPAD_SAVE(cx->blk_sub);
- cx->blk_sub.argarray = av;
- if (items >= AvMAX(av) + 1) {
- SV **ary = AvALLOC(av);
- if (AvARRAY(av) != ary) {
- AvMAX(av) += AvARRAY(av) - AvALLOC(av);
- AvARRAY(av) = ary;
- }
- if (items >= AvMAX(av) + 1) {
- AvMAX(av) = items - 1;
- Renew(ary,items+1,SV*);
- AvALLOC(av) = ary;
- AvARRAY(av) = ary;
- }
- }
- ++mark;
- Copy(mark,AvARRAY(av),items,SV*);
- AvFILLp(av) = items - 1;
- assert(!AvREAL(av));
- if (reified) {
- /* transfer 'ownership' of refcnts to new @_ */
- AvREAL_on(av);
- AvREIFY_off(av);
- }
- while (items--) {
- if (*mark)
- SvTEMP_off(*mark);
- mark++;
+ /* cx->blk_sub.argarray has no reference count, so we
+ need something to hang on to our argument array so
+ that cx->blk_sub.argarray does not end up pointing
+ to freed memory as the result of undef *_. So put
+ it in the callee’s pad, donating our refer-
+ ence count. */
+ SvREFCNT_dec(PAD_SVl(0));
+ PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
+
+ /* GvAV(PL_defgv) might have been modified on scope
+ exit, so restore it. */
+ if (arg != GvAV(PL_defgv)) {
+ AV * const av = GvAV(PL_defgv);
+ GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
+ SvREFCNT_dec(av);
}
}
+ else SvREFCNT_dec(arg);
if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
Perl_get_db_sub(aTHX_ NULL, cv);
if (PERLDB_GOTO) {
}
}
else {
- label = SvPV_const(sv, label_len);
+ label = SvPV_nomg_const(sv, label_len);
label_flags = SvUTF8(sv);
- if (!(do_dump || *label))
- DIE(aTHX_ must_have_label);
}
}
- else if (PL_op->op_flags & OPf_SPECIAL) {
- if (! do_dump)
- DIE(aTHX_ must_have_label);
- }
- else {
+ else if (!(PL_op->op_flags & OPf_SPECIAL)) {
label = cPVOP->op_pv;
label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
label_len = strlen(label);
- if (!(do_dump || *label)) DIE(aTHX_ must_have_label);
}
+ if (!(do_dump || label_len)) DIE(aTHX_ must_have_label);
PERL_ASYNC_CHECK();
- if (label && *label) {
+ if (label_len) {
OP *gotoprobe = NULL;
bool leaving_eval = FALSE;
bool in_block = FALSE;
JMPENV_POP;
PL_op = oldop;
JMPENV_JUMP(ret);
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
}
JMPENV_POP;
PL_op = oldop;
return NULL;
}
-/* James Bond: Do you expect me to talk?
- Auric Goldfinger: No, Mr. Bond. I expect you to die.
-
- This code is an ugly hack, doesn't work with lexicals in subroutines that are
- called more than once, and is only used by regcomp.c, for (?{}) blocks.
-
- Currently it is not used outside the core code. Best if it stays that way.
-
- Hence it's now deprecated, and will be removed.
-*/
-OP *
-Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
-/* sv Text to convert to OP tree. */
-/* startop op_free() this to undo. */
-/* code Short string id of the caller. */
-{
- PERL_ARGS_ASSERT_SV_COMPILE_2OP;
- return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
-}
-
-/* Don't use this. It will go away without warning once the regexp engine is
- refactored not to use it. */
-OP *
-Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
- PAD **padp)
-{
- dVAR; dSP; /* Make POPBLOCK work. */
- PERL_CONTEXT *cx;
- SV **newsp;
- I32 gimme = G_VOID;
- I32 optype;
- OP dummy;
- char tbuf[TYPE_DIGITS(long) + 12 + 10];
- char *tmpbuf = tbuf;
- char *safestr;
- int runtime;
- CV* runcv = NULL; /* initialise to avoid compiler warnings */
- STRLEN len;
- bool need_catch;
-
- PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
-
- ENTER_with_name("eval");
- lex_start(sv, NULL, LEX_START_SAME_FILTER);
- SAVETMPS;
- /* switch to eval mode */
-
- if (IN_PERL_COMPILETIME) {
- SAVECOPSTASH_FREE(&PL_compiling);
- CopSTASH_set(&PL_compiling, PL_curstash);
- }
- if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
- SV * const sv = sv_newmortal();
- Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
- code, (unsigned long)++PL_evalseq,
- CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
- tmpbuf = SvPVX(sv);
- len = SvCUR(sv);
- }
- else
- len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
- (unsigned long)++PL_evalseq);
- SAVECOPFILE_FREE(&PL_compiling);
- CopFILE_set(&PL_compiling, tmpbuf+2);
- SAVECOPLINE(&PL_compiling);
- CopLINE_set(&PL_compiling, 1);
- /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
- deleting the eval's FILEGV from the stash before gv_check() runs
- (i.e. before run-time proper). To work around the coredump that
- ensues, we always turn GvMULTI_on for any globals that were
- introduced within evals. See force_ident(). GSAR 96-10-12 */
- safestr = savepvn(tmpbuf, len);
- SAVEDELETE(PL_defstash, safestr, len);
- SAVEHINTS();
-#ifdef OP_IN_REGISTER
- PL_opsave = op;
-#else
- SAVEVPTR(PL_op);
-#endif
-
- /* we get here either during compilation, or via pp_regcomp at runtime */
- runtime = IN_PERL_RUNTIME;
- if (runtime)
- {
- runcv = find_runcv(NULL);
-
- /* At run time, we have to fetch the hints from PL_curcop. */
- PL_hints = PL_curcop->cop_hints;
- if (PL_hints & HINT_LOCALIZE_HH) {
- /* SAVEHINTS created a new HV in PL_hintgv, which we
- need to GC */
- SvREFCNT_dec(GvHV(PL_hintgv));
- GvHV(PL_hintgv) =
- refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
- hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
- }
- SAVECOMPILEWARNINGS();
- PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
- cophh_free(CopHINTHASH_get(&PL_compiling));
- /* XXX Does this need to avoid copying a label? */
- PL_compiling.cop_hints_hash
- = cophh_copy(PL_curcop->cop_hints_hash);
- }
-
- PL_op = &dummy;
- PL_op->op_type = OP_ENTEREVAL;
- PL_op->op_flags = 0; /* Avoid uninit warning. */
- PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
- PUSHEVAL(cx, 0);
- need_catch = CATCH_GET;
- CATCH_SET(TRUE);
-
- if (runtime)
- (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq, NULL);
- else
- (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax, NULL);
- CATCH_SET(need_catch);
- POPBLOCK(cx,PL_curpm);
- POPEVAL(cx);
-
- (*startop)->op_type = OP_NULL;
- (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
- /* XXX DAPM do this properly one year */
- *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
- LEAVE_with_name("eval");
- if (IN_PERL_COMPILETIME)
- CopHINTS_set(&PL_compiling, PL_hints);
-#ifdef OP_IN_REGISTER
- op = PL_opsave;
-#endif
- PERL_UNUSED_VAR(newsp);
- PERL_UNUSED_VAR(optype);
-
- return PL_eval_start;
-}
-
/*
=for apidoc find_runcv
CV*
Perl_find_runcv(pTHX_ U32 *db_seqp)
{
+ return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
+}
+
+/* If this becomes part of the API, it might need a better name. */
+CV *
+Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
+{
dVAR;
PERL_SI *si;
+ int level = 0;
if (db_seqp)
*db_seqp = PL_curcop->cop_seq;
I32 ix;
for (ix = si->si_cxix; ix >= 0; ix--) {
const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
+ CV *cv = NULL;
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
- CV * const cv = cx->blk_sub.cv;
+ cv = cx->blk_sub.cv;
/* skip DB:: code */
if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
*db_seqp = cx->blk_oldcop->cop_seq;
continue;
}
- return cv;
}
else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
- return cx->blk_eval.cv;
+ cv = cx->blk_eval.cv;
+ if (cv) {
+ switch (cond) {
+ case FIND_RUNCV_padid_eq:
+ if (!CvPADLIST(cv)
+ || PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg))
+ continue;
+ return cv;
+ case FIND_RUNCV_level_eq:
+ if (level++ != arg) continue;
+ /* GERONIMO! */
+ default:
+ return cv;
+ }
+ }
}
}
- return PL_main_cv;
+ return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
}
default:
JMPENV_POP;
JMPENV_JUMP(ret);
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
}
JMPENV_POP;
return ret;
}
-/* Compile a require/do, an eval '', or a /(?{...})/.
- * In the last case, startop is non-null, and contains the address of
- * a pointer that should be set to the just-compiled code.
+/* Compile a require/do or an eval ''.
+ *
* outside is the lexically enclosing CV (if any) that invoked us.
+ * seq is the current COP scope value.
+ * hh is the saved hints hash, if any.
+ *
* Returns a bool indicating whether the compile was successful; if so,
- * PL_eval_start contains the first op of the compiled ocde; otherwise,
- * pushes undef (also croaks if startop != NULL).
- */
-
-/* This function is called from three places, sv_compile_2op, pp_require
- * and pp_entereval. These can be distinguished as follows:
- * sv_compile_2op - startop is non-null
- * pp_require - startop is null; saveop is not entereval
- * pp_entereval - startop is null; saveop is entereval
+ * PL_eval_start contains the first op of the compiled code; otherwise,
+ * pushes undef.
+ *
+ * This function is called from two places: pp_require and pp_entereval.
+ * These can be distinguished by whether PL_op is entereval.
*/
STATIC bool
-S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh)
+S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
{
dVAR; dSP;
OP * const saveop = PL_op;
+ bool clear_hints = saveop->op_type != OP_ENTEREVAL;
COP * const oldcurcop = PL_curcop;
- bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
+ bool in_require = (saveop->op_type == OP_REQUIRE);
int yystatus;
CV *evalcv;
PL_madskills = 0;
#endif
- if (!startop) ENTER_with_name("evalcomp");
+ ENTER_with_name("evalcomp");
SAVESPTR(PL_compcv);
PL_compcv = evalcv;
PL_eval_root = NULL;
PL_curcop = &PL_compiling;
- if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
+ if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
PL_in_eval |= EVAL_KEEPERR;
else
CLEAR_ERRSV();
- if (!startop) {
- bool clear_hints = saveop->op_type != OP_ENTEREVAL;
- SAVEHINTS();
- if (clear_hints) {
- PL_hints = 0;
- hv_clear(GvHV(PL_hintgv));
- }
- else {
- PL_hints = saveop->op_private & OPpEVAL_COPHH
- ? oldcurcop->cop_hints : saveop->op_targ;
- if (hh) {
- /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
- SvREFCNT_dec(GvHV(PL_hintgv));
- GvHV(PL_hintgv) = hh;
- }
- }
- SAVECOMPILEWARNINGS();
- if (clear_hints) {
- if (PL_dowarn & G_WARN_ALL_ON)
- PL_compiling.cop_warnings = pWARN_ALL ;
- else if (PL_dowarn & G_WARN_ALL_OFF)
- PL_compiling.cop_warnings = pWARN_NONE ;
- else
- PL_compiling.cop_warnings = pWARN_STD ;
+ SAVEHINTS();
+ if (clear_hints) {
+ PL_hints = 0;
+ hv_clear(GvHV(PL_hintgv));
+ }
+ else {
+ PL_hints = saveop->op_private & OPpEVAL_COPHH
+ ? oldcurcop->cop_hints : saveop->op_targ;
+ if (hh) {
+ /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
+ SvREFCNT_dec(GvHV(PL_hintgv));
+ GvHV(PL_hintgv) = hh;
}
- else {
- PL_compiling.cop_warnings =
- DUP_WARNINGS(oldcurcop->cop_warnings);
- cophh_free(CopHINTHASH_get(&PL_compiling));
- if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
- /* The label, if present, is the first entry on the chain. So rather
- than writing a blank label in front of it (which involves an
- allocation), just use the next entry in the chain. */
- PL_compiling.cop_hints_hash
- = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
- /* Check the assumption that this removed the label. */
- assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
- }
- else
- PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
+ }
+ SAVECOMPILEWARNINGS();
+ if (clear_hints) {
+ if (PL_dowarn & G_WARN_ALL_ON)
+ PL_compiling.cop_warnings = pWARN_ALL ;
+ else if (PL_dowarn & G_WARN_ALL_OFF)
+ PL_compiling.cop_warnings = pWARN_NONE ;
+ else
+ PL_compiling.cop_warnings = pWARN_STD ;
+ }
+ else {
+ PL_compiling.cop_warnings =
+ DUP_WARNINGS(oldcurcop->cop_warnings);
+ cophh_free(CopHINTHASH_get(&PL_compiling));
+ if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
+ /* The label, if present, is the first entry on the chain. So rather
+ than writing a blank label in front of it (which involves an
+ allocation), just use the next entry in the chain. */
+ PL_compiling.cop_hints_hash
+ = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
+ /* Check the assumption that this removed the label. */
+ assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
}
+ else
+ PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
}
CALL_BLOCK_HOOKS(bhk_eval, saveop);
PERL_CONTEXT *cx;
I32 optype; /* Used by POPEVAL. */
SV *namesv;
+ SV *errsv = NULL;
cx = NULL;
namesv = NULL;
PL_eval_root = NULL;
}
SP = PL_stack_base + POPMARK; /* pop original mark */
- if (!startop) {
- POPBLOCK(cx,PL_curpm);
- POPEVAL(cx);
- namesv = cx->blk_eval.old_namesv;
- }
+ POPBLOCK(cx,PL_curpm);
+ POPEVAL(cx);
+ namesv = cx->blk_eval.old_namesv;
/* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
}
+ errsv = ERRSV;
if (in_require) {
if (!cx) {
/* If cx is still NULL, it means that we didn't go in the
SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
&PL_sv_undef, 0);
Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
- SVfARG(ERRSV
- ? ERRSV
- : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
- }
- else if (startop) {
- if (yystatus != 3) {
- POPBLOCK(cx,PL_curpm);
- POPEVAL(cx);
- }
- Perl_croak(aTHX_ "%"SVf"Compilation failed in regexp",
- SVfARG(ERRSV
- ? ERRSV
+ SVfARG(errsv
+ ? errsv
: newSVpvs_flags("Unknown error\n", SVs_TEMP)));
}
else {
- if (!*(SvPVx_nolen_const(ERRSV))) {
- sv_setpvs(ERRSV, "Compilation error");
+ if (!*(SvPV_nolen_const(errsv))) {
+ sv_setpvs(errsv, "Compilation error");
}
}
if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
PUTBACK;
return FALSE;
}
- else if (!startop) LEAVE_with_name("evalcomp");
+ else
+ LEAVE_with_name("evalcomp");
+
CopLINE_set(&PL_compiling, 0);
- if (startop) {
- *startop = PL_eval_root;
- } else
- SAVEFREEOP(PL_eval_root);
+ SAVEFREEOP(PL_eval_root);
+ cv_forget_slab(evalcv);
DEBUG_x(dump_eval());
/* Register with debugger: */
- if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
+ if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
CV * const cv = get_cvs("DB::postponed", 0);
if (cv) {
dSP;
PP(pp_require)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
SV *sv;
const char *name;
STRLEN len;
STRLEN unixlen;
#ifdef VMS
int vms_unixname = 0;
+ char *unixnamebuf;
+ char *unixdir;
+ char *unixdirbuf;
#endif
const char *tryname = NULL;
SV *namesv = NULL;
SV *hook_sv = NULL;
SV *encoding;
OP *op;
+ int saved_errno;
sv = POPs;
if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
sv = sv_2mortal(new_version(sv));
- if (!sv_derived_from(PL_patchlevel, "version"))
+ if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
upg_version(PL_patchlevel, TRUE);
if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
if ( vcmp(sv,PL_patchlevel) <= 0 )
* To prevent this, the key must be stored in UNIX format if the VMS
* name can be translated to UNIX.
*/
- if ((unixname = tounixspec(name, NULL)) != NULL) {
+
+ if ((unixnamebuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))
+ && (unixname = tounixspec(name, unixnamebuf)) != NULL) {
unixlen = strlen(unixname);
vms_unixname = 1;
}
}
}
+ LOADING_FILE_PROBE(unixname);
+
/* prepare to compile file */
if (path_is_absolute(name)) {
tryname = name;
tryrsfp = doopen_pm(sv);
}
- if (!tryrsfp) {
+ if (!tryrsfp && !(errno == EACCES && path_is_absolute(name))) {
AV * const ar = GvAVn(PL_incgv);
I32 i;
#ifdef VMS
}
#ifdef VMS
- char *unixdir;
- if ((unixdir = tounixpath(dir, NULL)) == NULL)
+ if (((unixdirbuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) == NULL)
+ || ((unixdir = tounixpath(dir, unixdirbuf)) == NULL))
continue;
sv_setpv(namesv, unixdir);
sv_catpv(namesv, unixname);
memcpy(tmp, dir, dirlen);
tmp +=dirlen;
- *tmp++ = '/';
+
+ /* Avoid '<dir>//<file>' */
+ if (!dirlen || *(tmp-1) != '/') {
+ *tmp++ = '/';
+ }
+
/* name came from an SV, so it will have a '\0' at the
end that we can copy as part of this memcpy(). */
memcpy(tmp, name, len + 1);
if (tryrsfp) {
if (tryname[0] == '.' && tryname[1] == '/') {
++tryname;
- while (*++tryname == '/');
+ while (*++tryname == '/') {}
}
break;
}
- else if (errno == EMFILE)
- /* no point in trying other paths if out of handles */
- break;
+ else if (errno == EMFILE || errno == EACCES) {
+ /* no point in trying other paths if out of handles;
+ * on the other hand, if we couldn't open one of the
+ * files, then going on with the search could lead to
+ * unexpected results; see perl #113422
+ */
+ break;
+ }
}
}
}
}
}
+ saved_errno = errno; /* sv_2mortal can realloc things */
sv_2mortal(namesv);
if (!tryrsfp) {
if (PL_op->op_type == OP_REQUIRE) {
- if(errno == EMFILE) {
+ if(saved_errno == EMFILE || saved_errno == EACCES) {
/* diag_listed_as: Can't locate %s */
- DIE(aTHX_ "Can't locate %s: %s", name, Strerror(errno));
+ DIE(aTHX_ "Can't locate %s: %s", name, Strerror(saved_errno));
} else {
if (namesv) { /* did we lookup @INC? */
AV * const ar = GvAVn(PL_incgv);
I32 i;
+ SV *const msg = newSVpvs_flags("", SVs_TEMP);
SV *const inc = newSVpvs_flags("", SVs_TEMP);
for (i = 0; i <= AvFILL(ar); i++) {
sv_catpvs(inc, " ");
sv_catsv(inc, *av_fetch(ar, i, TRUE));
}
+ if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
+ const char *c, *e = name + len - 3;
+ sv_catpv(msg, " (you may need to install the ");
+ for (c = name; c < e; c++) {
+ if (*c == '/') {
+ sv_catpvn(msg, "::", 2);
+ }
+ else {
+ sv_catpvn(msg, c, 1);
+ }
+ }
+ sv_catpv(msg, " module)");
+ }
+ else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
+ sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
+ }
+ else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
+ sv_catpv(msg, " (did you run h2ph?)");
+ }
/* diag_listed_as: Can't locate %s */
DIE(aTHX_
- "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
- name,
- (memEQ(name + len - 2, ".h", 3)
- ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
- (memEQ(name + len - 3, ".ph", 4)
- ? " (did you run h2ph?)" : ""),
- inc
- );
+ "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
+ name, msg, inc);
}
}
DIE(aTHX_ "Can't locate %s", name);
}
+ CLEAR_ERRSV();
RETPUSHUNDEF;
}
else
encoding = PL_encoding;
PL_encoding = NULL;
- if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq, NULL))
+ if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
op = DOCATCH(PL_eval_start);
else
op = PL_op->op_next;
/* Restore encoding. */
PL_encoding = encoding;
+ LOADED_FILE_PROBE(unixname);
+
return op;
}
PP(pp_entereval)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
SV *sv;
const I32 gimme = GIMME_V;
const U32 was = PL_breakable_sub_gen;
PUTBACK;
- if (doeval(gimme, NULL, runcv, seq, saved_hh)) {
+ if (doeval(gimme, runcv, seq, saved_hh)) {
if (was != PL_breakable_sub_gen /* Some subs defined here. */
? (PERLDB_LINE || PERLDB_SAVESRC)
: PERLDB_SAVESRC_NOSUBS) {
SV **newsp;
PMOP *newpm;
I32 gimme;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
OP *retop;
const U8 save_flags = PL_op -> op_flags;
I32 optype;
SV **newsp;
PMOP *newpm;
I32 gimme;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
I32 optype;
POPBLOCK(cx,newpm);
SV **newsp;
PMOP *newpm;
I32 gimme;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
I32 optype;
PERL_ASYNC_CHECK();
PP(pp_entergiven)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
ENTER_with_name("given");
SAVETMPS;
- SAVECLEARSV(PAD_SVl(PL_op->op_targ));
- sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs);
+ if (PL_op->op_targ) {
+ SAVEPADSVANDMORTALIZE(PL_op->op_targ);
+ SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
+ PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
+ }
+ else {
+ SAVE_DEFSV;
+ DEFSV_set(POPs);
+ }
PUSHBLOCK(cx, CXt_GIVEN, SP);
PUSHGIVEN(cx);
PP(pp_leavegiven)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
PMOP *newpm;
PP(pp_enterwhen)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
/* This is essentially an optimization: if the match
{
dVAR; dSP;
I32 cxix;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
PMOP *newpm;
{
dVAR; dSP;
I32 cxix;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
PMOP *newpm;
{
dVAR;
I32 cxix;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
cxix = dopoptogiven(cxstack_ix);
if (cxix < 0)
S_doparseform(pTHX_ SV *sv)
{
STRLEN len;
- register char *s = SvPV(sv, len);
- register char *send;
- register char *base = NULL; /* start of current field */
- register I32 skipspaces = 0; /* number of contiguous spaces seen */
+ char *s = SvPV(sv, len);
+ char *send;
+ char *base = NULL; /* start of current field */
+ I32 skipspaces = 0; /* number of contiguous spaces seen */
bool noblank = FALSE; /* ~ or ~~ seen on this line */
bool repeat = FALSE; /* ~~ seen on this line */
bool postspace = FALSE; /* a text field may need right padding */
U32 *fops;
- register U32 *fpc;
+ U32 *fpc;
U32 *linepc = NULL; /* position of last FF_LINEMARK */
- register I32 arg;
+ I32 arg;
bool ischop; /* it's a ^ rather than a @ */
bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
char *prune_from = NULL;
bool read_from_cache = FALSE;
STRLEN umaxlen;
+ SV *err = NULL;
PERL_ARGS_ASSERT_RUN_USER_FILTER;
PUSHs(filter_state);
}
PUTBACK;
- count = call_sv(filter_sub, G_SCALAR);
+ count = call_sv(filter_sub, G_SCALAR|G_EVAL);
SPAGAIN;
if (count > 0) {
if (SvOK(out)) {
status = SvIV(out);
}
+ else {
+ SV * const errsv = ERRSV;
+ if (SvTRUE_NN(errsv))
+ err = newSVsv(errsv);
+ }
}
PUTBACK;
LEAVE_with_name("call_filter_sub");
}
- if(SvOK(upstream)) {
+ if (SvIsCOW(upstream)) sv_force_normal(upstream);
+ if(!err && SvOK(upstream)) {
got_p = SvPV(upstream, got_len);
if (umaxlen) {
if (got_len > umaxlen) {
}
}
}
- if (prune_from) {
+ if (!err && prune_from) {
/* Oh. Too long. Stuff some in our cache. */
STRLEN cached_len = got_p + got_len - prune_from;
SV *const cache = datasv;
have touched the SV upstream, so it may be undefined. If we naively
concatenate it then we get a warning about use of uninitialised value.
*/
- if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
+ if (!err && upstream != buf_sv &&
+ (SvOK(upstream) || SvGMAGICAL(upstream))) {
sv_catsv(buf_sv, upstream);
}
}
filter_del(S_run_user_filter);
}
+
+ if (err)
+ croak_sv(err);
+
if (status == 0 && read_from_cache) {
/* If we read some data from the cache (and by getting here it implies
that we emptied the cache) then we aren't yet at EOF, and mustn't
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff