X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=261b1be2e2c865f4b50669a8f0bff857de5be868;hb=206957a79d0bac91e0b2fccc7ef76f95e8df245e;hp=b0ffcb52a9c6552cb9631b5afc46eea1d0da6592;hpb=52d1f6fbd78cbd98dc95a58db296db2bbc0759ae;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index b0ffcb5..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)) { @@ -1322,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)) { @@ -1475,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) @@ -2312,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 || @@ -2330,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) { @@ -2715,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); @@ -2802,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; @@ -3082,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; } @@ -3095,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); @@ -3537,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 ; @@ -3578,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; @@ -3891,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(); @@ -3904,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); @@ -3917,7 +3962,10 @@ STATIC void S_destroy_matcher(pTHX_ PMOP *matcher) { dVAR; + + PERL_ARGS_ASSERT_DESTROY_MATCHER; PERL_UNUSED_ARG(matcher); + FREETMPS; LEAVE; } @@ -3964,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) @@ -3995,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; @@ -4421,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"); @@ -4663,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; @@ -4829,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 == ':')