X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/c38a65302a7e2e2ea9b8748d368c87d573add6fd..2fdbfb4d61a8af78322ced14c20952a7b3b5761a:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 36f0963..85f8278 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, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 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. @@ -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++); } } @@ -1466,7 +1458,7 @@ Perl_qerror(pTHX_ SV *err) else if (PL_errors) sv_catsv(PL_errors, err); else - Perl_warn(aTHX_ "%"SVf, (void*)err); + Perl_warn(aTHX_ "%"SVf, SVfARG(err)); ++PL_error_count; } @@ -2028,7 +2020,7 @@ PP(pp_return) /* Unassume the success we assumed earlier. */ SV * const nsv = cx->blk_eval.old_namesv; (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD); - DIE(aTHX_ "%"SVf" did not return a true value", (void*)nsv); + DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv)); } break; case CXt_FORMAT: @@ -2336,7 +2328,7 @@ PP(pp_goto) goto retry; tmpstr = sv_newmortal(); gv_efullname3(tmpstr, gv, NULL); - DIE(aTHX_ "Goto undefined subroutine &%"SVf"",(void*)tmpstr); + DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr)); } DIE(aTHX_ "Goto undefined subroutine"); } @@ -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,19 +3082,30 @@ 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", - (void*)vnormal(sv), (void*)vnormal(PL_patchlevel)); + SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel))); } else { if ( vcmp(sv,PL_patchlevel) > 0 ) DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped", - (void*)vnormal(sv), (void*)vnormal(PL_patchlevel)); + 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]; @@ -3377,7 +3377,7 @@ PP(pp_require) ENTER; SAVETMPS; - lex_start(sv_2mortal(newSVpvs(""))); + lex_start(NULL); SAVEGENERICSV(PL_rsfp_filters); PL_rsfp_filters = NULL; @@ -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_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. */ @@ -3574,7 +3571,7 @@ PP(pp_leaveeval) /* Unassume the success we assumed earlier. */ SV * const nsv = cx->blk_eval.old_namesv; (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD); - retop = Perl_die(aTHX_ "%"SVf" did not return a true value", (void*)nsv); + retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv)); /* die_where() did LEAVE, or we won't be here */ } else { @@ -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;