t/re/pat_psycho.t

   1 #!./perl
   2 #
   3 # This is a home for regular expression tests that don't fit into
   4 # the format supported by re/regexp.t.  If you want to add a test
   5 # that does fit that format, add it to re/re_tests, not here.
   6 #
   7 # this file includes test that my burn a lot of CPU or otherwise be heavy
   8 # on resources. Set env var $PERL_SKIP_PSYCHO_TEST to skip this file
   9
  10 use strict;
  11 use warnings;
  12 use 5.010;
  13
  14
  15 sub run_tests;
  16
  17 $| = 1;
  18
  19
  20 BEGIN {
  21     chdir 't' if -d 't';
  22     @INC = ('../lib','.');
  23     require './test.pl';
  24 }
  25
  26
  27 skip_all('$PERL_SKIP_PSYCHO_TEST set') if $ENV{PERL_SKIP_PSYCHO_TEST};
  28 plan tests => 11;  # Update this when adding/deleting tests.
  29
  30 run_tests() unless caller;
  31
  32 #
  33 # Tests start here.
  34 #
  35 sub run_tests {
  36     print "# Set PERL_SKIP_PSYCHO_TEST to skip these tests\n";
  37
  38     {
  39
  40         # stress test tries
  41
  42         my @normal = qw [the are some normal words];
  43
  44         local $" = "|";
  45
  46         note "setting up trie psycho vars ...";
  47         my @psycho = (@normal, map chr $_, 255 .. 20000);
  48         my $psycho1 = "@psycho";
  49         for (my $i = @psycho; -- $i;) {
  50             my $j = int rand (1 + $i);
  51             @psycho [$i, $j] = @psycho [$j, $i];
  52         }
  53         my $psycho2 = "@psycho";
  54
  55         foreach my $word (@normal) {
  56             ok $word =~ /($psycho1)/ && $1 eq $word, qq{"$word" =~ /\$psycho1/};
  57             ok $word =~ /($psycho2)/ && $1 eq $word, qq{"$word" =~ /\$psycho1/};
  58         }
  59     }
  60
  61
  62     {
  63         # stress test CURLYX/WHILEM.
  64         #
  65         # This test includes varying levels of nesting, and according to
  66         # profiling done against build 28905, exercises every code line in the
  67         # CURLYX and WHILEM blocks, except those related to LONGJMP, the
  68         # super-linear cache and warnings. It executes about 0.5M regexes
  69
  70         my $r = qr/^
  71                     (?:
  72                         ( (?:a|z+)+ )
  73                         (?:
  74                             ( (?:b|z+){3,}? )
  75                             (
  76                                 (?:
  77                                     (?:
  78                                         (?:c|z+){1,1}?z
  79                                     )?
  80                                     (?:c|z+){1,1}
  81                                 )*
  82                             )
  83                             (?:z*){2,}
  84                             ( (?:z+|d)+ )
  85                             (?:
  86                                 ( (?:e|z+)+ )
  87                             )*
  88                             ( (?:f|z+)+ )
  89                         )*
  90                         ( (?:z+|g)+ )
  91                         (?:
  92                             ( (?:h|z+)+ )
  93                         )*
  94                         ( (?:i|z+)+ )
  95                     )+
  96                     ( (?:j|z+)+ )
  97                     (?:
  98                         ( (?:k|z+)+ )
  99                     )*
 100                     ( (?:l|z+)+ )
 101               $/x;
 102
 103         my $ok = 1;
 104         my $msg = "CURLYX stress test";
 105         OUTER:
 106           for my $a ("x","a","aa") {
 107             for my $b ("x","bbb","bbbb") {
 108               my $bs = $a.$b;
 109               for my $c ("x","c","cc") {
 110                 my $cs = $bs.$c;
 111                 for my $d ("x","d","dd") {
 112                   my $ds = $cs.$d;
 113                   for my $e ("x","e","ee") {
 114                     my $es = $ds.$e;
 115                     for my $f ("x","f","ff") {
 116                       my $fs = $es.$f;
 117                       for my $g ("x","g","gg") {
 118                         my $gs = $fs.$g;
 119                         for my $h ("x","h","hh") {
 120                           my $hs = $gs.$h;
 121                           for my $i ("x","i","ii") {
 122                             my $is = $hs.$i;
 123                             for my $j ("x","j","jj") {
 124                               my $js = $is.$j;
 125                               for my $k ("x","k","kk") {
 126                                 my $ks = $js.$k;
 127                                 for my $l ("x","l","ll") {
 128                                   my $ls = $ks.$l;
 129                                   if ($ls =~ $r) {
 130                                     if ($ls =~ /x/) {
 131                                       $msg .= ": unexpected match for [$ls]";
 132                                       $ok = 0;
 133                                       last OUTER;
 134                                     }
 135                                     my $cap = "$1$2$3$4$5$6$7$8$9$10$11$12";
 136                                     unless ($ls eq $cap) {
 137                                       $msg .= ": capture: [$ls], got [$cap]";
 138                                       $ok = 0;
 139                                       last OUTER;
 140                                     }
 141                                   }
 142                                   else {
 143                                     unless ($ls =~ /x/) {
 144                                       $msg = ": failed for [$ls]";
 145                                       $ok = 0;
 146                                       last OUTER;
 147                                     }
 148                                   }
 149                                 }
 150                               }
 151                             }
 152                           }
 153                         }
 154                       }
 155                     }
 156                   }
 157                 }
 158               }
 159             }
 160         }
 161         ok($ok, $msg);
 162     }
 163 } # End of sub run_tests
 164
 165 1;