X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=2f2876bac982c87e3c0ae3c54030e32d548b3af8;hb=19b95bf092bc6fdb9455fe107fc46111b0a1ec31;hp=f1ad3edee56ae0945e1ef0a29f80c88d5d52f00e;hpb=780a5241a93925d81e932db73df46ee749b203b9;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index f1ad3ed..2f2876b 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -39,7 +39,14 @@ PP(pp_const) { dVAR; dSP; - XPUSHs(cSVOP_sv); + if ( PL_op->op_flags & OPf_SPECIAL ) + /* This is a const op added to hold the hints hash for + pp_entereval. The hash can be modified by the code + being eval'ed, so we return a copy instead. */ + XPUSHs(sv_2mortal((SV*)Perl_hv_copy_hints_hv(aTHX_ (HV*)cSVOP_sv))); + else + /* Normal const. */ + XPUSHs(cSVOP_sv); RETURN; } @@ -123,8 +130,11 @@ PP(pp_sassign) else if (PL_op->op_private & OPpASSIGN_STATE) { if (SvPADSTALE(right)) SvPADSTALE_off(right); - else + else { + (void)POPs; + PUSHs(right); RETURN; /* ignore assignment */ + } } if (PL_tainting && PL_tainted && !SvTAINTED(left)) TAINT_NOT; @@ -782,23 +792,30 @@ PP(pp_print) PP(pp_rv2av) { dVAR; dSP; dTOPss; - AV *av; + const I32 gimme = GIMME_V; + static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context"; + static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context"; + static const char an_array[] = "an ARRAY"; + static const char a_hash[] = "a HASH"; + const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV; + const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV; if (SvROK(sv)) { wasref: - tryAMAGICunDEREF(to_av); + tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg); - av = (AV*)SvRV(sv); - if (SvTYPE(av) != SVt_PVAV) - DIE(aTHX_ "Not an ARRAY reference"); + sv = SvRV(sv); + if (SvTYPE(sv) != type) + DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash); if (PL_op->op_flags & OPf_REF) { - SETs((SV*)av); + SETs(sv); RETURN; } else if (LVRET) { - if (GIMME == G_SCALAR) - Perl_croak(aTHX_ "Can't return array to lvalue scalar context"); - SETs((SV*)av); + if (gimme != G_ARRAY) + Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar + : return_hash_to_lvalue_scalar); + SETs(sv); RETURN; } else if (PL_op->op_flags & OPf_MOD @@ -806,17 +823,17 @@ PP(pp_rv2av) Perl_croak(aTHX_ PL_no_localize_ref); } else { - if (SvTYPE(sv) == SVt_PVAV) { - av = (AV*)sv; + if (SvTYPE(sv) == type) { if (PL_op->op_flags & OPf_REF) { - SETs((SV*)av); + SETs(sv); RETURN; } else if (LVRET) { - if (GIMME == G_SCALAR) - Perl_croak(aTHX_ "Can't return array to lvalue" - " scalar context"); - SETs((SV*)av); + if (gimme != G_ARRAY) + Perl_croak(aTHX_ + is_pp_rv2av ? return_array_to_lvalue_scalar + : return_hash_to_lvalue_scalar); + SETs(sv); RETURN; } } @@ -829,56 +846,38 @@ PP(pp_rv2av) if (SvROK(sv)) goto wasref; } - if (!SvOK(sv)) { - if (PL_op->op_flags & OPf_REF || - PL_op->op_private & HINT_STRICT_REFS) - DIE(aTHX_ PL_no_usym, "an ARRAY"); - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - if (GIMME == G_ARRAY) { - (void)POPs; - RETURN; - } - RETSETUNDEF; - } - if ((PL_op->op_flags & OPf_SPECIAL) && - !(PL_op->op_flags & OPf_MOD)) - { - gv = (GV*)gv_fetchsv(sv, 0, SVt_PVAV); - if (!gv - && (!is_gv_magical_sv(sv,0) - || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV)))) - { - RETSETUNDEF; - } - } - else { - if (PL_op->op_private & HINT_STRICT_REFS) - DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY"); - gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV); - } + gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash, + type, &sp); + if (!gv) + RETURN; } else { gv = (GV*)sv; } - av = GvAVn(gv); + sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv); if (PL_op->op_private & OPpLVAL_INTRO) - av = save_ary(gv); + sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv); if (PL_op->op_flags & OPf_REF) { - SETs((SV*)av); + SETs(sv); RETURN; } else if (LVRET) { - if (GIMME == G_SCALAR) - Perl_croak(aTHX_ "Can't return array to lvalue" - " scalar context"); - SETs((SV*)av); + if (gimme != G_ARRAY) + Perl_croak(aTHX_ + is_pp_rv2av ? return_array_to_lvalue_scalar + : return_hash_to_lvalue_scalar); + SETs(sv); RETURN; } } } - if (GIMME == G_ARRAY) { + if (is_pp_rv2av) { + AV *const av = (AV*)sv; + /* The guts of pp_rv2av, with no intenting 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); @@ -897,122 +896,24 @@ PP(pp_rv2av) } SP += maxarg; } - else if (GIMME_V == G_SCALAR) { + else if (gimme == G_SCALAR) { dTARGET; const I32 maxarg = AvFILL(av) + 1; SETi(maxarg); } - RETURN; -} - -PP(pp_rv2hv) -{ - dVAR; dSP; dTOPss; - HV *hv; - const I32 gimme = GIMME_V; - static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context"; - - if (SvROK(sv)) { - wasref: - tryAMAGICunDEREF(to_hv); - - hv = (HV*)SvRV(sv); - if (SvTYPE(hv) != SVt_PVHV) - DIE(aTHX_ "Not a HASH reference"); - if (PL_op->op_flags & OPf_REF) { - SETs((SV*)hv); - RETURN; - } - else if (LVRET) { - if (gimme != G_ARRAY) - Perl_croak(aTHX_ return_hash_to_lvalue_scalar ); - SETs((SV*)hv); - RETURN; - } - else if (PL_op->op_flags & OPf_MOD - && PL_op->op_private & OPpLVAL_INTRO) - Perl_croak(aTHX_ PL_no_localize_ref); - } - else { - if (SvTYPE(sv) == SVt_PVHV) { - hv = (HV*)sv; - if (PL_op->op_flags & OPf_REF) { - SETs((SV*)hv); - RETURN; - } - else if (LVRET) { - if (gimme != G_ARRAY) - Perl_croak(aTHX_ return_hash_to_lvalue_scalar ); - SETs((SV*)hv); - RETURN; - } - } - else { - GV *gv; - - if (SvTYPE(sv) != SVt_PVGV) { - if (SvGMAGICAL(sv)) { - mg_get(sv); - if (SvROK(sv)) - goto wasref; - } - if (!SvOK(sv)) { - if (PL_op->op_flags & OPf_REF || - PL_op->op_private & HINT_STRICT_REFS) - DIE(aTHX_ PL_no_usym, "a HASH"); - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - if (gimme == G_ARRAY) { - SP--; - RETURN; - } - RETSETUNDEF; - } - if ((PL_op->op_flags & OPf_SPECIAL) && - !(PL_op->op_flags & OPf_MOD)) - { - gv = (GV*)gv_fetchsv(sv, 0, SVt_PVHV); - if (!gv - && (!is_gv_magical_sv(sv,0) - || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV)))) - { - RETSETUNDEF; - } - } - else { - if (PL_op->op_private & HINT_STRICT_REFS) - DIE(aTHX_ PL_no_symref_sv, sv, "a HASH"); - gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV); - } - } - else { - gv = (GV*)sv; - } - hv = GvHVn(gv); - if (PL_op->op_private & OPpLVAL_INTRO) - hv = save_hash(gv); - if (PL_op->op_flags & OPf_REF) { - SETs((SV*)hv); - RETURN; - } - else if (LVRET) { - if (gimme != G_ARRAY) - Perl_croak(aTHX_ return_hash_to_lvalue_scalar ); - SETs((SV*)hv); - RETURN; - } - } - } - + } else { + /* The guts of pp_rv2hv */ if (gimme == G_ARRAY) { /* array wanted */ - *PL_stack_sp = (SV*)hv; + *PL_stack_sp = sv; return do_kv(); } else if (gimme == G_SCALAR) { dTARGET; - TARG = Perl_hv_scalar(aTHX_ hv); + TARG = Perl_hv_scalar(aTHX_ (HV*)sv); + SPAGAIN; SETTARG; } + } RETURN; } @@ -1071,6 +972,12 @@ PP(pp_aassign) int duplicates = 0; SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */ + if (PL_op->op_private & OPpASSIGN_STATE) { + if (SvPADSTALE(*firstlelem)) + SvPADSTALE_off(*firstlelem); + else + RETURN; /* ignore assignment */ + } PL_delaymagic = DM_DELAY; /* catch simultaneous items */ gimme = GIMME_V; @@ -1088,12 +995,6 @@ PP(pp_aassign) } } } - if (PL_op->op_private & OPpASSIGN_STATE) { - if (SvPADSTALE(*firstlelem)) - SvPADSTALE_off(*firstlelem); - else - RETURN; /* ignore assignment */ - } relem = firstrelem; lelem = firstlelem; @@ -1282,7 +1183,8 @@ PP(pp_qr) if (pm->op_pmdynflags & PMdf_TAINTED) SvTAINTED_on(rv); sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0); - RETURNX(PUSHs(rv)); + XPUSHs(rv); + RETURN; } PP(pp_match) @@ -1347,19 +1249,19 @@ PP(pp_match) /* XXXX What part of this is needed with true \G-support? */ if ((global = dynpm->op_pmflags & PMf_GLOBAL)) { - rx->startp[0] = -1; + rx->offs[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 & RXf_GPOS_SEEN)) - rx->endp[0] = rx->startp[0] = mg->mg_len; + rx->offs[0].end = rx->offs[0].start = mg->mg_len; else if (rx->extflags & RXf_ANCH_GPOS) { r_flags |= REXEC_IGNOREPOS; - rx->endp[0] = rx->startp[0] = mg->mg_len; + rx->offs[0].end = rx->offs[0].start = mg->mg_len; } else if (rx->extflags & RXf_GPOS_FLOAT) gpos = mg->mg_len; else - rx->endp[0] = rx->startp[0] = mg->mg_len; + rx->offs[0].end = rx->offs[0].start = mg->mg_len; minmatch = (mg->mg_flags & MGf_MINMATCH) ? rx->gofs + 1 : 0; update_minmatch = 0; } @@ -1368,14 +1270,15 @@ PP(pp_match) /* remove comment to get faster /g but possibly unsafe $1 vars after a match. Test for the unsafe vars will fail as well*/ if (( /* !global && */ rx->nparens) - || SvTEMP(TARG) || PL_sawampersand || (pm->op_pmflags & PMf_EVAL)) + || SvTEMP(TARG) || PL_sawampersand || + (pm->op_pmflags & (PMf_EVAL|PMf_KEEPCOPY))) r_flags |= REXEC_COPY_STR; if (SvSCREAM(TARG)) r_flags |= REXEC_SCREAM; play_it_again: - if (global && rx->startp[0] != -1) { - t = s = rx->endp[0] + truebase - rx->gofs; + if (global && rx->offs[0].start != -1) { + t = s = rx->offs[0].end + truebase - rx->gofs; if ((s + rx->minlen) > strend || s < truebase) goto nope; if (update_minmatch++) @@ -1391,6 +1294,7 @@ play_it_again: goto nope; if ( (rx->extflags & RXf_CHECK_ALL) && !PL_sawampersand + && !(pm->op_pmflags & PMf_KEEPCOPY) && ((rx->extflags & RXf_NOSCAN) || !((rx->extflags & RXf_INTUIT_TAIL) && (r_flags & REXEC_SCREAM))) @@ -1421,10 +1325,10 @@ play_it_again: EXTEND_MORTAL(nparens + i); for (i = !i; i <= nparens; i++) { PUSHs(sv_newmortal()); - if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) { - const I32 len = rx->endp[i] - rx->startp[i]; - s = rx->startp[i] + truebase; - if (rx->endp[i] < 0 || rx->startp[i] < 0 || + if ((rx->offs[i].start != -1) && rx->offs[i].end != -1 ) { + const I32 len = rx->offs[i].end - rx->offs[i].start; + s = rx->offs[i].start + truebase; + if (rx->offs[i].end < 0 || rx->offs[i].start < 0 || len < 0 || len > strend - s) DIE(aTHX_ "panic: pp_match start/end pointers"); sv_setpvn(*SP, s, len); @@ -1445,16 +1349,17 @@ play_it_again: mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob, NULL, 0); } - if (rx->startp[0] != -1) { - mg->mg_len = rx->endp[0]; - if (rx->startp[0] + rx->gofs == (UV)rx->endp[0]) + if (rx->offs[0].start != -1) { + mg->mg_len = rx->offs[0].end; + if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end) mg->mg_flags |= MGf_MINMATCH; else mg->mg_flags &= ~MGf_MINMATCH; } } - had_zerolen = (rx->startp[0] != -1 - && rx->startp[0] + rx->gofs == (UV)rx->endp[0]); + had_zerolen = (rx->offs[0].start != -1 + && (rx->offs[0].start + rx->gofs + == (UV)rx->offs[0].end)); PUTBACK; /* EVAL blocks may use stack */ r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; goto play_it_again; @@ -1479,9 +1384,9 @@ play_it_again: mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob, NULL, 0); } - if (rx->startp[0] != -1) { - mg->mg_len = rx->endp[0]; - if (rx->startp[0] + rx->gofs == (UV)rx->endp[0]) + if (rx->offs[0].start != -1) { + mg->mg_len = rx->offs[0].end; + if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end) mg->mg_flags |= MGf_MINMATCH; else mg->mg_flags &= ~MGf_MINMATCH; @@ -1505,18 +1410,18 @@ yup: /* Confirmed by INTUIT */ if (global) { /* FIXME - should rx->subbeg be const char *? */ rx->subbeg = (char *) truebase; - rx->startp[0] = s - truebase; + rx->offs[0].start = s - truebase; if (RX_MATCH_UTF8(rx)) { char * const t = (char*)utf8_hop((U8*)s, rx->minlenret); - rx->endp[0] = t - truebase; + rx->offs[0].end = t - truebase; } else { - rx->endp[0] = s - truebase + rx->minlenret; + rx->offs[0].end = s - truebase + rx->minlenret; } rx->sublen = strend - truebase; goto gotcha; } - if (PL_sawampersand) { + if (PL_sawampersand || pm->op_pmflags & PMf_KEEPCOPY) { I32 off; #ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) { @@ -1540,13 +1445,15 @@ yup: /* Confirmed by INTUIT */ } rx->sublen = strend - t; RX_MATCH_COPIED_on(rx); - off = rx->startp[0] = s - t; - rx->endp[0] = off + rx->minlenret; + off = rx->offs[0].start = s - t; + rx->offs[0].end = off + rx->minlenret; } else { /* startp/endp are used by @- @+. */ - rx->startp[0] = s - truebase; - rx->endp[0] = s - truebase + rx->minlenret; + rx->offs[0].start = s - truebase; + rx->offs[0].end = s - truebase + rx->minlenret; } + /* including rx->nparens in the below code seems highly suspicious. + -dmq */ rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */ LEAVE_SCOPE(oldsave); RETPUSHYES; @@ -2049,8 +1956,7 @@ PP(pp_iter) if (lv) SvREFCNT_dec(LvTARG(lv)); else { - lv = cx->blk_loop.iterlval = newSV(0); - sv_upgrade(lv, SVt_PVLV); + lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV); LvTYPE(lv) = 'y'; sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0); } @@ -2152,7 +2058,7 @@ PP(pp_subst) rx = PM_GETRE(pm); } r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand - || (pm->op_pmflags & PMf_EVAL)) + || (pm->op_pmflags & (PMf_EVAL|PMf_KEEPCOPY)) ) ? REXEC_COPY_STR : 0; if (SvSCREAM(TARG)) r_flags |= REXEC_SCREAM; @@ -2167,6 +2073,7 @@ PP(pp_subst) /* How to do it in subst? */ /* if ( (rx->extflags & RXf_CHECK_ALL) && !PL_sawampersand + && !(pm->op_pmflags & PMf_KEEPCOPY) && ((rx->extflags & RXf_NOSCAN) || !((rx->extflags & RXf_INTUIT_TAIL) && (r_flags & REXEC_SCREAM)))) @@ -2232,8 +2139,8 @@ PP(pp_subst) SvSCREAM_off(TARG); /* disable possible screamer */ if (once) { rxtainted |= RX_MATCH_TAINTED(rx); - m = orig + rx->startp[0]; - d = orig + rx->endp[0]; + m = orig + rx->offs[0].start; + d = orig + rx->offs[0].end; s = orig; if (m - s > strend - d) { /* faster to shorten from end */ if (clen) { @@ -2275,7 +2182,7 @@ PP(pp_subst) if (iters++ > maxiters) DIE(aTHX_ "Substitution loop"); rxtainted |= RX_MATCH_TAINTED(rx); - m = rx->startp[0] + orig; + m = rx->offs[0].start + orig; if ((i = m - s)) { if (s != d) Move(s, d, i, char); @@ -2285,7 +2192,7 @@ PP(pp_subst) Copy(c, d, clen, char); d += clen; } - s = rx->endp[0] + orig; + s = rx->offs[0].end + orig; } while (CALLREGEXEC(rx, s, strend, orig, s == m, TARG, NULL, /* don't match same null twice */ @@ -2348,12 +2255,12 @@ PP(pp_subst) s = orig + (m - s); strend = s + (strend - m); } - m = rx->startp[0] + orig; + m = rx->offs[0].start + orig; if (doutf8 && !SvUTF8(dstr)) sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv); else sv_catpvn(dstr, s, m-s); - s = rx->endp[0] + orig; + s = rx->offs[0].end + orig; if (clen) sv_catpvn(dstr, c, clen); if (once) @@ -3098,7 +3005,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) : "on an undefined value"); } /* assume it's a package name */ - stash = gv_stashpvn(packname, packlen, FALSE); + stash = gv_stashpvn(packname, packlen, 0); if (!stash) packsv = sv; else { @@ -3117,6 +3024,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) && SvOBJECT(ob)))) { Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference", + (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" : name); } @@ -3190,7 +3098,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) } /* we're relying on gv_fetchmethod not autovivifying the stash */ - if (gv_stashpvn(packname, packlen, FALSE)) { + if (gv_stashpvn(packname, packlen, 0)) { Perl_croak(aTHX_ "Can't locate object method \"%s\" via package \"%.*s\"", leaf, (int)packlen, packname);