Commit | Line | Data |
---|---|---|
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 | |
10 | use strict; | |
11 | use warnings; | |
12 | use 5.010; | |
13 | ||
14 | ||
15 | sub run_tests; | |
16 | ||
17 | $| = 1; | |
18 | ||
e425a60b YO |
19 | |
20 | BEGIN { | |
21 | chdir 't' if -d 't'; | |
9d45b377 | 22 | @INC = ('../lib','.'); |
90b541eb | 23 | require './test.pl'; |
e425a60b | 24 | } |
e425a60b | 25 | |
e425a60b | 26 | |
9414be01 | 27 | skip_all('$PERL_SKIP_PSYCHO_TEST set') if $ENV{PERL_SKIP_PSYCHO_TEST}; |
9d45b377 | 28 | plan tests => 11; # Update this when adding/deleting tests. |
e425a60b | 29 | |
9d45b377 | 30 | run_tests() unless caller; |
e425a60b YO |
31 | |
32 | # | |
33 | # Tests start here. | |
34 | # | |
35 | sub 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 | } |
e425a60b YO |
163 | } # End of sub run_tests |
164 | ||
165 | 1; |