From: Dave Mitchell <davem@fdisolutions.com>
Date: Sat, 30 Sep 2006 00:22:20 +0000 (+0000)
Subject: add stress test for CURLYX/WHILEM regex ops
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=bfac009d8686ae692a2b3faa02801b15a15e64ba;p=p5sagit%2Fp5-mst-13.2.git

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
--- 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"};