X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=261b1be2e2c865f4b50669a8f0bff857de5be868;hb=206957a79d0bac91e0b2fccc7ef76f95e8df245e;hp=2419f2783d54fbd0d6000a52a0c52959a5035bd4;hpb=3b719c58b6800b0db9786a0d03d9b07e39a8b70f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index 2419f27..261b1be 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -231,7 +231,6 @@ 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 (CxONCE(cx) || !CALLREGEXEC(rx, s, cx->sb_strend, orig, @@ -298,7 +297,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 +306,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 +320,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 +360,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 +389,8 @@ void Perl_rxres_free(pTHX_ void **rsp) { UV * const p = (UV*)*rsp; + + PERL_ARGS_ASSERT_RXRES_FREE; PERL_UNUSED_CONTEXT; if (p) { @@ -1224,14 +1225,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 +1244,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,6 +1262,8 @@ S_dopoptolabel(pTHX_ const char *label) if (CxTYPE(cx) == CXt_NULL) return -1; break; + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: case CXt_LOOP_FOR: case CXt_LOOP_PLAIN: if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) { @@ -1320,6 +1328,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)) { @@ -1372,6 +1383,8 @@ S_dopoptoloop(pTHX_ I32 startingblock) if ((CxTYPE(cx)) == CXt_NULL) return -1; break; + 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)); @@ -1397,6 +1410,8 @@ S_dopoptogiven(pTHX_ I32 startingblock) 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)); @@ -1448,6 +1463,8 @@ Perl_dounwind(pTHX_ I32 cxix) case CXt_EVAL: POPEVAL(cx); break; + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: case CXt_LOOP_FOR: case CXt_LOOP_PLAIN: POPLOOP(cx); @@ -1467,6 +1484,9 @@ void Perl_qerror(pTHX_ SV *err) { dVAR; + + PERL_ARGS_ASSERT_QERROR; + if (PL_in_eval) sv_catsv(ERRSV, err); else if (PL_errors) @@ -1827,9 +1847,9 @@ PP(pp_enteriter) register PERL_CONTEXT *cx; const I32 gimme = GIMME_V; SV **svp; - U16 cxtype = CXt_LOOP_FOR; + U8 cxtype = CXt_LOOP_FOR; #ifdef USE_ITHREADS - void *iterdata; + PAD *iterdata; #endif ENTER; @@ -1841,13 +1861,11 @@ 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 { @@ -1856,7 +1874,7 @@ PP(pp_enteriter) SAVEGENERICSV(*svp); *svp = newSV(0); #ifdef USE_ITHREADS - iterdata = (void*)gv; + iterdata = (PAD*)gv; #endif } @@ -1867,18 +1885,23 @@ PP(pp_enteriter) PUSHBLOCK(cx, cxtype, SP); #ifdef USE_ITHREADS - PUSHLOOP_FOR(cx, iterdata, MARK); + PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ); #else - PUSHLOOP_FOR(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))) @@ -1899,33 +1922,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 = (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; + 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; } } @@ -2145,6 +2185,8 @@ PP(pp_last) cxstack_ix++; /* temporarily protect top context */ mark = newsp; switch (CxTYPE(cx)) { + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: case CXt_LOOP_FOR: case CXt_LOOP_PLAIN: pop2 = CxTYPE(cx); @@ -2189,7 +2231,9 @@ PP(pp_last) cxstack_ix--; /* Stack values are safe: */ switch (pop2) { + case CXt_LOOP_LAZYIV: case CXt_LOOP_PLAIN: + case CXt_LOOP_LAZYSV: case CXt_LOOP_FOR: POPLOOP(cx); /* release loop vars ... */ LEAVE; @@ -2280,6 +2324,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 || @@ -2298,7 +2344,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) { @@ -2548,6 +2594,8 @@ PP(pp_goto) break; } /* else fall through */ + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: case CXt_LOOP_FOR: case CXt_LOOP_PLAIN: gotoprobe = cx->blk_oldcop->op_sibling; @@ -2681,6 +2729,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); @@ -2768,6 +2818,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; @@ -2815,7 +2867,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); @@ -3048,6 +3100,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; } @@ -3061,6 +3115,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); @@ -3503,6 +3559,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 ; @@ -3521,7 +3582,7 @@ PP(pp_require) /* 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); @@ -3544,6 +3605,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((SV*)Perl_hv_copy_hints_hv(aTHX_ (HV*)cSVOP_sv)); + RETURN; +} + + PP(pp_entereval) { dVAR; dSP; @@ -3620,7 +3694,7 @@ 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 */ @@ -3737,7 +3811,7 @@ 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) @@ -3857,8 +3931,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(); @@ -3870,6 +3947,8 @@ S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) { dVAR; dSP; + + PERL_ARGS_ASSERT_MATCHER_MATCHES_SV; PL_op = (OP *) matcher; XPUSHs(sv); @@ -3883,7 +3962,10 @@ STATIC void S_destroy_matcher(pTHX_ PMOP *matcher) { dVAR; + + PERL_ARGS_ASSERT_DESTROY_MATCHER; PERL_UNUSED_ARG(matcher); + FREETMPS; LEAVE; } @@ -3930,6 +4012,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) @@ -3961,6 +4048,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; @@ -4387,6 +4477,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"); @@ -4629,6 +4721,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; @@ -4795,6 +4889,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 == ':')