X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=64b5fc59f960ee7d72b6dba2943beedf5df5cbee;hb=19c4478c878cb3732a73314cc162df7f808d5d78;hp=a7657f8648e3fc48f6fdc0892ac01e4f52528335;hpb=8b73ab1881b775e12ace39efe757716ab526e9db;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_hot.c b/pp_hot.c
index a7657f8..64b5fc5 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -39,14 +39,7 @@ PP(pp_const)
 {
     dVAR;
     dSP;
-    if ( PL_op->op_flags & OPf_SPECIAL )
-        /* This is a const op added to hold the hints hash for
-           pp_entereval. The hash can be modified by the code
-           being eval'ed, so we return a copy instead. */
-        mXPUSHs((SV*)Perl_hv_copy_hints_hv(aTHX_ (HV*)cSVOP_sv));
-    else
-        /* Normal const. */
-        XPUSHs(cSVOP_sv);
+    XPUSHs(cSVOP_sv);
     RETURN;
 }
 
@@ -78,13 +71,6 @@ PP(pp_null)
     return NORMAL;
 }
 
-PP(pp_setstate)
-{
-    dVAR;
-    PL_curcop = (COP*)PL_op;
-    return NORMAL;
-}
-
 PP(pp_pushmark)
 {
     dVAR;
@@ -815,8 +801,6 @@ PP(pp_rv2av)
 {
     dVAR; dSP; dTOPss;
     const I32 gimme = GIMME_V;
-    static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context";
-    static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
     static const char an_array[] = "an ARRAY";
     static const char a_hash[] = "a HASH";
     const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
@@ -835,8 +819,7 @@ PP(pp_rv2av)
 	}
 	else if (LVRET) {
 	    if (gimme != G_ARRAY)
-		Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar
-			   : return_hash_to_lvalue_scalar);
+		goto croak_cant_return;
 	    SETs(sv);
 	    RETURN;
 	}
@@ -852,9 +835,7 @@ PP(pp_rv2av)
 	    }
 	    else if (LVRET) {
 		if (gimme != G_ARRAY)
-		    Perl_croak(aTHX_
-			       is_pp_rv2av ? return_array_to_lvalue_scalar
-			       : return_hash_to_lvalue_scalar);
+		    goto croak_cant_return;
 		SETs(sv);
 		RETURN;
 	    }
@@ -885,9 +866,7 @@ PP(pp_rv2av)
 	    }
 	    else if (LVRET) {
 		if (gimme != G_ARRAY)
-		    Perl_croak(aTHX_
-			       is_pp_rv2av ? return_array_to_lvalue_scalar
-			       : return_hash_to_lvalue_scalar);
+		    goto croak_cant_return;
 		SETs(sv);
 		RETURN;
 	    }
@@ -937,12 +916,20 @@ PP(pp_rv2av)
     }
     }
     RETURN;
+
+ croak_cant_return:
+    Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
+	       is_pp_rv2av ? "array" : "hash");
+    RETURN;
 }
 
 STATIC void
 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
 {
     dVAR;
+
+    PERL_ARGS_ASSERT_DO_ODDBALL;
+
     if (*relem) {
 	SV *tmpstr;
         const HE *didstore;
@@ -1033,8 +1020,14 @@ PP(pp_aassign)
 		*(relem++) = sv;
 		didstore = av_store(ary,i++,sv);
 		if (magic) {
-		    if (SvSMAGICAL(sv))
+		    if (SvSMAGICAL(sv)) {
+			/* More magic can happen in the mg_set callback, so we
+			 * backup the delaymagic for now. */
+			U16 dmbak = PL_delaymagic;
+			PL_delaymagic = 0;
 			mg_set(sv);
+			PL_delaymagic = dmbak;
+		    }
 		    if (!didstore)
 			sv_2mortal(sv);
 		}
@@ -1064,8 +1057,12 @@ PP(pp_aassign)
 			duplicates += 2;
 		    didstore = hv_store_ent(hash,sv,tmpstr,0);
 		    if (magic) {
-			if (SvSMAGICAL(tmpstr))
+			if (SvSMAGICAL(tmpstr)) {
+			    U16 dmbak = PL_delaymagic;
+			    PL_delaymagic = 0;
 			    mg_set(tmpstr);
+			    PL_delaymagic = dmbak;
+			}
 			if (!didstore)
 			    sv_2mortal(tmpstr);
 		    }
@@ -1089,7 +1086,13 @@ PP(pp_aassign)
 	    }
 	    else
 		sv_setsv(sv, &PL_sv_undef);
-	    SvSETMAGIC(sv);
+
+	    if (SvSMAGICAL(sv)) {
+		U16 dmbak = PL_delaymagic;
+		PL_delaymagic = 0;
+		mg_set(sv);
+		PL_delaymagic = dmbak;
+	    }
 	    break;
 	}
     }
@@ -1902,8 +1905,9 @@ PP(pp_iter)
     dVAR; dSP;
     register PERL_CONTEXT *cx;
     SV *sv, *oldsv;
-    AV* av;
     SV **itersvp;
+    AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
+    bool av_is_stack = FALSE;
 
     EXTEND(SP, 1);
     cx = &cxstack[cxstack_ix];
@@ -1911,16 +1915,14 @@ PP(pp_iter)
 	DIE(aTHX_ "panic: pp_iter");
 
     itersvp = CxITERVAR(cx);
-    av = CxTYPE(cx) == CXt_LOOP_STACK ? PL_curstack : cx->blk_loop.iterary;
-    if (SvTYPE(av) != SVt_PVAV) {
-	/* iterate ($min .. $max) */
-	if (cx->blk_loop.iterlval) {
+    if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
 	    /* string increment */
-	    register SV* cur = cx->blk_loop.iterlval;
+	    SV* cur = cx->blk_loop.state_u.lazysv.cur;
+	    SV *end = cx->blk_loop.state_u.lazysv.end;
+	    /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
+	       It has SvPVX of "" and SvCUR of 0, which is what we want.  */
 	    STRLEN maxlen = 0;
-	    const char *max =
-	      SvOK((SV*)av) ?
-	      SvPV_const((SV*)av, maxlen) : (const char *)"";
+	    const char *max = SvPV_const(end, maxlen);
 	    if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
 		if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
 		    /* safe to reuse old SV */
@@ -1942,15 +1944,16 @@ PP(pp_iter)
 		RETPUSHYES;
 	    }
 	    RETPUSHNO;
-	}
+    }
+    else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
 	/* integer increment */
-	if (cx->blk_loop.iterix > cx->blk_loop.itermax)
+	if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
 	    RETPUSHNO;
 
 	/* don't risk potential race */
 	if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
 	    /* safe to reuse old SV */
-	    sv_setiv(*itersvp, cx->blk_loop.iterix++);
+	    sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
 	}
 	else
 	{
@@ -1958,47 +1961,52 @@ PP(pp_iter)
 	     * completely new SV for closures/references to work as they
 	     * used to */
 	    oldsv = *itersvp;
-	    *itersvp = newSViv(cx->blk_loop.iterix++);
+	    *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
 	    SvREFCNT_dec(oldsv);
 	}
 
 	/* Handle end of range at IV_MAX */
-	if ((cx->blk_loop.iterix == IV_MIN) &&
-	    (cx->blk_loop.itermax == IV_MAX))
+	if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
+	    (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
 	{
-	    cx->blk_loop.iterix++;
-	    cx->blk_loop.itermax++;
+	    cx->blk_loop.state_u.lazyiv.cur++;
+	    cx->blk_loop.state_u.lazyiv.end++;
 	}
 
 	RETPUSHYES;
     }
 
     /* iterate array */
+    assert(CxTYPE(cx) == CXt_LOOP_FOR);
+    av = cx->blk_loop.state_u.ary.ary;
+    if (!av) {
+	av_is_stack = TRUE;
+	av = PL_curstack;
+    }
     if (PL_op->op_private & OPpITER_REVERSED) {
-	/* In reverse, use itermax as the min :-)  */
-	if (cx->blk_loop.iterix <= (CxTYPE(cx) == CXt_LOOP_STACK
-				    ? cx->blk_loop.itermax : 0))
+	if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
+				    ? cx->blk_loop.resetsp + 1 : 0))
 	    RETPUSHNO;
 
 	if (SvMAGICAL(av) || AvREIFY(av)) {
-	    SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
+	    SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
 	    sv = svp ? *svp : NULL;
 	}
 	else {
-	    sv = AvARRAY(av)[--cx->blk_loop.iterix];
+	    sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
 	}
     }
     else {
-	if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
+	if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
 				    AvFILL(av)))
 	    RETPUSHNO;
 
 	if (SvMAGICAL(av) || AvREIFY(av)) {
-	    SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
+	    SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
 	    sv = svp ? *svp : NULL;
 	}
 	else {
-	    sv = AvARRAY(av)[++cx->blk_loop.iterix];
+	    sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
 	}
     }
 
@@ -2007,31 +2015,24 @@ PP(pp_iter)
 	Perl_croak(aTHX_ "Use of freed value in iteration");
     }
 
-    if (sv)
+    if (sv) {
 	SvTEMP_off(sv);
+	SvREFCNT_inc_simple_void_NN(sv);
+    }
     else
 	sv = &PL_sv_undef;
