do_vop() couldn't correctly handle surprises from UTF-8 overloading.

p4raw-id: //depot/perl@28029

diff --git a/doop.c b/doop.c
index 45437e1..6ff58c5 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -1173,19 +1173,38 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
     STRLEN lensave;
     const char *lsave;
     const char *rsave;
-    const bool left_utf = DO_UTF8(left);
-    const bool right_utf = DO_UTF8(right);
+    bool left_utf;
+    bool right_utf;
     STRLEN needlen = 0;
 
-    if (left_utf && !right_utf)
-       sv_utf8_upgrade(right);
-    else if (!left_utf && right_utf)
-       sv_utf8_upgrade(left);
 
     if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
        sv_setpvn(sv, "", 0);   /* avoid undef warning on |= and ^= */
     lsave = lc = SvPV_nomg_const(left, leftlen);
     rsave = rc = SvPV_nomg_const(right, rightlen);
+
+    /* This need 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 = sv_2mortal(newSVpvn(rsave, rightlen));
+       sv_utf8_upgrade(right);
+       rsave = rc = SvPV_nomg_const(right, rightlen);
+       right_utf = TRUE;
+    }
+    else if (!left_utf && right_utf) {
+       left = sv_2mortal(newSVpvn(lsave, leftlen));
+       sv_utf8_upgrade(left);
+       lsave = lc = SvPV_nomg_const(left, leftlen);
+       left_utf = TRUE;
+    }
+
     len = leftlen < rightlen ? leftlen : rightlen;
     lensave = len;
     SvCUR_set(sv, len);

diff --git a/t/uni/overload.t b/t/uni/overload.t
index ef61667..ca63b44 100644 (file)
--- a/t/uni/overload.t
+++ b/t/uni/overload.t
@@ -7,12 +7,12 @@ BEGIN {
     }
 }
 
-use Test::More tests => 190;
+use Test::More tests => 202;
 
 package UTF8Toggle;
 use strict;
 
-use overload '""' => 'stringify';
+use overload '""' => 'stringify', fallback => 1;
 
 sub new {
     my $class = shift;
@@ -243,6 +243,17 @@ foreach my $b ($big, UTF8Toggle->new($big)) {
     }
 }
 
+my $bits = "\311";
+foreach my $pieces ($bits, UTF8Toggle->new($bits)) {
+    like ($bits ^ $pieces, qr/\A\0+\z/, "something xor itself is zeros");
+    like ($bits ^ $pieces, qr/\A\0+\z/, "something xor itself is zeros");
+    like ($bits ^ $pieces, qr/\A\0+\z/, "something xor itself is zeros");
+
+    like ($pieces ^ $bits, qr/\A\0+\z/, "something xor itself is zeros");
+    like ($pieces ^ $bits, qr/\A\0+\z/, "something xor itself is zeros");
+    like ($pieces ^ $bits, qr/\A\0+\z/, "something xor itself is zeros");
+}
+
 END {
     1 while -f $tmpfile and unlink $tmpfile || die "unlink '$tmpfile': $!";
 }