This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
stop $foo =~ /(bar)/g skipping copy
[perl5.git] / t / re / pat_psycho.t
CommitLineData
e425a60b
YO
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.
9414be01
DM
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
e425a60b
YO
9
10use strict;
11use warnings;
12use 5.010;
13
14
15sub run_tests;
16
17$| = 1;
18
e425a60b
YO
19
20BEGIN {
21 chdir 't' if -d 't';
9d45b377 22 @INC = ('../lib','.');
90b541eb 23 require './test.pl';
e425a60b 24}
e425a60b 25
e425a60b 26
9414be01 27skip_all('$PERL_SKIP_PSYCHO_TEST set') if $ENV{PERL_SKIP_PSYCHO_TEST};
a41aa44d 28plan tests => 15; # Update this when adding/deleting tests.
e425a60b 29
9d45b377 30run_tests() unless caller;
e425a60b
YO
31
32#
33# Tests start here.
34#
35sub run_tests {
9414be01 36 print "# Set PERL_SKIP_PSYCHO_TEST to skip these tests\n";
e425a60b
YO
37
38 {
39
9414be01
DM
40 # stress test tries
41
42 my @normal = qw [the are some normal words];
e425a60b 43
9d45b377 44 local $" = "|";
e425a60b 45
9414be01 46 note "setting up trie psycho vars ...";
9d45b377
YO
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];
e425a60b 52 }
9d45b377 53 my $psycho2 = "@psycho";
e425a60b 54
9d45b377 55 foreach my $word (@normal) {
9414be01
DM
56 ok $word =~ /($psycho1)/ && $1 eq $word, qq{"$word" =~ /\$psycho1/};
57 ok $word =~ /($psycho2)/ && $1 eq $word, qq{"$word" =~ /\$psycho1/};
e425a60b
YO
58 }
59 }
60
61
62 {
9d45b377
YO
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
e425a60b 69
9d45b377
YO
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 }
e425a60b 160 }
9d45b377 161 ok($ok, $msg);
e425a60b 162 }
a41aa44d
DM
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;
1921 while $x =~ /(.)/g;
193print "ok\n";
194EOF
195
196 fresh_perl_is(<<'EOF', "ok\n", {}, 'utf8 =~ /(.)/, mention $&');
197$&;
198local ${^UTF8CACHE} = 1; # defeat debugging
199$x = "\x{100}" x 1_000_000;
2001 while $x =~ /(.)/g;
201print "ok\n";
202EOF
203
204
205 }
e425a60b
YO
206} # End of sub run_tests
207
2081;