PP(pp_regcreset)
{
dVAR;
- /* XXXX Should store the old value to allow for tie/overload - and
- restore in regcomp, where marked with XXXX. */
- PL_reginterp_cnt = 0;
TAINT_NOT;
return NORMAL;
}
dVAR;
dSP;
register PMOP *pm = (PMOP*)cLOGOP->op_other;
- SV *tmpstr;
+ SV **args;
+ int nargs;
REGEXP *re = NULL;
+ REGEXP *new_re;
+ const regexp_engine *eng;
+ int is_bare_re;
+
+ if (PL_op->op_flags & OPf_STACKED) {
+ dMARK;
+ nargs = SP - MARK;
+ args = ++MARK;
+ }
+ else {
+ nargs = 1;
+ args = SP;
+ }
/* prevent recompiling under /o and ithreads. */
#if defined(USE_ITHREADS)
if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
- if (PL_op->op_flags & OPf_STACKED) {
- dMARK;
- SP = MARK;
- }
- else
- (void)POPs;
+ SP = args-1;
RETURN;
}
#endif
-#define tryAMAGICregexp(rx) \
- STMT_START { \
- SvGETMAGIC(rx); \
- if (SvROK(rx) && SvAMAGIC(rx)) { \
- SV *sv = AMG_CALLunary(rx, regexp_amg); \
- if (sv) { \
- if (SvROK(sv)) \
- sv = SvRV(sv); \
- if (SvTYPE(sv) != SVt_REGEXP) \
- Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
- rx = sv; \
- } \
- } \
- } STMT_END
-
-
- if (PL_op->op_flags & OPf_STACKED) {
- /* multiple args; concatenate them */
- dMARK; dORIGMARK;
- tmpstr = PAD_SV(ARGTARG);
- sv_setpvs(tmpstr, "");
- while (++MARK <= SP) {
- SV *msv = *MARK;
- SV *sv;
-
- tryAMAGICregexp(msv);
-
- if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
- (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
- {
- sv_setsv(tmpstr, sv);
- continue;
- }
- sv_catsv_nomg(tmpstr, msv);
- }
- SvSETMAGIC(tmpstr);
- SP = ORIGMARK;
- }
- else {
- tmpstr = POPs;
- tryAMAGICregexp(tmpstr);
- }
-
-#undef tryAMAGICregexp
-
- if (SvROK(tmpstr)) {
- SV * const sv = SvRV(tmpstr);
- if (SvTYPE(sv) == SVt_REGEXP)
- re = (REGEXP*) sv;
- }
- else if (SvTYPE(tmpstr) == SVt_REGEXP)
- re = (REGEXP*) tmpstr;
-
- if (re) {
- /* The match's LHS's get-magic might need to access this op's reg-
- exp (as is sometimes the case with $'; see bug 70764). So we
- must call get-magic now before we replace the regexp. Hopeful-
- ly this hack can be replaced with the approach described at
- http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
- /msg122415.html some day. */
- if(pm->op_type == OP_MATCH) {
- SV *lhs;
- const bool was_tainted = PL_tainted;
- if (pm->op_flags & OPf_STACKED)
- lhs = TOPs;
- else if (pm->op_private & OPpTARGET_MY)
- lhs = PAD_SV(pm->op_targ);
- else lhs = DEFSV;
- SvGETMAGIC(lhs);
- /* Restore the previous value of PL_tainted (which may have been
- modified by get-magic), to avoid incorrectly setting the
- RXf_TAINTED flag further down. */
- PL_tainted = was_tainted;
+ re = PM_GETRE(pm);
+ assert (re != (REGEXP*) &PL_sv_undef);
+ eng = re ? RX_ENGINE(re) : current_re_engine();
+
+ new_re = (eng->op_comp
+ ? eng->op_comp
+ : &Perl_re_op_compile
+ )(aTHX_ args, nargs, pm->op_code_list, eng, re,
+ &is_bare_re,
+ (pm->op_pmflags & RXf_PMf_COMPILETIME),
+ pm->op_pmflags |
+ (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
+ if (pm->op_pmflags & PMf_HAS_CV)
+ ((struct regexp *)SvANY(new_re))->qr_anoncv
+ = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
+
+ if (is_bare_re) {
+ REGEXP *tmp;
+ /* The match's LHS's get-magic might need to access this op's regexp
+ (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
+ get-magic now before we replace the regexp. Hopefully this hack can
+ be replaced with the approach described at
+ http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
+ some day. */
+ if (pm->op_type == OP_MATCH) {
+ SV *lhs;
+ const bool was_tainted = PL_tainted;
+ if (pm->op_flags & OPf_STACKED)
+ lhs = args[-1];
+ else if (pm->op_private & OPpTARGET_MY)
+ lhs = PAD_SV(pm->op_targ);
+ else lhs = DEFSV;
+ SvGETMAGIC(lhs);
+ /* Restore the previous value of PL_tainted (which may have been
+ modified by get-magic), to avoid incorrectly setting the
+ RXf_TAINTED flag further down. */
+ PL_tainted = was_tainted;
}
-
- re = reg_temp_copy(NULL, re);
- ReREFCNT_dec(PM_GETRE(pm));
- PM_SETRE(pm, re);
+ tmp = reg_temp_copy(NULL, new_re);
+ ReREFCNT_dec(new_re);
+ new_re = tmp;
}
- else {
- STRLEN len = 0;
- const char *t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : "";
-
- re = PM_GETRE(pm);
- assert (re != (REGEXP*) &PL_sv_undef);
-
- /* Check against the last compiled regexp. */
- if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
- memNE(RX_PRECOMP(re), t, len))
- {
- const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
- U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
- if (re) {
- ReREFCNT_dec(re);
-#ifdef USE_ITHREADS
- PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
-#else
- PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
-#endif
- } else if (PL_curcop->cop_hints_hash) {
- SV *ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
- if (ptr && SvIOK(ptr) && SvIV(ptr))
- eng = INT2PTR(regexp_engine*,SvIV(ptr));
- }
-
- if (PL_op->op_flags & OPf_SPECIAL)
- PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
-
- if (!DO_UTF8(tmpstr) && SvUTF8(tmpstr)) {
- /* Not doing UTF-8, despite what the SV says. Is this only if
- we're trapped in use 'bytes'? */
- /* Make a copy of the octet sequence, but without the flag on,
- as the compiler now honours the SvUTF8 flag on tmpstr. */
- STRLEN len;
- const char *const p = SvPV(tmpstr, len);
- tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
- }
- else if (SvAMAGIC(tmpstr) || SvGMAGICAL(tmpstr)) {
- /* make a copy to avoid extra stringifies */
- tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr));
- }
-
- if (eng)
- PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
- else
- PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
-
- PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
- inside tie/overload accessors. */
- }
+ if (re != new_re) {
+ ReREFCNT_dec(re);
+ PM_SETRE(pm, new_re);
}
-
- re = PM_GETRE(pm);
#ifndef INCOMPLETE_TAINTS
- if (PL_tainting) {
- if (PL_tainted) {
- SvTAINTED_on((SV*)re);
- RX_EXTFLAGS(re) |= RXf_TAINTED;
- }
+ if (PL_tainting && PL_tainted) {
+ SvTAINTED_on((SV*)new_re);
+ RX_EXTFLAGS(new_re) |= RXf_TAINTED;
}
#endif
- if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
- pm = PL_curpm;
-
-
#if !defined(USE_ITHREADS)
/* can't change the optree at runtime either */
/* PMf_KEEP is handled differently under threads to avoid these problems */
+ if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
+ pm = PL_curpm;
if (pm->op_pmflags & PMf_KEEP) {
pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
cLOGOP->op_first->op_next = PL_op->op_next;
}
#endif
+
+ SP = args-1;
RETURN;
}
+
PP(pp_substcont)
{
dVAR;
s -= RX_GOFS(rx);
/* Are we done */
- /* I believe that we can't set REXEC_SCREAM here if
- SvSCREAM(cx->sb_targ) is true because SvPVX(cx->sb_targ) isn't always
- equal to s. [See the comment before Perl_re_intuit_start(), which is
- called from Perl_regexec_flags(), which says that it should be when
- SvSCREAM() is true.] s, cx->sb_strend and orig will be consistent
- with SvPVX(cx->sb_targ), as substconst doesn't modify cx->sb_targ
- during the match. */
if (CxONCE(cx) || s < orig ||
!CALLREGEXEC(rx, s, cx->sb_strend, orig,
(s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
targ = dstr;
}
else {
-#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(targ)) {
sv_force_normal_flags(targ, SV_COW_DROP_PV);
} else
-#endif
{
SvPV_free(targ);
}
};
STATIC I32
-S_dopoptolabel(pTHX_ const char *label)
+S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
{
dVAR;
register I32 i;
case CXt_FORMAT:
case CXt_EVAL:
case CXt_NULL:
+ /* diag_listed_as: Exiting subroutine via %s */
Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
context_name[CxTYPE(cx)], OP_NAME(PL_op));
if (CxTYPE(cx) == CXt_NULL)
case CXt_LOOP_FOR:
case CXt_LOOP_PLAIN:
{
- const char *cx_label = CxLABEL(cx);
- if (!cx_label || strNE(label, cx_label) ) {
+ STRLEN cx_label_len = 0;
+ U32 cx_label_flags = 0;
+ const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
+ if (!cx_label || !(
+ ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
+ (flags & SVf_UTF8)
+ ? (bytes_cmp_utf8(
+ (const U8*)cx_label, cx_label_len,
+ (const U8*)label, len) == 0)
+ : (bytes_cmp_utf8(
+ (const U8*)label, len,
+ (const U8*)cx_label, cx_label_len) == 0)
+ : (len == cx_label_len && ((cx_label == label)
+ || memEQ(cx_label, label, len))) )) {
DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
(long)i, cx_label));
continue;
case CXt_FORMAT:
case CXt_EVAL:
case CXt_NULL:
+ /* diag_listed_as: Exiting subroutine via %s */
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;
}
- stash_hek = HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop));
+ DEBUG_CX("CALLER");
+ assert(CopSTASH(cx->blk_oldcop));
+ stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
+ ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
+ : NULL;
if (GIMME != G_ARRAY) {
EXTEND(SP, 1);
if (!stash_hek)
if (MARK < SP) {
copy_sv:
if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
+ if (!SvPADTMP(*SP)) {
*++newsp = SvREFCNT_inc(*SP);
FREETMPS;
sv_2mortal(*newsp);
+ }
+ else {
+ /* FREETMPS could clobber it */
+ SV *sv = SvREFCNT_inc(*SP);
+ FREETMPS;
+ *++newsp = sv_mortalcopy(sv);
+ SvREFCNT_dec(sv);
+ }
}
else
*++newsp =
- !SvTEMP(*SP)
+ SvPADTMP(*SP)
+ ? sv_mortalcopy(*SP)
+ : !SvTEMP(*SP)
? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
: *SP;
}
if (ref || !CxLVAL(cx))
while (++MARK <= SP)
*++newsp =
- SvTEMP(*MARK)
- ? *MARK
- : ref && SvFLAGS(*MARK) & SVs_PADTMP
+ SvFLAGS(*MARK) & SVs_PADTMP
? sv_mortalcopy(*MARK)
+ : SvTEMP(*MARK)
+ ? *MARK
: sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
else while (++MARK <= SP) {
if (*MARK != &PL_sv_undef
POPSUB(cx,sv);
PL_curpm = newpm;
LEAVESUB(sv);
+ /* diag_listed_as: Can't return %s from lvalue subroutine */
Perl_croak(aTHX_
"Can't return a %s from lvalue subroutine",
SvREADONLY(TOPs) ? "readonly value" : "temporary");
retop = cx->blk_sub.retop;
break;
default:
- DIE(aTHX_ "panic: return");
+ DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
}
TAINT_NOT;
if (MARK < SP) {
if (popsub2) {
if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
- if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
+ if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
+ && !SvMAGICAL(TOPs)) {
*++newsp = SvREFCNT_inc(*SP);
FREETMPS;
sv_2mortal(*newsp);
SvREFCNT_dec(sv);
}
}
- else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1) {
+ else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
+ && !SvMAGICAL(*SP)) {
*++newsp = *SP;
}
else
else if (gimme == G_ARRAY) {
while (++MARK <= SP) {
*++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
+ && !SvGMAGICAL(*MARK)
? *MARK : sv_mortalcopy(*MARK);
TAINT_NOT; /* Each item is independent */
}
DIE(aTHX_ "Can't \"last\" outside a loop block");
}
else {
- cxix = dopoptolabel(cPVOP->op_pv);
+ cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv),
+ (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0);
if (cxix < 0)
- DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
+ DIE(aTHX_ "Label not found for \"last %"SVf"\"",
+ SVfARG(newSVpvn_flags(cPVOP->op_pv,
+ strlen(cPVOP->op_pv),
+ ((cPVOP->op_private & OPpPV_IS_UTF8)
+ ? SVf_UTF8 : 0) | SVs_TEMP)));
}
if (cxix < cxstack_ix)
dounwind(cxix);
nextop = cx->blk_sub.retop;
break;
default:
- DIE(aTHX_ "panic: last");
+ DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
}
TAINT_NOT;
DIE(aTHX_ "Can't \"next\" outside a loop block");
}
else {
- cxix = dopoptolabel(cPVOP->op_pv);
- if (cxix < 0)
- DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
+ cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv),
+ (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0);
+ if (cxix < 0)
+ DIE(aTHX_ "Label not found for \"next %"SVf"\"",
+ SVfARG(newSVpvn_flags(cPVOP->op_pv,
+ strlen(cPVOP->op_pv),
+ ((cPVOP->op_private & OPpPV_IS_UTF8)
+ ? SVf_UTF8 : 0) | SVs_TEMP)));
}
if (cxix < cxstack_ix)
dounwind(cxix);
DIE(aTHX_ "Can't \"redo\" outside a loop block");
}
else {
- cxix = dopoptolabel(cPVOP->op_pv);
- if (cxix < 0)
- DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
+ cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv),
+ (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0);
+ if (cxix < 0)
+ DIE(aTHX_ "Label not found for \"redo %"SVf"\"",
+ SVfARG(newSVpvn_flags(cPVOP->op_pv,
+ strlen(cPVOP->op_pv),
+ ((cPVOP->op_private & OPpPV_IS_UTF8)
+ ? SVf_UTF8 : 0) | SVs_TEMP)));
}
if (cxix < cxstack_ix)
dounwind(cxix);
}
STATIC OP *
-S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
+S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
{
dVAR;
OP **ops = opstack;
/* 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) {
- const char *kid_label = CopLABEL(kCOP);
- if (kid_label && strEQ(kid_label, label))
+ STRLEN kid_label_len;
+ U32 kid_label_flags;
+ const char *kid_label = CopLABEL_len_flags(kCOP,
+ &kid_label_len, &kid_label_flags);
+ if (kid_label && (
+ ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
+ (flags & SVf_UTF8)
+ ? (bytes_cmp_utf8(
+ (const U8*)kid_label, kid_label_len,
+ (const U8*)label, len) == 0)
+ : (bytes_cmp_utf8(
+ (const U8*)label, len,
+ (const U8*)kid_label, kid_label_len) == 0)
+ : ( len == kid_label_len && ((kid_label == label)
+ || memEQ(kid_label, label, len)))))
return kid;
}
}
else
*ops++ = kid;
}
- if ((o = dofindlabel(kid, label, ops, oplimit)))
+ if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
return o;
}
}
#define GOTO_DEPTH 64
OP *enterops[GOTO_DEPTH];
const char *label = NULL;
+ STRLEN label_len = 0;
+ U32 label_flags = 0;
const bool do_dump = (PL_op->op_type == OP_DUMP);
static const char must_have_label[] = "goto must have label";
/* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
if (CxTYPE(cx) == CXt_EVAL) {
if (CxREALEVAL(cx))
+ /* diag_listed_as: Can't goto subroutine from an eval-%s */
DIE(aTHX_ "Can't goto subroutine from an eval-string");
else
+ /* diag_listed_as: Can't goto subroutine from an eval-%s */
DIE(aTHX_ "Can't goto subroutine from an eval-block");
}
else if (CxMULTICALL(cx))
}
}
else {
- label = SvPV_nolen_const(sv);
- if (!(do_dump || *label))
- DIE(aTHX_ must_have_label);
+ label = SvPV_const(sv, label_len);
+ label_flags = SvUTF8(sv);
}
}
- else if (PL_op->op_flags & OPf_SPECIAL) {
- if (! do_dump)
- DIE(aTHX_ must_have_label);
+ else if (!(PL_op->op_flags & OPf_SPECIAL)) {
+ label = cPVOP->op_pv;
+ label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
+ label_len = strlen(label);
}
- else
- label = cPVOP->op_pv;
+ if (!(do_dump || label_len)) DIE(aTHX_ must_have_label);
PERL_ASYNC_CHECK();
- if (label && *label) {
+ if (label_len) {
OP *gotoprobe = NULL;
bool leaving_eval = FALSE;
bool in_block = FALSE;
DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
default:
if (ix)
- DIE(aTHX_ "panic: goto");
+ DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
+ CxTYPE(cx), (long) ix);
gotoprobe = PL_main_root;
break;
}
if (gotoprobe) {
- retop = dofindlabel(gotoprobe, label,
+ retop = dofindlabel(gotoprobe, label, label_len, label_flags,
enterops, enterops + GOTO_DEPTH);
if (retop)
break;
gotoprobe->op_sibling->op_type == OP_UNSTACK &&
gotoprobe->op_sibling->op_sibling) {
retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
- label, enterops, enterops + GOTO_DEPTH);
+ label, label_len, label_flags, enterops,
+ enterops + GOTO_DEPTH);
if (retop)
break;
}
PL_lastgotoprobe = gotoprobe;
}
if (!retop)
- DIE(aTHX_ "Can't find label %s", label);
+ DIE(aTHX_ "Can't find label %"SVf,
+ SVfARG(newSVpvn_flags(label, label_len,
+ SVs_TEMP | label_flags)));
/* if we're leaving an eval, check before we pop any frames
that we're not going to punt, otherwise the error
return NULL;
}
-/* James Bond: Do you expect me to talk?
- Auric Goldfinger: No, Mr. Bond. I expect you to die.
-
- This code is an ugly hack, doesn't work with lexicals in subroutines that are
- called more than once, and is only used by regcomp.c, for (?{}) blocks.
-
- Currently it is not used outside the core code. Best if it stays that way.
-
- Hence it's now deprecated, and will be removed.
-*/
-OP *
-Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
-/* sv Text to convert to OP tree. */
-/* startop op_free() this to undo. */
-/* code Short string id of the caller. */
-{
- PERL_ARGS_ASSERT_SV_COMPILE_2OP;
- return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
-}
-
-/* Don't use this. It will go away without warning once the regexp engine is
- refactored not to use it. */
-OP *
-Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
- PAD **padp)
-{
- dVAR; dSP; /* Make POPBLOCK work. */
- PERL_CONTEXT *cx;
- SV **newsp;
- I32 gimme = G_VOID;
- I32 optype;
- OP dummy;
- char tbuf[TYPE_DIGITS(long) + 12 + 10];
- char *tmpbuf = tbuf;
- char *safestr;
- int runtime;
- CV* runcv = NULL; /* initialise to avoid compiler warnings */
- STRLEN len;
- bool need_catch;
-
- PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
-
- ENTER_with_name("eval");
- lex_start(sv, NULL, LEX_START_SAME_FILTER);
- SAVETMPS;
- /* switch to eval mode */
-
- if (IN_PERL_COMPILETIME) {
- SAVECOPSTASH_FREE(&PL_compiling);
- CopSTASH_set(&PL_compiling, PL_curstash);
- }
- if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
- SV * const sv = sv_newmortal();
- Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
- code, (unsigned long)++PL_evalseq,
- CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
- tmpbuf = SvPVX(sv);
- len = SvCUR(sv);
- }
- else
- len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
- (unsigned long)++PL_evalseq);
- SAVECOPFILE_FREE(&PL_compiling);
- CopFILE_set(&PL_compiling, tmpbuf+2);
- SAVECOPLINE(&PL_compiling);
- CopLINE_set(&PL_compiling, 1);
- /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
- deleting the eval's FILEGV from the stash before gv_check() runs
- (i.e. before run-time proper). To work around the coredump that
- ensues, we always turn GvMULTI_on for any globals that were
- introduced within evals. See force_ident(). GSAR 96-10-12 */
- safestr = savepvn(tmpbuf, len);
- SAVEDELETE(PL_defstash, safestr, len);
- SAVEHINTS();
-#ifdef OP_IN_REGISTER
- PL_opsave = op;
-#else
- SAVEVPTR(PL_op);
-#endif
-
- /* we get here either during compilation, or via pp_regcomp at runtime */
- runtime = IN_PERL_RUNTIME;
- if (runtime)
- {
- runcv = find_runcv(NULL);
-
- /* At run time, we have to fetch the hints from PL_curcop. */
- PL_hints = PL_curcop->cop_hints;
- if (PL_hints & HINT_LOCALIZE_HH) {
- /* SAVEHINTS created a new HV in PL_hintgv, which we
- need to GC */
- SvREFCNT_dec(GvHV(PL_hintgv));
- GvHV(PL_hintgv) =
- refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
- hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
- }
- SAVECOMPILEWARNINGS();
- PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
- cophh_free(CopHINTHASH_get(&PL_compiling));
- /* XXX Does this need to avoid copying a label? */
- PL_compiling.cop_hints_hash
- = cophh_copy(PL_curcop->cop_hints_hash);
- }
-
- PL_op = &dummy;
- PL_op->op_type = OP_ENTEREVAL;
- PL_op->op_flags = 0; /* Avoid uninit warning. */
- PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
- PUSHEVAL(cx, 0);
- need_catch = CATCH_GET;
- CATCH_SET(TRUE);
-
- if (runtime)
- (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq, NULL);
- else
- (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax, NULL);
- CATCH_SET(need_catch);
- POPBLOCK(cx,PL_curpm);
- POPEVAL(cx);
-
- (*startop)->op_type = OP_NULL;
- (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
- /* XXX DAPM do this properly one year */
- *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
- LEAVE_with_name("eval");
- if (IN_PERL_COMPILETIME)
- CopHINTS_set(&PL_compiling, PL_hints);
-#ifdef OP_IN_REGISTER
- op = PL_opsave;
-#endif
- PERL_UNUSED_VAR(newsp);
- PERL_UNUSED_VAR(optype);
-
- return PL_eval_start;
-}
-
/*
=for apidoc find_runcv
}
-/* Compile a require/do, an eval '', or a /(?{...})/.
- * In the last case, startop is non-null, and contains the address of
- * a pointer that should be set to the just-compiled code.
+/* Compile a require/do or an eval ''.
+ *
* outside is the lexically enclosing CV (if any) that invoked us.
+ * seq is the current COP scope value.
+ * hh is the saved hints hash, if any.
+ *
* Returns a bool indicating whether the compile was successful; if so,
- * PL_eval_start contains the first op of the compiled ocde; otherwise,
- * pushes undef (also croaks if startop != NULL).
- */
-
-/* This function is called from three places, sv_compile_2op, pp_return
- * and pp_entereval. These can be distinguished as follows:
- * sv_compile_2op - startop is non-null
- * pp_require - startop is null; in_require is true
- * pp_entereval - stortop is null; in_require is false
+ * PL_eval_start contains the first op of the compiled code; otherwise,
+ * pushes undef.
+ *
+ * This function is called from two places: pp_require and pp_entereval.
+ * These can be distinguished by whether PL_op is entereval.
*/
STATIC bool
-S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh)
+S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
{
dVAR; dSP;
OP * const saveop = PL_op;
+ bool clear_hints = saveop->op_type != OP_ENTEREVAL;
COP * const oldcurcop = PL_curcop;
bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
int yystatus;
PL_madskills = 0;
#endif
- if (!startop) ENTER_with_name("evalcomp");
+ ENTER_with_name("evalcomp");
SAVESPTR(PL_compcv);
PL_compcv = evalcv;
else
CLEAR_ERRSV();
- if (!startop) {
- SAVEHINTS();
- if (in_require) {
- PL_hints = 0;
- hv_clear(GvHV(PL_hintgv));
- }
- else {
- PL_hints = saveop->op_private & OPpEVAL_COPHH
- ? oldcurcop->cop_hints : saveop->op_targ;
- if (hh) {
- /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
- SvREFCNT_dec(GvHV(PL_hintgv));
- GvHV(PL_hintgv) = hh;
- }
- }
- SAVECOMPILEWARNINGS();
- if (in_require) {
- if (PL_dowarn & G_WARN_ALL_ON)
- PL_compiling.cop_warnings = pWARN_ALL ;
- else if (PL_dowarn & G_WARN_ALL_OFF)
- PL_compiling.cop_warnings = pWARN_NONE ;
- else
- PL_compiling.cop_warnings = pWARN_STD ;
+ SAVEHINTS();
+ if (clear_hints) {
+ PL_hints = 0;
+ hv_clear(GvHV(PL_hintgv));
+ }
+ else {
+ PL_hints = saveop->op_private & OPpEVAL_COPHH
+ ? oldcurcop->cop_hints : saveop->op_targ;
+ if (hh) {
+ /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
+ SvREFCNT_dec(GvHV(PL_hintgv));
+ GvHV(PL_hintgv) = hh;
}
- else {
- PL_compiling.cop_warnings =
- DUP_WARNINGS(oldcurcop->cop_warnings);
- cophh_free(CopHINTHASH_get(&PL_compiling));
- if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
- /* The label, if present, is the first entry on the chain. So rather
- than writing a blank label in front of it (which involves an
- allocation), just use the next entry in the chain. */
- PL_compiling.cop_hints_hash
- = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
- /* Check the assumption that this removed the label. */
- assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
- }
- else
- PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
+ }
+ SAVECOMPILEWARNINGS();
+ if (clear_hints) {
+ if (PL_dowarn & G_WARN_ALL_ON)
+ PL_compiling.cop_warnings = pWARN_ALL ;
+ else if (PL_dowarn & G_WARN_ALL_OFF)
+ PL_compiling.cop_warnings = pWARN_NONE ;
+ else
+ PL_compiling.cop_warnings = pWARN_STD ;
+ }
+ else {
+ PL_compiling.cop_warnings =
+ DUP_WARNINGS(oldcurcop->cop_warnings);
+ cophh_free(CopHINTHASH_get(&PL_compiling));
+ if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
+ /* The label, if present, is the first entry on the chain. So rather
+ than writing a blank label in front of it (which involves an
+ allocation), just use the next entry in the chain. */
+ PL_compiling.cop_hints_hash
+ = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
+ /* Check the assumption that this removed the label. */
+ assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
}
+ else
+ PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
}
CALL_BLOCK_HOOKS(bhk_eval, saveop);
yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
- if (!startop && yystatus != 3) LEAVE_with_name("evalcomp");
-
if (yystatus || PL_parser->error_count || !PL_eval_root) {
SV **newsp; /* Used by POPBLOCK. */
PERL_CONTEXT *cx;
PL_eval_root = NULL;
}
SP = PL_stack_base + POPMARK; /* pop original mark */
- if (!startop) {
- POPBLOCK(cx,PL_curpm);
- POPEVAL(cx);
- namesv = cx->blk_eval.old_namesv;
- }
+ POPBLOCK(cx,PL_curpm);
+ POPEVAL(cx);
+ namesv = cx->blk_eval.old_namesv;
+ /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
}
? ERRSV
: newSVpvs_flags("Unknown error\n", SVs_TEMP)));
}
- else if (startop) {
- if (yystatus != 3) {
- POPBLOCK(cx,PL_curpm);
- POPEVAL(cx);
- }
- Perl_croak(aTHX_ "%"SVf"Compilation failed in regexp",
- SVfARG(ERRSV
- ? ERRSV
- : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
- }
else {
if (!*(SvPVx_nolen_const(ERRSV))) {
sv_setpvs(ERRSV, "Compilation error");
}
}
- PUSHs(&PL_sv_undef);
+ if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
PUTBACK;
return FALSE;
}
+ else
+ LEAVE_with_name("evalcomp");
+
CopLINE_set(&PL_compiling, 0);
- if (startop) {
- *startop = PL_eval_root;
- } else
- SAVEFREEOP(PL_eval_root);
+ SAVEFREEOP(PL_eval_root);
DEBUG_x(dump_eval());
encoding = PL_encoding;
PL_encoding = NULL;
- if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq, NULL))
+ if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
op = DOCATCH(PL_eval_start);
else
op = PL_op->op_next;
PUTBACK;
- if (doeval(gimme, NULL, runcv, seq, saved_hh)) {
+ if (doeval(gimme, runcv, seq, saved_hh)) {
if (was != PL_breakable_sub_gen /* Some subs defined here. */
? (PERLDB_LINE || PERLDB_SAVESRC)
: PERLDB_SAVESRC_NOSUBS) {
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);
+ tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
if (tmpsv) {
SPAGAIN;
(void)POPs;
cxix = dopoptogiven(cxstack_ix);
if (cxix < 0)
- DIE(aTHX_ "Can't use when() outside a topicalizer");
+ /* diag_listed_as: Can't "when" outside a topicalizer */
+ DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
+ PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
POPBLOCK(cx,newpm);
assert(CxTYPE(cx) == CXt_WHEN);
int count;
ENTER_with_name("call_filter_sub");
- save_gp(PL_defgv, 0);
- GvINTRO_off(PL_defgv);
- SAVEGENERICSV(GvSV(PL_defgv));
+ SAVE_DEFSV;
SAVETMPS;
EXTEND(SP, 2);
DEFSV_set(upstream);
- SvREFCNT_inc_simple_void_NN(upstream);
PUSHMARK(SP);
mPUSHi(0);
if (filter_state) {
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff