X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=85f82786cfa9938a697168def27906c9be1e4caa;hb=bdc0bf6fc8e477f7c30b05ea4c2ff791dd0f31af;hp=48f2ed6379e1b61b1a1f7f11a531332cec7e76be;hpb=b2e5e6ba5e47d15a5738d4108c62ba11afc28b4c;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index 48f2ed6..85f8278 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -76,6 +76,7 @@ PP(pp_regcomp) register PMOP *pm = (PMOP*)cLOGOP->op_other; SV *tmpstr; MAGIC *mg = NULL; + regexp * re; /* prevent recompiling under /o and ithreads. */ #if defined(USE_ITHREADS) @@ -118,21 +119,21 @@ PP(pp_regcomp) mg = mg_find(sv, PERL_MAGIC_qr); } if (mg) { - regexp * const re = (regexp *)mg->mg_obj; + regexp * const re = reg_temp_copy((regexp *)mg->mg_obj); ReREFCNT_dec(PM_GETRE(pm)); - PM_SETRE(pm, ReREFCNT_inc(re)); + PM_SETRE(pm, re); } else { STRLEN len; - const char *t = SvPV_const(tmpstr, len); - regexp * const re = PM_GETRE(pm); + const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : ""; + re = PM_GETRE(pm); /* Check against the last compiled regexp. */ if (!re || !re->precomp || re->prelen != (I32)len || memNE(re->precomp, t, len)) { const regexp_engine *eng = re ? re->engine : NULL; - + U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME; if (re) { ReREFCNT_dec(re); PM_SETRE(pm, NULL); /* crucial if regcomp aborts */ @@ -146,50 +147,42 @@ PP(pp_regcomp) if (PL_op->op_flags & OPf_SPECIAL) PL_reginterp_cnt = I32_MAX; /* Mark as safe. */ - pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */ if (DO_UTF8(tmpstr)) - pm->op_pmdynflags |= PMdf_DYN_UTF8; - else { - pm->op_pmdynflags &= ~PMdf_DYN_UTF8; - if (pm->op_pmdynflags & PMdf_UTF8) - t = (char*)bytes_to_utf8((U8*)t, &len); - } - if (eng) - PM_SETRE(pm, CALLREGCOMP_ENG(eng,(char *)t, (char *)t + len, pm)); - else - PM_SETRE(pm, CALLREGCOMP((char *)t, (char *)t + len, pm)); - - if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8)) - Safefree(t); + pm_flags |= RXf_UTF8; + + if (eng) + PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags)); + else + PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags)); + PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed inside tie/overload accessors. */ } } + + re = PM_GETRE(pm); #ifndef INCOMPLETE_TAINTS if (PL_tainting) { if (PL_tainted) - pm->op_pmdynflags |= PMdf_TAINTED; + re->extflags |= RXf_TAINTED; else - pm->op_pmdynflags &= ~PMdf_TAINTED; + re->extflags &= ~RXf_TAINTED; } #endif if (!PM_GETRE(pm)->prelen && PL_curpm) pm = PL_curpm; - else if (strEQ("\\s+", PM_GETRE(pm)->precomp)) - pm->op_pmflags |= PMf_WHITE; - else - pm->op_pmflags &= ~PMf_WHITE; - /* XXX runtime compiled output needs to move to the pad */ + +#if !defined(USE_ITHREADS) + /* can't change the optree at runtime either */ + /* PMf_KEEP is handled differently under threads to avoid these problems */ if (pm->op_pmflags & PMf_KEEP) { pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ -#if !defined(USE_ITHREADS) - /* XXX can't change the optree at runtime either */ cLOGOP->op_first->op_next = PL_op->op_next; -#endif } +#endif RETURN; } @@ -279,20 +272,19 @@ PP(pp_substcont) s = orig + (m - s); cx->sb_strend = s + (cx->sb_strend - m); } - cx->sb_m = m = rx->startp[0] + orig; + cx->sb_m = m = rx->offs[0].start + orig; if (m > s) { if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ)) sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv); else sv_catpvn(dstr, s, m-s); } - cx->sb_s = rx->endp[0] + orig; + cx->sb_s = rx->offs[0].end + orig; { /* Update the pos() information. */ SV * const sv = cx->sb_targ; MAGIC *mg; I32 i; - if (SvTYPE(sv) < SVt_PVMG) - SvUPGRADE(sv, SVt_PVMG); + SvUPGRADE(sv, SVt_PVMG); if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) { #ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW(sv)) @@ -310,7 +302,7 @@ PP(pp_substcont) (void)ReREFCNT_inc(rx); cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); rxres_save(&cx->sb_rxres, rx); - RETURNOP(pm->op_pmreplstart); + RETURNOP(pm->op_pmstashstartu.op_pmreplstart); } void @@ -346,8 +338,8 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) *p++ = PTR2UV(rx->subbeg); *p++ = (UV)rx->sublen; for (i = 0; i <= rx->nparens; ++i) { - *p++ = (UV)rx->startp[i]; - *p++ = (UV)rx->endp[i]; + *p++ = (UV)rx->offs[i].start; + *p++ = (UV)rx->offs[i].end; } } @@ -374,8 +366,8 @@ Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) rx->subbeg = INT2PTR(char*,*p++); rx->sublen = (I32)(*p++); for (i = 0; i <= rx->nparens; ++i) { - rx->startp[i] = (I32)(*p++); - rx->endp[i] = (I32)(*p++); + rx->offs[i].start = (I32)(*p++); + rx->offs[i].end = (I32)(*p++); } } @@ -2658,9 +2650,8 @@ S_save_lines(pTHX_ AV *array, SV *sv) while (s && s < send) { const char *t; - SV * const tmpstr = newSV(0); + SV * const tmpstr = newSV_type(SVt_PVMG); - sv_upgrade(tmpstr, SVt_PVMG); t = strchr(s, '\n'); if (t) t++; @@ -2874,7 +2865,6 @@ Perl_find_runcv(pTHX_ U32 *db_seqp) * outside is the lexically enclosing CV (if any) that invoked us. */ -/* With USE_5005THREADS, eval_owner must be held on entry to doeval */ STATIC OP * S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) { @@ -2888,8 +2878,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) PUSHMARK(SP); SAVESPTR(PL_compcv); - PL_compcv = (CV*)newSV(0); - sv_upgrade((SV *)PL_compcv, SVt_PVCV); + PL_compcv = (CV*)newSV_type(SVt_PVCV); CvEVAL_on(PL_compcv); assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); cxstack[cxstack_ix].blk_eval.cv = PL_compcv; @@ -2919,10 +2908,10 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) SAVESPTR(PL_unitcheckav); PL_unitcheckav = newAV(); SAVEFREESV(PL_unitcheckav); - SAVEI32(PL_error_count); + SAVEI8(PL_error_count); #ifdef PERL_MAD - SAVEI32(PL_madskills); + SAVEBOOL(PL_madskills); PL_madskills = 0; #endif @@ -2971,7 +2960,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) } else { if (!*msg) { - sv_setpv(ERRSV, "Compilation error"); + sv_setpvs(ERRSV, "Compilation error"); } } PERL_UNUSED_VAR(newsp); @@ -3093,7 +3082,7 @@ PP(pp_require) sv = new_version(sv); if (!sv_derived_from(PL_patchlevel, "version")) - upg_version(PL_patchlevel); + upg_version(PL_patchlevel, TRUE); if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) { if ( vcmp(sv,PL_patchlevel) <= 0 ) DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped", @@ -3105,7 +3094,18 @@ PP(pp_require) SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel))); } - RETPUSHYES; + /* If we request a version >= 5.9.5, load feature.pm with the + * feature bundle that corresponds to the required version. + * We do this only with use, not require. */ + if (PL_compcv && vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) { + SV *const importsv = vnormal(sv); + *SvPVX_mutable(importsv) = ':'; + ENTER; + Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL); + LEAVE; + } + + RETPUSHYES; } name = SvPV_const(sv, len); if (!(name && len > 0 && *name)) @@ -3276,7 +3276,7 @@ PP(pp_require) || (*name == ':' && name[1] != ':' && strchr(name+2, ':')) #endif ) { - const char *dir = SvPVx_nolen_const(dirsv); + const char *dir = SvPV_nolen_const(dirsv); #ifdef MACOS_TRADITIONAL char buf1[256]; char buf2[256]; @@ -3389,10 +3389,6 @@ PP(pp_require) PL_compiling.cop_warnings = pWARN_ALL ; else if (PL_dowarn & G_WARN_ALL_OFF) PL_compiling.cop_warnings = pWARN_NONE ; - else if (PL_taint_warn && !(PL_dowarn & G_WARN_ON)) { - PL_compiling.cop_warnings - = Perl_new_warnings_bitfield(aTHX_ NULL, WARN_TAINTstring, WARNsize); - } else PL_compiling.cop_warnings = pWARN_STD ; @@ -3449,6 +3445,7 @@ PP(pp_entereval) } sv = POPs; + TAINT_IF(SvTAINTED(sv)); TAINT_PROPER("eval"); ENTER; @@ -3507,7 +3504,7 @@ PP(pp_entereval) /* prepare to compile string */ if (PERLDB_LINE && PL_curstash != PL_debstash) - save_lines(CopFILEAV(&PL_compiling), PL_linestr); + save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr); PUTBACK; ret = doeval(gimme, NULL, runcv, seq); if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */ @@ -3619,7 +3616,6 @@ Perl_create_eval_scope(pTHX_ U32 flags) PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); PUSHEVAL(cx, 0, 0); - PL_eval_root = PL_op; /* Only needed so that goto works right. */ PL_in_eval = EVAL_INEVAL; if (flags & G_KEEPERR) @@ -3734,8 +3730,7 @@ PP(pp_leavegiven) } /* Helper routines used by pp_smartmatch */ -STATIC -PMOP * +STATIC PMOP * S_make_matcher(pTHX_ regexp *re) { dVAR; @@ -3748,8 +3743,7 @@ S_make_matcher(pTHX_ regexp *re) return matcher; } -STATIC -bool +STATIC bool S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) { dVAR; @@ -3763,8 +3757,7 @@ S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) return (SvTRUEx(POPs)); } -STATIC -void +STATIC void S_destroy_matcher(pTHX_ PMOP *matcher) { dVAR; @@ -3782,8 +3775,7 @@ PP(pp_smartmatch) /* This version of do_smartmatch() implements the * table of smart matches that is found in perlsyn. */ -STATIC -OP * +STATIC OP * S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) { dVAR;