X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e3393f51d48d8b790e26324eb0336fac9689fa46..e64345f82d66a32f6da47acf482e7e6c9282b433:/pp_hot.c diff --git a/pp_hot.c b/pp_hot.c index f4d79dc..2f159e5 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -197,6 +197,13 @@ PP(pp_sassign) } } + if ( + SvTEMP(right) && !SvSMAGICAL(right) && SvREFCNT(right) == 1 && + (!isGV_with_GP(right) || SvFAKE(right)) && ckWARN(WARN_MISC) + ) + Perl_warner(aTHX_ + packWARN(WARN_MISC), "Useless assignment to a temporary" + ); SvSetMagicSV(right, left); SETs(right); RETURN; @@ -315,7 +322,7 @@ PP(pp_readline) { dVAR; dSP; SvGETMAGIC(TOPs); - tryAMAGICunTARGET(iter, 0); + tryAMAGICunTARGET(iter_amg, 0, 0); PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); if (!isGV_with_GP(PL_last_in_gv)) { if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv))) @@ -324,7 +331,7 @@ PP(pp_readline) dSP; XPUSHs(MUTABLE_SV(PL_last_in_gv)); PUTBACK; - pp_rv2gv(); + Perl_pp_rv2gv(aTHX); PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); } } @@ -334,75 +341,17 @@ PP(pp_readline) PP(pp_eq) { dVAR; dSP; - tryAMAGICbin_MG(eq_amg, AMGf_set); -#ifndef NV_PRESERVES_UV - if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { - SP--; - SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s))); - RETURN; - } -#endif -#ifdef PERL_PRESERVE_IVUV - SvIV_please_nomg(TOPs); - if (SvIOK(TOPs)) { - /* Unless the left argument is integer in range we are going - to have to use NV maths. Hence only attempt to coerce the - right argument if we know the left is integer. */ - SvIV_please_nomg(TOPm1s); - if (SvIOK(TOPm1s)) { - const bool auvok = SvUOK(TOPm1s); - const bool buvok = SvUOK(TOPs); - - if (auvok == buvok) { /* ## IV == IV or UV == UV ## */ - /* Casting IV to UV before comparison isn't going to matter - on 2s complement. On 1s complement or sign&magnitude - (if we have any of them) it could to make negative zero - differ from normal zero. As I understand it. (Need to - check - is negative zero implementation defined behaviour - anyway?). NWC */ - const UV buv = SvUVX(POPs); - const UV auv = SvUVX(TOPs); - - SETs(boolSV(auv == buv)); - RETURN; - } - { /* ## Mixed IV,UV ## */ - SV *ivp, *uvp; - IV iv; - - /* == is commutative so doesn't matter which is left or right */ - if (auvok) { - /* top of stack (b) is the iv */ - ivp = *SP; - uvp = *--SP; - } else { - uvp = *SP; - ivp = *--SP; - } - iv = SvIVX(ivp); - if (iv < 0) - /* As uv is a UV, it's >0, so it cannot be == */ - SETs(&PL_sv_no); - else - /* we know iv is >= 0 */ - SETs(boolSV((UV)iv == SvUVX(uvp))); - RETURN; - } - } - } -#endif - { -#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) - dPOPTOPnnrl_nomg; - if (Perl_isnan(left) || Perl_isnan(right)) - RETSETNO; - SETs(boolSV(left == right)); -#else - dPOPnv_nomg; - SETs(boolSV(SvNV_nomg(TOPs) == value)); -#endif - RETURN; - } + SV *left, *right; + + tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric); + right = POPs; + left = TOPs; + SETs(boolSV( + (SvIOK_notUV(left) && SvIOK_notUV(right)) + ? (SvIVX(left) == SvIVX(right)) + : ( do_ncmp(left, right) == 0) + )); + RETURN; } PP(pp_preinc) @@ -664,8 +613,8 @@ PP(pp_add) PP(pp_aelemfast) { dVAR; dSP; - AV * const av = PL_op->op_flags & OPf_SPECIAL - ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAV(cGVOP_gv); + AV * const av = PL_op->op_type == OP_AELEMFAST_LEX + ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv); const U32 lval = PL_op->op_flags & OPf_MOD; SV** const svp = av_fetch(av, PL_op->op_private, lval); SV *sv = (svp ? *svp : &PL_sv_undef); @@ -710,13 +659,13 @@ PP(pp_pushre) PP(pp_print) { dVAR; dSP; dMARK; dORIGMARK; - IO *io; register PerlIO *fp; MAGIC *mg; GV * const gv = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv; + IO *io = GvIO(gv); - if (gv && (io = GvIO(gv)) + if (io && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { had_magic: @@ -729,39 +678,25 @@ PP(pp_print) Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); ++SP; } - PUSHMARK(MARK - 1); - *MARK = SvTIED_obj(MUTABLE_SV(io), mg); - PUTBACK; - ENTER_with_name("call_PRINT"); - if( PL_op->op_type == OP_SAY ) { - /* local $\ = "\n" */ - SAVEGENERICSV(PL_ors_sv); - PL_ors_sv = newSVpvs("\n"); - } - call_method("PRINT", G_SCALAR); - LEAVE_with_name("call_PRINT"); - SPAGAIN; - MARK = ORIGMARK + 1; - *MARK = *SP; - SP = MARK; - RETURN; + return Perl_tied_method(aTHX_ "PRINT", mark - 1, MUTABLE_SV(io), + mg, + (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK + | (PL_op->op_type == OP_SAY + ? TIED_METHOD_SAY : 0)), sp - mark); } - if (!(io = GvIO(gv))) { + if (!io) { if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv))) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) goto had_magic; - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { - if (ckWARN2(WARN_CLOSED, WARN_IO)) { - if (IoIFP(io)) - report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); - else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); - } + if (IoIFP(io)) + report_wrongway_fh(gv, '<'); + else + report_evil_fh(gv); SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI); goto just_say_no; } @@ -827,8 +762,10 @@ PP(pp_rv2av) if (!(PL_op->op_private & OPpDEREFed)) SvGETMAGIC(sv); if (SvROK(sv)) { - tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg); - + if (SvAMAGIC(sv)) { + sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg); + SPAGAIN; + } sv = SvRV(sv); if (SvTYPE(sv) != type) DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash); @@ -836,11 +773,14 @@ PP(pp_rv2av) SETs(sv); RETURN; } - else if (LVRET) { + else if (PL_op->op_private & OPpMAYBE_LVSUB) { + const I32 flags = is_lvalue_sub(); + if (flags && !(flags & OPpENTERSUB_INARGS)) { if (gimme != G_ARRAY) goto croak_cant_return; SETs(sv); RETURN; + } } else if (PL_op->op_flags & OPf_MOD && PL_op->op_private & OPpLVAL_INTRO) @@ -878,56 +818,59 @@ PP(pp_rv2av) SETs(sv); RETURN; } - else if (LVRET) { + else if (PL_op->op_private & OPpMAYBE_LVSUB) { + const I32 flags = is_lvalue_sub(); + if (flags && !(flags & OPpENTERSUB_INARGS)) { if (gimme != G_ARRAY) goto croak_cant_return; SETs(sv); RETURN; + } } } } if (is_pp_rv2av) { AV *const av = MUTABLE_AV(sv); - /* The guts of pp_rv2av, with no intenting change to preserve history + /* The guts of pp_rv2av, with no intending change to preserve history (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; + 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; } - else { - Copy(AvARRAY(av), SP+1, maxarg, SV*); + else if (gimme == G_SCALAR) { + dTARGET; + const I32 maxarg = AvFILL(av) + 1; + SETi(maxarg); } - SP += maxarg; - } - else if (gimme == G_SCALAR) { - dTARGET; - const I32 maxarg = AvFILL(av) + 1; - SETi(maxarg); - } } else { /* The guts of pp_rv2hv */ - if (gimme == G_ARRAY) { /* array wanted */ - *PL_stack_sp = sv; - return do_kv(); - } - else if (gimme == G_SCALAR) { - dTARGET; - TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv)); - SPAGAIN; - SETTARG; - } + if (gimme == G_ARRAY) { /* array wanted */ + *PL_stack_sp = sv; + return Perl_do_kv(aTHX); + } + else if (gimme == G_SCALAR) { + dTARGET; + TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv)); + SPAGAIN; + SETTARG; + } } RETURN; @@ -1001,8 +944,19 @@ PP(pp_aassign) /* If there's a common identifier on both sides we have to take * special care that assigning the identifier on the left doesn't * clobber a value on the right that's used later in the list. + * Don't bother if LHS is just an empty hash or array. */ - if (PL_op->op_private & (OPpASSIGN_COMMON)) { + + if ( (PL_op->op_private & OPpASSIGN_COMMON) + && ( + firstlelem != lastlelem + || ! ((sv = *firstlelem)) + || SvMAGICAL(sv) + || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV) + || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1) + || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0) + ) + ) { EXTEND_MORTAL(lastrelem - firstrelem + 1); for (relem = firstrelem; relem <= lastrelem; relem++) { if ((sv = *relem)) { @@ -1106,6 +1060,14 @@ PP(pp_aassign) break; } if (relem <= lastrelem) { + if ( + SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 && + (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC) + ) + Perl_warner(aTHX_ + packWARN(WARN_MISC), + "Useless assignment to a temporary" + ); sv_setsv(sv, *relem); *(relem++) = sv; } @@ -1247,8 +1209,10 @@ PP(pp_qr) (void)sv_bless(rv, stash); } - if (RX_EXTFLAGS(rx) & RXf_TAINTED) + if (RX_EXTFLAGS(rx) & RXf_TAINTED) { SvTAINTED_on(rv); + SvTAINTED_on(SvRV(rv)); + } XPUSHs(rv); RETURN; } @@ -1357,7 +1321,7 @@ PP(pp_match) if (SvSCREAM(TARG)) r_flags |= REXEC_SCREAM; -play_it_again: + 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) @@ -1382,22 +1346,18 @@ play_it_again: && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */ goto yup; } - if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, - minmatch, TARG, NUM2PTR(void*, gpos), r_flags)) - { - PL_curpm = pm; - if (dynpm->op_pmflags & PMf_ONCE) { + if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, + minmatch, TARG, NUM2PTR(void*, gpos), r_flags)) + goto ret_no; + + PL_curpm = pm; + if (dynpm->op_pmflags & PMf_ONCE) { #ifdef USE_ITHREADS - SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]); + SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]); #else - dynpm->op_pmflags |= PMf_USED; + dynpm->op_pmflags |= PMf_USED; #endif - } - goto gotcha; } - else - goto ret_no; - /*NOTREACHED*/ gotcha: if (rxtainted) @@ -1579,21 +1539,15 @@ Perl_do_readline(pTHX) const I32 gimme = GIMME_V; if (io) { - MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - PUSHMARK(SP); - XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); - PUTBACK; - ENTER_with_name("call_READLINE"); - call_method("READLINE", gimme); - LEAVE_with_name("call_READLINE"); - SPAGAIN; + Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0); if (gimme == G_SCALAR) { - SV* const result = POPs; - SvSetSV_nosteal(TARG, result); - PUSHTARG; + SPAGAIN; + SvSetSV_nosteal(TARG, TOPs); + SETTARG; } - RETURN; + return NORMAL; } } fp = NULL; @@ -1622,8 +1576,8 @@ Perl_do_readline(pTHX) } else if (type == OP_GLOB) SP--; - else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) { - report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY); + else if (IoTYPE(io) == IoTYPE_WRONLY) { + report_wrongway_fh(PL_last_in_gv, '>'); } } if (!fp) { @@ -1635,7 +1589,7 @@ Perl_do_readline(pTHX) "glob failed (can't start child: %s)", Strerror(errno)); else - report_evil_fh(PL_last_in_gv, io, PL_op->op_type); + report_evil_fh(PL_last_in_gv); } if (gimme == G_SCALAR) { /* undef TARG, and push that undefined value */ @@ -1781,31 +1735,6 @@ Perl_do_readline(pTHX) } } -PP(pp_enter) -{ - dVAR; dSP; - register PERL_CONTEXT *cx; - I32 gimme = OP_GIMME(PL_op, -1); - - if (gimme == -1) { - if (cxstack_ix >= 0) { - /* If this flag is set, we're just inside a return, so we should - * store the caller's context */ - gimme = (PL_op->op_flags & OPf_SPECIAL) - ? block_gimme() - : cxstack[cxstack_ix].blk_gimme; - } else - gimme = G_SCALAR; - } - - ENTER_with_name("block"); - - SAVETMPS; - PUSHBLOCK(cx, CXt_BLOCK, SP); - - RETURN; -} - PP(pp_helem) { dVAR; dSP; @@ -1885,57 +1814,6 @@ PP(pp_helem) RETURN; } -PP(pp_leave) -{ - dVAR; dSP; - register PERL_CONTEXT *cx; - SV **newsp; - PMOP *newpm; - I32 gimme; - - if (PL_op->op_flags & OPf_SPECIAL) { - cx = &cxstack[cxstack_ix]; - cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */ - } - - POPBLOCK(cx,newpm); - - gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR); - - TAINT_NOT; - if (gimme == G_VOID) - SP = newsp; - else if (gimme == G_SCALAR) { - register SV **mark; - MARK = newsp + 1; - if (MARK <= SP) { - if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) - *MARK = TOPs; - else - *MARK = sv_mortalcopy(TOPs); - } else { - MEXTEND(mark,0); - *MARK = &PL_sv_undef; - } - SP = MARK; - } - else if (gimme == G_ARRAY) { - /* in case LEAVE wipes old return values */ - register SV **mark; - for (mark = newsp + 1; mark <= SP; mark++) { - if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) { - *mark = sv_mortalcopy(*mark); - TAINT_NOT; /* Each item is independent */ - } - } - } - PL_curpm = newpm; /* Don't pop $1 et al till now */ - - LEAVE_with_name("block"); - - RETURN; -} - PP(pp_iter) { dVAR; dSP; @@ -2074,6 +1952,73 @@ PP(pp_iter) RETPUSHYES; } +/* +A description of how taint works in pattern matching and substitution. + +While the pattern is being assembled/concatenated and them 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. + +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. + +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. + +In addition, 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 +to be tainted. + +The taint behaviour of pp_subst (and pp_substcont) is quite complex. + +There are three possible sources of taint + * the source string + * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN) + * the replacement string (or expression under /e) + +There are four destinations of taint and they are affected by the sources +according to the rules below: + + * the return value (not including /r): + tainted by the source string and pattern, but only for the + number-of-iterations case; boolean returns aren't tainted; + * the modified string (or modified copy under /r): + tainted by the source string, pattern, and replacement strings; + * $1 et al: + tainted by the pattern, and under 'use re "taint"', by the source + string too; + * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted: + should always be unset before executing subsequent code. + +The overall action of pp_subst is: + + * at the start, set bits in rxtainted indicating the taint status of + the various sources. + + * After each pattern execution, update the SUBST_TAINT_PAT bit in + rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the + pattern has subsequently become tainted via locale ops. + + * If control is being passed to pp_substcont to execute a /e block, + save rxtainted in the CXt_SUBST block, for future use by + pp_substcont. + + * Whenever control is being returned to perl code (either by falling + off the "end" of pp_subst/pp_substcont, or by entering a /e block), + use the flag bits in rxtainted to make all the appropriate types of + destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1 + et al will appear tainted. + +pp_match is just a simpler version of the above. + +*/ + PP(pp_subst) { dVAR; dSP; dTARG; @@ -2089,7 +2034,8 @@ PP(pp_subst) I32 maxiters; register I32 i; bool once; - U8 rxtainted; + U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits. + See "how taint works" above */ char *orig; U8 r_flags; register REGEXP *rx = PM_GETRE(pm); @@ -2098,7 +2044,6 @@ PP(pp_subst) const I32 oldsave = PL_savestack_ix; STRLEN slen; bool doutf8 = FALSE; - I32 matched; #ifdef PERL_OLD_COPY_ON_WRITE bool is_cow; #endif @@ -2117,11 +2062,6 @@ PP(pp_subst) EXTEND(SP,1); } - /* In non-destructive replacement mode, duplicate target scalar so it - * remains unchanged. */ - if (rpm->op_pmflags & PMf_NONDESTRUCT) - TARG = newSVsv(TARG); - #ifdef PERL_OLD_COPY_ON_WRITE /* Awooga. Awooga. "bool" types that are actually char are dangerous, because they make integers such as 256 "false". */ @@ -2130,14 +2070,14 @@ PP(pp_subst) if (SvIsCOW(TARG)) sv_force_normal_flags(TARG,0); #endif - if ( + if (!(rpm->op_pmflags & PMf_NONDESTRUCT) #ifdef PERL_OLD_COPY_ON_WRITE - !is_cow && + && !is_cow #endif - (SvREADONLY(TARG) - || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG)) - || SvTYPE(TARG) > SVt_PVLV) - && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))) + && (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); PUTBACK; @@ -2145,11 +2085,20 @@ PP(pp_subst) s = SvPV_mutable(TARG, len); if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV) force_on_match = 1; - rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) || - (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); - if (PL_tainted) - rxtainted |= 2; - TAINT_NOT; + + /* only replace once? */ + once = !(rpm->op_pmflags & PMf_GLOBAL); + + /* See "how taint works" above */ + if (PL_tainting) { + rxtainted = ( + (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0) + | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? 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)); @@ -2179,7 +2128,7 @@ PP(pp_subst) s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL); if (!s) - goto nope; + goto ret_no; /* How to do it in subst? */ /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL) && !PL_sawampersand @@ -2191,24 +2140,33 @@ PP(pp_subst) */ } - /* only replace once? */ - once = !(rpm->op_pmflags & PMf_GLOBAL); - matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL, - r_flags | REXEC_CHECKED); + if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL, + r_flags | REXEC_CHECKED)) + { + ret_no: + SPAGAIN; + PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no); + LEAVE_SCOPE(oldsave); + RETURN; + } + /* known replacement string? */ if (dstr) { + if (SvTAINTED(dstr)) + rxtainted |= SUBST_TAINT_REPL; /* Upgrade the source if the replacement is utf8 but the source is not, * but only if it matched; see * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html */ - if (matched && DO_UTF8(dstr) && ! DO_UTF8(TARG)) { - const STRLEN new_len = sv_utf8_upgrade(TARG); + if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) { + char * const orig_pvx = SvPVX(TARG); + const STRLEN new_len = sv_utf8_upgrade_nomg(TARG); /* If the lengths are the same, the pattern contains only * invariants, can keep going; otherwise, various internal markers * could be off, so redo */ - if (new_len != len) { + if (new_len != len || orig_pvx != SvPVX(TARG)) { goto setup_match; } } @@ -2241,17 +2199,10 @@ PP(pp_subst) #endif && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR)) && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN) - && (!doutf8 || SvUTF8(TARG))) { - if (!matched) - { - SPAGAIN; - if (rpm->op_pmflags & PMf_NONDESTRUCT) - PUSHs(TARG); - else - PUSHs(&PL_sv_no); - LEAVE_SCOPE(oldsave); - RETURN; - } + && (!doutf8 || SvUTF8(TARG)) + && !(rpm->op_pmflags & PMf_NONDESTRUCT)) + { + #ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW(TARG)) { assert (!force_on_match); @@ -2267,7 +2218,8 @@ PP(pp_subst) PL_curpm = pm; SvSCREAM_off(TARG); /* disable possible screamer */ if (once) { - rxtainted |= RX_MATCH_TAINTED(rx); + 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; @@ -2300,18 +2252,15 @@ PP(pp_subst) else { sv_chop(TARG, d); } - TAINT_IF(rxtainted & 1); SPAGAIN; - if (rpm->op_pmflags & PMf_NONDESTRUCT) - PUSHs(TARG); - else - PUSHs(&PL_sv_yes); + PUSHs(&PL_sv_yes); } else { do { if (iters++ > maxiters) DIE(aTHX_ "Substitution loop"); - rxtainted |= RX_MATCH_TAINTED(rx); + if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ + rxtainted |= SUBST_TAINT_PAT; m = RX_OFFS(rx)[0].start + orig; if ((i = m - s)) { if (s != d) @@ -2332,29 +2281,11 @@ PP(pp_subst) SvCUR_set(TARG, d - SvPVX_const(TARG) + i); Move(s, d, i+1, char); /* include the NUL */ } - TAINT_IF(rxtainted & 1); - SPAGAIN; - if (rpm->op_pmflags & PMf_NONDESTRUCT) - PUSHs(TARG); - else - mPUSHi((I32)iters); - } - (void)SvPOK_only_UTF8(TARG); - TAINT_IF(rxtainted); - if (SvSMAGICAL(TARG)) { - PUTBACK; - mg_set(TARG); SPAGAIN; + mPUSHi((I32)iters); } - SvTAINT(TARG); - if (doutf8) - SvUTF8_on(TARG); - LEAVE_SCOPE(oldsave); - RETURN; } - - if (matched) - { + else { if (force_on_match) { force_on_match = 0; s = SvPV_force(TARG, len); @@ -2363,13 +2294,18 @@ PP(pp_subst) #ifdef PERL_OLD_COPY_ON_WRITE have_a_cow: #endif - rxtainted |= RX_MATCH_TAINTED(rx); - dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG)); - SAVEFREESV(dstr); + if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ + rxtainted |= SUBST_TAINT_PAT; + dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0)); PL_curpm = pm; if (!c) { register PERL_CONTEXT *cx; SPAGAIN; + /* 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: + * iters maxiters r_flags oldsave rxtainted orig dstr targ + * s m strend rx once */ PUSHSUBST(cx); RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot); } @@ -2377,7 +2313,8 @@ PP(pp_subst) do { if (iters++ > maxiters) DIE(aTHX_ "Substitution loop"); - rxtainted |= RX_MATCH_TAINTED(rx); + if (RX_MATCH_TAINTED(rx)) + rxtainted |= SUBST_TAINT_PAT; if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) { m = s; s = orig; @@ -2402,50 +2339,65 @@ PP(pp_subst) else sv_catpvn(dstr, s, strend - s); + if (rpm->op_pmflags & PMf_NONDESTRUCT) { + /* From here on down we're using the copy, and leaving the original + untouched. */ + TARG = dstr; + SPAGAIN; + PUSHs(dstr); + } else { #ifdef PERL_OLD_COPY_ON_WRITE - /* 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 than the - regexp malloc()ing a buffer and copying our original, only for - us to throw it away here during the substitution. */ - if (SvIsCOW(TARG)) { - sv_force_normal_flags(TARG, SV_COW_DROP_PV); - } else + /* 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 + than the regexp malloc()ing a buffer and copying our original, + only for us to throw it away here during the substitution. */ + if (SvIsCOW(TARG)) { + sv_force_normal_flags(TARG, SV_COW_DROP_PV); + } else #endif - { - SvPV_free(TARG); - } - SvPV_set(TARG, SvPVX(dstr)); - SvCUR_set(TARG, SvCUR(dstr)); - SvLEN_set(TARG, SvLEN(dstr)); - doutf8 |= DO_UTF8(dstr); - SvPV_set(dstr, NULL); + { + SvPV_free(TARG); + } + SvPV_set(TARG, SvPVX(dstr)); + SvCUR_set(TARG, SvCUR(dstr)); + SvLEN_set(TARG, SvLEN(dstr)); + doutf8 |= DO_UTF8(dstr); + SvPV_set(dstr, NULL); - TAINT_IF(rxtainted & 1); - SPAGAIN; - if (rpm->op_pmflags & PMf_NONDESTRUCT) - PUSHs(TARG); - else + SPAGAIN; mPUSHi((I32)iters); + } + } - (void)SvPOK_only(TARG); + if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) { + (void)SvPOK_only_UTF8(TARG); if (doutf8) SvUTF8_on(TARG); - TAINT_IF(rxtainted); - SvSETMAGIC(TARG); - SvTAINT(TARG); - LEAVE_SCOPE(oldsave); - RETURN; } - goto ret_no; -nope: -ret_no: - SPAGAIN; - if (rpm->op_pmflags & PMf_NONDESTRUCT) - PUSHs(TARG); - else - PUSHs(&PL_sv_no); + /* See "how taint works" above */ + if (PL_tainting) { + if ((rxtainted & SUBST_TAINT_PAT) || + ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) == + (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) + ) + (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */ + + if (!(rxtainted & SUBST_TAINT_BOOLRET) + && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT)) + ) + SvTAINTED_on(TOPs); /* taint return value */ + else + 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)); + SvTAINT(TARG); + } + SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */ + TAINT_NOT; LEAVE_SCOPE(oldsave); RETURN; } @@ -2511,22 +2463,25 @@ PP(pp_leavesub) I32 gimme; register PERL_CONTEXT *cx; SV *sv; + bool gmagic; if (CxMULTICALL(&cxstack[cxstack_ix])) return 0; POPBLOCK(cx,newpm); cxstack_ix++; /* temporarily protect top context */ + gmagic = CxLVAL(cx) & OPpENTERSUB_DEREF; TAINT_NOT; if (gimme == G_SCALAR) { MARK = newsp + 1; if (MARK <= SP) { if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { - if (SvTEMP(TOPs)) { + if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) { *MARK = SvREFCNT_inc(TOPs); FREETMPS; sv_2mortal(*MARK); + if (gmagic) SvGETMAGIC(*MARK); } else { sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */ @@ -2535,8 +2490,12 @@ PP(pp_leavesub) SvREFCNT_dec(sv); } } + else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) { + *MARK = TOPs; + if (gmagic) SvGETMAGIC(TOPs); + } else - *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs); + *MARK = sv_mortalcopy(TOPs); } else { MEXTEND(MARK, 0); @@ -2546,7 +2505,7 @@ PP(pp_leavesub) } else if (gimme == G_ARRAY) { for (MARK = newsp + 1; MARK <= SP; MARK++) { - if (!SvTEMP(*MARK)) { + if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1) { *MARK = sv_mortalcopy(*MARK); TAINT_NOT; /* Each item is independent */ } @@ -2563,173 +2522,6 @@ PP(pp_leavesub) return cx->blk_sub.retop; } -/* This duplicates the above code because the above code must not - * get any slower by more conditions */ -PP(pp_leavesublv) -{ - dVAR; dSP; - SV **mark; - SV **newsp; - PMOP *newpm; - I32 gimme; - register PERL_CONTEXT *cx; - SV *sv; - - if (CxMULTICALL(&cxstack[cxstack_ix])) - return 0; - - POPBLOCK(cx,newpm); - cxstack_ix++; /* temporarily protect top context */ - - TAINT_NOT; - - if (CxLVAL(cx) & OPpENTERSUB_INARGS) { - /* We are an argument to a function or grep(). - * This kind of lvalueness was legal before lvalue - * subroutines too, so be backward compatible: - * cannot report errors. */ - - /* Scalar context *is* possible, on the LHS of -> only, - * as in f()->meth(). But this is not an lvalue. */ - if (gimme == G_SCALAR) - goto temporise; - if (gimme == G_ARRAY) { - if (!CvLVALUE(cx->blk_sub.cv)) - goto temporise_array; - EXTEND_MORTAL(SP - newsp); - for (mark = newsp + 1; mark <= SP; mark++) { - if (SvTEMP(*mark)) - NOOP; - else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY)) - *mark = sv_mortalcopy(*mark); - else { - /* Can be a localized value subject to deletion. */ - PL_tmps_stack[++PL_tmps_ix] = *mark; - SvREFCNT_inc_void(*mark); - } - } - } - } - else if (CxLVAL(cx)) { /* Leave it as it is if we can. */ - /* Here we go for robustness, not for speed, so we change all - * the refcounts so the caller gets a live guy. Cannot set - * TEMP, so sv_2mortal is out of question. */ - if (!CvLVALUE(cx->blk_sub.cv)) { - LEAVE; - cxstack_ix--; - POPSUB(cx,sv); - PL_curpm = newpm; - LEAVESUB(sv); - DIE(aTHX_ "Can't modify non-lvalue subroutine call"); - } - if (gimme == G_SCALAR) { - MARK = newsp + 1; - EXTEND_MORTAL(1); - if (MARK == SP) { - /* Temporaries are bad unless they happen to have set magic - * attached, such as the elements of a tied hash or array */ - if ((SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP) || - (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE)) - == SVf_READONLY - ) && - !SvSMAGICAL(TOPs)) { - LEAVE; - cxstack_ix--; - POPSUB(cx,sv); - PL_curpm = newpm; - LEAVESUB(sv); - DIE(aTHX_ "Can't return %s from lvalue subroutine", - SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef" - : "a readonly value" : "a temporary"); - } - else { /* Can be a localized value - * subject to deletion. */ - PL_tmps_stack[++PL_tmps_ix] = *mark; - SvREFCNT_inc_void(*mark); - } - } - else { /* Should not happen? */ - LEAVE; - cxstack_ix--; - POPSUB(cx,sv); - PL_curpm = newpm; - LEAVESUB(sv); - DIE(aTHX_ "%s returned from lvalue subroutine in scalar context", - (MARK > SP ? "Empty array" : "Array")); - } - SP = MARK; - } - else if (gimme == G_ARRAY) { - EXTEND_MORTAL(SP - newsp); - for (mark = newsp + 1; mark <= SP; mark++) { - if (*mark != &PL_sv_undef - && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { - /* Might be flattened array after $#array = */ - PUTBACK; - LEAVE; - cxstack_ix--; - POPSUB(cx,sv); - PL_curpm = newpm; - LEAVESUB(sv); - DIE(aTHX_ "Can't return a %s from lvalue subroutine", - SvREADONLY(TOPs) ? "readonly value" : "temporary"); - } - else { - /* Can be a localized value subject to deletion. */ - PL_tmps_stack[++PL_tmps_ix] = *mark; - SvREFCNT_inc_void(*mark); - } - } - } - } - else { - if (gimme == G_SCALAR) { - temporise: - MARK = newsp + 1; - if (MARK <= SP) { - if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { - if (SvTEMP(TOPs)) { - *MARK = SvREFCNT_inc(TOPs); - FREETMPS; - sv_2mortal(*MARK); - } - else { - sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */ - FREETMPS; - *MARK = sv_mortalcopy(sv); - SvREFCNT_dec(sv); - } - } - else - *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs); - } - else { - MEXTEND(MARK, 0); - *MARK = &PL_sv_undef; - } - SP = MARK; - } - else if (gimme == G_ARRAY) { - temporise_array: - for (MARK = newsp + 1; MARK <= SP; MARK++) { - if (!SvTEMP(*MARK)) { - *MARK = sv_mortalcopy(*MARK); - TAINT_NOT; /* Each item is independent */ - } - } - } - } - PUTBACK; - - LEAVE; - cxstack_ix--; - POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ - PL_curpm = newpm; /* ... and pop $1 et al */ - - LEAVESUB(sv); - return cx->blk_sub.retop; -} - PP(pp_entersub) { dVAR; dSP; dPOPss; @@ -2764,12 +2556,16 @@ PP(pp_entersub) if (sv == &PL_sv_yes) { /* unfound import, ignore */ if (hasargs) SP = PL_stack_base + POPMARK; + else + (void)POPMARK; RETURN; } SvGETMAGIC(sv); if (SvROK(sv)) { - SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */ - tryAMAGICunDEREF(to_cv); + if (SvAMAGIC(sv)) { + sv = amagic_deref_call(sv, to_cv_amg); + /* Don't SPAGAIN here. */ + } } else { const char *sym; @@ -2799,6 +2595,8 @@ PP(pp_entersub) SAVETMPS; retry: + if (CvCLONE(cv) && ! CvCLONED(cv)) + DIE(aTHX_ "Closure prototype called"); if (!CvROOT(cv) && !CvXSUB(cv)) { GV* autogv; SV* sub_name;