o->op_targ = 0;
goto retry;
}
+ case OP_ENTERTRY:
case OP_ENTEREVAL: /* Was holding hints. */
o->op_targ = 0;
break;
case OP_LEAVETRY:
kid = cLISTOPo->op_first;
scalar(kid);
- while ((kid = kid->op_sibling)) {
- if (kid->op_sibling)
- scalarvoid(kid);
- else
+ kid = kid->op_sibling;
+ do_kids:
+ while (kid) {
+ OP *sib = kid->op_sibling;
+ if (sib && kid->op_type != OP_LEAVEWHEN) {
+ if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
+ scalar(kid);
+ scalarvoid(sib);
+ break;
+ } else
+ scalarvoid(kid);
+ } else
scalar(kid);
+ kid = sib;
}
PL_curcop = &PL_compiling;
break;
case OP_SCOPE:
case OP_LINESEQ:
case OP_LIST:
- for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
- if (kid->op_sibling)
- scalarvoid(kid);
- else
- scalar(kid);
- }
- PL_curcop = &PL_compiling;
- break;
+ kid = cLISTOPo->op_first;
+ goto do_kids;
case OP_SORT:
Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
break;
want = o->op_flags & OPf_WANT;
if ((want && want != OPf_WANT_SCALAR)
|| (PL_parser && PL_parser->error_count)
- || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE)
+ || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
{
return o;
}
case OP_LEAVETRY:
kid = cLISTOPo->op_first;
list(kid);
- while ((kid = kid->op_sibling)) {
- if (kid->op_sibling)
- scalarvoid(kid);
- else
+ kid = kid->op_sibling;
+ do_kids:
+ while (kid) {
+ OP *sib = kid->op_sibling;
+ if (sib && kid->op_type != OP_LEAVEWHEN) {
+ if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
+ list(kid);
+ scalarvoid(sib);
+ break;
+ } else
+ scalarvoid(kid);
+ } else
list(kid);
+ kid = sib;
}
PL_curcop = &PL_compiling;
break;
case OP_SCOPE:
case OP_LINESEQ:
- for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
- if (kid->op_sibling)
- scalarvoid(kid);
- else
- list(kid);
- }
- PL_curcop = &PL_compiling;
- break;
+ kid = cLISTOPo->op_first;
+ goto do_kids;
}
return o;
}
&& looks_like_bool(cLOGOPo->op_first->op_sibling));
case OP_NULL:
+ case OP_SCALAR:
return (
o->op_flags & OPf_KIDS
&& looks_like_bool(cUNOPo->op_first));
- case OP_SCALAR:
- return looks_like_bool(cUNOPo->op_first);
-
-
case OP_ENTERSUB:
case OP_NOT: case OP_XOR:
)&& !attrs) {
if (CvFLAGS(PL_compcv)) {
/* might have had built-in attrs applied */
- CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
+ if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
+ CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
}
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(PL_compcv);
&& block->op_type != OP_NULL
#endif
) {
+ cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
cv_undef(cv);
- CvFLAGS(cv) = CvFLAGS(PL_compcv);
+ CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
if (!CvWEAKOUTSIDE(cv))
SvREFCNT_dec(CvOUTSIDE(cv));
CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
PERL_ARGS_ASSERT_CK_SHIFT;
if (!(o->op_flags & OPf_KIDS)) {
- OP *argop = newUNOP(OP_RV2AV, 0,
- scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
+ OP *argop;
+
+ if (!CvUNIQUE(PL_compcv)) {
+ o->op_flags |= OPf_SPECIAL;
+ return o;
+ }
+
+ argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
#ifdef PERL_MAD
OP * const oldo = o;
o = newUNOP(type, 0, scalar(argop));
container of the rep_op var */
STATIC OP *
S_opt_scalarhv(pTHX_ OP *rep_op) {
+ dVAR;
UNOP *unop;
PERL_ARGS_ASSERT_OPT_SCALARHV;
){
OP * nop = o;
OP * lop = o;
- if (!(nop->op_flags && OPf_WANT_VOID)) {
+ if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
while (nop && nop->op_next) {
switch (nop->op_next->op_type) {
case OP_NOT:
}
}
}
- if (lop->op_flags && OPf_WANT_VOID) {
+ if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
cLOGOP->op_first = opt_scalarhv(fop);
if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
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. */
- OP *matchop = pm->op_next;
- SV *lhs;
- const bool was_tainted = PL_tainted;
- if (matchop->op_flags & OPf_STACKED)
+ if(pm->op_type == OP_MATCH) {
+ SV *lhs;
+ const bool was_tainted = PL_tainted;
+ if (pm->op_flags & OPf_STACKED)
lhs = TOPs;
- else if (matchop->op_private & OPpTARGET_MY)
- lhs = PAD_SV(matchop->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;
+ 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));
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);
{
const char *cx_label = CxLABEL(cx);
if (!cx_label || strNE(label, cx_label) ) {
- DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
+ 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;
}
}
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_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:
}
void
-Perl_die_where(pTHX_ SV *msv)
+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 (msv) {
- 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)+SvCUR(msv)-1) {
- STRLEN len;
- STRLEN msglen;
- const char* message = SvPV_const(msv, msglen);
- e = SvPV_const(err, len);
- e += len - msglen;
- if (*e != *message || strNE(e,message))
- e = NULL;
- }
- if (!e) {
- STRLEN start;
- SvGROW(err, SvCUR(err)+sizeof(prefix)+SvCUR(msv));
- sv_catpvn(err, prefix, sizeof(prefix)-1);
- sv_catsv(err, msv);
- start = SvCUR(err)-SvCUR(msv)-sizeof(prefix)+1;
- Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s",
- SvPVX_const(err)+start);
- }
- }
- else {
- STRLEN msglen;
- const char* message = SvPV_const(msv, msglen);
- sv_setpvn(ERRSV, message, msglen);
- SvFLAGS(ERRSV) |= SvFLAGS(msv) & SVf_UTF8;
- }
- }
-
while ((cxix = dopoptoeval(cxstack_ix)) < 0
&& PL_curstackinfo->si_prev)
{
if (cxix >= 0) {
I32 optype;
+ SV *namesv;
register PERL_CONTEXT *cx;
SV **newsp;
POPBLOCK(cx,PL_curpm);
if (CxTYPE(cx) != CXt_EVAL) {
STRLEN msglen;
- const char* message = SvPVx_const( msv ? msv : ERRSV, 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;
if (gimme == G_SCALAR)
*++newsp = &PL_sv_undef;
PL_curcop = cx->blk_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);
+ /* 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 */
DIE(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));
+ }
+ else {
+ sv_setsv(ERRSV, exceptsv);
+ }
assert(CxTYPE(cx) == CXt_EVAL);
+ PL_restartjmpenv = cx->blk_eval.cur_top_env;
PL_restartop = cx->blk_eval.retop;
JMPENV_JUMP(3);
/* NOTREACHED */
}
}
- write_to_stderr( msv ? msv : ERRSV );
+ write_to_stderr(exceptsv);
my_failure_exit();
/* NOTREACHED */
}
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))
{
/* don't do recursive DB::DB call */
return NORMAL;
- ENTER_with_name("sub");
+ ENTER;
SAVETMPS;
SAVEI32(PL_debug);
(void)(*CvXSUB(cv))(aTHX_ cv);
CvDEPTH(cv)--;
FREETMPS;
- LEAVE_with_name("sub");
+ LEAVE;
return NORMAL;
}
else {
SV **newsp;
PMOP *newpm;
I32 optype = 0;
+ SV *namesv;
SV *sv;
OP *retop = NULL;
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;
(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:
PUSHMARK(mark);
PUTBACK;
(void)(*CvXSUB(cv))(aTHX_ cv);
- LEAVE_with_name("sub");
+ LEAVE;
return retop;
}
else {
else
label = cPVOP->op_pv;
+ PERL_ASYNC_CHECK();
+
if (label && *label) {
OP *gotoprobe = NULL;
bool leaving_eval = FALSE;
}
}
+/*
+=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.
+*/
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? */
dVAR; dSP; /* Make POPBLOCK work. */
PERL_CONTEXT *cx;
SV **newsp;
}
+/* Run yyparse() in a setjmp wrapper. Returns:
+ * 0: yyparse() successful
+ * 1: yyparse() failed
+ * 3: yyparse() died
+ */
+STATIC int
+S_try_yyparse(pTHX)
+{
+ int ret;
+ dJMPENV;
+
+ assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
+ JMPENV_PUSH(ret);
+ switch (ret) {
+ case 0:
+ ret = yyparse() ? 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) {
+
+ /* 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) : yyparse();
+
+ 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_with_name("eval"); /* 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;
SVfARG(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(sv_2mortal(hintsv))),
SVfARG(vnormal(PL_patchlevel)));
}
}
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 (Perl_fetch_cop_label(aTHX_ PL_curcop->cop_hints_hash, 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;
+ /* Check the assumption that this removed the label. */
+ assert(Perl_fetch_cop_label(aTHX_ PL_compiling.cop_hints_hash, 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++;
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;
!(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_with_name("eval");
POPBLOCK(cx,newpm);
assert(CxTYPE(cx) == CXt_GIVEN);
- SP = newsp;
- PUTBACK;
-
- PL_curpm = newpm; /* pop $1 et al */
+ 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 */
LEAVE_with_name("given");
-
- return NORMAL;
+ RETURN;
}
/* Helper routines used by pp_smartmatch */
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_with_name("eval");
SAVETMPS;
I32 cxix;
register PERL_CONTEXT *cx;
I32 inner;
-
+ dSP;
+
cxix = dopoptogiven(cxstack_ix);
if (cxix < 0) {
if (PL_op->op_flags & OPf_SPECIAL)
if (CxFOREACH(cx))
return CX_LOOP_NEXTOP_GET(cx);
else
- return cx->blk_givwhen.leave_op;
+ /* RETURNOP calls PUTBACK which restores the old old sp */
+ RETURNOP(cx->blk_givwhen.leave_op);
}
STATIC OP *
https://perl5.git.perl.org / perl5.git / commitdiff