X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/08b6664b858b8fd4b5c0c27542763337b6d78e46..354810ee5b030780b7036ad80d5adf09f6dcb317:/doop.c?ds=sidebyside

diff --git a/doop.c b/doop.c
index dc6956c..2294281 100644
--- a/doop.c
+++ b/doop.c
@@ -323,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_BYTE_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;
@@ -423,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_BYTE_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;
@@ -477,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_BYTE_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;
@@ -1030,6 +1012,14 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
     const char *rsave;
     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;
 
@@ -1049,32 +1039,70 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
 
     /* Create downgraded temporaries of any UTF-8 encoded operands */
     if (DO_UTF8(left)) {
-        bool utf8 = TRUE;
+        const U8 * save_lc = (U8 *) lc;
 
+        left_utf8 = TRUE;
         result_needs_to_be_utf8 = TRUE;
 
-        lc = (char *) bytes_from_utf8((const U8 *) lc, &leftlen, &utf8);
-        if (utf8) {
-            Perl_croak(aTHX_ fatal_above_ff_msg, PL_op_desc[optype]);
-        }
-	SAVEFREEPV(lc);
+        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);
     }
     if (DO_UTF8(right)) {
-        bool utf8 = TRUE;
+        const U8 * save_rc = (U8 *) rc;
 
+        right_utf8 = TRUE;
         result_needs_to_be_utf8 = TRUE;
 
-        rc = (char *) bytes_from_utf8((const U8 *) rc, &rightlen, &utf8);
-        if (utf8) {
+        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]);
         }
-	SAVEFREEPV(rc);
+        len = leftlen;
+    }
+    else {  /* Neither is UTF-8 */
+        len = leftlen < rightlen ? leftlen : rightlen;
     }
 
+    lensave = len;
     lsave = lc;
     rsave = rc;
-    len = leftlen < rightlen ? leftlen : rightlen;
-    lensave = len;
+
     SvCUR_set(sv, len);
     (void)SvPOK_only(sv);
     if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
@@ -1138,64 +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) {
-                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';
+    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;
-	}
+        break;
+    }
 
     if (result_needs_to_be_utf8) {
-	sv_utf8_upgrade_nomg(sv);
+        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);
 }
 
 
-/* used for: pp_keys(), pp_values() */
+/* 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)
 {
     dSP;
     HV * const keys = MUTABLE_HV(POPs);
-    HE *entry;
-    SSize_t extend_size;
     const U8 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_AVHVSWITCH
-	   && (PL_op->op_private & 3) + OP_EACH == OP_KEYS  );
-    const I32 dovalues = dokv || (PL_op->op_type == OP_VALUES)
-	|| (  PL_op->op_type == OP_AVHVSWITCH
-	   && (PL_op->op_private & 3) + OP_EACH == OP_VALUES  );
+
+    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 */
 
@@ -1214,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);
 	    }
@@ -1233,22 +1297,9 @@ Perl_do_kv(pTHX)
 	    Perl_croak(aTHX_ "Can't modify keys in list assignment");
     }
 
-    /* 2*HvUSEDKEYS() should never be big enough to truncate or wrap */
-    assert(HvUSEDKEYS(keys) <= (SSize_t_MAX >> 1));
-    extend_size = (SSize_t)HvUSEDKEYS(keys) * (dokeys + dovalues);
-    EXTEND(SP, extend_size);
-
-    while ((entry = hv_iternext(keys))) {
-	if (dokeys) {
-	    SV* const sv = hv_iterkeysv(entry);
-	    XPUSHs(sv);
-	}
-	if (dovalues) {
-	    SV *const sv = hv_iterval(keys,entry);
-	    XPUSHs(sv);
-	}
-    }
-    RETURN;
+    PUTBACK;
+    hv_pushkv(keys, (dokeys | (dovalues << 1)));
+    return NORMAL;
 }
 
 /*