X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=8298026457b26a8b84d52d6d1e0db191d053b65d;hb=f9bc45eff51a0e2fac1537ecee1124be910c832e;hp=9d51b1e3e3a3e258393e6d9d69916e423b4a062c;hpb=afd1eb533c8ea286efcac6fd054ae7cebaf0dfe3;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_hot.c b/pp_hot.c
index 9d51b1e..8298026 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1,6 +1,7 @@
 /*    pp_hot.c
  *
- *    Copyright (c) 1991-2001, Larry Wall
+ *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ *    2000, 2001, 2002, 2003, 2004, 2005, 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.
@@ -15,16 +16,25 @@
  *                     Fire, Foes!  Awake!
  */
 
+/* This file contains 'hot' pp ("push/pop") functions that
+ * execute the opcodes that make up a perl program. A typical pp function
+ * expects to find its arguments on the stack, and usually pushes its
+ * results onto the stack, hence the 'pp' terminology. Each OP structure
+ * contains a pointer to the relevant pp_foo() function.
+ *
+ * By 'hot', we mean common ops whose execution speed is critical.
+ * By gathering them together into a single file, we encourage
+ * CPU cache hits on hot code. Also it could be taken as a warning not to
+ * change any code in this file unless you're sure it won't affect
+ * performance.
+ */
+
 #include "EXTERN.h"
 #define PERL_IN_PP_HOT_C
 #include "perl.h"
 
 /* Hot code. */
 
-#ifdef USE_THREADS
-static void unset_cvowner(pTHXo_ void *cvarg);
-#endif /* USE_THREADS */
-
 PP(pp_const)
 {
     dSP;
@@ -48,7 +58,7 @@ PP(pp_gvsv)
     if (PL_op->op_private & OPpLVAL_INTRO)
 	PUSHs(save_scalar(cGVOP_gv));
     else
-	PUSHs(GvSV(cGVOP_gv));
+	PUSHs(GvSVn(cGVOP_gv));
     RETURN;
 }
 
@@ -72,14 +82,7 @@ PP(pp_pushmark)
 PP(pp_stringify)
 {
     dSP; dTARGET;
-    STRLEN len;
-    char *s;
-    s = SvPV(TOPs,len);
-    sv_setpvn(TARG,s,len);
-    if (SvUTF8(TOPs))
-	SvUTF8_on(TARG);
-    else
-	SvUTF8_off(TARG);
+    sv_copypv(TARG,TOPs);
     SETTARG;
     RETURN;
 }
@@ -142,21 +145,22 @@ PP(pp_concat)
   dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
   {
     dPOPTOPssrl;
-    STRLEN llen;
-    char* lpv;
     bool lbyte;
     STRLEN rlen;
-    char* rpv = SvPV(right, rlen);	/* mg_get(right) happens here */
-    bool rbyte = !SvUTF8(right);
+    const char *rpv = SvPV_const(right, rlen);	/* mg_get(right) happens here */
+    const bool rbyte = !DO_UTF8(right);
+    bool rcopied = FALSE;
 
     if (TARG == right && right != left) {
 	right = sv_2mortal(newSVpvn(rpv, rlen));
-	rpv = SvPV(right, rlen);	/* no point setting UTF8 here */
+	rpv = SvPV_const(right, rlen);	/* no point setting UTF-8 here */
+	rcopied = TRUE;
     }
 
     if (TARG != left) {
-	lpv = SvPV(left, llen);		/* mg_get(left) may happen here */
-	lbyte = !SvUTF8(left);
+        STRLEN llen;
+        const char* const lpv = SvPV_const(left, llen);	/* mg_get(left) may happen here */
+	lbyte = !DO_UTF8(left);
 	sv_setpvn(TARG, lpv, llen);
 	if (!lbyte)
 	    SvUTF8_on(TARG);
@@ -164,31 +168,25 @@ PP(pp_concat)
 	    SvUTF8_off(TARG);
     }
     else { /* TARG == left */
+        STRLEN llen;
 	if (SvGMAGICAL(left))
 	    mg_get(left);		/* or mg_get(left) may happen here */
 	if (!SvOK(TARG))
-	    sv_setpv(left, "");
-	lpv = SvPV_nomg(left, llen);
-	lbyte = !SvUTF8(left);
-    }
-
-#if defined(PERL_Y2KWARN)
-    if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
-	if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
-	    && (llen == 2 || !isDIGIT(lpv[llen - 3])))
-	{
-	    Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
-			"about to append an integer to '19'");
-	}
+	    sv_setpvn(left, "", 0);
+	(void)SvPV_nomg_const(left, llen);    /* Needed to set UTF8 flag */
+	lbyte = !DO_UTF8(left);
+	if (IN_BYTES)
+	    SvUTF8_off(TARG);
     }
-#endif
 
     if (lbyte != rbyte) {
 	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);
+	    rpv = SvPV_const(right, rlen);
 	}
     }
     sv_catpvn_nomg(TARG, rpv, rlen);
@@ -204,10 +202,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]);
-        else if (PL_op->op_private & OPpDEREF) {
+	    SAVECLEARSV(PAD_SVl(PL_op->op_targ));
+        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;
 	}
     }
@@ -236,8 +234,9 @@ PP(pp_eq)
 {
     dSP; tryAMAGICbinSET(eq,0);
 #ifndef NV_PRESERVES_UV
-    if (SvROK(TOPs) && SvROK(TOPm1s)) {
-	SETs(boolSV(SvRV(TOPs) == SvRV(TOPm1s)));
+    if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
+        SP--;
+	SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
 	RETURN;
     }
 #endif
@@ -252,53 +251,40 @@ PP(pp_eq)
 	    bool auvok = SvUOK(TOPm1s);
 	    bool buvok = SvUOK(TOPs);
 	
-	    if (!auvok && !buvok) { /* ## IV == IV ## */
-		IV aiv = SvIVX(TOPm1s);
-		IV biv = SvIVX(TOPs);
+	    if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
+                /* Casting IV to UV before comparison isn't going to matter
+                   on 2s complement. On 1s complement or sign&magnitude
+                   (if we have any of them) it could to make negative zero
+                   differ from normal zero. As I understand it. (Need to
+                   check - is negative zero implementation defined behaviour
+                   anyway?). NWC  */
+		UV buv = SvUVX(POPs);
+		UV auv = SvUVX(TOPs);
 		
-		SP--;
-		SETs(boolSV(aiv == biv));
-		RETURN;
-	    }
-	    if (auvok && buvok) { /* ## UV == UV ## */
-		UV auv = SvUVX(TOPm1s);
-		UV buv = SvUVX(TOPs);
-		
-		SP--;
 		SETs(boolSV(auv == buv));
 		RETURN;
 	    }
 	    {			/* ## Mixed IV,UV ## */
+                SV *ivp, *uvp;
 		IV iv;
-		UV uv;
 		
-		/* == is commutative so swap if needed (save code) */
+		/* == is commutative so doesn't matter which is left or right */
 		if (auvok) {
-		    /* swap. top of stack (b) is the iv */
-		    iv = SvIVX(TOPs);
-		    SP--;
-		    if (iv < 0) {
-			/* As (a) is a UV, it's >0, so it cannot be == */
-			SETs(&PL_sv_no);
-			RETURN;
-		    }
-		    uv = SvUVX(TOPs);
-		} else {
-		    iv = SvIVX(TOPm1s);
-		    SP--;
-		    if (iv < 0) {
-			/* As (b) is a UV, it's >0, so it cannot be == */
-			SETs(&PL_sv_no);
-			RETURN;
-		    }
-		    uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
-		}
+		    /* top of stack (b) is the iv */
+                    ivp = *SP;
+                    uvp = *--SP;
+                } else {
+                    uvp = *SP;
+                    ivp = *--SP;
+                }
+                iv = SvIVX(ivp);
+                if (iv < 0) {
+                    /* As uv is a UV, it's >0, so it cannot be == */
+                    SETs(&PL_sv_no);
+                    RETURN;
+                }
 		/* we know iv is >= 0 */
-		if (uv > (UV) IV_MAX) {
-		    SETs(&PL_sv_no);
-		    RETURN;
-		}
-		SETs(boolSV((UV)iv == uv));
+		SETs(boolSV((UV)iv == SvUVX(uvp)));
 		RETURN;
 	    }
 	}
