X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/94fcd414575e04d8b809003ba7bca1216090abff..eb36cb72ef10b6174e7dbe1080bd1872ad79cd34:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index b512686..c596fdb 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -77,8 +77,7 @@ PP(pp_regcomp) dSP; register PMOP *pm = (PMOP*)cLOGOP->op_other; SV *tmpstr; - MAGIC *mg = NULL; - regexp * re; + REGEXP *re = NULL; /* prevent recompiling under /o and ithreads. */ #if defined(USE_ITHREADS) @@ -117,11 +116,11 @@ PP(pp_regcomp) if (SvROK(tmpstr)) { SV * const sv = SvRV(tmpstr); - if(SvMAGICAL(sv)) - mg = mg_find(sv, PERL_MAGIC_qr); + if (SvTYPE(sv) == SVt_REGEXP) + re = (REGEXP*) sv; } - if (mg) { - regexp * const re = reg_temp_copy((regexp *)mg->mg_obj); + if (re) { + re = reg_temp_copy(re); ReREFCNT_dec(PM_GETRE(pm)); PM_SETRE(pm, re); } @@ -129,16 +128,21 @@ PP(pp_regcomp) STRLEN len; const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : ""; re = PM_GETRE(pm); + assert (re != (REGEXP*) &PL_sv_undef); /* Check against the last compiled regexp. */ - if (!re || !re->precomp || re->prelen != (I32)len || - memNE(re->precomp, t, len)) + if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len || + memNE(RX_PRECOMP(re), t, len)) { - const regexp_engine *eng = re ? re->engine : NULL; + const regexp_engine *eng = re ? RX_ENGINE(re) : NULL; U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME; if (re) { ReREFCNT_dec(re); +#ifdef USE_ITHREADS + PM_SETRE(pm, (REGEXP*) &PL_sv_undef); +#else PM_SETRE(pm, NULL); /* crucial if regcomp aborts */ +#endif } else if (PL_curcop->cop_hints_hash) { SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0, "regcomp", 7, 0, 0); @@ -149,8 +153,17 @@ PP(pp_regcomp) if (PL_op->op_flags & OPf_SPECIAL) PL_reginterp_cnt = I32_MAX; /* Mark as safe. */ - if (DO_UTF8(tmpstr)) - pm_flags |= RXf_UTF8; + if (DO_UTF8(tmpstr)) { + assert (SvUTF8(tmpstr)); + } else if (SvUTF8(tmpstr)) { + /* Not doing UTF-8, despite what the SV says. Is this only if + we're trapped in use 'bytes'? */ + /* Make a copy of the octet sequence, but without the flag on, + as the compiler now honours the SvUTF8 flag on tmpstr. */ + STRLEN len; + const char *const p = SvPV(tmpstr, len); + tmpstr = newSVpvn_flags(p, len, SVs_TEMP); + } if (eng) PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags)); @@ -167,13 +180,13 @@ PP(pp_regcomp) #ifndef INCOMPLETE_TAINTS if (PL_tainting) { if (PL_tainted) - re->extflags |= RXf_TAINTED; + RX_EXTFLAGS(re) |= RXf_TAINTED; else - re->extflags &= ~RXf_TAINTED; + RX_EXTFLAGS(re) &= ~RXf_TAINTED; } #endif - if (!PM_GETRE(pm)->prelen && PL_curpm) + if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) pm = PL_curpm; @@ -254,7 +267,7 @@ PP(pp_substcont) SvPV_set(dstr, NULL); TAINT_IF(cx->sb_rxtainted & 1); - PUSHs(sv_2mortal(newSViv(saviters - 1))); + mPUSHi(saviters - 1); (void)SvPOK_only_UTF8(targ); TAINT_IF(cx->sb_rxtainted); @@ -267,21 +280,21 @@ PP(pp_substcont) } cx->sb_iters = saviters; } - if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { + if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) { m = s; s = orig; - cx->sb_orig = orig = rx->subbeg; + cx->sb_orig = orig = RX_SUBBEG(rx); s = orig + (m - s); cx->sb_strend = s + (cx->sb_strend - m); } - cx->sb_m = m = rx->offs[0].start + orig; + cx->sb_m = m = RX_OFFS(rx)[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->offs[0].end + orig; + cx->sb_s = RX_OFFS(rx)[0].end + orig; { /* Update the pos() information. */ SV * const sv = cx->sb_targ; MAGIC *mg; @@ -314,11 +327,11 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) U32 i; PERL_UNUSED_CONTEXT; - if (!p || p[1] < rx->nparens) { + if (!p || p[1] < RX_NPARENS(rx)) { #ifdef PERL_OLD_COPY_ON_WRITE - i = 7 + rx->nparens * 2; + i = 7 + RX_NPARENS(rx) * 2; #else - i = 6 + rx->nparens * 2; + i = 6 + RX_NPARENS(rx) * 2; #endif if (!p) Newx(p, i, UV); @@ -327,21 +340,21 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) *rsp = (void*)p; } - *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : NULL); + *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL); RX_MATCH_COPIED_off(rx); #ifdef PERL_OLD_COPY_ON_WRITE - *p++ = PTR2UV(rx->saved_copy); - rx->saved_copy = NULL; + *p++ = PTR2UV(RX_SAVED_COPY(rx)); + RX_SAVED_COPY(rx) = NULL; #endif - *p++ = rx->nparens; + *p++ = RX_NPARENS(rx); - *p++ = PTR2UV(rx->subbeg); - *p++ = (UV)rx->sublen; - for (i = 0; i <= rx->nparens; ++i) { - *p++ = (UV)rx->offs[i].start; - *p++ = (UV)rx->offs[i].end; + *p++ = PTR2UV(RX_SUBBEG(rx)); + *p++ = (UV)RX_SUBLEN(rx); + for (i = 0; i <= RX_NPARENS(rx); ++i) { + *p++ = (UV)RX_OFFS(rx)[i].start; + *p++ = (UV)RX_OFFS(rx)[i].end; } } @@ -357,19 +370,19 @@ Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) *p++ = 0; #ifdef PERL_OLD_COPY_ON_WRITE - if (rx->saved_copy) - SvREFCNT_dec (rx->saved_copy); - rx->saved_copy = INT2PTR(SV*,*p); + if (RX_SAVED_COPY(rx)) + SvREFCNT_dec (RX_SAVED_COPY(rx)); + RX_SAVED_COPY(rx) = INT2PTR(SV*,*p); *p++ = 0; #endif - rx->nparens = *p++; + RX_NPARENS(rx) = *p++; - rx->subbeg = INT2PTR(char*,*p++); - rx->sublen = (I32)(*p++); - for (i = 0; i <= rx->nparens; ++i) { - rx->offs[i].start = (I32)(*p++); - rx->offs[i].end = (I32)(*p++); + RX_SUBBEG(rx) = INT2PTR(char*,*p++); + RX_SUBLEN(rx) = (I32)(*p++); + for (i = 0; i <= RX_NPARENS(rx); ++i) { + RX_OFFS(rx)[i].start = (I32)(*p++); + RX_OFFS(rx)[i].end = (I32)(*p++); } } @@ -926,7 +939,7 @@ PP(pp_grepstart) if (PL_stack_base + *PL_markstack_ptr == SP) { (void)POPMARK; if (GIMME_V == G_SCALAR) - XPUSHs(sv_2mortal(newSViv(0))); + mXPUSHi(0); RETURNOP(PL_op->op_next->op_next); } PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1; @@ -1629,9 +1642,9 @@ PP(pp_caller) if (!stashname) PUSHs(&PL_sv_undef); else - PUSHs(sv_2mortal(newSVpv(stashname, 0))); - PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0))); - PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop)))); + mPUSHs(newSVpv(stashname, 0)); + mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0)); + mPUSHi((I32)CopLINE(cx->blk_oldcop)); if (!MAXARG) RETURN; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { @@ -1640,23 +1653,23 @@ PP(pp_caller) if (isGV(cvgv)) { SV * const sv = newSV(0); gv_efullname3(sv, cvgv, NULL); - PUSHs(sv_2mortal(sv)); - PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); + mPUSHs(sv); + mPUSHi((I32)cx->blk_sub.hasargs); } else { - PUSHs(sv_2mortal(newSVpvs("(unknown)"))); - PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); + PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP)); + mPUSHi((I32)cx->blk_sub.hasargs); } } else { - PUSHs(sv_2mortal(newSVpvs("(eval)"))); - PUSHs(sv_2mortal(newSViv(0))); + PUSHs(newSVpvs_flags("(eval)", SVs_TEMP)); + mPUSHi(0); } gimme = (I32)cx->blk_gimme; if (gimme == G_VOID) PUSHs(&PL_sv_undef); else - PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY))); + mPUSHi(gimme & G_ARRAY); if (CxTYPE(cx) == CXt_EVAL) { /* eval STRING */ if (cx->blk_eval.old_op_type == OP_ENTEREVAL) { @@ -1665,7 +1678,7 @@ PP(pp_caller) } /* require */ else if (cx->blk_eval.old_namesv) { - PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv))); + mPUSHs(newSVsv(cx->blk_eval.old_namesv)); PUSHs(&PL_sv_yes); } /* eval BLOCK (try blocks have old_namesv == 0) */ @@ -1699,7 +1712,7 @@ PP(pp_caller) /* XXX only hints propagated via op_private are currently * visible (others are not easily accessible, since they * use the global PL_hints) */ - PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop)))); + mPUSHi(CopHINTS_get(cx->blk_oldcop)); { SV * mask ; STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ; @@ -1722,7 +1735,7 @@ PP(pp_caller) } else mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]); - PUSHs(sv_2mortal(mask)); + mPUSHs(mask); } PUSHs(cx->blk_oldcop->cop_hints_hash ? @@ -1860,8 +1873,25 @@ PP(pp_enteriter) SvGETMAGIC(sv); SvGETMAGIC(right); if (RANGE_IS_NUMERIC(sv,right)) { - if ((SvOK(sv) && SvNV(sv) < IV_MIN) || - (SvOK(right) && SvNV(right) >= IV_MAX)) +#ifdef NV_PRESERVES_UV + if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) || + (SvNV(sv) > (NV)IV_MAX))) + || + (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) || + (SvNV(right) < (NV)IV_MIN)))) +#else + if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN) + || + ((SvNV(sv) > 0) && + ((SvUV(sv) > (UV)IV_MAX) || + (SvNV(sv) > (NV)UV_MAX))))) + || + (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN) + || + ((SvNV(right) > 0) && + ((SvUV(right) > (UV)IV_MAX) || + (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); @@ -2419,7 +2449,7 @@ PP(pp_goto) if (CvDEPTH(cv) < 2) SvREFCNT_inc_simple_void_NN(cv); else { - if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)) + if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)) sub_crush_depth(cv); pad_push(padlist, CvDEPTH(cv)); } @@ -2660,14 +2690,6 @@ S_save_lines(pTHX_ AV *array, SV *sv) } } -STATIC void -S_docatch_body(pTHX) -{ - dVAR; - CALLRUNOPS(aTHX); - return; -} - STATIC OP * S_docatch(pTHX_ OP *o) { @@ -2688,7 +2710,7 @@ S_docatch(pTHX_ OP *o) assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env; redo_body: - docatch_body(); + CALLRUNOPS(aTHX); break; case 3: /* die caught by an inner eval - continue inner loop */ @@ -3014,7 +3036,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) } STATIC PerlIO * -S_check_type_and_open(pTHX_ const char *name, const char *mode) +S_check_type_and_open(pTHX_ const char *name) { Stat_t st; const int st_rc = PerlLIO_stat(name, &st); @@ -3023,36 +3045,40 @@ S_check_type_and_open(pTHX_ const char *name, const char *mode) return NULL; } - return PerlIO_open(name, mode); + return PerlIO_open(name, PERL_SCRIPT_MODE); } +#ifndef PERL_DISABLE_PMC STATIC PerlIO * -S_doopen_pm(pTHX_ const char *name, const char *mode) +S_doopen_pm(pTHX_ const char *name, const STRLEN namelen) { -#ifndef PERL_DISABLE_PMC - const STRLEN namelen = strlen(name); PerlIO *fp; - if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) { - SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c'); - const char * const pmc = SvPV_nolen_const(pmcsv); + if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) { + SV *const pmcsv = newSV(namelen + 2); + char *const pmc = SvPVX(pmcsv); Stat_t pmcstat; + + memcpy(pmc, name, namelen); + pmc[namelen] = 'c'; + pmc[namelen + 1] = '\0'; + if (PerlLIO_stat(pmc, &pmcstat) < 0) { - fp = check_type_and_open(name, mode); + fp = check_type_and_open(name); } else { - fp = check_type_and_open(pmc, mode); + fp = check_type_and_open(pmc); } SvREFCNT_dec(pmcsv); } else { - fp = check_type_and_open(name, mode); + fp = check_type_and_open(name); } return fp; +} #else - return check_type_and_open(name, mode); +# define doopen_pm(name, namelen) check_type_and_open(name) #endif /* !PERL_DISABLE_PMC */ -} PP(pp_require) { @@ -3080,10 +3106,6 @@ PP(pp_require) sv = POPs; if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) { - if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */ - Perl_warner(aTHX_ packWARN(WARN_PORTABLE), - "v-string in use/require non-portable"); - sv = new_version(sv); if (!sv_derived_from(PL_patchlevel, "version")) upg_version(PL_patchlevel, TRUE); @@ -3133,10 +3155,11 @@ PP(pp_require) } } - /* 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) { + /* We do this only with use, not require. */ + if (PL_compcv && + /* If we request a version >= 5.9.5, load feature.pm with the + * feature bundle that corresponds to the required version. */ + vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) { SV *const importsv = vnormal(sv); *SvPVX_mutable(importsv) = ':'; ENTER; @@ -3188,7 +3211,7 @@ PP(pp_require) if (path_is_absolute(name)) { tryname = name; - tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE); + tryrsfp = doopen_pm(name, len); } #ifdef MACOS_TRADITIONAL if (!tryrsfp) { @@ -3197,7 +3220,7 @@ PP(pp_require) MacPerl_CanonDir(name, newname, 1); if (path_is_absolute(newname)) { tryname = newname; - tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE); + tryrsfp = doopen_pm(newname, strlen(newname)); } } #endif @@ -3208,7 +3231,7 @@ PP(pp_require) if (vms_unixname) #endif { - namesv = newSV(0); + namesv = newSV_type(SVt_PV); for (i = 0; i <= AvFILL(ar); i++) { SV * const dirsv = *av_fetch(ar, i, TRUE); @@ -3338,7 +3361,16 @@ PP(pp_require) || (*name == ':' && name[1] != ':' && strchr(name+2, ':')) #endif ) { - const char *dir = SvOK(dirsv) ? SvPV_nolen_const(dirsv) : ""; + const char *dir; + STRLEN dirlen; + + if (SvOK(dirsv)) { + dir = SvPV_const(dirsv, dirlen); + } else { + dir = ""; + dirlen = 0; + } + #ifdef MACOS_TRADITIONAL char buf1[256]; char buf2[256]; @@ -3366,13 +3398,32 @@ PP(pp_require) "%s\\%s", dir, name); # else - Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); + /* The equivalent of + Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); + but without the need to parse the format string, or + call strlen on either pointer, and with the correct + allocation up front. */ + { + char *tmp = SvGROW(namesv, dirlen + len + 2); + + memcpy(tmp, dir, dirlen); + tmp +=dirlen; + *tmp++ = '/'; + /* name came from an SV, so it will have a '\0' at the + end that we can copy as part of this memcpy(). */ + memcpy(tmp, name, len + 1); + + SvCUR_set(namesv, dirlen + len + 1); + + /* Don't even actually have to turn SvPOK_on() as we + access it directly with SvPVX() below. */ + } # endif # endif #endif TAINT_PROPER("require"); tryname = SvPVX_const(namesv); - tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE); + tryrsfp = doopen_pm(tryname, SvCUR(namesv)); if (tryrsfp) { if (tryname[0] == '.' && tryname[1] == '/') tryname += 2; @@ -3795,7 +3846,7 @@ PP(pp_leavegiven) /* Helper routines used by pp_smartmatch */ STATIC PMOP * -S_make_matcher(pTHX_ regexp *re) +S_make_matcher(pTHX_ REGEXP *re) { dVAR; PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED); @@ -3848,8 +3899,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) SV *e = TOPs; /* e is for 'expression' */ SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */ SV *This, *Other; /* 'This' (and Other to match) to play with C++ */ - MAGIC *mg; - regexp *this_regex, *other_regex; + REGEXP *this_regex, *other_regex; # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0) @@ -3864,24 +3914,22 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) && NOT_EMPTY_PROTO(This) && (Other = d))) # define SM_REGEX ( \ - (SvROK(d) && SvMAGICAL(This = SvRV(d)) \ - && (mg = mg_find(This, PERL_MAGIC_qr)) \ - && (this_regex = (regexp *)mg->mg_obj) \ + (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \ + && (this_regex = (REGEXP*) This) \ && (Other = e)) \ || \ - (SvROK(e) && SvMAGICAL(This = SvRV(e)) \ - && (mg = mg_find(This, PERL_MAGIC_qr)) \ - && (this_regex = (regexp *)mg->mg_obj) \ + (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \ + && (this_regex = (REGEXP*) This) \ && (Other = d)) ) # define SM_OTHER_REF(type) \ (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type) -# define SM_OTHER_REGEX (SvROK(Other) && SvMAGICAL(SvRV(Other)) \ - && (mg = mg_find(SvRV(Other), PERL_MAGIC_qr)) \ - && (other_regex = (regexp *)mg->mg_obj)) - +# define SM_OTHER_REGEX (SvROK(Other) \ + && (SvTYPE(SvRV(Other)) == SVt_REGEXP) \ + && (other_regex = (REGEXP*) SvRV(Other))) + # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \ sv_2mortal(newSViv(PTR2IV(sv))), 0) @@ -3990,23 +4038,19 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) AV * const other_av = (AV *) SvRV(Other); const I32 other_len = av_len(other_av) + 1; I32 i; - - if (HvUSEDKEYS((HV *) This) != other_len) - RETPUSHNO; - - for(i = 0; i < other_len; ++i) { + + for (i = 0; i < other_len; ++i) { SV ** const svp = av_fetch(other_av, i, FALSE); char *key; STRLEN key_len; - if (!svp) /* ??? When can this happen? */ - RETPUSHNO; - - key = SvPV(*svp, key_len); - if(!hv_exists((HV *) This, key, key_len)) - RETPUSHNO; + if (svp) { /* ??? When can this not happen? */ + key = SvPV(*svp, key_len); + if (hv_exists((HV *) This, key, key_len)) + RETPUSHYES; + } } - RETPUSHYES; + RETPUSHNO; } else if (SM_OTHER_REGEX) { PMOP * const matcher = make_matcher(other_regex); @@ -4648,7 +4692,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) DEFSV = upstream; PUSHMARK(SP); - PUSHs(sv_2mortal(newSViv(0))); + mPUSHi(0); if (filter_state) { PUSHs(filter_state); }