Commit | Line | Data |
e425a60b |
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 | |
e425a60b |
16 | |
17 | BEGIN { |
18 | chdir 't' if -d 't'; |
9d45b377 |
19 | @INC = ('../lib','.'); |
20 | do "re/ReTest.pl" or die $@; |
e425a60b |
21 | } |
e425a60b |
22 | |
e425a60b |
23 | |
9d45b377 |
24 | plan tests => 11; # Update this when adding/deleting tests. |
e425a60b |
25 | |
9d45b377 |
26 | run_tests() unless caller; |
e425a60b |
27 | |
28 | # |
29 | # Tests start here. |
30 | # |
31 | sub run_tests { |
32 | |
9d45b377 |
33 | SKIP: |
e425a60b |
34 | { |
9d45b377 |
35 | print "# Set PERL_SKIP_PSYCHO_TEST to skip this test\n"; |
36 | my @normal = qw [the are some normal words]; |
e425a60b |
37 | |
9d45b377 |
38 | skip "Skipped Psycho", 2 * @normal if $ENV {PERL_SKIP_PSYCHO_TEST}; |
e425a60b |
39 | |
9d45b377 |
40 | local $" = "|"; |
e425a60b |
41 | |
9d45b377 |
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]; |
e425a60b |
47 | } |
9d45b377 |
48 | my $psycho2 = "@psycho"; |
e425a60b |
49 | |
9d45b377 |
50 | foreach my $word (@normal) { |
51 | ok $word =~ /($psycho1)/ && $1 eq $word, 'Psycho'; |
52 | ok $word =~ /($psycho2)/ && $1 eq $word, 'Psycho'; |
e425a60b |
53 | } |
54 | } |
55 | |
56 | |
9d45b377 |
57 | SKIP: |
e425a60b |
58 | { |
9d45b377 |
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 |
e425a60b |
65 | |
9d45b377 |
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 | } |
e425a60b |
158 | } |
9d45b377 |
159 | ok($ok, $msg); |
e425a60b |
160 | } |
e425a60b |
161 | } # End of sub run_tests |
162 | |
163 | 1; |