@@ -314,12 +300,12 @@ PP(pp_eq)
 PP(pp_preinc)
 {
     dSP;
-    if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+    if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
 	DIE(aTHX_ PL_no_modify);
-    if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
-    	SvIVX(TOPs) != IV_MAX)
+    if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
+        && SvIVX(TOPs) != IV_MAX)
     {
-	++SvIVX(TOPs);
+	SvIV_set(TOPs, SvIVX(TOPs) + 1);
 	SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
     }
     else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
@@ -339,6 +325,41 @@ PP(pp_or)
     }
 }
 
+PP(pp_dor)
+{
+    /* Most of this is lifted straight from pp_defined */
+    dSP;
+    register SV* const 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);
@@ -412,7 +433,7 @@ PP(pp_add)
 		if ((auvok = SvUOK(TOPm1s)))
 		    auv = SvUVX(TOPm1s);
 		else {
-		    register IV aiv = SvIVX(TOPm1s);
+		    register const IV aiv = SvIVX(TOPm1s);
 		    if (aiv >= 0) {
 			auv = aiv;
 			auvok = 1;	/* Now acting as a sign flag.  */
@@ -432,7 +453,7 @@ PP(pp_add)
 	    if (buvok)
 		buv = SvUVX(TOPs);
 	    else {
-		register IV biv = SvIVX(TOPs);
+		register const IV biv = SvIVX(TOPs);
 		if (biv >= 0) {
 		    buv = biv;
 		    buvok = 1;
@@ -440,7 +461,7 @@ PP(pp_add)
 		    buv = (UV)-biv;
 	    }
 	    /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
-	       else "IV" now, independant of how it came in.
+	       else "IV" now, independent of how it came in.
 	       if a, b represents positive, A, B negative, a maps to -A etc
 	       a + b =>  (a + b)
 	       A + b => -(a - b)
@@ -504,8 +525,9 @@ PP(pp_add)
 PP(pp_aelemfast)
 {
     dSP;
-    AV *av = GvAV(cGVOP_gv);
-    U32 lval = PL_op->op_flags & OPf_MOD;
+    AV *av = PL_op->op_flags & OPf_SPECIAL ?
+		(AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
+    const U32 lval = PL_op->op_flags & OPf_MOD;
     SV** svp = av_fetch(av, PL_op->op_private, lval);
     SV *sv = (svp ? *svp : &PL_sv_undef);
     EXTEND(SP, 1);
@@ -548,7 +570,7 @@ PP(pp_pushre)
 
 PP(pp_print)
 {
-    dSP; dMARK; dORIGMARK;
+    dVAR; dSP; dMARK; dORIGMARK;
     GV *gv;
     IO *io;
     register PerlIO *fp;
@@ -558,7 +580,10 @@ PP(pp_print)
 	gv = (GV*)*++MARK;
     else
 	gv = PL_defoutgv;
-    if ((mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
+
+    if (gv && (io = GvIO(gv))
+	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+    {
       had_magic:
 	if (MARK == ORIGMARK) {
 	    /* If using default handle then we need to make space to
@@ -570,7 +595,7 @@ PP(pp_print)
 	    ++SP;
 	}
 	PUSHMARK(MARK - 1);
-	*MARK = SvTIED_obj((SV*)gv, mg);
+	*MARK = SvTIED_obj((SV*)io, mg);
 	PUTBACK;
 	ENTER;
 	call_method("PRINT", G_SCALAR);
@@ -582,12 +607,12 @@ PP(pp_print)
 	RETURN;
     }
     if (!(io = GvIO(gv))) {
-        if ((GvEGV(gv))
-		&& (mg = SvTIED_mg((SV*)GvEGV(gv), PERL_MAGIC_tiedscalar)))
+        if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
+	    && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
             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))) {
@@ -597,7 +622,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 {
@@ -666,6 +691,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) {
@@ -686,9 +714,6 @@ PP(pp_rv2av)
 	    GV *gv;
 	
 	    if (SvTYPE(sv) != SVt_PVGV) {
-		char *sym;
-		STRLEN len;
-
 		if (SvGMAGICAL(sv)) {
 		    mg_get(sv);
 		    if (SvROK(sv))
@@ -699,29 +724,28 @@ PP(pp_rv2av)
 		      PL_op->op_private & HINT_STRICT_REFS)
 			DIE(aTHX_ PL_no_usym, "an ARRAY");
 		    if (ckWARN(WARN_UNINITIALIZED))
-			report_uninit();
+			report_uninit(sv);
 		    if (GIMME == G_ARRAY) {
 			(void)POPs;
 			RETURN;
 		    }
 		    RETSETUNDEF;
 		}
-		sym = SvPV(sv,len);
 		if ((PL_op->op_flags & OPf_SPECIAL) &&
 		    !(PL_op->op_flags & OPf_MOD))
 		{
-		    gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
+		    gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVAV);
 		    if (!gv
-			&& (!is_gv_magical(sym,len,0)
-			    || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
+			&& (!is_gv_magical_sv(sv,0)
+			    || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV))))
 		    {
 			RETSETUNDEF;
 		    }
 		}
 		else {
 		    if (PL_op->op_private & HINT_STRICT_REFS)
-			DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
-		    gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
+			DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
+		    gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV);
 		}
 	    }
 	    else {
@@ -745,14 +769,17 @@ PP(pp_rv2av)
     }
 
     if (GIMME == G_ARRAY) {
-	I32 maxarg = AvFILL(av) + 1;
+	const I32 maxarg = AvFILL(av) + 1;
 	(void)POPs;			/* XXXX May be optimized away? */
 	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;
+		/* See note in pp_helem, and bug id #27839 */
+		SP[i+1] = svp
+		    ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
+		    : &PL_sv_undef;
 	    }
 	}
 	else {
@@ -760,9 +787,9 @@ PP(pp_rv2av)
 	}
 	SP += maxarg;
     }
-    else {
+    else if (GIMME_V == G_SCALAR) {
 	dTARGET;
-	I32 maxarg = AvFILL(av) + 1;
+	const I32 maxarg = AvFILL(av) + 1;
 	SETi(maxarg);
     }
     RETURN;
@@ -772,36 +799,40 @@ PP(pp_rv2hv)
 {
     dSP; dTOPss;
     HV *hv;
+    const I32 gimme = GIMME_V;
+    static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
 
     if (SvROK(sv)) {
       wasref:
 	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)
-		Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
+	    if (gimme != G_ARRAY)
+		Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
 	    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);
 		RETURN;
 	    }
 	    else if (LVRET) {
-		if (GIMME == G_SCALAR)
-		    Perl_croak(aTHX_ "Can't return hash to lvalue"
-			       " scalar context");
+		if (gimme != G_ARRAY)
+		    Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
 		SETs((SV*)hv);
 		RETURN;
 	    }
@@ -810,9 +841,6 @@ PP(pp_rv2hv)
 	    GV *gv;
 	
 	    if (SvTYPE(sv) != SVt_PVGV) {
-		char *sym;
-		STRLEN len;
-
 		if (SvGMAGICAL(sv)) {
 		    mg_get(sv);
 		    if (SvROK(sv))
@@ -823,29 +851,28 @@ PP(pp_rv2hv)
 		      PL_op->op_private & HINT_STRICT_REFS)
 			DIE(aTHX_ PL_no_usym, "a HASH");
 		    if (ckWARN(WARN_UNINITIALIZED))
-			report_uninit();
-		    if (GIMME == G_ARRAY) {
+			report_uninit(sv);
+		    if (gimme == G_ARRAY) {
 			SP--;
 			RETURN;
 		    }
 		    RETSETUNDEF;
 		}
-		sym = SvPV(sv,len);
 		if ((PL_op->op_flags & OPf_SPECIAL) &&
 		    !(PL_op->op_flags & OPf_MOD))
 		{
-		    gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
+		    gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVHV);
 		    if (!gv
-			&& (!is_gv_magical(sym,len,0)
-			    || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
+			&& (!is_gv_magical_sv(sv,0)
+			    || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV))))
 		    {
 			RETSETUNDEF;
 		    }
 		}
 		else {
 		    if (PL_op->op_private & HINT_STRICT_REFS)
-			DIE(aTHX_ PL_no_symref, sym, "a HASH");
-		    gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
+			DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
+		    gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV);
 		}
 	    }
 	    else {
@@ -859,77 +886,24 @@ PP(pp_rv2hv)
 		RETURN;
 	    }
 	    else if (LVRET) {
-		if (GIMME == G_SCALAR)
-		    Perl_croak(aTHX_ "Can't return hash to lvalue"
-			       " scalar context");
+		if (gimme != G_ARRAY)
+		    Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
 		SETs((SV*)hv);
 		RETURN;
 	    }
 	}
     }
 
-    if (GIMME == G_ARRAY) { /* array wanted */
+    if (gimme == G_ARRAY) { /* array wanted */
 	*PL_stack_sp = (SV*)hv;
 	return do_kv();
     }
-    else {
+    else if (gimme == G_SCALAR) {
 	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);
-	else
-	    sv_setiv(TARG, 0);
-	
+    TARG = Perl_hv_scalar(aTHX_ hv);
 	SETTARG;
-	RETURN;
     }
-}
-
-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;
+    RETURN;
 }
 
 STATIC void
@@ -937,45 +911,37 @@ S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
 {
     if (*relem) {
 	SV *tmpstr;
-	if (ckWARN(WARN_MISC)) {
+        const HE *didstore;
+
+        if (ckWARN(WARN_MISC)) {
+	    const char *err;
 	    if (relem == firstrelem &&
 		SvROK(*relem) &&
 		(SvTYPE(SvRV(*relem)) == SVt_PVAV ||
 		 SvTYPE(SvRV(*relem)) == SVt_PVHV))
 	    {
-		Perl_warner(aTHX_ WARN_MISC,
-			    "Reference found where even-sized list expected");
+		err = "Reference found where even-sized list expected";
 	    }
 	    else
-		Perl_warner(aTHX_ 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);
+		err = "Odd number of elements in hash assignment";
+	    Perl_warner(aTHX_ packWARN(WARN_MISC), err);
 	}
-	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;
     }
 }
 
 PP(pp_aassign)
 {
-    dSP;
+    dVAR; dSP;
     SV **lastlelem = PL_stack_sp;
     SV **lastrelem = PL_stack_base + POPMARK;
     SV **firstrelem = PL_stack_base + POPMARK + 1;
@@ -991,8 +957,12 @@ PP(pp_aassign)
     HV *hash;
     I32 i;
     int magic;
+    int duplicates = 0;
+    SV **firsthashrelem = 0;	/* "= 0" keeps gcc 2.95 quiet  */
+
 
     PL_delaymagic = DM_DELAY;		/* catch simultaneous items */
+    gimme = GIMME_V;
 
     /* If there's a common identifier on both sides we have to take
      * special care that assigning the identifier on the left doesn't
@@ -1001,7 +971,6 @@ PP(pp_aassign)
     if (PL_op->op_private & (OPpASSIGN_COMMON)) {
 	EXTEND_MORTAL(lastrelem - firstrelem + 1);
 	for (relem = firstrelem; relem <= lastrelem; relem++) {
-	    /*SUPPRESS 560*/
 	    if ((sv = *relem)) {
 		TAINT_NOT;	/* Each item is independent */
 		*relem = sv_mortalcopy(sv);
@@ -1021,27 +990,13 @@ 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;
 	    while (relem <= lastrelem) {	/* gobble up all the rest */
 		SV **didstore;
-		sv = NEWSV(28,0);
 		assert(*relem);
-		sv_setsv(sv,*relem);
+		sv = newSVsv(*relem);
 		*(relem++) = sv;
 		didstore = av_store(ary,i++,sv);
 		if (magic) {
@@ -1059,6 +1014,7 @@ PP(pp_aassign)
 		hash = (HV*)sv;
 		magic = SvMAGICAL(hash) != 0;
 		hv_clear(hash);
+		firsthashrelem = relem;
 
 		while (relem < lastrelem) {	/* gobble up all the rest */
 		    HE *didstore;
@@ -1070,6 +1026,9 @@ PP(pp_aassign)
 		    if (*relem)
 			sv_setsv(tmpstr,*relem);	/* value */
 		    *(relem++) = tmpstr;
+		    if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
+			/* key overwrites an existing entry */
+			duplicates += 2;
 		    didstore = hv_store_ent(hash,sv,tmpstr,0);
 		    if (magic) {
 			if (SvSMAGICAL(tmpstr))
@@ -1104,10 +1063,13 @@ PP(pp_aassign)
     if (PL_delaymagic & ~DM_DELAY) {
 	if (PL_delaymagic & DM_UID) {
 #ifdef HAS_SETRESUID
-	    (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
+	    (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
+			    (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
+			    (Uid_t)-1);
 #else
 #  ifdef HAS_SETREUID
-	    (void)setreuid(PL_uid,PL_euid);
+	    (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
+			   (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
 #  else
 #    ifdef HAS_SETRUID
 	    if ((PL_delaymagic & DM_UID) == DM_RUID) {
@@ -1117,7 +1079,7 @@ PP(pp_aassign)
 #    endif /* HAS_SETRUID */
 #    ifdef HAS_SETEUID
 	    if ((PL_delaymagic & DM_UID) == DM_EUID) {
-		(void)seteuid(PL_uid);
+		(void)seteuid(PL_euid);
 		PL_delaymagic &= ~DM_EUID;
 	    }
 #    endif /* HAS_SETEUID */
@@ -1133,10 +1095,13 @@ PP(pp_aassign)
 	}
 	if (PL_delaymagic & DM_GID) {
 #ifdef HAS_SETRESGID
-	    (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
+	    (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
+			    (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
+			    (Gid_t)-1);
 #else
 #  ifdef HAS_SETREGID
-	    (void)setregid(PL_gid,PL_egid);
+	    (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
+			   (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
 #  else
 #    ifdef HAS_SETRGID
 	    if ((PL_delaymagic & DM_GID) == DM_RGID) {
@@ -1146,7 +1111,7 @@ PP(pp_aassign)
 #    endif /* HAS_SETRGID */
 #    ifdef HAS_SETEGID
 	    if ((PL_delaymagic & DM_GID) == DM_EGID) {
-		(void)setegid(PL_gid);
+		(void)setegid(PL_egid);
 		PL_delaymagic &= ~DM_EGID;
 	    }
 #    endif /* HAS_SETEGID */
@@ -1164,17 +1129,26 @@ PP(pp_aassign)
     }
     PL_delaymagic = 0;
 
-    gimme = GIMME_V;
     if (gimme == G_VOID)
 	SP = firstrelem - 1;
     else if (gimme == G_SCALAR) {
 	dTARGET;
 	SP = firstrelem;
-	SETi(lastrelem - firstrelem + 1);
+	SETi(lastrelem - firstrelem + 1 - duplicates);
     }
     else {
-	if (ary || hash)
+	if (ary)
+	    SP = lastrelem;
+	else if (hash) {
+	    if (duplicates) {
+		/* Removes from the stack the entries which ended up as
+		 * duplicated keys in the hash (fix for [perl #24380]) */
+		Move(firsthashrelem + duplicates,
+			firsthashrelem, duplicates, SV**);
+		lastrelem -= duplicates;
+	    }
 	    SP = lastrelem;
+	}
 	else
 	    SP = firstrelem + (lastlelem - firstlelem);
 	lelem = firstlelem + (relem - firstrelem);
@@ -1190,6 +1164,8 @@ PP(pp_qr)
     register PMOP *pm = cPMOP;
     SV *rv = sv_newmortal();
     SV *sv = newSVrv(rv, "Regexp");
+    if (pm->op_pmdynflags & PMdf_TAINTED)
+        SvTAINTED_on(rv);
     sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
     RETURNX(PUSHs(rv));
 }
@@ -1198,37 +1174,43 @@ PP(pp_match)
 {
     dSP; dTARG;
     register PMOP *pm = cPMOP;
-    register char *t;
-    register char *s;
-    char *strend;
+    PMOP *dynpm = pm;
+    const register char *t;
+    const register char *s;
+    const char *strend;
     I32 global;
     I32 r_flags = REXEC_CHECKED;
-    char *truebase;			/* Start of string  */
+    const char *truebase;			/* Start of string  */
     register REGEXP *rx = PM_GETRE(pm);
     bool rxtainted;
-    I32 gimme = GIMME;
+    const I32 gimme = GIMME;
     STRLEN len;
     I32 minmatch = 0;
-    I32 oldsave = PL_savestack_ix;
+    const I32 oldsave = PL_savestack_ix;
     I32 update_minmatch = 1;
     I32 had_zerolen = 0;
 
     if (PL_op->op_flags & OPf_STACKED)
 	TARG = POPs;
+    else if (PL_op->op_private & OPpTARGET_MY)
+	GETTARGET;
     else {
 	TARG = DEFSV;
 	EXTEND(SP,1);
     }
-    PL_reg_sv = TARG;
+
     PUTBACK;				/* EVAL blocks need stack_sp. */
-    s = SvPV(TARG, len);
-    strend = s + len;
+    s = SvPV_const(TARG, len);
     if (!s)
 	DIE(aTHX_ "panic: pp_match");
+    strend = s + len;
     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
 		 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
     TAINT_NOT;
 
+    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)
@@ -1236,16 +1218,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);
@@ -1267,11 +1252,6 @@ PP(pp_match)
     if (SvSCREAM(TARG))
 	r_flags |= REXEC_SCREAM;
 
-    if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
-	SAVEINT(PL_multiline);
-	PL_multiline = pm->op_pmflags & PMf_MULTILINE;
-    }
-
 play_it_again:
     if (global && rx->startp[0] != -1) {
 	t = s = rx->endp[0] + truebase;
@@ -1282,8 +1262,9 @@ play_it_again:
     }
     if (rx->reganch & RE_USE_INTUIT &&
 	DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
-	PL_bostr = truebase;
-	s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
+	/* FIXME - can PL_bostr be made const char *?  */
+	PL_bostr = (char *)truebase;
+	s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
 
 	if (!s)
 	    goto nope;
@@ -1295,11 +1276,11 @@ play_it_again:
 	     && !SvROK(TARG))	/* Cannot trust since INTUIT cannot guess ^ */
 	    goto yup;
     }
-    if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
+    if (CALLREGEXEC(aTHX_ rx, (char*)s, (char *)strend, (char*)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
@@ -1311,28 +1292,42 @@ play_it_again:
 	RX_MATCH_TAINTED_on(rx);
     TAINT_IF(RX_MATCH_TAINTED(rx));
     if (gimme == G_ARRAY) {
-	I32 nparens, i, len;
+	const I32 nparens = rx->nparens;
+	I32 i = (global && !nparens) ? 1 : 0;
 
-	nparens = rx->nparens;
-	if (global && !nparens)
-	    i = 1;
-	else
-	    i = 0;
 	SPAGAIN;			/* EVAL blocks could move the stack. */
 	EXTEND(SP, nparens + i);
 	EXTEND_MORTAL(nparens + i);
 	for (i = !i; i <= nparens; i++) {
 	    PUSHs(sv_newmortal());
-	    /*SUPPRESS 560*/
 	    if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
-		len = rx->endp[i] - rx->startp[i];
+		const I32 len = rx->endp[i] - rx->startp[i];
 		s = rx->startp[i] + truebase;
+	        if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
+		    len < 0 || len > strend - s)
+		    DIE(aTHX_ "panic: pp_match start/end pointers");
 		sv_setpvn(*SP, s, len);
-		if (DO_UTF8(TARG))
+		if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
 		    SvUTF8_on(*SP);
 	    }
 	}
 	if (global) {
+	    if (dynpm->op_pmflags & PMf_CONTINUE) {
+		MAGIC* mg = 0;
+		if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
+		    mg = mg_find(TARG, PERL_MAGIC_regex_global);
+		if (!mg) {
+		    sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
+		    mg = mg_find(TARG, PERL_MAGIC_regex_global);
+		}
+		if (rx->startp[0] != -1) {
+		    mg->mg_len = rx->endp[0];
+		    if (rx->startp[0] == rx->endp[0])
+			mg->mg_flags |= MGf_MINMATCH;
+		    else
+			mg->mg_flags &= ~MGf_MINMATCH;
+		}
+	    }
 	    had_zerolen = (rx->startp[0] != -1
 			   && rx->startp[0] == rx->endp[0]);
 	    PUTBACK;			/* EVAL blocks may use stack */
@@ -1370,16 +1365,17 @@ 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);
     rx->subbeg = Nullch;
     if (global) {
-	rx->subbeg = truebase;
+	/* FIXME - should rx->subbeg be const char *?  */
+	rx->subbeg = (char *) truebase;
 	rx->startp[0] = s - truebase;
-	if (DO_UTF8(PL_reg_sv)) {
+	if (RX_MATCH_UTF8(rx)) {
 	    char *t = (char*)utf8_hop((U8*)s, rx->minlen);
 	    rx->endp[0] = t - truebase;
 	}
@@ -1391,8 +1387,26 @@ yup:					/* Confirmed by INTUIT */
     }
     if (PL_sawampersand) {
 	I32 off;
+#ifdef PERL_OLD_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 = (char *) SvPVX_const(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_OLD_COPY_ON_WRITE
+	    rx->saved_copy = Nullsv;
+#endif
+	}
 	rx->sublen = strend - t;
 	RX_MATCH_COPIED_on(rx);
 	off = rx->startp[0] = s - t;
@@ -1402,13 +1416,13 @@ yup:					/* Confirmed by INTUIT */
 	rx->startp[0] = s - truebase;
 	rx->endp[0] = s - truebase + rx->minlen;
     }
-    rx->nparens = rx->lastparen = 0;	/* used by @- and @+ */
+    rx->nparens = rx->lastparen = rx->lastcloseparen = 0;	/* used by @-, @+, and $^N */
     LEAVE_SCOPE(oldsave);
     RETPUSHYES;
 
 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)
@@ -1424,26 +1438,29 @@ ret_no:
 OP *
 Perl_do_readline(pTHX)
 {
-    dSP; dTARGETSTACKED;
+    dVAR; dSP; dTARGETSTACKED;
     register SV *sv;
     STRLEN tmplen = 0;
     STRLEN offset;
     PerlIO *fp;
-    register IO *io = GvIO(PL_last_in_gv);
-    register I32 type = PL_op->op_type;
-    I32 gimme = GIMME_V;
+    register IO * const io = GvIO(PL_last_in_gv);
+    register const I32 type = PL_op->op_type;
+    const I32 gimme = GIMME_V;
     MAGIC *mg;
 
-    if ((mg = SvTIED_mg((SV*)PL_last_in_gv, PERL_MAGIC_tiedscalar))) {
+    if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
 	PUSHMARK(SP);
-	XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
+	XPUSHs(SvTIED_obj((SV*)io, mg));
 	PUTBACK;
 	ENTER;
 	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;
@@ -1456,7 +1473,7 @@ Perl_do_readline(pTHX)
 		    if (av_len(GvAVn(PL_last_in_gv)) < 0) {
 			IoFLAGS(io) &= ~IOf_START;
 			do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
-			sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
+			sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
 			SvSETMAGIC(GvSV(PL_last_in_gv));
 			fp = IoIFP(io);
 			goto have_fp;
@@ -1477,17 +1494,22 @@ Perl_do_readline(pTHX)
 	}
     }
     if (!fp) {
-	if (ckWARN2(WARN_GLOB, WARN_CLOSED)
-		&& (!io || !(IoFLAGS(io) & IOf_START))) {
+	if ((!io || !(IoFLAGS(io) & IOf_START))
+	    && ckWARN2(WARN_GLOB, WARN_CLOSED))
+	{
 	    if (type == OP_GLOB)
-		Perl_warner(aTHX_ WARN_GLOB,
+		Perl_warner(aTHX_ packWARN(WARN_GLOB),
 			    "glob failed (can't start child: %s)",
 			    Strerror(errno));
 	    else
 		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);
+		SvOK_off(TARG);
+	    }
 	    PUSHTARG;
 	}
 	RETURN;
@@ -1497,14 +1519,17 @@ Perl_do_readline(pTHX)
 	sv = TARG;
 	if (SvROK(sv))
 	    sv_unref(sv);
-	(void)SvUPGRADE(sv, SVt_PV);
+	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)) {
+		SvPV_force_nolen(sv);
+	    }
 	    offset = SvCUR(sv);
-	else
-	    offset = 0;
+	}
     }
     else {
 	sv = sv_2mortal(NEWSV(57, 80));
@@ -1526,7 +1551,9 @@ Perl_do_readline(pTHX)
     for (;;) {
 	PUTBACK;
 	if (!sv_gets(sv, fp, offset)
-	    && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
+	    && (type == OP_GLOB
+		|| SNARF_EOF(gimme, PL_rs, io, sv)
+		|| PerlIO_error(fp)))
 	{
 	    PerlIO_clearerr(fp);
 	    if (IoFLAGS(io) & IOf_ARGV) {
@@ -1537,14 +1564,17 @@ Perl_do_readline(pTHX)
 	    }
 	    else if (type == OP_GLOB) {
 		if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
-		    Perl_warner(aTHX_ WARN_GLOB,
+		    Perl_warner(aTHX_ packWARN(WARN_GLOB),
 			   "glob failed (child exited with status %d%s)",
 			   (int)(STATUS_CURRENT >> 8),
 			   (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
 		}
 	    }
 	    if (gimme == G_SCALAR) {
-		(void)SvOK_off(TARG);
+		if (type != OP_RCATLINE) {
+		    SV_CHECK_THINKFIRST_COW_DROP(TARG);
+		    SvOK_off(TARG);
+		}
 		SPAGAIN;
 		PUSHTARG;
 	    }
@@ -1559,38 +1589,47 @@ Perl_do_readline(pTHX)
 	XPUSHs(sv);
 	if (type == OP_GLOB) {
 	    char *tmps;
+	    const char *t1;
 
 	    if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
 		tmps = SvEND(sv) - 1;
-		if (*tmps == *SvPVX(PL_rs)) {
+		if (*tmps == *SvPVX_const(PL_rs)) {
 		    *tmps = '\0';
-		    SvCUR(sv)--;
+		    SvCUR_set(sv, SvCUR(sv) - 1);
 		}
 	    }
-	    for (tmps = SvPVX(sv); *tmps; tmps++)
-		if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
-		    strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
+	    for (t1 = SvPVX_const(sv); *t1; t1++)
+		if (!isALPHA(*t1) && !isDIGIT(*t1) &&
+		    strchr("$&*(){}[]'\";\\|?<>~`", *t1))
 			break;
-	    if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
+	    if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
 		(void)POPs;		/* Unmatched wildcard?  Chuck it... */
 		continue;
 	    }
+	} else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
+	     const U8 *s = (const U8*)SvPVX_const(sv) + offset;
+	     const STRLEN len = SvCUR(sv) - offset;
+	     const U8 *f;
+	     
+	     if (ckWARN(WARN_UTF8) &&
+		    !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
+		  /* Emulate :encoding(utf8) warning in the same case. */
+		  Perl_warner(aTHX_ packWARN(WARN_UTF8),
+			      "utf8 \"\\x%02X\" does not map to Unicode",
+			      f < (U8*)SvEND(sv) ? *f : 0);
 	}
 	if (gimme == G_ARRAY) {
 	    if (SvLEN(sv) - SvCUR(sv) > 20) {
-		SvLEN_set(sv, SvCUR(sv)+1);
-		Renew(SvPVX(sv), SvLEN(sv), char);
+		SvPV_shrink_to_cur(sv);
 	    }
 	    sv = sv_2mortal(NEWSV(58, 80));
 	    continue;
 	}
 	else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
 	    /* try to reclaim a bit of scalar space (only on 1st alloc) */
-	    if (SvCUR(sv) < 60)
-		SvLEN_set(sv, 80);
-	    else
-		SvLEN_set(sv, SvCUR(sv)+40);	/* allow some slop */
-	    Renew(SvPVX(sv), SvLEN(sv), char);
+	    const STRLEN new_len
+		= SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
+	    SvPV_renew(sv, new_len);
 	}
 	RETURN;
     }
@@ -1598,7 +1637,7 @@ Perl_do_readline(pTHX)
 
 PP(pp_enter)
 {
-    dSP;
+    dVAR; dSP;
     register PERL_CONTEXT *cx;
     I32 gimme = OP_GIMME(PL_op, -1);
 
@@ -1624,23 +1663,35 @@ PP(pp_helem)
     SV **svp;
     SV *keysv = POPs;
     HV *hv = (HV*)POPs;
-    U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
-    U32 defer = PL_op->op_private & OPpLVAL_DEFER;
+    const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
+    const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
     SV *sv;
-    U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
+    const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
     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;
     }
@@ -1649,8 +1700,7 @@ PP(pp_helem)
 	    SV* lv;
 	    SV* key2;
 	    if (!defer) {
-		STRLEN n_a;
-		DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
+		DIE(aTHX_ PL_no_helem_sv, keysv);
 	    }
 	    lv = sv_newmortal();
 	    sv_upgrade(lv, SVt_PVLV);
@@ -1663,12 +1713,12 @@ PP(pp_helem)
 	    RETURN;
 	}
 	if (PL_op->op_private & OPpLVAL_INTRO) {
-	    if (HvNAME(hv) && isGV(*svp))
+	    if (HvNAME_get(hv) && isGV(*svp))
 		save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
 	    else {
 		if (!preeminent) {
 		    STRLEN keylen;
-		    char *key = SvPV(keysv, keylen);
+		    const char * const key = SvPV_const(keysv, keylen);
 		    SAVEDELETE(hv, savepvn(key,keylen), keylen);
 		} else
 		    save_helem(hv, keysv, svp);
@@ -1692,9 +1742,8 @@ PP(pp_helem)
 
 PP(pp_leave)
 {
-    dSP;
+    dVAR; dSP;
     register PERL_CONTEXT *cx;
-    register SV **mark;
     SV **newsp;
     PMOP *newpm;
     I32 gimme;
@@ -1718,6 +1767,7 @@ PP(pp_leave)
     if (gimme == G_VOID)
 	SP = newsp;
     else if (gimme == G_SCALAR) {
+	register SV **mark;
 	MARK = newsp + 1;
 	if (MARK <= SP) {
 	    if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
@@ -1732,6 +1782,7 @@ PP(pp_leave)
     }
     else if (gimme == G_ARRAY) {
 	/* in case LEAVE wipes old return values */
+	register SV **mark;
 	for (mark = newsp + 1; mark <= SP; mark++) {
 	    if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
 		*mark = sv_mortalcopy(*mark);
@@ -1750,7 +1801,7 @@ PP(pp_iter)
 {
     dSP;
     register PERL_CONTEXT *cx;
-    SV* sv;
+    SV *sv, *oldsv;
     AV* av;
     SV **itersvp;
 
@@ -1766,24 +1817,23 @@ PP(pp_iter)
 	if (cx->blk_loop.iterlval) {
 	    /* string increment */
 	    register SV* cur = cx->blk_loop.iterlval;
-	    STRLEN maxlen;
-	    char *max = SvPV((SV*)av, maxlen);
+	    STRLEN maxlen = 0;
+	    const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
 	    if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
-#ifndef USE_THREADS			  /* 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
 		     * they used to */
-		    SvREFCNT_dec(*itersvp);
+		    oldsv = *itersvp;
 		    *itersvp = newSVsv(cur);
+		    SvREFCNT_dec(oldsv);
 		}
-		if (strEQ(SvPVX(cur), max))
+		if (strEQ(SvPVX_const(cur), max))
 		    sv_setiv(cur, 0); /* terminate next time */
 		else
 		    sv_inc(cur);
@@ -1795,39 +1845,62 @@ PP(pp_iter)
 	if (cx->blk_loop.iterix > cx->blk_loop.itermax)
 	    RETPUSHNO;
 
-#ifndef USE_THREADS			  /* 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
 	     * used to */
-	    SvREFCNT_dec(*itersvp);
+	    oldsv = *itersvp;
 	    *itersvp = newSViv(cx->blk_loop.iterix++);
+	    SvREFCNT_dec(oldsv);
 	}
 	RETPUSHYES;
     }
 
     /* iterate array */
-    if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
-	RETPUSHNO;
-
-    SvREFCNT_dec(*itersvp);
+    if (PL_op->op_private & OPpITER_REVERSED) {
+	/* In reverse, use itermax as the min :-)  */
+	if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
+	    RETPUSHNO;
 
-    if (SvMAGICAL(av) || AvREIFY(av)) {
-	SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
-	if (svp)
-	    sv = *svp;
-	else
-	    sv = Nullsv;
+	if (SvMAGICAL(av) || AvREIFY(av)) {
+	    SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
+	    if (svp)
+		sv = *svp;
+	    else
+		sv = Nullsv;
+	}
+	else {
+	    sv = AvARRAY(av)[cx->blk_loop.iterix--];
+	}
     }
     else {
-	sv = AvARRAY(av)[++cx->blk_loop.iterix];
+	if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
+				    AvFILL(av)))
+	    RETPUSHNO;
+
+	if (SvMAGICAL(av) || AvREIFY(av)) {
+	    SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
+	    if (svp)
+		sv = *svp;
+	    else
+		sv = Nullsv;
+	}
+	else {
+	    sv = AvARRAY(av)[++cx->blk_loop.iterix];
+	}
+    }
+
+    if (sv && SvREFCNT(sv) == 0) {
+	*itersvp = Nullsv;
+	Perl_croak(aTHX_ "Use of freed value in iteration");
     }
+
     if (sv)
 	SvTEMP_off(sv);
     else
@@ -1852,7 +1925,10 @@ PP(pp_iter)
 	sv = (SV*)lv;
     }
 
+    oldsv = *itersvp;
     *itersvp = SvREFCNT_inc(sv);
+    SvREFCNT_dec(oldsv);
+
     RETPUSHYES;
 }
 
@@ -1865,7 +1941,7 @@ PP(pp_subst)
     register char *s;
     char *strend;
     register char *m;
-    char *c;
+    const char *c;
     register char *d;
     STRLEN clen;
     I32 iters = 0;
@@ -1879,28 +1955,43 @@ PP(pp_subst)
     STRLEN len;
     int force_on_match = 0;
     I32 oldsave = PL_savestack_ix;
-    bool do_utf8;
     STRLEN slen;
+    bool doutf8 = FALSE;
+#ifdef PERL_OLD_COPY_ON_WRITE
+    bool is_cow;
+#endif
+    SV *nsv = Nullsv;
 
     /* known replacement string? */
     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
     if (PL_op->op_flags & OPf_STACKED)
 	TARG = POPs;
+    else if (PL_op->op_private & OPpTARGET_MY)
+	GETTARGET;
     else {
 	TARG = DEFSV;
 	EXTEND(SP,1);
     }
-    PL_reg_sv = TARG;
-    do_utf8 = DO_UTF8(PL_reg_sv);
-    if (SvFAKE(TARG) && SvREADONLY(TARG))
-	sv_force_normal(TARG);
-    if (SvREADONLY(TARG)
-	|| (SvTYPE(TARG) > SVt_PVLV
-	    && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
+
+#ifdef PERL_OLD_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_OLD_COPY_ON_WRITE
+	!is_cow &&
+#endif
+	(SvREADONLY(TARG)
+	|| ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
+	     && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
 	DIE(aTHX_ PL_no_modify);
     PUTBACK;
 
-    s = SvPV(TARG, len);
+    s = SvPV_mutable(TARG, len);
     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
 	force_on_match = 1;
     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
@@ -1909,12 +2000,14 @@ PP(pp_subst)
 	rxtainted |= 2;
     TAINT_NOT;
 
+    RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
+
   force_it:
     if (!pm || !s)
 	DIE(aTHX_ "panic: pp_subst");
 
     strend = s + len;
-    slen = do_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. */
@@ -1924,13 +2017,10 @@ 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)) {
-	SAVEINT(PL_multiline);
-	PL_multiline = pm->op_pmflags & PMf_MULTILINE;
-    }
+
     orig = m = s;
     if (rx->reganch & RE_USE_INTUIT) {
 	PL_bostr = orig;
@@ -1952,11 +2042,36 @@ PP(pp_subst)
     once = !(rpm->op_pmflags & PMf_GLOBAL);
 
     /* known replacement string? */
-    c = dstr ? SvPV(dstr, clen) : Nullch;
-
+    if (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_const(nsv, clen);
+	     doutf8 = TRUE;
+	}
+	else {
+	    c = SvPV_const(dstr, clen);
+	    doutf8 = DO_UTF8(dstr);
+	}
+    }
+    else {
+        c = Nullch;
+	doutf8 = FALSE;
+    }
+    
     /* can do inplace substitution? */
-    if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
-	&& !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
+    if (c
+#ifdef PERL_OLD_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))
 	{
@@ -1965,6 +2080,12 @@ PP(pp_subst)
 	    LEAVE_SCOPE(oldsave);
 	    RETURN;
 	}
+#ifdef PERL_OLD_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);
@@ -1991,7 +2112,6 @@ PP(pp_subst)
 		*m = '\0';
 		SvCUR_set(TARG, m - s);
 	    }
-	    /*SUPPRESS 560*/
 	    else if ((i = m - s)) {	/* faster from front */
 		d -= clen;
 		m = d;
@@ -2020,7 +2140,6 @@ PP(pp_subst)
 		    DIE(aTHX_ "Substitution loop");
 		rxtainted |= RX_MATCH_TAINTED(rx);
 		m = rx->startp[0] + orig;
-		/*SUPPRESS 560*/
 		if ((i = m - s)) {
 		    if (s != d)
 			Move(s, d, i, char);
@@ -2037,7 +2156,7 @@ PP(pp_subst)
 				 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
 	    if (s != d) {
 		i = strend - s;
-		SvCUR_set(TARG, d - SvPVX(TARG) + i);
+		SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
 		Move(s, d, i+1, char);		/* include the NUL */
 	    }
 	    TAINT_IF(rxtainted & 1);
@@ -2052,6 +2171,8 @@ PP(pp_subst)
 	    SPAGAIN;
 	}
 	SvTAINT(TARG);
+	if (doutf8)
+	    SvUTF8_on(TARG);
 	LEAVE_SCOPE(oldsave);
 	RETURN;
     }
@@ -2059,22 +2180,23 @@ PP(pp_subst)
     if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
 		    r_flags | REXEC_CHECKED))
     {
-	bool isutf8;
-
 	if (force_on_match) {
 	    force_on_match = 0;
 	    s = SvPV_force(TARG, len);
 	    goto force_it;
 	}
+#ifdef PERL_OLD_COPY_ON_WRITE
+      have_a_cow:
+#endif
 	rxtainted |= RX_MATCH_TAINTED(rx);
-	dstr = NEWSV(25, len);
-	sv_setpvn(dstr, m, s-m);
+	dstr = newSVpvn(m, s-m);
 	if (DO_UTF8(TARG))
 	    SvUTF8_on(dstr);
 	PL_curpm = pm;
 	if (!c) {
 	    register PERL_CONTEXT *cx;
 	    SPAGAIN;
+	    (void)ReREFCNT_inc(rx);
 	    PUSHSUBST(cx);
 	    RETURNOP(cPMOP->op_pmreplroot);
 	}
@@ -2091,7 +2213,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);
@@ -2099,15 +2224,29 @@ 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));
-	SvPVX(TARG) = SvPVX(dstr);
+	if (doutf8 && !DO_UTF8(TARG))
+	    sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
+	else
+	    sv_catpvn(dstr, s, strend - s);
+
+#ifdef PERL_OLD_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
+	{
+	    SvPV_free(TARG);
+	}
+	SvPV_set(TARG, SvPVX(dstr));
 	SvCUR_set(TARG, SvCUR(dstr));
 	SvLEN_set(TARG, SvLEN(dstr));
-	isutf8 = DO_UTF8(dstr);
-	SvPVX(dstr) = 0;
+	doutf8 |= DO_UTF8(dstr);
+	SvPV_set(dstr, (char*)0);
 	sv_free(dstr);
 
 	TAINT_IF(rxtainted & 1);
@@ -2115,7 +2254,7 @@ PP(pp_subst)
 	PUSHs(sv_2mortal(newSViv((I32)iters)));
 
 	(void)SvPOK_only(TARG);
-	if (isutf8)
+	if (doutf8)
 	    SvUTF8_on(TARG);
 	TAINT_IF(rxtainted);
 	SvSETMAGIC(TARG);
@@ -2135,7 +2274,7 @@ ret_no:
 
 PP(pp_grepwhile)
 {
-    dSP;
+    dVAR; dSP;
 
     if (SvTRUEx(POPs))
 	PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
@@ -2153,8 +2292,15 @@ PP(pp_grepwhile)
 	(void)POPMARK;				/* pop dst */
 	SP = PL_stack_base + POPMARK;		/* pop original mark */
 	if (gimme == G_SCALAR) {
-	    dTARGET;
-	    XPUSHi(items);
+	    if (PL_op->op_private & OPpGREP_LEX) {
+		SV* sv = sv_newmortal();
+		sv_setiv(sv, items);
+		PUSHs(sv);
+	    }
+	    else {
+		dTARGET;
+		XPUSHi(items);
+	    }
 	}
 	else if (gimme == G_ARRAY)
 	    SP += items;
@@ -2168,7 +2314,10 @@ PP(pp_grepwhile)
 
 	src = PL_stack_base[*PL_markstack_ptr];
 	SvTEMP_off(src);
-	DEFSV = src;
+	if (PL_op->op_private & OPpGREP_LEX)
+	    PAD_SVl(PL_op->op_targ) = src;
+	else
+	    DEFSV = src;
 
 	RETURNOP(cLOGOP->op_other);
     }
@@ -2176,7 +2325,7 @@ PP(pp_grepwhile)
 
 PP(pp_leavesub)
 {
-    dSP;
+    dVAR; dSP;
     SV **mark;
     SV **newsp;
     PMOP *newpm;
@@ -2185,6 +2334,7 @@ PP(pp_leavesub)
     SV *sv;
 
     POPBLOCK(cx,newpm);
+    cxstack_ix++; /* temporarily protect top context */
 
     TAINT_NOT;
     if (gimme == G_SCALAR) {
@@ -2222,19 +2372,20 @@ PP(pp_leavesub)
     }
     PUTBACK;
 
+    LEAVE;
+    cxstack_ix--;
     POPSUB(cx,sv);	/* Stack values are safe: release CV and @_ ... */
     PL_curpm = newpm;	/* ... and pop $1 et al */
 
-    LEAVE;
     LEAVESUB(sv);
-    return pop_return();
+    return cx->blk_sub.retop;
 }
 
 /* This duplicates the above code because the above code must not
  * get any slower by more conditions */
 PP(pp_leavesublv)
 {
-    dSP;
+    dVAR; dSP;
     SV **mark;
     SV **newsp;
     PMOP *newpm;
@@ -2243,6 +2394,7 @@ PP(pp_leavesublv)
     SV *sv;
 
     POPBLOCK(cx,newpm);
+    cxstack_ix++; /* temporarily protect top context */
 
     TAINT_NOT;
 
@@ -2278,9 +2430,10 @@ 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;
+	    cxstack_ix--;
 	    POPSUB(cx,sv);
 	    PL_curpm = newpm;
-	    LEAVE;
 	    LEAVESUB(sv);
 	    DIE(aTHX_ "Can't modify non-lvalue subroutine call");
 	}
@@ -2288,13 +2441,18 @@ PP(pp_leavesublv)
 	    MARK = newsp + 1;
 	    EXTEND_MORTAL(1);
 	    if (MARK == SP) {
-		if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
+		/* Temporaries are bad unless they happen to be elements
+		 * of a tied hash or array */
+		if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
+		    !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
+		    LEAVE;
+		    cxstack_ix--;
 		    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. */
@@ -2303,9 +2461,10 @@ PP(pp_leavesublv)
 		}
 	    }
 	    else {			/* Should not happen? */
+		LEAVE;
+		cxstack_ix--;
 		POPSUB(cx,sv);
 		PL_curpm = newpm;
-		LEAVE;
 		LEAVESUB(sv);
 		DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
 		    (MARK > SP ? "Empty array" : "Array"));
@@ -2319,9 +2478,10 @@ PP(pp_leavesublv)
 		    && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
 		    /* Might be flattened array after $#array =  */
 		    PUTBACK;
+		    LEAVE;
+		    cxstack_ix--;
 		    POPSUB(cx,sv);
 		    PL_curpm = newpm;
-		    LEAVE;
 		    LEAVESUB(sv);
 		    DIE(aTHX_ "Can't return a %s from lvalue subroutine",
 			SvREADONLY(TOPs) ? "readonly value" : "temporary");
@@ -2373,24 +2533,25 @@ PP(pp_leavesublv)
     }
     PUTBACK;
 
+    LEAVE;
+    cxstack_ix--;
     POPSUB(cx,sv);	/* Stack values are safe: release CV and @_ ... */
     PL_curpm = newpm;	/* ... and pop $1 et al */
 
-    LEAVE;
     LEAVESUB(sv);
-    return pop_return();
+    return cx->blk_sub.retop;
 }
 
 
 STATIC CV *
 S_get_db_sub(pTHX_ SV **svp, CV *cv)
 {
-    SV *dbsv = GvSV(PL_DBsub);
+    SV *dbsv = GvSVn(PL_DBsub);
 
+    save_item(dbsv);
     if (!PERLDB_SUB_NN) {
 	GV *gv = CvGV(cv);
 
-	save_item(dbsv);
 	if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
 	     || strEQ(GvNAME(gv), "END")
 	     || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
@@ -2407,10 +2568,11 @@ S_get_db_sub(pTHX_ SV **svp, CV *cv)
 	}
     }
     else {
-	(void)SvUPGRADE(dbsv, SVt_PVIV);
+	const int type = SvTYPE(dbsv);
+	if (type < SVt_PVIV && type != SVt_IV)
+	    sv_upgrade(dbsv, SVt_PVIV);
 	(void)SvIOK_on(dbsv);
-	SAVEIV(SvIVX(dbsv));
-	SvIVX(dbsv) = PTR2IV(cv);	/* Do it the quickest way  */
+	SvIV_set(dbsv, PTR2IV(cv));	/* Do it the quickest way  */
     }
 
     if (CvXSUB(cv))
@@ -2421,22 +2583,30 @@ S_get_db_sub(pTHX_ SV **svp, CV *cv)
 
 PP(pp_entersub)
 {
-    dSP; dPOPss;
+    dVAR; dSP; dPOPss;
     GV *gv;
     HV *stash;
     register CV *cv;
     register PERL_CONTEXT *cx;
     I32 gimme;
-    bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
+    const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
 
     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;
-	    STRLEN n_a;
-
+	    const char *sym;
 	    if (sv == &PL_sv_yes) {		/* unfound import, ignore */
 		if (hasargs)
 		    SP = PL_stack_base + POPMARK;
@@ -2444,10 +2614,13 @@ PP(pp_entersub)
 	    }
 	    if (SvGMAGICAL(sv)) {
 		mg_get(sv);
-		sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
+		if (SvROK(sv))
+		    goto got_rv;
+		sym = SvPOKp(sv) ? SvPVX_const(sv) : Nullch;
 	    }
-	    else
-		sym = SvPV(sv, n_a);
+	    else {
+		sym = SvPV_nolen_const(sv);
+            }
 	    if (!sym)
 		DIE(aTHX_ PL_no_usym, "a subroutine");
 	    if (PL_op->op_private & HINT_STRICT_REFS)
@@ -2455,6 +2628,7 @@ PP(pp_entersub)
 	    cv = get_cv(sym, TRUE);
 	    break;
 	}
+  got_rv:
 	{
 	    SV **sp = &sv;		/* Used in tryAMAGICunDEREF macro. */
 	    tryAMAGICunDEREF(to_cv);
@@ -2466,18 +2640,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;
@@ -2485,179 +2651,96 @@ 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 (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
+	    DIE(aTHX_ "No DB::sub routine defined");
     }
 
-#ifdef USE_THREADS
-    /*
-     * 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);
+	PUSHBLOCK(cx, CXt_SUB, MARK);
+	PUSHSUB(cx);
+	cx->blk_sub.retop = PL_op->op_next;
+	CvDEPTH(cv)++;
+	/* XXX This would be a natural place to set C<PL_compcv = cv> 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) {
+	    PERL_STACK_OVERFLOW_CHECK();
+	    pad_push(padlist, CvDEPTH(cv));
+	}
+	SAVECOMPPAD();
+	PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
+	if (hasargs)
+	{
+	    AV* av;
+#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) {
+		SV **ary = AvALLOC(av);
+		if (AvARRAY(av) != ary) {
+		    AvMAX(av) += AvARRAY(av) - AvALLOC(av);
+		    SvPV_set(av, (char*)ary);
+		}
+		if (items > AvMAX(av) + 1) {
+		    AvMAX(av) = items - 1;
+		    Renew(ary,items,SV*);
+		    AvALLOC(av) = ary;
+		    SvPV_set(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_THREADS */
-
-    if (CvXSUB(cv)) {
 #ifdef PERL_XSUB_OLDSTYLE
 	if (CvOLDSTYLE(cv)) {
 	    I32 (*fp3)(int,int,int);
@@ -2686,14 +2769,8 @@ try_autoload:
 		/* 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;
-#ifdef USE_THREADS
-		av = (AV*)PL_curpad[0];
-#else
-		av = GvAV(PL_defgv);
-#endif /* USE_THREADS */		
-		items = AvFILLp(av) + 1;   /* @_ is not tieable */
+		AV * const av = GvAV(PL_defgv);
+		const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
 
 		if (items) {
 		    /* Mark is at the end of the stack. */
@@ -2710,7 +2787,7 @@ try_autoload:
 		PL_curcopdb = NULL;
 	    }
 	    /* Do we need to open block here? XXXX */
-	    (void)(*CvXSUB(cv))(aTHXo_ cv);
+	    (void)(*CvXSUB(cv))(aTHX_ cv);
 
 	    /* Enforce some sanity in scalar context. */
 	    if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
@@ -2724,143 +2801,42 @@ 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<PL_compcv = cv> 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_THREADS
-	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_THREADS */		
-	SAVEVPTR(PL_curpad);
-    	PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
-#ifndef USE_THREADS
-	if (hasargs)
-#endif /* USE_THREADS */
-	{
-	    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_THREADS
-	    cx->blk_sub.savearray = GvAV(PL_defgv);
-	    GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
-#endif /* USE_THREADS */
-	    cx->blk_sub.oldcurpad = PL_curpad;
-	    cx->blk_sub.argarray = av;
-	    ++MARK;
+    /*NOTREACHED*/
+    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;
     }
 }
 
@@ -2868,12 +2844,12 @@ void
 Perl_sub_crush_depth(pTHX_ CV *cv)
 {
     if (CvANON(cv))
-	Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
+	Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
     else {
-	SV* tmpstr = sv_newmortal();
+	SV* const tmpstr = sv_newmortal();
 	gv_efullname3(tmpstr, CvGV(cv), Nullch);
-	Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
-		SvPVX(tmpstr));
+	Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
+		tmpstr);
     }
 }
 
@@ -2881,21 +2857,34 @@ PP(pp_aelem)
 {
     dSP;
     SV** svp;
-    SV* elemsv = POPs;
+    SV* const elemsv = POPs;
     IV elem = SvIV(elemsv);
     AV* av = (AV*)POPs;
-    U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
-    U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
+    const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
+    const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
     SV *sv;
 
     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
-	Perl_warner(aTHX_ 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)
 	RETPUSHUNDEF;
     svp = av_fetch(av, elem, lval && !defer);
     if (lval) {
+#ifdef PERL_MALLOC_WRAP
+	 if (SvUOK(elemsv)) {
+	      const UV uv = SvUV(elemsv);
+	      elem = uv > IV_MAX ? IV_MAX : uv;
+	 }
+	 else if (SvNOK(elemsv))
+	      elem = (IV)SvNV(elemsv);
+	 if (elem > 0) {
+	      static const char oom_array_extend[] =
+		"Out of memory during array extend"; /* Duplicated in av.c */
+	      MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
+	 }
+#endif
 	if (!svp || *svp == &PL_sv_undef) {
 	    SV* lv;
 	    if (!defer)
@@ -2933,19 +2922,19 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
 	if (SvTYPE(sv) < SVt_RV)
 	    sv_upgrade(sv, SVt_RV);
 	else if (SvTYPE(sv) >= SVt_PV) {
-	    (void)SvOOK_off(sv);
-	    Safefree(SvPVX(sv));
-	    SvLEN(sv) = SvCUR(sv) = 0;
+	    SvPV_free(sv);
+            SvLEN_set(sv, 0);
+	    SvCUR_set(sv, 0);
 	}
 	switch (to_what) {
 	case OPpDEREF_SV:
-	    SvRV(sv) = NEWSV(355,0);
+	    SvRV_set(sv, NEWSV(355,0));
 	    break;
 	case OPpDEREF_AV:
-	    SvRV(sv) = (SV*)newAV();
+	    SvRV_set(sv, (SV*)newAV());
 	    break;
 	case OPpDEREF_HV:
-	    SvRV(sv) = (SV*)newHV();
+	    SvRV_set(sv, (SV*)newHV());
 	    break;
 	}
 	SvROK_on(sv);
@@ -2956,10 +2945,10 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
 PP(pp_method)
 {
     dSP;
-    SV* sv = TOPs;
+    SV* const sv = TOPs;
 
     if (SvROK(sv)) {
-	SV* rsv = SvRV(sv);
+	SV* const rsv = SvRV(sv);
 	if (SvTYPE(rsv) == SVt_PVCV) {
 	    SETs(rsv);
 	    RETURN;
@@ -2973,8 +2962,8 @@ PP(pp_method)
 PP(pp_method_named)
 {
     dSP;
-    SV* sv = cSVOP->op_sv;
-    U32 hash = SvUVX(sv);
+    SV* const sv = cSVOP_sv;
+    U32 hash = SvSHARED_HASH(sv);
 
     XPUSHs(method_common(sv, &hash));
     RETURN;
@@ -2983,17 +2972,15 @@ PP(pp_method_named)
 STATIC SV *
 S_method_common(pTHX_ SV* meth, U32* hashp)
 {
-    SV* sv;
     SV* ob;
     GV* gv;
     HV* stash;
-    char* name;
     STRLEN namelen;
-    char* packname = 0;
+    const char* packname = Nullch;
+    SV *packsv = Nullsv;
     STRLEN packlen;
-
-    name = SvPV(meth, namelen);
-    sv = *(PL_stack_base + TOPMARK + 1);
+    const char * const name = SvPV_const(meth, namelen);
+    SV * const sv = *(PL_stack_base + TOPMARK + 1);
 
     if (!sv)
 	Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
@@ -3006,10 +2993,17 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
 	GV* iogv;
 
 	/* this isn't a reference */
-	packname = Nullch;
+        if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
+          const HE* const 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)) ||
-	    !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
+	    !(packname) ||
+	    !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
 	    !(ob=(SV*)GvIO(iogv)))
 	{
 	    /* this isn't the name of a filehandle either */
@@ -3025,6 +3019,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 */
@@ -3048,7 +3048,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
 
     /* shortcut for simple names */
     if (hashp) {
-	HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
+	const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
 	if (he) {
 	    gv = (GV*)HeVAL(he);
 	    if (isGV(gv) && GvCV(gv) &&
@@ -3057,7 +3057,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
@@ -3067,9 +3067,9 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
 	   cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
 	   don't want that.
 	*/
-	char* leaf = name;
-	char* sep = Nullch;
-	char* p;
+	const char* leaf = name;
+	const char* sep = Nullch;
+	const char* p;
 
 	for (p = name; *p; p++) {
 	    if (*p == '\'')
@@ -3078,10 +3078,30 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
 		sep = p, leaf = p + 2;
 	}
 	if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
-	    /* the method name is unqualified or starts with SUPER:: */ 
-	    packname = sep ? CopSTASHPV(PL_curcop) :
-		stash ? HvNAME(stash) : packname;
-	    packlen = strlen(packname);
+	    /* the method name is unqualified or starts with SUPER:: */
+	    bool need_strlen = 1;
+	    if (sep) {
+		packname = CopSTASHPV(PL_curcop);
+	    }
+	    else if (stash) {
+		HEK * const packhek = HvNAME_HEK(stash);
+		if (packhek) {
+		    packname = HEK_KEY(packhek);
+		    packlen = HEK_LEN(packhek);
+		    need_strlen = 0;
+		} else {
+		    goto croak;
+		}
+	    }
+
+	    if (!packname) {
+	    croak:
+		Perl_croak(aTHX_
+			   "Can't use anonymous symbol table for method lookup");
+	    }
+	    else if (need_strlen)
+		packlen = strlen(packname);
+
 	}
 	else {
 	    /* the method name is qualified */
@@ -3105,21 +3125,12 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
 }
 
-#ifdef USE_THREADS
-static void
-unset_cvowner(pTHXo_ 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_THREADS */
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */