forcibly check the timing of the regex/alarm test in bulk

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

diff --git a/t/re/pat.t b/t/re/pat.t
index 1588d1c..b01c7d1 100644 (file)
--- a/t/re/pat.t
+++ b/t/re/pat.t
@@ -24,7 +24,7 @@ BEGIN {
 
 skip_all_without_unicode_tables();
 
-plan tests => 1015;  # Update this when adding/deleting tests.
+plan tests => 1022;  # Update this when adding/deleting tests.
 
 run_tests() unless caller;
 
@@ -1902,14 +1902,31 @@ EOP
             }
         }
         {
-            fresh_perl_is('
+            my $is_cygwin = $^O eq "cygwin";
+            local $::TODO = "this flaps on github cygwin vm, but not on cygwin iron #18129"
+              if $is_cygwin;
+            my $expected = "Timeout";
+            my $code = '
                 BEGIN{require q(test.pl);}
                 watchdog(3);
-                $SIG{ALRM} = sub {print "Timeout\n"; exit(1)};
+                $SIG{ALRM} = sub {print "'.$expected.'\n"; exit(1)};
                 alarm 1;
                 $_ = "a" x 1000 . "b" x 1000 . "c" x 1000;
                 /.*a.*b.*c.*[de]/;
-            ',"Timeout",{},"Test Perl 73464")
+                print "increase the multipliers in the regex above to run the regex longer";
+            ';
+            # this flaps on github cygwin vm, but not on cygwin iron #18129
+            # so on cygwin it's run for 50 seconds to see if it fails eventually
+            my $max = $is_cygwin ? 50 : 1;
+            my ($iter, $result, $status);
+            for my $i (1..$max) {
+                $iter = $i;
+                $result = fresh_perl($code,{});
+                $status = $?;
+                last if $result ne $expected;
+            }
+            is($result, $expected, "Test Perl 73464")
+              or diag "PROG:", $code, "STATUS:", $status, "failed on iteration: $iter";
         }
 
         {   # [perl #128686], crashed the the interpreter
@@ -2243,6 +2260,46 @@ SKIP:
         unlike("\x{200E}", $pat, "200E isn't in pattern");
     }
 
+    # gh17490: test recursion check
+    {
+        my $eval = '(?{1})';
+        my $re = sprintf '(?&FOO)(?(DEFINE)(?<FOO>%sfoo))', $eval x 20;
+        my $result = eval qq{"foo" =~ /$re/};
+        is($@ // '', '', "many evals did not die");
+        ok($result, "regexp correctly matched");
+    }
+
+    # gh16947: test regexp corruption (GOSUB)
+    {
+        fresh_perl_is(q{
+            'xy' =~ /x(?0)|x(?|y|y)/ && print 'ok'
+        }, 'ok', {}, 'gh16947: test regexp corruption (GOSUB)');
+    }
+    # gh16947: test fix doesn't break SUSPEND
+    {
+        fresh_perl_is(q{ 'sx' =~ m{ss++}i; print 'ok' },
+                'ok', {}, "gh16947: test fix doesn't break SUSPEND");
+    }
+
+    # gh17730: should not crash
+    {
+        fresh_perl_is(q{
+            "q00" =~ m{(((*ACCEPT)0)*00)?0(?1)}; print "ok"
+        }, 'ok', {}, 'gh17730: should not crash');
+    }
+
+    # gh17743: more regexp corruption via GOSUB
+    {
+        fresh_perl_is(q{
+            "0" =~ /((0(?0)|000(?|0000|0000)(?0))|)/; print "ok"
+        }, 'ok', {}, 'gh17743: test regexp corruption (1)');
+
+        fresh_perl_is(q{
+            "000000000000" =~ /(0(())(0((?0)())|000(?|\x{ef}\x{bf}\x{bd}|\x{ef}\x{bf}\x{bd}))|)/;
+            print "ok"
+        }, 'ok', {}, 'gh17743: test regexp corruption (2)');
+    }
+
 } # End of sub run_tests
 
 1;