X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=0eac63ef5906cbf52ce760844361883b3798e49d;hb=2dfd8427393aecf9e4f0fdf1f999b249b467815c;hp=4ba11712f1993b40d42eb7e1a1e2613da8f9cc62;hpb=d7aa53827cc12fdf8a697328df844e16aaa58287;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index 4ba1171..0eac63e 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1,7 +1,7 @@ /* pp_ctl.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -82,14 +82,41 @@ PP(pp_regcomp) SV *tmpstr; STRLEN len; MAGIC *mg = Null(MAGIC*); - - tmpstr = POPs; /* prevent recompiling under /o and ithreads. */ #if defined(USE_ITHREADS) - if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) - RETURN; + if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) { + if (PL_op->op_flags & OPf_STACKED) { + dMARK; + SP = MARK; + } + else + (void)POPs; + RETURN; + } #endif + if (PL_op->op_flags & OPf_STACKED) { + /* multiple args; concatentate them */ + dMARK; dORIGMARK; + tmpstr = PAD_SV(ARGTARG); + sv_setpvn(tmpstr, "", 0); + while (++MARK <= SP) { + if (PL_amagic_generation) { + SV *sv; + if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) && + (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign))) + { + sv_setsv(tmpstr, sv); + continue; + } + } + sv_catsv(tmpstr, *MARK); + } + SvSETMAGIC(tmpstr); + SP = ORIGMARK; + } + else + tmpstr = POPs; if (SvROK(tmpstr)) { SV *sv = SvRV(tmpstr); @@ -172,7 +199,7 @@ PP(pp_substcont) SV *nsv = Nullsv; REGEXP *old = PM_GETRE(pm); if(old != rx) { - if(old) + if(old) ReREFCNT_dec(old); PM_SETRE(pm,rx); } @@ -181,7 +208,7 @@ PP(pp_substcont) RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ)); if (cx->sb_iters++) { - I32 saviters = cx->sb_iters; + const I32 saviters = cx->sb_iters; if (cx->sb_iters > cx->sb_maxiters) DIE(aTHX_ "Substitution loop"); @@ -213,16 +240,14 @@ PP(pp_substcont) } else #endif { - (void)SvOOK_off(targ); - if (SvLEN(targ)) - Safefree(SvPVX(targ)); + SvPV_free(targ); } - SvPVX(targ) = SvPVX(dstr); + SvPV_set(targ, SvPVX(dstr)); SvCUR_set(targ, SvCUR(dstr)); SvLEN_set(targ, SvLEN(dstr)); if (DO_UTF8(dstr)) SvUTF8_on(targ); - SvPVX(dstr) = 0; + SvPV_set(dstr, (char*)0); sv_free(dstr); TAINT_IF(cx->sb_rxtainted & 1); @@ -249,7 +274,7 @@ PP(pp_substcont) } cx->sb_m = m = rx->startp[0] + orig; if (m > s) { - if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ)) + if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ)) sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv); else sv_catpvn(dstr, s, m-s); @@ -379,12 +404,13 @@ PP(pp_formline) NV value; bool gotsome = FALSE; STRLEN len; - STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1; + STRLEN fudge = SvPOK(tmpForm) + ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0; bool item_is_utf8 = FALSE; bool targ_is_utf8 = FALSE; SV * nsv = Nullsv; OP * parseres = 0; - char *fmt; + const char *fmt; bool oneline; if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { @@ -411,7 +437,7 @@ PP(pp_formline) for (;;) { DEBUG_f( { - char *name = "???"; + const char *name = "???"; arg = -1; switch (*fpc) { case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break; @@ -431,7 +457,7 @@ PP(pp_formline) case FF_MORE: name = "MORE"; break; case FF_LINEMARK: name = "LINEMARK"; break; case FF_END: name = "END"; break; - case FF_0DECIMAL: name = "0DECIMAL"; break; + case FF_0DECIMAL: name = "0DECIMAL"; break; case FF_LINESNGL: name = "LINESNGL"; break; } if (arg >= 0) @@ -449,14 +475,14 @@ PP(pp_formline) case FF_LITERAL: arg = *fpc++; if (targ_is_utf8 && !SvUTF8(tmpForm)) { - SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); + SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); *t = '\0'; sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv); t = SvEND(PL_formtarget); break; } if (!targ_is_utf8 && DO_UTF8(tmpForm)) { - SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); + SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); *t = '\0'; sv_utf8_upgrade(PL_formtarget); SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); @@ -632,7 +658,7 @@ PP(pp_formline) s = item; if (item_is_utf8) { if (!targ_is_utf8) { - SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); + SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); *t = '\0'; sv_utf8_upgrade(PL_formtarget); SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); @@ -665,7 +691,7 @@ PP(pp_formline) break; } if (targ_is_utf8 && !item_is_utf8) { - SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); + SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); *t = '\0'; sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv); for (; t < SvEND(PL_formtarget); t++) { @@ -710,7 +736,7 @@ PP(pp_formline) item = s = SvPV(sv, len); itemsize = len; if ((item_is_utf8 = DO_UTF8(sv))) - itemsize = sv_len_utf8(sv); + itemsize = sv_len_utf8(sv); if (itemsize) { bool chopped = FALSE; gotsome = TRUE; @@ -731,7 +757,7 @@ PP(pp_formline) } } } - SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); + SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); if (targ_is_utf8) SvUTF8_on(PL_formtarget); if (oneline) { @@ -776,7 +802,7 @@ PP(pp_formline) gotsome = TRUE; value = SvNV(sv); /* overflow evidence */ - if (num_overflow(value, fieldsize, arg)) { + if (num_overflow(value, fieldsize, arg)) { arg = fieldsize; while (arg--) *t++ = '#'; @@ -803,7 +829,7 @@ PP(pp_formline) if (gotsome) { if (arg) { /* repeat until fields exhausted? */ *t = '\0'; - SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); + SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); lines += FmLINES(PL_formtarget); if (lines == 200) { arg = t - linemark; @@ -839,7 +865,7 @@ PP(pp_formline) } s = t - 3; if (strnEQ(s," ",3)) { - while (s > SvPVX(PL_formtarget) && isSPACE(s[-1])) + while (s > SvPVX_const(PL_formtarget) && isSPACE(s[-1])) s--; } *s++ = '.'; @@ -850,7 +876,7 @@ PP(pp_formline) case FF_END: *t = '\0'; - SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); + SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); if (targ_is_utf8) SvUTF8_on(PL_formtarget); FmLINES(PL_formtarget) += lines; @@ -862,7 +888,7 @@ PP(pp_formline) PP(pp_grepstart) { - dSP; + dVAR; dSP; SV *src; if (PL_stack_base + *PL_markstack_ptr == SP) { @@ -904,8 +930,8 @@ PP(pp_mapstart) PP(pp_mapwhile) { - dSP; - I32 gimme = GIMME_V; + dVAR; dSP; + const I32 gimme = GIMME_V; I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */ I32 count; I32 shift; @@ -942,7 +968,7 @@ PP(pp_mapwhile) * irrelevant. --jhi */ if (shift < count) shift = count; /* Avoid shifting too often --Ben Tilly */ - + EXTEND(SP,shift); src = SP; dst = (SP += shift); @@ -957,7 +983,7 @@ PP(pp_mapwhile) while (items-- > 0) *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); } - else { + else { /* scalar context: we don't care about which values map returns * (we use undef here). And so we certainly don't want to do mortal * copies of meaningless values. */ @@ -1033,9 +1059,9 @@ PP(pp_flip) else { dTOPss; SV *targ = PAD_SV(PL_op->op_targ); - int flip = 0; + int flip = 0; - if (PL_op->op_private & OPpFLIP_LINENUM) { + if (PL_op->op_private & OPpFLIP_LINENUM) { if (GvIO(PL_last_in_gv)) { flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); } @@ -1043,10 +1069,10 @@ PP(pp_flip) GV *gv = gv_fetchpv(".", TRUE, SVt_PV); if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv)); } - } else { - flip = SvTRUE(sv); - } - if (flip) { + } else { + flip = SvTRUE(sv); + } + if (flip) { sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1); if (PL_op->op_flags & OPf_SPECIAL) { sv_setiv(targ, 1); @@ -1059,7 +1085,7 @@ PP(pp_flip) RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); } } - sv_setpv(TARG, ""); + sv_setpvn(TARG, "", 0); SETs(targ); RETURN; } @@ -1073,7 +1099,7 @@ PP(pp_flip) SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \ SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \ (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \ - looks_like_number(left)) && SvPOKp(left) && *SvPVX(left) != '0')) \ + looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \ && (!SvOK(right) || looks_like_number(right)))) PP(pp_flop) @@ -1112,13 +1138,13 @@ PP(pp_flop) else { SV *final = sv_mortalcopy(right); STRLEN len, n_a; - char *tmps = SvPV(final, len); + const char *tmps = SvPV(final, len); sv = sv_mortalcopy(left); SvPV_force(sv,n_a); while (!SvNIOKp(sv) && SvCUR(sv) <= len) { XPUSHs(sv); - if (strEQ(SvPVX(sv),tmps)) + if (strEQ(SvPVX_const(sv),tmps)) break; sv = sv_2mortal(newSVsv(sv)); sv_inc(sv); @@ -1156,7 +1182,7 @@ PP(pp_flop) /* Control. */ -static char *context_name[] = { +static const char * const context_name[] = { "pseudo-block", "subroutine", "eval", @@ -1167,13 +1193,12 @@ static char *context_name[] = { }; STATIC I32 -S_dopoptolabel(pTHX_ char *label) +S_dopoptolabel(pTHX_ const char *label) { register I32 i; - register PERL_CONTEXT *cx; for (i = cxstack_ix; i >= 0; i--) { - cx = &cxstack[i]; + register const PERL_CONTEXT *cx = &cxstack[i]; switch (CxTYPE(cx)) { case CXt_SUBST: case CXt_SUB: @@ -1203,16 +1228,14 @@ S_dopoptolabel(pTHX_ char *label) I32 Perl_dowantarray(pTHX) { - I32 gimme = block_gimme(); + const I32 gimme = block_gimme(); return (gimme == G_VOID) ? G_SCALAR : gimme; } I32 Perl_block_gimme(pTHX) { - I32 cxix; - - cxix = dopoptosub(cxstack_ix); + const I32 cxix = dopoptosub(cxstack_ix); if (cxix < 0) return G_VOID; @@ -1233,9 +1256,7 @@ Perl_block_gimme(pTHX) I32 Perl_is_lvalue_sub(pTHX) { - I32 cxix; - - cxix = dopoptosub(cxstack_ix); + const I32 cxix = dopoptosub(cxstack_ix); assert(cxix >= 0); /* We should only be called from inside subs */ if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv)) @@ -1254,9 +1275,8 @@ STATIC I32 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock) { I32 i; - register PERL_CONTEXT *cx; for (i = startingblock; i >= 0; i--) { - cx = &cxstk[i]; + register const PERL_CONTEXT *cx = &cxstk[i]; switch (CxTYPE(cx)) { default: continue; @@ -1274,9 +1294,8 @@ STATIC I32 S_dopoptoeval(pTHX_ I32 startingblock) { I32 i; - register PERL_CONTEXT *cx; for (i = startingblock; i >= 0; i--) { - cx = &cxstack[i]; + register const PERL_CONTEXT *cx = &cxstack[i]; switch (CxTYPE(cx)) { default: continue; @@ -1292,9 +1311,8 @@ STATIC I32 S_dopoptoloop(pTHX_ I32 startingblock) { I32 i; - register PERL_CONTEXT *cx; for (i = startingblock; i >= 0; i--) { - cx = &cxstack[i]; + register const PERL_CONTEXT *cx = &cxstack[i]; switch (CxTYPE(cx)) { case CXt_SUBST: case CXt_SUB: @@ -1318,12 +1336,11 @@ S_dopoptoloop(pTHX_ I32 startingblock) void Perl_dounwind(pTHX_ I32 cxix) { - register PERL_CONTEXT *cx; I32 optype; while (cxstack_ix > cxix) { SV *sv; - cx = &cxstack[cxstack_ix]; + register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", (long) cxstack_ix, PL_block_type[CxTYPE(cx)])); /* Note: we don't need to restore the base context info till the end. */ @@ -1364,23 +1381,23 @@ Perl_qerror(pTHX_ SV *err) } OP * -Perl_die_where(pTHX_ char *message, STRLEN msglen) +Perl_die_where(pTHX_ const char *message, STRLEN msglen) { + dVAR; STRLEN n_a; if (PL_in_eval) { I32 cxix; - register PERL_CONTEXT *cx; I32 gimme; SV **newsp; if (message) { if (PL_in_eval & EVAL_KEEPERR) { - static char prefix[] = "\t(in cleanup) "; + static const char prefix[] = "\t(in cleanup) "; SV *err = ERRSV; - char *e = Nullch; + const char *e = Nullch; if (!SvPOK(err)) - sv_setpv(err,""); + sv_setpvn(err,"",0); else if (SvCUR(err) >= sizeof(prefix)+msglen-1) { e = SvPV(err, n_a); e += n_a - msglen; @@ -1393,7 +1410,7 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) sv_catpvn(err, message, msglen); if (ckWARN(WARN_MISC)) { STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1; - Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start); + Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start); } } } @@ -1411,6 +1428,7 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) if (cxix >= 0) { I32 optype; + register PERL_CONTEXT *cx; if (cxix < cxstack_ix) dounwind(cxix); @@ -1438,9 +1456,9 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) PL_curcop = cx->blk_oldcop; if (optype == OP_REQUIRE) { - char* msg = SvPVx(ERRSV, n_a); - SV *nsv = cx->blk_eval.old_namesv; - (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), + const char* msg = SvPVx(ERRSV, n_a); + SV *nsv = cx->blk_eval.old_namesv; + (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), &PL_sv_undef, 0); DIE(aTHX_ "%sCompilation failed in require", *msg ? msg : "Unknown error\n"); @@ -1525,10 +1543,8 @@ PP(pp_caller) register PERL_CONTEXT *cx; register PERL_CONTEXT *ccstack = cxstack; PERL_SI *top_si = PL_curstackinfo; - I32 dbcxix; I32 gimme; - char *stashname; - SV *sv; + const char *stashname; I32 count = 0; if (MAXARG) @@ -1548,7 +1564,8 @@ PP(pp_caller) } RETURN; } - if (PL_DBsub && cxix >= 0 && + /* caller() should not report the automatic calls to &DB::sub */ + if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) count++; if (!count--) @@ -1558,10 +1575,11 @@ PP(pp_caller) cx = &ccstack[cxix]; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { - dbcxix = dopoptosub_at(ccstack, cxix - 1); + const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1); /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the field below is defined for any cx. */ - if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) + /* caller() should not report the automatic calls to &DB::sub */ + if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) cx = &ccstack[dbcxix]; } @@ -1592,7 +1610,7 @@ PP(pp_caller) GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv); /* So is ccstack[dbcxix]. */ if (isGV(cvgv)) { - sv = NEWSV(49, 0); + SV * const sv = NEWSV(49, 0); gv_efullname3(sv, cvgv, Nullch); PUSHs(sv_2mortal(sv)); PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); @@ -1636,7 +1654,7 @@ PP(pp_caller) && CopSTASH_eq(PL_curcop, PL_debstash)) { AV *ary = cx->blk_sub.argarray; - int off = AvARRAY(ary) - AvALLOC(ary); + const int off = AvARRAY(ary) - AvALLOC(ary); if (!PL_dbargs) { GV* tmpgv; @@ -1686,7 +1704,7 @@ PP(pp_caller) PP(pp_reset) { dSP; - char *tmps; + const char *tmps; STRLEN n_a; if (MAXARG < 1) @@ -1707,6 +1725,7 @@ PP(pp_lineseq) PP(pp_dbstate) { + dVAR; PL_curcop = (COP*)PL_op; TAINT_NOT; /* Each statement is presumed innocent */ PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; @@ -1718,7 +1737,7 @@ PP(pp_dbstate) dSP; register CV *cv; register PERL_CONTEXT *cx; - I32 gimme = G_ARRAY; + const I32 gimme = G_ARRAY; U8 hasargs; GV *gv; @@ -1758,9 +1777,9 @@ PP(pp_scope) PP(pp_enteriter) { - dSP; dMARK; + dVAR; dSP; dMARK; register PERL_CONTEXT *cx; - I32 gimme = GIMME_V; + const I32 gimme = GIMME_V; SV **svp; U32 cxtype = CXt_LOOP; #ifdef USE_ITHREADS @@ -1845,9 +1864,9 @@ PP(pp_enteriter) PP(pp_enterloop) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; - I32 gimme = GIMME_V; + const I32 gimme = GIMME_V; ENTER; SAVETMPS; @@ -1861,7 +1880,7 @@ PP(pp_enterloop) PP(pp_leaveloop) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; I32 gimme; SV **newsp; @@ -1869,6 +1888,7 @@ PP(pp_leaveloop) SV **mark; POPBLOCK(cx,newpm); + assert(CxTYPE(cx) == CXt_LOOP); mark = newsp; newsp = PL_stack_base + cx->blk_loop.resetsp; @@ -1901,7 +1921,7 @@ PP(pp_leaveloop) PP(pp_return) { - dSP; dMARK; + dVAR; dSP; dMARK; I32 cxix; register PERL_CONTEXT *cx; bool popsub2 = FALSE; @@ -1951,7 +1971,7 @@ PP(pp_return) { /* 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); + (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD); DIE(aTHX_ "%"SVf" did not return a true value", nsv); } break; @@ -2010,13 +2030,13 @@ PP(pp_return) LEAVESUB(sv); if (clear_errsv) - sv_setpv(ERRSV,""); + sv_setpvn(ERRSV,"",0); return retop; } PP(pp_last) { - dSP; + dVAR; dSP; I32 cxix; register PERL_CONTEXT *cx; I32 pop2 = 0; @@ -2104,6 +2124,7 @@ PP(pp_last) PP(pp_next) { + dVAR; I32 cxix; register PERL_CONTEXT *cx; I32 inner; @@ -2127,14 +2148,17 @@ PP(pp_next) TOPBLOCK(cx); if (PL_scopestack_ix < inner) leave_scope(PL_scopestack[PL_scopestack_ix]); + PL_curcop = cx->blk_oldcop; return cx->blk_loop.next_op; } PP(pp_redo) { + dVAR; I32 cxix; register PERL_CONTEXT *cx; I32 oldsave; + OP* redo_op; if (PL_op->op_flags & OPf_SPECIAL) { cxix = dopoptoloop(cxstack_ix); @@ -2149,19 +2173,28 @@ PP(pp_redo) if (cxix < cxstack_ix) dounwind(cxix); + redo_op = cxstack[cxix].blk_loop.redo_op; + if (redo_op->op_type == OP_ENTER) { + /* pop one less context to avoid $x being freed in while (my $x..) */ + cxstack_ix++; + assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK); + redo_op = redo_op->op_next; + } + TOPBLOCK(cx); oldsave = PL_scopestack[PL_scopestack_ix - 1]; LEAVE_SCOPE(oldsave); FREETMPS; - return cx->blk_loop.redo_op; + PL_curcop = cx->blk_oldcop; + return redo_op; } STATIC OP * -S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit) +S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) { OP *kid = Nullop; OP **ops = opstack; - static char too_deep[] = "Target of goto is too deeply nested"; + static const char too_deep[] = "Target of goto is too deeply nested"; if (ops >= oplimit) Perl_croak(aTHX_ too_deep); @@ -2211,18 +2244,16 @@ PP(pp_dump) PP(pp_goto) { - dSP; + dVAR; dSP; OP *retop = 0; I32 ix; register PERL_CONTEXT *cx; #define GOTO_DEPTH 64 OP *enterops[GOTO_DEPTH]; - char *label; - int do_dump = (PL_op->op_type == OP_DUMP); - static char must_have_label[] = "goto must have label"; - AV *oldav = Nullav; + const char *label = 0; + const bool do_dump = (PL_op->op_type == OP_DUMP); + static const char must_have_label[] = "goto must have label"; - label = 0; if (PL_op->op_flags & OPf_STACKED) { SV *sv = POPs; STRLEN n_a; @@ -2235,12 +2266,13 @@ PP(pp_goto) SV** mark; I32 items = 0; I32 oldsave; + bool reified = 0; retry: if (!CvROOT(cv) && !CvXSUB(cv)) { - GV *gv = CvGV(cv); - GV *autogv; + const GV * const gv = CvGV(cv); if (gv) { + GV *autogv; SV *tmpstr; /* autoloaded stub? */ if (cv != GvCV(gv) && (cv = GvCV(gv))) @@ -2257,7 +2289,7 @@ PP(pp_goto) } /* First do some returnish stuff. */ - SvREFCNT_inc(cv); /* avoid premature free during unwind */ + (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */ FREETMPS; cxix = dopoptosub(cxstack_ix); if (cxix < 0) @@ -2265,40 +2297,42 @@ PP(pp_goto) if (cxix < cxstack_ix) dounwind(cxix); TOPBLOCK(cx); - if (CxREALEVAL(cx)) - DIE(aTHX_ "Can't goto subroutine from an eval-string"); - mark = PL_stack_sp; + SPAGAIN; + if (CxTYPE(cx) == CXt_EVAL) { + if (CxREALEVAL(cx)) + DIE(aTHX_ "Can't goto subroutine from an eval-string"); + else + DIE(aTHX_ "Can't goto subroutine from an eval-block"); + } if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) { /* put @_ back onto stack */ AV* av = cx->blk_sub.argarray; - + items = AvFILLp(av) + 1; - PL_stack_sp++; - EXTEND(PL_stack_sp, items); /* @_ could have been extended. */ - Copy(AvARRAY(av), PL_stack_sp, items, SV*); - PL_stack_sp += items; + EXTEND(SP, items+1); /* @_ could have been extended. */ + Copy(AvARRAY(av), SP + 1, items, SV*); SvREFCNT_dec(GvAV(PL_defgv)); GvAV(PL_defgv) = cx->blk_sub.savearray; + CLEAR_ARGARRAY(av); /* abandon @_ if it got reified */ if (AvREAL(av)) { - oldav = av; /* delay until return */ + reified = 1; + SvREFCNT_dec(av); av = newAV(); av_extend(av, items-1); - AvFLAGS(av) = AVf_REIFY; + AvREIFY_only(av); PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av); } - else - CLEAR_ARGARRAY(av); } else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */ AV* av; av = GvAV(PL_defgv); items = AvFILLp(av) + 1; - PL_stack_sp++; - EXTEND(PL_stack_sp, items); /* @_ could have been extended. */ - Copy(AvARRAY(av), PL_stack_sp, items, SV*); - PL_stack_sp += items; + EXTEND(SP, items+1); /* @_ could have been extended. */ + Copy(AvARRAY(av), SP + 1, items, SV*); } + mark = SP; + SP += items; if (CxTYPE(cx) == CXt_SUB && !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) SvREFCNT_dec(cx->blk_sub.cv); @@ -2307,11 +2341,14 @@ PP(pp_goto) /* Now do some callish stuff. */ SAVETMPS; - /* For reified @_, delay freeing till return from new sub */ - if (oldav) - SAVEFREESV((SV*)oldav); SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ if (CvXSUB(cv)) { + OP* retop = cx->blk_sub.retop; + if (reified) { + I32 index; + for (index=0; indexblk_sub.retop; + return retop; } else { AV* padlist = CvPADLIST(cv); @@ -2360,7 +2395,7 @@ PP(pp_goto) else { if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)) sub_crush_depth(cv); - pad_push(padlist, CvDEPTH(cv), 1); + pad_push(padlist, CvDEPTH(cv)); } PAD_SET_CUR(padlist, CvDEPTH(cv)); if (cx->blk_sub.hasargs) @@ -2372,24 +2407,29 @@ PP(pp_goto) GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); CX_CURPAD_SAVE(cx->blk_sub); cx->blk_sub.argarray = av; - ++mark; if (items >= AvMAX(av) + 1) { ary = AvALLOC(av); if (AvARRAY(av) != ary) { AvMAX(av) += AvARRAY(av) - AvALLOC(av); - SvPVX(av) = (char*)ary; + SvPV_set(av, (char*)ary); } if (items >= AvMAX(av) + 1) { AvMAX(av) = items - 1; Renew(ary,items+1,SV*); AvALLOC(av) = ary; - SvPVX(av) = (char*)ary; + SvPV_set(av, (char*)ary); } } + ++mark; Copy(mark,AvARRAY(av),items,SV*); AvFILLp(av) = items - 1; assert(!AvREAL(av)); + if (reified) { + /* transfer 'ownership' of refcnts to new @_ */ + AvREAL_on(av); + AvREIFY_off(av); + } while (items--) { if (*mark) SvTEMP_off(*mark); @@ -2403,14 +2443,15 @@ PP(pp_goto) */ SV *sv = GvSV(PL_DBsub); CV *gotocv; - + + save_item(sv); if (PERLDB_SUB_NN) { - (void)SvUPGRADE(sv, SVt_PVIV); + int type = SvTYPE(sv); + if (type < SVt_PVIV && type != SVt_IV) + sv_upgrade(sv, SVt_PVIV); (void)SvIOK_on(sv); - SAVEIV(SvIVX(sv)); - SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */ + SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */ } else { - save_item(sv); gv_efullname3(sv, CvGV(cv), Nullch); } if ( PERLDB_GOTO @@ -2579,7 +2620,7 @@ PP(pp_exit) PP(pp_nswitch) { dSP; - NV value = SvNVx(GvSV(cCOP->cop_gv)); + const NV value = SvNVx(GvSV(cCOP->cop_gv)); register I32 match = I_32(value); if (value < 0.0) { @@ -2621,12 +2662,12 @@ PP(pp_cswitch) STATIC void S_save_lines(pTHX_ AV *array, SV *sv) { - register char *s = SvPVX(sv); - register char *send = SvPVX(sv) + SvCUR(sv); - register char *t; + register const char *s = SvPVX_const(sv); + register const char *send = SvPVX_const(sv) + SvCUR(sv); register I32 line = 1; while (s && s < send) { + const char *t; SV *tmpstr = NEWSV(85,0); sv_upgrade(tmpstr, SVt_PVMG); @@ -2642,14 +2683,6 @@ S_save_lines(pTHX_ AV *array, SV *sv) } } -#ifdef PERL_FLEXIBLE_EXCEPTIONS -STATIC void * -S_docatch_body(pTHX_ va_list args) -{ - return docatch_body(); -} -#endif - STATIC void * S_docatch_body(pTHX) { @@ -2661,9 +2694,7 @@ STATIC OP * S_docatch(pTHX_ OP *o) { int ret; - OP *oldop = PL_op; - OP *retop; - volatile PERL_SI *cursi = PL_curstackinfo; + OP * const oldop = PL_op; dJMPENV; #ifdef DEBUGGING @@ -2671,39 +2702,32 @@ S_docatch(pTHX_ OP *o) #endif PL_op = o; - /* Normally, the leavetry at the end of this block of ops will - * pop an op off the return stack and continue there. By setting - * the op to Nullop, we force an exit from the inner runops() - * loop. DAPM. - */ - assert(cxstack_ix >= 0); - assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); - retop = cxstack[cxstack_ix].blk_eval.retop; - cxstack[cxstack_ix].blk_eval.retop = Nullop; - -#ifdef PERL_FLEXIBLE_EXCEPTIONS - redo_body: - CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body)); -#else JMPENV_PUSH(ret); -#endif switch (ret) { case 0: -#ifndef PERL_FLEXIBLE_EXCEPTIONS + assert(cxstack_ix >= 0); + assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); + cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env; redo_body: docatch_body(); -#endif break; case 3: /* die caught by an inner eval - continue inner loop */ - if (PL_restartop && cursi == PL_curstackinfo) { + + /* 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) + { PL_op = PL_restartop; PL_restartop = 0; goto redo_body; } - /* a die in this eval - continue in outer loop */ - if (!PL_restartop) - break; /* FALL THROUGH */ default: JMPENV_POP; @@ -2713,16 +2737,16 @@ S_docatch(pTHX_ OP *o) } JMPENV_POP; PL_op = oldop; - return retop; + return Nullop; } OP * -Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp) +Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) /* sv Text to convert to OP tree. */ /* startop op_free() this to undo. */ /* code Short string id of the caller. */ { - dSP; /* Make POPBLOCK work. */ + dVAR; dSP; /* Make POPBLOCK work. */ PERL_CONTEXT *cx; SV **newsp; I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */ @@ -2819,15 +2843,14 @@ than in in the scope of the debugger itself). 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) { + I32 ix; for (ix = si->si_cxix; ix >= 0; ix--) { - cx = &(si->si_cxstack[ix]); + const PERL_CONTEXT *cx = &(si->si_cxstack[ix]); if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { CV *cv = cx->blk_sub.cv; /* skip DB:: code */ @@ -2855,7 +2878,7 @@ Perl_find_runcv(pTHX_ U32 *db_seqp) STATIC OP * S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) { - dSP; + dVAR; dSP; OP *saveop = PL_op; PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE) @@ -2901,13 +2924,13 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) if (saveop && saveop->op_flags & OPf_SPECIAL) PL_in_eval |= EVAL_KEEPERR; else - sv_setpv(ERRSV,""); + sv_setpvn(ERRSV,"",0); if (yyparse() || PL_error_count || !PL_eval_root) { SV **newsp; /* Used by POPBLOCK. */ PERL_CONTEXT *cx = &cxstack[cxstack_ix]; I32 optype = 0; /* Might be reset by POPEVAL. */ STRLEN n_a; - + PL_op = saveop; if (PL_eval_root) { op_free(PL_eval_root); @@ -2921,15 +2944,15 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) lex_end(); LEAVE; if (optype == OP_REQUIRE) { - char* msg = SvPVx(ERRSV, n_a); + const char* msg = SvPVx(ERRSV, n_a); SV *nsv = cx->blk_eval.old_namesv; - (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), + (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), &PL_sv_undef, 0); DIE(aTHX_ "%sCompilation failed in require", *msg ? msg : "Unknown error\n"); } else if (startop) { - char* msg = SvPVx(ERRSV, n_a); + const char* msg = SvPVx(ERRSV, n_a); POPBLOCK(cx,PL_curpm); POPEVAL(cx); @@ -2937,7 +2960,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) (*msg ? msg : "Unknown error\n")); } else { - char* msg = SvPVx(ERRSV, n_a); + const char* msg = SvPVx(ERRSV, n_a); if (!*msg) { sv_setpv(ERRSV, "Compilation error"); } @@ -2993,12 +3016,12 @@ STATIC PerlIO * S_doopen_pm(pTHX_ const char *name, const char *mode) { #ifndef PERL_DISABLE_PMC - STRLEN namelen = strlen(name); + const STRLEN namelen = strlen(name); PerlIO *fp; if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) { SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c'); - char *pmc = SvPV_nolen(pmcsv); + const char * const pmc = SvPV_nolen(pmcsv); Stat_t pmstat; Stat_t pmcstat; if (PerlLIO_stat(pmc, &pmcstat) < 0) { @@ -3027,7 +3050,7 @@ S_doopen_pm(pTHX_ const char *name, const char *mode) PP(pp_require) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; SV *sv; char *name; @@ -3035,9 +3058,8 @@ PP(pp_require) char *tryname = Nullch; SV *namesv = Nullsv; SV** svp; - I32 gimme = GIMME_V; + const I32 gimme = GIMME_V; PerlIO *tryrsfp = 0; - STRLEN n_a; int filter_has_file = 0; GV *filter_child_proc = 0; SV *filter_state = 0; @@ -3056,7 +3078,7 @@ PP(pp_require) if (!sv_derived_from(PL_patchlevel, "version")) (void *)upg_version(PL_patchlevel); if ( vcmp(sv,PL_patchlevel) > 0 ) - DIE(aTHX_ "Perl v%_ required--this is only v%_, stopped", + DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped", vstringify(sv), vstringify(PL_patchlevel)); RETPUSHYES; @@ -3222,6 +3244,7 @@ PP(pp_require) || (*name == ':' && name[1] != ':' && strchr(name+2, ':')) #endif ) { + STRLEN n_a; char *dir = SvPVx(dirsv, n_a); #ifdef MACOS_TRADITIONAL char buf1[256]; @@ -3230,15 +3253,29 @@ PP(pp_require) MacPerl_CanonDir(name, buf2, 1); Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':')); #else -#ifdef VMS +# ifdef VMS char *unixdir; if ((unixdir = tounixpath(dir, Nullch)) == Nullch) continue; sv_setpv(namesv, unixdir); sv_catpv(namesv, unixname); -#else +# else +# ifdef SYMBIAN + if (PL_origfilename[0] && + PL_origfilename[1] == ':' && + !(dir[0] && dir[1] == ':')) + Perl_sv_setpvf(aTHX_ namesv, + "%c:%s\\%s", + PL_origfilename[0], + dir, name); + else + Perl_sv_setpvf(aTHX_ namesv, + "%s\\%s", + dir, name); +# else Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); -#endif +# endif +# endif #endif TAINT_PROPER("require"); tryname = SvPVX(namesv); @@ -3265,13 +3302,14 @@ PP(pp_require) AV *ar = GvAVn(PL_incgv); I32 i; sv_catpvn(msg, " in @INC", 8); - if (instr(SvPVX(msg), ".h ")) + if (instr(SvPVX_const(msg), ".h ")) sv_catpv(msg, " (change .h to .ph maybe?)"); - if (instr(SvPVX(msg), ".ph ")) + if (instr(SvPVX_const(msg), ".ph ")) sv_catpv(msg, " (did you run h2ph?)"); sv_catpv(msg, " (@INC contains:"); for (i = 0; i <= AvFILL(ar); i++) { - char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a); + STRLEN n_a; + const char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a); Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir); sv_catsv(msg, dirmsgsv); } @@ -3341,7 +3379,7 @@ PP(pp_require) PL_encoding = Nullsv; op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq)); - + /* Restore encoding. */ PL_encoding = encoding; @@ -3355,10 +3393,10 @@ PP(pp_dofile) PP(pp_entereval) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; dPOPss; - I32 gimme = GIMME_V, was = PL_sub_generation; + const I32 gimme = GIMME_V, was = PL_sub_generation; char tbuf[TYPE_DIGITS(long) + 12]; char *tmpbuf = tbuf; char *safestr; @@ -3439,14 +3477,14 @@ PP(pp_entereval) PP(pp_leaveeval) { - dSP; + dVAR; dSP; register SV **mark; SV **newsp; PMOP *newpm; I32 gimme; register PERL_CONTEXT *cx; OP *retop; - U8 save_flags = PL_op -> op_flags; + const U8 save_flags = PL_op -> op_flags; I32 optype; POPBLOCK(cx,newpm); @@ -3492,14 +3530,14 @@ PP(pp_leaveeval) { /* 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); + (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD); retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv); /* die_where() did LEAVE, or we won't be here */ } else { LEAVE; if (!(save_flags & OPf_SPECIAL)) - sv_setpv(ERRSV,""); + sv_setpvn(ERRSV,"",0); } RETURNOP(retop); @@ -3507,9 +3545,9 @@ PP(pp_leaveeval) PP(pp_entertry) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; - I32 gimme = GIMME_V; + const I32 gimme = GIMME_V; ENTER; SAVETMPS; @@ -3519,25 +3557,23 @@ PP(pp_entertry) cx->blk_eval.retop = cLOGOP->op_other->op_next; PL_in_eval = EVAL_INEVAL; - sv_setpv(ERRSV,""); + sv_setpvn(ERRSV,"",0); PUTBACK; return DOCATCH(PL_op->op_next); } PP(pp_leavetry) { - dSP; + dVAR; dSP; register SV **mark; SV **newsp; PMOP *newpm; - OP* retop; I32 gimme; register PERL_CONTEXT *cx; I32 optype; POPBLOCK(cx,newpm); POPEVAL(cx); - retop = cx->blk_eval.retop; TAINT_NOT; if (gimme == G_VOID) @@ -3568,8 +3604,8 @@ PP(pp_leavetry) PL_curpm = newpm; /* Don't pop $1 et al till now */ LEAVE; - sv_setpv(ERRSV,""); - RETURNOP(retop); + sv_setpvn(ERRSV,"",0); + RETURN; } STATIC OP * @@ -3703,9 +3739,7 @@ S_doparseform(pTHX_ SV *sv) while (*s == '#') s++; if (*s == '.') { - char *f; - s++; - f = s; + const char * const f = ++s; while (*s == '#') s++; arg |= 256 + (s - f); @@ -3722,9 +3756,7 @@ S_doparseform(pTHX_ SV *sv) while (*s == '#') s++; if (*s == '.') { - char *f; - s++; - f = s; + const char * const f = ++s; while (*s == '#') s++; arg |= 256 + (s - f); @@ -3788,7 +3820,7 @@ S_doparseform(pTHX_ SV *sv) sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0); SvCOMPILED_on(sv); - if (unchopnum && repeat) + if (unchopnum && repeat) DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)"); return 0; } @@ -3824,6 +3856,7 @@ S_num_overflow(NV value, I32 fldsize, I32 frcsize) static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) { + dVAR; SV *datasv = FILTER_DATA(idx); int filter_has_file = IoLINES(datasv); GV *filter_child_proc = (GV *)IoFMT_GV(datasv); @@ -3894,7 +3927,7 @@ run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) /* perhaps someone can come up with a better name for this? it is not really "absolute", per se ... */ static bool -S_path_is_absolute(pTHX_ char *name) +S_path_is_absolute(pTHX_ const char *name) { if (PERL_FILE_IS_ABSOLUTE(name) #ifdef MACOS_TRADITIONAL @@ -3909,3 +3942,13 @@ S_path_is_absolute(pTHX_ char *name) else return FALSE; } + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */