X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=476fd805d09902166fa516878a280f9e7efe2391;hb=4dc4bba60f13ed8dad154870e750085525979ec1;hp=498d50854158cd23b9df4422ee472f479a2a439b;hpb=3a76ca8818b782f5517982af5ac3381a6a3eb189;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index 498d508..476fd80 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1,7 +1,7 @@ /* pp_hot.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -138,7 +138,7 @@ PP(pp_sassign) assert(SvROK(cv)); } - /* Can do the optimisation if right (LVAUE) is not a typeglob, + /* Can do the optimisation if right (LVALUE) is not a typeglob, left (RVALUE) is a reference to something, and we're in void context. */ if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) { @@ -150,7 +150,7 @@ PP(pp_sassign) SV *const value = SvRV(cv); SvUPGRADE((SV *)gv, SVt_RV); - SvROK_on(gv); + SvPCS_IMPORTED_on(gv); SvRV_set(gv, value); SvREFCNT_inc_simple_void(value); SETs(right); @@ -180,6 +180,10 @@ PP(pp_sassign) LEAVE; } + if (strEQ(GvNAME(right),"isa")) { + GvCVGEN(right) = 0; + ++PL_sub_generation; + } } SvSetMagicSV(right, left); SETs(right); @@ -417,7 +421,7 @@ PP(pp_defined) register SV* sv; bool defined; const int op_type = PL_op->op_type; - const int is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN); + const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN); if (is_dor) { sv = TOPs; @@ -752,7 +756,11 @@ PP(pp_print) if (MARK <= SP) goto just_say_no; else { - if (PL_ors_sv && SvOK(PL_ors_sv)) + if (PL_op->op_type == OP_SAY) { + if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp)) + goto just_say_no; + } + else if (PL_ors_sv && SvOK(PL_ors_sv)) if (!do_print(PL_ors_sv, fp)) /* $\ */ goto just_say_no; @@ -1296,6 +1304,7 @@ PP(pp_match) 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; @@ -1342,18 +1351,23 @@ PP(pp_match) 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->reganch & ROPT_GPOS_SEEN)) + if (!(rx->extflags & RXf_GPOS_SEEN)) rx->endp[0] = rx->startp[0] = mg->mg_len; - else if (rx->reganch & ROPT_ANCH_GPOS) { + else if (rx->extflags & RXf_ANCH_GPOS) { r_flags |= REXEC_IGNOREPOS; rx->endp[0] = rx->startp[0] = mg->mg_len; - } - minmatch = (mg->mg_flags & MGf_MINMATCH); + } else if (rx->extflags & RXf_GPOS_FLOAT) + gpos = mg->mg_len; + else + rx->endp[0] = rx->startp[0] = mg->mg_len; + minmatch = (mg->mg_flags & MGf_MINMATCH) ? rx->gofs + 1 : 0; update_minmatch = 0; } } } - if ((!global && rx->nparens) + /* 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)) r_flags |= REXEC_COPY_STR; if (SvSCREAM(TARG)) @@ -1361,29 +1375,29 @@ PP(pp_match) play_it_again: if (global && rx->startp[0] != -1) { - t = s = rx->endp[0] + truebase; - if ((s + rx->minlen) > strend) + t = s = rx->endp[0] + truebase - rx->gofs; + if ((s + rx->minlen) > strend || s < truebase) goto nope; if (update_minmatch++) minmatch = had_zerolen; } - if (rx->reganch & RE_USE_INTUIT && - DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) { + if (rx->extflags & RXf_USE_INTUIT && + DO_UTF8(TARG) == ((rx->extflags & RXf_UTF8) != 0)) { /* FIXME - can PL_bostr be made const char *? */ PL_bostr = (char *)truebase; - s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)strend, r_flags, NULL); + s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL); if (!s) goto nope; - if ( (rx->reganch & ROPT_CHECK_ALL) + if ( (rx->extflags & RXf_CHECK_ALL) && !PL_sawampersand - && ((rx->reganch & ROPT_NOSCAN) - || !((rx->reganch & RE_INTUIT_TAIL) + && ((rx->extflags & RXf_NOSCAN) + || !((rx->extflags & RXf_INTUIT_TAIL) && (r_flags & REXEC_SCREAM))) && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */ goto yup; } - if (CALLREGEXEC(aTHX_ rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, NULL, r_flags)) + if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, INT2PTR(void*, gpos), r_flags)) { PL_curpm = pm; if (dynpm->op_pmflags & PMf_ONCE) @@ -1433,14 +1447,14 @@ play_it_again: } if (rx->startp[0] != -1) { mg->mg_len = rx->endp[0]; - if (rx->startp[0] == rx->endp[0]) + if (rx->startp[0] + rx->gofs == (UV)rx->endp[0]) mg->mg_flags |= MGf_MINMATCH; else mg->mg_flags &= ~MGf_MINMATCH; } } had_zerolen = (rx->startp[0] != -1 - && rx->startp[0] == rx->endp[0]); + && rx->startp[0] + rx->gofs == (UV)rx->endp[0]); PUTBACK; /* EVAL blocks may use stack */ r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; goto play_it_again; @@ -1467,7 +1481,7 @@ play_it_again: } if (rx->startp[0] != -1) { mg->mg_len = rx->endp[0]; - if (rx->startp[0] == rx->endp[0]) + if (rx->startp[0] + rx->gofs == (UV)rx->endp[0]) mg->mg_flags |= MGf_MINMATCH; else mg->mg_flags &= ~MGf_MINMATCH; @@ -1493,11 +1507,11 @@ yup: /* Confirmed by INTUIT */ rx->subbeg = (char *) truebase; rx->startp[0] = s - truebase; if (RX_MATCH_UTF8(rx)) { - char * const t = (char*)utf8_hop((U8*)s, rx->minlen); + char * const t = (char*)utf8_hop((U8*)s, rx->minlenret); rx->endp[0] = t - truebase; } else { - rx->endp[0] = s - truebase + rx->minlen; + rx->endp[0] = s - truebase + rx->minlenret; } rx->sublen = strend - truebase; goto gotcha; @@ -1509,7 +1523,7 @@ yup: /* Confirmed by INTUIT */ 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), truebase, t, + (int) SvTYPE(TARG), (void*)truebase, (void*)t, (int)(t-truebase)); } rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG); @@ -1527,11 +1541,11 @@ yup: /* Confirmed by INTUIT */ rx->sublen = strend - t; RX_MATCH_COPIED_on(rx); off = rx->startp[0] = s - t; - rx->endp[0] = off + rx->minlen; + rx->endp[0] = off + rx->minlenret; } else { /* startp/endp are used by @- @+. */ rx->startp[0] = s - truebase; - rx->endp[0] = s - truebase + rx->minlen; + rx->endp[0] = s - truebase + rx->minlenret; } rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */ LEAVE_SCOPE(oldsave); @@ -1636,8 +1650,14 @@ Perl_do_readline(pTHX) have_fp: if (gimme == G_SCALAR) { sv = TARG; - if (SvROK(sv)) - sv_unref(sv); + if (type == OP_RCATLINE && SvGMAGICAL(sv)) + mg_get(sv); + if (SvROK(sv)) { + if (type == OP_RCATLINE) + SvPV_force_nolen(sv); + else + sv_unref(sv); + } else if (isGV_with_GP(sv)) { SvPV_force_nolen(sv); } @@ -1818,7 +1838,7 @@ PP(pp_helem) SV* lv; SV* key2; if (!defer) { - DIE(aTHX_ PL_no_helem_sv, keysv); + DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); } lv = sv_newmortal(); sv_upgrade(lv, SVt_PVLV); @@ -1937,7 +1957,9 @@ PP(pp_iter) /* string increment */ register SV* cur = cx->blk_loop.iterlval; STRLEN maxlen = 0; - const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : ""; + const char *max = + SvOK((SV*)av) ? + SvPV_const((SV*)av, maxlen) : (const char *)""; if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) { if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { /* safe to reuse old SV */ @@ -2098,7 +2120,8 @@ PP(pp_subst) !is_cow && #endif (SvREADONLY(TARG) - || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV) + || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG)) + || SvTYPE(TARG) > SVt_PVLV) && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))) DIE(aTHX_ PL_no_modify); PUTBACK; @@ -2135,17 +2158,17 @@ PP(pp_subst) r_flags |= REXEC_SCREAM; orig = m = s; - if (rx->reganch & RE_USE_INTUIT) { + if (rx->extflags & RXf_USE_INTUIT) { PL_bostr = orig; - s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL); + s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL); if (!s) goto nope; /* How to do it in subst? */ -/* if ( (rx->reganch & ROPT_CHECK_ALL) +/* if ( (rx->extflags & RXf_CHECK_ALL) && !PL_sawampersand - && ((rx->reganch & ROPT_NOSCAN) - || !((rx->reganch & RE_INTUIT_TAIL) + && ((rx->extflags & RXf_NOSCAN) + || !((rx->extflags & RXf_INTUIT_TAIL) && (r_flags & REXEC_SCREAM)))) goto yup; */ @@ -2182,10 +2205,10 @@ PP(pp_subst) #ifdef PERL_OLD_COPY_ON_WRITE && !is_cow #endif - && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR)) - && !(rx->reganch & ROPT_LOOKBEHIND_SEEN) + && (I32)clen <= rx->minlenret && (once || !(r_flags & REXEC_COPY_STR)) + && !(rx->extflags & RXf_LOOKBEHIND_SEEN) && (!doutf8 || SvUTF8(TARG))) { - if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, + if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL, r_flags | REXEC_CHECKED)) { SPAGAIN; @@ -2263,7 +2286,7 @@ PP(pp_subst) d += clen; } s = rx->endp[0] + orig; - } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, + } while (CALLREGEXEC(rx, s, strend, orig, s == m, TARG, NULL, /* don't match same null twice */ REXEC_NOT_FIRST|REXEC_IGNOREPOS)); @@ -2290,7 +2313,7 @@ PP(pp_subst) RETURN; } - if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, + if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL, r_flags | REXEC_CHECKED)) { if (force_on_match) { @@ -2335,7 +2358,7 @@ PP(pp_subst) sv_catpvn(dstr, c, clen); if (once) break; - } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, + } while (CALLREGEXEC(rx, s, strend, orig, s == m, TARG, NULL, r_flags)); if (doutf8 && !DO_UTF8(TARG)) sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv); @@ -2660,45 +2683,6 @@ PP(pp_leavesublv) return cx->blk_sub.retop; } - -STATIC CV * -S_get_db_sub(pTHX_ SV **svp, CV *cv) -{ - dVAR; - SV * const dbsv = GvSVn(PL_DBsub); - - save_item(dbsv); - if (!PERLDB_SUB_NN) { - GV * const gv = CvGV(cv); - - if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) - || strEQ(GvNAME(gv), "END") - || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ - !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) ))) { - /* Use GV from the stack as a fallback. */ - /* GV is potentially non-unique, or contain different CV. */ - SV * const tmp = newRV((SV*)cv); - sv_setsv(dbsv, tmp); - SvREFCNT_dec(tmp); - } - else { - gv_efullname3(dbsv, gv, NULL); - } - } - else { - const int type = SvTYPE(dbsv); - if (type < SVt_PVIV && type != SVt_IV) - sv_upgrade(dbsv, SVt_PVIV); - (void)SvIOK_on(dbsv); - SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */ - } - - if (CvISXSUB(cv)) - PL_curcopdb = PL_curcop; - cv = GvCV(PL_DBsub); - return cv; -} - PP(pp_entersub) { dVAR; dSP; dPOPss; @@ -2793,7 +2777,7 @@ try_autoload: else { sub_name = sv_newmortal(); gv_efullname3(sub_name, gv, NULL); - DIE(aTHX_ "Undefined subroutine &%"SVf" called", (void*)sub_name); + DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name)); } } if (!cv) @@ -2806,7 +2790,11 @@ try_autoload: if (CvASSERTION(cv) && PL_DBassertion) sv_setiv(PL_DBassertion, 1); - cv = get_db_sub(&sv, cv); + Perl_get_db_sub(aTHX_ &sv, cv); + if (CvISXSUB(cv)) + PL_curcopdb = PL_curcop; + cv = GvCV(PL_DBsub); + if (!cv || (!CvXSUB(cv) && !CvSTART(cv))) DIE(aTHX_ "No DB::sub routine defined"); } @@ -2850,13 +2838,13 @@ try_autoload: SV **ary = AvALLOC(av); if (AvARRAY(av) != ary) { AvMAX(av) += AvARRAY(av) - AvALLOC(av); - SvPV_set(av, (char*)ary); + AvARRAY(av) = ary; } if (items > AvMAX(av) + 1) { AvMAX(av) = items - 1; Renew(ary,items,SV*); AvALLOC(av) = ary; - SvPV_set(av, (char*)ary); + AvARRAY(av) = ary; } } Copy(MARK,AvARRAY(av),items,SV*); @@ -2877,7 +2865,7 @@ try_autoload: sub_crush_depth(cv); #if 0 DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p entersub returning %p\n", thr, CvSTART(cv))); + "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv))); #endif RETURNOP(CvSTART(cv)); } @@ -2933,7 +2921,7 @@ Perl_sub_crush_depth(pTHX_ CV *cv) SV* const tmpstr = sv_newmortal(); gv_efullname3(tmpstr, CvGV(cv), NULL); Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"", - (void*)tmpstr); + SVfARG(tmpstr)); } } @@ -2951,7 +2939,7 @@ PP(pp_aelem) if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", - (void*)elemsv); + SVfARG(elemsv)); if (elem > 0) elem -= CopARYBASE_get(PL_curcop); if (SvTYPE(av) != SVt_PVAV)