#define tryAMAGICregexp(rx) \
STMT_START { \
+ SvGETMAGIC(rx); \
if (SvROK(rx) && SvAMAGIC(rx)) { \
SV *sv = AMG_CALLun(rx, regexp); \
if (sv) { \
sv_setpvs(tmpstr, "");
while (++MARK <= SP) {
SV *msv = *MARK;
- if (PL_amagic_generation) {
- SV *sv;
+ SV *sv;
- tryAMAGICregexp(msv);
+ tryAMAGICregexp(msv);
- if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
- (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
- {
- sv_setsv(tmpstr, sv);
- continue;
- }
+ if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
+ (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
+ {
+ sv_setsv(tmpstr, sv);
+ continue;
}
sv_catsv(tmpstr, msv);
}
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);
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 (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);
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
-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);
- 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));
+ }
+ 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 */
}
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);
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))
{
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:
else
label = cPVOP->op_pv;
+ PERL_ASYNC_CHECK();
+
if (label && *label) {
OP *gotoprobe = NULL;
bool leaving_eval = FALSE;
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;
int runtime;
CV* runcv = NULL; /* initialise to avoid compiler warnings */
STRLEN len;
+ bool need_catch;
PERL_ARGS_ASSERT_SV_COMPILE_2OP;
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);
}
+/* 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) {
+
+ CALL_BLOCK_HOOKS(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) : 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;
}
}
- /* 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_with_name("load_feature");
- Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
- LEAVE_with_name("load_feature");
- }
- /* If a version >= 5.11.0 is requested, strictures are on by default! */
- if (PL_compcv &&
- vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
- PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
+ /* We do this only with "use", not "require" or "no". */
+ if (PL_compcv && !(cUNOP->op_first->op_private & OPpCONST_NOVER)) {
+ /* If we request a version >= 5.9.5, load feature.pm with the
+ * feature bundle that corresponds to the required version. */
+ if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
+ SV *const importsv = vnormal(sv);
+ *SvPVX_mutable(importsv) = ':';
+ ENTER_with_name("load_feature");
+ Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
+ LEAVE_with_name("load_feature");
+ }
+ /* If a version >= 5.11.0 is requested, strictures are on by default! */
+ if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
+ PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
+ }
}
RETPUSHYES;
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 = SvPV_nolen_const(*svp);
-
if (count > 0) {
int i = 0;
SV *arg;
FREETMPS;
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;
break;
}
}
}
- SAVECOPFILE_FREE(&PL_compiling);
- CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
+ if (tryrsfp) {
+ SAVECOPFILE_FREE(&PL_compiling);
+ CopFILE_set(&PL_compiling, tryname);
+ }
SvREFCNT_dec(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;
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");
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 */
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 * tmpsv;
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)) {
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 / blobdiff