From 79cb9dc8c366724b080f84ffdb0d0a6e22621c7a Mon Sep 17 00:00:00 2001 From: "Paul \"LeoNerd\" Evans" Date: Fri, 2 May 2025 09:14:30 +0100 Subject: [PATCH] Implement assigning xor (^^=) operator When I added '^^' I forgot to implement or test the assigning version of it. Also it seems `pp_xor` had the left and right arguments round the wrong way; but until the asymmetry introduced by this change nobody had noticed before. This is now fixed. Also adds `B::Deparse` support for the new assigning xor operator --- lib/B/Deparse.pm | 15 +++++++++++---- lib/B/Deparse.t | 5 +++++ op.c | 1 + pod/perldelta.pod | 6 ++++++ pod/perlop.pod | 4 ++-- pp_ctl.c | 15 ++++++++++----- t/op/lop.t | 10 +++++++++- toke.c | 4 ++++ 8 files changed, 48 insertions(+), 12 deletions(-) diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm index 112a3b3abe83..668ab90c7e3c 100644 --- a/lib/B/Deparse.pm +++ b/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; diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t index 2ff712a248aa..6d270234b2ff 100644 --- a/lib/B/Deparse.t +++ b/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); diff --git a/op.c b/op.c index 7027f18f036c..56a73ac1febe 100644 --- a/op.c +++ b/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++; diff --git a/pod/perldelta.pod b/pod/perldelta.pod index a722ab7cf428..7c215045ae79 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -27,6 +27,12 @@ here, but most should go in the L 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 diff --git a/pod/perlop.pod b/pod/perlop.pod index 0b2d144dc895..6f0820a045bb 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -1341,7 +1341,7 @@ That should probably be written more simply as: =head2 Assignment Operators 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 diff --git a/pp_ctl.c b/pp_ctl.c index ae4a4f2b0b73..10b01cda2b34 100644 --- a/pp_ctl.c +++ b/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; } diff --git a/t/op/lop.t b/t/op/lop.t index cdc5e87778cd..5de888527cb7 100644 --- a/t/op/lop.t +++ b/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"); diff --git a/toke.c b/toke.c index e6acb5a70177..5759c7890d32 100644 --- a/toke.c +++ b/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] == '.')