-    if (av != PL_curstack && sv == &PL_sv_undef) {
-	SV *lv = cx->blk_loop.iterlval;
-	if (lv && SvREFCNT(lv) > 1) {
-	    SvREFCNT_dec(lv);
-	    lv = NULL;
-	}
-	if (lv)
-	    SvREFCNT_dec(LvTARG(lv));
-	else {
-	    lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV);
-	    LvTYPE(lv) = 'y';
-	    sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
-	}
+    if (!av_is_stack && sv == &PL_sv_undef) {
+	SV *lv = newSV_type(SVt_PVLV);
+	LvTYPE(lv) = 'y';
+	sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
 	LvTARG(lv) = SvREFCNT_inc_simple(av);
-	LvTARGOFF(lv) = cx->blk_loop.iterix;
+	LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
 	LvTARGLEN(lv) = (STRLEN)UV_MAX;
-	sv = (SV*)lv;
+	sv = lv;
     }
 
     oldsv = *itersvp;
-    *itersvp = SvREFCNT_inc_simple_NN(sv);
+    *itersvp = sv;
     SvREFCNT_dec(oldsv);
 
     RETPUSHYES;
@@ -2834,10 +2835,6 @@ try_autoload:
 	if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && 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", (void*)thr, (void*)CvSTART(cv)));
-#endif
 	RETURNOP(CvSTART(cv));
     }
     else {
@@ -2886,6 +2883,8 @@ try_autoload:
 void
 Perl_sub_crush_depth(pTHX_ CV *cv)
 {
+    PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
+
     if (CvANON(cv))
 	Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
     else {
@@ -2959,6 +2958,8 @@ PP(pp_aelem)
 void
 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
 {
+    PERL_ARGS_ASSERT_VIVIFY_REF;
+
     SvGETMAGIC(sv);
     if (!SvOK(sv)) {
 	if (SvREADONLY(sv))
@@ -3021,6 +3022,8 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
     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);
 
@@ -3097,81 +3100,11 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
 	}
     }
 
-    gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
-
-    if (!gv) {
-	/* This code tries to figure out just what went wrong with
-	   gv_fetchmethod.  It therefore needs to duplicate a lot of
-	   the internals of that function.  We can't move it inside
-	   Perl_gv_fetchmethod_autoload(), however, since that would
-	   cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
-	   don't want that.
-	*/
-	const char* leaf = name;
-	const char* sep = NULL;
-	const char* p;
-
-	for (p = name; *p; p++) {
-	    if (*p == '\'')
-		sep = p, leaf = p + 1;
-	    else if (*p == ':' && *(p + 1) == ':')
-		sep = p, leaf = p + 2;
-	}
-	if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
-	    /* the method name is unqualified or starts with SUPER:: */
-#ifndef USE_ITHREADS
-	    if (sep)
-		stash = CopSTASH(PL_curcop);
-#else
-	    bool need_strlen = 1;
-	    if (sep) {
-		packname = CopSTASHPV(PL_curcop);
-	    }
-	    else
-#endif
-	    if (stash) {
-		HEK * const packhek = HvNAME_HEK(stash);
-		if (packhek) {
-		    packname = HEK_KEY(packhek);
-		    packlen = HEK_LEN(packhek);
-#ifdef USE_ITHREADS
-		    need_strlen = 0;
-#endif
-		} else {
-		    goto croak;
-		}
-	    }
+    gv = gv_fetchmethod_flags(stash ? stash : (HV*)packsv, name,
+			      GV_AUTOLOAD | GV_CROAK);
 
-	    if (!packname) {
-	    croak:
-		Perl_croak(aTHX_
-			   "Can't use anonymous symbol table for method lookup");
-	    }
-#ifdef USE_ITHREADS
-	    if (need_strlen)
-		packlen = strlen(packname);
-#endif
+    assert(gv);
 
-	}
-	else {
-	    /* the method name is qualified */
-	    packname = name;
-	    packlen = sep - name;
-	}
-	
-	/* we're relying on gv_fetchmethod not autovivifying the stash */
-	if (gv_stashpvn(packname, packlen, 0)) {
-	    Perl_croak(aTHX_
-		       "Can't locate object method \"%s\" via package \"%.*s\"",
-		       leaf, (int)packlen, packname);
-	}
-	else {
-	    Perl_croak(aTHX_
-		       "Can't locate object method \"%s\" via package \"%.*s\""
-		       " (perhaps you forgot to load \"%.*s\"?)",
-		       leaf, (int)packlen, packname, (int)packlen, packname);
-	}
-    }
     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
 }