X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=61d8b4371f419160c267b6e4db0d8b4fd6d883c5;hb=51a27c589a9ebb52028180274895e08bd9c273e1;hp=4624fbb4e633461a2bfa0c6912540997d0397c03;hpb=9711599ee3b2375539002b6ddc0873ec478916bb;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_hot.c b/pp_hot.c
index 4624fbb..61d8b43 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -753,14 +753,16 @@ PP(pp_print)
 	goto just_say_no;
     }
     else {
+	SV * const ofs = GvSV(PL_ofsgv); /* $, */
 	MARK++;
-	if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
+	if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
 	    while (MARK <= SP) {
 		if (!do_print(*MARK, fp))
 		    break;
 		MARK++;
 		if (MARK <= SP) {
-		    if (!do_print(PL_ofs_sv, fp)) { /* $, */
+		    /* don't use 'ofs' here - it may be invalidated by magic callbacks */
+		    if (!do_print(GvSV(PL_ofsgv), fp)) {
 			MARK--;
 			break;
 		    }
@@ -1752,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;
     }
 
@@ -1777,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) {
@@ -1818,18 +1820,14 @@ 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 {
-		if (!preeminent) {
-		    STRLEN keylen;
-		    const char * const key = SvPV_const(keysv, keylen);
-		    SAVEDELETE(hv, savepvn(key,keylen),
-			       SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
-		} else
-		    save_helem(hv, keysv, svp, !(PL_op->op_flags & OPf_SPECIAL));
-            }
+	    else if (preeminent)
+		save_helem_flags(hv, keysv, svp,
+		     (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
+	    else
+		SAVEHDELETE(hv, keysv);
 	}
 	else if (PL_op->op_private & OPpDEREF)
 	    vivify_ref(*svp, PL_op->op_private & OPpDEREF);
@@ -1862,13 +1860,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)
@@ -2771,7 +2763,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_fetchpvs("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");
@@ -2870,8 +2869,10 @@ try_autoload:
 	    PL_curcopdb = NULL;
 	}
 	/* Do we need to open block here? XXXX */
-	if (CvXSUB(cv)) /* XXX this is supposed to be true */
-	    (void)(*CvXSUB(cv))(aTHX_ cv);
+
+	/* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
+	assert(CvXSUB(cv));
+	CALL_FPTR(CvXSUB(cv))(aTHX_ cv);
 
 	/* Enforce some sanity in scalar context. */
 	if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
@@ -2910,6 +2911,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))
@@ -2920,6 +2923,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
@@ -2949,8 +2965,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);
     }
@@ -3021,17 +3041,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))
@@ -3060,7 +3079,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");
 	    }
@@ -3085,6 +3105,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);
@@ -3108,7 +3129,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);