Use of code points over 0xFF in string bitwise operators

Implement complete fatalization.  Some instances of these were fatalized
in 5.28.  However, in cases where the wide characters did not affect the
end result, no deprecation notice was raised.  So they remained legal,
though deprecated.  Now, all occurrences are fatal (as of 5.32).

Modify source code in doop.c.  Adapt test file.  Update perldiag and
perldeprecation.

For:  RT 134140

(Commiter changed a verb to past tense in the pod)

Author: jkeenan

doop.c

@@ -1084,30 +1084,11 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
      * 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 */
+     * appended to the final result, unchanged.  As of perl-5.32, we no longer
+     * accept above-FF code points in the dangling portion.
+     */
     if (left_utf8 || right_utf8) {
-        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;
-        }
-
-        Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
-                               DEPRECATED_ABOVE_FF_MSG, PL_op_desc[optype]);
+        Perl_croak(aTHX_ FATAL_ABOVE_FF_MSG, PL_op_desc[optype]);
     }
     else {  /* Neither is UTF-8 */
         len = MIN(leftlen, rightlen);

pod/perldeprecation.pod

@@ -65,14 +65,14 @@ nonsensical. Some instances of these have been deprecated since Perl
 the wide characters did not affect the end result, no deprecation
 notice was raised, and so remain legal.  Now, all occurrences either are
 fatal or raise a deprecation warning, so that the remaining legal
-occurrences will be fatal in 5.32.
+occurrences became fatal in 5.32.
 
 An example of this is
 
  "" & "\x{100}"
 
 The wide character is not used in the C<&> operation because the left
-operand is shorter.  This now warns anyway.
+operand is shorter.  This now throws an exception.
 
 =head3 hostname() doesn't accept any arguments
 

pod/perldiag.pod

@@ -7338,7 +7338,7 @@ C<~>) on a string containing a code point over 0xFF.  The string bitwise
 operators treat their operands as strings of bytes, and values beyond
 0xFF are nonsensical in this context.
 
-This became fatal in Perl 5.28.
+Certain instances became fatal in Perl 5.28; others in perl 5.32.
 
 =item Use of strings with code points over 0xFF as arguments to vec is forbidden
 

t/op/bop.t

