This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Revert: Restrict code points to <= IV_MAX
authorKarl Williamson <khw@cpan.org>
Mon, 3 Jul 2017 18:26:34 +0000 (12:26 -0600)
committerKarl Williamson <khw@cpan.org>
Thu, 13 Jul 2017 03:14:23 +0000 (21:14 -0600)
This reverts the two related commits
51099b64db323d0e1d871837f619d72bea8ca2f9  (partially)
13f4dd346e6f3b61534a20f246de3a80b3feb743  (entirely)

I was in the middle of a long branch dealing with this and related
issues when these were pushed to blead.  It was far easier for me to
revert these at the beginning of my branch than to try to rebase
unreverted.  And there are changes needed to the approaches taken in the
reverted commits.  A third related commit,
113b8661ce6d987db4dd217e2f90cbb983ce5d00, doesn't cause problems so
isn't reverted.

I reverted the second commit, then the first one, and squashed them
together into this one.  No other changes were done in this commit.
The reason for the squashing is to avoid problems when bisecting on a
32-bit machine.  If the bisect landed between the commits, it could show
failures.  The portion of the first commit that wasn't reverted was the
part that was rendered moot because of the changes in the meantime that
forbid bitwise operations on strings containing code points above
Latin1.

The next commit in this series will reinstate portions of these commits.
I reverted as much as possible here to make this reversion commit
cleaner.

The biggest problem with these commits, is that some Perl applications
are made vulnerable to Denial of Service attacks.  I do believe it is ok
to croak when a program tries, for example, to do chr() of too large a
number, which is what the reverted commit does (and what this branch
will eventually reinstate doing).  But when parsing UTF-8, you can't
just die if you find something too large.  That would be an easy DOS on
any program, such as a web server, that gets its UTF-8 from the public.
Perl already has a means to deal with too-large code points (before
5.26, this was those code points that overflow the word size), and web
servers should have already been written in such a way as to deal with
these.  This branch just adapts the code so that anything above IV_MAX
is considered to be overflowing.  Web servers should not have to change
as a result.

A second issue is that one of the reasons we did the original
deprecation is so that we can use the forbidden code points internally
ourselves, such as Perl 6 does to store Grapheme Normal Form.  The
implementation should not burn bridges, but allow that use to easily
happen when the time comes.  For that reason, some tests should not be
deleted, but commented out, so they can be quickly adapted.

While working on this branch, I found several unlikely-to-occur bugs in
the existing code.  These should be fixed now in the code that handles
up to UV_MAX code points, so that when we do allow internal use of such,
the bugs are already gone.

I also had researched the tests that fail as a result of the IV_MAX
restriction.  Some of the test changes in these reverted commits were
inappropriate.

For example, some tests that got changed were for bugs that happen only
on code points that are now illegal on 32-bit builds.  Lowering the code
point in the test to a legal value, as was done in some instances,  no
longer tests for the original bug.  Instead, where I found this, I just
skip the test on 32-bit platforms.

Other tests were simply deleted, where a lower code point would have
worked, and the test is useful with a lower code point.  I retain such
tests, using a lower code point.  In some cases, it was probably ok to
delete the tests on 32-bit platforms, as something was retained for a
64-bit one, but since I had already done the adaptive work, I retain
that.

And still other tests were from files that I extensively revamp, so I
went with the revamp.

The following few commits fix those as far as possible now.  This is so
that the reversion of the tests and my changes are close together in the
final commit series.  Some changes have to wait to later, as for those
where the entire test files are revamped, or when the deprecation
messages finally go away in the final commit of this series.

In cases where the message wording I was contemplating using conflicts
with the reverted commits, I change mine to use that of the reverted
commits.

ext/XS-APItest/t/utf8.t
ext/XS-APItest/t/utf8_warn_base.pl
t/comp/parser.t
t/lib/warnings/utf8
t/op/chop.t
t/op/index.t
t/op/ver.t
t/opbasic/qq.t
t/re/pat_advanced.t
t/uni/parser.t
utf8.c

