t/re/pat.t: Add ability to skip on memory constrained

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

diff --git a/t/re/pat.t b/t/re/pat.t
index b7c645e..b046638 100644 (file)
--- a/t/re/pat.t
+++ b/t/re/pat.t
@@ -25,7 +25,7 @@ BEGIN {
 skip_all('no re module') unless defined &DynaLoader::boot_DynaLoader;
 skip_all_without_unicode_tables();
 
-plan tests => 960;  # Update this when adding/deleting tests.
+plan tests => 965;  # Update this when adding/deleting tests.
 
 run_tests() unless caller;
 
@@ -354,8 +354,11 @@ sub run_tests {
         ok $@ =~ /^\QLookbehind longer than 255 not/, "Lookbehind limit";
     }
 
-    {
-        # Long Monsters
+  SKIP:
+    {   # Long Monsters
+
+        skip('limited memory', 20) if $ENV{'PERL_SKIP_BIG_MEM_TESTS'};
+
         for my $l (125, 140, 250, 270, 300000, 30) { # Ordered to free memory
             my $a = 'a' x $l;
            my $message = "Long monster, length = $l";
@@ -367,8 +370,11 @@ sub run_tests {
         }
     }
 
-    {
-        # 20000 nodes, each taking 3 words per string, and 1 per branch
+  SKIP:
+    {   # 20000 nodes, each taking 3 words per string, and 1 per branch
+
+        skip('limited memory', 20) if $ENV{'PERL_SKIP_BIG_MEM_TESTS'};
+
         my $long_constant_len = join '|', 12120 .. 32645;
         my $long_var_len = join '|', 8120 .. 28645;
         my %ans = ( 'ax13876y25677lbc' => 1,
@@ -1421,7 +1427,10 @@ EOP
         ok("\x{017F}\x{017F}" =~ qr/^[$sharp_s]?$/i, "[] to EXACTish optimization");
     }
 
-    {   # Test that it avoids spllitting a multi-char fold across nodes
+    {   # Test that it avoids spllitting a multi-char fold across nodes.
+        # These all fold to things that are like 'ss', which, if split across
+        # nodes could fail to match a single character that folds to the
+        # combination.
         my $utf8_locale = find_utf8_ctype_locale();
         for my $char('F', $sharp_s, "\x{FB00}") {
             my $length = 260;    # Long enough to overflow an EXACTFish regnode
@@ -1471,6 +1480,32 @@ EOP
     }
 
     {
+        my $s = ("0123456789" x 26214) x 2; # Should fill 2 LEXACTS, plus
+                                            # small change
+        my $pattern_prefix = "use utf8; use re qw(Debug COMPILE)";
+        my $pattern = "$pattern_prefix; qr/$s/;";
+        my $result = fresh_perl($pattern);
+        if ($? != 0) {  # Re-run so as to display STDERR.
+            fail($pattern);
+            fresh_perl($pattern, { stderr => 0, verbose => 1 });
+        }
+        like($result, qr/Final program[^X]*\bLEXACT\b[^X]*\bLEXACT\b[^X]*\bEXACT\b[^X]*\bEND\b/s,
+             "Check that LEXACT nodes are generated");
+        like($s, qr/$s/, "Check that LEXACT nodes match");
+        like("a$s", qr/a$s/, "Previous test preceded by an 'a'");
+        substr($s, 260000, 1) = "\x{100}";
+        $pattern = "$pattern_prefix; qr/$s/;";
+        $result = fresh_perl($pattern, { 'wide_chars' => 1 } );
+        if ($? != 0) {  # Re-run so as to display STDERR.
+            fail($pattern);
+            fresh_perl($pattern, { stderr => 0, verbose => 1 });
+        }
+        like($result, qr/Final program[^X]*\bLEXACT_ONLY8\b[^X]*\bLEXACT\b[^X]*\bEXACT\b[^X]*\bEND\b/s,
+             "Check that an LEXACT_ONLY node is generated with a \\x{100}");
+        like($s, qr/$s/, "Check that LEXACT_ONLY8 nodes match");
+    }
+
+    {
         for my $char (":", uni_to_native("\x{f7}"), "\x{2010}") {
             my $utf8_char = $char;
             utf8::upgrade($utf8_char);