#define PERL_IN_PP_CTL_C
#include "perl.h"
-#ifndef WORD_ALIGN
-#define WORD_ALIGN sizeof(U32)
-#endif
-
#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
#define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
STMT_START { \
SvGETMAGIC(rx); \
if (SvROK(rx) && SvAMAGIC(rx)) { \
- SV *sv = AMG_CALLun(rx, regexp); \
+ SV *sv = AMG_CALLunary(rx, regexp_amg); \
if (sv) { \
if (SvROK(sv)) \
sv = SvRV(sv); \
if (PL_op->op_flags & OPf_STACKED) {
- /* multiple args; concatentate them */
+ /* multiple args; concatenate them */
dMARK; dORIGMARK;
tmpstr = PAD_SV(ARGTARG);
sv_setpvs(tmpstr, "");
sv_setsv(tmpstr, sv);
continue;
}
- sv_catsv(tmpstr, msv);
+ sv_catsv_nomg(tmpstr, msv);
}
SvSETMAGIC(tmpstr);
SP = ORIGMARK;
memNE(RX_PRECOMP(re), t, len))
{
const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
- U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
+ U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
if (re) {
ReREFCNT_dec(re);
#ifdef USE_ITHREADS
PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
#endif
} else if (PL_curcop->cop_hints_hash) {
- SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
- "regcomp", 7, 0, 0);
+ SV *ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
if (ptr && SvIOK(ptr) && SvIV(ptr))
eng = INT2PTR(regexp_engine*,SvIV(ptr));
}
tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr));
}
+ /* If it is gmagical, create a mortal copy, but without calling
+ get-magic, as we have already done that. */
+ if(SvGMAGICAL(tmpstr)) {
+ SV *mortalcopy = sv_newmortal();
+ sv_setsv_flags(mortalcopy, tmpstr, 0);
+ tmpstr = mortalcopy;
+ }
+
if (eng)
PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
else
#ifndef INCOMPLETE_TAINTS
if (PL_tainting) {
- if (PL_tainted)
+ if (PL_tainted) {
+ SvTAINTED_on((SV*)re);
RX_EXTFLAGS(re) |= RXf_TAINTED;
- else
- RX_EXTFLAGS(re) &= ~RXf_TAINTED;
+ }
}
#endif
SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
- if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
- cx->sb_rxtainted |= 2;
+ /* See "how taint works" above pp_subst() */
+ if (SvTAINTED(TOPs))
+ cx->sb_rxtainted |= SUBST_TAINT_REPL;
sv_catsv_nomg(dstr, POPs);
/* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
s -= RX_GOFS(rx);
else
sv_catpvn(dstr, s, cx->sb_strend - s);
}
- cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
+ if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
+ cx->sb_rxtainted |= SUBST_TAINT_PAT;
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(targ)) {
SvUTF8_on(targ);
SvPV_set(dstr, NULL);
- TAINT_IF(cx->sb_rxtainted & 1);
if (pm->op_pmflags & PMf_NONDESTRUCT)
PUSHs(targ);
else
mPUSHi(saviters - 1);
(void)SvPOK_only_UTF8(targ);
- TAINT_IF(cx->sb_rxtainted);
- SvSETMAGIC(targ);
- SvTAINT(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 ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
+ ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
+ == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
+ )
+ (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
+
+ if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
+ && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
+ )
+ 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));
+ SvTAINT(TARG);
+ }
+ /* PL_tainted must be correctly set for this mg_set */
+ SvSETMAGIC(TARG);
+ TAINT_NOT;
LEAVE_SCOPE(cx->sb_oldsave);
POPSUBST(cx);
RETURNOP(pm->op_next);
+ /* NOTREACHED */
}
cx->sb_iters = saviters;
}
}
if (old != rx)
(void)ReREFCNT_inc(rx);
- cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
+ /* 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 (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
+ cx->sb_rxtainted |= SUBST_TAINT_PAT;
+
+ if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
+ ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
+ == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
+ )
+ (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
+
+ if (cx->sb_iters > 1 && (cx->sb_rxtainted &
+ (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
+ SvTAINTED_on(cx->sb_targ);
+ TAINT_NOT;
+ }
rxres_save(&cx->sb_rxres, rx);
+ PL_curpm = pm;
RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
}
{
dVAR; dSP; dMARK; dORIGMARK;
register SV * const tmpForm = *++MARK;
- register U32 *fpc;
- register char *t;
- const char *f;
+ SV *formsv; /* contains text of original format */
+ register U32 *fpc; /* format ops program counter */
+ register char *t; /* current append position in target string */
+ const char *f; /* current position in format string */
register I32 arg;
- register SV *sv = NULL;
- const char *item = NULL;
- I32 itemsize = 0;
- I32 fieldsize = 0;
- I32 lines = 0;
- bool chopspace = (strchr(PL_chopset, ' ') != NULL);
- const char *chophere = NULL;
- char *linemark = NULL;
+ register 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 */
+ I32 lines = 0; /* number of lines that have been output */
+ bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
+ const char *chophere = NULL; /* where to chop current item */
+ char *linemark = NULL; /* pos of start of line in output */
NV value;
- bool gotsome = FALSE;
+ bool gotsome = FALSE; /* seen at least one non-blank item on this line */
STRLEN len;
- const STRLEN fudge = SvPOK(tmpForm)
- ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
+ STRLEN fudge; /* estimate of output size in bytes */
bool item_is_utf8 = FALSE;
bool targ_is_utf8 = FALSE;
SV * nsv = NULL;
- OP * parseres = NULL;
const char *fmt;
+ MAGIC *mg = NULL;
+ U8 *source; /* source of bytes to append */
+ STRLEN to_copy; /* how may bytes to append */
+
+ mg = doparseform(tmpForm);
+
+ fpc = (U32*)mg->mg_ptr;
+ /* the actual string the format was compiled from.
+ * with overload etc, this may not match tmpForm */
+ formsv = mg->mg_obj;
+
- if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
- if (SvREADONLY(tmpForm)) {
- SvREADONLY_off(tmpForm);
- parseres = doparseform(tmpForm);
- SvREADONLY_on(tmpForm);
- }
- else
- parseres = doparseform(tmpForm);
- if (parseres)
- return parseres;
- }
SvPV_force(PL_formtarget, len);
+ if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
+ SvTAINTED_on(PL_formtarget);
if (DO_UTF8(PL_formtarget))
targ_is_utf8 = TRUE;
+ fudge = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
t += len;
- f = SvPV_const(tmpForm, len);
- /* need to jump to the next word */
- fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
+ f = SvPV_const(formsv, len);
for (;;) {
DEBUG_f( {
case FF_LITERAL:
arg = *fpc++;
- if (targ_is_utf8 && !SvUTF8(tmpForm)) {
+ item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
+ if (targ_is_utf8 && !item_is_utf8) {
+ char *s;
SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
*t = '\0';
- sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
+
+ /* this is an unrolled sv_catpvn_utf8_upgrade(),
+ * but with the addition of s/~/ /g */
+ if (!(nsv))
+ nsv = newSVpvn_flags(f, arg, SVs_TEMP);
+ else
+ sv_setpvn(nsv, f, arg);
+ SvUTF8_off(nsv);
+ for (s = SvPVX(nsv); s <= SvEND(nsv); s++)
+ if (*s == '~')
+ *s = ' ';
+ sv_utf8_upgrade(nsv);
+ sv_catsv(PL_formtarget, nsv);
+
t = SvEND(PL_formtarget);
f += arg;
break;
}
- if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
+ if (!targ_is_utf8 && item_is_utf8) {
SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
*t = '\0';
- sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
+ sv_utf8_upgrade_flags_grow(PL_formtarget, 0, fudge + 1);
t = SvEND(PL_formtarget);
targ_is_utf8 = TRUE;
}
- while (arg--)
- *t++ = *f++;
+ while (arg--) {
+ *t++ = (*f == '~') ? ' ' : *f;
+ f++;
+ }
break;
case FF_SKIP:
sv = &PL_sv_no;
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
}
+ if (SvTAINTED(sv))
+ SvTAINTED_on(PL_formtarget);
break;
case FF_CHECKNL:
if (!targ_is_utf8) {
SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
*t = '\0';
- sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
+ sv_utf8_upgrade_flags_grow(PL_formtarget, 0,
fudge + 1);
t = SvEND(PL_formtarget);
targ_is_utf8 = TRUE;
const int ch = *t++ = *s++;
if (iscntrl(ch))
#else
- if ( !((*t++ = *s++) & ~31) )
+ if ( !((*t++ = *s++) & ~31) )
#endif
t[-1] = ' ';
}
{
const bool oneline = fpc[-1] == FF_LINESNGL;
const char *s = item = SvPV_const(sv, len);
+ const char *const send = s + len;
+
item_is_utf8 = DO_UTF8(sv);
- itemsize = len;
- if (itemsize) {
- STRLEN to_copy = itemsize;
- const char *const send = s + len;
- const U8 *source = (const U8 *) s;
- U8 *tmp = NULL;
-
- gotsome = TRUE;
- chophere = s + itemsize;
- while (s < send) {
- if (*s++ == '\n') {
- if (oneline) {
- to_copy = s - SvPVX_const(sv) - 1;
- chophere = s;
- break;
- } else {
- if (s == send) {
- itemsize--;
- to_copy--;
- } else
- lines++;
- }
+ if (!len)
+ break;
+ gotsome = TRUE;
+ chophere = s + len;
+ source = (U8 *) s;
+ to_copy = len;
+ while (s < send) {
+ if (*s++ == '\n') {
+ if (oneline) {
+ to_copy = s - SvPVX_const(sv) - 1;
+ chophere = s;
+ break;
+ } else {
+ if (s == send) {
+ to_copy--;
+ } else
+ lines++;
}
}
- if (targ_is_utf8 && !item_is_utf8) {
- source = tmp = bytes_to_utf8(source, &to_copy);
+ }
+ }
+
+ {
+ U8 *tmp = NULL;
+ if (targ_is_utf8 && !item_is_utf8) {
+ source = tmp = bytes_to_utf8(source, &to_copy);
+ SvCUR_set(PL_formtarget,
+ t - SvPVX_const(PL_formtarget));
+ } else {
+ if (item_is_utf8 && !targ_is_utf8) {
+ /* Upgrade targ to UTF8, and then we reduce it to
+ a problem we have a simple solution for. */
SvCUR_set(PL_formtarget,
t - SvPVX_const(PL_formtarget));
+ targ_is_utf8 = TRUE;
+ /* Don't need get magic. */
+ sv_utf8_upgrade_nomg(PL_formtarget);
} else {
- if (item_is_utf8 && !targ_is_utf8) {
- /* Upgrade targ to UTF8, and then we reduce it to
- a problem we have a simple solution for. */
- SvCUR_set(PL_formtarget,
- t - SvPVX_const(PL_formtarget));
- targ_is_utf8 = TRUE;
- /* Don't need get magic. */
- sv_utf8_upgrade_nomg(PL_formtarget);
- } else {
- SvCUR_set(PL_formtarget,
- t - SvPVX_const(PL_formtarget));
- }
-
- /* Easy. They agree. */
- assert (item_is_utf8 == targ_is_utf8);
- }
- SvGROW(PL_formtarget,
- SvCUR(PL_formtarget) + to_copy + fudge + 1);
- t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
-
- Copy(source, t, to_copy, char);
- t += to_copy;
- SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
- if (item_is_utf8) {
- if (SvGMAGICAL(sv)) {
- /* Mustn't call sv_pos_b2u() as it does a second
- mg_get(). Is this a bug? Do we need a _flags()
- variant? */
- itemsize = utf8_length(source, source + itemsize);
- } else {
- sv_pos_b2u(sv, &itemsize);
- }
- assert(!tmp);
- } else if (tmp) {
- Safefree(tmp);
+ SvCUR_set(PL_formtarget,
+ t - SvPVX_const(PL_formtarget));
}
+
+ /* Easy. They agree. */
+ assert (item_is_utf8 == targ_is_utf8);
}
+ SvGROW(PL_formtarget,
+ SvCUR(PL_formtarget) + to_copy + fudge + 1);
+ t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
+
+ Copy(source, t, to_copy, char);
+ t += to_copy;
+ SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
+ if (tmp)
+ Safefree(tmp);
break;
}
arg = *fpc++;
if (gotsome) {
if (arg) { /* repeat until fields exhausted? */
- *t = '\0';
- SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
- lines += FmLINES(PL_formtarget);
- if (targ_is_utf8)
- SvUTF8_on(PL_formtarget);
- FmLINES(PL_formtarget) = lines;
- SP = ORIGMARK;
- RETURNOP(cLISTOP->op_first);
+ fpc--;
+ goto end;
}
}
else {
break;
}
case FF_END:
+ end:
*t = '\0';
SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
if (targ_is_utf8)
SvUTF8_on(PL_formtarget);
FmLINES(PL_formtarget) += lines;
SP = ORIGMARK;
- RETPUSHYES;
+ if (fpc[-1] == FF_BLANK)
+ RETURNOP(cLISTOP->op_first);
+ else
+ RETPUSHYES;
}
}
}
RETURNOP(PL_op->op_next->op_next);
}
PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
- pp_pushmark(); /* push dst */
- pp_pushmark(); /* push src */
+ Perl_pp_pushmark(aTHX); /* push dst */
+ Perl_pp_pushmark(aTHX); /* push src */
ENTER_with_name("grep"); /* enter outer scope */
SAVETMPS;
PUTBACK;
if (PL_op->op_type == OP_MAPSTART)
- pp_pushmark(); /* push top */
+ Perl_pp_pushmark(aTHX); /* push top */
return ((LOGOP*)PL_op->op_next)->op_other;
}
/* copy the new items down to the destination list */
dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
if (gimme == G_ARRAY) {
- while (items-- > 0)
- *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
+ /* add returned items to the collection (making mortal copies
+ * if necessary), then clear the current temps stack frame
+ * *except* for those items. We do this splicing the items
+ * into the start of the tmps frame (so some items may be on
+ * the tmps stack twice), then moving PL_tmps_floor above
+ * them, then freeing the frame. That way, the only tmps that
+ * accumulate over iterations are the return values for map.
+ * We have to do to this way so that everything gets correctly
+ * freed if we die during the map.
+ */
+ I32 tmpsbase;
+ I32 i = items;
+ /* make space for the slice */
+ EXTEND_MORTAL(items);
+ tmpsbase = PL_tmps_floor + 1;
+ Move(PL_tmps_stack + tmpsbase,
+ PL_tmps_stack + tmpsbase + items,
+ PL_tmps_ix - PL_tmps_floor,
+ SV*);
+ PL_tmps_ix += items;
+
+ while (i-- > 0) {
+ SV *sv = POPs;
+ if (!SvTEMP(sv))
+ sv = sv_mortalcopy(sv);
+ *dst-- = sv;
+ PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
+ }
+ /* clear the stack frame except for the items */
+ PL_tmps_floor += items;
+ FREETMPS;
+ /* FREETMPS may have cleared the TEMP flag on some of the items */
+ i = items;
+ while (i-- > 0)
+ SvTEMP_on(PL_tmps_stack[--tmpsbase]);
}
else {
/* scalar context: we don't care about which values map returns
(void)POPs;
*dst-- = &PL_sv_undef;
}
+ FREETMPS;
}
}
+ else {
+ FREETMPS;
+ }
LEAVE_with_name("grep_item"); /* exit inner scope */
/* All done yet? */
PERL_ARGS_ASSERT_QERROR;
- if (PL_in_eval)
- sv_catsv(ERRSV, err);
+ if (PL_in_eval) {
+ if (PL_in_eval & EVAL_KEEPERR) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
+ SvPV_nolen_const(err));
+ }
+ else
+ sv_catsv(ERRSV, err);
+ }
else if (PL_errors)
sv_catsv(PL_errors, err);
else
I32 cxix;
I32 gimme;
+ /*
+ * Historically, perl used to set ERRSV ($@) early in the die
+ * process and rely on it not getting clobbered during unwinding.
+ * That sucked, because it was liable to get clobbered, so the
+ * setting of ERRSV used to emit the exception from eval{} has
+ * been moved to much later, after unwinding (see just before
+ * JMPENV_JUMP below). However, some modules were relying on the
+ * early setting, by examining $@ during unwinding to use it as
+ * a flag indicating whether the current unwinding was caused by
+ * an exception. It was never a reliable flag for that purpose,
+ * being totally open to false positives even without actual
+ * clobberage, but was useful enough for production code to
+ * semantically rely on it.
+ *
+ * We'd like to have a proper introspective interface that
+ * explicitly describes the reason for whatever unwinding
+ * operations are currently in progress, so that those modules
+ * work reliably and $@ isn't further overloaded. But we don't
+ * have one yet. In its absence, as a stopgap measure, ERRSV is
+ * now *additionally* set here, before unwinding, to serve as the
+ * (unreliable) flag that it used to.
+ *
+ * This behaviour is temporary, and should be removed when a
+ * proper way to detect exceptional unwinding has been developed.
+ * As of 2010-12, the authors of modules relying on the hack
+ * are aware of the issue, because the modules failed on
+ * perls 5.13.{1..7} which had late setting of $@ without this
+ * early-setting hack.
+ */
+ if (!(in_eval & EVAL_KEEPERR)) {
+ SvTEMP_off(exceptsv);
+ sv_setsv(ERRSV, exceptsv);
+ }
+
while ((cxix = dopoptoeval(cxstack_ix)) < 0
&& PL_curstackinfo->si_prev)
{
SV *namesv;
register PERL_CONTEXT *cx;
SV **newsp;
+ COP *oldcop;
+ JMPENV *restartjmpenv;
+ OP *restartop;
if (cxix < cxstack_ix)
dounwind(cxix);
}
POPEVAL(cx);
namesv = cx->blk_eval.old_namesv;
+ oldcop = cx->blk_oldcop;
+ restartjmpenv = cx->blk_eval.cur_top_env;
+ restartop = cx->blk_eval.retop;
if (gimme == G_SCALAR)
*++newsp = &PL_sv_undef;
* XXX it might be better to find a way to avoid messing with
* PL_curcop in save_re_context() instead, but this is a more
* minimal fix --GSAR */
- PL_curcop = cx->blk_oldcop;
+ PL_curcop = oldcop;
if (optype == OP_REQUIRE) {
const char* const msg = SvPVx_nolen_const(exceptsv);
else {
sv_setsv(ERRSV, exceptsv);
}
- assert(CxTYPE(cx) == CXt_EVAL);
- PL_restartjmpenv = cx->blk_eval.cur_top_env;
- PL_restartop = cx->blk_eval.retop;
+ PL_restartjmpenv = restartjmpenv;
+ PL_restartop = restartop;
JMPENV_JUMP(3);
/* NOTREACHED */
}
}
PUSHs(cx->blk_oldcop->cop_hints_hash ?
- sv_2mortal(newRV_noinc(
- MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
- cx->blk_oldcop->cop_hints_hash))))
+ sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
: &PL_sv_undef);
RETURN;
}
}
else { /* symbol table variable */
GV * const gv = MUTABLE_GV(POPs);
- SV** svp = &GvSV(gv); SAVEGENERICSV(*svp);
+ SV** svp = &GvSV(gv);
+ save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
*svp = newSV(0);
-#ifdef USE_ITHREADS
itervar = (void *)gv;
-#else
- itervar = (void *)svp;
-#endif
}
if (PL_op->op_private & OPpITER_DEF)
register PERL_CONTEXT *cx;
bool popsub2 = FALSE;
bool clear_errsv = FALSE;
+ bool lval = FALSE;
I32 gimme;
SV **newsp;
PMOP *newpm;
switch (CxTYPE(cx)) {
case CXt_SUB:
popsub2 = TRUE;
+ lval = !!CvLVALUE(cx->blk_sub.cv);
retop = cx->blk_sub.retop;
cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
break;
retop = cx->blk_eval.retop;
if (CxTRYBLOCK(cx))
break;
- lex_end();
if (optype == OP_REQUIRE &&
(MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
{
}
}
else
- *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
+ *++newsp =
+ (lval || SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
}
else
*++newsp = sv_mortalcopy(*SP);
}
else if (gimme == G_ARRAY) {
while (++MARK <= SP) {
- *++newsp = (popsub2 && SvTEMP(*MARK))
+ *++newsp = popsub2 && (lval || SvTEMP(*MARK))
? *MARK : sv_mortalcopy(*MARK);
TAINT_NOT; /* Each item is independent */
}
SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
if (CvISXSUB(cv)) {
OP* const retop = cx->blk_sub.retop;
- SV **newsp;
- I32 gimme;
+ SV **newsp __attribute__unused__;
+ I32 gimme __attribute__unused__;
if (reified) {
I32 index;
for (index=0; index<items; index++)
enterops, enterops + GOTO_DEPTH);
if (retop)
break;
+ if (gotoprobe->op_sibling &&
+ gotoprobe->op_sibling->op_type == OP_UNSTACK &&
+ gotoprobe->op_sibling->op_sibling) {
+ retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
+ label, enterops, enterops + GOTO_DEPTH);
+ if (retop)
+ break;
+ }
}
PL_lastgotoprobe = gotoprobe;
}
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)
/* 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;
STRLEN len;
bool need_catch;
- PERL_ARGS_ASSERT_SV_COMPILE_2OP;
+ PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
ENTER_with_name("eval");
- lex_start(sv, NULL, FALSE);
+ lex_start(sv, NULL, LEX_START_SAME_FILTER);
SAVETMPS;
/* switch to eval mode */
/* 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. */
(*startop)->op_type = OP_NULL;
(*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
- lex_end();
/* XXX DAPM do this properly one year */
*padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
LEAVE_with_name("eval");
else
CLEAR_ERRSV();
- CALL_BLOCK_HOOKS(eval, saveop);
+ CALL_BLOCK_HOOKS(bhk_eval, saveop);
/* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
* so honour CATCH_GET and trap it here if necessary */
namesv = cx->blk_eval.old_namesv;
}
}
- lex_end();
if (yystatus != 3)
LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
}
}
- if (PL_unitcheckav)
+ if (PL_unitcheckav) {
+ OP *es = PL_eval_start;
call_list(PL_scopestack_ix, PL_unitcheckav);
+ PL_eval_start = es;
+ }
/* compiled okay, so do it */
}
STATIC PerlIO *
-S_check_type_and_open(pTHX_ const char *name)
+S_check_type_and_open(pTHX_ SV *name)
{
Stat_t st;
- const int st_rc = PerlLIO_stat(name, &st);
+ const char *p = SvPV_nolen_const(name);
+ const int st_rc = PerlLIO_stat(p, &st);
PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
return NULL;
}
- return PerlIO_open(name, PERL_SCRIPT_MODE);
+#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
+ return PerlIO_openn(aTHX_ NULL, PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
+#else
+ return PerlIO_open(p, PERL_SCRIPT_MODE);
+#endif
}
#ifndef PERL_DISABLE_PMC
STATIC PerlIO *
-S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
+S_doopen_pm(pTHX_ SV *name)
{
- PerlIO *fp;
+ STRLEN namelen;
+ const char *p = SvPV_const(name, namelen);
PERL_ARGS_ASSERT_DOOPEN_PM;
- if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
- SV *const pmcsv = newSV(namelen + 2);
- char *const pmc = SvPVX(pmcsv);
+ if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
+ SV *const pmcsv = sv_newmortal();
Stat_t pmcstat;
- memcpy(pmc, name, namelen);
- pmc[namelen] = 'c';
- pmc[namelen + 1] = '\0';
+ SvSetSV_nosteal(pmcsv,name);
+ sv_catpvn(pmcsv, "c", 1);
- if (PerlLIO_stat(pmc, &pmcstat) < 0) {
- fp = check_type_and_open(name);
- }
- else {
- fp = check_type_and_open(pmc);
- }
- SvREFCNT_dec(pmcsv);
+ if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
+ return check_type_and_open(pmcsv);
}
- else {
- fp = check_type_and_open(name);
- }
- return fp;
+ return check_type_and_open(name);
}
#else
-# define doopen_pm(name, namelen) check_type_and_open(name)
+# define doopen_pm(name) check_type_and_open(name)
#endif /* !PERL_DISABLE_PMC */
PP(pp_require)
sv = POPs;
if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
- sv = new_version(sv);
+ sv = sv_2mortal(new_version(sv));
if (!sv_derived_from(PL_patchlevel, "version"))
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 )
DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
- SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
+ SVfARG(sv_2mortal(vnormal(sv))),
+ SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
+ );
}
else {
if ( vcmp(sv,PL_patchlevel) > 0 ) {
|| strstr(SvPVX(pv),".0") /* FP with leading 0 */
) {
DIE(aTHX_ "Perl %"SVf" required--this is only "
- "%"SVf", stopped", SVfARG(vnormal(req)),
- SVfARG(vnormal(PL_patchlevel)));
+ "%"SVf", stopped",
+ SVfARG(sv_2mortal(vnormal(req))),
+ SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
+ );
}
else { /* probably 'use 5.10' or 'use 5.8' */
SV *hintsv;
DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
"--this is only %"SVf", stopped",
- SVfARG(vnormal(req)),
- SVfARG(vnormal(sv_2mortal(hintsv))),
- SVfARG(vnormal(PL_patchlevel)));
+ SVfARG(sv_2mortal(vnormal(req))),
+ SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
+ SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
+ );
}
}
}
- /* We do this only with "use", not "require" or "no". */
- if (PL_compcv && !(cUNOP->op_first->op_private & OPpCONST_NOVER)) {
- /* If we request a version >= 5.9.5, load feature.pm with the
- * feature bundle that corresponds to the required version. */
- if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
- SV *const importsv = vnormal(sv);
- *SvPVX_mutable(importsv) = ':';
- ENTER_with_name("load_feature");
- Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
- LEAVE_with_name("load_feature");
- }
- /* If a version >= 5.11.0 is requested, strictures are on by default! */
- if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
- PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
- }
- }
-
RETPUSHYES;
}
name = SvPV_const(sv, len);
/* prepare to compile file */
if (path_is_absolute(name)) {
+ /* At this point, name is SvPVX(sv) */
tryname = name;
- tryrsfp = doopen_pm(name, len);
+ tryrsfp = doopen_pm(sv);
}
if (!tryrsfp) {
AV * const ar = GvAVn(PL_incgv);
memcpy(tmp, name, len + 1);
SvCUR_set(namesv, dirlen + len + 1);
-
- /* Don't even actually have to turn SvPOK_on() as we
- access it directly with SvPVX() below. */
+ SvPOK_on(namesv);
}
# endif
#endif
TAINT_PROPER("require");
tryname = SvPVX_const(namesv);
- tryrsfp = doopen_pm(tryname, SvCUR(namesv));
+ tryrsfp = doopen_pm(namesv);
if (tryrsfp) {
if (tryname[0] == '.' && tryname[1] == '/') {
++tryname;
}
}
}
- if (tryrsfp) {
- SAVECOPFILE_FREE(&PL_compiling);
- CopFILE_set(&PL_compiling, tryname);
- }
- SvREFCNT_dec(namesv);
+ sv_2mortal(namesv);
if (!tryrsfp) {
if (PL_op->op_type == OP_REQUIRE) {
if(errno == EMFILE) {
/* Check whether a hook in @INC has already filled %INC */
if (!hook_sv) {
(void)hv_store(GvHVn(PL_incgv),
- unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
+ unixname, unixlen, newSVpv(tryname,0),0);
} else {
SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
if (!svp)
ENTER_with_name("eval");
SAVETMPS;
- lex_start(NULL, tryrsfp, TRUE);
+ SAVECOPFILE_FREE(&PL_compiling);
+ CopFILE_set(&PL_compiling, tryname);
+ lex_start(NULL, tryrsfp, 0);
SAVEHINTS();
PL_hints = 0;
{
dVAR;
dSP;
- mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
+ mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
RETURN;
}
const I32 gimme = GIMME_V;
const U32 was = PL_breakable_sub_gen;
char tbuf[TYPE_DIGITS(long) + 12];
+ bool saved_delete = FALSE;
char *tmpbuf = tbuf;
STRLEN len;
CV* runcv;
TAINT_PROPER("eval");
ENTER_with_name("eval");
- lex_start(sv, NULL, FALSE);
+ lex_start(sv, NULL, LEX_START_SAME_FILTER);
SAVETMPS;
/* switch to eval mode */
}
SAVECOMPILEWARNINGS();
PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
- if (PL_compiling.cop_hints_hash) {
- Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
- }
+ cophh_free(CopHINTHASH_get(&PL_compiling));
if (Perl_fetch_cop_label(aTHX_ PL_curcop, 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
- = PL_curcop->cop_hints_hash->refcounted_he_next;
+ = cophh_copy(PL_curcop->cop_hints_hash->refcounted_he_next);
/* Check the assumption that this removed the label. */
assert(Perl_fetch_cop_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
}
else
- PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
- if (PL_compiling.cop_hints_hash) {
- HINTS_REFCNT_LOCK;
- PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
- HINTS_REFCNT_UNLOCK;
- }
+ PL_compiling.cop_hints_hash = cophh_copy(PL_curcop->cop_hints_hash);
/* special case: an eval '' executed within the DB package gets lexically
* placed in the first non-DB CV rather than the current CV - this
* allows the debugger to execute code, find lexicals etc, in the
if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
+ else {
+ char *const safestr = savepvn(tmpbuf, len);
+ SAVEDELETE(PL_defstash, safestr, len);
+ saved_delete = TRUE;
+ }
+
PUTBACK;
if (doeval(gimme, NULL, runcv, seq)) {
? (PERLDB_LINE || PERLDB_SAVESRC)
: PERLDB_SAVESRC_NOSUBS) {
/* Retain the filegv we created. */
- } else {
+ } else if (!saved_delete) {
char *const safestr = savepvn(tmpbuf, len);
SAVEDELETE(PL_defstash, safestr, len);
}
return DOCATCH(PL_eval_start);
} else {
- /* We have already left the scope set up earler thanks to the LEAVE
+ /* We have already left the scope set up earlier thanks to the LEAVE
in doeval(). */
if (was != PL_breakable_sub_gen /* Some subs defined here. */
? (PERLDB_LINE || PERLDB_SAVESRC)
: PERLDB_SAVESRC_INVALID) {
/* Retain the filegv we created. */
- } else {
+ } else if (!saved_delete) {
(void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
}
return PL_op->op_next;
I32 optype;
SV *namesv;
+ PERL_ASYNC_CHECK();
POPBLOCK(cx,newpm);
POPEVAL(cx);
namesv = cx->blk_eval.old_namesv;
assert(CvDEPTH(PL_compcv) == 1);
#endif
CvDEPTH(PL_compcv) = 0;
- lex_end();
if (optype == OP_REQUIRE &&
!(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
register PERL_CONTEXT *cx;
I32 optype;
+ PERL_ASYNC_CHECK();
POPBLOCK(cx,newpm);
POPEVAL(cx);
PERL_UNUSED_VAR(optype);
ENTER_with_name("given");
SAVETMPS;
- sv_setsv(PAD_SV(PL_op->op_targ), POPs);
+ sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs);
PUSHBLOCK(cx, CXt_GIVEN, SP);
PUSHGIVEN(cx);
PL_op = (OP *) matcher;
XPUSHs(sv);
PUTBACK;
- (void) pp_match();
+ (void) Perl_pp_match(aTHX);
SPAGAIN;
return (SvTRUEx(POPs));
}
PUSHs(d); PUSHs(e);
PUTBACK;
if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
- (void) pp_i_eq();
+ (void) Perl_pp_i_eq(aTHX);
else
- (void) pp_eq();
+ (void) Perl_pp_eq(aTHX);
SPAGAIN;
if (SvTRUEx(POPs))
RETPUSHYES;
DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
PUSHs(d); PUSHs(e);
PUTBACK;
- return pp_seq();
+ return Perl_pp_seq(aTHX);
}
PP(pp_enterwhen)
{
dVAR; dSP;
register PERL_CONTEXT *cx;
- I32 gimme;
+ I32 gimme __attribute__unused__;
SV **newsp;
PMOP *newpm;
RETURNOP(cx->blk_givwhen.leave_op);
}
-STATIC OP *
+static MAGIC *
S_doparseform(pTHX_ SV *sv)
{
STRLEN len;
- register char *s = SvPV_force(sv, len);
- register char * const send = s + len;
- register char *base = NULL;
- register I32 skipspaces = 0;
- bool noblank = FALSE;
- bool repeat = FALSE;
- bool postspace = FALSE;
+ 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 */
+ 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 *linepc = NULL;
+ U32 *linepc = NULL; /* position of last FF_LINEMARK */
register I32 arg;
- bool ischop;
- bool unchopnum = FALSE;
+ 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) */
+ MAGIC *mg = NULL;
+ SV *sv_copy;
PERL_ARGS_ASSERT_DOPARSEFORM;
if (len == 0)
Perl_croak(aTHX_ "Null picture in formline");
+ if (SvTYPE(sv) >= SVt_PVMG) {
+ /* This might, of course, still return NULL. */
+ mg = mg_find(sv, PERL_MAGIC_fm);
+ } else {
+ sv_upgrade(sv, SVt_PVMG);
+ }
+
+ if (mg) {
+ /* still the same as previously-compiled string? */
+ SV *old = mg->mg_obj;
+ if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
+ && len == SvCUR(old)
+ && strnEQ(SvPVX(old), SvPVX(sv), len)
+ ) {
+ DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
+ return mg;
+ }
+
+ DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
+ Safefree(mg->mg_ptr);
+ mg->mg_ptr = NULL;
+ SvREFCNT_dec(old);
+ mg->mg_obj = NULL;
+ }
+ else {
+ DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
+ mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
+ }
+
+ sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
+ s = SvPV(sv_copy, len); /* work on the copy, not the original */
+ send = s + len;
+
+
/* estimate the buffer size needed */
for (base = s; s <= send; s++) {
if (*s == '\n' || *s == '@' || *s == '^')
case '~':
if (*s == '~') {
repeat = TRUE;
- *s = ' ';
+ skipspaces++;
+ s++;
}
noblank = TRUE;
- s[-1] = ' ';
/* FALL THROUGH */
case ' ': case '\t':
skipspaces++;
base = s - 1;
*fpc++ = FF_FETCH;
- if (*s == '*') {
+ if (*s == '*') { /* @* or ^* */
s++;
*fpc++ = 2; /* skip the @* or ^* */
if (ischop) {
} else
*fpc++ = FF_LINEGLOB;
}
- else if (*s == '#' || (*s == '.' && s[1] == '#')) {
+ else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
arg = ischop ? 512 : 0;
base = s - 1;
while (*s == '#')
*fpc++ = (U16)arg;
unchopnum |= ! ischop;
}
- else {
+ else { /* text field */
I32 prespace = 0;
bool ismore = FALSE;
*fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
if (prespace)
- *fpc++ = (U16)prespace;
+ *fpc++ = (U16)prespace; /* add SPACE or HALFSPACE */
*fpc++ = FF_ITEM;
if (ismore)
*fpc++ = FF_MORE;
assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
arg = fpc - fops;
- { /* need to jump to the next word */
- int z;
- z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
- SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
- s = SvPVX(sv) + SvCUR(sv) + z;
- }
- Copy(fops, s, arg, U32);
- Safefree(fops);
- sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
- SvCOMPILED_on(sv);
+
+ mg->mg_ptr = (char *) fops;
+ mg->mg_len = arg * sizeof(U32);
+ mg->mg_obj = sv_copy;
+ mg->mg_flags |= MGf_REFCOUNTED;
if (unchopnum && repeat)
- DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
- return 0;
+ Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
+
+ return mg;
}
if (take) {
sv_catpvn(buf_sv, cache_p, take);
sv_chop(cache, cache_p + take);
- /* Definately not EOF */
+ /* Definitely not EOF */
return 1;
}
https://perl5.git.perl.org / perl5.git / blobdiff