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; concatentate them */
+ /* multiple args; concatenate them */
dMARK; dORIGMARK;
tmpstr = PAD_SV(ARGTARG);
sv_setpvs(tmpstr, "");
while (++MARK <= SP) {
- if (PL_amagic_generation) {
- SV *sv;
- if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
- (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
- {
- sv_setsv(tmpstr, sv);
- continue;
- }
+ 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;
}
- sv_catsv(tmpstr, *MARK);
+ sv_catsv_nomg(tmpstr, msv);
}
SvSETMAGIC(tmpstr);
SP = ORIGMARK;
}
- else
+ 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) {
- re = reg_temp_copy(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);
}
else {
- STRLEN len;
- const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
+ STRLEN len = 0;
+ const char *t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : "";
+
re = PM_GETRE(pm);
assert (re != (REGEXP*) &PL_sv_undef);
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));
}
const char *const p = SvPV(tmpstr, len);
tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
}
+ else if (SvAMAGIC(tmpstr)) {
+ /* make a copy to avoid extra stringifies */
+ 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)
+ if (eng)
PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
- else
+ else
PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
register REGEXP * const rx = cx->sb_rx;
SV *nsv = NULL;
REGEXP *old = PM_GETRE(pm);
+
+ PERL_ASYNC_CHECK();
+
if(old != rx) {
if(old)
ReREFCNT_dec(old);
if (cx->sb_iters > cx->sb_maxiters)
DIE(aTHX_ "Substitution loop");
+ SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
+
if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
cx->sb_rxtainted |= 2;
- sv_catsv(dstr, POPs);
+ sv_catsv_nomg(dstr, POPs);
+ /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
+ s -= RX_GOFS(rx);
/* Are we done */
- if (CxONCE(cx) || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
- s == m, cx->sb_targ, NULL,
- ((cx->sb_rflags & REXEC_COPY_STR)
- ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
- : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
+ 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))))
{
SV * const targ = cx->sb_targ;
SvPV_set(dstr, NULL);
TAINT_IF(cx->sb_rxtainted & 1);
- mPUSHi(saviters - 1);
+ if (pm->op_pmflags & PMf_NONDESTRUCT)
+ PUSHs(targ);
+ else
+ mPUSHi(saviters - 1);
(void)SvPOK_only_UTF8(targ);
TAINT_IF(cx->sb_rxtainted);
(void)ReREFCNT_inc(rx);
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
rxres_save(&cx->sb_rxres, rx);
+ PL_curpm = pm;
RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
}
NV value;
bool gotsome = FALSE;
STRLEN len;
- const STRLEN fudge = SvPOK(tmpForm)
+ const STRLEN fudge = SvPOKp(tmpForm)
? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
bool item_is_utf8 = FALSE;
bool targ_is_utf8 = FALSE;
return parseres;
}
SvPV_force(PL_formtarget, len);
+ if (SvTAINTED(tmpForm))
+ SvTAINTED_on(PL_formtarget);
if (DO_UTF8(PL_formtarget))
targ_is_utf8 = TRUE;
t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
sv = *++MARK;
else {
sv = &PL_sv_no;
- if (ckWARN(WARN_SYNTAX))
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
+ Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
}
+ if (SvTAINTED(sv))
+ SvTAINTED_on(PL_formtarget);
break;
case FF_CHECKNL:
*t = '\0';
SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
lines += FmLINES(PL_formtarget);
- if (lines == 200) {
- arg = t - linemark;
- if (strnEQ(linemark, linemark - arg, arg))
- DIE(aTHX_ "Runaway format");
- }
if (targ_is_utf8)
SvUTF8_on(PL_formtarget);
FmLINES(PL_formtarget) = lines;
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 */
- ENTER; /* enter outer scope */
+ Perl_pp_pushmark(aTHX); /* push dst */
+ Perl_pp_pushmark(aTHX); /* push src */
+ ENTER_with_name("grep"); /* enter outer scope */
SAVETMPS;
if (PL_op->op_private & OPpGREP_LEX)
SAVESPTR(PAD_SVl(PL_op->op_targ));
else
SAVE_DEFSV;
- ENTER; /* enter inner scope */
+ ENTER_with_name("grep_item"); /* enter inner scope */
SAVEVPTR(PL_curpm);
src = PL_stack_base[*PL_markstack_ptr];
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;
}
}
- LEAVE; /* exit inner scope */
+ else {
+ FREETMPS;
+ }
+ LEAVE_with_name("grep_item"); /* exit inner scope */
/* All done yet? */
if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
(void)POPMARK; /* pop top */
- LEAVE; /* exit outer scope */
+ LEAVE_with_name("grep"); /* exit outer scope */
(void)POPMARK; /* pop src */
items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
(void)POPMARK; /* pop dst */
else {
SV *src;
- ENTER; /* enter inner scope */
+ ENTER_with_name("grep_item"); /* enter inner scope */
SAVEVPTR(PL_curpm);
/* set $_ to the new source item */
case CXt_FORMAT:
case CXt_EVAL:
case CXt_NULL:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
- context_name[CxTYPE(cx)], OP_NAME(PL_op));
+ Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
+ context_name[CxTYPE(cx)], OP_NAME(PL_op));
if (CxTYPE(cx) == CXt_NULL)
return -1;
break;
case CXt_LOOP_LAZYSV:
case CXt_LOOP_FOR:
case CXt_LOOP_PLAIN:
- if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
- DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
- (long)i, CxLABEL(cx)));
+ {
+ const char *cx_label = CxLABEL(cx);
+ if (!cx_label || strNE(label, cx_label) ) {
+ DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
+ (long)i, cx_label));
continue;
}
- DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
+ DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
return i;
+ }
}
}
return i;
case CXt_EVAL:
case CXt_SUB:
case CXt_FORMAT:
- DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
return i;
}
}
default:
continue;
case CXt_EVAL:
- DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
return i;
}
}
case CXt_FORMAT:
case CXt_EVAL:
case CXt_NULL:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
- context_name[CxTYPE(cx)], OP_NAME(PL_op));
+ Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
+ context_name[CxTYPE(cx)], OP_NAME(PL_op));
if ((CxTYPE(cx)) == CXt_NULL)
return -1;
break;
case CXt_LOOP_LAZYSV:
case CXt_LOOP_FOR:
case CXt_LOOP_PLAIN:
- DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
return i;
}
}
default:
continue;
case CXt_GIVEN:
- DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
return i;
case CXt_LOOP_PLAIN:
assert(!CxFOREACHDEF(cx));
case CXt_LOOP_LAZYSV:
case CXt_LOOP_FOR:
if (CxFOREACHDEF(cx)) {
- DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
return i;
}
}
default:
continue;
case CXt_WHEN:
- DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
return i;
}
}
while (cxstack_ix > cxix) {
SV *sv;
register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
- DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
- (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
+ DEBUG_CX("UNWIND"); \
/* Note: we don't need to restore the base context info till the end. */
switch (CxTYPE(cx)) {
case CXt_SUBST:
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
++PL_parser->error_count;
}
-OP *
-Perl_die_where(pTHX_ const char *message, STRLEN msglen)
+void
+Perl_die_unwind(pTHX_ SV *msv)
{
dVAR;
+ SV *exceptsv = sv_mortalcopy(msv);
+ U8 in_eval = PL_in_eval;
+ PERL_ARGS_ASSERT_DIE_UNWIND;
- if (PL_in_eval) {
+ if (in_eval) {
I32 cxix;
I32 gimme;
- if (message) {
- if (PL_in_eval & EVAL_KEEPERR) {
- static const char prefix[] = "\t(in cleanup) ";
- SV * const err = ERRSV;
- const char *e = NULL;
- if (!SvPOK(err))
- sv_setpvs(err,"");
- else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
- STRLEN len;
- e = SvPV_const(err, len);
- e += len - msglen;
- if (*e != *message || strNE(e,message))
- e = NULL;
- }
- if (!e) {
- SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
- sv_catpvn(err, prefix, sizeof(prefix)-1);
- sv_catpvn(err, message, msglen);
- if (ckWARN(WARN_MISC)) {
- const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
- Perl_warner(aTHX_ packWARN(WARN_MISC), "%s",
- SvPVX_const(err)+start);
- }
- }
- }
- else {
- sv_setpvn(ERRSV, message, msglen);
- }
+ /*
+ * 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
if (cxix >= 0) {
I32 optype;
+ SV *namesv;
register PERL_CONTEXT *cx;
SV **newsp;
+ COP *oldcop;
+ JMPENV *restartjmpenv;
+ OP *restartop;
if (cxix < cxstack_ix)
dounwind(cxix);
POPBLOCK(cx,PL_curpm);
if (CxTYPE(cx) != CXt_EVAL) {
- if (!message)
- message = SvPVx_const(ERRSV, msglen);
+ STRLEN msglen;
+ const char* message = SvPVx_const(exceptsv, msglen);
PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
PerlIO_write(Perl_error_log, message, msglen);
my_exit(1);
}
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(ERRSV);
- SV * const nsv = cx->blk_eval.old_namesv;
- (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
+ const char* const msg = SvPVx_nolen_const(exceptsv);
+ (void)hv_store(GvHVn(PL_incgv),
+ SvPVX_const(namesv), SvCUR(namesv),
&PL_sv_undef, 0);
- DIE(aTHX_ "%sCompilation failed in require",
- *msg ? msg : "Unknown error\n");
+ /* note that unlike pp_entereval, pp_require isn't
+ * supposed to trap errors. So now that we've popped the
+ * EVAL that pp_require pushed, and processed the error
+ * message, rethrow the error */
+ Perl_croak(aTHX_ "%sCompilation failed in require",
+ *msg ? msg : "Unknown error\n");
+ }
+ if (in_eval & EVAL_KEEPERR) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
+ SvPV_nolen_const(exceptsv));
}
- assert(CxTYPE(cx) == CXt_EVAL);
- return cx->blk_eval.retop;
+ else {
+ sv_setsv(ERRSV, exceptsv);
+ }
+ PL_restartjmpenv = restartjmpenv;
+ PL_restartop = restartop;
+ JMPENV_JUMP(3);
+ /* NOTREACHED */
}
}
- if (!message)
- message = SvPVx_const(ERRSV, msglen);
- write_to_stderr(message, msglen);
+ write_to_stderr(exceptsv);
my_failure_exit();
/* NOTREACHED */
- return 0;
}
PP(pp_xor)
RETSETNO;
}
-PP(pp_caller)
+/*
+=for apidoc caller_cx
+
+The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
+returned C<PERL_CONTEXT> structure can be interrogated to find all the
+information returned to Perl by C<caller>. Note that XSUBs don't get a
+stack frame, so C<caller_cx(0, NULL)> will return information for the
+immediately-surrounding Perl code.
+
+This function skips over the automatic calls to C<&DB::sub> made on the
+behalf of the debugger. If the stack frame requested was a sub called by
+C<DB::sub>, the return value will be the frame for the call to
+C<DB::sub>, since that has the correct line number/etc. for the call
+site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
+frame for the sub call itself.
+
+=cut
+*/
+
+const PERL_CONTEXT *
+Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
{
- dVAR;
- dSP;
register I32 cxix = dopoptosub(cxstack_ix);
register const PERL_CONTEXT *cx;
register const PERL_CONTEXT *ccstack = cxstack;
const PERL_SI *top_si = PL_curstackinfo;
- I32 gimme;
- const char *stashname;
- I32 count = 0;
-
- if (MAXARG)
- count = POPi;
for (;;) {
/* we may be in a higher stacklevel, so dig down deeper */
ccstack = top_si->si_cxstack;
cxix = dopoptosub_at(ccstack, top_si->si_cxix);
}
- if (cxix < 0) {
- if (GIMME != G_ARRAY) {
- EXTEND(SP, 1);
- RETPUSHUNDEF;
- }
- RETURN;
- }
+ if (cxix < 0)
+ return NULL;
/* caller() should not report the automatic calls to &DB::sub */
if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
}
cx = &ccstack[cxix];
+ if (dbcxp) *dbcxp = cx;
+
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
/* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
cx = &ccstack[dbcxix];
}
+ return cx;
+}
+
+PP(pp_caller)
+{
+ dVAR;
+ dSP;
+ register const PERL_CONTEXT *cx;
+ const PERL_CONTEXT *dbcx;
+ I32 gimme;
+ const char *stashname;
+ I32 count = 0;
+
+ if (MAXARG)
+ count = POPi;
+
+ cx = caller_cx(count, &dbcx);
+ if (!cx) {
+ if (GIMME != G_ARRAY) {
+ EXTEND(SP, 1);
+ RETPUSHUNDEF;
+ }
+ RETURN;
+ }
+
stashname = CopSTASHPV(cx->blk_oldcop);
if (GIMME != G_ARRAY) {
EXTEND(SP, 1);
if (!MAXARG)
RETURN;
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
- GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
+ GV * const cvgv = CvGV(dbcx->blk_sub.cv);
/* So is ccstack[dbcxix]. */
if (isGV(cvgv)) {
SV * const sv = newSV(0);
AV * const ary = cx->blk_sub.argarray;
const int off = AvARRAY(ary) - AvALLOC(ary);
- if (!PL_dbargs) {
- PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI,
- SVt_PVAV)));
- AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
- }
+ if (!PL_dbargs)
+ Perl_init_dbargs(aTHX);
if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
av_extend(PL_dbargs, AvFILLp(ary) + off);
}
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;
}
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
FREETMPS;
+ PERL_ASYNC_CHECK();
+
if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
|| SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
{
dVAR; dSP; dMARK;
register PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
- SV **svp;
+ void *itervar; /* location of the iteration variable */
U8 cxtype = CXt_LOOP_FOR;
-#ifdef USE_ITHREADS
- PAD *iterdata;
-#endif
- ENTER;
+ ENTER_with_name("loop1");
SAVETMPS;
- if (PL_op->op_targ) {
- if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
+ if (PL_op->op_targ) { /* "my" variable */
+ if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
SVs_PADSTALE, SVs_PADSTALE);
}
SAVEPADSVANDMORTALIZE(PL_op->op_targ);
-#ifndef USE_ITHREADS
- svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
+#ifdef USE_ITHREADS
+ itervar = PL_comppad;
#else
- iterdata = NULL;
+ itervar = &PAD_SVl(PL_op->op_targ);
#endif
}
- else {
+ else { /* symbol table variable */
GV * const gv = MUTABLE_GV(POPs);
- svp = &GvSV(gv); /* symbol table variable */
- SAVEGENERICSV(*svp);
+ SV** svp = &GvSV(gv);
+ save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
*svp = newSV(0);
-#ifdef USE_ITHREADS
- iterdata = (PAD*)gv;
-#endif
+ itervar = (void *)gv;
}
if (PL_op->op_private & OPpITER_DEF)
cxtype |= CXp_FOR_DEF;
- ENTER;
+ ENTER_with_name("loop2");
PUSHBLOCK(cx, cxtype, SP);
-#ifdef USE_ITHREADS
- PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
-#else
- PUSHLOOP_FOR(cx, svp, MARK, 0);
-#endif
+ PUSHLOOP_FOR(cx, itervar, MARK);
if (PL_op->op_flags & OPf_STACKED) {
SV *maybe_ary = POPs;
if (SvTYPE(maybe_ary) != SVt_PVAV) {
register PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
- ENTER;
+ ENTER_with_name("loop1");
SAVETMPS;
- ENTER;
+ ENTER_with_name("loop2");
PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
PUSHLOOP_PLAIN(cx, SP);
POPLOOP(cx); /* Stack values are safe: release loop vars ... */
PL_curpm = newpm; /* ... and pop $1 et al */
- LEAVE;
- LEAVE;
+ LEAVE_with_name("loop2");
+ LEAVE_with_name("loop1");
return NORMAL;
}
SV **newsp;
PMOP *newpm;
I32 optype = 0;
+ SV *namesv;
SV *sv;
- OP *retop;
+ OP *retop = NULL;
const I32 cxix = dopoptosub(cxstack_ix);
if (!(PL_in_eval & EVAL_KEEPERR))
clear_errsv = TRUE;
POPEVAL(cx);
+ namesv = cx->blk_eval.old_namesv;
retop = cx->blk_eval.retop;
if (CxTRYBLOCK(cx))
break;
- lex_end();
if (optype == OP_REQUIRE &&
(MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
{
/* Unassume the success we assumed earlier. */
- SV * const nsv = cx->blk_eval.old_namesv;
- (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
- DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
+ (void)hv_delete(GvHVn(PL_incgv),
+ SvPVX_const(namesv), SvCUR(namesv),
+ G_DISCARD);
+ DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
}
break;
case CXt_FORMAT:
I32 pop2 = 0;
I32 gimme;
I32 optype;
- OP *nextop;
+ OP *nextop = NULL;
SV **newsp;
PMOP *newpm;
SV **mark;
if (PL_scopestack_ix < inner)
leave_scope(PL_scopestack[PL_scopestack_ix]);
PL_curcop = cx->blk_oldcop;
- return CX_LOOP_NEXTOP_GET(cx);
+ return (cx)->blk_loop.my_op->op_nextop;
}
PP(pp_redo)
OP *kid;
/* First try all the kids at this level, since that's likeliest. */
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
- if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
- CopLABEL(kCOP) && strEQ(CopLABEL(kCOP), label))
- return kid;
+ if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
+ const char *kid_label = CopLABEL(kCOP);
+ if (kid_label && strEQ(kid_label, label))
+ return kid;
+ }
}
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
if (kid == PL_lastgotoprobe)
else
label = cPVOP->op_pv;
+ PERL_ASYNC_CHECK();
+
if (label && *label) {
OP *gotoprobe = NULL;
bool leaving_eval = FALSE;
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;
}
DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
}
+ if (*enterops && enterops[1]) {
+ I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
+ if (enterops[i])
+ deprecate("\"goto\" to jump into a construct");
+ }
+
/* pop unwanted frames */
if (ix < cxstack_ix) {
* for each op. For now, we punt on the hard ones. */
if (PL_op->op_type == OP_ENTERITER)
DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
- CALL_FPTR(PL_op->op_ppaddr)(aTHX);
+ PL_op->op_ppaddr(aTHX);
}
PL_op = oldop;
}
}
}
+/*
+=for apidoc docatch
+
+Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
+
+0 is used as continue inside eval,
+
+3 is used for a die caught by an inner eval - continue inner loop
+
+See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
+establish a local jmpenv to handle exception traps.
+
+=cut
+*/
STATIC OP *
S_docatch(pTHX_ OP *o)
{
break;
case 3:
/* die caught by an inner eval - continue inner loop */
-
- /* NB XXX we rely on the old popped CxEVAL still being at the top
- * of the stack; the way die_where() currently works, this
- * assumption is valid. In theory The cur_top_env value should be
- * returned in another global, the way retop (aka PL_restartop)
- * is. */
- assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
-
- if (PL_restartop
- && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
- {
+ if (PL_restartop && PL_restartjmpenv == PL_top_env) {
+ PL_restartjmpenv = NULL;
PL_op = PL_restartop;
PL_restartop = 0;
goto redo_body;
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. */
{
- /* FIXME - how much of this code is common with pp_entereval? */
+ 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;
int runtime;
CV* runcv = NULL; /* initialise to avoid compiler warnings */
STRLEN len;
+ bool need_catch;
- PERL_ARGS_ASSERT_SV_COMPILE_2OP;
+ PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
- ENTER;
- lex_start(sv, NULL, FALSE);
+ ENTER_with_name("eval");
+ lex_start(sv, NULL, 0);
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. */
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);
else
(void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
+ CATCH_SET(need_catch);
POPBLOCK(cx,PL_curpm);
POPEVAL(cx);
(*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;
+ LEAVE_with_name("eval");
if (IN_PERL_COMPILETIME)
CopHINTS_set(&PL_compiling, PL_hints);
#ifdef OP_IN_REGISTER
}
+/* Run yyparse() in a setjmp wrapper. Returns:
+ * 0: yyparse() successful
+ * 1: yyparse() failed
+ * 3: yyparse() died
+ */
+STATIC int
+S_try_yyparse(pTHX_ int gramtype)
+{
+ int ret;
+ dJMPENV;
+
+ assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
+ JMPENV_PUSH(ret);
+ switch (ret) {
+ case 0:
+ ret = yyparse(gramtype) ? 1 : 0;
+ break;
+ case 3:
+ break;
+ default:
+ JMPENV_POP;
+ JMPENV_JUMP(ret);
+ /* 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.
{
dVAR; dSP;
OP * const saveop = PL_op;
+ bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
+ int yystatus;
- PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
+ PL_in_eval = (in_require
? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
: EVAL_INEVAL);
PL_in_eval |= EVAL_KEEPERR;
else
CLEAR_ERRSV();
- if (yyparse() || PL_parser->error_count || !PL_eval_root) {
+
+ 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 */
+
+ yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
+
+ if (yystatus || PL_parser->error_count || !PL_eval_root) {
SV **newsp; /* Used by POPBLOCK. */
- PERL_CONTEXT *cx = &cxstack[cxstack_ix];
- I32 optype = 0; /* Might be reset by POPEVAL. */
+ PERL_CONTEXT *cx = NULL;
+ I32 optype; /* Used by POPEVAL. */
+ SV *namesv = NULL;
const char *msg;
+ PERL_UNUSED_VAR(newsp);
+ PERL_UNUSED_VAR(optype);
+
+ /* note that if yystatus == 3, then the EVAL CX block has already
+ * been popped, and various vars restored */
PL_op = saveop;
- if (PL_eval_root) {
- op_free(PL_eval_root);
- PL_eval_root = NULL;
- }
- SP = PL_stack_base + POPMARK; /* pop original mark */
- if (!startop) {
- POPBLOCK(cx,PL_curpm);
- POPEVAL(cx);
+ if (yystatus != 3) {
+ if (PL_eval_root) {
+ op_free(PL_eval_root);
+ 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;
+ }
}
- lex_end();
- LEAVE; /* pp_entereval knows about this LEAVE. */
+ if (yystatus != 3)
+ LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
msg = SvPVx_nolen_const(ERRSV);
- if (optype == OP_REQUIRE) {
- const SV * const nsv = cx->blk_eval.old_namesv;
- (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
- &PL_sv_undef, 0);
+ if (in_require) {
+ if (!cx) {
+ /* If cx is still NULL, it means that we didn't go in the
+ * POPEVAL branch. */
+ cx = &cxstack[cxstack_ix];
+ assert(CxTYPE(cx) == CXt_EVAL);
+ namesv = cx->blk_eval.old_namesv;
+ }
+ (void)hv_store(GvHVn(PL_incgv),
+ SvPVX_const(namesv), SvCUR(namesv),
+ &PL_sv_undef, 0);
Perl_croak(aTHX_ "%sCompilation failed in require",
*msg ? msg : "Unknown error\n");
}
else if (startop) {
- POPBLOCK(cx,PL_curpm);
- POPEVAL(cx);
+ if (yystatus != 3) {
+ POPBLOCK(cx,PL_curpm);
+ POPEVAL(cx);
+ }
Perl_croak(aTHX_ "%sCompilation failed in regexp",
(*msg ? msg : "Unknown error\n"));
}
sv_setpvs(ERRSV, "Compilation error");
}
}
- PERL_UNUSED_VAR(newsp);
PUSHs(&PL_sv_undef);
PUTBACK;
return FALSE;
SAVEFREEOP(PL_eval_root);
/* Set the context for this new optree.
- * If the last op is an OP_REQUIRE, force scalar context.
- * Otherwise, propagate the context from the eval(). */
- if (PL_eval_root->op_type == OP_LEAVEEVAL
- && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
- && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
- == OP_REQUIRE)
- scalar(PL_eval_root);
- else if ((gimme & G_WANT) == G_VOID)
+ * Propagate the context from the eval(). */
+ if ((gimme & G_WANT) == G_VOID)
scalarvoid(PL_eval_root);
else if ((gimme & G_WANT) == G_ARRAY)
list(PL_eval_root);
}
}
- 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_mortalcopy(name);
Stat_t pmcstat;
- memcpy(pmc, name, namelen);
- pmc[namelen] = 'c';
- pmc[namelen + 1] = '\0';
+ 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 = newSV(0);
+ SV *hintsv;
I32 second = 0;
if (av_len(lav)>=1)
second = SvIV(*av_fetch(lav,1,0));
second /= second >= 600 ? 100 : 10;
- hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
- (int)first, (int)second,0);
+ hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
+ (int)first, (int)second);
upg_version(hintsv, TRUE);
DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
"--this is only %"SVf", stopped",
- SVfARG(vnormal(req)),
- SVfARG(vnormal(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. */
- if (PL_compcv &&
- /* If we request a version >= 5.9.5, load feature.pm with the
- * feature bundle that corresponds to the required version. */
- vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
- SV *const importsv = vnormal(sv);
- *SvPVX_mutable(importsv) = ':';
- ENTER;
- Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
- LEAVE;
- }
- /* If a version >= 5.11.0 is requested, strictures are on by default! */
- if (PL_compcv &&
- 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);
tryname = SvPVX_const(namesv);
tryrsfp = NULL;
- ENTER;
+ ENTER_with_name("call_INC");
SAVETMPS;
EXTEND(SP, 2);
count = call_sv(loader, G_ARRAY);
SPAGAIN;
- /* Adjust file name if the hook has set an %INC entry */
- svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
- if (svp)
- tryname = SvPVX_const(*svp);
-
if (count > 0) {
int i = 0;
SV *arg;
PUTBACK;
FREETMPS;
- LEAVE;
+ LEAVE_with_name("call_INC");
+
+ /* Adjust file name if the hook has set an %INC entry.
+ This needs to happen after the FREETMPS above. */
+ svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+ if (svp)
+ tryname = SvPV_nolen_const(*svp);
if (tryrsfp) {
hook_sv = dirsv;
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;
}
}
}
- SAVECOPFILE_FREE(&PL_compiling);
- CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
- SvREFCNT_dec(namesv);
+ sv_2mortal(namesv);
if (!tryrsfp) {
if (PL_op->op_type == OP_REQUIRE) {
- const char *msgstr = name;
if(errno == EMFILE) {
- SV * const msg
- = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
- Strerror(errno)));
- msgstr = SvPV_nolen_const(msg);
+ /* diag_listed_as: Can't locate %s */
+ DIE(aTHX_ "Can't locate %s: %s", name, Strerror(errno));
} else {
if (namesv) { /* did we lookup @INC? */
AV * const ar = GvAVn(PL_incgv);
I32 i;
- SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
- "%s in @INC%s%s (@INC contains:",
- msgstr,
- (instr(msgstr, ".h ")
- ? " (change .h to .ph maybe?)" : ""),
- (instr(msgstr, ".ph ")
- ? " (did you run h2ph?)" : "")
- ));
-
+ SV *const inc = newSVpvs_flags("", SVs_TEMP);
for (i = 0; i <= AvFILL(ar); i++) {
- sv_catpvs(msg, " ");
- sv_catsv(msg, *av_fetch(ar, i, TRUE));
+ sv_catpvs(inc, " ");
+ sv_catsv(inc, *av_fetch(ar, i, TRUE));
}
- sv_catpvs(msg, ")");
- msgstr = SvPV_nolen_const(msg);
- }
+
+ /* 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
+ );
+ }
}
- DIE(aTHX_ "Can't locate %s", msgstr);
+ DIE(aTHX_ "Can't locate %s", name);
}
RETPUSHUNDEF;
/* 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)
unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
}
- ENTER;
+ 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;
- if (PL_compiling.cop_hints_hash) {
- Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
- PL_compiling.cop_hints_hash = NULL;
- }
+ hv_clear(GvHV(PL_hintgv));
SAVECOMPILEWARNINGS();
if (PL_dowarn & G_WARN_ALL_ON)
PL_compiling.cop_warnings = pWARN_STD ;
if (filter_sub || filter_cache) {
- SV * const datasv = filter_add(S_run_user_filter, NULL);
+ /* We can use the SvPV of the filter PVIO itself as our cache, rather
+ than hanging another SV from it. In turn, filter_add() optionally
+ takes the SV to use as the filter (or creates a new SV if passed
+ NULL), so simply pass in whatever value filter_cache has. */
+ SV * const datasv = filter_add(S_run_user_filter, filter_cache);
IoLINES(datasv) = filter_has_file;
IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
- IoFMT_GV(datasv) = MUTABLE_GV(filter_cache);
}
/* switch to eval mode */
{
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;
saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
}
sv = POPs;
+ if (!SvPOK(sv)) {
+ /* make sure we've got a plain PV (no overload etc) before testing
+ * for taint. Making a copy here is probably overkill, but better
+ * safe than sorry */
+ STRLEN len;
+ const char * const p = SvPV_const(sv, len);
+
+ sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
+ }
TAINT_IF(SvTAINTED(sv));
TAINT_PROPER("eval");
- ENTER;
- lex_start(sv, NULL, FALSE);
+ ENTER_with_name("eval");
+ lex_start(sv, NULL, 0);
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);
- }
- 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;
+ 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
+ = 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 = 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;
OP *retop;
const U8 save_flags = PL_op -> op_flags;
I32 optype;
+ SV *namesv;
POPBLOCK(cx,newpm);
POPEVAL(cx);
+ namesv = cx->blk_eval.old_namesv;
retop = cx->blk_eval.retop;
TAINT_NOT;
assert(CvDEPTH(PL_compcv) == 1);
#endif
CvDEPTH(PL_compcv) = 0;
- lex_end();
if (optype == OP_REQUIRE &&
!(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
{
/* Unassume the success we assumed earlier. */
- SV * const nsv = cx->blk_eval.old_namesv;
- (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
- retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
- /* die_where() did LEAVE, or we won't be here */
+ (void)hv_delete(GvHVn(PL_incgv),
+ SvPVX_const(namesv), SvCUR(namesv),
+ G_DISCARD);
+ retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
+ SVfARG(namesv));
+ /* die_unwind() did LEAVE, or we won't be here */
}
else {
- LEAVE;
+ LEAVE_with_name("eval");
if (!(save_flags & OPf_SPECIAL)) {
CLEAR_ERRSV();
}
POPBLOCK(cx,newpm);
POPEVAL(cx);
PL_curpm = newpm;
- LEAVE;
+ LEAVE_with_name("eval_scope");
PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(gimme);
PERL_UNUSED_VAR(optype);
PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
- ENTER;
+ ENTER_with_name("eval_scope");
SAVETMPS;
PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
}
PL_curpm = newpm; /* Don't pop $1 et al till now */
- LEAVE;
+ LEAVE_with_name("eval_scope");
CLEAR_ERRSV();
RETURN;
}
register PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
- ENTER;
+ ENTER_with_name("given");
SAVETMPS;
sv_setsv(PAD_SV(PL_op->op_targ), POPs);
POPBLOCK(cx,newpm);
assert(CxTYPE(cx) == CXt_GIVEN);
- SP = newsp;
- PUTBACK;
-
- PL_curpm = newpm; /* pop $1 et al */
-
- LEAVE;
+ TAINT_NOT;
+ if (gimme == G_VOID)
+ SP = newsp;
+ else if (gimme == G_SCALAR) {
+ register SV **mark;
+ MARK = newsp + 1;
+ if (MARK <= SP) {
+ if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
+ *MARK = TOPs;
+ else
+ *MARK = sv_mortalcopy(TOPs);
+ }
+ else {
+ MEXTEND(mark,0);
+ *MARK = &PL_sv_undef;
+ }
+ SP = MARK;
+ }
+ else {
+ /* in case LEAVE wipes old return values */
+ register SV **mark;
+ for (mark = newsp + 1; mark <= SP; mark++) {
+ if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
+ *mark = sv_mortalcopy(*mark);
+ TAINT_NOT; /* Each item is independent */
+ }
+ }
+ }
+ PL_curpm = newpm; /* Don't pop $1 et al till now */
- return NORMAL;
+ LEAVE_with_name("given");
+ RETURN;
}
/* Helper routines used by pp_smartmatch */
PM_SETRE(matcher, ReREFCNT_inc(re));
SAVEFREEOP((OP *) matcher);
- ENTER; SAVETMPS;
+ ENTER_with_name("matcher"); SAVETMPS;
SAVEOP();
return matcher;
}
PL_op = (OP *) matcher;
XPUSHs(sv);
PUTBACK;
- (void) pp_match();
+ (void) Perl_pp_match(aTHX);
SPAGAIN;
return (SvTRUEx(POPs));
}
PERL_UNUSED_ARG(matcher);
FREETMPS;
- LEAVE;
+ LEAVE_with_name("matcher");
}
/* Do a smart match */
PP(pp_smartmatch)
{
+ DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
return do_smartmatch(NULL, NULL);
}
SV *e = TOPs; /* e is for 'expression' */
SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
+ /* Take care only to invoke mg_get() once for each argument.
+ * Currently we do this by copying the SV if it's magical. */
+ if (d) {
+ if (SvGMAGICAL(d))
+ d = sv_mortalcopy(d);
+ }
+ else
+ d = &PL_sv_undef;
+
+ assert(e);
+ if (SvGMAGICAL(e))
+ e = sv_mortalcopy(e);
+
/* First of all, handle overload magic of the rightmost argument */
if (SvAMAGIC(e)) {
- SV * const tmpsv = amagic_call(d, e, smart_amg, 0);
+ SV * tmpsv;
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
+ DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
+
+ tmpsv = amagic_call(d, e, smart_amg, 0);
if (tmpsv) {
SPAGAIN;
(void)POPs;
SETs(tmpsv);
RETURN;
}
+ DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
}
SP -= 2; /* Pop the values */
- /* Take care only to invoke mg_get() once for each argument.
- * Currently we do this by copying the SV if it's magical. */
- if (d) {
- if (SvGMAGICAL(d))
- d = sv_mortalcopy(d);
- }
- else
- d = &PL_sv_undef;
-
- assert(e);
- if (SvGMAGICAL(e))
- e = sv_mortalcopy(e);
/* ~~ undef */
if (!SvOK(e)) {
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
if (SvOK(d))
RETPUSHNO;
else
RETPUSHYES;
}
- if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP))
+ if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
+ }
if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
object_on_left = TRUE;
bool andedresults = TRUE;
HV *hv = (HV*) SvRV(d);
I32 numkeys = hv_iterinit(hv);
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
if (numkeys == 0)
RETPUSHYES;
while ( (he = hv_iternext(hv)) ) {
- ENTER;
+ DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
+ ENTER_with_name("smartmatch_hash_key_test");
SAVETMPS;
PUSHMARK(SP);
PUSHs(hv_iterkeysv(he));
else
andedresults = SvTRUEx(POPs) && andedresults;
FREETMPS;
- LEAVE;
+ LEAVE_with_name("smartmatch_hash_key_test");
}
if (andedresults)
RETPUSHYES;
bool andedresults = TRUE;
AV *av = (AV*) SvRV(d);
const I32 len = av_len(av);
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
if (len == -1)
RETPUSHYES;
for (i = 0; i <= len; ++i) {
SV * const * const svp = av_fetch(av, i, FALSE);
- ENTER;
+ DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
+ ENTER_with_name("smartmatch_array_elem_test");
SAVETMPS;
PUSHMARK(SP);
if (svp)
else
andedresults = SvTRUEx(POPs) && andedresults;
FREETMPS;
- LEAVE;
+ LEAVE_with_name("smartmatch_array_elem_test");
}
if (andedresults)
RETPUSHYES;
}
else {
sm_any_sub:
- ENTER;
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
+ ENTER_with_name("smartmatch_coderef");
SAVETMPS;
PUSHMARK(SP);
PUSHs(d);
else if (SvTEMP(TOPs))
SvREFCNT_inc_void(TOPs);
FREETMPS;
- LEAVE;
+ LEAVE_with_name("smartmatch_coderef");
RETURN;
}
}
goto sm_any_hash; /* Treat objects like scalars */
}
else if (!SvOK(d)) {
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
RETPUSHNO;
}
else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
U32 this_key_count = 0,
other_key_count = 0;
HV *hv = MUTABLE_HV(SvRV(e));
-
+
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
/* Tied hashes don't know how many keys they have. */
if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
tied = TRUE;
(void) hv_iterinit(hv);
while ( (he = hv_iternext(hv)) ) {
SV *key = hv_iterkeysv(he);
-
+
+ DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
++ this_key_count;
if(!hv_exists_ent(other_hv, key, 0)) {
I32 i;
HV *hv = MUTABLE_HV(SvRV(e));
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
for (i = 0; i < other_len; ++i) {
SV ** const svp = av_fetch(other_av, i, FALSE);
+ DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
if (svp) { /* ??? When can this not happen? */
if (hv_exists_ent(hv, *svp, 0))
RETPUSHYES;
RETPUSHNO;
}
else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
sm_regex_hash:
{
PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
(void) hv_iterinit(hv);
while ( (he = hv_iternext(hv)) ) {
+ DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
(void) hv_iterinit(hv);
destroy_matcher(matcher);
}
else {
sm_any_hash:
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
RETPUSHYES;
else
const I32 other_len = av_len(other_av) + 1;
I32 i;
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
for (i = 0; i < other_len; ++i) {
SV ** const svp = av_fetch(other_av, i, FALSE);
+
+ DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
if (svp) { /* ??? When can this not happen? */
if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
RETPUSHYES;
}
if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
AV *other_av = MUTABLE_AV(SvRV(d));
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
RETPUSHNO;
else {
(void) sv_2mortal(MUTABLE_SV(seen_this));
}
if (NULL == seen_other) {
- seen_this = newHV();
+ seen_other = newHV();
(void) sv_2mortal(MUTABLE_SV(seen_other));
}
for(i = 0; i <= other_len; ++i) {
SV * const * const other_elem = av_fetch(other_av, i, FALSE);
if (!this_elem || !other_elem) {
- if (this_elem || other_elem)
+ if ((this_elem && SvOK(*this_elem))
+ || (other_elem && SvOK(*other_elem)))
RETPUSHNO;
}
else if (hv_exists_ent(seen_this,
PUSHs(*this_elem);
PUTBACK;
+ DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
(void) do_smartmatch(seen_this, seen_other);
SPAGAIN;
+ DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
if (!SvTRUEx(POPs))
RETPUSHNO;
}
}
else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
sm_regex_array:
{
PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
for(i = 0; i <= this_len; ++i) {
SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
+ DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
if (svp && matcher_matches_sv(matcher, *svp)) {
destroy_matcher(matcher);
RETPUSHYES;
const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
I32 i;
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
for (i = 0; i <= this_len; ++i) {
SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
+ DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
if (!svp || !SvOK(*svp))
RETPUSHYES;
}
I32 i;
const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
for (i = 0; i <= this_len; ++i) {
SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
if (!svp)
PUSHs(*svp);
PUTBACK;
/* infinite recursion isn't supposed to happen here */
+ DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
(void) do_smartmatch(NULL, NULL);
SPAGAIN;
+ DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
if (SvTRUEx(POPs))
RETPUSHYES;
}
else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
SV *t = d; d = e; e = t;
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
goto sm_regex_hash;
}
else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
SV *t = d; d = e; e = t;
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
goto sm_regex_array;
}
else {
PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
PUTBACK;
PUSHs(matcher_matches_sv(matcher, d)
? &PL_sv_yes
/* See if there is overload magic on left */
else if (object_on_left && SvAMAGIC(d)) {
SV *tmpsv;
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
+ DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
PUSHs(d); PUSHs(e);
PUTBACK;
tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
RETURN;
}
SP -= 2;
+ DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
goto sm_any_scalar;
}
else if (!SvOK(d)) {
/* undef ~~ scalar ; we already know that the scalar is SvOK */
+ DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
RETPUSHNO;
}
else
sm_any_scalar:
if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
+ DEBUG_M(if (SvNIOK(e))
+ Perl_deb(aTHX_ " applying rule Any-Num\n");
+ else
+ Perl_deb(aTHX_ " applying rule Num-numish\n");
+ );
/* numeric comparison */
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;
}
/* As a last resort, use string comparison */
+ 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)
fails, we don't want to push a context and then
pop it again right away, so we skip straight
to the op that follows the leavewhen.
+ RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
*/
if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
- return cLOGOP->op_other->op_next;
+ RETURNOP(cLOGOP->op_other->op_next);
- ENTER;
+ ENTER_with_name("eval");
SAVETMPS;
PUSHBLOCK(cx, CXt_WHEN, SP);
PL_curpm = newpm; /* pop $1 et al */
- LEAVE;
+ LEAVE_with_name("eval");
return NORMAL;
}
I32 cxix;
register PERL_CONTEXT *cx;
I32 inner;
-
+ dSP;
+
cxix = dopoptogiven(cxstack_ix);
if (cxix < 0) {
if (PL_op->op_flags & OPf_SPECIAL)
PL_curcop = cx->blk_oldcop;
if (CxFOREACH(cx))
- return CX_LOOP_NEXTOP_GET(cx);
+ return (cx)->blk_loop.my_op->op_nextop;
else
- return cx->blk_givwhen.leave_op;
+ /* RETURNOP calls PUTBACK which restores the old old sp */
+ RETURNOP(cx->blk_givwhen.leave_op);
}
STATIC OP *
int status = 0;
SV *upstream;
STRLEN got_len;
- const char *got_p = NULL;
- const char *prune_from = NULL;
+ char *got_p = NULL;
+ char *prune_from = NULL;
bool read_from_cache = FALSE;
STRLEN umaxlen;
for PL_parser->error_count == 0.) Solaris doesn't segfault --
not sure where the trouble is yet. XXX */
- if (IoFMT_GV(datasv)) {
- SV *const cache = MUTABLE_SV(IoFMT_GV(datasv));
+ {
+ SV *const cache = datasv;
if (SvOK(cache)) {
STRLEN cache_len;
const char *cache_p = SvPV(cache, cache_len);
if (take) {
sv_catpvn(buf_sv, cache_p, take);
sv_chop(cache, cache_p + take);
- /* Definately not EOF */
+ /* Definitely not EOF */
return 1;
}
dSP;
int count;
- ENTER;
+ ENTER_with_name("call_filter_sub");
SAVE_DEFSV;
SAVETMPS;
EXTEND(SP, 2);
PUTBACK;
FREETMPS;
- LEAVE;
+ LEAVE_with_name("call_filter_sub");
}
if(SvOK(upstream)) {
prune_from = got_p + umaxlen;
}
} else {
- const char *const first_nl =
- (const char *)memchr(got_p, '\n', got_len);
+ char *const first_nl = (char *)memchr(got_p, '\n', got_len);
if (first_nl && first_nl + 1 < got_p + got_len) {
/* There's a second line here... */
prune_from = first_nl + 1;
if (prune_from) {
/* Oh. Too long. Stuff some in our cache. */
STRLEN cached_len = got_p + got_len - prune_from;
- SV *cache = MUTABLE_SV(IoFMT_GV(datasv));
+ SV *const cache = datasv;
- if (!cache) {
- IoFMT_GV(datasv) = MUTABLE_GV((cache = newSV(got_len - umaxlen)));
- } else if (SvOK(cache)) {
+ if (SvOK(cache)) {
/* Cache should be empty. */
assert(!SvCUR(cache));
}
SvUTF8_on(cache);
}
SvCUR_set(upstream, got_len - cached_len);
+ *prune_from = 0;
/* Can't yet be EOF */
if (status == 0)
status = 1;
if (status <= 0) {
IoLINES(datasv) = 0;
- SvREFCNT_dec(IoFMT_GV(datasv));
if (filter_state) {
SvREFCNT_dec(filter_state);
IoTOP_GV(datasv) = NULL;
https://perl5.git.perl.org / perl5.git / blobdiff