X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/583a5589b0727e1fccd2f9f7f0c8cb50c04884d5..2ec7214c34f5d160ff6a0e8acb3f151c5974e83a:/pp_hot.c diff --git a/pp_hot.c b/pp_hot.c index a1c9579..27ecb4a 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -85,9 +85,12 @@ PP(pp_pushmark) PP(pp_stringify) { dVAR; dSP; dTARGET; - sv_copypv(TARG,TOPs); - SETTARG; - RETURN; + SV * const sv = TOPs; + SETs(TARG); + sv_copypv(TARG, sv); + SvSETMAGIC(TARG); + /* no PUTBACK, SETs doesn't inc/dec SP */ + return NORMAL; } PP(pp_gv) @@ -99,14 +102,22 @@ PP(pp_gv) PP(pp_and) { - dVAR; dSP; + dVAR; PERL_ASYNC_CHECK(); - if (!SvTRUE(TOPs)) - RETURN; - else { - if (PL_op->op_type == OP_AND) - --SP; - RETURNOP(cLOGOP->op_other); + { + /* SP is not used to remove a variable that is saved across the + sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine + register or load/store vs direct mem ops macro is introduced, this + should be a define block between direct PL_stack_sp and dSP operations, + presently, using PL_stack_sp is bias towards CISC cpus */ + SV * const sv = *PL_stack_sp; + if (!SvTRUE_NN(sv)) + return NORMAL; + else { + if (PL_op->op_type == OP_AND) + --PL_stack_sp; + return cLOGOP->op_other; + } } } @@ -122,7 +133,7 @@ PP(pp_sassign) SV * const temp = left; left = right; right = temp; } - if (PL_tainting && PL_tainted && !SvTAINTED(right)) + if (TAINTING_get && TAINT_get && !SvTAINTED(right)) TAINT_NOT; if (PL_op->op_private & OPpASSIGN_CV_TO_GV) { SV * const cv = SvRV(right); @@ -173,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"}; @@ -196,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)); } } @@ -306,21 +317,106 @@ PP(pp_concat) } } +/* push the elements of av onto the stack. + * XXX Note that padav has similar code but without the mg_get(). + * I suspect that the mg_get is no longer needed, but while padav + * differs, it can't share this function */ + +STATIC void +S_pushav(pTHX_ AV* const av) +{ + dSP; + const I32 maxarg = AvFILL(av) + 1; + EXTEND(SP, maxarg); + if (SvRMAGICAL(av)) { + U32 i; + for (i=0; i < (U32)maxarg; i++) { + SV ** const svp = av_fetch(av, i, FALSE); + /* See note in pp_helem, and bug id #27839 */ + SP[i+1] = svp + ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp + : &PL_sv_undef; + } + } + else { + Copy(AvARRAY(av), SP+1, maxarg, SV*); + } + SP += maxarg; + PUTBACK; +} + + +/* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */ + +PP(pp_padrange) +{ + dVAR; dSP; + PADOFFSET base = PL_op->op_targ; + int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK; + int i; + if (PL_op->op_flags & OPf_SPECIAL) { + /* fake the RHS of my ($x,$y,..) = @_ */ + PUSHMARK(SP); + S_pushav(aTHX_ GvAVn(PL_defgv)); + SPAGAIN; + } + + /* note, this is only skipped for compile-time-known void cxt */ + if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) { + EXTEND(SP, count); + PUSHMARK(SP); + for (i = 0; i op_private & OPpLVAL_INTRO) { + SV **svp = &(PAD_SVl(base)); + const UV payload = (UV)( + (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT)) + | (count << SAVE_TIGHT_SHIFT) + | SAVEt_CLEARPADRANGE); + assert(OPpPADRANGE_COUNTMASK + 1 == (1 <> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base); + { + dSS_ADD; + SS_ADD_UV(payload); + SS_ADD_END(1); + } + + for (i = 0; i op_flags & OPf_MOD) { - if (PL_op->op_private & OPpLVAL_INTRO) - if (!(PL_op->op_private & OPpPAD_STATE)) - SAVECLEARSV(PAD_SVl(PL_op->op_targ)); - if (PL_op->op_private & OPpDEREF) { - PUTBACK; - TOPs = vivify_ref(TOPs, PL_op->op_private & OPpDEREF); - SPAGAIN; + dVAR; dSP; + EXTEND(SP, 1); + { + OP * const op = PL_op; + /* access PL_curpad once */ + SV ** const padentry = &(PAD_SVl(op->op_targ)); + { + dTARG; + TARG = *padentry; + PUSHs(TARG); + PUTBACK; /* no pop/push after this, TOPs ok */ + } + if (op->op_flags & OPf_MOD) { + if (op->op_private & OPpLVAL_INTRO) + if (!(op->op_private & OPpPAD_STATE)) + save_clearsv(padentry); + if (op->op_private & OPpDEREF) { + /* TOPs is equivalent to TARG here. Using TOPs (SP) rather + than TARG reduces the scope of TARG, so it does not + span the call to save_clearsv, resulting in smaller + machine code. */ + TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF); + } } + return op->op_next; } - RETURN; } PP(pp_readline) @@ -329,7 +425,7 @@ PP(pp_readline) dSP; if (TOPs) { SvGETMAGIC(TOPs); - tryAMAGICunTARGETlist(iter_amg, 0, 0); + tryAMAGICunTARGETlist(iter_amg, 0); PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); } else PL_last_in_gv = PL_argvgv, PL_stack_sp--; @@ -369,7 +465,7 @@ PP(pp_preinc) const bool inc = PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC; if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))) - Perl_croak_no_modify(aTHX); + Perl_croak_no_modify(); if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN)) { @@ -687,7 +783,7 @@ PP(pp_print) Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); ++SP; } - return Perl_tied_method(aTHX_ "PRINT", mark - 1, MUTABLE_SV(io), + return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io), mg, (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK | (PL_op->op_type == OP_SAY @@ -817,23 +913,10 @@ PP(pp_rv2av) (until such time as we get tools that can do blame annotation across whitespace changes. */ if (gimme == G_ARRAY) { - const I32 maxarg = AvFILL(av) + 1; - (void)POPs; /* XXXX May be optimized away? */ - EXTEND(SP, maxarg); - if (SvRMAGICAL(av)) { - U32 i; - for (i=0; i < (U32)maxarg; i++) { - SV ** const svp = av_fetch(av, i, FALSE); - /* See note in pp_helem, and bug id #27839 */ - SP[i+1] = svp - ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp - : &PL_sv_undef; - } - } - else { - Copy(AvARRAY(av), SP+1, maxarg, SV*); - } - SP += maxarg; + SP--; + PUTBACK; + S_pushav(aTHX_ av); + SPAGAIN; } else if (gimme == G_SCALAR) { dTARGET; @@ -867,22 +950,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"; } @@ -891,15 +971,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; } } @@ -921,11 +992,12 @@ PP(pp_aassign) HV *hash; I32 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 @@ -1003,48 +1075,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; + 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++; - tmpstr = sv_newmortal(); - if (*relem) - sv_setsv(tmpstr,*relem); /* value */ - 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: @@ -1073,10 +1173,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 @@ -1142,7 +1242,13 @@ PP(pp_aassign) tmp_gid = PerlProc_getgid(); tmp_egid = PerlProc_getegid(); } - PL_tainting |= (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)); + 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; @@ -1151,35 +1257,19 @@ PP(pp_aassign) else if (gimme == G_SCALAR) { dTARGET; SP = firstrelem; - SETi(lastrelem - firstrelem + 1 - duplicates); + SETi(lastrelem - firstrelem + 1); } else { - if (ary) + if (ary || hash) + /* note that in this case *firstlelem may have been overwritten + by sv_undef in the odd hash case */ 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); - } - } - 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; @@ -1208,16 +1298,16 @@ 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); } - if (RX_EXTFLAGS(rx) & RXf_TAINTED) { + if (RX_ISTAINTED(rx)) { SvTAINTED_on(rv); SvTAINTED_on(SvRV(rv)); } @@ -1230,21 +1320,18 @@ PP(pp_match) dVAR; dSP; dTARG; PMOP *pm = cPMOP; PMOP *dynpm = pm; - const char *t; const char *s; const char *strend; + I32 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; if (PL_op->op_flags & OPf_STACKED) TARG = POPs; @@ -1258,17 +1345,18 @@ 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; - rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) || - (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); + 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; /* PMdf_USED is set after a ?? matches once */ if ( @@ -1279,15 +1367,9 @@ PP(pp_match) #endif ) { DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once")); - failure: - - if (gimme == G_ARRAY) - RETURN; - RETPUSHNO; + goto nope; } - - /* empty pattern special-cased to use last successful pattern if possible, except for qr// */ if (!ReANY(rx)->mother_re && !RX_PRELEN(rx) @@ -1298,35 +1380,27 @@ PP(pp_match) if (RX_MINLEN(rx) > (I32)len) { DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match\n")); - goto failure; - } - - truebase = t = s; - - /* XXXX What part of this is needed with true \G-support? */ - if ((global = dynpm->op_pmflags & PMf_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; - } - } + goto nope; } + + /* get pos() if //g */ + if (global) { + MAGIC * const mg = mg_find_mglob(TARG); + if (mg && mg->mg_len >= 0) { + curpos = mg->mg_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)) - ) { + ) +#endif + { r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE); /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer * only on the first iteration. Therefore we need to copy $' as well @@ -1336,33 +1410,16 @@ PP(pp_match) r_flags |= REXEC_COPY_SKIP_POST; }; + s = truebase; + 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; - 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 (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) { @@ -1373,11 +1430,35 @@ PP(pp_match) #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))) { + MAGIC *mg = mg_find_mglob(TARG); + if (!mg) { + mg = sv_magicext_mglob(TARG); + } + assert(RX_OFFS(rx)[0].start != -1); /* XXX get rid of next line? */ + if (RX_OFFS(rx)[0].start != -1) { + mg->mg_len = 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; @@ -1388,7 +1469,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, " @@ -1401,145 +1482,22 @@ 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; - } - -yup: /* Confirmed by INTUIT */ - 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; - } - if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) { - I32 off; -#ifdef PERL_OLD_COPY_ON_WRITE - if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) { - 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_OLD_COPY_ON_WRITE - 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); - } - else { /* startp/endp are used by @- @+. */ - RX_OFFS(rx)[0].start = s - truebase; - RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx); - } - /* 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); + MAGIC* const mg = mg_find_mglob(TARG); if (mg) mg->mg_len = -1; - } } LEAVE_SCOPE(oldsave); if (gimme == G_ARRAY) @@ -1562,7 +1520,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); @@ -1639,7 +1597,7 @@ Perl_do_readline(pTHX) } SvUPGRADE(sv, SVt_PV); tmplen = SvLEN(sv); /* remember if already alloced */ - if (!tmplen && !SvREADONLY(sv)) { + if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) { /* try short-buffering it. Please update t/op/readline.t * if you change the growth length. */ @@ -1720,7 +1678,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) { @@ -1798,7 +1756,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); @@ -1841,156 +1799,165 @@ PP(pp_iter) { dVAR; dSP; PERL_CONTEXT *cx; - SV *sv, *oldsv; + SV *oldsv; SV **itersvp; - AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */ - bool av_is_stack = FALSE; EXTEND(SP, 1); cx = &cxstack[cxstack_ix]; - if (!CxTYPE_is_LOOP(cx)) - DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx)); - itersvp = CxITERVAR(cx); - if (CxTYPE(cx) == CXt_LOOP_LAZYSV) { - /* string increment */ - SV* cur = cx->blk_loop.state_u.lazysv.cur; - SV *end = cx->blk_loop.state_u.lazysv.end; - /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no. - It has SvPVX of "" and SvCUR of 0, which is what we want. */ - STRLEN maxlen = 0; - const char *max = SvPV_const(end, maxlen); - if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) { - if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { - /* safe to reuse old SV */ - sv_setsv(*itersvp, cur); - } - else - { - /* we need a fresh SV every time so that loop body sees a - * completely new SV for closures/references to work as - * they used to */ - oldsv = *itersvp; - *itersvp = newSVsv(cur); - SvREFCNT_dec(oldsv); - } - if (strEQ(SvPVX_const(cur), max)) - sv_setiv(cur, 0); /* terminate next time */ - else - sv_inc(cur); - RETPUSHYES; - } - RETPUSHNO; + + switch (CxTYPE(cx)) { + + case CXt_LOOP_LAZYSV: /* string increment */ + { + SV* cur = cx->blk_loop.state_u.lazysv.cur; + SV *end = cx->blk_loop.state_u.lazysv.end; + /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no. + It has SvPVX of "" and SvCUR of 0, which is what we want. */ + STRLEN maxlen = 0; + const char *max = SvPV_const(end, maxlen); + if (SvNIOK(cur) || SvCUR(cur) > maxlen) + RETPUSHNO; + + oldsv = *itersvp; + if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) { + /* safe to reuse old SV */ + sv_setsv(oldsv, cur); + } + else + { + /* we need a fresh SV every time so that loop body sees a + * completely new SV for closures/references to work as + * they used to */ + *itersvp = newSVsv(cur); + SvREFCNT_dec_NN(oldsv); + } + if (strEQ(SvPVX_const(cur), max)) + sv_setiv(cur, 0); /* terminate next time */ + else + sv_inc(cur); + break; } - else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) { - /* integer increment */ - if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end) + + case CXt_LOOP_LAZYIV: /* integer increment */ + { + IV cur = cx->blk_loop.state_u.lazyiv.cur; + if (cur > cx->blk_loop.state_u.lazyiv.end) RETPUSHNO; + oldsv = *itersvp; /* don't risk potential race */ - if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { + if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) { /* safe to reuse old SV */ - sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur); + sv_setiv(oldsv, cur); } else { /* we need a fresh SV every time so that loop body sees a * completely new SV for closures/references to work as they * used to */ - oldsv = *itersvp; - *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur); - SvREFCNT_dec(oldsv); + *itersvp = newSViv(cur); + SvREFCNT_dec_NN(oldsv); } - if (cx->blk_loop.state_u.lazyiv.cur == IV_MAX) { + if (cur == IV_MAX) { /* Handle end of range at IV_MAX */ cx->blk_loop.state_u.lazyiv.end = IV_MIN; } else ++cx->blk_loop.state_u.lazyiv.cur; - - RETPUSHYES; + break; } - /* iterate array */ - assert(CxTYPE(cx) == CXt_LOOP_FOR); - av = cx->blk_loop.state_u.ary.ary; - if (!av) { - av_is_stack = TRUE; - av = PL_curstack; - } - if (PL_op->op_private & OPpITER_REVERSED) { - if (cx->blk_loop.state_u.ary.ix <= (av_is_stack - ? cx->blk_loop.resetsp + 1 : 0)) - RETPUSHNO; + case CXt_LOOP_FOR: /* iterate array */ + { - if (SvMAGICAL(av) || AvREIFY(av)) { - SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE); - sv = svp ? *svp : NULL; - } - else { - sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix]; - } - } - else { - if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp : - AvFILL(av))) - RETPUSHNO; + AV *av = cx->blk_loop.state_u.ary.ary; + SV *sv; + bool av_is_stack = FALSE; + IV ix; - if (SvMAGICAL(av) || AvREIFY(av)) { - SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE); - sv = svp ? *svp : NULL; - } - else { - sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix]; - } - } + if (!av) { + av_is_stack = TRUE; + av = PL_curstack; + } + if (PL_op->op_private & OPpITER_REVERSED) { + ix = --cx->blk_loop.state_u.ary.ix; + if (ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)) + RETPUSHNO; + } + else { + ix = ++cx->blk_loop.state_u.ary.ix; + if (ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))) + RETPUSHNO; + } - if (sv && SvIS_FREED(sv)) { - *itersvp = NULL; - Perl_croak(aTHX_ "Use of freed value in iteration"); - } + if (SvMAGICAL(av) || AvREIFY(av)) { + SV * const * const svp = av_fetch(av, ix, FALSE); + sv = svp ? *svp : NULL; + } + else { + sv = AvARRAY(av)[ix]; + } - if (sv) { - SvTEMP_off(sv); - SvREFCNT_inc_simple_void_NN(sv); - } - 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) = cx->blk_loop.state_u.ary.ix; - LvTARGLEN(lv) = (STRLEN)UV_MAX; - sv = lv; - } + if (sv) { + if (SvIS_FREED(sv)) { + *itersvp = NULL; + Perl_croak(aTHX_ "Use of freed value in iteration"); + } + if (SvPADTMP(sv) && !IS_PADGV(sv)) + sv = newSVsv(sv); + else { + SvTEMP_off(sv); + SvREFCNT_inc_simple_void_NN(sv); + } + } + 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); + oldsv = *itersvp; + *itersvp = sv; + SvREFCNT_dec(oldsv); + break; + } + default: + DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx)); + } RETPUSHYES; } /* A description of how taint works in pattern matching and substitution. +This is all conditional on NO_TAINT_SUPPORT not being defined. Under +NO_TAINT_SUPPORT, taint-related operations should become no-ops. + While the pattern is being assembled/concatenated and then compiled, -PL_tainted will get set if any component of the pattern is tainted, e.g. -/.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag -is set on the pattern if PL_tainted is set. +PL_tainted will get set (via TAINT_set) if any component of the pattern +is tainted, e.g. /.*$tainted/. At the end of pattern compilation, +the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via +TAINT_get). When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to the pattern is marked as tainted. This means that subsequent usage, such -as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too. +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 @@ -2047,13 +2014,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 */ @@ -2065,7 +2029,7 @@ PP(pp_subst) const I32 oldsave = PL_savestack_ix; STRLEN slen; bool doutf8 = FALSE; /* whether replacement is in utf8 */ -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW bool is_cow; #endif SV *nsv = NULL; @@ -2084,7 +2048,7 @@ PP(pp_subst) } SvGETMAGIC(TARG); /* must come before cow check */ -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW /* Awooga. Awooga. "bool" types that are actually char are dangerous, because they make integers such as 256 "false". */ is_cow = SvIsCOW(TARG) ? TRUE : FALSE; @@ -2093,17 +2057,20 @@ PP(pp_subst) sv_force_normal_flags(TARG,0); #endif if (!(rpm->op_pmflags & PMf_NONDESTRUCT) -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW && !is_cow #endif && (SvREADONLY(TARG) || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG)) || SvTYPE(TARG) > SVt_PVLV) && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))) - Perl_croak_no_modify(aTHX); + 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; @@ -2111,24 +2078,22 @@ PP(pp_subst) once = !(rpm->op_pmflags & PMf_GLOBAL); /* See "how taint works" above */ - if (PL_tainting) { + if (TAINTING_get) { rxtainted = ( (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0) - | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0) + | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0) | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0) | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT)) ? SUBST_TAINT_BOOLRET : 0)); 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. */ @@ -2139,38 +2104,24 @@ PP(pp_subst) rx = PM_GETRE(pm); } +#ifdef PERL_SAWAMPERSAND r_flags = ( RX_NPARENS(rx) || PL_sawampersand || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) ) ? REXEC_COPY_STR : 0; +#else + 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? */ @@ -2201,35 +2152,40 @@ PP(pp_subst) /* can do inplace substitution? */ if (c -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW && !is_cow #endif && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR)) - && !(RX_EXTFLAGS(rx) & (RXf_LOOKBEHIND_SEEN|RXf_MODIFIES_VARS)) + && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST) && (!doutf8 || SvUTF8(TARG)) && !(rpm->op_pmflags & PMf_NONDESTRUCT)) { -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW if (SvIsCOW(TARG)) { - assert (!force_on_match); + if (!force_on_match) goto have_a_cow; + assert(SvVOK(TARG)); } #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; @@ -2242,27 +2198,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 */ @@ -2283,7 +2235,7 @@ PP(pp_subst) /* don't match same null twice */ REXEC_NOT_FIRST|REXEC_IGNOREPOS)); 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 */ } @@ -2293,8 +2245,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 @@ -2304,19 +2259,22 @@ 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_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW have_a_cow: #endif 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: @@ -2333,12 +2291,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)); @@ -2373,7 +2332,7 @@ PP(pp_subst) SPAGAIN; PUSHs(dstr); } else { -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW /* The match may make the string COW. If so, brilliant, because that's just saved us one malloc, copy and free - the regexp has donated the old buffer, and we malloc an entirely new one, rather @@ -2402,7 +2361,7 @@ PP(pp_subst) } /* See "how taint works" above */ - if (PL_tainting) { + if (TAINTING_get) { if ((rxtainted & SUBST_TAINT_PAT) || ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) @@ -2417,8 +2376,9 @@ PP(pp_subst) SvTAINTED_off(TOPs); /* may have got tainted earlier */ /* needed for mg_set below */ - PL_tainted = - cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)); + TAINT_set( + cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)) + ); SvTAINT(TARG); } SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */ @@ -2469,6 +2429,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; @@ -2510,7 +2474,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 @@ -2614,7 +2578,6 @@ PP(pp_entersub) } ENTER; - SAVETMPS; retry: if (CvCLONE(cv) && ! CvCLONED(cv)) @@ -2703,28 +2666,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"); @@ -2740,8 +2704,15 @@ try_autoload: else { I32 markix = TOPMARK; + SAVETMPS; PUTBACK; + 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) { /* Need to copy @_ to stack. Alternative may be to * switch stack to @_, and copy return values @@ -2790,8 +2761,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)); } @@ -2884,7 +2862,7 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) SvGETMAGIC(sv); if (!SvOK(sv)) { if (SvREADONLY(sv)) - Perl_croak_no_modify(aTHX); + Perl_croak_no_modify(); prepare_SV_for_RV(sv); switch (to_what) { case OPpDEREF_SV: @@ -2963,6 +2941,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; @@ -3011,10 +3002,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)))) {