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);
}
oldsave = PL_scopestack[PL_scopestack_ix - 1];
LEAVE_SCOPE(oldsave);
+ /* A destructor called during LEAVE_SCOPE could have undefined
+ * our precious cv. See bug #99850. */
+ if (!CvROOT(cv) && !CvXSUB(cv)) {
+ const GV * const gv = CvGV(cv);
+ if (gv) {
+ SV * const tmpstr = sv_newmortal();
+ gv_efullname3(tmpstr, gv, NULL);
+ DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
+ SVfARG(tmpstr));
+ }
+ DIE(aTHX_ "Goto undefined subroutine");
+ }
+
/* Now do some callish stuff. */
SAVETMPS;
SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
CATCH_SET(TRUE);
if (runtime)
- (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
+ (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq, NULL);
else
- (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
+ (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax, NULL);
CATCH_SET(need_catch);
POPBLOCK(cx,PL_curpm);
POPEVAL(cx);
return cv;
}
else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
- return PL_compcv;
+ return cx->blk_eval.cv;
}
}
return PL_main_cv;
* 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
+ */
+
STATIC bool
-S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
+S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh)
{
dVAR; dSP;
OP * const saveop = PL_op;
+ COP * const oldcurcop = PL_curcop;
bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
int yystatus;
+ CV *evalcv;
PL_in_eval = (in_require
? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
PUSHMARK(SP);
- SAVESPTR(PL_compcv);
- PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
- CvEVAL_on(PL_compcv);
+ evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
+ CvEVAL_on(evalcv);
assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
- cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
+ cxstack[cxstack_ix].blk_eval.cv = evalcv;
cxstack[cxstack_ix].blk_gimme = gimme;
- CvOUTSIDE_SEQ(PL_compcv) = seq;
- CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
+ CvOUTSIDE_SEQ(evalcv) = seq;
+ CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
/* set up a scratch pad */
- CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
+ CvPADLIST(evalcv) = pad_new(padnew_SAVE);
PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
if (!PL_madskills)
- SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
+ SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
/* make sure we compile in the right package */
PL_madskills = 0;
#endif
+ if (!startop) ENTER_with_name("evalcomp");
+ SAVESPTR(PL_compcv);
+ PL_compcv = evalcv;
+
/* try to compile it */
PL_eval_root = NULL;
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 ;
+ }
+ 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);
/* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
POPEVAL(cx);
namesv = cx->blk_eval.old_namesv;
}
- }
- if (yystatus != 3)
+ /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
+ }
if (in_require) {
if (!cx) {
sv_setpvs(ERRSV, "Compilation error");
}
}
- PUSHs(&PL_sv_undef);
+ if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
PUTBACK;
return FALSE;
}
+ else if (!startop) LEAVE_with_name("evalcomp");
CopLINE_set(&PL_compiling, 0);
if (startop) {
*startop = PL_eval_root;
/* compiled okay, so do it */
- CvDEPTH(PL_compcv) = 1;
+ CvDEPTH(evalcv) = 1;
SP = PL_stack_base + POPMARK; /* pop original mark */
PL_op = saveop; /* The caller may need it. */
PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
CopFILE_set(&PL_compiling, tryname);
lex_start(NULL, tryrsfp, 0);
- SAVEHINTS();
- PL_hints = 0;
- hv_clear(GvHV(PL_hintgv));
-
- SAVECOMPILEWARNINGS();
- 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 ;
-
if (filter_sub || filter_cache) {
/* 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
encoding = PL_encoding;
PL_encoding = NULL;
- if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
+ if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq, NULL))
op = DOCATCH(PL_eval_start);
else
op = PL_op->op_next;
SvPVbyte_force(sv, len);
}
else if (bytes && SvUTF8(sv)) {
- /* Don’t modify someone else’s scalar */
+ /* Don't modify someone else's scalar */
STRLEN len;
sv = newSVsv(sv);
(void)sv_2mortal(sv);
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 */
- SAVEHINTS();
- PL_hints = PL_op->op_private & OPpEVAL_COPHH
- ? PL_curcop->cop_hints : PL_op->op_targ;
- if (saved_hh) {
- /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
- SvREFCNT_dec(GvHV(PL_hintgv));
- GvHV(PL_hintgv) = saved_hh;
- }
- SAVECOMPILEWARNINGS();
- PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
- cophh_free(CopHINTHASH_get(&PL_compiling));
- if (Perl_cop_fetch_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_cop_fetch_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 {
+ /* 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 */
char *const safestr = savepvn(tmpbuf, len);
SAVEDELETE(PL_defstash, safestr, len);
saved_delete = TRUE;
PUTBACK;
- if (doeval(gimme, NULL, runcv, seq)) {
+ if (doeval(gimme, NULL, runcv, seq, saved_hh)) {
if (was != PL_breakable_sub_gen /* Some subs defined here. */
? (PERLDB_LINE || PERLDB_SAVESRC)
: PERLDB_SAVESRC_NOSUBS) {
const U8 save_flags = PL_op -> op_flags;
I32 optype;
SV *namesv;
+ CV *evalcv;
PERL_ASYNC_CHECK();
POPBLOCK(cx,newpm);
POPEVAL(cx);
namesv = cx->blk_eval.old_namesv;
retop = cx->blk_eval.retop;
+ evalcv = cx->blk_eval.cv;
TAINT_NOT;
SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
PL_curpm = newpm; /* Don't pop $1 et al till now */
#ifdef DEBUGGING
- assert(CvDEPTH(PL_compcv) == 1);
+ assert(CvDEPTH(evalcv) == 1);
#endif
- CvDEPTH(PL_compcv) = 0;
+ CvDEPTH(evalcv) = 0;
if (optype == OP_REQUIRE &&
!(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
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);