PATCH: [perl #133756] Failure to match properly

[perl5.git] / t / re / pat_advanced.t

diff --git a/t/re/pat_advanced.t b/t/re/pat_advanced.t
index 3d57bea..ade8b15 100644 (file)
--- a/t/re/pat_advanced.t
+++ b/t/re/pat_advanced.t
@@ -2176,6 +2176,33 @@ EOP
             }
         }
         ok(! $failed, "Matched multi-char fold 'ss' across EXACTF node boundaries; if failed, was at count $failed");
+
+        for my $non_finals ("t", "ft", "ift", "sift") {
+            my $base_pat = $non_finals . "enKalt";   # (The tail is taken from
+                                                     # the trouble ticket, is
+                                                     # arbitrary)
+            for my $utf8 ("non-UTF-8", "UTF-8") {
+
+                # Try at different lengths to be sure to get a node boundary
+                for my $repeat (120 .. 270) {   # [perl #133756]
+                    my $head = ("b" x $repeat) . "\xDC";
+                    my $pat = $base_pat;
+                    utf8::upgrade($pat) if $utf8 eq "UTF-8";
+                    $pat     = $head . $pat;
+                    my $text = $head . $base_pat;
+
+                    if ($text !~ /$pat/i) {
+                        $failed = $repeat;
+                        last;
+                    }
+                }
+
+                ok(! $failed, "A non-final fold character "
+                            . (length($non_finals) - 1)
+                            . " characters from the end of an EXACTFish"
+                            . " $utf8 pattern works; if failed, was at count $failed");
+            }
+        }
     }
 
     {
@@ -2333,27 +2360,44 @@ EOF
     }
 
     # User-defined Unicode properties to match above-Unicode code points
-    sub Is_32_Bit_Super { return "110000\tFFFFFFFF\n" }
+    sub Is_31_Bit_Super { return "110000\t7FFFFFFF\n" }
     sub Is_Portable_Super { return '!utf8::Any' }   # Matches beyond 32 bits
 
     {   # Assertion was failing on on 64-bit platforms; just didn't work on 32.
         no warnings qw(non_unicode portable);
-        no warnings 'deprecated'; # These are above IV_MAX
         use Config;
 
         # 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) {
-            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}/,
-                            "chr(0xFFFF_FFFF) can match a Unicode property");
-            my $p = qr/^[\x{FFFF_FFFF}]$/;
-            ok(chr(0xFFFF_FFFF) =~ $p,
-                    "chr(0xFFFF_FFFF) can match itself in a [class]");
-            ok(chr(0xFFFF_FFFF) =~ $p, # Tests any caching
-                    "chr(0xFFFF_FFFF) can match itself in a [class] subsequently");
+        if ($Config{uvsize} < 8) {
+            ok(chr(0x7FFF_FFFE) =~ /\p{Is_31_Bit_Super}/,
+                            "chr(0x7FFF_FFFE) can match a Unicode property");
+            ok(chr(0x7FFF_FFFF) =~ /\p{Is_31_Bit_Super}/,
+                            "chr(0x7FFF_FFFF) can match a Unicode property");
+            my $p = qr/^[\x{7FFF_FFFF}]$/;
+            ok(chr(0x7FFF_FFFF) =~ $p,
+                    "chr(0x7FFF_FFFF) can match itself in a [class]");
+            ok(chr(0x7FFF_FFFF) =~ $p, # Tests any caching
+                    "chr(0x7FFF_FFFF) can match itself in a [class] subsequently");
+        }
+        else {
+            no warnings 'overflow';
+            ok(chr(0x7FFF_FFFF_FFFF_FFFE) =~ qr/\p{Is_Portable_Super}/,
+                    "chr(0x7FFF_FFFF_FFFF_FFFE) can match a Unicode property");
+            ok(chr(0x7FFF_FFFF_FFFF_FFFF) =~ qr/^\p{Is_Portable_Super}$/,
+                    "chr(0x7FFF_FFFF_FFFF_FFFF) can match a Unicode property");
+
+            my $p = qr/^[\x{7FFF_FFFF_FFFF_FFFF}]$/;
+            ok(chr(0x7FFF_FFFF_FFFF_FFFF) =~ $p,
+                    "chr(0x7FFF_FFFF_FFFF_FFFF) can match itself in a [class]");
+            ok(chr(0x7FFF_FFFF_FFFF_FFFF) =~ $p, # Tests any caching
+                    "chr(0x7FFF_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(0x7FFF_FFFF_FFFF_FFFE) !~ qr/\p{Is_31_Bit_Super}/, "chr(0x7FFF_FFFF_FFFF_FFFE) shouldn't match a range ending in 0x7FFF_FFFF");
         }
     }