X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/6502358f02d6c4ea5159a32e117a91663131f6af..7d1023018d6df04126471b553a1871067b16348d:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 51180cf..c6ee3f7 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 (PM_GETRE(pm)->extflags & RXf_WHITE) - 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++); } } @@ -1467,7 +1459,8 @@ Perl_qerror(pTHX_ SV *err) sv_catsv(PL_errors, err); else Perl_warn(aTHX_ "%"SVf, SVfARG(err)); - ++PL_error_count; + if (PL_parser) + ++PL_parser->error_count; } OP * @@ -2658,9 +2651,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++; @@ -2754,7 +2746,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) STRLEN len; ENTER; - lex_start(sv); + lex_start(sv, NULL, FALSE); SAVETMPS; /* switch to eval mode */ @@ -2874,7 +2866,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 +2879,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,24 +2909,22 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) SAVESPTR(PL_unitcheckav); PL_unitcheckav = newAV(); SAVEFREESV(PL_unitcheckav); - SAVEI32(PL_error_count); #ifdef PERL_MAD - SAVEI32(PL_madskills); + SAVEBOOL(PL_madskills); PL_madskills = 0; #endif /* try to compile it */ PL_eval_root = NULL; - PL_error_count = 0; PL_curcop = &PL_compiling; CopARYBASE_set(PL_curcop, 0); if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL)) PL_in_eval |= EVAL_KEEPERR; else sv_setpvn(ERRSV,"",0); - if (yyparse() || PL_error_count || !PL_eval_root) { + if (yyparse() || PL_parser->error_count || !PL_eval_root) { SV **newsp; /* Used by POPBLOCK. */ PERL_CONTEXT *cx = &cxstack[cxstack_ix]; I32 optype = 0; /* Might be reset by POPEVAL. */ @@ -3020,7 +3008,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) CvDEPTH(PL_compcv) = 1; SP = PL_stack_base + POPMARK; /* pop original mark */ PL_op = saveop; /* The caller may need it. */ - PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */ + PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */ RETURNOP(PL_eval_start); } @@ -3093,7 +3081,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 +3093,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 +3275,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]; @@ -3377,11 +3376,8 @@ PP(pp_require) ENTER; SAVETMPS; - lex_start(NULL); - SAVEGENERICSV(PL_rsfp_filters); - PL_rsfp_filters = NULL; + lex_start(NULL, tryrsfp, TRUE); - PL_rsfp = tryrsfp; SAVEHINTS(); PL_hints = 0; SAVECOMPILEWARNINGS(); @@ -3445,10 +3441,11 @@ PP(pp_entereval) } sv = POPs; + TAINT_IF(SvTAINTED(sv)); TAINT_PROPER("eval"); ENTER; - lex_start(sv); + lex_start(sv, NULL, FALSE); SAVETMPS; /* switch to eval mode */ @@ -3503,7 +3500,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. */ @@ -3729,8 +3726,7 @@ PP(pp_leavegiven) } /* Helper routines used by pp_smartmatch */ -STATIC -PMOP * +STATIC PMOP * S_make_matcher(pTHX_ regexp *re) { dVAR; @@ -3743,8 +3739,7 @@ S_make_matcher(pTHX_ regexp *re) return matcher; } -STATIC -bool +STATIC bool S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) { dVAR; @@ -3758,8 +3753,7 @@ S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) return (SvTRUEx(POPs)); } -STATIC -void +STATIC void S_destroy_matcher(pTHX_ PMOP *matcher) { dVAR; @@ -3777,8 +3771,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; @@ -4522,7 +4515,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) /* I was having segfault trouble under Linux 2.2.5 after a parse error occured. (Had to hack around it with a test - for PL_error_count == 0.) Solaris doesn't segfault -- + for PL_parser->error_count == 0.) Solaris doesn't segfault -- not sure where the trouble is yet. XXX */ if (IoFMT_GV(datasv)) {