add stress test for CURLYX/WHILEM regex ops

p4raw-id: //depot/perl@28906

diff --git a/t/op/pat.t b/t/op/pat.t
index 303e448..59499b1 100755 (executable)
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -3632,11 +3632,113 @@ $brackets = qr{
              }x;
 ok("{b{c}d" !~ m/^((??{ $brackets }))/, "bracket mismatch");
 
+
+# stress test CURLYX/WHILEM.
+#
+# This test includes varying levels of nesting, and according to
+# profiling done against build 28905, exercises every code line in the
+# CURLYX and WHILEM blocks, except those related to LONGJMP, the
+# super-linear cache and warnings. It executes about 0.5M regexes
+
+{
+  my $r = qr/^
+           (?:
+               ( (?:a|z+)+ )
+               (?:
+                   ( (?:b|z+){3,}? )
+                   (
+                       (?:
+                           (?:c|z+){1,1}
+                       )*
+                   )
+                   (?:z*){2,}
+                   ( (?:z+|d)+ )
+                   (?:
+                       ( (?:e|z+)+ )
+                   )*
+                   ( (?:f|z+)+ )
+               )*
+               ( (?:z+|g)+ )
+               (?:
+                   ( (?:h|z+)+ )
+               )*
+               ( (?:i|z+)+ )
+           )+
+           ( (?:j|z+)+ )
+           (?:
+               ( (?:k|z+)+ )
+           )*
+           ( (?:l|z+)+ )
+       $/x;
+  
+  
+  my $ok = 1;
+  my $msg = "CURLYX stress test";
+  OUTER:
+  for my $a ("x","a","aa") {
+    for my $b ("x","bbb","bbbb") {
+      my $bs = $a.$b;
+      for my $c ("x","c","cc") {
+        my $cs = $bs.$c;
+        for my $d ("x","d","dd") {
+          my $ds = $cs.$d;
+          for my $e ("x","e","ee") {
+            my $es = $ds.$e;
+            for my $f ("x","f","ff") {
+              my $fs = $es.$f;
+              for my $g ("x","g","gg") {
+                my $gs = $fs.$g;
+                for my $h ("x","h","hh") {
+                  my $hs = $gs.$h;
+                  for my $i ("x","i","ii") {
+                    my $is = $hs.$i;
+                    for my $j ("x","j","jj") {
+                      my $js = $is.$j;
+                      for my $k ("x","k","kk") {
+                        my $ks = $js.$k;
+                        for my $l ("x","l","ll") {
+                          my $ls = $ks.$l;
+                          if ($ls =~ $r) {
+                            if ($ls =~ /x/) {
+                              $msg .= ": unexpected match for [$ls]";
+                             $ok = 0;
+                              last OUTER;
+                            }
+                            my $cap = "$1$2$3$4$5$6$7$8$9$10$11$12";
+                            unless ($ls eq $cap) {
+                              $msg .= ": capture: [$ls], got [$cap]";
+                             $ok = 0;
+                              last OUTER;
+                            }
+                          }
+                          else {
+                            unless ($ls =~ /x/) {
+                              $msg = ": failed for [$ls]";
+                             $ok = 0;
+                              last OUTER;
+                            }
+                          }
+                        }
+                      }
+                    }
+                  }
+                }
+              }
+            }
+          }
+        }
+      }
+    }
+  }
+  ok($ok, $msg);
+}
+
+
 # Keep the following test last -- it may crash perl
 
 ok(("a" x (2**15 - 10)) =~ /^()(a|bb)*$/, "Recursive stack cracker: #24274")
     or print "# Unexpected outcome: should pass or crash perl\n";
 
 # Don't forget to update this!
-BEGIN{print "1..1252\n"};
+BEGIN{print "1..1253\n"};