/* Control. */
+static char *context_name[] = {
+ "pseudo-block",
+ "subroutine",
+ "eval",
+ "loop",
+ "substitution",
+ "block",
+ "format"
+};
+
STATIC I32
S_dopoptolabel(pTHX_ char *label)
{
cx = &cxstack[i];
switch (CxTYPE(cx)) {
case CXt_SUBST:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s",
- OP_NAME(PL_op));
- break;
case CXt_SUB:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s",
- OP_NAME(PL_op));
- break;
case CXt_FORMAT:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s",
- OP_NAME(PL_op));
- break;
case CXt_EVAL:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s",
- OP_NAME(PL_op));
- break;
case CXt_NULL:
if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s",
- OP_NAME(PL_op));
- return -1;
+ Perl_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:
if (!cx->blk_loop.label ||
strNE(label, cx->blk_loop.label) ) {
cx = &cxstack[i];
switch (CxTYPE(cx)) {
case CXt_SUBST:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s",
- OP_NAME(PL_op));
- break;
case CXt_SUB:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s",
- OP_NAME(PL_op));
- break;
case CXt_FORMAT:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s",
- OP_NAME(PL_op));
- break;
case CXt_EVAL:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s",
- OP_NAME(PL_op));
- break;
case CXt_NULL:
if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s",
- OP_NAME(PL_op));
- return -1;
+ Perl_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:
DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
return i;
/* Unassume the success we assumed earlier. */
SV *nsv = cx->blk_eval.old_namesv;
(void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
- DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
+ DIE(aTHX_ "%"SVf" did not return a true value", nsv);
}
break;
case CXt_FORMAT:
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
if (kid == PL_lastgotoprobe)
continue;
- if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
- (ops == opstack ||
- (ops[-1]->op_type != OP_NEXTSTATE &&
- ops[-1]->op_type != OP_DBSTATE)))
- *ops++ = kid;
+ if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
+ if (ops == opstack)
+ *ops++ = kid;
+ else if (ops[-1]->op_type == OP_NEXTSTATE ||
+ ops[-1]->op_type == OP_DBSTATE)
+ ops[-1] = kid;
+ else
+ *ops++ = kid;
+ }
if ((o = dofindlabel(kid, label, ops, oplimit)))
return o;
}
goto retry;
tmpstr = sv_newmortal();
gv_efullname3(tmpstr, gv, Nullch);
- DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
+ DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
}
DIE(aTHX_ "Goto undefined subroutine");
}
char *tmpbuf = tbuf;
char *safestr;
int runtime;
- CV* runcv;
+ CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
ENTER;
lex_start(sv);
/* we get here either during compilation, or via pp_regcomp at runtime */
runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
if (runtime)
- runcv = find_runcv();
+ runcv = find_runcv(NULL);
PL_op = &dummy;
PL_op->op_type = OP_ENTEREVAL;
=for apidoc find_runcv
Locate the CV corresponding to the currently executing sub or eval.
+If db_seqp is non_null, skip CVs that are in the DB package and populate
+*db_seqp with the cop sequence number at the point that the DB:: code was
+entered. (allows debuggers to eval in the scope of the breakpoint rather
+than in in the scope of the debuger itself).
=cut
*/
CV*
-Perl_find_runcv(pTHX)
+Perl_find_runcv(pTHX_ U32 *db_seqp)
{
I32 ix;
PERL_SI *si;
PERL_CONTEXT *cx;
+ if (db_seqp)
+ *db_seqp = PL_curcop->cop_seq;
for (si = PL_curstackinfo; si; si = si->si_prev) {
for (ix = si->si_cxix; ix >= 0; ix--) {
cx = &(si->si_cxstack[ix]);
- if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
- return cx->blk_sub.cv;
+ if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
+ CV *cv = cx->blk_sub.cv;
+ /* skip DB:: code */
+ if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
+ *db_seqp = cx->blk_oldcop->cop_seq;
+ continue;
+ }
+ return cv;
+ }
else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
return PL_compcv;
}
STRLEN len;
OP *ret;
CV* runcv;
+ U32 seq;
if (!SvPV(sv,len))
RETPUSHUNDEF;
PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
SAVEFREESV(PL_compiling.cop_io);
}
- runcv = find_runcv();
+ /* 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
+ * scope of the code being debugged. Passing &seq gets find_runcv
+ * to do the dirty work for us */
+ runcv = find_runcv(&seq);
push_return(PL_op->op_next);
PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
if (PERLDB_LINE && PL_curstash != PL_debstash)
save_lines(CopFILEAV(&PL_compiling), PL_linestr);
PUTBACK;
- ret = doeval(gimme, NULL, runcv, PL_curcop->cop_seq);
+ ret = doeval(gimme, NULL, runcv, seq);
if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
&& ret != PL_op->op_next) { /* Successive compilation. */
strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
/* Unassume the success we assumed earlier. */
SV *nsv = cx->blk_eval.old_namesv;
(void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
- retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
+ retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
/* die_where() did LEAVE, or we won't be here */
}
else {
projects / p5sagit/p5-mst-13.2.git / blobdiff