@@ -18,7 +18,7 @@ BEGIN {
 # If you find tests are failing, please try adding names to tests to track
 # down where the failure is, and supply your new names as a patch.
 # (Just-in-time test naming)
-plan tests => 504;
+plan tests => 491;
 
 # numerics
 ok ((0xdead & 0xbeef) == 0x9ead);
@@ -613,73 +613,30 @@ foreach my $op_info ([and => "&"], [or => "|"], [xor => "^"]) {
 }
 
 {
-    # Since these are temporary, and it was a pain to make them into loops,
-    # the code is just rolled out.
-    local $SIG{__WARN__} = sub { push @warnings, @_; };
-
-    undef @warnings;
-    is("abc" & "abc\x{100}", "abc", '"abc" & "abc\x{100}" works');
-    if (! is(@warnings, 1, "... but returned a single warning")) {
-        diag join "\n", @warnings;
-    }
-    like ($warnings[0], qr /^Use of strings with code points over 0xFF as (?#
-                            )arguments to bitwise and \(&\) operator (?#
-                            )is deprecated/,
-                        "... which is the expected warning");
-    undef @warnings;
-    is("abc" | "abc\x{100}", "abc\x{100}", '"abc" | "abc\x{100}" works');
-    if (! is(@warnings, 1, "... but returned a single warning")) {
-        diag join "\n", @warnings;
-    }
-    like ($warnings[0], qr /^Use of strings with code points over 0xFF as (?#
-                            )arguments to bitwise or \(|\) operator (?#
-                            )is deprecated/,
-                        "... which is the expected warning");
-    undef @warnings;
-    is("abc" ^ "abc\x{100}", "\0\0\0\x{100}", '"abc" ^ "abc\x{100}" works');
-    if (! is(@warnings, 1, "... but returned a single warning")) {
-        diag join "\n", @warnings;
-    }
-    like ($warnings[0], qr /^Use of strings with code points over 0xFF as (?#
-                            )arguments to bitwise xor \(\^\) operator (?#
-                            )is deprecated/,
-                        "... which is the expected warning");
-    undef @warnings;
-    is("abc\x{100}" & "abc", "abc", '"abc\x{100}" & "abc" works');
-    if (! is(@warnings, 1, "... but returned a single warning")) {
-        diag join "\n", @warnings;
-    }
-    like ($warnings[0], qr /^Use of strings with code points over 0xFF as (?#
-                            )arguments to bitwise and \(&\) operator (?#
-                            )is deprecated/,
-                        "... which is the expected warning");
-    undef @warnings;
-    is("abc\x{100}" | "abc", "abc\x{100}", '"abc\x{100}" | "abc" works');
-    if (! is(@warnings, 1, "... but returned a single warning")) {
-        diag join "\n", @warnings;
-    }
-    like ($warnings[0], qr /^Use of strings with code points over 0xFF as (?#
-                            )arguments to bitwise or \(|\) operator (?#
-                            )is deprecated/,
-                        "... which is the expected warning");
-    undef @warnings;
-    is("abc\x{100}" ^ "abc", "\0\0\0\x{100}", '"abc\x{100}" ^ "abc" works');
-    if (! is(@warnings, 1, "... but returned a single warning")) {
-        diag join "\n", @warnings;
-    }
-    like ($warnings[0], qr /^Use of strings with code points over 0xFF as (?#
-                            )arguments to bitwise xor \(\^\) operator (?#
-                            )is deprecated/,
-                        "... which is the expected warning");
-    no warnings 'deprecated';
-    undef @warnings;
-    my $foo = "abc" & "abc\x{100}";
-    $foo = "abc" | "abc\x{100}";
-    $foo = "abc" ^ "abc\x{100}";
-    $foo = "abc\x{100}" & "abc";
-    $foo = "abc\x{100}" | "abc";
-    $foo = "abc\x{100}" ^ "abc";
-    if (! is(@warnings, 0, "... And none of the last 6 main tests warns when 'deprecated' is off")) {
-        diag join "\n", @warnings;
+    # RT 134140 fatalizations
+    my %op_pairs = (
+        and => { low => 'and', high => '&', regex => qr/&/  },
+        or  => { low => 'or',  high => '|', regex => qr/\|/ },
+        xor => { low => 'xor', high => '^', regex => qr/\^/ },
+    );
+    my @combos = (
+        { string  => '"abc" & "abc\x{100}"',  op_pair => $op_pairs{and} },
+        { string  => '"abc" | "abc\x{100}"',  op_pair => $op_pairs{or}  },
+        { string  => '"abc" ^ "abc\x{100}"',  op_pair => $op_pairs{xor} },
+        { string  => '"abc\x{100}" & "abc"',  op_pair => $op_pairs{and} },
+        { string  => '"abc\x{100}" | "abc"',  op_pair => $op_pairs{or}  },
+        { string  => '"abc\x{100}" ^ "abc"',  op_pair => $op_pairs{xor} },
+
+    );
+
+    # Use of strings with code points over 0xFF as arguments to %s operator is not allowed
+    for my $h (@combos) {
+        my $s1 = "Use of strings with code points over 0xFF as arguments to bitwise";
+        my $s2 = "operator is not allowed";
+        my $expected  = qr/$s1 $h->{op_pair}->{low} \($h->{op_pair}->{regex}\) $s2/;
+        my $description = "$s1 $h->{op_pair}->{low} ($h->{op_pair}->{high}) operator is not allowed";
+        local $@;
+        eval $h->{string};
+        like $@, $expected, $description;
     }
 }