X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=7afa42225a65056943bda9869f811a9ed708427d;hb=d092c3cd1c0e81a16217f2dd8f09f8426e33ebe5;hp=a60a17675034fe0756d51afad2c7a1057681c77a;hpb=e23d9e2f39425eea292ee5999c974fdc2cdd98b8;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index a60a176..7afa422 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1754,9 +1754,13 @@ PP(pp_enter) I32 gimme = OP_GIMME(PL_op, -1); if (gimme == -1) { - if (cxstack_ix >= 0) - gimme = cxstack[cxstack_ix].blk_gimme; - else + if (cxstack_ix >= 0) { + /* If this flag is set, we're just inside a return, so we should + * store the caller's context */ + gimme = (PL_op->op_flags & OPf_SPECIAL) + ? block_gimme() + : cxstack[cxstack_ix].blk_gimme; + } else gimme = G_SCALAR; } @@ -1779,28 +1783,24 @@ PP(pp_helem) const U32 defer = PL_op->op_private & OPpLVAL_DEFER; SV *sv; const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0; - I32 preeminent = 0; + const bool localizing = PL_op->op_private & OPpLVAL_INTRO; + bool preeminent = TRUE; if (SvTYPE(hv) != SVt_PVHV) RETPUSHUNDEF; - if (PL_op->op_private & OPpLVAL_INTRO) { + if (localizing) { MAGIC *mg; HV *stash; - /* does the element we're localizing already exist? */ - preeminent = /* can we determine whether it exists? */ - ( !SvRMAGICAL(hv) - || mg_find((const SV *)hv, PERL_MAGIC_env) - || ( (mg = mg_find((const 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(MUTABLE_SV(hv), mg)))) - && gv_fetchmethod_autoload(stash, "EXISTS", TRUE) - && gv_fetchmethod_autoload(stash, "DELETE", TRUE) - ) - ) ? hv_exists_ent(hv, keysv, 0) : 1; + + /* If we can determine whether the element exist, + * Try to preserve the existenceness of a tied hash + * element by using EXISTS and DELETE if possible. + * Fallback to FETCH and STORE otherwise. */ + if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env)) + preeminent = hv_exists_ent(hv, keysv, 0); } + he = hv_fetch_ent(hv, keysv, lval && !defer, hash); svp = he ? &HeVAL(he) : NULL; if (lval) { @@ -1820,7 +1820,7 @@ PP(pp_helem) PUSHs(lv); RETURN; } - if (PL_op->op_private & OPpLVAL_INTRO) { + if (localizing) { if (HvNAME_get(hv) && isGV(*svp)) save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL)); else { @@ -1865,13 +1865,7 @@ PP(pp_leave) POPBLOCK(cx,newpm); - gimme = OP_GIMME(PL_op, -1); - if (gimme == -1) { - if (cxstack_ix >= 0) - gimme = cxstack[cxstack_ix].blk_gimme; - else - gimme = G_SCALAR; - } + gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR); TAINT_NOT; if (gimme == G_VOID) @@ -2774,7 +2768,14 @@ try_autoload: Perl_get_db_sub(aTHX_ &sv, cv); if (CvISXSUB(cv)) PL_curcopdb = PL_curcop; - cv = GvCV(PL_DBsub); + if (CvLVALUE(cv)) { + /* check for lsub that handles lvalue subroutines */ + cv = GvCV(gv_HVadd(gv_fetchpv("DB::lsub", GV_ADDMULTI, SVt_PVHV))); + /* if lsub not found then fall back to DB::sub */ + if (!cv) cv = GvCV(PL_DBsub); + } else { + cv = GvCV(PL_DBsub); + } if (!cv || (!CvXSUB(cv) && !CvSTART(cv))) DIE(aTHX_ "No DB::sub routine defined"); @@ -2913,6 +2914,8 @@ PP(pp_aelem) AV *const av = MUTABLE_AV(POPs); const U32 lval = PL_op->op_flags & OPf_MOD || LVRET; const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av)); + const bool localizing = PL_op->op_private & OPpLVAL_INTRO; + bool preeminent = TRUE; SV *sv; if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)) @@ -2923,6 +2926,19 @@ PP(pp_aelem) elem -= CopARYBASE_get(PL_curcop); if (SvTYPE(av) != SVt_PVAV) RETPUSHUNDEF; + + if (localizing) { + MAGIC *mg; + HV *stash; + + /* If we can determine whether the element exist, + * Try to preserve the existenceness of a tied array + * element by using EXISTS and DELETE if possible. + * Fallback to FETCH and STORE otherwise. */ + if (SvCANEXISTDELETE(av)) + preeminent = av_exists(av, elem); + } + svp = av_fetch(av, elem, lval && !defer); if (lval) { #ifdef PERL_MALLOC_WRAP @@ -2952,8 +2968,12 @@ PP(pp_aelem) PUSHs(lv); RETURN; } - if (PL_op->op_private & OPpLVAL_INTRO) - save_aelem(av, elem, svp); + if (localizing) { + if (preeminent) + save_aelem(av, elem, svp); + else + SAVEADELETE(av, elem); + } else if (PL_op->op_private & OPpDEREF) vivify_ref(*svp, PL_op->op_private & OPpDEREF); } @@ -3024,17 +3044,16 @@ S_method_common(pTHX_ SV* meth, U32* hashp) SV* ob; GV* gv; HV* stash; - STRLEN namelen; const char* packname = NULL; SV *packsv = NULL; STRLEN packlen; - const char * const name = SvPV_const(meth, namelen); SV * const sv = *(PL_stack_base + TOPMARK + 1); PERL_ARGS_ASSERT_METHOD_COMMON; if (!sv) - Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name); + Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value", + SVfARG(meth)); SvGETMAGIC(sv); if (SvROK(sv)) @@ -3063,7 +3082,8 @@ S_method_common(pTHX_ SV* meth, U32* hashp) : !isIDFIRST(*packname) )) { - Perl_croak(aTHX_ "Can't call method \"%s\" %s", name, + Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s", + SVfARG(meth), SvOK(sv) ? "without a package or object reference" : "on an undefined value"); } @@ -3088,6 +3108,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) && (ob = MUTABLE_SV(GvIO((const GV *)ob))) && SvOBJECT(ob)))) { + const char * const name = SvPV_nolen_const(meth); Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference", (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" : name); @@ -3111,7 +3132,8 @@ S_method_common(pTHX_ SV* meth, U32* hashp) } } - gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv), name, + gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv), + SvPV_nolen_const(meth), GV_AUTOLOAD | GV_CROAK); assert(gv);