/* 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;
cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
dPOPss;
+ /* See comment in pp_flop() */
if (SvNIOKp(sv) || !SvPOKp(sv) ||
SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
(looks_like_number(sv) && *SvPVX(sv) != '0' &&
- looks_like_number((SV*)cx->blk_loop.iterary) &&
- *SvPVX(cx->blk_loop.iterary) != '0'))
+ looks_like_number((SV*)cx->blk_loop.iterary)))
{
if (SvNV(sv) < IV_MIN ||
SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
/* 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 tbuf[TYPE_DIGITS(long) + 12 + 10];
char *tmpbuf = tbuf;
char *safestr;
+ int runtime;
+ CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
ENTER;
lex_start(sv);
#endif
PL_hints &= HINT_UTF8;
+ /* 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(NULL);
+
PL_op = &dummy;
PL_op->op_type = OP_ENTEREVAL;
PL_op->op_flags = 0; /* Avoid uninit warning. */
PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
PUSHEVAL(cx, 0, Nullgv);
- rop = doeval(G_SCALAR, startop);
+
+ if (runtime)
+ rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
+ else
+ rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
POPBLOCK(cx,PL_curpm);
POPEVAL(cx);
return rop;
}
+
+/*
+=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_ 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) {
+ 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;
+ }
+ }
+ return PL_main_cv;
+}
+
+
+/* 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.
+ * outside is the lexically enclosing CV (if any) that invoked us.
+ */
+
/* With USE_5005THREADS, eval_owner must be held on entry to doeval */
STATIC OP *
-S_doeval(pTHX_ int gimme, OP** startop)
+S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
{
dSP;
OP *saveop = PL_op;
- CV *caller;
- I32 i;
PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
PUSHMARK(SP);
- caller = PL_compcv;
- for (i = cxstack_ix - 1; i >= 0; i--) {
- PERL_CONTEXT *cx = &cxstack[i];
- if (CxTYPE(cx) == CXt_EVAL)
- break;
- else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
- caller = cx->blk_sub.cv;
- break;
- }
- }
-
SAVESPTR(PL_compcv);
PL_compcv = (CV*)NEWSV(1104,0);
sv_upgrade((SV *)PL_compcv, SVt_PVCV);
assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
+ CvOUTSIDE_SEQ(PL_compcv) = seq;
+ CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
+
/* set up a scratch pad */
CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
- if (!saveop ||
- (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
- {
- CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
- }
SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
Perl_croak(aTHX_ "%sCompilation failed in regexp",
(*msg ? msg : "Unknown error\n"));
}
+ else {
+ char* msg = SvPVx(ERRSV, n_a);
+ if (!*msg) {
+ sv_setpv(ERRSV, "Compilation error");
+ }
+ }
RETPUSHUNDEF;
}
CopLINE_set(&PL_compiling, 0);
if (startop) {
*startop = PL_eval_root;
- SvREFCNT_dec(CvOUTSIDE(PL_compcv));
- CvOUTSIDE(PL_compcv) = Nullcv;
} else
SAVEFREEOP(PL_eval_root);
if (gimme & G_VOID)
encoding = PL_encoding;
PL_encoding = Nullsv;
- op = DOCATCH(doeval(gimme, NULL));
+ op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
/* Restore encoding. */
PL_encoding = encoding;
char *safestr;
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);
}
+ /* 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);
+ 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