X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/fcb8da00bbf96c055c5bfb9ae7a8086051c6f3b0..354810ee5b030780b7036ad80d5adf09f6dcb317:/doop.c

diff --git a/doop.c b/doop.c
index a562536..2294281 100644
--- a/doop.c
+++ b/doop.c
@@ -15,8 +15,8 @@
  */
 
 /* This file contains some common functions needed to carry out certain
- * ops. For example both pp_schomp() and pp_chomp() - scalar and array
- * chomp operations - call the function do_chomp() found in this file.
+ * ops. For example, both pp_sprintf() and pp_prtf() call the function
+ * do_sprintf() found in this file.
  */
 
 #include "EXTERN.h"
@@ -30,7 +30,6 @@
 STATIC I32
 S_do_trans_simple(pTHX_ SV * const sv)
 {
-    dVAR;
     I32 matches = 0;
     STRLEN len;
     U8 *s = (U8*)SvPV_nomg(sv,len);
@@ -99,7 +98,6 @@ S_do_trans_simple(pTHX_ SV * const sv)
 STATIC I32
 S_do_trans_count(pTHX_ SV * const sv)
 {
-    dVAR;
     STRLEN len;
     const U8 *s = (const U8*)SvPV_nomg_const(sv, len);
     const U8 * const send = s + len;
@@ -137,7 +135,6 @@ S_do_trans_count(pTHX_ SV * const sv)
 STATIC I32
 S_do_trans_complex(pTHX_ SV * const sv)
 {
-    dVAR;
     STRLEN len;
     U8 *s = (U8*)SvPV_nomg(sv, len);
     U8 * const send = s+len;
@@ -301,7 +298,6 @@ S_do_trans_complex(pTHX_ SV * const sv)
 STATIC I32
 S_do_trans_simple_utf8(pTHX_ SV * const sv)
 {
-    dVAR;
     U8 *s;
     U8 *send;
     U8 *d;
@@ -327,15 +323,9 @@ S_do_trans_simple_utf8(pTHX_ SV * const sv)
 
     s = (U8*)SvPV_nomg(sv, len);
     if (!SvUTF8(sv)) {
-	const U8 *t = s;
-	const U8 * const e = s + len;
-	while (t < e) {
-	    const U8 ch = *t++;
-	    hibit = !NATIVE_IS_INVARIANT(ch);
-	    if (hibit) {
-		s = bytes_to_utf8(s, &len);
-		break;
-	    }
+        hibit = ! is_utf8_invariant_string(s, len);
+        if (hibit) {
+            s = bytes_to_utf8(s, &len);
 	}
     }
     send = s + len;
@@ -361,7 +351,7 @@ S_do_trans_simple_utf8(pTHX_ SV * const sv)
 	if (uv < none) {
 	    s += UTF8SKIP(s);
 	    matches++;
-	    d = uvuni_to_utf8(d, uv);
+	    d = uvchr_to_utf8(d, uv);
 	}
 	else if (uv == none) {
 	    const int i = UTF8SKIP(s);
@@ -372,7 +362,7 @@ S_do_trans_simple_utf8(pTHX_ SV * const sv)
 	else if (uv == extra) {
 	    s += UTF8SKIP(s);
 	    matches++;
-	    d = uvuni_to_utf8(d, final);
+	    d = uvchr_to_utf8(d, final);
 	}
 	else
 	    s += UTF8SKIP(s);
@@ -406,7 +396,6 @@ S_do_trans_simple_utf8(pTHX_ SV * const sv)
 STATIC I32
 S_do_trans_count_utf8(pTHX_ SV * const sv)
 {
-    dVAR;
     const U8 *s;
     const U8 *start = NULL;
     const U8 *send;
@@ -428,15 +417,9 @@ S_do_trans_count_utf8(pTHX_ SV * const sv)
 
     s = (const U8*)SvPV_nomg_const(sv, len);
     if (!SvUTF8(sv)) {
-	const U8 *t = s;
-	const U8 * const e = s + len;
-	while (t < e) {
-	    const U8 ch = *t++;
-	    hibit = !NATIVE_IS_INVARIANT(ch);
-	    if (hibit) {
-		start = s = bytes_to_utf8(s, &len);
-		break;
-	    }
+        hibit = ! is_utf8_invariant_string(s, len);
+        if (hibit) {
+            start = s = bytes_to_utf8(s, &len);
 	}
     }
     send = s + len;
@@ -456,7 +439,6 @@ S_do_trans_count_utf8(pTHX_ SV * const sv)
 STATIC I32
 S_do_trans_complex_utf8(pTHX_ SV * const sv)
 {
-    dVAR;
     U8 *start, *send;
     U8 *d;
     I32 matches = 0;
@@ -483,15 +465,9 @@ S_do_trans_complex_utf8(pTHX_ SV * const sv)
     PERL_ARGS_ASSERT_DO_TRANS_COMPLEX_UTF8;
 
     if (!SvUTF8(sv)) {
-	const U8 *t = s;
-	const U8 * const e = s + len;
-	while (t < e) {
-	    const U8 ch = *t++;
-	    hibit = !NATIVE_IS_INVARIANT(ch);
-	    if (hibit) {
-		s = bytes_to_utf8(s, &len);
-		break;
-	    }
+        hibit = ! is_utf8_invariant_string(s, len);
+        if (hibit) {
+            s = bytes_to_utf8(s, &len);
 	}
     }
     send = s + len;
@@ -532,7 +508,7 @@ S_do_trans_complex_utf8(pTHX_ SV * const sv)
 		matches++;
 		s += UTF8SKIP(s);
 		if (uv != puv) {
-		    d = uvuni_to_utf8(d, uv);
+		    d = uvchr_to_utf8(d, uv);
 		    puv = uv;
 		}
 		continue;
@@ -550,13 +526,13 @@ S_do_trans_complex_utf8(pTHX_ SV * const sv)
 		if (havefinal) {
 		    s += UTF8SKIP(s);
 		    if (puv != final) {
-			d = uvuni_to_utf8(d, final);
+			d = uvchr_to_utf8(d, final);
 			puv = final;
 		    }
 		}
 		else {
 		    STRLEN len;
-		    uv = utf8n_to_uvuni(s, send - s, &len, UTF8_ALLOW_DEFAULT);
+		    uv = utf8n_to_uvchr(s, send - s, &len, UTF8_ALLOW_DEFAULT);
 		    if (uv != puv) {
 			Move(s, d, len, U8);
 			d += len;
@@ -585,7 +561,7 @@ S_do_trans_complex_utf8(pTHX_ SV * const sv)
 	    if (uv < none) {
 		matches++;
 		s += UTF8SKIP(s);
-		d = uvuni_to_utf8(d, uv);
+		d = uvchr_to_utf8(d, uv);
 		continue;
 	    }
 	    else if (uv == none) {	/* "none" is unmapped character */
@@ -598,7 +574,7 @@ S_do_trans_complex_utf8(pTHX_ SV * const sv)
 	    else if (uv == extra && !del) {
 		matches++;
 		s += UTF8SKIP(s);
-		d = uvuni_to_utf8(d, final);
+		d = uvchr_to_utf8(d, final);
 		continue;
 	    }
 	    matches++;			/* "none+1" is delete character */
@@ -624,68 +600,49 @@ S_do_trans_complex_utf8(pTHX_ SV * const sv)
 I32
 Perl_do_trans(pTHX_ SV *sv)
 {
-    dVAR;
     STRLEN len;
-    const I32 hasutf = (PL_op->op_private &
-                    (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF));
+    const I32 flags = PL_op->op_private;
+    const I32 hasutf = flags & (OPpTRANS_FROM_UTF | OPpTRANS_TO_UTF);
 
     PERL_ARGS_ASSERT_DO_TRANS;
 
-    if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL)) {
-        if (SvIsCOW(sv))
-            sv_force_normal_flags(sv, 0);
-        if (SvREADONLY(sv))
-            Perl_croak_no_modify(aTHX);
+    if (SvREADONLY(sv) && !(flags & OPpTRANS_IDENTICAL)) {
+        Perl_croak_no_modify();
     }
     (void)SvPV_const(sv, len);
     if (!len)
 	return 0;
-    if (!(PL_op->op_private & OPpTRANS_IDENTICAL)) {
-	if (!SvPOKp(sv))
+    if (!(flags & OPpTRANS_IDENTICAL)) {
+	if (!SvPOKp(sv) || SvTHINKFIRST(sv))
 	    (void)SvPV_force_nomg(sv, len);
 	(void)SvPOK_only_UTF8(sv);
     }
 
     DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));
 
-    switch (PL_op->op_private & ~hasutf & (
-		OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL|
-		OPpTRANS_SQUASH|OPpTRANS_DELETE|OPpTRANS_COMPLEMENT)) {
-    case 0:
-	if (hasutf)
-	    return do_trans_simple_utf8(sv);
-	else
-	    return do_trans_simple(sv);
-
-    case OPpTRANS_IDENTICAL:
-    case OPpTRANS_IDENTICAL|OPpTRANS_COMPLEMENT:
-	if (hasutf)
-	    return do_trans_count_utf8(sv);
-	else
-	    return do_trans_count(sv);
-
-    default:
-	if (hasutf)
-	    return do_trans_complex_utf8(sv);
-	else
-	    return do_trans_complex(sv);
+    /* If we use only OPpTRANS_IDENTICAL to bypass the READONLY check,
+     * we must also rely on it to choose the readonly strategy.
+     */
+    if (flags & OPpTRANS_IDENTICAL) {
+        return hasutf ? do_trans_count_utf8(sv) : do_trans_count(sv);
+    } else if (flags & (OPpTRANS_SQUASH|OPpTRANS_DELETE|OPpTRANS_COMPLEMENT)) {
+        return hasutf ? do_trans_complex_utf8(sv) : do_trans_complex(sv);
+    } else {
+        return hasutf ? do_trans_simple_utf8(sv) : do_trans_simple(sv);
     }
 }
 
 void
-Perl_do_join(pTHX_ register SV *sv, SV *delim, register SV **mark, register SV **sp)
+Perl_do_join(pTHX_ SV *sv, SV *delim, SV **mark, SV **sp)
 {
-    dVAR;
     SV ** const oldmark = mark;
-    register I32 items = sp - mark;
-    register STRLEN len;
+    I32 items = sp - mark;
+    STRLEN len;
     STRLEN delimlen;
+    const char * const delims = SvPV_const(delim, delimlen);
 
     PERL_ARGS_ASSERT_DO_JOIN;
 
-    (void) SvPV_const(delim, delimlen); /* stringify and get the delimlen */
-    /* SvCUR assumes it's SvPOK() and woe betide you if it's not. */
-
     mark++;
     len = (items > 0 ? (delimlen * (items - 1) ) : 0);
     SvUPGRADE(sv, SVt_PV);
@@ -705,11 +662,11 @@ Perl_do_join(pTHX_ register SV *sv, SV *delim, register SV **mark, register SV *
 	++mark;
     }
 
-    sv_setpvs(sv, "");
+    SvPVCLEAR(sv);
     /* sv_setpv retains old UTF8ness [perl #24846] */
     SvUTF8_off(sv);
 
-    if (PL_tainting && SvMAGICAL(sv))
+    if (TAINTING_get && SvMAGICAL(sv))
 	SvTAINTED_off(sv);
 
     if (items-- > 0) {
@@ -719,27 +676,37 @@ Perl_do_join(pTHX_ register SV *sv, SV *delim, register SV **mark, register SV *
     }
 
     if (delimlen) {
+	const U32 delimflag = DO_UTF8(delim) ? SV_CATUTF8 : SV_CATBYTES;
 	for (; items > 0; items--,mark++) {
-	    sv_catsv(sv,delim);
-	    sv_catsv(sv,*mark);
+	    STRLEN len;
+	    const char *s;
+	    sv_catpvn_flags(sv,delims,delimlen,delimflag);
+	    s = SvPV_const(*mark,len);
+	    sv_catpvn_flags(sv,s,len,
+			    DO_UTF8(*mark) ? SV_CATUTF8 : SV_CATBYTES);
 	}
     }
     else {
 	for (; items > 0; items--,mark++)
-	    sv_catsv(sv,*mark);
+	{
+	    STRLEN len;
+	    const char *s = SvPV_const(*mark,len);
+	    sv_catpvn_flags(sv,s,len,
+			    DO_UTF8(*mark) ? SV_CATUTF8 : SV_CATBYTES);
+	}
     }
     SvSETMAGIC(sv);
 }
 
 void
-Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
+Perl_do_sprintf(pTHX_ SV *sv, SSize_t len, SV **sarg)
 {
-    dVAR;
     STRLEN patlen;
     const char * const pat = SvPV_const(*sarg, patlen);
     bool do_taint = FALSE;
 
     PERL_ARGS_ASSERT_DO_SPRINTF;
+    assert(len >= 1);
 
     if (SvTAINTED(*sarg))
 	TAINT_PROPER(
@@ -752,7 +719,7 @@ Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
     SvUTF8_off(sv);
     if (DO_UTF8(*sarg))
         SvUTF8_on(sv);
-    sv_vsetpvfn(sv, pat, patlen, NULL, sarg + 1, len - 1, &do_taint);
+    sv_vsetpvfn(sv, pat, patlen, NULL, sarg + 1, (Size_t)(len - 1), &do_taint);
     SvSETMAGIC(sv);
     if (do_taint)
 	SvTAINTED_on(sv);
@@ -760,50 +727,72 @@ Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
 
 /* currently converts input to bytes if possible, but doesn't sweat failure */
 UV
-Perl_do_vecget(pTHX_ SV *sv, SSize_t offset, int size)
+Perl_do_vecget(pTHX_ SV *sv, STRLEN offset, int size)
 {
-    dVAR;
-    STRLEN srclen, len, uoffset, bitoffs = 0;
-    const unsigned char *s = (const unsigned char *) SvPV_const(sv, srclen);
+    STRLEN srclen, len, avail, uoffset, bitoffs = 0;
+    const I32 svpv_flags = ((PL_op->op_flags & OPf_MOD || LVRET)
+                                          ? SV_UNDEF_RETURNS_NULL : 0);
+    unsigned char *s = (unsigned char *)
+                            SvPV_flags(sv, srclen, (svpv_flags|SV_GMAGIC));
     UV retnum = 0;
 
+    if (!s) {
+      s = (unsigned char *)"";
+    }
+    
     PERL_ARGS_ASSERT_DO_VECGET;
 
-    if (offset < 0)
-	return 0;
     if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
 	Perl_croak(aTHX_ "Illegal number of bits in vec");
 
-    if (SvUTF8(sv))
-	(void) Perl_sv_utf8_downgrade(aTHX_ sv, TRUE);
+    if (SvUTF8(sv)) {
+	if (Perl_sv_utf8_downgrade(aTHX_ sv, TRUE)) {
+            /* PVX may have changed */
+            s = (unsigned char *) SvPV_flags(sv, srclen, svpv_flags);
+        }
+        else {
+            Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+                                "Use of strings with code points over 0xFF as"
+                                " arguments to vec is deprecated. This will"
+                                " be a fatal error in Perl 5.32");
+        }
+    }
 
     if (size < 8) {
 	bitoffs = ((offset%8)*size)%8;
 	uoffset = offset/(8/size);
     }
-    else if (size > 8)
-	uoffset = offset*(size/8);
+    else if (size > 8) {
+	int n = size/8;
+        if (offset > Size_t_MAX / n - 1) /* would overflow */
+            return 0;
+	uoffset = offset*n;
+    }
     else
 	uoffset = offset;
 
-    len = uoffset + (bitoffs + size + 7)/8;	/* required number of bytes */
-    if (len > srclen) {
+    if (uoffset >= srclen)
+        return 0;
+
+    len   = (bitoffs + size + 7)/8; /* required number of bytes */
+    avail = srclen - uoffset;       /* available number of bytes */
+
+    /* Does the byte range overlap the end of the string? If so,
+     * handle specially. */
+    if (avail < len) {
 	if (size <= 8)
 	    retnum = 0;
 	else {
 	    if (size == 16) {
-		if (uoffset >= srclen)
-		    retnum = 0;
-		else
-		    retnum = (UV) s[uoffset] <<  8;
+                assert(avail == 1);
+                retnum = (UV) s[uoffset] <<  8;
 	    }
 	    else if (size == 32) {
-		if (uoffset >= srclen)
-		    retnum = 0;
-		else if (uoffset + 1 >= srclen)
+                assert(avail >= 1 && avail <= 3);
+		if (avail == 1)
 		    retnum =
 			((UV) s[uoffset    ] << 24);
-		else if (uoffset + 2 >= srclen)
+		else if (avail == 2)
 		    retnum =
 			((UV) s[uoffset    ] << 24) +
 			((UV) s[uoffset + 1] << 16);
@@ -817,34 +806,33 @@ Perl_do_vecget(pTHX_ SV *sv, SSize_t offset, int size)
 	    else if (size == 64) {
 		Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
 			       "Bit vector size > 32 non-portable");
-		if (uoffset >= srclen)
-		    retnum = 0;
-		else if (uoffset + 1 >= srclen)
+                assert(avail >= 1 && avail <= 7);
+		if (avail == 1)
 		    retnum =
 			(UV) s[uoffset     ] << 56;
-		else if (uoffset + 2 >= srclen)
+		else if (avail == 2)
 		    retnum =
 			((UV) s[uoffset    ] << 56) +
 			((UV) s[uoffset + 1] << 48);
-		else if (uoffset + 3 >= srclen)
+		else if (avail == 3)
 		    retnum =
 			((UV) s[uoffset    ] << 56) +
 			((UV) s[uoffset + 1] << 48) +
 			((UV) s[uoffset + 2] << 40);
-		else if (uoffset + 4 >= srclen)
+		else if (avail == 4)
 		    retnum =
 			((UV) s[uoffset    ] << 56) +
 			((UV) s[uoffset + 1] << 48) +
 			((UV) s[uoffset + 2] << 40) +
 			((UV) s[uoffset + 3] << 32);
-		else if (uoffset + 5 >= srclen)
+		else if (avail == 5)
 		    retnum =
 			((UV) s[uoffset    ] << 56) +
 			((UV) s[uoffset + 1] << 48) +
 			((UV) s[uoffset + 2] << 40) +
 			((UV) s[uoffset + 3] << 32) +
-			(     s[uoffset + 4] << 24);
-		else if (uoffset + 6 >= srclen)
+			((UV) s[uoffset + 4] << 24);
+		else if (avail == 6)
 		    retnum =
 			((UV) s[uoffset    ] << 56) +
 			((UV) s[uoffset + 1] << 48) +
@@ -860,7 +848,7 @@ Perl_do_vecget(pTHX_ SV *sv, SSize_t offset, int size)
 			((UV) s[uoffset + 3] << 32) +
 			((UV) s[uoffset + 4] << 24) +
 			((UV) s[uoffset + 5] << 16) +
-			(     s[uoffset + 6] <<  8);
+			((UV) s[uoffset + 6] <<  8);
 	    }
 #endif
 	}
@@ -907,21 +895,31 @@ Perl_do_vecget(pTHX_ SV *sv, SSize_t offset, int size)
 void
 Perl_do_vecset(pTHX_ SV *sv)
 {
-    dVAR;
-    register SSize_t offset, bitoffs = 0;
-    register int size;
-    register unsigned char *s;
-    register UV lval;
+    STRLEN offset, bitoffs = 0;
+    int size;
+    unsigned char *s;
+    UV lval;
     I32 mask;
     STRLEN targlen;
     STRLEN len;
     SV * const targ = LvTARG(sv);
+    char errflags = LvFLAGS(sv);
 
     PERL_ARGS_ASSERT_DO_VECSET;
 
+    /* some out-of-range errors have been deferred if/until the LV is
+     * actually written to: f(vec($s,-1,8)) is not always fatal */
+    if (errflags) {
+        assert(!(errflags & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE)));
+        if (errflags & LVf_NEG_OFF)
+            Perl_croak_nocontext("Negative offset to vec in lvalue context");
+        Perl_croak_nocontext("Out of memory!");
+    }
+
     if (!targ)
 	return;
-    s = (unsigned char*)SvPV_force(targ, targlen);
+    s = (unsigned char*)SvPV_force_flags(targ, targlen,
+                                         SV_GMAGIC | SV_UNDEF_RETURNS_NULL);
     if (SvUTF8(targ)) {
 	/* This is handled by the SvPOK_only below...
 	if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE))
@@ -933,9 +931,8 @@ Perl_do_vecset(pTHX_ SV *sv)
     (void)SvPOK_only(targ);
     lval = SvUV(sv);
     offset = LvTARGOFF(sv);
-    if (offset < 0)
-	Perl_croak(aTHX_ "Negative offset to vec in lvalue context");
     size = LvTARGLEN(sv);
+
     if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
 	Perl_croak(aTHX_ "Illegal number of bits in vec");
 
@@ -943,14 +940,20 @@ Perl_do_vecset(pTHX_ SV *sv)
 	bitoffs = ((offset%8)*size)%8;
 	offset /= 8/size;
     }
-    else if (size > 8)
-	offset *= size/8;
-
-    len = offset + (bitoffs + size + 7)/8;	/* required number of bytes */
-    if (len > targlen) {
-	s = (unsigned char*)SvGROW(targ, len + 1);
-	(void)memzero((char *)(s + targlen), len - targlen + 1);
-	SvCUR_set(targ, len);
+    else if (size > 8) {
+	int n = size/8;
+        if (offset > Size_t_MAX / n - 1) /* would overflow */
+            Perl_croak_nocontext("Out of memory!");
+	offset *= n;
+    }
+
+    len = (bitoffs + size + 7)/8;	/* required number of bytes */
+    if (targlen < offset || targlen - offset < len) {
+        STRLEN newlen = offset > Size_t_MAX - len - 1 ? /* avoid overflow */
+                                        Size_t_MAX : offset + len + 1;
+	s = (unsigned char*)SvGROW(targ, newlen);
+	(void)memzero((char *)(s + targlen), newlen - targlen);
+	SvCUR_set(targ, newlen - 1);
     }
 
     if (size < 8) {
@@ -993,76 +996,121 @@ Perl_do_vecset(pTHX_ SV *sv)
 void
 Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
 {
-    dVAR;
 #ifdef LIBERAL
-    register long *dl;
-    register long *ll;
-    register long *rl;
+    long *dl;
+    long *ll;
+    long *rl;
 #endif
-    register char *dc;
+    char *dc;
     STRLEN leftlen;
     STRLEN rightlen;
-    register const char *lc;
-    register const char *rc;
-    register STRLEN len;
+    const char *lc;
+    const char *rc;
+    STRLEN len;
     STRLEN lensave;
     const char *lsave;
     const char *rsave;
-    bool left_utf;
-    bool right_utf;
     STRLEN needlen = 0;
+    bool result_needs_to_be_utf8 = FALSE;
+    bool left_utf8 = FALSE;
+    bool right_utf8 = FALSE;
+    U8 * left_non_downgraded = NULL;
+    U8 * right_non_downgraded = NULL;
+    Size_t left_non_downgraded_len = 0;
+    Size_t right_non_downgraded_len = 0;
+    char * non_downgraded = NULL;
+    Size_t non_downgraded_len = 0;
 
     PERL_ARGS_ASSERT_DO_VOP;
 
     if (sv != left || (optype != OP_BIT_AND && !SvOK(sv)))
-	sv_setpvs(sv, "");	/* avoid undef warning on |= and ^= */
+        SvPVCLEAR(sv);        /* avoid undef warning on |= and ^= */
     if (sv == left) {
-	lsave = lc = SvPV_force_nomg(left, leftlen);
+	lc = SvPV_force_nomg(left, leftlen);
     }
     else {
-	lsave = lc = SvPV_nomg_const(left, leftlen);
+	lc = SvPV_nomg_const(left, leftlen);
 	SvPV_force_nomg_nolen(sv);
     }
-    rsave = rc = SvPV_nomg_const(right, rightlen);
+    rc = SvPV_nomg_const(right, rightlen);
 
-    /* This need to come after SvPV to ensure that string overloading has
+    /* This needs to come after SvPV to ensure that string overloading has
        fired off.  */
 
-    left_utf = DO_UTF8(left);
-    right_utf = DO_UTF8(right);
-
-    if (left_utf && !right_utf) {
-	/* Avoid triggering overloading again by using temporaries.
-	   Maybe there should be a variant of sv_utf8_upgrade that takes pvn
-	*/
-	right = newSVpvn_flags(rsave, rightlen, SVs_TEMP);
-	sv_utf8_upgrade(right);
-	rsave = rc = SvPV_nomg_const(right, rightlen);
-	right_utf = TRUE;
+    /* Create downgraded temporaries of any UTF-8 encoded operands */
+    if (DO_UTF8(left)) {
+        const U8 * save_lc = (U8 *) lc;
+
+        left_utf8 = TRUE;
+        result_needs_to_be_utf8 = TRUE;
+
+        left_non_downgraded_len = leftlen;
+        lc = (char *) bytes_from_utf8_loc((const U8 *) lc, &leftlen,
+                                          &left_utf8,
+                                          (const U8 **) &left_non_downgraded);
+        /* Calculate the number of trailing unconvertible bytes.  This quantity
+         * is the original length minus the length of the converted portion. */
+        left_non_downgraded_len -= left_non_downgraded - save_lc;
+        SAVEFREEPV(lc);
     }
-    else if (!left_utf && right_utf) {
-	left = newSVpvn_flags(lsave, leftlen, SVs_TEMP);
-	sv_utf8_upgrade(left);
-	lsave = lc = SvPV_nomg_const(left, leftlen);
-	left_utf = TRUE;
+    if (DO_UTF8(right)) {
+        const U8 * save_rc = (U8 *) rc;
+
+        right_utf8 = TRUE;
+        result_needs_to_be_utf8 = TRUE;
+
+        right_non_downgraded_len = rightlen;
+        rc = (char *) bytes_from_utf8_loc((const U8 *) rc, &rightlen,
+                                          &right_utf8,
+                                          (const U8 **) &right_non_downgraded);
+        right_non_downgraded_len -= right_non_downgraded - save_rc;
+        SAVEFREEPV(rc);
+    }
+
+    /* We set 'len' to the length that the operation actually operates on.  The
+     * dangling part of the longer operand doesn't actually participate in the
+     * operation.  What happens is that we pretend that the shorter operand has
+     * been extended to the right by enough imaginary zeros to match the length
+     * of the longer one.  But we know in advance the result of the operation
+     * on zeros without having to do it.  In the case of '&', the result is
+     * zero, and the dangling portion is simply discarded.  For '|' and '^', the
+     * result is the same as the other operand, so the dangling part is just
+     * appended to the final result, unchanged.  We currently accept above-FF
+     * code points in the dangling portion, as that's how it has long worked,
+     * and code depends on it staying that way.  But it is now fatal for
+     * above-FF to appear in the portion that does get operated on.  Hence, any
+     * above-FF must come only in the longer operand, and only in its dangling
+     * portion.  That means that at least one of the operands has to be
+     * entirely non-UTF-8, and the length of that operand has to be before the
+     * first above-FF in the other */
+    if (left_utf8) {
+        if (right_utf8 || rightlen > leftlen) {
+            Perl_croak(aTHX_ fatal_above_ff_msg, PL_op_desc[optype]);
+        }
+        len = rightlen;
+    }
+    else if (right_utf8) {
+        if (leftlen > rightlen) {
+            Perl_croak(aTHX_ fatal_above_ff_msg, PL_op_desc[optype]);
+        }
+        len = leftlen;
+    }
+    else {  /* Neither is UTF-8 */
+        len = leftlen < rightlen ? leftlen : rightlen;
     }
 
-    len = leftlen < rightlen ? leftlen : rightlen;
     lensave = len;
+    lsave = lc;
+    rsave = rc;
+
     SvCUR_set(sv, len);
     (void)SvPOK_only(sv);
-    if ((left_utf || right_utf) && (sv == left || sv == right)) {
-	needlen = optype == OP_BIT_AND ? len : leftlen + rightlen;
-	Newxz(dc, needlen + 1, char);
-    }
-    else if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
+    if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
 	dc = SvPV_force_nomg_nolen(sv);
 	if (SvLEN(sv) < len + 1) {
 	    dc = SvGROW(sv, len + 1);
 	    (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
 	}
-	if (optype != OP_BIT_AND && (left_utf || right_utf))
-	    dc = SvGROW(sv, leftlen + rightlen + 1);
     }
     else {
 	needlen = optype == OP_BIT_AND
@@ -1071,79 +1119,7 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
 	sv_usepvn_flags(sv, dc, needlen, SV_HAS_TRAILING_NUL);
 	dc = SvPVX(sv);		/* sv_usepvn() calls Renew() */
     }
-    if (left_utf || right_utf) {
-	UV duc, luc, ruc;
-	char *dcorig = dc;
-	char *dcsave = NULL;
-	STRLEN lulen = leftlen;
-	STRLEN rulen = rightlen;
-	STRLEN ulen;
 
-	switch (optype) {
-	case OP_BIT_AND:
-	    while (lulen && rulen) {
-		luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
-		lc += ulen;
-		lulen -= ulen;
-		ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
-		rc += ulen;
-		rulen -= ulen;
-		duc = luc & ruc;
-		dc = (char*)uvchr_to_utf8((U8*)dc, duc);
-	    }
-	    if (sv == left || sv == right)
-		(void)sv_usepvn(sv, dcorig, needlen);
-	    SvCUR_set(sv, dc - dcorig);
-	    break;
-	case OP_BIT_XOR:
-	    while (lulen && rulen) {
-		luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
-		lc += ulen;
-		lulen -= ulen;
-		ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
-		rc += ulen;
-		rulen -= ulen;
-		duc = luc ^ ruc;
-		dc = (char*)uvchr_to_utf8((U8*)dc, duc);
-	    }
-	    goto mop_up_utf;
-	case OP_BIT_OR:
-	    while (lulen && rulen) {
-		luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
-		lc += ulen;
-		lulen -= ulen;
-		ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
-		rc += ulen;
-		rulen -= ulen;
-		duc = luc | ruc;
-		dc = (char*)uvchr_to_utf8((U8*)dc, duc);
-	    }
-	  mop_up_utf:
-	    if (rulen)
-		dcsave = savepvn(rc, rulen);
-	    else if (lulen)
-		dcsave = savepvn(lc, lulen);
-	    if (sv == left || sv == right)
-		(void)sv_usepvn(sv, dcorig, needlen); /* Uses Renew(). */
-	    SvCUR_set(sv, dc - dcorig);
-	    if (rulen)
-		sv_catpvn(sv, dcsave, rulen);
-	    else if (lulen)
-		sv_catpvn(sv, dcsave, lulen);
-	    else
-		*SvEND(sv) = '\0';
-	    Safefree(dcsave);
-	    break;
-	default:
-	    if (sv == left || sv == right)
-		Safefree(dcorig);
-	    Perl_croak(aTHX_ "panic: do_vop called for op %u (%s)",
-			(unsigned)optype, PL_op_name[optype]);
-	}
-	SvUTF8_on(sv);
-	goto finish;
-    }
-    else
 #ifdef LIBERAL
     if (len >= sizeof(long)*4 &&
 	!((unsigned long)dc % sizeof(long)) &&
@@ -1190,47 +1166,95 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
 	len = remainder;
     }
 #endif
-    {
-	switch (optype) {
-	case OP_BIT_AND:
-	    while (len--)
-		*dc++ = *lc++ & *rc++;
-	    *dc = '\0';
-	    break;
-	case OP_BIT_XOR:
-	    while (len--)
-		*dc++ = *lc++ ^ *rc++;
-	    goto mop_up;
-	case OP_BIT_OR:
-	    while (len--)
-		*dc++ = *lc++ | *rc++;
-	  mop_up:
-	    len = lensave;
-	    if (rightlen > len)
-		sv_catpvn(sv, rsave + len, rightlen - len);
-	    else if (leftlen > (STRLEN)len)
-		sv_catpvn(sv, lsave + len, leftlen - len);
-	    else
-		*SvEND(sv) = '\0';
-	    break;
-	}
+    switch (optype) {
+    case OP_BIT_AND:
+        while (len--)
+            *dc++ = *lc++ & *rc++;
+        *dc = '\0';
+        break;
+    case OP_BIT_XOR:
+        while (len--)
+            *dc++ = *lc++ ^ *rc++;
+        goto mop_up;
+    case OP_BIT_OR:
+        while (len--)
+            *dc++ = *lc++ | *rc++;
+      mop_up:
+        len = lensave;
+        if (rightlen > len) {
+            if (dc == rc)
+                SvCUR(sv) = rightlen;
+            else
+                sv_catpvn_nomg(sv, rsave + len, rightlen - len);
+        }
+        else if (leftlen > len) {
+            if (dc == lc)
+                SvCUR(sv) = leftlen;
+            else
+                sv_catpvn_nomg(sv, lsave + len, leftlen - len);
+        }
+        *SvEND(sv) = '\0';
+
+        /* If there is trailing stuff that couldn't be converted from UTF-8, it
+         * is appended as-is for the ^ and | operators.  This preserves
+         * backwards compatibility */
+        if (right_non_downgraded) {
+            non_downgraded = (char *) right_non_downgraded;
+            non_downgraded_len = right_non_downgraded_len;
+        }
+        else if (left_non_downgraded) {
+            non_downgraded = (char *) left_non_downgraded;
+            non_downgraded_len = left_non_downgraded_len;
+        }
+
+        break;
     }
-finish:
+
+    if (result_needs_to_be_utf8) {
+        sv_utf8_upgrade_nomg(sv);
+
+        /* Append any trailing UTF-8 as-is. */
+        if (non_downgraded) {
+            sv_catpvn_nomg(sv, non_downgraded, non_downgraded_len);
+        }
+    }
+
     SvTAINT(sv);
 }
 
+
+/* Perl_do_kv() may be:
+ *  * called directly as the pp function for pp_keys() and pp_values();
+ *  * It may also be called directly when the op is OP_AVHVSWITCH, to
+ *       implement CORE::keys(), CORE::values().
+ *
+ * In all cases it expects an HV on the stack and returns a list of keys,
+ * values, or key-value pairs, depending on PL_op.
+ */
+
 OP *
 Perl_do_kv(pTHX)
 {
-    dVAR;
     dSP;
     HV * const keys = MUTABLE_HV(POPs);
-    register HE *entry;
-    const I32 gimme = GIMME_V;
-    const I32 dokv =     (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV);
-    /* op_type is OP_RKEYS/OP_RVALUES if pp_rkeys delegated to here */
-    const I32 dokeys =   dokv || (PL_op->op_type == OP_KEYS || PL_op->op_type == OP_RKEYS);
-    const I32 dovalues = dokv || (PL_op->op_type == OP_VALUES || PL_op->op_type == OP_RVALUES);
+    const U8 gimme = GIMME_V;
+
+    const I32 dokeys   =     (PL_op->op_type == OP_KEYS)
+                          || (    PL_op->op_type == OP_AVHVSWITCH
+                              && (PL_op->op_private & OPpAVHVSWITCH_MASK)
+                                    + OP_EACH == OP_KEYS);
+
+    const I32 dovalues =     (PL_op->op_type == OP_VALUES)
+                          || (    PL_op->op_type == OP_AVHVSWITCH
+                              && (PL_op->op_private & OPpAVHVSWITCH_MASK)
+                                     + OP_EACH == OP_VALUES);
+
+    assert(   PL_op->op_type == OP_KEYS
+           || PL_op->op_type == OP_VALUES
+           || PL_op->op_type == OP_AVHVSWITCH);
+
+    assert(!(    PL_op->op_type == OP_VALUES
+             && (PL_op->op_private & OPpMAYBE_LVSUB)));
 
     (void)hv_iterinit(keys);	/* always reset iterator regardless */
 
@@ -1249,6 +1273,11 @@ Perl_do_kv(pTHX)
 	    IV i;
 	    dTARGET;
 
+            /* note that in 'scalar(keys %h)' the OP_KEYS is usually
+             * optimised away and the action is performed directly by the
+             * padhv or rv2hv op. We now only get here via OP_AVHVSWITCH
+             * and \&CORE::keys
+             */
 	    if (! SvTIED_mg((const SV *)keys, PERL_MAGIC_tied) ) {
 		i = HvUSEDKEYS(keys);
 	    }
@@ -1261,37 +1290,18 @@ Perl_do_kv(pTHX)
 	RETURN;
     }
 
-    EXTEND(SP, HvUSEDKEYS(keys) * (dokeys + dovalues));
-
-    PUTBACK;	/* hv_iternext and hv_iterval might clobber stack_sp */
-    while ((entry = hv_iternext(keys))) {
-	SPAGAIN;
-	if (dokeys) {
-	    SV* const sv = hv_iterkeysv(entry);
-	    XPUSHs(sv);	/* won't clobber stack_sp */
-	}
-	if (dovalues) {
-	    SV *tmpstr;
-	    PUTBACK;
-	    tmpstr = hv_iterval(keys,entry);
-	    DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu",
-			    (unsigned long)HeHASH(entry),
-			    (int)HvMAX(keys)+1,
-			    (unsigned long)(HeHASH(entry) & HvMAX(keys))));
-	    SPAGAIN;
-	    XPUSHs(tmpstr);
-	}
-	PUTBACK;
+    if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
+	const I32 flags = is_lvalue_sub();
+	if (flags && !(flags & OPpENTERSUB_INARGS))
+	    /* diag_listed_as: Can't modify %s in %s */
+	    Perl_croak(aTHX_ "Can't modify keys in list assignment");
     }
+
+    PUTBACK;
+    hv_pushkv(keys, (dokeys | (dovalues << 1)));
     return NORMAL;
 }
 
 /*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: t
- * End:
- *
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
  */