Implement assigning xor (^^=) operator

lib/B/Deparse.pm

@@ -7,7 +7,7 @@
 # This is based on the module of the same name by Malcolm Beattie,
 # but essentially none of his code remains.
 
-package B::Deparse 1.84;
+package B::Deparse 1.85;
 use strict;
 use Carp;
 use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
@@ -3318,9 +3318,16 @@ sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
 sub pp_or  { logop(@_, "or",  2, "||", 10, "unless") }
 sub pp_dor { logop(@_, "//", 10) }
 
-# xor is syntactically a logop, but it's really a binop (contrary to
-# old versions of opcode.pl). Syntax is what matters here.
-sub pp_xor { logop(@_, "xor", 2, "^^", 10, "") }
+sub pp_xor {
+    my $self = shift;
+    my ($op, $cx) = @_;
+    if ($cx > 2 or $op->flags & OPf_STACKED) {
+        binop($self, @_, "^^", 10, ASSIGN);
+    }
+    else {
+        binop($self, @_, "xor", 2);
+    }
+}
 
 sub logassignop {
     my $self = shift;

lib/B/Deparse.t

@@ -3450,3 +3450,8 @@ $_ = (!$p) isa 'Some::Class';
 $_ = (!$p) =~ tr/1//;
 $_ = (!$p) =~ /1/;
 $_ = (!$p) =~ s/1//r;
+####
+# xor operator
+my($x, $y, $z);
+$z = 1 + ($x ^^ $y);
+$z = ($x ^^= $y);

op.c

@@ -3230,6 +3230,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
     case OP_I_MODULO:
     case OP_I_ADD:
     case OP_I_SUBTRACT:
+    case OP_XOR:
         if (!(o->op_flags & OPf_STACKED))
             goto nomod;
         PL_modcount++;

pod/perldelta.pod

@@ -27,6 +27,12 @@ here, but most should go in the L</Performance Enhancements> section.
 
 [ List each enhancement as a =head2 entry ]
 
+=head2 Assigning logical xor C<^^=> operator
+
+Perl 5.40.0 introduced the logical medium-precedence exclusive-or operator
+C<^^>.  It was not noticed at the time that the assigning variant C<^^=> was
+also missing.  This is now added.
+
 =head1 Security
 
 XXX Any security-related notices go here. In particular, any security

pod/perlop.pod

@@ -1341,7 +1341,7 @@ That should probably be written more simply as:
 =head2 Assignment Operators
 X<assignment> X<operator, assignment> X<=> X<**=> X<+=> X<*=> X<&=>
 X<<< <<= >>> X<&&=> X<-=> X</=> X<|=> X<<< >>= >>> X<||=> X<//=> X<.=>
-X<%=> X<^=> X<x=> X<&.=> X<|.=> X<^.=>
+X<%=> X<^=> X<x=> X<&.=> X<|.=> X<^.=> X<^^=>
 
 C<"="> is the ordinary assignment operator.
 
@@ -1360,7 +1360,7 @@ The following are recognized:
     **=    +=    *=    &=    &.=    <<=    &&=
            -=    /=    |=    |.=    >>=    ||=
            .=    %=    ^=    ^.=           //=
-                 x=
+                 x=                        ^^=
 
 Although these are grouped by family, they all have the precedence
 of assignment.  These combined assignment operators can only operate on

pp_ctl.c

@@ -2172,11 +2172,16 @@ Perl_die_unwind(pTHX_ SV *msv)
 
 PP(pp_xor)
 {
-    SV *left  = PL_stack_sp[0];
-    SV *right = PL_stack_sp[-1];
-    rpp_replace_2_IMM_NN(SvTRUE_NN(left) != SvTRUE_NN(right)
-                    ? &PL_sv_yes
-                    : &PL_sv_no);
+    SV *left  = PL_stack_sp[-1];
+    SV *right = PL_stack_sp[0];
+    bool ret = SvTRUE_NN(left) != SvTRUE_NN(right);
+    if (PL_op->op_flags & OPf_STACKED) {
+        sv_setbool(left, ret);
+        rpp_replace_2_1(left);
+    }
+    else {
+        rpp_replace_2_IMM_NN(boolSV(ret));
+    }
     return NORMAL;
 }
 

t/op/lop.t

@@ -10,7 +10,7 @@ BEGIN {
     set_up_inc('../lib');
 }
 
-plan tests => 47;
+plan tests => 58;
 
 for my $i (undef, 0 .. 2, "", "0 but true") {
     my $true = 1;
@@ -105,8 +105,16 @@ for my $test (
     my ($a,$b, $exp) = @$test;
     is(($a xor $b), $exp, "($a xor $b) == '$exp'");
     is(($a ^^ $b), $exp, "($a ^^ $b) == '$exp'");
+
+    my ($lhs, $rhs) = @$test;
+    $lhs ^^= $rhs;
+    is($lhs, $exp, "$a ^^= $b gives '$exp'");
 }
 
+my $var = 123;
+($var ^^= 456) ^^= 456;
+is($var, 1, '^^= yields mutable lvalue');
+
 # precedence
 is((1 xor 1 and 0), 1, '(1 xor 1 and 0) == 1');
 is((1 xor 0 or 1), 1, "(1 xor 0 or 1) == 1");

toke.c

@@ -6097,6 +6097,10 @@ yyl_caret(pTHX_ char *s)
             TOKEN(0);
         }
         pl_yylval.ival = OP_XOR;
+        if (*s == '=') {
+            s++;
+            OPERATOR(ASSIGNOP);
+        }
         OPERATOR(OROR);
     }
     if (bof && s[1] == '.')