gmtime/localtime are busted around 2**48
[perl.git] / 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;