register REGEXP *rx = cx->sb_rx;
rxres_restore(&cx->sb_rxres, rx);
- PL_reg_match_utf8 = SvUTF8(cx->sb_targ) ? 1 : 0;
+ RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
if (cx->sb_iters++) {
I32 saviters = cx->sb_iters;
sv_catpvn(dstr, s, cx->sb_strend - s);
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
- (void)SvOOK_off(targ);
- Safefree(SvPVX(targ));
+#ifdef PERL_COPY_ON_WRITE
+ if (SvIsCOW(targ)) {
+ sv_force_normal_flags(targ, SV_COW_DROP_PV);
+ } else
+#endif
+ {
+ (void)SvOOK_off(targ);
+ if (SvLEN(targ))
+ Safefree(SvPVX(targ));
+ }
SvPVX(targ) = SvPVX(dstr);
SvCUR_set(targ, SvCUR(dstr));
SvLEN_set(targ, SvLEN(dstr));
U32 i;
if (!p || p[1] < rx->nparens) {
+#ifdef PERL_COPY_ON_WRITE
+ i = 7 + rx->nparens * 2;
+#else
i = 6 + rx->nparens * 2;
+#endif
if (!p)
New(501, p, i, UV);
else
*p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
RX_MATCH_COPIED_off(rx);
+#ifdef PERL_COPY_ON_WRITE
+ *p++ = PTR2UV(rx->saved_copy);
+ rx->saved_copy = Nullsv;
+#endif
+
*p++ = rx->nparens;
*p++ = PTR2UV(rx->subbeg);
UV *p = (UV*)*rsp;
U32 i;
- if (RX_MATCH_COPIED(rx))
- Safefree(rx->subbeg);
+ RX_MATCH_COPY_FREE(rx);
RX_MATCH_COPIED_set(rx, *p);
*p++ = 0;
+#ifdef PERL_COPY_ON_WRITE
+ if (rx->saved_copy)
+ SvREFCNT_dec (rx->saved_copy);
+ rx->saved_copy = INT2PTR(SV*,*p);
+ *p++ = 0;
+#endif
+
rx->nparens = *p++;
rx->subbeg = INT2PTR(char*,*p++);
if (p) {
Safefree(INT2PTR(char*,*p));
+#ifdef PERL_COPY_ON_WRITE
+ if (p[1]) {
+ SvREFCNT_dec (INT2PTR(SV*,p[1]));
+ }
+#endif
Safefree(p);
*rsp = Null(void*);
}
/* 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;
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
FREETMPS;
- if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
+ if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
+ || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
{
dSP;
register CV *cv;
push_return(PL_op->op_next);
PUSHBLOCK(cx, CXt_SUB, SP);
- PUSHSUB(cx);
+ PUSHSUB_DB(cx);
CvDEPTH(cv)++;
(void)SvREFCNT_inc(cv);
PAD_SET_CUR(CvPADLIST(cv),1);
/* 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:
if (o->op_type == OP_LEAVE ||
o->op_type == OP_SCOPE ||
o->op_type == OP_LEAVELOOP ||
+ o->op_type == OP_LEAVESUB ||
o->op_type == OP_LEAVETRY)
{
*ops++ = cUNOPo->op_first;
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");
}
/* First do some returnish stuff. */
+ FREETMPS;
cxix = dopoptosub(cxstack_ix);
if (cxix < 0)
DIE(aTHX_ "Can't goto subroutine outside a subroutine");
if (label && *label) {
OP *gotoprobe = 0;
bool leaving_eval = FALSE;
+ bool in_block = FALSE;
PERL_CONTEXT *last_eval_cx = 0;
/* find label */
case CXt_SUBST:
continue;
case CXt_BLOCK:
- if (ix)
+ if (ix) {
gotoprobe = cx->blk_oldcop->op_sibling;
- else
+ in_block = TRUE;
+ } else
gotoprobe = PL_main_root;
break;
case CXt_SUB:
if (*enterops && enterops[1]) {
OP *oldop = PL_op;
- for (ix = 1; enterops[ix]; ix++) {
+ ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
+ for (; enterops[ix]; ix++) {
PL_op = enterops[ix];
/* Eventually we may want to stack the needed arguments
* for each op. For now, we punt on the hard ones. */
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;
}
cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
CvOUTSIDE_SEQ(PL_compcv) = seq;
- CvOUTSIDE(PL_compcv) = outside ? (CV*)SvREFCNT_inc(outside) : outside;
+ CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
/* set up a scratch pad */
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