X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=3ef7e3210b4064bef651c9b2852c9c7b7df41b91;hb=59b714e260d430f6d20c1573b9cd0f5fe0955ad8;hp=e82197208bcb210e498ebe3d7e6962a4ef4609d8;hpb=85a646323d457a108a69d6fa2e42cbaca4201c8b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index e821972..3ef7e32 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, 2005, 2006, 2007 by Larry Wall and others + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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. @@ -9,12 +9,14 @@ */ /* - * Now far ahead the Road has gone, - * And I must follow, if I can, - * Pursuing it with eager feet, - * Until it joins some larger way - * Where many paths and errands meet. - * And whither then? I cannot say. + * Now far ahead the Road has gone, + * And I must follow, if I can, + * Pursuing it with eager feet, + * Until it joins some larger way + * Where many paths and errands meet. + * And whither then? I cannot say. + * + * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"] */ /* This file contains control-oriented pp ("push/pop") functions that @@ -95,7 +97,7 @@ PP(pp_regcomp) /* multiple args; concatentate them */ dMARK; dORIGMARK; tmpstr = PAD_SV(ARGTARG); - sv_setpvn(tmpstr, "", 0); + sv_setpvs(tmpstr, ""); while (++MARK <= SP) { if (PL_amagic_generation) { SV *sv; @@ -231,10 +233,9 @@ PP(pp_substcont) if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs)) cx->sb_rxtainted |= 2; sv_catsv(dstr, POPs); - FREETMPS; /* Prevent excess tmp stack */ /* Are we done */ - if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig, + if (CxONCE(cx) || !CALLREGEXEC(rx, s, cx->sb_strend, orig, s == m, cx->sb_targ, NULL, ((cx->sb_rflags & REXEC_COPY_STR) ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST) @@ -298,7 +299,6 @@ PP(pp_substcont) { /* Update the pos() information. */ SV * const sv = cx->sb_targ; MAGIC *mg; - I32 i; SvUPGRADE(sv, SVt_PVMG); if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) { #ifdef PERL_OLD_COPY_ON_WRITE @@ -308,10 +308,7 @@ PP(pp_substcont) mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob, NULL, 0); } - i = m - orig; - if (DO_UTF8(sv)) - sv_pos_b2u(sv, &i); - mg->mg_len = i; + mg->mg_len = m - orig; } if (old != rx) (void)ReREFCNT_inc(rx); @@ -325,6 +322,8 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) { UV *p = (UV*)*rsp; U32 i; + + PERL_ARGS_ASSERT_RXRES_SAVE; PERL_UNUSED_CONTEXT; if (!p || p[1] < RX_NPARENS(rx)) { @@ -363,6 +362,8 @@ Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) { UV *p = (UV*)*rsp; U32 i; + + PERL_ARGS_ASSERT_RXRES_RESTORE; PERL_UNUSED_CONTEXT; RX_MATCH_COPY_FREE(rx); @@ -390,6 +391,8 @@ void Perl_rxres_free(pTHX_ void **rsp) { UV * const p = (UV*)*rsp; + + PERL_ARGS_ASSERT_RXRES_FREE; PERL_UNUSED_CONTEXT; if (p) { @@ -437,7 +440,6 @@ PP(pp_formline) SV * nsv = NULL; OP * parseres = NULL; const char *fmt; - bool oneline; if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { if (SvREADONLY(tmpForm)) { @@ -503,6 +505,7 @@ PP(pp_formline) *t = '\0'; sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv); t = SvEND(PL_formtarget); + f += arg; break; } if (!targ_is_utf8 && DO_UTF8(tmpForm)) { @@ -763,51 +766,76 @@ PP(pp_formline) case FF_LINESNGL: chopspace = 0; - oneline = TRUE; - goto ff_line; case FF_LINEGLOB: - oneline = FALSE; - ff_line: { + const bool oneline = fpc[-1] == FF_LINESNGL; const char *s = item = SvPV_const(sv, len); + item_is_utf8 = DO_UTF8(sv); itemsize = len; - if ((item_is_utf8 = DO_UTF8(sv))) - itemsize = sv_len_utf8(sv); if (itemsize) { - bool chopped = FALSE; + STRLEN to_copy = itemsize; const char *const send = s + len; + const U8 *source = (const U8 *) s; + U8 *tmp = NULL; + gotsome = TRUE; chophere = s + itemsize; while (s < send) { if (*s++ == '\n') { if (oneline) { - chopped = TRUE; + to_copy = s - SvPVX_const(sv) - 1; chophere = s; break; } else { if (s == send) { itemsize--; - chopped = TRUE; + to_copy--; } else lines++; } } } - SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); - if (targ_is_utf8) - SvUTF8_on(PL_formtarget); - if (oneline) { - SvCUR_set(sv, chophere - item); - sv_catsv(PL_formtarget, sv); - SvCUR_set(sv, itemsize); - } else - sv_catsv(PL_formtarget, sv); - if (chopped) - SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1); - SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); + if (targ_is_utf8 && !item_is_utf8) { + source = tmp = bytes_to_utf8(source, &to_copy); + SvCUR_set(PL_formtarget, + t - SvPVX_const(PL_formtarget)); + } else { + if (item_is_utf8 && !targ_is_utf8) { + /* Upgrade targ to UTF8, and then we reduce it to + a problem we have a simple solution for. */ + SvCUR_set(PL_formtarget, + t - SvPVX_const(PL_formtarget)); + targ_is_utf8 = TRUE; + /* Don't need get magic. */ + sv_utf8_upgrade_flags(PL_formtarget, 0); + } else { + SvCUR_set(PL_formtarget, + t - SvPVX_const(PL_formtarget)); + } + + /* Easy. They agree. */ + assert (item_is_utf8 == targ_is_utf8); + } + SvGROW(PL_formtarget, + SvCUR(PL_formtarget) + to_copy + fudge + 1); t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget); - if (item_is_utf8) - targ_is_utf8 = TRUE; + + Copy(source, t, to_copy, char); + t += to_copy; + SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy); + if (item_is_utf8) { + if (SvGMAGICAL(sv)) { + /* Mustn't call sv_pos_b2u() as it does a second + mg_get(). Is this a bug? Do we need a _flags() + variant? */ + itemsize = utf8_length(source, source + itemsize); + } else { + sv_pos_b2u(sv, &itemsize); + } + assert(!tmp); + } else if (tmp) { + Safefree(tmp); + } } break; } @@ -960,7 +988,7 @@ PP(pp_grepstart) if (PL_op->op_private & OPpGREP_LEX) PAD_SVl(PL_op->op_targ) = src; else - DEFSV = src; + DEFSV_set(src); PUTBACK; if (PL_op->op_type == OP_MAPSTART) @@ -1071,7 +1099,7 @@ PP(pp_mapwhile) if (PL_op->op_private & OPpGREP_LEX) PAD_SVl(PL_op->op_targ) = src; else - DEFSV = src; + DEFSV_set(src); RETURNOP(cLOGOP->op_other); } @@ -1128,7 +1156,7 @@ PP(pp_flip) RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); } } - sv_setpvn(TARG, "", 0); + sv_setpvs(TARG, ""); SETs(targ); RETURN; } @@ -1224,14 +1252,17 @@ PP(pp_flop) static const char * const context_name[] = { "pseudo-block", + "when", + NULL, /* CXt_BLOCK never actually needs "block" */ + "given", + NULL, /* CXt_LOOP_FOR never actually needs "loop" */ + NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */ + NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */ + NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */ "subroutine", + "format", "eval", - "loop", "substitution", - "block", - "format", - "given", - "when" }; STATIC I32 @@ -1240,6 +1271,8 @@ S_dopoptolabel(pTHX_ const char *label) dVAR; register I32 i; + PERL_ARGS_ASSERT_DOPOPTOLABEL; + for (i = cxstack_ix; i >= 0; i--) { register const PERL_CONTEXT * const cx = &cxstack[i]; switch (CxTYPE(cx)) { @@ -1256,7 +1289,10 @@ S_dopoptolabel(pTHX_ const char *label) if (CxTYPE(cx) == CXt_NULL) return -1; break; - case CXt_LOOP: + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_FOR: + case CXt_LOOP_PLAIN: if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) { DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n", (long)i, CxLABEL(cx))); @@ -1319,6 +1355,9 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) { dVAR; I32 i; + + PERL_ARGS_ASSERT_DOPOPTOSUB_AT; + for (i = startingblock; i >= 0; i--) { register const PERL_CONTEXT * const cx = &cxstk[i]; switch (CxTYPE(cx)) { @@ -1371,7 +1410,10 @@ S_dopoptoloop(pTHX_ I32 startingblock) if ((CxTYPE(cx)) == CXt_NULL) return -1; break; - case CXt_LOOP: + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_FOR: + case CXt_LOOP_PLAIN: DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i)); return i; } @@ -1392,7 +1434,12 @@ S_dopoptogiven(pTHX_ I32 startingblock) case CXt_GIVEN: DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i)); return i; - case CXt_LOOP: + case CXt_LOOP_PLAIN: + assert(!CxFOREACHDEF(cx)); + break; + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_FOR: if (CxFOREACHDEF(cx)) { DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i)); return i; @@ -1443,7 +1490,10 @@ Perl_dounwind(pTHX_ I32 cxix) case CXt_EVAL: POPEVAL(cx); break; - case CXt_LOOP: + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_FOR: + case CXt_LOOP_PLAIN: POPLOOP(cx); break; case CXt_NULL: @@ -1461,6 +1511,9 @@ void Perl_qerror(pTHX_ SV *err) { dVAR; + + PERL_ARGS_ASSERT_QERROR; + if (PL_in_eval) sv_catsv(ERRSV, err); else if (PL_errors) @@ -1486,7 +1539,7 @@ Perl_die_where(pTHX_ const char *message, STRLEN msglen) SV * const err = ERRSV; const char *e = NULL; if (!SvPOK(err)) - sv_setpvn(err,"",0); + sv_setpvs(err,""); else if (SvCUR(err) >= sizeof(prefix)+msglen-1) { STRLEN len; e = SvPV_const(err, len); @@ -1500,7 +1553,8 @@ Perl_die_where(pTHX_ const char *message, STRLEN msglen) sv_catpvn(err, message, msglen); if (ckWARN(WARN_MISC)) { const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1; - Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start); + Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", + SvPVX_const(err)+start); } } } @@ -1740,8 +1794,8 @@ PP(pp_caller) PUSHs(cx->blk_oldcop->cop_hints_hash ? sv_2mortal(newRV_noinc( - (SV*)Perl_refcounted_he_chain_2hv(aTHX_ - cx->blk_oldcop->cop_hints_hash))) + MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_ + cx->blk_oldcop->cop_hints_hash)))) : &PL_sv_undef); RETURN; } @@ -1821,9 +1875,9 @@ PP(pp_enteriter) register PERL_CONTEXT *cx; const I32 gimme = GIMME_V; SV **svp; - U16 cxtype = CXt_LOOP | CXp_FOREACH; + U8 cxtype = CXt_LOOP_FOR; #ifdef USE_ITHREADS - void *iterdata; + PAD *iterdata; #endif ENTER; @@ -1835,22 +1889,20 @@ PP(pp_enteriter) SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ), SVs_PADSTALE, SVs_PADSTALE); } + SAVEPADSVANDMORTALIZE(PL_op->op_targ); #ifndef USE_ITHREADS svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */ - SAVESPTR(*svp); #else - SAVEPADSV(PL_op->op_targ); - iterdata = INT2PTR(void*, PL_op->op_targ); - cxtype |= CXp_PADVAR; + iterdata = NULL; #endif } else { - GV * const gv = (GV*)POPs; + GV * const gv = MUTABLE_GV(POPs); svp = &GvSV(gv); /* symbol table variable */ SAVEGENERICSV(*svp); *svp = newSV(0); #ifdef USE_ITHREADS - iterdata = (void*)gv; + iterdata = (PAD*)gv; #endif } @@ -1861,18 +1913,23 @@ PP(pp_enteriter) PUSHBLOCK(cx, cxtype, SP); #ifdef USE_ITHREADS - PUSHLOOP(cx, iterdata, MARK); + PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ); #else - PUSHLOOP(cx, svp, MARK); + PUSHLOOP_FOR(cx, svp, MARK, 0); #endif if (PL_op->op_flags & OPf_STACKED) { - cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs); - if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) { + SV *maybe_ary = POPs; + if (SvTYPE(maybe_ary) != SVt_PVAV) { dPOPss; - SV * const right = (SV*)cx->blk_loop.iterary; + SV * const right = maybe_ary; SvGETMAGIC(sv); SvGETMAGIC(right); if (RANGE_IS_NUMERIC(sv,right)) { + cx->cx_type &= ~CXTYPEMASK; + cx->cx_type |= CXt_LOOP_LAZYIV; + /* Make sure that no-one re-orders cop.h and breaks our + assumptions */ + assert(CxTYPE(cx) == CXt_LOOP_LAZYIV); #ifdef NV_PRESERVES_UV if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) || (SvNV(sv) > (NV)IV_MAX))) @@ -1893,34 +1950,50 @@ PP(pp_enteriter) (SvNV(right) > (NV)UV_MAX)))))) #endif DIE(aTHX_ "Range iterator outside integer range"); - cx->blk_loop.iterix = SvIV(sv); - cx->blk_loop.itermax = SvIV(right); + cx->blk_loop.state_u.lazyiv.cur = SvIV(sv); + cx->blk_loop.state_u.lazyiv.end = SvIV(right); #ifdef DEBUGGING /* for correct -Dstv display */ cx->blk_oldsp = sp - PL_stack_base; #endif } else { - cx->blk_loop.iterlval = newSVsv(sv); - (void) SvPV_force_nolen(cx->blk_loop.iterlval); + cx->cx_type &= ~CXTYPEMASK; + cx->cx_type |= CXt_LOOP_LAZYSV; + /* Make sure that no-one re-orders cop.h and breaks our + assumptions */ + assert(CxTYPE(cx) == CXt_LOOP_LAZYSV); + cx->blk_loop.state_u.lazysv.cur = newSVsv(sv); + cx->blk_loop.state_u.lazysv.end = right; + SvREFCNT_inc(right); + (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur); + /* This will do the upgrade to SVt_PV, and warn if the value + is uninitialised. */ (void) SvPV_nolen_const(right); + /* Doing this avoids a check every time in pp_iter in pp_hot.c + to replace !SvOK() with a pointer to "". */ + if (!SvOK(right)) { + SvREFCNT_dec(right); + cx->blk_loop.state_u.lazysv.end = &PL_sv_no; + } } } - else if (PL_op->op_private & OPpITER_REVERSED) { - cx->blk_loop.itermax = 0; - cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1; - + else /* SvTYPE(maybe_ary) == SVt_PVAV */ { + cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary); + SvREFCNT_inc(maybe_ary); + cx->blk_loop.state_u.ary.ix = + (PL_op->op_private & OPpITER_REVERSED) ? + AvFILL(cx->blk_loop.state_u.ary.ary) + 1 : + -1; } } - else { - cx->blk_loop.iterary = PL_curstack; - AvFILLp(PL_curstack) = SP - PL_stack_base; + else { /* iterating over items on the stack */ + cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */ if (PL_op->op_private & OPpITER_REVERSED) { - cx->blk_loop.itermax = MARK - PL_stack_base + 1; - cx->blk_loop.iterix = cx->blk_oldsp + 1; + cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1; } else { - cx->blk_loop.iterix = MARK - PL_stack_base; + cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base; } } @@ -1937,8 +2010,8 @@ PP(pp_enterloop) SAVETMPS; ENTER; - PUSHBLOCK(cx, CXt_LOOP, SP); - PUSHLOOP(cx, 0, SP); + PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP); + PUSHLOOP_PLAIN(cx, SP); RETURN; } @@ -1953,7 +2026,7 @@ PP(pp_leaveloop) SV **mark; POPBLOCK(cx,newpm); - assert(CxTYPE(cx) == CXt_LOOP); + assert(CxTYPE_is_LOOP(cx)); mark = newsp; newsp = PL_stack_base + cx->blk_loop.resetsp; @@ -2103,8 +2176,9 @@ PP(pp_return) PL_curpm = newpm; /* ... and pop $1 et al */ LEAVESUB(sv); - if (clear_errsv) - sv_setpvn(ERRSV,"",0); + if (clear_errsv) { + CLEAR_ERRSV(); + } return retop; } @@ -2140,8 +2214,11 @@ PP(pp_last) cxstack_ix++; /* temporarily protect top context */ mark = newsp; switch (CxTYPE(cx)) { - case CXt_LOOP: - pop2 = CXt_LOOP; + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_FOR: + case CXt_LOOP_PLAIN: + pop2 = CxTYPE(cx); newsp = PL_stack_base + cx->blk_loop.resetsp; nextop = cx->blk_loop.my_op->op_lastop->op_next; break; @@ -2183,7 +2260,10 @@ PP(pp_last) cxstack_ix--; /* Stack values are safe: */ switch (pop2) { - case CXt_LOOP: + case CXt_LOOP_LAZYIV: + case CXt_LOOP_PLAIN: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_FOR: POPLOOP(cx); /* release loop vars ... */ LEAVE; break; @@ -2273,6 +2353,8 @@ S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) OP **ops = opstack; static const char too_deep[] = "Target of goto is too deeply nested"; + PERL_ARGS_ASSERT_DOFINDLABEL; + if (ops >= oplimit) Perl_croak(aTHX_ too_deep); if (o->op_type == OP_LEAVE || @@ -2291,7 +2373,7 @@ S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) /* First try all the kids at this level, since that's likeliest. */ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && - kCOP->cop_label && strEQ(kCOP->cop_label, label)) + CopLABEL(kCOP) && strEQ(CopLABEL(kCOP), label)) return kid; } for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { @@ -2333,7 +2415,7 @@ PP(pp_goto) if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { I32 cxix; register PERL_CONTEXT *cx; - CV* cv = (CV*)SvRV(sv); + CV *cv = MUTABLE_CV(SvRV(sv)); SV** mark; I32 items = 0; I32 oldsave; @@ -2395,7 +2477,7 @@ PP(pp_goto) av = newAV(); av_extend(av, items-1); AvREIFY_only(av); - PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av); + PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av); } } else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */ @@ -2456,10 +2538,10 @@ PP(pp_goto) PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); if (CxHASARGS(cx)) { - AV* const av = (AV*)PAD_SVl(0); + AV *const av = MUTABLE_AV(PAD_SVl(0)); cx->blk_sub.savearray = GvAV(PL_defgv); - GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av); + GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av)); CX_CURPAD_SAVE(cx->blk_sub); cx->blk_sub.argarray = av; @@ -2497,7 +2579,7 @@ PP(pp_goto) CV * const gotocv = get_cv("DB::goto", FALSE); if (gotocv) { PUSHMARK( PL_stack_sp ); - call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG); + call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG); PL_stack_sp--; } } @@ -2541,7 +2623,10 @@ PP(pp_goto) break; } /* else fall through */ - case CXt_LOOP: + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_FOR: + case CXt_LOOP_PLAIN: gotoprobe = cx->blk_oldcop->op_sibling; break; case CXt_SUBST: @@ -2673,6 +2758,8 @@ S_save_lines(pTHX_ AV *array, SV *sv) const char * const send = SvPVX_const(sv) + SvCUR(sv); I32 line = 1; + PERL_ARGS_ASSERT_SAVE_LINES; + while (s && s < send) { const char *t; SV * const tmpstr = newSV_type(SVt_PVMG); @@ -2760,6 +2847,8 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) CV* runcv = NULL; /* initialise to avoid compiler warnings */ STRLEN len; + PERL_ARGS_ASSERT_SV_COMPILE_2OP; + ENTER; lex_start(sv, NULL, FALSE); SAVETMPS; @@ -2807,7 +2896,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) PL_op->op_type = OP_ENTEREVAL; PL_op->op_flags = 0; /* Avoid uninit warning. */ PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP); - PUSHEVAL(cx, 0, NULL); + PUSHEVAL(cx, 0); if (runtime) (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq); @@ -2820,7 +2909,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) (*startop)->op_ppaddr = PL_ppaddr[OP_NULL]; lex_end(); /* XXX DAPM do this properly one year */ - *padp = (AV*)SvREFCNT_inc_simple(PL_comppad); + *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad)); LEAVE; if (IN_PERL_COMPILETIME) CopHINTS_set(&PL_compiling, PL_hints); @@ -2897,13 +2986,13 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) PUSHMARK(SP); SAVESPTR(PL_compcv); - PL_compcv = (CV*)newSV_type(SVt_PVCV); + PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV)); CvEVAL_on(PL_compcv); 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_simple(outside); + CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); /* set up a scratch pad */ @@ -2941,7 +3030,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL)) PL_in_eval |= EVAL_KEEPERR; else - sv_setpvn(ERRSV,"",0); + CLEAR_ERRSV(); if (yyparse() || PL_parser->error_count || !PL_eval_root) { SV **newsp; /* Used by POPBLOCK. */ PERL_CONTEXT *cx = &cxstack[cxstack_ix]; @@ -3014,9 +3103,9 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) if (cv) { dSP; PUSHMARK(SP); - XPUSHs((SV*)CopFILEGV(&PL_compiling)); + XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling))); PUTBACK; - call_sv((SV*)cv, G_DISCARD); + call_sv(MUTABLE_SV(cv), G_DISCARD); } } @@ -3040,6 +3129,8 @@ S_check_type_and_open(pTHX_ const char *name) Stat_t st; const int st_rc = PerlLIO_stat(name, &st); + PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN; + if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) { return NULL; } @@ -3053,6 +3144,8 @@ S_doopen_pm(pTHX_ const char *name, const STRLEN namelen) { PerlIO *fp; + PERL_ARGS_ASSERT_DOOPEN_PM; + if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) { SV *const pmcsv = newSV(namelen + 2); char *const pmc = SvPVX(pmcsv); @@ -3118,14 +3211,14 @@ PP(pp_require) I32 first = 0; AV *lav; SV * const req = SvRV(sv); - SV * const pv = *hv_fetchs((HV*)req, "original", FALSE); + SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE); /* get the left hand term */ - lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE)); + lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE))); first = SvIV(*av_fetch(lav,0,0)); if ( first > (int)PERL_REVISION /* probably 'use 6.0' */ - || hv_exists((HV*)req, "qv", 2 ) /* qv style */ + || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */ || av_len(lav) > 1 /* FP with > 3 digits */ || strstr(SvPVX(pv),".0") /* FP with leading 0 */ ) { @@ -3234,7 +3327,7 @@ PP(pp_require) for (i = 0; i <= AvFILL(ar); i++) { SV * const dirsv = *av_fetch(ar, i, TRUE); - if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied)) + if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied)) mg_get(dirsv); if (SvROK(dirsv)) { int count; @@ -3244,7 +3337,7 @@ PP(pp_require) if (SvTYPE(SvRV(loader)) == SVt_PVAV && !sv_isobject(loader)) { - loader = *av_fetch((AV *)SvRV(loader), 0, TRUE); + loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE); } Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s", @@ -3288,12 +3381,12 @@ PP(pp_require) } } - if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) { + if (SvROK(arg) && isGV_with_GP(SvRV(arg))) { arg = SvRV(arg); } - if (SvTYPE(arg) == SVt_PVGV) { - IO * const io = GvIO((GV *)arg); + if (isGV_with_GP(arg)) { + IO * const io = GvIO((const GV *)arg); ++filter_has_file; @@ -3495,6 +3588,11 @@ PP(pp_require) SAVEHINTS(); PL_hints = 0; + if (PL_compiling.cop_hints_hash) { + Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); + PL_compiling.cop_hints_hash = NULL; + } + SAVECOMPILEWARNINGS(); if (PL_dowarn & G_WARN_ALL_ON) PL_compiling.cop_warnings = pWARN_ALL ; @@ -3506,14 +3604,14 @@ PP(pp_require) if (filter_sub || filter_cache) { SV * const datasv = filter_add(S_run_user_filter, NULL); IoLINES(datasv) = filter_has_file; - IoTOP_GV(datasv) = (GV *)filter_state; - IoBOTTOM_GV(datasv) = (GV *)filter_sub; - IoFMT_GV(datasv) = (GV *)filter_cache; + IoTOP_GV(datasv) = MUTABLE_GV(filter_state); + IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub); + IoFMT_GV(datasv) = MUTABLE_GV(filter_cache); } /* switch to eval mode */ PUSHBLOCK(cx, CXt_EVAL, SP); - PUSHEVAL(cx, name, NULL); + PUSHEVAL(cx, name); cx->blk_eval.retop = PL_op->op_next; SAVECOPLINE(&PL_compiling); @@ -3536,6 +3634,19 @@ PP(pp_require) return op; } +/* This is a op added to hold the hints hash for + pp_entereval. The hash can be modified by the code + being eval'ed, so we return a copy instead. */ + +PP(pp_hintseval) +{ + dVAR; + dSP; + mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv)))); + RETURN; +} + + PP(pp_entereval) { dVAR; dSP; @@ -3555,7 +3666,7 @@ PP(pp_entereval) const int fakelen = 9 + 1; if (PL_op->op_private & OPpEVAL_HAS_HH) { - saved_hh = (HV*) SvREFCNT_inc(POPs); + saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs)); } sv = POPs; @@ -3612,16 +3723,17 @@ PP(pp_entereval) runcv = find_runcv(&seq); PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); - PUSHEVAL(cx, 0, NULL); + PUSHEVAL(cx, 0); cx->blk_eval.retop = PL_op->op_next; /* prepare to compile string */ - if (PERLDB_LINE && PL_curstash != PL_debstash) + if (PERLDB_SAVESRC && PL_curstash != PL_debstash) save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr); PUTBACK; ok = doeval(gimme, NULL, runcv, seq); - if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */ + if ((PERLDB_LINE || PERLDB_SAVESRC) + && was != (I32)PL_sub_generation /* Some subs defined here. */ && ok) { /* Copy in anything fake and short. */ my_strlcpy(safestr, fakestr, fakelen); @@ -3690,8 +3802,9 @@ PP(pp_leaveeval) } else { LEAVE; - if (!(save_flags & OPf_SPECIAL)) - sv_setpvn(ERRSV,"",0); + if (!(save_flags & OPf_SPECIAL)) { + CLEAR_ERRSV(); + } } RETURNOP(retop); @@ -3729,13 +3842,13 @@ Perl_create_eval_scope(pTHX_ U32 flags) SAVETMPS; PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); - PUSHEVAL(cx, 0, 0); + PUSHEVAL(cx, 0); PL_in_eval = EVAL_INEVAL; if (flags & G_KEEPERR) PL_in_eval |= EVAL_KEEPERR; else - sv_setpvn(ERRSV,"",0); + CLEAR_ERRSV(); if (flags & G_FAKINGEVAL) { PL_eval_root = PL_op; /* Only needed so that goto works right. */ } @@ -3794,7 +3907,7 @@ PP(pp_leavetry) PL_curpm = newpm; /* Don't pop $1 et al till now */ LEAVE; - sv_setpvn(ERRSV,"",0); + CLEAR_ERRSV(); RETURN; } @@ -3849,8 +3962,11 @@ S_make_matcher(pTHX_ REGEXP *re) { dVAR; PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED); + + PERL_ARGS_ASSERT_MAKE_MATCHER; + PM_SETRE(matcher, ReREFCNT_inc(re)); - + SAVEFREEOP((OP *) matcher); ENTER; SAVETMPS; SAVEOP(); @@ -3862,6 +3978,8 @@ S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) { dVAR; dSP; + + PERL_ARGS_ASSERT_MATCHER_MATCHES_SV; PL_op = (OP *) matcher; XPUSHs(sv); @@ -3875,7 +3993,10 @@ STATIC void S_destroy_matcher(pTHX_ PMOP *matcher) { dVAR; + + PERL_ARGS_ASSERT_DESTROY_MATCHER; PERL_UNUSED_ARG(matcher); + FREETMPS; LEAVE; } @@ -3922,6 +4043,11 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) && (Other = d)) ) +# define SM_OBJECT ( \ + (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) \ + || \ + (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) ) \ + # define SM_OTHER_REF(type) \ (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type) @@ -3953,6 +4079,9 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) if (SvGMAGICAL(e)) e = sv_mortalcopy(e); + if (SM_OBJECT) + Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation"); + if (SM_CV_NEP) { I32 c; @@ -3983,7 +4112,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) if (SM_OTHER_REF(PVHV)) { /* Check that the key-sets are identical */ HE *he; - HV *other_hv = (HV *) SvRV(Other); + HV *other_hv = MUTABLE_HV(SvRV(Other)); bool tied = FALSE; bool other_tied = FALSE; U32 this_key_count = 0, @@ -3993,29 +4122,29 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) if (SvTIED_mg(This, PERL_MAGIC_tied)) { tied = TRUE; } - else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) { + else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) { HV * const temp = other_hv; - other_hv = (HV *) This; - This = (SV *) temp; + other_hv = MUTABLE_HV(This); + This = MUTABLE_SV(temp); tied = TRUE; } - if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) + if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) other_tied = TRUE; - if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv)) + if (!tied && HvUSEDKEYS((const HV *) This) != HvUSEDKEYS(other_hv)) RETPUSHNO; /* The hashes have the same number of keys, so it suffices to check that one is a subset of the other. */ - (void) hv_iterinit((HV *) This); - while ( (he = hv_iternext((HV *) This)) ) { + (void) hv_iterinit(MUTABLE_HV(This)); + while ( (he = hv_iternext(MUTABLE_HV(This))) ) { I32 key_len; char * const key = hv_iterkey(he, &key_len); ++ this_key_count; if(!hv_exists(other_hv, key, key_len)) { - (void) hv_iterinit((HV *) This); /* reset iterator */ + (void) hv_iterinit(MUTABLE_HV(This)); /* reset iterator */ RETPUSHNO; } } @@ -4034,7 +4163,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) RETPUSHYES; } else if (SM_OTHER_REF(PVAV)) { - AV * const other_av = (AV *) SvRV(Other); + AV * const other_av = MUTABLE_AV(SvRV(Other)); const I32 other_len = av_len(other_av) + 1; I32 i; @@ -4045,7 +4174,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) if (svp) { /* ??? When can this not happen? */ key = SvPV(*svp, key_len); - if (hv_exists((HV *) This, key, key_len)) + if (hv_exists(MUTABLE_HV(This), key, key_len)) RETPUSHYES; } } @@ -4055,10 +4184,10 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) PMOP * const matcher = make_matcher(other_regex); HE *he; - (void) hv_iterinit((HV *) This); - while ( (he = hv_iternext((HV *) This)) ) { + (void) hv_iterinit(MUTABLE_HV(This)); + while ( (he = hv_iternext(MUTABLE_HV(This))) ) { if (matcher_matches_sv(matcher, hv_iterkeysv(he))) { - (void) hv_iterinit((HV *) This); + (void) hv_iterinit(MUTABLE_HV(This)); destroy_matcher(matcher); RETPUSHYES; } @@ -4067,7 +4196,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) RETPUSHNO; } else { - if (hv_exists_ent((HV *) This, Other, 0)) + if (hv_exists_ent(MUTABLE_HV(This), Other, 0)) RETPUSHYES; else RETPUSHNO; @@ -4075,8 +4204,8 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) } else if (SM_REF(PVAV)) { if (SM_OTHER_REF(PVAV)) { - AV *other_av = (AV *) SvRV(Other); - if (av_len((AV *) This) != av_len(other_av)) + AV *other_av = MUTABLE_AV(SvRV(Other)); + if (av_len(MUTABLE_AV(This)) != av_len(other_av)) RETPUSHNO; else { I32 i; @@ -4084,14 +4213,14 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) if (NULL == seen_this) { seen_this = newHV(); - (void) sv_2mortal((SV *) seen_this); + (void) sv_2mortal(MUTABLE_SV(seen_this)); } if (NULL == seen_other) { seen_this = newHV(); - (void) sv_2mortal((SV *) seen_other); + (void) sv_2mortal(MUTABLE_SV(seen_other)); } for(i = 0; i <= other_len; ++i) { - SV * const * const this_elem = av_fetch((AV *)This, i, FALSE); + SV * const * const this_elem = av_fetch(MUTABLE_AV(This), i, FALSE); SV * const * const other_elem = av_fetch(other_av, i, FALSE); if (!this_elem || !other_elem) { @@ -4127,11 +4256,11 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) } else if (SM_OTHER_REGEX) { PMOP * const matcher = make_matcher(other_regex); - const I32 this_len = av_len((AV *) This); + const I32 this_len = av_len(MUTABLE_AV(This)); I32 i; for(i = 0; i <= this_len; ++i) { - SV * const * const svp = av_fetch((AV *)This, i, FALSE); + SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE); if (svp && matcher_matches_sv(matcher, *svp)) { destroy_matcher(matcher); RETPUSHYES; @@ -4143,8 +4272,8 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) else if (SvIOK(Other) || SvNOK(Other)) { I32 i; - for(i = 0; i <= AvFILL((AV *) This); ++i) { - SV * const * const svp = av_fetch((AV *)This, i, FALSE); + for(i = 0; i <= AvFILL(MUTABLE_AV(This)); ++i) { + SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE); if (!svp) continue; @@ -4162,11 +4291,11 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) RETPUSHNO; } else if (SvPOK(Other)) { - const I32 this_len = av_len((AV *) This); + const I32 this_len = av_len(MUTABLE_AV(This)); I32 i; for(i = 0; i <= this_len; ++i) { - SV * const * const svp = av_fetch((AV *)This, i, FALSE); + SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE); if (!svp) continue; @@ -4379,6 +4508,8 @@ S_doparseform(pTHX_ SV *sv) bool unchopnum = FALSE; int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */ + PERL_ARGS_ASSERT_DOPARSEFORM; + if (len == 0) Perl_croak(aTHX_ "Null picture in formline"); @@ -4611,8 +4742,8 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) dVAR; SV * const datasv = FILTER_DATA(idx); const int filter_has_file = IoLINES(datasv); - SV * const filter_state = (SV *)IoTOP_GV(datasv); - SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv); + SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv)); + SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv)); int status = 0; SV *upstream; STRLEN got_len; @@ -4621,6 +4752,8 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) bool read_from_cache = FALSE; STRLEN umaxlen; + PERL_ARGS_ASSERT_RUN_USER_FILTER; + assert(maxlen >= 0); umaxlen = maxlen; @@ -4630,7 +4763,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) not sure where the trouble is yet. XXX */ if (IoFMT_GV(datasv)) { - SV *const cache = (SV *)IoFMT_GV(datasv); + SV *const cache = MUTABLE_SV(IoFMT_GV(datasv)); if (SvOK(cache)) { STRLEN cache_len; const char *cache_p = SvPV(cache, cache_len); @@ -4689,7 +4822,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) SAVETMPS; EXTEND(SP, 2); - DEFSV = upstream; + DEFSV_set(upstream); PUSHMARK(SP); mPUSHi(0); if (filter_state) { @@ -4729,10 +4862,10 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) if (prune_from) { /* Oh. Too long. Stuff some in our cache. */ STRLEN cached_len = got_p + got_len - prune_from; - SV *cache = (SV *)IoFMT_GV(datasv); + SV *cache = MUTABLE_SV(IoFMT_GV(datasv)); if (!cache) { - IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen)); + IoFMT_GV(datasv) = MUTABLE_GV((cache = newSV(got_len - umaxlen))); } else if (SvOK(cache)) { /* Cache should be empty. */ assert(!SvCUR(cache)); @@ -4787,6 +4920,8 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) static bool S_path_is_absolute(const char *name) { + PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE; + if (PERL_FILE_IS_ABSOLUTE(name) #ifdef MACOS_TRADITIONAL || (*name == ':')