X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=fc2b9c5925f97c73746c37ecb1983b5b40de7fff;hb=6a93df2e699ee31021f3373dcafbb41d67f7f951;hp=0b3d6228c378795c6de001d2d729fefeae16b41a;hpb=0dae17bd7971d11b90a07b6fc03ec78ab38e4db4;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index 0b3d622..fc2b9c5 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1,6 +1,7 @@ /* pp_hot.c * - * Copyright (c) 1991-2002, Larry Wall + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, + * 2000, 2001, 2002, 2003, 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. @@ -136,11 +137,12 @@ PP(pp_concat) bool lbyte; STRLEN rlen; char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */ - bool rbyte = !SvUTF8(right); + bool rbyte = !SvUTF8(right), rcopied = FALSE; if (TARG == right && right != left) { right = sv_2mortal(newSVpvn(rpv, rlen)); rpv = SvPV(right, rlen); /* no point setting UTF8 here */ + rcopied = TRUE; } if (TARG != left) { @@ -176,6 +178,8 @@ PP(pp_concat) if (lbyte) sv_utf8_upgrade_nomg(TARG); else { + if (!rcopied) + right = sv_2mortal(newSVpvn(rpv, rlen)); sv_utf8_upgrade_nomg(right); rpv = SvPV(right, rlen); } @@ -682,6 +686,9 @@ PP(pp_rv2av) SETs((SV*)av); 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_PVAV) { @@ -801,11 +808,14 @@ PP(pp_rv2hv) RETURN; } else if (LVRET) { - if (GIMME == G_SCALAR) + if (GIMME != G_SCALAR) Perl_croak(aTHX_ "Can't return hash to lvalue scalar context"); 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) { @@ -1180,7 +1190,7 @@ PP(pp_match) (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); TAINT_NOT; - PL_reg_match_utf8 = DO_UTF8(TARG); + RX_MATCH_UTF8_set(rx, DO_UTF8(TARG)); /* PMdf_USED is set after a ?? matches once */ if (pm->op_pmdynflags & PMdf_USED) { @@ -1355,7 +1365,7 @@ yup: /* Confirmed by INTUIT */ if (global) { rx->subbeg = truebase; rx->startp[0] = s - truebase; - if (PL_reg_match_utf8) { + if (RX_MATCH_UTF8(rx)) { char *t = (char*)utf8_hop((U8*)s, rx->minlen); rx->endp[0] = t - truebase; } @@ -1367,8 +1377,26 @@ yup: /* Confirmed by INTUIT */ } if (PL_sawampersand) { I32 off; +#ifdef PERL_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), truebase, t, + (int)(t-truebase)); + } + rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG); + rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase); + assert (SvPOKp(rx->saved_copy)); + } else +#endif + { - rx->subbeg = savepvn(t, strend - t); + rx->subbeg = savepvn(t, strend - t); +#ifdef PERL_COPY_ON_WRITE + rx->saved_copy = Nullsv; +#endif + } rx->sublen = strend - t; RX_MATCH_COPIED_on(rx); off = rx->startp[0] = s - t; @@ -1466,7 +1494,11 @@ Perl_do_readline(pTHX) report_evil_fh(PL_last_in_gv, io, PL_op->op_type); } if (gimme == G_SCALAR) { - (void)SvOK_off(TARG); + /* undef TARG, and push that undefined value */ + if (type != OP_RCATLINE) { + SV_CHECK_THINKFIRST_COW_DROP(TARG); + (void)SvOK_off(TARG); + } PUSHTARG; } RETURN; @@ -1478,7 +1510,7 @@ Perl_do_readline(pTHX) sv_unref(sv); (void)SvUPGRADE(sv, SVt_PV); tmplen = SvLEN(sv); /* remember if already alloced */ - if (!tmplen) + if (!tmplen && !SvREADONLY(sv)) Sv_Grow(sv, 80); /* try short-buffering it */ offset = 0; if (type == OP_RCATLINE && SvOK(sv)) { @@ -1527,7 +1559,10 @@ Perl_do_readline(pTHX) } } if (gimme == G_SCALAR) { - (void)SvOK_off(TARG); + if (type != OP_RCATLINE) { + SV_CHECK_THINKFIRST_COW_DROP(TARG); + (void)SvOK_off(TARG); + } SPAGAIN; PUSHTARG; } @@ -1824,6 +1859,12 @@ PP(pp_iter) else { sv = AvARRAY(av)[++cx->blk_loop.iterix]; } + if (sv && SvREFCNT(sv) == 0) { + *itersvp = Nullsv; + Perl_croak(aTHX_ + "Use of freed value in iteration (perhaps you modified the iterated array within the loop?)"); + } + if (sv) SvTEMP_off(sv); else @@ -1877,6 +1918,10 @@ PP(pp_subst) I32 oldsave = PL_savestack_ix; STRLEN slen; bool doutf8 = FALSE; +#ifdef PERL_COPY_ON_WRITE + bool is_cow; +#endif + SV *nsv = Nullsv; /* known replacement string? */ dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv; @@ -1887,11 +1932,21 @@ PP(pp_subst) EXTEND(SP,1); } +#ifdef PERL_COPY_ON_WRITE + /* Awooga. Awooga. "bool" types that are actually char are dangerous, + because they make integers such as 256 "false". */ + is_cow = SvIsCOW(TARG) ? TRUE : FALSE; +#else if (SvIsCOW(TARG)) sv_force_normal_flags(TARG,0); - if (SvREADONLY(TARG) +#endif + if ( +#ifdef PERL_COPY_ON_WRITE + !is_cow && +#endif + (SvREADONLY(TARG) || (SvTYPE(TARG) > SVt_PVLV - && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))) + && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))) DIE(aTHX_ PL_no_modify); PUTBACK; @@ -1904,14 +1959,14 @@ PP(pp_subst) rxtainted |= 2; TAINT_NOT; - PL_reg_match_utf8 = DO_UTF8(TARG); + RX_MATCH_UTF8_set(rx, DO_UTF8(TARG)); force_it: if (!pm || !s) DIE(aTHX_ "panic: pp_subst"); strend = s + len; - slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len; + slen = RX_MATCH_UTF8(rx) ? 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. */ @@ -1921,7 +1976,7 @@ PP(pp_subst) rx = PM_GETRE(pm); } r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand) - ? REXEC_COPY_STR : 0; + ? REXEC_COPY_STR : 0; if (SvSCREAM(TARG)) r_flags |= REXEC_SCREAM; if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { @@ -1952,7 +2007,7 @@ PP(pp_subst) if (dstr) { /* replacement needing upgrading? */ if (DO_UTF8(TARG) && !doutf8) { - SV *nsv = sv_newmortal(); + nsv = sv_newmortal(); SvSetSV(nsv, dstr); if (PL_encoding) sv_recode_to_utf8(nsv, PL_encoding); @@ -1972,8 +2027,13 @@ PP(pp_subst) } /* can do inplace substitution? */ - if (c && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR)) - && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) { + if (c +#ifdef PERL_COPY_ON_WRITE + && !is_cow +#endif + && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR)) + && !(rx->reganch & ROPT_LOOKBEHIND_SEEN) + && (!doutf8 || SvUTF8(TARG))) { if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, r_flags | REXEC_CHECKED)) { @@ -1982,6 +2042,12 @@ PP(pp_subst) LEAVE_SCOPE(oldsave); RETURN; } +#ifdef PERL_COPY_ON_WRITE + if (SvIsCOW(TARG)) { + assert (!force_on_match); + goto have_a_cow; + } +#endif if (force_on_match) { force_on_match = 0; s = SvPV_force(TARG, len); @@ -2083,6 +2149,9 @@ PP(pp_subst) s = SvPV_force(TARG, len); goto force_it; } +#ifdef PERL_COPY_ON_WRITE + have_a_cow: +#endif rxtainted |= RX_MATCH_TAINTED(rx); dstr = NEWSV(25, len); sv_setpvn(dstr, m, s-m); @@ -2092,6 +2161,7 @@ PP(pp_subst) if (!c) { register PERL_CONTEXT *cx; SPAGAIN; + ReREFCNT_inc(rx); PUSHSUBST(cx); RETURNOP(cPMOP->op_pmreplroot); } @@ -2108,7 +2178,10 @@ PP(pp_subst) strend = s + (strend - m); } m = rx->startp[0] + orig; - sv_catpvn(dstr, s, m-s); + 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; if (clen) sv_catpvn(dstr, c, clen); @@ -2116,17 +2189,26 @@ PP(pp_subst) break; } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, TARG, NULL, r_flags)); - if (doutf8 && !DO_UTF8(dstr)) { - SV* nsv = sv_2mortal(newSVpvn(s, strend - s)); - - sv_utf8_upgrade(nsv); - sv_catpvn(dstr, SvPVX(nsv), SvCUR(nsv)); - } + if (doutf8 && !DO_UTF8(TARG)) + sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv); else sv_catpvn(dstr, s, strend - s); - (void)SvOOK_off(TARG); - Safefree(SvPVX(TARG)); +#ifdef PERL_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 +#endif + { + (void)SvOOK_off(TARG); + if (SvLEN(TARG)) + Safefree(SvPVX(TARG)); + } SvPVX(TARG) = SvPVX(dstr); SvCUR_set(TARG, SvCUR(dstr)); SvLEN_set(TARG, SvLEN(dstr)); @@ -2246,10 +2328,10 @@ PP(pp_leavesub) } PUTBACK; + LEAVE; POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ - LEAVE; LEAVESUB(sv); return pop_return(); } @@ -2302,9 +2384,9 @@ PP(pp_leavesublv) * 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; POPSUB(cx,sv); PL_curpm = newpm; - LEAVE; LEAVESUB(sv); DIE(aTHX_ "Can't modify non-lvalue subroutine call"); } @@ -2313,9 +2395,9 @@ PP(pp_leavesublv) EXTEND_MORTAL(1); if (MARK == SP) { if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { + LEAVE; POPSUB(cx,sv); PL_curpm = newpm; - LEAVE; LEAVESUB(sv); DIE(aTHX_ "Can't return %s from lvalue subroutine", SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef" @@ -2328,9 +2410,9 @@ PP(pp_leavesublv) } } else { /* Should not happen? */ + LEAVE; POPSUB(cx,sv); PL_curpm = newpm; - LEAVE; LEAVESUB(sv); DIE(aTHX_ "%s returned from lvalue subroutine in scalar context", (MARK > SP ? "Empty array" : "Array")); @@ -2344,9 +2426,9 @@ PP(pp_leavesublv) && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { /* Might be flattened array after $#array = */ PUTBACK; + LEAVE; POPSUB(cx,sv); PL_curpm = newpm; - LEAVE; LEAVESUB(sv); DIE(aTHX_ "Can't return a %s from lvalue subroutine", SvREADONLY(TOPs) ? "readonly value" : "temporary"); @@ -2398,10 +2480,10 @@ PP(pp_leavesublv) } PUTBACK; + LEAVE; POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ - LEAVE; LEAVESUB(sv); return pop_return(); } @@ -2457,6 +2539,16 @@ PP(pp_entersub) if (!sv) DIE(aTHX_ "Not a CODE reference"); switch (SvTYPE(sv)) { + /* This is overwhelming the most common case: */ + case SVt_PVGV: + if (!(cv = GvCVu((GV*)sv))) + cv = sv_2cv(sv, &stash, &gv, FALSE); + if (!cv) { + ENTER; + SAVETMPS; + goto try_autoload; + } + break; default: if (!SvROK(sv)) { char *sym; @@ -2494,18 +2586,10 @@ PP(pp_entersub) case SVt_PVHV: case SVt_PVAV: DIE(aTHX_ "Not a CODE reference"); + /* This is the second most common case: */ case SVt_PVCV: cv = (CV*)sv; break; - case SVt_PVGV: - if (!(cv = GvCVu((GV*)sv))) - cv = sv_2cv(sv, &stash, &gv, FALSE); - if (!cv) { - ENTER; - SAVETMPS; - goto try_autoload; - } - break; } ENTER; @@ -2513,108 +2597,21 @@ PP(pp_entersub) retry: if (!CvROOT(cv) && !CvXSUB(cv)) { - GV* autogv; - SV* sub_name; - - /* anonymous or undef'd function leaves us no recourse */ - if (CvANON(cv) || !(gv = CvGV(cv))) - DIE(aTHX_ "Undefined subroutine called"); - - /* autoloaded stub? */ - if (cv != GvCV(gv)) { - cv = GvCV(gv); - } - /* should call AUTOLOAD now? */ - else { -try_autoload: - if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), - FALSE))) - { - cv = GvCV(autogv); - } - /* sorry */ - else { - sub_name = sv_newmortal(); - gv_efullname3(sub_name, gv, Nullch); - DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name)); - } - } - if (!cv) - DIE(aTHX_ "Not a CODE reference"); - goto retry; + goto fooey; } gimme = GIMME_V; if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) { + if (CvASSERTION(cv) && PL_DBassertion) + sv_setiv(PL_DBassertion, 1); + cv = get_db_sub(&sv, cv); if (!cv) DIE(aTHX_ "No DBsub routine"); } - if (CvXSUB(cv)) { -#ifdef PERL_XSUB_OLDSTYLE - if (CvOLDSTYLE(cv)) { - I32 (*fp3)(int,int,int); - dMARK; - register I32 items = SP - MARK; - /* We dont worry to copy from @_. */ - while (SP > mark) { - SP[1] = SP[0]; - SP--; - } - PL_stack_sp = mark + 1; - fp3 = (I32(*)(int,int,int))CvXSUB(cv); - items = (*fp3)(CvXSUBANY(cv).any_i32, - MARK - PL_stack_base + 1, - items); - PL_stack_sp = PL_stack_base + items; - } - else -#endif /* PERL_XSUB_OLDSTYLE */ - { - I32 markix = TOPMARK; - - PUTBACK; - - if (!hasargs) { - /* Need to copy @_ to stack. Alternative may be to - * switch stack to @_, and copy return values - * back. This would allow popping @_ in XSUB, e.g.. XXXX */ - AV* av; - I32 items; - av = GvAV(PL_defgv); - items = AvFILLp(av) + 1; /* @_ is not tieable */ - - if (items) { - /* Mark is at the end of the stack. */ - EXTEND(SP, items); - Copy(AvARRAY(av), SP + 1, items, SV*); - SP += items; - PUTBACK ; - } - } - /* We assume first XSUB in &DB::sub is the called one. */ - if (PL_curcopdb) { - SAVEVPTR(PL_curcop); - PL_curcop = PL_curcopdb; - PL_curcopdb = NULL; - } - /* Do we need to open block here? XXXX */ - (void)(*CvXSUB(cv))(aTHX_ cv); - - /* Enforce some sanity in scalar context. */ - if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) { - if (markix > PL_stack_sp - PL_stack_base) - *(PL_stack_base + markix) = &PL_sv_undef; - else - *(PL_stack_base + markix) = *PL_stack_sp; - PL_stack_sp = PL_stack_base + markix; - } - } - LEAVE; - return NORMAL; - } - else { + if (!(CvXSUB(cv))) { + /* This path taken at least 75% of the time */ dMARK; register I32 items = SP - MARK; AV* padlist = CvPADLIST(cv); @@ -2624,8 +2621,8 @@ try_autoload: CvDEPTH(cv)++; /* XXX This would be a natural place to set C so * that eval'' ops within this sub know the correct lexical space. - * Owing the speed considerations, we choose to search for the cv - * in doeval() instead. + * Owing the speed considerations, we choose instead to search for + * the cv using find_runcv() when calling doeval(). */ if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); @@ -2692,6 +2689,105 @@ try_autoload: #endif RETURNOP(CvSTART(cv)); } + else { +#ifdef PERL_XSUB_OLDSTYLE + if (CvOLDSTYLE(cv)) { + I32 (*fp3)(int,int,int); + dMARK; + register I32 items = SP - MARK; + /* We dont worry to copy from @_. */ + while (SP > mark) { + SP[1] = SP[0]; + SP--; + } + PL_stack_sp = mark + 1; + fp3 = (I32(*)(int,int,int))CvXSUB(cv); + items = (*fp3)(CvXSUBANY(cv).any_i32, + MARK - PL_stack_base + 1, + items); + PL_stack_sp = PL_stack_base + items; + } + else +#endif /* PERL_XSUB_OLDSTYLE */ + { + I32 markix = TOPMARK; + + PUTBACK; + + if (!hasargs) { + /* Need to copy @_ to stack. Alternative may be to + * switch stack to @_, and copy return values + * back. This would allow popping @_ in XSUB, e.g.. XXXX */ + AV* av; + I32 items; + av = GvAV(PL_defgv); + items = AvFILLp(av) + 1; /* @_ is not tieable */ + + if (items) { + /* Mark is at the end of the stack. */ + EXTEND(SP, items); + Copy(AvARRAY(av), SP + 1, items, SV*); + SP += items; + PUTBACK ; + } + } + /* We assume first XSUB in &DB::sub is the called one. */ + if (PL_curcopdb) { + SAVEVPTR(PL_curcop); + PL_curcop = PL_curcopdb; + PL_curcopdb = NULL; + } + /* Do we need to open block here? XXXX */ + (void)(*CvXSUB(cv))(aTHX_ cv); + + /* Enforce some sanity in scalar context. */ + if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) { + if (markix > PL_stack_sp - PL_stack_base) + *(PL_stack_base + markix) = &PL_sv_undef; + else + *(PL_stack_base + markix) = *PL_stack_sp; + PL_stack_sp = PL_stack_base + markix; + } + } + LEAVE; + return NORMAL; + } + + assert (0); /* Cannot get here. */ + /* This is deliberately moved here as spaghetti code to keep it out of the + hot path. */ + { + GV* autogv; + SV* sub_name; + + fooey: + /* anonymous or undef'd function leaves us no recourse */ + if (CvANON(cv) || !(gv = CvGV(cv))) + DIE(aTHX_ "Undefined subroutine called"); + + /* autoloaded stub? */ + if (cv != GvCV(gv)) { + cv = GvCV(gv); + } + /* should call AUTOLOAD now? */ + else { +try_autoload: + if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), + FALSE))) + { + cv = GvCV(autogv); + } + /* sorry */ + else { + sub_name = sv_newmortal(); + gv_efullname3(sub_name, gv, Nullch); + DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name); + } + } + if (!cv) + DIE(aTHX_ "Not a CODE reference"); + goto retry; + } } void @@ -2702,8 +2798,8 @@ Perl_sub_crush_depth(pTHX_ CV *cv) else { SV* tmpstr = sv_newmortal(); gv_efullname3(tmpstr, CvGV(cv), Nullch); - Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%s\"", - SvPVX(tmpstr)); + Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"", + tmpstr); } } @@ -2719,7 +2815,7 @@ PP(pp_aelem) SV *sv; if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%s\" as array index", SvPV_nolen(elemsv)); + Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv); if (elem > 0) elem -= PL_curcop->cop_arybase; if (SvTYPE(av) != SVt_PVAV) @@ -2803,7 +2899,7 @@ PP(pp_method) PP(pp_method_named) { dSP; - SV* sv = cSVOP->op_sv; + SV* sv = cSVOP_sv; U32 hash = SvUVX(sv); XPUSHs(method_common(sv, &hash)); @@ -2838,8 +2934,18 @@ S_method_common(pTHX_ SV* meth, U32* hashp) /* this isn't a reference */ packname = Nullch; + + if(SvOK(sv) && (packname = SvPV(sv, packlen))) { + HE* he; + he = hv_fetch_ent(PL_stashcache, sv, 0, 0); + if (he) { + stash = INT2PTR(HV*,SvIV(HeVAL(he))); + goto fetch; + } + } + if (!SvOK(sv) || - !(packname = SvPV(sv, packlen)) || + !(packname) || !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) || !(ob=(SV*)GvIO(iogv))) { @@ -2858,6 +2964,10 @@ S_method_common(pTHX_ SV* meth, U32* hashp) stash = gv_stashpvn(packname, packlen, FALSE); if (!stash) packsv = sv; + else { + SV* ref = newSViv(PTR2IV(stash)); + hv_store(PL_stashcache, packname, packlen, ref, 0); + } goto fetch; } /* it _is_ a filehandle name -- replace with a reference */ @@ -2914,7 +3024,11 @@ S_method_common(pTHX_ SV* meth, U32* hashp) /* the method name is unqualified or starts with SUPER:: */ packname = sep ? CopSTASHPV(PL_curcop) : stash ? HvNAME(stash) : packname; - packlen = strlen(packname); + if (!packname) + Perl_croak(aTHX_ + "Can't use anonymous symbol table for method lookup"); + else + packlen = strlen(packname); } else { /* the method name is qualified */