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