index 95e2628..c7a032e 100644 (file)
@@ -381,23 +381,19 @@ my %code_points = (
     0x40000000     =>
     (isASCII) ?    "\xfd\x80\x80\x80\x80\x80"
     : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0"),
+    0x80000000 - 1 =>
+    (isASCII) ?    "\xfd\xbf\xbf\xbf\xbf\xbf"
+    : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xbf\xbf\xbf\xbf\xbf\xbf"),
+    0x80000000     =>
+    (isASCII) ?    "\xfe\x82\x80\x80\x80\x80\x80"
+    : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
+    0xFFFFFFFF     =>
+    (isASCII) ?    "\xfe\x83\xbf\xbf\xbf\xbf\xbf"
+    : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa3\xbf\xbf\xbf\xbf\xbf\xbf"),
 );
 
 if ($::is64bit) {
     no warnings qw(overflow portable);
-
-    $code_points{0x80000000 - 1}
-     = (isASCII)
-     ?    "\xfd\xbf\xbf\xbf\xbf\xbf"
-     : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xbf\xbf\xbf\xbf\xbf\xbf"),
-    $code_points{0x80000000}
-     = (isASCII)
-     ?    "\xfe\x82\x80\x80\x80\x80\x80"
-     : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
-    $code_points{0xFFFFFFFF}
-     = (isASCII)
-     ?    "\xfe\x83\xbf\xbf\xbf\xbf\xbf"
-     : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa3\xbf\xbf\xbf\xbf\xbf\xbf"),
     $code_points{0x100000000}
      = (isASCII)
      ?              "\xfe\x84\x80\x80\x80\x80\x80"
@@ -410,7 +406,10 @@ if ($::is64bit) {
      = (isASCII)
      ?              "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80"
      : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0\xa0");
-
+    $code_points{0xFFFFFFFFFFFFFFFF}
+     = (isASCII)
+     ?              "\xff\x80\x8f\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"
+     : I8_to_native("\xff\xaf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf");
     if (isASCII) {  # These could falsely show as overlongs in a naive
                     # implementation
         $code_points{0x40000000000}
@@ -869,9 +868,6 @@ my $p = (isASCII) ? "\xe1\x80" : I8_to_native("\xE4\xA0");  # partial
 for my $restriction (sort keys %restriction_types) {
     use bytes;
 
-    next if $restriction eq 'fits_in_31_bits'
-         && !defined $restriction_types{"fits_in_31_bits"}{'first_invalid_offset'};
-
     for my $use_flags ("", "_flags") {
 
         # For each restriction, we test it in both the is_foo_flags functions
index a3f4052..66f6f3d 100644 (file)
@@ -377,6 +377,70 @@ my @tests = (
         (isASCII) ? 4 : 5,
         qr/Unicode non-character.*is not recommended for open interchange/
     ],
+    [ "requires at least 32 bits",
+        (isASCII)
+         ?  "\xfe\x82\x80\x80\x80\x80\x80"
+         : I8_to_native(
+            "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
+        # This code point is chosen so that it is representable in a UV on
+        # 32-bit machines
+        $::UTF8_WARN_ABOVE_31_BIT, $::UTF8_DISALLOW_ABOVE_31_BIT,
+        $::UTF8_GOT_ABOVE_31_BIT,
+        'utf8', 0x80000000,
+        (isASCII) ? 7 : $::max_bytes,
+        (isASCII) ? 1 : 8,
+        nonportable_regex(0x80000000)
+    ],
+    [ "highest 32 bit code point",
+        (isASCII)
+         ?  "\xfe\x83\xbf\xbf\xbf\xbf\xbf"
+         : I8_to_native(
+            "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa3\xbf\xbf\xbf\xbf\xbf\xbf"),
+        $::UTF8_WARN_ABOVE_31_BIT, $::UTF8_DISALLOW_ABOVE_31_BIT,
+        $::UTF8_GOT_ABOVE_31_BIT,
+        'utf8', 0xFFFFFFFF,
+        (isASCII) ? 7 : $::max_bytes,
+        (isASCII) ? 1 : 8,
+        nonportable_regex(0xffffffff)
+    ],
+    [ "requires at least 32 bits, and use SUPER-type flags, instead of"
+    . " ABOVE_31_BIT",
+        (isASCII)
+         ? "\xfe\x82\x80\x80\x80\x80\x80"
+         : I8_to_native(
+           "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
+        $::UTF8_WARN_SUPER, $::UTF8_DISALLOW_SUPER, $::UTF8_GOT_SUPER,
+        'utf8', 0x80000000,
+        (isASCII) ? 7 : $::max_bytes,
+        1,
+        nonportable_regex(0x80000000)
+    ],
+    [ "overflow with warnings/disallow for more than 31 bits",
+        # This tests the interaction of WARN_ABOVE_31_BIT/DISALLOW_ABOVE_31_BIT
+        # with overflow.  The overflow malformation is never allowed, so
+        # preventing it takes precedence if the ABOVE_31_BIT options would
+        # otherwise allow in an overflowing value.  The ASCII code points (1
+        # for 32-bits; 1 for 64) were chosen because the old overflow
+        # detection algorithm did not catch them; this means this test also
+        # checks for that fix.  The EBCDIC are arbitrary overflowing ones
+        # since we have no reports of failures with it.
+       (($::is64bit)
+        ? ((isASCII)
+           ?    "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"
+           : I8_to_native(
+                "\xff\xB0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"))
+        : ((isASCII)
+           ?    "\xfe\x86\x80\x80\x80\x80\x80"
+           : I8_to_native(
+                "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"))),
+        $::UTF8_WARN_ABOVE_31_BIT,
+        $::UTF8_DISALLOW_ABOVE_31_BIT,
+        $::UTF8_GOT_ABOVE_31_BIT,
+        'utf8', 0,
+        (! isASCII || $::is64bit) ? $::max_bytes : 7,
+        (isASCII || $::is64bit) ? 2 : 8,
+        qr/overflows/
+    ],
 );
 
 if (! $::is64bit) {
@@ -407,66 +471,6 @@ else {
             $::max_bytes, (isASCII) ? 1 : 7,
             qr/and( is)? not portable/
         ];
-        [ "requires at least 32 bits",
-            (isASCII)
-             ?  "\xfe\x82\x80\x80\x80\x80\x80"
-             : I8_to_native(
-                "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
-            # This code point is chosen so that it is representable in a UV on
-            # 32-bit machines
-            $::UTF8_WARN_ABOVE_31_BIT, $::UTF8_DISALLOW_ABOVE_31_BIT,
-            $::UTF8_GOT_ABOVE_31_BIT,
-            'utf8', 0x80000000,
-            (isASCII) ? 7 : $::max_bytes,
-            (isASCII) ? 1 : 8,
-            nonportable_regex(0x80000000)
-        ],
-        [ "highest 32 bit code point",
-            (isASCII)
-             ?  "\xfe\x83\xbf\xbf\xbf\xbf\xbf"
-             : I8_to_native(
-                "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa3\xbf\xbf\xbf\xbf\xbf\xbf"),
-            $::UTF8_WARN_ABOVE_31_BIT, $::UTF8_DISALLOW_ABOVE_31_BIT,
-            $::UTF8_GOT_ABOVE_31_BIT,
-            'utf8', 0xFFFFFFFF,
-            (isASCII) ? 7 : $::max_bytes,
-            (isASCII) ? 1 : 8,
-            nonportable_regex(0xffffffff)
-        ],
-        [ "requires at least 32 bits, and use SUPER-type flags, instead of"
-        . " ABOVE_31_BIT",
-            (isASCII)
-             ? "\xfe\x82\x80\x80\x80\x80\x80"
-             : I8_to_native(
-               "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
-            $::UTF8_WARN_SUPER, $::UTF8_DISALLOW_SUPER, $::UTF8_GOT_SUPER,
-            'utf8', 0x80000000,
-            (isASCII) ? 7 : $::max_bytes,
-            1,
-            nonportable_regex(0x80000000)
-        ],
-        [ "overflow with warnings/disallow for more than 31 bits",
-            # This tests the interaction of WARN_ABOVE_31_BIT/DISALLOW_ABOVE_31_BIT
-            # with overflow.  The overflow malformation is never allowed, so
-            # preventing it takes precedence if the ABOVE_31_BIT options would
-            # otherwise allow in an overflowing value.  The ASCII code points (1
-            # for 32-bits; 1 for 64) were chosen because the old overflow
-            # detection algorithm did not catch them; this means this test also
-            # checks for that fix.  The EBCDIC are arbitrary overflowing ones
-            # since we have no reports of failures with it.
-            ((isASCII)
-               ?    "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"
-               : I8_to_native(
-                    "\xff\xB0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0")),
-            $::UTF8_WARN_ABOVE_31_BIT,
-            $::UTF8_DISALLOW_ABOVE_31_BIT,
-            $::UTF8_GOT_ABOVE_31_BIT,
-            'utf8', 0,
-            (! isASCII || $::is64bit) ? $::max_bytes : 7,
-            (isASCII || $::is64bit) ? 2 : 8,
-            qr/overflows/
-        ];
-
     if (! isASCII) {
         push @tests,   # These could falsely show wrongly in a naive
                        # implementation
index 9b0f3a7..6fd5ad0 100644 (file)
@@ -586,7 +586,7 @@ is $@, "", 'substr keys assignment';
 {
 
     no warnings;
-    eval "q" . chr(0x7fffffff);
+    eval "q" . chr(100000000064);
     like $@, qr/Can't find string terminator "." anywhere before EOF/,
         'RT 128952';
 }
index a26bbed..64f0829 100644 (file)
@@ -99,11 +99,12 @@ Operation "uc" returns its argument for non-Unicode code point 0x110000 at - lin
 Operation "uc" returns its argument for UTF-16 surrogate U+D800 at - line 5.
 ########
 use warnings 'utf8';
-my $big_nonUnicode = uc(chr(0x7fff_ffff));
+no warnings 'deprecated'; # This is above IV_MAX on 32 bit machines
+my $big_nonUnicode = uc(chr(0x8000_0000));
 no warnings 'non_unicode';
-my $big_nonUnicode = uc(chr(0x7fff_ffff));
+my $big_nonUnicode = uc(chr(0x8000_0000));
 EXPECT
-Operation "uc" returns its argument for non-Unicode code point 0x7FFFFFFF at - line 2.
+Operation "uc" returns its argument for non-Unicode code point 0x80000000 at - line 3.
 ########
 use warnings 'utf8';
 my $d7ff  = lc pack("U", 0xD7FF);
@@ -735,6 +736,39 @@ $a = uc("\x{103}");
 $a = ucfirst("\x{104}");
 EXPECT
 ########
+# NAME Deprecation of too-large code points
+require "../test.pl";
+use warnings 'non_unicode';
+my $max_cp = ~0 >> 1;
+my $max_char = chr $max_cp;
+my $to_warn_cp = $max_cp + 1;
+my $to_warn_char = chr $to_warn_cp;
+$max_char =~ /[\x{110000}\P{Unassigned}]/;
+$to_warn_char =~ /[\x{110000}\P{Unassigned}]/;
+my $temp = qr/$max_char/;
+$temp = qr/$to_warn_char/;
+$temp = uc($max_char);
+$temp = uc($to_warn_char);
+my $file = tempfile();
+open(my $fh, "+>:utf8", $file);
+print $fh $max_char, "\n";
+print $fh $to_warn_char, "\n";
+close $fh;
+EXPECT
+OPTION regex
+Use of code point 0x80+ is deprecated; the permissible max is 0x7F+\. This will be fatal in Perl 5\.28 at - line \d+.
+Use of code point 0x80+ is deprecated; the permissible max is 0x7F+\. This will be fatal in Perl 5\.28 in pattern match \(m//\) at - line \d+.
+Use of code point 0x80+ is deprecated; the permissible max is 0x7F+\. This will be fatal in Perl 5\.28 in regexp compilation at - line \d+.
+Use of code point 0x80+ is deprecated; the permissible max is 0x7F+\. This will be fatal in Perl 5\.28 in regexp compilation at - line \d+.
+Use of code point 0x80+ is deprecated; the permissible max is 0x7F+\. This will be fatal in Perl 5\.28 at - line \d+.
+Use of code point 0x80+ is deprecated; the permissible max is 0x7F+\. This will be fatal in Perl 5\.28 in regexp compilation at - line \d+.
+Operation "uc" returns its argument for non-Unicode code point 0x7F+ at - line \d+.
+Use of code point 0x80+ is deprecated; the permissible max is 0x7F+\. This will be fatal in Perl 5\.28 in uc at - line \d+.
+Use of code point 0x80+ is deprecated; the permissible max is 0x7F+\. This will be fatal in Perl 5\.28 at - line \d+.
+Operation "uc" returns its argument for non-Unicode code point 0x80+ at - line \d+.
+Code point 0x7F+ is not Unicode, may not be portable in print at - line \d+.
+Use of code point 0x80+ is deprecated; the permissible max is 0x7F+\. This will be fatal in Perl 5\.28 in print at - line \d+.
+########
 # NAME  [perl #127262]
 BEGIN{
     if (ord('A') == 193) {
index 8afc546..743f21a 100644 (file)
@@ -7,7 +7,7 @@ BEGIN {
     require './charset_tools.pl';
 }
 
-my $tests_count = 146;
+my $tests_count = 148;
 plan tests => $tests_count;
 
 $_ = 'abc';
@@ -253,10 +253,22 @@ foreach my $start (@chars) {
     # [perl #73246] chop doesn't support utf8
     # the problem was UTF8_IS_START() didn't handle perl's extended UTF8
 
-    my $utf = "\x{7fffffff}\x{7ffffffe}";
+    no warnings 'deprecated'; # This is above IV_MAX on 32 bit machines
+    my $utf = "\x{80000001}\x{80000000}";
     my $result = chop($utf);
-    is($utf, "\x{7fffffff}", "chopping high 'unicode'- remnant");
-    is($result, "\x{7ffffffe}", "chopping high 'unicode' - result");
+    is($utf, "\x{80000001}", "chopping high 'unicode'- remnant");
+    is($result, "\x{80000000}", "chopping high 'unicode' - result");
+
+    SKIP: {
+        no warnings 'overflow'; # avoid compile-time warnings below on 32-bit architectures
+        use Config;
+        $Config{ivsize} >= 8
+         or skip("this build can't handle very large characters", 2);
+        my $utf = "\x{ffffffffffffffff}\x{fffffffffffffffe}";
+        my $result = chop $utf;
+        is($utf, "\x{ffffffffffffffff}", "chop even higher 'unicode' - remnant");
+        is($result, "\x{fffffffffffffffe}", "chop even higher 'unicode' - result");
+    }
 }
 
 $/ = "\n";
index f043ef8..d1e46dc 100644 (file)
@@ -130,16 +130,17 @@ is(rindex($a, "foo",    ), 0);
 }
 
 {
-    my $a = eval q{"\x{7fffffff}"};
+    no warnings 'deprecated'; # These are above IV_MAX on 32 bit machines
+    my $a = eval q{"\x{80000000}"};
     my $s = $a.'defxyz';
-    is(index($s, 'def'), 1, "0x7fffffff is a single character");
+    is(index($s, 'def'), 1, "0x80000000 is a single character");
 
-    my $b = eval q{"\x{7ffffffd}"};
+    my $b = eval q{"\x{fffffffd}"};
     my $t = $b.'pqrxyz';
-    is(index($t, 'pqr'), 1, "0x7ffffffd is a single character");
+    is(index($t, 'pqr'), 1, "0xfffffffd is a single character");
 
     local ${^UTF8CACHE} = -1;
-    is(index($t, 'xyz'), 4, "0x7ffffffd and utf8cache");
+    is(index($t, 'xyz'), 4, "0xfffffffd and utf8cache");
 }
 
 
index 182c42a..e896711 100644 (file)
@@ -12,7 +12,7 @@ $DOWARN = 1; # enable run-time warnings now
 
 use Config;
 
-plan( tests => 52 );
+plan( tests => 58 );
 
 eval 'use v5.5.640';
 is( $@, '', "use v5.5.640; $@");
@@ -224,6 +224,26 @@ $v = $revision + $version/1000 + $subversion/1000000;
 
 ok( abs($v - $]) < 10**-8 , "\$^V == \$] (numeric)" );
 
+{
+
+  no warnings 'deprecated'; # These are above IV_MAX on 32 bit machines
+  # [ID 20010902.001 (#7608)] check if v-strings handle full UV range or not
+  if ( $Config{'uvsize'} >= 4 ) {
+    is(  sprintf("%vd", eval 'v2147483647.2147483648'),   '2147483647.2147483648', 'v-string > IV_MAX[32-bit]' );
+    is(  sprintf("%vd", eval 'v3141592653'),              '3141592653',            'IV_MAX < v-string < UV_MAX[32-bit]');
+    is(  sprintf("%vd", eval 'v4294967295'),              '4294967295',            'v-string == UV_MAX[32-bit] - 1');
+  }
+
+  SKIP: {
+    skip("No quads", 3) if $Config{uvsize} < 8;
+
+    if ( $Config{'uvsize'} >= 8 ) {
+      is(  sprintf("%vd", eval 'v9223372036854775807.9223372036854775808'),   '9223372036854775807.9223372036854775808', 'v-string > IV_MAX[64-bit]' );
+      is(  sprintf("%vd", eval 'v17446744073709551615'),                      '17446744073709551615',                    'IV_MAX < v-string < UV_MAX[64-bit]');
+      is(  sprintf("%vd", eval 'v18446744073709551615'),                      '18446744073709551615',                    'v-string == UV_MAX[64-bit] - 1');
+    }
+  }
+}
 
 # Tests for magic v-strings 
 
index e633783..5d6908c 100644 (file)
@@ -8,7 +8,7 @@ BEGIN {
 # This file uses a specially crafted is() function rather than that found in
 # t/test.pl or Test::More.  Hence, we place this file in directory t/opbasic.
 
-print q(1..28
+print q(1..29
 );
 
 # This is() function is written to avoid ""
@@ -71,6 +71,11 @@ is ("a\o{120}b", "a" . chr(0x50) . "b");
 is ("a\o{400}b", "a" . chr(0x100) . "b");
 is ("a\o{1000}b", "a" . chr(0x200) . "b");
 
+# This caused a memory fault
+no warnings "utf8";
+no warnings 'deprecated'; # This is above IV_MAX on 32 bit machines
+is ("abc", eval qq[qq\x{8000_0000}abc\x{8000_0000}]);
+
 # Maybe \x{} should be an error, but if not it should certainly mean \x{0}
 # rather than anything else.
 is ("\x{}", chr(0));
index 3d57bea..68c827a 100644 (file)
@@ -2344,7 +2344,7 @@ EOF
         # We use 'ok' instead of 'like' because the warnings are lexically
         # scoped, and want to turn them off, so have to do the match in this
         # scope.
-        if ($Config{uvsize} > 4) {
+        if ($Config{uvsize} < 8) {
             ok(chr(0xFFFF_FFFE) =~ /\p{Is_32_Bit_Super}/,
                             "chr(0xFFFF_FFFE) can match a Unicode property");
             ok(chr(0xFFFF_FFFF) =~ /\p{Is_32_Bit_Super}/,
@@ -2355,6 +2355,24 @@ EOF
             ok(chr(0xFFFF_FFFF) =~ $p, # Tests any caching
                     "chr(0xFFFF_FFFF) can match itself in a [class] subsequently");
         }
+        else {
+            no warnings 'overflow';
+            ok(chr(0xFFFF_FFFF_FFFF_FFFE) =~ qr/\p{Is_Portable_Super}/,
+                    "chr(0xFFFF_FFFF_FFFF_FFFE) can match a Unicode property");
+            ok(chr(0xFFFF_FFFF_FFFF_FFFF) =~ qr/^\p{Is_Portable_Super}$/,
+                    "chr(0xFFFF_FFFF_FFFF_FFFF) can match a Unicode property");
+
+            my $p = qr/^[\x{FFFF_FFFF_FFFF_FFFF}]$/;
+            ok(chr(0xFFFF_FFFF_FFFF_FFFF) =~ $p,
+                    "chr(0xFFFF_FFFF_FFFF_FFFF) can match itself in a [class]");
+            ok(chr(0xFFFF_FFFF_FFFF_FFFF) =~ $p, # Tests any caching
+                    "chr(0xFFFF_FFFF_FFFF_FFFF) can match itself in a [class] subsequently");
+
+            # This test is because something was declared as 32 bits, but
+            # should have been cast to 64; only a problem where
+            # sizeof(STRLEN) != sizeof(UV)
+            ok(chr(0xFFFF_FFFF_FFFF_FFFE) !~ qr/\p{Is_32_Bit_Super}/, "chr(0xFFFF_FFFF_FFFF_FFFE) shouldn't match a range ending in 0xFFFF_FFFF");
+        }
     }
 
     { # [perl #112530], the code below caused a panic
@@ -2404,7 +2422,8 @@ EOF
         $Config{uvsize} == 8
          or skip("need large code-points for this test", 1);
 
-       fresh_perl_is('/\x{E000000000}|/ and print qq(ok\n)', "ok\n", {},
+        # This is above IV_MAX on 32 bit machines, so turn off those warnings
+       fresh_perl_is('no warnings "deprecated"; /\x{E000000000}|/ and print qq(ok\n)', "ok\n", {},
                      "buffer overflow in TRIE_STORE_REVCHAR");
     }
 
index c5cf21c..2c68fb0 100644 (file)
@@ -237,8 +237,9 @@ SKIP: {   # [perl #128738]
         skip("test is only valid on 64-bit ints", 2);
     }
     else {
+        no warnings 'deprecated';
         my $a;
-        eval "\$a = q \x{7fffffff}Hello, \\\\whirled!\x{7fffffff}";
+        eval "\$a = q \x{ffffffff}Hello, \\\\whirled!\x{ffffffff}";
         is $@, "",
                "No errors in eval'ing a string with large code point delimiter";
         is $a, 'Hello, \whirled!',
diff --git a/utf8.c b/utf8.c
index e55a6f1..a784c54 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -37,8 +37,7 @@ static const char malformed_text[] = "Malformed UTF-8 character";
 static const char unees[] =
                         "Malformed UTF-8 character (unexpected end of string)";
 static const char cp_above_legal_max[] =
-      "Use of code point 0x%" UVXf " is not allowed; "
-      "the permissible max is 0x%" UVXf;
+ "Use of code point 0x%" UVXf " is deprecated; the permissible max is 0x%" UVXf ". This will be fatal in Perl 5.28";
 
 #define MAX_NON_DEPRECATED_CP ((UV) (IV_MAX))
 
@@ -199,8 +198,11 @@ Perl_uvoffuni_to_utf8_flags(pTHX_ U8 *d, UV uv, const UV flags)
      * performance hit on these high EBCDIC code points. */
 
     if (UNLIKELY(UNICODE_IS_SUPER(uv))) {
-        if (UNLIKELY(uv > MAX_NON_DEPRECATED_CP)) {
-            Perl_croak(aTHX_ cp_above_legal_max, uv, MAX_NON_DEPRECATED_CP);
+        if (   UNLIKELY(uv > MAX_NON_DEPRECATED_CP)
+            && ckWARN_d(WARN_DEPRECATED))
+        {
+            Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
+                        cp_above_legal_max, uv, MAX_NON_DEPRECATED_CP);
         }
         if (   (flags & UNICODE_WARN_SUPER)
             || (   UNICODE_IS_ABOVE_31_BIT(uv)
@@ -1682,9 +1684,12 @@ Perl_utf8n_to_uvchr_error(pTHX_ const U8 *s,
                  * where 'uv' is not valid. */
                 if (   ! (orig_problems
                                     & (UTF8_GOT_TOO_SHORT|UTF8_GOT_OVERFLOW))
-                    && UNLIKELY(uv > MAX_NON_DEPRECATED_CP)) {
-                    Perl_croak(aTHX_ cp_above_legal_max, uv,
-                                     MAX_NON_DEPRECATED_CP);
+                    && UNLIKELY(uv > MAX_NON_DEPRECATED_CP)
+                    && ckWARN_d(WARN_DEPRECATED))
+                {
+                    message = Perl_form(aTHX_ cp_above_legal_max,
+                                              uv, MAX_NON_DEPRECATED_CP);
+                    pack_warn = packWARN(WARN_DEPRECATED);
                 }
             }
             else if (possible_problems & UTF8_GOT_NONCHAR) {
@@ -2928,9 +2933,11 @@ S__to_utf8_case(pTHX_ const UV uv1, const U8 *p, U8* ustrp, STRLEN *lenp,
                 }
 
                 if (UNLIKELY(UNICODE_IS_SUPER(uv1))) {
-                    if (UNLIKELY(uv1 > MAX_NON_DEPRECATED_CP)) {
-                        Perl_croak(aTHX_ cp_above_legal_max, uv1,
-                                         MAX_NON_DEPRECATED_CP);
+                    if (   UNLIKELY(uv1 > MAX_NON_DEPRECATED_CP)
+                        && ckWARN_d(WARN_DEPRECATED))
+                    {
+                        Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
+                                cp_above_legal_max, uv1, MAX_NON_DEPRECATED_CP);
                     }
                     if (ckWARN_d(WARN_NON_UNICODE)) {
                         const char* desc = (PL_op) ? OP_DESC(PL_op) : normal;