X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/6e240d0bbb2875825a18bd4f02983684ddfefa5f..77e42cd2aa3aeb1b12b284fc71ecb17547b4a5c7:/pp_hot.c diff --git a/pp_hot.c b/pp_hot.c index 333c593..1155328 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -184,7 +184,7 @@ PP(pp_sassign) */ SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL, SvRV(cv)))); - SvREFCNT_dec(cv); + SvREFCNT_dec_NN(cv); LEAVE_with_name("sassign_coderef"); } else { /* What can happen for the corner case *{"BONK"} = \&{"BONK"}; @@ -207,7 +207,7 @@ PP(pp_sassign) assert(CvFLAGS(source) & CVf_CONST); SvREFCNT_inc_void(source); - SvREFCNT_dec(upgraded); + SvREFCNT_dec_NN(upgraded); SvRV_set(right, MUTABLE_SV(source)); } } @@ -322,15 +322,15 @@ PP(pp_concat) * I suspect that the mg_get is no longer needed, but while padav * differs, it can't share this function */ -void +STATIC void S_pushav(pTHX_ AV* const av) { dSP; - const I32 maxarg = AvFILL(av) + 1; + const SSize_t maxarg = AvFILL(av) + 1; EXTEND(SP, maxarg); if (SvRMAGICAL(av)) { - U32 i; - for (i=0; i < (U32)maxarg; i++) { + PADOFFSET i; + for (i=0; i < (PADOFFSET)maxarg; i++) { SV ** const svp = av_fetch(av, i, FALSE); /* See note in pp_helem, and bug id #27839 */ SP[i+1] = svp @@ -339,7 +339,11 @@ S_pushav(pTHX_ AV* const av) } } else { - Copy(AvARRAY(av), SP+1, maxarg, SV*); + PADOFFSET i; + for (i=0; i < (PADOFFSET)maxarg; i++) { + SV * const sv = AvARRAY(av)[i]; + SP[i+1] = sv ? sv : &PL_sv_undef; + } } SP += maxarg; PUTBACK; @@ -376,8 +380,11 @@ PP(pp_padrange) | SAVEt_CLEARPADRANGE); assert(OPpPADRANGE_COUNTMASK + 1 == (1 <> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base); - SSCHECK(1); - SSPUSHUV(payload); + { + dSS_ADD; + SS_ADD_UV(payload); + SS_ADD_END(1); + } for (i = 0; i op_type == OP_SAY @@ -917,7 +924,7 @@ PP(pp_rv2av) } else if (gimme == G_SCALAR) { dTARGET; - const I32 maxarg = AvFILL(av) + 1; + const SSize_t maxarg = AvFILL(av) + 1; SETi(maxarg); } } else { @@ -947,22 +954,19 @@ PP(pp_rv2av) } STATIC void -S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) +S_do_oddball(pTHX_ SV **oddkey, SV **firstkey) { dVAR; PERL_ARGS_ASSERT_DO_ODDBALL; - if (*relem) { - SV *tmpstr; - const HE *didstore; - + if (*oddkey) { if (ckWARN(WARN_MISC)) { const char *err; - if (relem == firstrelem && - SvROK(*relem) && - (SvTYPE(SvRV(*relem)) == SVt_PVAV || - SvTYPE(SvRV(*relem)) == SVt_PVHV)) + if (oddkey == firstkey && + SvROK(*oddkey) && + (SvTYPE(SvRV(*oddkey)) == SVt_PVAV || + SvTYPE(SvRV(*oddkey)) == SVt_PVHV)) { err = "Reference found where even-sized list expected"; } @@ -971,15 +975,6 @@ S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err); } - tmpstr = newSV(0); - didstore = hv_store_ent(hash,*relem,tmpstr,0); - if (SvMAGICAL(hash)) { - if (SvSMAGICAL(tmpstr)) - mg_set(tmpstr); - if (!didstore) - sv_2mortal(tmpstr); - } - TAINT_NOT; } } @@ -999,13 +994,14 @@ PP(pp_aassign) I32 gimme; HV *hash; - I32 i; + SSize_t i; int magic; - int duplicates = 0; - SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */ + U32 lval = 0; PL_delaymagic = DM_DELAY; /* catch simultaneous items */ gimme = GIMME_V; + if (gimme == G_ARRAY) + lval = PL_op->op_flags & OPf_MOD || LVRET; /* If there's a common identifier on both sides we have to take * special care that assigning the identifier on the left doesn't @@ -1063,8 +1059,8 @@ PP(pp_aassign) i = 0; while (relem <= lastrelem) { /* gobble up all the rest */ SV **didstore; - assert(*relem); - SvGETMAGIC(*relem); /* before newSV, in case it dies */ + if (*relem) + SvGETMAGIC(*relem); /* before newSV, in case it dies */ sv = newSV(0); sv_setsv_nomg(sv, *relem); *(relem++) = sv; @@ -1083,48 +1079,76 @@ PP(pp_aassign) break; case SVt_PVHV: { /* normal hash */ SV *tmpstr; + int odd; + int duplicates = 0; SV** topelem = relem; + SV **firsthashrelem = relem; hash = MUTABLE_HV(sv); magic = SvMAGICAL(hash) != 0; + + odd = ((lastrelem - firsthashrelem)&1)? 0 : 1; + if ( odd ) { + do_oddball(lastrelem, firsthashrelem); + /* we have firstlelem to reuse, it's not needed anymore + */ + *(lastrelem+1) = &PL_sv_undef; + } + ENTER; SAVEFREESV(SvREFCNT_inc_simple_NN(sv)); hv_clear(hash); - firsthashrelem = relem; - - while (relem < lastrelem) { /* gobble up all the rest */ + while (relem < lastrelem+odd) { /* gobble up all the rest */ HE *didstore; - sv = *relem ? *relem : &PL_sv_no; - relem++; - tmpstr = sv_newmortal(); - if (*relem) - sv_setsv(tmpstr,*relem); /* value */ + assert(*relem); + /* Copy the key if aassign is called in lvalue context, + to avoid having the next op modify our rhs. Copy + it also if it is gmagical, lest it make the + hv_store_ent call below croak, leaking the value. */ + sv = lval || SvGMAGICAL(*relem) + ? sv_mortalcopy(*relem) + : *relem; relem++; - if (gimme != G_VOID) { + assert(*relem); + SvGETMAGIC(*relem); + tmpstr = newSV(0); + sv_setsv_nomg(tmpstr,*relem++); /* value */ + if (gimme == G_ARRAY) { if (hv_exists_ent(hash, sv, 0)) /* key overwrites an existing entry */ duplicates += 2; - else - if (gimme == G_ARRAY) { + else { /* copy element back: possibly to an earlier - * stack location if we encountered dups earlier */ + * stack location if we encountered dups earlier, + * possibly to a later stack location if odd */ *topelem++ = sv; *topelem++ = tmpstr; } } didstore = hv_store_ent(hash,sv,tmpstr,0); - if (didstore) SvREFCNT_inc_simple_void_NN(tmpstr); if (magic) { - if (SvSMAGICAL(tmpstr)) - mg_set(tmpstr); - } + if (!didstore) sv_2mortal(tmpstr); + SvSETMAGIC(tmpstr); + } TAINT_NOT; } - if (relem == lastrelem) { - do_oddball(hash, relem, firstrelem); - relem++; - } LEAVE; + if (duplicates && gimme == G_ARRAY) { + /* at this point we have removed the duplicate key/value + * pairs from the stack, but the remaining values may be + * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed + * the (a 2), but the stack now probably contains + * (a b 3), because { hv_save(a,1); hv_save(a,2) } + * obliterates the earlier key. So refresh all values. */ + lastrelem -= duplicates; + relem = firsthashrelem; + while (relem < lastrelem+odd) { + HE *he; + he = hv_fetch_ent(hash, *relem++, 0, 0); + *relem++ = (he ? HeVAL(he) : &PL_sv_undef); + } + } + if (odd && gimme == G_ARRAY) lastrelem++; } break; default: @@ -1153,10 +1177,10 @@ PP(pp_aassign) } if (PL_delaymagic & ~DM_DELAY) { /* Will be used to set PL_tainting below */ - UV tmp_uid = PerlProc_getuid(); - UV tmp_euid = PerlProc_geteuid(); - UV tmp_gid = PerlProc_getgid(); - UV tmp_egid = PerlProc_getegid(); + Uid_t tmp_uid = PerlProc_getuid(); + Uid_t tmp_euid = PerlProc_geteuid(); + Gid_t tmp_gid = PerlProc_getgid(); + Gid_t tmp_egid = PerlProc_getegid(); if (PL_delaymagic & DM_UID) { #ifdef HAS_SETRESUID @@ -1223,6 +1247,12 @@ PP(pp_aassign) tmp_egid = PerlProc_getegid(); } TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) ); +#ifdef NO_TAINT_SUPPORT + PERL_UNUSED_VAR(tmp_uid); + PERL_UNUSED_VAR(tmp_euid); + PERL_UNUSED_VAR(tmp_gid); + PERL_UNUSED_VAR(tmp_egid); +#endif } PL_delaymagic = 0; @@ -1231,35 +1261,19 @@ PP(pp_aassign) else if (gimme == G_SCALAR) { dTARGET; SP = firstrelem; - SETi(lastrelem - firstrelem + 1 - duplicates); + SETi(lastrelem - firstrelem + 1); } else { - if (ary) - SP = lastrelem; - else if (hash) { - if (duplicates) { - /* at this point we have removed the duplicate key/value - * pairs from the stack, but the remaining values may be - * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed - * the (a 2), but the stack now probably contains - * (a b 3), because { hv_save(a,1); hv_save(a,2) } - * obliterates the earlier key. So refresh all values. */ - lastrelem -= duplicates; - relem = firsthashrelem; - while (relem < lastrelem) { - HE *he; - sv = *relem++; - he = hv_fetch_ent(hash, sv, 0, 0); - *relem++ = (he ? HeVAL(he) : &PL_sv_undef); - } - } + if (ary || hash) + /* note that in this case *firstlelem may have been overwritten + by sv_undef in the odd hash case */ SP = lastrelem; - } - else + else { SP = firstrelem + (lastlelem - firstlelem); - lelem = firstlelem + (relem - firstrelem); - while (relem <= SP) - *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef; + lelem = firstlelem + (relem - firstrelem); + while (relem <= SP) + *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef; + } } RETURN; @@ -1288,12 +1302,12 @@ PP(pp_qr) cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv); if ((cv = *cvp) && CvCLONE(*cvp)) { *cvp = cv_clone(cv); - SvREFCNT_dec(cv); + SvREFCNT_dec_NN(cv); } if (pkg) { HV *const stash = gv_stashsv(pkg, GV_ADD); - SvREFCNT_dec(pkg); + SvREFCNT_dec_NN(pkg); (void)sv_bless(rv, stash); } @@ -1310,21 +1324,19 @@ PP(pp_match) dVAR; dSP; dTARG; PMOP *pm = cPMOP; PMOP *dynpm = pm; - const char *t; const char *s; const char *strend; + SSize_t curpos = 0; /* initial pos() or current $+[0] */ I32 global; - U8 r_flags = REXEC_CHECKED; + U8 r_flags = 0; const char *truebase; /* Start of string */ REGEXP *rx = PM_GETRE(pm); bool rxtainted; const I32 gimme = GIMME; STRLEN len; - I32 minmatch = 0; const I32 oldsave = PL_savestack_ix; - I32 update_minmatch = 1; I32 had_zerolen = 0; - U32 gpos = 0; + MAGIC *mg = NULL; if (PL_op->op_flags & OPf_STACKED) TARG = POPs; @@ -1338,18 +1350,16 @@ PP(pp_match) PUTBACK; /* EVAL blocks need stack_sp. */ /* Skip get-magic if this is a qr// clone, because regcomp has already done it. */ - s = ReANY(rx)->mother_re + truebase = ReANY(rx)->mother_re ? SvPV_nomg_const(TARG, len) : SvPV_const(TARG, len); - if (!s) + if (!truebase) DIE(aTHX_ "panic: pp_match"); - strend = s + len; + strend = truebase + len; rxtainted = (RX_ISTAINTED(rx) || (TAINT_get && (pm->op_pmflags & PMf_RETAINT))); TAINT_NOT; - RX_MATCH_UTF8_set(rx, DO_UTF8(TARG)); - /* We need to know this in case we fail out early - pos() must be reset */ global = dynpm->op_pmflags & PMf_GLOBAL; @@ -1373,37 +1383,29 @@ PP(pp_match) rx = PM_GETRE(pm); } - if (RX_MINLEN(rx) > (I32)len) { - DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match\n")); + if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) { + DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%" + UVuf" < %"IVdf")\n", + (UV)len, (IV)RX_MINLEN(rx))); goto nope; } - truebase = t = s; - - /* XXXX What part of this is needed with true \G-support? */ + /* get pos() if //g */ if (global) { - RX_OFFS(rx)[0].start = -1; - if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { - MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global); - if (mg && mg->mg_len >= 0) { - if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN)) - RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len; - else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) { - r_flags |= REXEC_IGNOREPOS; - RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len; - } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT) - gpos = mg->mg_len; - else - RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len; - minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0; - update_minmatch = 0; - } - } + mg = mg_find_mglob(TARG); + if (mg && mg->mg_len >= 0) { + curpos = MgBYTEPOS(mg, TARG, truebase, len); + /* last time pos() was set, it was zero-length match */ + if (mg->mg_flags & MGf_MINMATCH) + had_zerolen = 1; + } } + #ifdef PERL_SAWAMPERSAND if ( RX_NPARENS(rx) || PL_sawampersand || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) + || (dynpm->op_pmflags & PMf_KEEPCOPY) ) #endif { @@ -1415,51 +1417,54 @@ PP(pp_match) if (! (global && gimme == G_ARRAY)) r_flags |= REXEC_COPY_SKIP_POST; }; - - play_it_again: - if (global && RX_OFFS(rx)[0].start != -1) { - t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx); - if ((s + RX_MINLEN(rx)) > strend || s < truebase) { - DEBUG_r(PerlIO_printf(Perl_debug_log, "Regex match can't succeed, so not even tried\n")); - goto nope; - } - if (update_minmatch++) - minmatch = had_zerolen; - } - if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT && - DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) { - /* FIXME - can PL_bostr be made const char *? */ - PL_bostr = (char *)truebase; - s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL); - - if (!s) - goto nope; #ifdef PERL_SAWAMPERSAND - if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL) - && !PL_sawampersand - && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) - && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */ - goto yup; + if (dynpm->op_pmflags & PMf_KEEPCOPY) + /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */ + r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST); #endif - } + + s = truebase; + + play_it_again: + if (global) + s = truebase + curpos; + if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, - minmatch, TARG, NUM2PTR(void*, gpos), r_flags)) - goto ret_no; + had_zerolen, TARG, NULL, r_flags)) + goto nope; PL_curpm = pm; - if (dynpm->op_pmflags & PMf_ONCE) { + if (dynpm->op_pmflags & PMf_ONCE) #ifdef USE_ITHREADS SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]); #else dynpm->op_pmflags |= PMf_USED; #endif - } - gotcha: if (rxtainted) RX_MATCH_TAINTED_on(rx); TAINT_IF(RX_MATCH_TAINTED(rx)); - if (gimme == G_ARRAY) { + + /* update pos */ + + if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) { + if (!mg) + mg = sv_magicext_mglob(TARG); + MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end); + if (RX_ZERO_LEN(rx)) + mg->mg_flags |= MGf_MINMATCH; + else + mg->mg_flags &= ~MGf_MINMATCH; + } + + if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) { + LEAVE_SCOPE(oldsave); + RETPUSHYES; + } + + /* push captures on stack */ + + { const I32 nparens = RX_NPARENS(rx); I32 i = (global && !nparens) ? 1 : 0; @@ -1470,7 +1475,7 @@ PP(pp_match) PUSHs(sv_newmortal()); if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) { const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start; - s = RX_OFFS(rx)[i].start + truebase; + const char * const s = RX_OFFS(rx)[i].start + truebase; if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 || len < 0 || len > strend - s) DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, " @@ -1483,152 +1488,23 @@ PP(pp_match) } } if (global) { - if (dynpm->op_pmflags & PMf_CONTINUE) { - MAGIC* mg = NULL; - if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) - mg = mg_find(TARG, PERL_MAGIC_regex_global); - if (!mg) { -#ifdef PERL_OLD_COPY_ON_WRITE - if (SvIsCOW(TARG)) - sv_force_normal_flags(TARG, 0); -#endif - mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global, - &PL_vtbl_mglob, NULL, 0); - } - if (RX_OFFS(rx)[0].start != -1) { - mg->mg_len = RX_OFFS(rx)[0].end; - if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end) - mg->mg_flags |= MGf_MINMATCH; - else - mg->mg_flags &= ~MGf_MINMATCH; - } - } - had_zerolen = (RX_OFFS(rx)[0].start != -1 - && (RX_OFFS(rx)[0].start + RX_GOFS(rx) - == (UV)RX_OFFS(rx)[0].end)); + curpos = (UV)RX_OFFS(rx)[0].end; + had_zerolen = RX_ZERO_LEN(rx); PUTBACK; /* EVAL blocks may use stack */ r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; goto play_it_again; } - else if (!nparens) - XPUSHs(&PL_sv_yes); LEAVE_SCOPE(oldsave); RETURN; } - else { - if (global) { - MAGIC* mg; - if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) - mg = mg_find(TARG, PERL_MAGIC_regex_global); - else - mg = NULL; - if (!mg) { -#ifdef PERL_OLD_COPY_ON_WRITE - if (SvIsCOW(TARG)) - sv_force_normal_flags(TARG, 0); -#endif - mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global, - &PL_vtbl_mglob, NULL, 0); - } - if (RX_OFFS(rx)[0].start != -1) { - mg->mg_len = RX_OFFS(rx)[0].end; - if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end) - mg->mg_flags |= MGf_MINMATCH; - else - mg->mg_flags &= ~MGf_MINMATCH; - } - } - LEAVE_SCOPE(oldsave); - RETPUSHYES; - } - -#ifdef PERL_SAWAMPERSAND -yup: /* Confirmed by INTUIT */ -#endif - if (rxtainted) - RX_MATCH_TAINTED_on(rx); - TAINT_IF(RX_MATCH_TAINTED(rx)); - PL_curpm = pm; - if (dynpm->op_pmflags & PMf_ONCE) { -#ifdef USE_ITHREADS - SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]); -#else - dynpm->op_pmflags |= PMf_USED; -#endif - } - if (RX_MATCH_COPIED(rx)) - Safefree(RX_SUBBEG(rx)); - RX_MATCH_COPIED_off(rx); - RX_SUBBEG(rx) = NULL; - if (global) { - /* FIXME - should rx->subbeg be const char *? */ - RX_SUBBEG(rx) = (char *) truebase; - RX_SUBOFFSET(rx) = 0; - RX_SUBCOFFSET(rx) = 0; - RX_OFFS(rx)[0].start = s - truebase; - if (RX_MATCH_UTF8(rx)) { - char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx)); - RX_OFFS(rx)[0].end = t - truebase; - } - else { - RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx); - } - RX_SUBLEN(rx) = strend - truebase; - goto gotcha; - } -#ifdef PERL_SAWAMPERSAND - if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) -#endif - { - I32 off; -#ifdef PERL_ANY_COW - if (SvCANCOW(TARG)) { - if (DEBUG_C_TEST) { - PerlIO_printf(Perl_debug_log, - "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n", - (int) SvTYPE(TARG), (void*)truebase, (void*)t, - (int)(t-truebase)); - } - RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG); - RX_SUBBEG(rx) - = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase); - assert (SvPOKp(RX_SAVED_COPY(rx))); - } else -#endif - { - - RX_SUBBEG(rx) = savepvn(t, strend - t); -#ifdef PERL_ANY_COW - RX_SAVED_COPY(rx) = NULL; -#endif - } - RX_SUBLEN(rx) = strend - t; - RX_SUBOFFSET(rx) = 0; - RX_SUBCOFFSET(rx) = 0; - RX_MATCH_COPIED_on(rx); - off = RX_OFFS(rx)[0].start = s - t; - RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx); - } -#ifdef PERL_SAWAMPERSAND - else { /* startp/endp are used by @- @+. */ - RX_OFFS(rx)[0].start = s - truebase; - RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx); - } -#endif - /* match via INTUIT shouldn't have any captures. Let @-, @+, $^N know */ - assert(!RX_NPARENS(rx)); - RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; - LEAVE_SCOPE(oldsave); - RETPUSHYES; + /* NOTREACHED */ nope: -ret_no: if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) { - if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { - MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global); - if (mg) - mg->mg_len = -1; - } + if (!mg) + mg = mg_find_mglob(TARG); + if (mg) + mg->mg_len = -1; } LEAVE_SCOPE(oldsave); if (gimme == G_ARRAY) @@ -1651,7 +1527,7 @@ Perl_do_readline(pTHX) if (io) { const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0); + Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0); if (gimme == G_SCALAR) { SPAGAIN; SvSetSV_nosteal(TARG, TOPs); @@ -1693,14 +1569,10 @@ Perl_do_readline(pTHX) } if (!fp) { if ((!io || !(IoFLAGS(io) & IOf_START)) - && ckWARN2(WARN_GLOB, WARN_CLOSED)) + && ckWARN(WARN_CLOSED) + && type != OP_GLOB) { - if (type == OP_GLOB) - Perl_ck_warner_d(aTHX_ packWARN(WARN_GLOB), - "glob failed (can't start child: %s)", - Strerror(errno)); - else - report_evil_fh(PL_last_in_gv); + report_evil_fh(PL_last_in_gv); } if (gimme == G_SCALAR) { /* undef TARG, and push that undefined value */ @@ -1809,7 +1681,7 @@ Perl_do_readline(pTHX) } } for (t1 = SvPVX_const(sv); *t1; t1++) - if (!isALNUMC(*t1) && + if (!isALPHANUMERIC(*t1) && strchr("$&*(){}[]'\";\\|?<>~`", *t1)) break; if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) { @@ -1887,7 +1759,7 @@ PP(pp_helem) sv_upgrade(lv, SVt_PVLV); LvTYPE(lv) = 'y'; sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0); - SvREFCNT_dec(key2); /* sv_magic() increments refcount */ + SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */ LvTARG(lv) = SvREFCNT_inc_simple(hv); LvTARGLEN(lv) = 1; PUSHs(lv); @@ -1961,7 +1833,7 @@ PP(pp_iter) * completely new SV for closures/references to work as * they used to */ *itersvp = newSVsv(cur); - SvREFCNT_dec(oldsv); + SvREFCNT_dec_NN(oldsv); } if (strEQ(SvPVX_const(cur), max)) sv_setiv(cur, 0); /* terminate next time */ @@ -1988,7 +1860,7 @@ PP(pp_iter) * completely new SV for closures/references to work as they * used to */ *itersvp = newSViv(cur); - SvREFCNT_dec(oldsv); + SvREFCNT_dec_NN(oldsv); } if (cur == IV_MAX) { @@ -2035,22 +1907,19 @@ PP(pp_iter) *itersvp = NULL; Perl_croak(aTHX_ "Use of freed value in iteration"); } - SvTEMP_off(sv); - SvREFCNT_inc_simple_void_NN(sv); + if (SvPADTMP(sv) && !IS_PADGV(sv)) + sv = newSVsv(sv); + else { + SvTEMP_off(sv); + SvREFCNT_inc_simple_void_NN(sv); + } + } + else if (!av_is_stack) { + sv = newSVavdefelem(av, ix, 0); } else sv = &PL_sv_undef; - if (!av_is_stack && sv == &PL_sv_undef) { - SV *lv = newSV_type(SVt_PVLV); - LvTYPE(lv) = 'y'; - sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0); - LvTARG(lv) = SvREFCNT_inc_simple(av); - LvTARGOFF(lv) = ix; - LvTARGLEN(lv) = (STRLEN)UV_MAX; - sv = lv; - } - oldsv = *itersvp; *itersvp = sv; SvREFCNT_dec(oldsv); @@ -2080,12 +1949,11 @@ the pattern is marked as tainted. This means that subsequent usage, such as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED, on the new pattern too. -During execution of a pattern, locale-variant ops such as ALNUML set the -local flag RF_tainted. At the end of execution, the engine sets the -RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it -otherwise. +At the start of execution of a pattern, the RXf_TAINTED_SEEN flag on the +regex is cleared; during execution, locale-variant ops such as POSIXL may +set RXf_TAINTED_SEEN. -In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code +RXf_TAINTED_SEEN is used post-execution by the get magic code of $1 et al to indicate whether the returned value should be tainted. It is the responsibility of the caller of the pattern (i.e. pp_match, pp_subst etc) to set this flag for any other circumstances where $1 needs @@ -2142,13 +2010,10 @@ PP(pp_subst) PMOP *rpm = pm; char *s; char *strend; - char *m; const char *c; - char *d; STRLEN clen; I32 iters = 0; I32 maxiters; - I32 i; bool once; U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits. See "how taint works" above */ @@ -2188,9 +2053,6 @@ PP(pp_subst) sv_force_normal_flags(TARG,0); #endif if (!(rpm->op_pmflags & PMf_NONDESTRUCT) -#ifdef PERL_ANY_COW - && !is_cow -#endif && (SvREADONLY(TARG) || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG)) || SvTYPE(TARG) > SVt_PVLV) @@ -2198,7 +2060,10 @@ PP(pp_subst) Perl_croak_no_modify(); PUTBACK; - s = SvPV_nomg(TARG, len); + orig = SvPV_nomg(TARG, len); + /* note we don't (yet) force the var into being a string; if we fail + * to match, we leave as-is; on successful match howeverm, we *will* + * coerce into a string, then repeat the match */ if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG)) force_on_match = 1; @@ -2216,14 +2081,12 @@ PP(pp_subst) TAINT_NOT; } - RX_MATCH_UTF8_set(rx, DO_UTF8(TARG)); - force_it: - if (!pm || !s) - DIE(aTHX_ "panic: pp_subst, pm=%p, s=%p", pm, s); + if (!pm || !orig) + DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig); - strend = s + len; - slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len; + strend = orig + len; + slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len; maxiters = 2 * slen + 10; /* We can match twice at each position, once with zero-length, second time with non-zero. */ @@ -2238,6 +2101,7 @@ PP(pp_subst) r_flags = ( RX_NPARENS(rx) || PL_sawampersand || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) + || (rpm->op_pmflags & PMf_KEEPCOPY) ) ? REXEC_COPY_STR : 0; @@ -2245,31 +2109,13 @@ PP(pp_subst) r_flags = REXEC_COPY_STR; #endif - orig = m = s; - if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) { - PL_bostr = orig; - s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL); - - if (!s) - goto ret_no; - /* How to do it in subst? */ -/* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL) - && !PL_sawampersand - && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)) - goto yup; -*/ - } - - if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL, - r_flags | REXEC_CHECKED)) + if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags)) { - ret_no: SPAGAIN; PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no); LEAVE_SCOPE(oldsave); RETURN; } - PL_curpm = pm; /* known replacement string? */ @@ -2304,8 +2150,11 @@ PP(pp_subst) && !is_cow #endif && (I32)clen <= RX_MINLENRET(rx) - && (once || !(r_flags & REXEC_COPY_STR)) - && !(RX_EXTFLAGS(rx) & (RXf_LOOKBEHIND_SEEN|RXf_MODIFIES_VARS)) + && ( once + || !(r_flags & REXEC_COPY_STR) + || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN)) + ) + && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST) && (!doutf8 || SvUTF8(TARG)) && !(rpm->op_pmflags & PMf_NONDESTRUCT)) { @@ -2318,18 +2167,22 @@ PP(pp_subst) } #endif if (force_on_match) { + /* redo the first match, this time with the orig var + * forced into being a string */ force_on_match = 0; - s = SvPV_force_nomg(TARG, len); + orig = SvPV_force_nomg(TARG, len); goto force_it; } - d = s; + if (once) { + char *d, *m; if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ rxtainted |= SUBST_TAINT_PAT; m = orig + RX_OFFS(rx)[0].start; d = orig + RX_OFFS(rx)[0].end; s = orig; if (m - s > strend - d) { /* faster to shorten from end */ + I32 i; if (clen) { Copy(c, m, clen, char); m += clen; @@ -2342,27 +2195,23 @@ PP(pp_subst) *m = '\0'; SvCUR_set(TARG, m - s); } - else if ((i = m - s)) { /* faster from front */ + else { /* faster from front */ + I32 i = m - s; d -= clen; - m = d; - Move(s, d - i, i, char); + if (i > 0) + Move(s, d - i, i, char); sv_chop(TARG, d-i); if (clen) - Copy(c, m, clen, char); - } - else if (clen) { - d -= clen; - sv_chop(TARG, d); - Copy(c, d, clen, char); - } - else { - sv_chop(TARG, d); + Copy(c, d, clen, char); } SPAGAIN; PUSHs(&PL_sv_yes); } else { + char *d, *m; + d = s = RX_OFFS(rx)[0].start + orig; do { + I32 i; if (iters++ > maxiters) DIE(aTHX_ "Substitution loop"); if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ @@ -2378,12 +2227,12 @@ PP(pp_subst) d += clen; } s = RX_OFFS(rx)[0].end + orig; - } while (CALLREGEXEC(rx, s, strend, orig, s == m, + } while (CALLREGEXEC(rx, s, strend, orig, + s == m, /* don't match same null twice */ TARG, NULL, - /* don't match same null twice */ - REXEC_NOT_FIRST|REXEC_IGNOREPOS)); + REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW)); if (s != d) { - i = strend - s; + I32 i = strend - s; SvCUR_set(TARG, d - SvPVX_const(TARG) + i); Move(s, d, i+1, char); /* include the NUL */ } @@ -2393,8 +2242,11 @@ PP(pp_subst) } else { bool first; + char *m; SV *repl; if (force_on_match) { + /* redo the first match, this time with the orig var + * forced into being a string */ force_on_match = 0; if (rpm->op_pmflags & PMf_NONDESTRUCT) { /* I feel that it should be possible to avoid this mortal copy @@ -2404,7 +2256,7 @@ PP(pp_subst) cases where it would be viable to drop into the copy code. */ TARG = sv_2mortal(newSVsv(TARG)); } - s = SvPV_force_nomg(TARG, len); + orig = SvPV_force_nomg(TARG, len); goto force_it; } #ifdef PERL_ANY_COW @@ -2413,10 +2265,13 @@ PP(pp_subst) if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ rxtainted |= SUBST_TAINT_PAT; repl = dstr; - dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0)); + s = RX_OFFS(rx)[0].start + orig; + dstr = newSVpvn_flags(orig, s-orig, + SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0)); if (!c) { PERL_CONTEXT *cx; SPAGAIN; + m = orig; /* note that a whole bunch of local vars are saved here for * use by pp_substcont: here's a list of them in case you're * searching for places in this sub that uses a particular var: @@ -2425,7 +2280,6 @@ PP(pp_subst) PUSHSUBST(cx); RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot); } - r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; first = TRUE; do { if (iters++ > maxiters) @@ -2433,12 +2287,13 @@ PP(pp_subst) if (RX_MATCH_TAINTED(rx)) rxtainted |= SUBST_TAINT_PAT; if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) { - m = s; - s = orig; + char *old_s = s; + char *old_orig = orig; assert(RX_SUBOFFSET(rx) == 0); + orig = RX_SUBBEG(rx); - s = orig + (m - s); - strend = s + (strend - m); + s = orig + (old_s - old_orig); + strend = s + (strend - old_s); } m = RX_OFFS(rx)[0].start + orig; sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG)); @@ -2463,7 +2318,8 @@ PP(pp_subst) if (once) break; } while (CALLREGEXEC(rx, s, strend, orig, s == m, - TARG, NULL, r_flags)); + TARG, NULL, + REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW)); sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG)); if (rpm->op_pmflags & PMf_NONDESTRUCT) { @@ -2570,6 +2426,10 @@ PP(pp_grepwhile) SAVEVPTR(PL_curpm); src = PL_stack_base[*PL_markstack_ptr]; + if (SvPADTMP(src) && !IS_PADGV(src)) { + src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src); + PL_tmps_floor++; + } SvTEMP_off(src); if (PL_op->op_private & OPpGREP_LEX) PAD_SVl(PL_op->op_targ) = src; @@ -2611,7 +2471,7 @@ PP(pp_leavesub) sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */ FREETMPS; *MARK = sv_mortalcopy(sv); - SvREFCNT_dec(sv); + SvREFCNT_dec_NN(sv); } } else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1 @@ -2639,8 +2499,8 @@ PP(pp_leavesub) PUTBACK; LEAVE; - cxstack_ix--; POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ + cxstack_ix--; PL_curpm = newpm; /* ... and pop $1 et al */ LEAVESUB(sv); @@ -2715,7 +2575,6 @@ PP(pp_entersub) } ENTER; - SAVETMPS; retry: if (CvCLONE(cv) && ! CvCLONED(cv)) @@ -2777,7 +2636,7 @@ try_autoload: if (!(CvISXSUB(cv))) { /* This path taken at least 75% of the time */ dMARK; - I32 items = SP - MARK; + SSize_t items = SP - MARK; PADLIST * const padlist = CvPADLIST(cv); PUSHBLOCK(cx, CXt_SUB, MARK); PUSHSUB(cx); @@ -2804,28 +2663,29 @@ try_autoload: cx->blk_sub.argarray = av; ++MARK; - if (items > AvMAX(av) + 1) { - SV **ary = AvALLOC(av); - if (AvARRAY(av) != ary) { - AvMAX(av) += AvARRAY(av) - AvALLOC(av); - AvARRAY(av) = ary; - } - if (items > AvMAX(av) + 1) { - AvMAX(av) = items - 1; - Renew(ary,items,SV*); - AvALLOC(av) = ary; - AvARRAY(av) = ary; - } - } + if (items - 1 > AvMAX(av)) { + SV **ary = AvALLOC(av); + AvMAX(av) = items - 1; + Renew(ary, items, SV*); + AvALLOC(av) = ary; + AvARRAY(av) = ary; + } + Copy(MARK,AvARRAY(av),items,SV*); AvFILLp(av) = items - 1; + MARK = AvARRAY(av); while (items--) { if (*MARK) + { + if (SvPADTMP(*MARK) && !IS_PADGV(*MARK)) + *MARK = sv_mortalcopy(*MARK); SvTEMP_off(*MARK); + } MARK++; } } + SAVETMPS; if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO && !CvLVALUE(cv)) DIE(aTHX_ "Can't modify non-lvalue subroutine call"); @@ -2839,25 +2699,55 @@ try_autoload: RETURNOP(CvSTART(cv)); } else { - I32 markix = TOPMARK; + SSize_t markix = TOPMARK; + SAVETMPS; PUTBACK; - if (!hasargs) { + if (((PL_op->op_private + & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub) + ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO && + !CvLVALUE(cv)) + DIE(aTHX_ "Can't modify non-lvalue subroutine call"); + + if (!hasargs && GvAV(PL_defgv)) { /* Need to copy @_ to stack. Alternative may be to * switch stack to @_, and copy return values * back. This would allow popping @_ in XSUB, e.g.. XXXX */ AV * const av = GvAV(PL_defgv); - const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */ + const SSize_t items = AvFILL(av) + 1; if (items) { + SSize_t i = 0; + const bool m = cBOOL(SvRMAGICAL(av)); /* Mark is at the end of the stack. */ EXTEND(SP, items); - Copy(AvARRAY(av), SP + 1, items, SV*); + for (; i < items; ++i) + { + SV *sv; + if (m) { + SV ** const svp = av_fetch(av, i, 0); + sv = svp ? *svp : NULL; + } + else sv = AvARRAY(av)[i]; + if (sv) SP[i+1] = sv; + else { + SP[i+1] = newSVavdefelem(av, i, 1); + } + } SP += items; PUTBACK ; } } + else { + SV **mark = PL_stack_base + markix; + SSize_t items = SP - mark; + while (items--) { + mark++; + if (*mark && SvPADTMP(*mark) && !IS_PADGV(*mark)) + *mark = sv_mortalcopy(*mark); + } + } /* We assume first XSUB in &DB::sub is the called one. */ if (PL_curcopdb) { SAVEVPTR(PL_curcop); @@ -2891,8 +2781,15 @@ Perl_sub_crush_depth(pTHX_ CV *cv) if (CvANON(cv)) Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine"); else { - SV* const tmpstr = sv_newmortal(); - gv_efullname3(tmpstr, CvGV(cv), NULL); + HEK *const hek = CvNAME_HEK(cv); + SV *tmpstr; + if (hek) { + tmpstr = sv_2mortal(newSVhek(hek)); + } + else { + tmpstr = sv_newmortal(); + gv_efullname3(tmpstr, CvGV(cv), NULL); + } Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"", SVfARG(tmpstr)); } @@ -2906,7 +2803,7 @@ PP(pp_aelem) IV elem = SvIV(elemsv); AV *const av = MUTABLE_AV(POPs); const U32 lval = PL_op->op_flags & OPf_MOD || LVRET; - const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av)); + const U32 defer = PL_op->op_private & OPpLVAL_DEFER; const bool localizing = PL_op->op_private & OPpLVAL_INTRO; bool preeminent = TRUE; SV *sv; @@ -2945,18 +2842,17 @@ PP(pp_aelem) MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend); } #endif - if (!svp || *svp == &PL_sv_undef) { - SV* lv; + if (!svp || !*svp) { + IV len; if (!defer) DIE(aTHX_ PL_no_aelem, elem); - lv = sv_newmortal(); - sv_upgrade(lv, SVt_PVLV); - LvTYPE(lv) = 'y'; - sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0); - LvTARG(lv) = SvREFCNT_inc_simple(av); - LvTARGOFF(lv) = elem; - LvTARGLEN(lv) = 1; - PUSHs(lv); + len = av_len(av); + mPUSHs(newSVavdefelem(av, + /* Resolve a negative index now, unless it points before the + beginning of the array, in which case record it for error + reporting in magic_setdefelem. */ + elem < 0 && len + elem >= 0 ? len + elem : elem, + 1)); RETURN; } if (localizing) { @@ -3064,6 +2960,19 @@ S_method_common(pTHX_ SV* meth, U32* hashp) if (SvROK(sv)) ob = MUTABLE_SV(SvRV(sv)); else if (!SvOK(sv)) goto undefined; + else if (isGV_with_GP(sv)) { + if (!GvIO(sv)) + Perl_croak(aTHX_ "Can't call method \"%"SVf"\" " + "without a package or object reference", + SVfARG(meth)); + ob = sv; + if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') { + assert(!LvTARGLEN(ob)); + ob = LvTARG(ob); + assert(ob); + } + *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob)); + } else { /* this isn't a reference */ GV* iogv; @@ -3112,10 +3021,9 @@ S_method_common(pTHX_ SV* meth, U32* hashp) *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv))); } - /* if we got here, ob should be a reference or a glob */ + /* if we got here, ob should be an object or a glob */ if (!ob || !(SvOBJECT(ob) - || (SvTYPE(ob) == SVt_PVGV - && isGV_with_GP(ob) + || (isGV_with_GP(ob) && (ob = MUTABLE_SV(GvIO((const GV *)ob))) && SvOBJECT(ob)))) {