X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f272994b1ce9066a01ab0ed3d6c5353b37057838..5129fff43c4fe08cb17d8789b8a5c778039a25c3:/pp_hot.c diff --git a/pp_hot.c b/pp_hot.c index ec18858..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. @@ -21,10 +22,6 @@ /* Hot code. */ -#ifdef USE_5005THREADS -static void unset_cvowner(pTHX_ void *cvarg); -#endif /* USE_5005THREADS */ - PP(pp_const) { dSP; @@ -140,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) { @@ -180,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); } @@ -197,10 +197,10 @@ PP(pp_padsv) XPUSHs(TARG); if (PL_op->op_flags & OPf_MOD) { if (PL_op->op_private & OPpLVAL_INTRO) - SAVECLEARSV(PL_curpad[PL_op->op_targ]); + SAVECLEARSV(PAD_SVl(PL_op->op_targ)); else if (PL_op->op_private & OPpDEREF) { PUTBACK; - vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF); + vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF); SPAGAIN; } } @@ -320,6 +320,42 @@ PP(pp_or) } } +PP(pp_dor) +{ + /* Most of this is lifted straight from pp_defined */ + dSP; + register SV* sv; + + sv = TOPs; + if (!sv || !SvANY(sv)) { + --SP; + RETURNOP(cLOGOP->op_other); + } + + switch (SvTYPE(sv)) { + case SVt_PVAV: + if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) + RETURN; + break; + case SVt_PVHV: + if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) + RETURN; + break; + case SVt_PVCV: + if (CvROOT(sv) || CvXSUB(sv)) + RETURN; + break; + default: + if (SvGMAGICAL(sv)) + mg_get(sv); + if (SvOK(sv)) + RETURN; + } + + --SP; + RETURNOP(cLOGOP->op_other); +} + PP(pp_add) { dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN); @@ -571,7 +607,7 @@ PP(pp_print) goto had_magic; if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,RMS$_IFI); + SETERRNO(EBADF,RMS_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { @@ -581,7 +617,7 @@ PP(pp_print) else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); } - SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); + SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI); goto just_say_no; } else { @@ -650,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) { @@ -734,7 +773,7 @@ PP(pp_rv2av) EXTEND(SP, maxarg); if (SvRMAGICAL(av)) { U32 i; - for (i=0; i < maxarg; i++) { + for (i=0; i < (U32)maxarg; i++) { SV **svp = av_fetch(av, i, FALSE); SP[i+1] = (svp) ? *svp : &PL_sv_undef; } @@ -744,7 +783,7 @@ PP(pp_rv2av) } SP += maxarg; } - else { + else if (GIMME_V == G_SCALAR) { dTARGET; I32 maxarg = AvFILL(av) + 1; SETi(maxarg); @@ -762,21 +801,24 @@ PP(pp_rv2hv) tryAMAGICunDEREF(to_hv); hv = (HV*)SvRV(sv); - if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV) + 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_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 || SvTYPE(sv) == SVt_PVAV) { + if (SvTYPE(sv) == SVt_PVHV) { hv = (HV*)sv; if (PL_op->op_flags & OPf_REF) { SETs((SV*)hv); @@ -858,8 +900,6 @@ PP(pp_rv2hv) } else { dTARGET; - if (SvTYPE(hv) == SVt_PVAV) - hv = avhv_keys((AV*)hv); if (HvFILL(hv)) Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf, (IV)HvFILL(hv), (IV)HvMAX(hv) + 1); @@ -871,57 +911,14 @@ PP(pp_rv2hv) } } -STATIC int -S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem, - SV **lastrelem) -{ - OP *leftop; - I32 i; - - leftop = ((BINOP*)PL_op)->op_last; - assert(leftop); - assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST); - leftop = ((LISTOP*)leftop)->op_first; - assert(leftop); - /* Skip PUSHMARK and each element already assigned to. */ - for (i = lelem - firstlelem; i > 0; i--) { - leftop = leftop->op_sibling; - assert(leftop); - } - if (leftop->op_type != OP_RV2HV) - return 0; - - /* pseudohash */ - if (av_len(ary) > 0) - av_fill(ary, 0); /* clear all but the fields hash */ - if (lastrelem >= relem) { - while (relem < lastrelem) { /* gobble up all the rest */ - SV *tmpstr; - assert(relem[0]); - assert(relem[1]); - /* Avoid a memory leak when avhv_store_ent dies. */ - tmpstr = sv_newmortal(); - sv_setsv(tmpstr,relem[1]); /* value */ - relem[1] = tmpstr; - if (avhv_store_ent(ary,relem[0],tmpstr,0)) - (void)SvREFCNT_inc(tmpstr); - if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr)) - mg_set(tmpstr); - relem += 2; - TAINT_NOT; - } - } - if (relem == lastrelem) - return 1; - return 2; -} - STATIC void S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) { if (*relem) { SV *tmpstr; - if (ckWARN(WARN_MISC)) { + HE *didstore; + + if (ckWARN(WARN_MISC)) { if (relem == firstrelem && SvROK(*relem) && (SvTYPE(SvRV(*relem)) == SVt_PVAV || @@ -934,26 +931,16 @@ S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in hash assignment"); } - if (SvTYPE(hash) == SVt_PVAV) { - /* pseudohash */ - tmpstr = sv_newmortal(); - if (avhv_store_ent((AV*)hash,*relem,tmpstr,0)) - (void)SvREFCNT_inc(tmpstr); - if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr)) - mg_set(tmpstr); - } - else { - HE *didstore; - tmpstr = NEWSV(29,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; + + tmpstr = NEWSV(29,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; } } @@ -1005,19 +992,6 @@ PP(pp_aassign) case SVt_PVAV: ary = (AV*)sv; magic = SvMAGICAL(ary) != 0; - if (PL_op->op_private & OPpASSIGN_HASH) { - switch (do_maybe_phash(ary, lelem, firstlelem, relem, - lastrelem)) - { - case 0: - goto normal_array; - case 1: - do_oddball((HV*)ary, relem, firstrelem); - } - relem = lastrelem + 1; - break; - } - normal_array: av_clear(ary); av_extend(ary, lastrelem - relem); i = 0; @@ -1184,6 +1158,7 @@ PP(pp_match) { dSP; dTARG; register PMOP *pm = cPMOP; + PMOP *dynpm = pm; register char *t; register char *s; char *strend; @@ -1215,8 +1190,9 @@ 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) { failure: if (gimme == G_ARRAY) @@ -1224,17 +1200,19 @@ PP(pp_match) RETPUSHNO; } + /* empty pattern special-cased to use last successful pattern if possible */ if (!rx->prelen && PL_curpm) { pm = PL_curpm; rx = PM_GETRE(pm); } - if (rx->minlen > len) - goto failure; + + if (rx->minlen > (I32)len) + goto failure; truebase = t = s; /* XXXX What part of this is needed with true \G-support? */ - if ((global = pm->op_pmflags & PMf_GLOBAL)) { + if ((global = dynpm->op_pmflags & PMf_GLOBAL)) { rx->startp[0] = -1; if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global); @@ -1287,8 +1265,8 @@ play_it_again: if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags)) { PL_curpm = pm; - if (pm->op_pmflags & PMf_ONCE) - pm->op_pmdynflags |= PMdf_USED; + if (dynpm->op_pmflags & PMf_ONCE) + dynpm->op_pmdynflags |= PMdf_USED; goto gotcha; } else @@ -1325,7 +1303,7 @@ play_it_again: } } if (global) { - if (pm->op_pmflags & PMf_CONTINUE) { + if (dynpm->op_pmflags & PMf_CONTINUE) { MAGIC* mg = 0; if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) mg = mg_find(TARG, PERL_MAGIC_regex_global); @@ -1378,8 +1356,8 @@ yup: /* Confirmed by INTUIT */ RX_MATCH_TAINTED_on(rx); TAINT_IF(RX_MATCH_TAINTED(rx)); PL_curpm = pm; - if (pm->op_pmflags & PMf_ONCE) - pm->op_pmdynflags |= PMdf_USED; + if (dynpm->op_pmflags & PMf_ONCE) + dynpm->op_pmdynflags |= PMdf_USED; if (RX_MATCH_COPIED(rx)) Safefree(rx->subbeg); RX_MATCH_COPIED_off(rx); @@ -1387,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; } @@ -1399,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; @@ -1416,7 +1412,7 @@ yup: /* Confirmed by INTUIT */ nope: ret_no: - if (global && !(pm->op_pmflags & PMf_CONTINUE)) { + if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) { if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global); if (mg) @@ -1450,8 +1446,11 @@ Perl_do_readline(pTHX) call_method("READLINE", gimme); LEAVE; SPAGAIN; - if (gimme == G_SCALAR) - SvSetMagicSV_nosteal(TARG, TOPs); + if (gimme == G_SCALAR) { + SV* result = POPs; + SvSetSV_nosteal(TARG, result); + PUSHTARG; + } RETURN; } fp = Nullfp; @@ -1495,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; @@ -1507,12 +1510,16 @@ 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 */ - if (type == OP_RCATLINE) + offset = 0; + if (type == OP_RCATLINE && SvOK(sv)) { + if (!SvPOK(sv)) { + STRLEN n_a; + (void)SvPV_force(sv, n_a); + } offset = SvCUR(sv); - else - offset = 0; + } } else { sv = sv_2mortal(NEWSV(57, 80)); @@ -1552,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; } @@ -1635,20 +1645,36 @@ PP(pp_helem) U32 lval = PL_op->op_flags & OPf_MOD || LVRET; U32 defer = PL_op->op_private & OPpLVAL_DEFER; SV *sv; +#ifdef PERL_COPY_ON_WRITE + U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0; +#else U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0; +#endif I32 preeminent = 0; if (SvTYPE(hv) == SVt_PVHV) { - if (PL_op->op_private & OPpLVAL_INTRO) - preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0); + if (PL_op->op_private & OPpLVAL_INTRO) { + MAGIC *mg; + HV *stash; + /* does the element we're localizing already exist? */ + preeminent = + /* can we determine whether it exists? */ + ( !SvRMAGICAL(hv) + || mg_find((SV*)hv, PERL_MAGIC_env) + || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied)) + /* Try to preserve the existenceness of a tied hash + * element by using EXISTS and DELETE if possible. + * Fallback to FETCH and STORE otherwise */ + && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg)))) + && gv_fetchmethod_autoload(stash, "EXISTS", TRUE) + && gv_fetchmethod_autoload(stash, "DELETE", TRUE) + ) + ) ? hv_exists_ent(hv, keysv, 0) : 1; + + } he = hv_fetch_ent(hv, keysv, lval && !defer, hash); svp = he ? &HeVAL(he) : 0; } - else if (SvTYPE(hv) == SVt_PVAV) { - if (PL_op->op_private & OPpLVAL_INTRO) - DIE(aTHX_ "Can't localize pseudo-hash element"); - svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash); - } else { RETPUSHUNDEF; } @@ -1777,13 +1803,11 @@ PP(pp_iter) STRLEN maxlen; char *max = SvPV((SV*)av, maxlen); if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) { -#ifndef USE_5005THREADS /* don't risk potential race */ if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { /* safe to reuse old SV */ sv_setsv(*itersvp, cur); } else -#endif { /* we need a fresh SV every time so that loop body sees a * completely new SV for closures/references to work as @@ -1803,13 +1827,12 @@ PP(pp_iter) if (cx->blk_loop.iterix > cx->blk_loop.itermax) RETPUSHNO; -#ifndef USE_5005THREADS /* don't risk potential race */ + /* don't risk potential race */ if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { /* safe to reuse old SV */ sv_setiv(*itersvp, cx->blk_loop.iterix++); } else -#endif { /* we need a fresh SV every time so that loop body sees a * completely new SV for closures/references to work as they @@ -1836,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 @@ -1889,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; @@ -1899,11 +1932,21 @@ PP(pp_subst) EXTEND(SP,1); } - if (SvFAKE(TARG) && SvREADONLY(TARG)) - sv_force_normal(TARG); - if (SvREADONLY(TARG) +#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); +#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; @@ -1916,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. */ @@ -1933,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)) { @@ -1962,8 +2005,21 @@ PP(pp_subst) /* known replacement string? */ if (dstr) { - c = SvPV(dstr, clen); - doutf8 = DO_UTF8(dstr); + /* replacement needing upgrading? */ + if (DO_UTF8(TARG) && !doutf8) { + nsv = sv_newmortal(); + SvSetSV(nsv, dstr); + if (PL_encoding) + sv_recode_to_utf8(nsv, PL_encoding); + else + sv_utf8_upgrade(nsv); + c = SvPV(nsv, clen); + doutf8 = TRUE; + } + else { + c = SvPV(dstr, clen); + doutf8 = DO_UTF8(dstr); + } } else { c = Nullch; @@ -1971,8 +2027,13 @@ PP(pp_subst) } /* can do inplace substitution? */ - if (c && 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)) { @@ -1981,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); @@ -2068,6 +2135,8 @@ PP(pp_subst) SPAGAIN; } SvTAINT(TARG); + if (doutf8) + SvUTF8_on(TARG); LEAVE_SCOPE(oldsave); RETURN; } @@ -2080,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); @@ -2089,6 +2161,7 @@ PP(pp_subst) if (!c) { register PERL_CONTEXT *cx; SPAGAIN; + ReREFCNT_inc(rx); PUSHSUBST(cx); RETURNOP(cPMOP->op_pmreplroot); } @@ -2105,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); @@ -2113,10 +2189,26 @@ PP(pp_subst) break; } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, TARG, NULL, r_flags)); - sv_catpvn(dstr, s, strend - s); - - (void)SvOOK_off(TARG); - Safefree(SvPVX(TARG)); + if (doutf8 && !DO_UTF8(TARG)) + sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv); + else + sv_catpvn(dstr, s, strend - s); + +#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)); @@ -2236,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(); } @@ -2292,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"); } @@ -2303,12 +2395,13 @@ 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 a %s from lvalue subroutine", - SvREADONLY(TOPs) ? "readonly value" : "temporary"); + 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. */ @@ -2317,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")); @@ -2333,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"); @@ -2387,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(); } @@ -2446,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; @@ -2483,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; @@ -2502,179 +2597,99 @@ 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"); } -#ifdef USE_5005THREADS - /* - * First we need to check if the sub or method requires locking. - * If so, we gain a lock on the CV, the first argument or the - * stash (for static methods), as appropriate. This has to be - * inline because for FAKE_THREADS, COND_WAIT inlines code to - * reschedule by returning a new op. - */ - MUTEX_LOCK(CvMUTEXP(cv)); - if (CvFLAGS(cv) & CVf_LOCKED) { - MAGIC *mg; - if (CvFLAGS(cv) & CVf_METHOD) { - if (SP > PL_stack_base + TOPMARK) - sv = *(PL_stack_base + TOPMARK + 1); - else { - AV *av = (AV*)PL_curpad[0]; - if (hasargs || !av || AvFILLp(av) < 0 - || !(sv = AvARRAY(av)[0])) - { - MUTEX_UNLOCK(CvMUTEXP(cv)); - DIE(aTHX_ "no argument for locked method call"); + if (!(CvXSUB(cv))) { + /* This path taken at least 75% of the time */ + dMARK; + register I32 items = SP - MARK; + AV* padlist = CvPADLIST(cv); + push_return(PL_op->op_next); + PUSHBLOCK(cx, CXt_SUB, MARK); + PUSHSUB(cx); + 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 instead to search for + * the cv using find_runcv() when calling doeval(). + */ + if (CvDEPTH(cv) < 2) + (void)SvREFCNT_inc(cv); + else { + PERL_STACK_OVERFLOW_CHECK(); + pad_push(padlist, CvDEPTH(cv), 1); + } + PAD_SET_CUR(padlist, CvDEPTH(cv)); + if (hasargs) + { + AV* av; + SV** ary; + +#if 0 + DEBUG_S(PerlIO_printf(Perl_debug_log, + "%p entersub preparing @_\n", thr)); +#endif + av = (AV*)PAD_SVl(0); + if (AvREAL(av)) { + /* @_ is normally not REAL--this should only ever + * happen when DB::sub() calls things that modify @_ */ + av_clear(av); + AvREAL_off(av); + AvREIFY_on(av); + } + cx->blk_sub.savearray = GvAV(PL_defgv); + GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); + CX_CURPAD_SAVE(cx->blk_sub); + cx->blk_sub.argarray = av; + ++MARK; + + if (items > AvMAX(av) + 1) { + ary = AvALLOC(av); + if (AvARRAY(av) != ary) { + AvMAX(av) += AvARRAY(av) - AvALLOC(av); + SvPVX(av) = (char*)ary; + } + if (items > AvMAX(av) + 1) { + AvMAX(av) = items - 1; + Renew(ary,items,SV*); + AvALLOC(av) = ary; + SvPVX(av) = (char*)ary; } } - if (SvROK(sv)) - sv = SvRV(sv); - else { - STRLEN len; - char *stashname = SvPV(sv, len); - sv = (SV*)gv_stashpvn(stashname, len, TRUE); + Copy(MARK,AvARRAY(av),items,SV*); + AvFILLp(av) = items - 1; + + while (items--) { + if (*MARK) + SvTEMP_off(*MARK); + MARK++; } } - else { - sv = (SV*)cv; - } - MUTEX_UNLOCK(CvMUTEXP(cv)); - mg = condpair_magic(sv); - MUTEX_LOCK(MgMUTEXP(mg)); - if (MgOWNER(mg) == thr) - MUTEX_UNLOCK(MgMUTEXP(mg)); - else { - while (MgOWNER(mg)) - COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); - MgOWNER(mg) = thr; - DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n", - thr, sv)); - MUTEX_UNLOCK(MgMUTEXP(mg)); - SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); - } - MUTEX_LOCK(CvMUTEXP(cv)); + /* warning must come *after* we fully set up the context + * stuff so that __WARN__ handlers can safely dounwind() + * if they want to + */ + if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION) + && !(PERLDB_SUB && cv == GvCV(PL_DBsub))) + sub_crush_depth(cv); +#if 0 + DEBUG_S(PerlIO_printf(Perl_debug_log, + "%p entersub returning %p\n", thr, CvSTART(cv))); +#endif + RETURNOP(CvSTART(cv)); } - /* - * Now we have permission to enter the sub, we must distinguish - * four cases. (0) It's an XSUB (in which case we don't care - * about ownership); (1) it's ours already (and we're recursing); - * (2) it's free (but we may already be using a cached clone); - * (3) another thread owns it. Case (1) is easy: we just use it. - * Case (2) means we look for a clone--if we have one, use it - * otherwise grab ownership of cv. Case (3) means we look for a - * clone (for non-XSUBs) and have to create one if we don't - * already have one. - * Why look for a clone in case (2) when we could just grab - * ownership of cv straight away? Well, we could be recursing, - * i.e. we originally tried to enter cv while another thread - * owned it (hence we used a clone) but it has been freed up - * and we're now recursing into it. It may or may not be "better" - * to use the clone but at least CvDEPTH can be trusted. - */ - if (CvOWNER(cv) == thr || CvXSUB(cv)) - MUTEX_UNLOCK(CvMUTEXP(cv)); else { - /* Case (2) or (3) */ - SV **svp; - - /* - * XXX Might it be better to release CvMUTEXP(cv) while we - * do the hv_fetch? We might find someone has pinched it - * when we look again, in which case we would be in case - * (3) instead of (2) so we'd have to clone. Would the fact - * that we released the mutex more quickly make up for this? - */ - if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE))) - { - /* We already have a clone to use */ - MUTEX_UNLOCK(CvMUTEXP(cv)); - cv = *(CV**)svp; - DEBUG_S(PerlIO_printf(Perl_debug_log, - "entersub: %p already has clone %p:%s\n", - thr, cv, SvPEEK((SV*)cv))); - CvOWNER(cv) = thr; - SvREFCNT_inc(cv); - if (CvDEPTH(cv) == 0) - SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv); - } - else { - /* (2) => grab ownership of cv. (3) => make clone */ - if (!CvOWNER(cv)) { - CvOWNER(cv) = thr; - SvREFCNT_inc(cv); - MUTEX_UNLOCK(CvMUTEXP(cv)); - DEBUG_S(PerlIO_printf(Perl_debug_log, - "entersub: %p grabbing %p:%s in stash %s\n", - thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ? - HvNAME(CvSTASH(cv)) : "(none)")); - } - else { - /* Make a new clone. */ - CV *clonecv; - SvREFCNT_inc(cv); /* don't let it vanish from under us */ - MUTEX_UNLOCK(CvMUTEXP(cv)); - DEBUG_S((PerlIO_printf(Perl_debug_log, - "entersub: %p cloning %p:%s\n", - thr, cv, SvPEEK((SV*)cv)))); - /* - * We're creating a new clone so there's no race - * between the original MUTEX_UNLOCK and the - * SvREFCNT_inc since no one will be trying to undef - * it out from underneath us. At least, I don't think - * there's a race... - */ - clonecv = cv_clone(cv); - SvREFCNT_dec(cv); /* finished with this */ - hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0); - CvOWNER(clonecv) = thr; - cv = clonecv; - SvREFCNT_inc(cv); - } - DEBUG_S(if (CvDEPTH(cv) != 0) - PerlIO_printf(Perl_debug_log, "depth %ld != 0\n", - CvDEPTH(cv))); - SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv); - } - } -#endif /* USE_5005THREADS */ - - if (CvXSUB(cv)) { #ifdef PERL_XSUB_OLDSTYLE if (CvOLDSTYLE(cv)) { I32 (*fp3)(int,int,int); @@ -2705,11 +2720,7 @@ try_autoload: * back. This would allow popping @_ in XSUB, e.g.. XXXX */ AV* av; I32 items; -#ifdef USE_5005THREADS - av = (AV*)PL_curpad[0]; -#else av = GvAV(PL_defgv); -#endif /* USE_5005THREADS */ items = AvFILLp(av) + 1; /* @_ is not tieable */ if (items) { @@ -2741,143 +2752,41 @@ try_autoload: LEAVE; return NORMAL; } - else { - dMARK; - register I32 items = SP - MARK; - AV* padlist = CvPADLIST(cv); - SV** svp = AvARRAY(padlist); - push_return(PL_op->op_next); - PUSHBLOCK(cx, CXt_SUB, MARK); - PUSHSUB(cx); - 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. - */ - if (CvDEPTH(cv) < 2) - (void)SvREFCNT_inc(cv); - else { /* save temporaries on recursion? */ - PERL_STACK_OVERFLOW_CHECK(); - if (CvDEPTH(cv) > AvFILLp(padlist)) { - AV *av; - AV *newpad = newAV(); - SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]); - I32 ix = AvFILLp((AV*)svp[1]); - I32 names_fill = AvFILLp((AV*)svp[0]); - svp = AvARRAY(svp[0]); - for ( ;ix > 0; ix--) { - if (names_fill >= ix && svp[ix] != &PL_sv_undef) { - char *name = SvPVX(svp[ix]); - if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */ - || *name == '&') /* anonymous code? */ - { - av_store(newpad, ix, SvREFCNT_inc(oldpad[ix])); - } - else { /* our own lexical */ - if (*name == '@') - av_store(newpad, ix, sv = (SV*)newAV()); - else if (*name == '%') - av_store(newpad, ix, sv = (SV*)newHV()); - else - av_store(newpad, ix, sv = NEWSV(0,0)); - SvPADMY_on(sv); - } - } - else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) { - av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix])); - } - else { - av_store(newpad, ix, sv = NEWSV(0,0)); - SvPADTMP_on(sv); - } - } - av = newAV(); /* will be @_ */ - av_extend(av, 0); - av_store(newpad, 0, (SV*)av); - AvFLAGS(av) = AVf_REIFY; - av_store(padlist, CvDEPTH(cv), (SV*)newpad); - AvFILLp(padlist) = CvDEPTH(cv); - svp = AvARRAY(padlist); - } - } -#ifdef USE_5005THREADS - if (!hasargs) { - AV* av = (AV*)PL_curpad[0]; - - items = AvFILLp(av) + 1; - if (items) { - /* Mark is at the end of the stack. */ - EXTEND(SP, items); - Copy(AvARRAY(av), SP + 1, items, SV*); - SP += items; - PUTBACK ; - } - } -#endif /* USE_5005THREADS */ - SAVEVPTR(PL_curpad); - PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); -#ifndef USE_5005THREADS - if (hasargs) -#endif /* USE_5005THREADS */ - { - AV* av; - SV** ary; -#if 0 - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p entersub preparing @_\n", thr)); -#endif - av = (AV*)PL_curpad[0]; - if (AvREAL(av)) { - /* @_ is normally not REAL--this should only ever - * happen when DB::sub() calls things that modify @_ */ - av_clear(av); - AvREAL_off(av); - AvREIFY_on(av); - } -#ifndef USE_5005THREADS - cx->blk_sub.savearray = GvAV(PL_defgv); - GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); -#endif /* USE_5005THREADS */ - cx->blk_sub.oldcurpad = PL_curpad; - cx->blk_sub.argarray = av; - ++MARK; + 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; - if (items > AvMAX(av) + 1) { - ary = AvALLOC(av); - if (AvARRAY(av) != ary) { - AvMAX(av) += AvARRAY(av) - AvALLOC(av); - SvPVX(av) = (char*)ary; - } - if (items > AvMAX(av) + 1) { - AvMAX(av) = items - 1; - Renew(ary,items,SV*); - AvALLOC(av) = ary; - SvPVX(av) = (char*)ary; - } + 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); } - Copy(MARK,AvARRAY(av),items,SV*); - AvFILLp(av) = items - 1; - - while (items--) { - if (*MARK) - SvTEMP_off(*MARK); - MARK++; + /* sorry */ + else { + sub_name = sv_newmortal(); + gv_efullname3(sub_name, gv, Nullch); + DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name); } } - /* warning must come *after* we fully set up the context - * stuff so that __WARN__ handlers can safely dounwind() - * if they want to - */ - if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION) - && !(PERLDB_SUB && cv == GvCV(PL_DBsub))) - sub_crush_depth(cv); -#if 0 - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p entersub returning %p\n", thr, CvSTART(cv))); -#endif - RETURNOP(CvSTART(cv)); + if (!cv) + DIE(aTHX_ "Not a CODE reference"); + goto retry; } } @@ -2889,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); } } @@ -2906,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) @@ -2990,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)); @@ -3007,6 +2916,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) char* name; STRLEN namelen; char* packname = 0; + SV *packsv = Nullsv; STRLEN packlen; name = SvPV(meth, namelen); @@ -3024,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))) { @@ -3042,6 +2962,12 @@ S_method_common(pTHX_ SV* meth, U32* hashp) } /* assume it's a package name */ 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 */ @@ -3074,7 +3000,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) } } - gv = gv_fetchmethod(stash, name); + gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name); if (!gv) { /* This code tries to figure out just what went wrong with @@ -3098,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 */ @@ -3121,22 +3051,3 @@ S_method_common(pTHX_ SV* meth, U32* hashp) } return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv; } - -#ifdef USE_5005THREADS -static void -unset_cvowner(pTHX_ void *cvarg) -{ - register CV* cv = (CV *) cvarg; - - DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n", - thr, cv, SvPEEK((SV*)cv)))); - MUTEX_LOCK(CvMUTEXP(cv)); - DEBUG_S(if (CvDEPTH(cv) != 0) - PerlIO_printf(Perl_debug_log, "depth %ld != 0\n", - CvDEPTH(cv))); - assert(thr == CvOWNER(cv)); - CvOWNER(cv) = 0; - MUTEX_UNLOCK(CvMUTEXP(cv)); - SvREFCNT_dec(cv); -} -#endif /* USE_5005THREADS */