X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a8a20bb606d6f1faffb9dd19f02579f3ce642620..03b6c93d31676fe9936f9a438ca3f9c1ba46fba9:/pp_hot.c diff --git a/pp_hot.c b/pp_hot.c index 38a5d4f..899f35f 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; + } } } @@ -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)); } } @@ -311,7 +322,7 @@ 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; @@ -365,8 +376,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_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) @@ -398,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--; @@ -756,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 @@ -923,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"; } @@ -947,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; } } @@ -977,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 @@ -1059,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: @@ -1129,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 @@ -1199,6 +1243,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; @@ -1207,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; @@ -1264,12 +1298,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); } @@ -1324,7 +1358,8 @@ PP(pp_match) (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 ( @@ -1335,15 +1370,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) @@ -1354,17 +1383,16 @@ 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; + goto nope; } truebase = t = s; /* XXXX What part of this is needed with true \G-support? */ - if ((global = dynpm->op_pmflags & PMf_GLOBAL)) { + if (global) { + MAGIC * const mg = mg_find_mglob(TARG); 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 (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) { @@ -1376,13 +1404,15 @@ PP(pp_match) 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; - } } } +#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 @@ -1404,22 +1434,41 @@ PP(pp_match) } 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); + s = CALLREG_INTUIT_START(rx, TARG, truebase, + (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; + { + /* we can match based purely on the result of INTUIT. + * Fix up all the things that won't get set because we skip + * calling regexec() */ + assert(!RX_NPARENS(rx)); + /* match via INTUIT shouldn't have any captures. + * Let @-, @+, $^N know */ + RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; + RX_MATCH_UTF8_set(rx, cBOOL(DO_UTF8(rx))); + if ( !(r_flags & REXEC_NOT_FIRST) ) + Perl_reg_set_capture_string(aTHX_ rx, + (char*)truebase, (char *)strend, + TARG, r_flags, cBOOL(DO_UTF8(TARG))); + + /* skipping regexec means that indices for $&, $-[0] etc not set */ + RX_OFFS(rx)[0].start = s - truebase; + RX_OFFS(rx)[0].end = + RX_MATCH_UTF8(rx) + ? (char*)utf8_hop((U8*)s, RX_MINLENRET(rx)) - truebase + : s - truebase + RX_MINLENRET(rx); + goto gotcha; + } } if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, NUM2PTR(void*, gpos), r_flags)) - goto ret_no; + goto nope; + gotcha: PL_curpm = pm; if (dynpm->op_pmflags & PMf_ONCE) { #ifdef USE_ITHREADS @@ -1429,11 +1478,34 @@ 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); + } + 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; + } + } + + 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; @@ -1457,26 +1529,6 @@ 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)); @@ -1484,118 +1536,16 @@ PP(pp_match) 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) @@ -1618,7 +1568,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); @@ -1776,7 +1726,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) { @@ -1854,7 +1804,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); @@ -1905,69 +1855,70 @@ PP(pp_iter) itersvp = CxITERVAR(cx); 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; - 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); - break; + 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; + } - case 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; break; + } - case CXt_LOOP_FOR: + case CXt_LOOP_FOR: /* iterate array */ { - /* iterate array */ AV *av = cx->blk_loop.state_u.ary.ary; SV *sv; bool av_is_stack = FALSE; @@ -1996,23 +1947,27 @@ PP(pp_iter) sv = AvARRAY(av)[ix]; } - if (sv && SvIS_FREED(sv)) { - *itersvp = NULL; - Perl_croak(aTHX_ "Use of freed value in iteration"); - } - if (sv) { - SvTEMP_off(sv); - SvREFCNT_inc_simple_void_NN(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) = cx->blk_loop.state_u.ary.ix; + LvTARGOFF(lv) = ix; LvTARGLEN(lv) = (STRLEN)UV_MAX; sv = lv; } @@ -2026,7 +1981,7 @@ PP(pp_iter) default: DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx)); } - RETPUSHYES; + RETPUSHYES; } /* @@ -2046,12 +2001,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 @@ -2126,7 +2080,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; @@ -2145,7 +2099,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; @@ -2154,7 +2108,7 @@ 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) @@ -2182,14 +2136,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); strend = s + len; - slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len; + slen = DO_UTF8(TARG) ? utf8_length((U8*)s, (U8*)strend) : len; maxiters = 2 * slen + 10; /* We can match twice at each position, once with zero-length, second time with non-zero. */ @@ -2200,17 +2152,20 @@ 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); + s = CALLREG_INTUIT_START(rx, TARG, orig, s, strend, r_flags, NULL); if (!s) goto ret_no; @@ -2262,20 +2217,21 @@ 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) { @@ -2368,7 +2324,7 @@ PP(pp_subst) s = 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 */ @@ -2434,7 +2390,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 @@ -2531,6 +2487,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; @@ -2572,7 +2532,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 @@ -2676,7 +2636,6 @@ PP(pp_entersub) } ENTER; - SAVETMPS; retry: if (CvCLONE(cv) && ! CvCLONED(cv)) @@ -2765,28 +2724,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"); @@ -2802,8 +2762,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 @@ -2852,8 +2819,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)); } @@ -3025,6 +2999,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; @@ -3073,10 +3060,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)))) {