stop $foo =~ /(bar)/g skipping copy
[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 # 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 => 15;  # 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
164
165     {
166         # these bits of test code used to run quadratically. If we break
167         # anything, they'll start to take minutes to run, rather than
168         # seconds. We don't actually measure times or set alarms, since
169         # that tends to be very fragile and prone to false positives.
170         # Instead, just hope that if someone is messing with
171         # performance-related code, they'll re-run the test suite and
172         # notice it suddenly takes a lot longer.
173
174         my $x;
175
176         $x = 'x' x 1_000_000;
177         1 while $x =~ /(.)/g;
178         pass "ascii =~ /(.)/";
179
180         {
181             local ${^UTF8CACHE} = 1; # defeat debugging
182             $x = "\x{100}" x 1_000_000;
183             1 while $x =~ /(.)/g;
184             pass "utf8 =~ /(.)/";
185         }
186
187         # run these in separate processes, since they set $&
188
189         fresh_perl_is(<<'EOF', "ok\n", {}, 'ascii =~ /(.)/, mention $&');
190 $&;
191 $x = 'x' x 1_000_000;
192 1 while $x =~ /(.)/g;
193 print "ok\n";
194 EOF
195
196         fresh_perl_is(<<'EOF', "ok\n", {}, 'utf8 =~ /(.)/, mention $&');
197 $&;
198 local ${^UTF8CACHE} = 1; # defeat debugging
199 $x = "\x{100}" x 1_000_000;
200 1 while $x =~ /(.)/g;
201 print "ok\n";
202 EOF
203
204
205     }
206 } # End of sub run_tests
207
208 1;