Commit | Line | Data |
0f289c68 |
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 => 123; # 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 | local $Message = "Call code from qr //"; |
34 | local $_ = 'var="foo"'; |
35 | $a = qr/(?{++$b})/; |
36 | $b = 7; |
37 | ok /$a$a/ && $b eq '9'; |
38 | |
39 | my $c="$a"; |
40 | ok /$a$a/ && $b eq '11'; |
41 | |
42 | undef $@; |
43 | eval {/$c/}; |
44 | ok $@ && $@ =~ /not allowed at runtime/; |
45 | |
46 | use re "eval"; |
47 | /$a$c$a/; |
48 | iseq $b, '14'; |
49 | |
50 | our $lex_a = 43; |
51 | our $lex_b = 17; |
52 | our $lex_c = 27; |
53 | my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/); |
54 | |
55 | iseq $lex_res, 1; |
56 | iseq $lex_a, 44; |
57 | iseq $lex_c, 43; |
58 | |
59 | no re "eval"; |
60 | undef $@; |
61 | my $match = eval { /$a$c$a/ }; |
62 | ok $@ && $@ =~ /Eval-group not allowed/ && !$match; |
63 | iseq $b, '14'; |
64 | |
65 | $lex_a = 2; |
66 | $lex_a = 43; |
67 | $lex_b = 17; |
68 | $lex_c = 27; |
69 | $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/); |
70 | |
71 | iseq $lex_res, 1; |
72 | iseq $lex_a, 44; |
73 | iseq $lex_c, 43; |
74 | |
75 | } |
76 | |
77 | { |
78 | our $a = bless qr /foo/ => 'Foo'; |
79 | ok 'goodfood' =~ $a, "Reblessed qr // matches"; |
80 | iseq $a, '(?-xism:foo)', "Reblessed qr // stringifies"; |
81 | my $x = "\x{3fe}"; |
82 | my $z = my $y = "\317\276"; # Byte representation of $x |
83 | $a = qr /$x/; |
84 | ok $x =~ $a, "UTF-8 interpolation in qr //"; |
85 | ok "a$a" =~ $x, "Stringified qr // preserves UTF-8"; |
86 | ok "a$x" =~ /^a$a\z/, "Interpolated qr // preserves UTF-8"; |
87 | ok "a$x" =~ /^a(??{$a})\z/, |
88 | "Postponed interpolation of qr // preserves UTF-8"; |
89 | { |
90 | local $BugId = '17776'; |
91 | iseq length qr /##/x, 12, "## in qr // doesn't corrupt memory"; |
92 | } |
93 | { |
94 | use re 'eval'; |
95 | ok "$x$x" =~ /^$x(??{$x})\z/, |
96 | "Postponed UTF-8 string in UTF-8 re matches UTF-8"; |
97 | ok "$y$x" =~ /^$y(??{$x})\z/, |
98 | "Postponed UTF-8 string in non-UTF-8 re matches UTF-8"; |
99 | ok "$y$x" !~ /^$y(??{$y})\z/, |
100 | "Postponed non-UTF-8 string in non-UTF-8 re doesn't match UTF-8"; |
101 | ok "$x$x" !~ /^$x(??{$y})\z/, |
102 | "Postponed non-UTF-8 string in UTF-8 re doesn't match UTF-8"; |
103 | ok "$y$y" =~ /^$y(??{$y})\z/, |
104 | "Postponed non-UTF-8 string in non-UTF-8 re matches non-UTF8"; |
105 | ok "$x$y" =~ /^$x(??{$y})\z/, |
106 | "Postponed non-UTF-8 string in UTF-8 re matches non-UTF8"; |
107 | |
108 | $y = $z; # Reset $y after upgrade. |
109 | ok "$x$y" !~ /^$x(??{$x})\z/, |
110 | "Postponed UTF-8 string in UTF-8 re doesn't match non-UTF-8"; |
111 | ok "$y$y" !~ /^$y(??{$x})\z/, |
112 | "Postponed UTF-8 string in non-UTF-8 re doesn't match non-UTF-8"; |
113 | } |
114 | } |
115 | |
116 | |
117 | { |
118 | use re 'eval'; |
119 | local $Message = 'Test if $^N and $+ work in (?{{})'; |
120 | our @ctl_n = (); |
121 | our @plus = (); |
122 | our $nested_tags; |
123 | $nested_tags = qr{ |
124 | < |
125 | ((\w)+) |
126 | (?{ |
127 | push @ctl_n, (defined $^N ? $^N : "undef"); |
128 | push @plus, (defined $+ ? $+ : "undef"); |
129 | }) |
130 | > |
131 | (??{$nested_tags})* |
132 | </\s* \w+ \s*> |
133 | }x; |
134 | |
135 | |
136 | my $c = 0; |
137 | for my $test ( |
138 | # Test structure: |
139 | # [ Expected result, Regex, Expected value(s) of $^N, Expected value(s) of $+ ] |
140 | [ 1, qr#^$nested_tags$#, "bla blubb bla", "a b a" ], |
141 | [ 1, qr#^($nested_tags)$#, "bla blubb <bla><blubb></blubb></bla>", "a b a" ], |
142 | [ 1, qr#^(|)$nested_tags$#, "bla blubb bla", "a b a" ], |
143 | [ 1, qr#^(?:|)$nested_tags$#, "bla blubb bla", "a b a" ], |
144 | [ 1, qr#^<(bl|bla)>$nested_tags<(/\1)>$#, "blubb /bla", "b /bla" ], |
145 | [ 1, qr#(??{"(|)"})$nested_tags$#, "bla blubb bla", "a b a" ], |
146 | [ 1, qr#^(??{"(bla|)"})$nested_tags$#, "bla blubb bla", "a b a" ], |
147 | [ 1, qr#^(??{"(|)"})(??{$nested_tags})$#, "bla blubb undef", "a b undef" ], |
148 | [ 1, qr#^(??{"(?:|)"})$nested_tags$#, "bla blubb bla", "a b a" ], |
149 | [ 1, qr#^((??{"(?:bla|)"}))((??{$nested_tags}))$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ], |
150 | [ 1, qr#^((??{"(?!)?"}))((??{$nested_tags}))$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ], |
151 | [ 1, qr#^((??{"(?:|<(/?bla)>)"}))((??{$nested_tags}))\1$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ], |
152 | [ 0, qr#^((??{"(?!)"}))?((??{$nested_tags}))(?!)$#, "bla blubb undef", "a b undef" ], |
153 | |
154 | ) { #"#silence vim highlighting |
155 | $c++; |
156 | @ctl_n = (); |
157 | @plus = (); |
158 | my $match = (("<bla><blubb></blubb></bla>" =~ $test->[1]) ? 1 : 0); |
159 | push @ctl_n, (defined $^N ? $^N : "undef"); |
160 | push @plus, (defined $+ ? $+ : "undef"); |
161 | ok($test->[0] == $match, "match $c"); |
162 | if ($test->[0] != $match) { |
163 | # unset @ctl_n and @plus |
164 | @ctl_n = @plus = (); |
165 | } |
166 | iseq("@ctl_n", $test->[2], "ctl_n $c"); |
167 | iseq("@plus", $test->[3], "plus $c"); |
168 | } |
169 | } |
170 | |
171 | { |
172 | use re 'eval'; |
173 | local $BugId = '56194'; |
174 | |
175 | our $f; |
176 | local $f; |
177 | $f = sub { |
178 | defined $_[0] ? $_[0] : "undef"; |
179 | }; |
180 | |
181 | ok("123" =~ m/^(\d)(((??{1 + $^N})))+$/); |
182 | |
183 | our @ctl_n; |
184 | our @plus; |
185 | |
186 | my $re = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))*(?{$^N})#; |
187 | my $re2 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))*(?{$^N})(|a(b)c|def)(??{"$^R"})#; |
188 | my $re3 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})){2}(?{$^N})(|a(b)c|def)(??{"$^R"})#; |
189 | our $re5; |
190 | local $re5 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})){2}(?{$^N})#; |
191 | my $re6 = qr#(??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})#; |
192 | my $re7 = qr#(??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})#; |
193 | my $re8 = qr/(\d+)/; |
194 | my $c = 0; |
195 | for my $test ( |
196 | # Test structure: |
197 | # [ |
198 | # String to match |
199 | # Regex too match |
200 | # Expected values of $^N |
201 | # Expected values of $+ |
202 | # Expected values of $1, $2, $3, $4 and $5 |
203 | # ] |
204 | [ |
205 | "1233", |
206 | qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(??{$^N})$#, |
207 | "1 2 3 3", |
208 | "1 2 3 3", |
209 | "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", |
210 | ], |
211 | [ |
212 | "1233", |
213 | qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(abc|def|)?(??{$+})$#, |
214 | "1 2 3 3", |
215 | "1 2 3 3", |
216 | "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", |
217 | ], |
218 | [ |
219 | "1233", |
220 | qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(|abc|def)?(??{$+})$#, |
221 | "1 2 3 3", |
222 | "1 2 3 3", |
223 | "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", |
224 | ], |
225 | [ |
226 | "1233", |
227 | qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(abc|def|)?(??{$^N})$#, |
228 | "1 2 3 3", |
229 | "1 2 3 3", |
230 | "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", |
231 | ], |
232 | [ |
233 | "1233", |
234 | qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(|abc|def)?(??{$^N})$#, |
235 | "1 2 3 3", |
236 | "1 2 3 3", |
237 | "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", |
238 | ], |
239 | [ |
240 | "123abc3", |
241 | qr#^($re)(|a(b)c|def)(??{$^R})$#, |
242 | "1 2 3 abc", |
243 | "1 2 3 b", |
244 | "\$1 = 123, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b", |
245 | ], |
246 | [ |
247 | "123abc3", |
248 | qr#^($re2)$#, |
249 | "1 2 3 123abc3", |
250 | "1 2 3 b", |
251 | "\$1 = 123abc3, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b", |
252 | ], |
253 | [ |
254 | "123abc3", |
255 | qr#^($re3)$#, |
256 | "1 2 123abc3", |
257 | "1 2 b", |
258 | "\$1 = 123abc3, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b", |
259 | ], |
260 | [ |
261 | "123abc3", |
262 | qr#^(??{$re5})(|abc|def)(??{"$^R"})$#, |
263 | "1 2 abc", |
264 | "1 2 abc", |
265 | "\$1 = abc, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef", |
266 | ], |
267 | [ |
268 | "123abc3", |
269 | qr#^(??{$re5})(|a(b)c|def)(??{"$^R"})$#, |
270 | "1 2 abc", |
271 | "1 2 b", |
272 | "\$1 = abc, \$2 = b, \$3 = undef, \$4 = undef, \$5 = undef", |
273 | ], |
274 | [ |
275 | "1234", |
276 | qr#^((\d+)((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1}))((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1}))((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1})))$#, |
277 | "1234 123 12 1 2 3 1234", |
278 | "1234 123 12 1 2 3 4", |
279 | "\$1 = 1234, \$2 = 1, \$3 = 2, \$4 = 3, \$5 = 4", |
280 | ], |
281 | [ |
282 | "1234556", |
283 | qr#^(\d+)($re6)($re6)($re6)$re6(($re6)$re6)$#, |
284 | "1234556 123455 12345 1234 123 12 1 2 3 4 4 5 56", |
285 | "1234556 123455 12345 1234 123 12 1 2 3 4 4 5 5", |
286 | "\$1 = 1, \$2 = 2, \$3 = 3, \$4 = 4, \$5 = 56", |
287 | ], |
288 | [ |
289 | "12345562", |
290 | qr#^((??{$re8}))($re7)($re7)($re7)$re7($re7)($re7(\2))$#, |
291 | "12345562 1234556 123455 12345 1234 123 12 1 2 3 4 4 5 62", |
292 | "12345562 1234556 123455 12345 1234 123 12 1 2 3 4 4 5 2", |
293 | "\$1 = 1, \$2 = 2, \$3 = 3, \$4 = 4, \$5 = 5", |
294 | ], |
295 | ) { |
296 | $c++; |
297 | @ctl_n = (); |
298 | @plus = (); |
299 | undef $^R; |
300 | my $match = $test->[0] =~ $test->[1]; |
301 | my $str = join(", ", '$1 = '.$f->($1), '$2 = '.$f->($2), '$3 = '.$f->($3), '$4 = '.$f->($4),'$5 = '.$f->($5)); |
302 | push @ctl_n, $f->($^N); |
303 | push @plus, $f->($+); |
304 | ok($match, "match $c"); |
305 | if (not $match) { |
306 | # unset $str, @ctl_n and @plus |
307 | $str = ""; |
308 | @ctl_n = @plus = (); |
309 | } |
310 | iseq("@ctl_n", $test->[2], "ctl_n $c"); |
311 | iseq("@plus", $test->[3], "plus $c"); |
312 | iseq($str, $test->[4], "str $c"); |
313 | } |
314 | SKIP: { |
315 | if ($] le '5.010') { |
316 | skip "test segfaults on perl < 5.10", 4; |
317 | } |
318 | |
319 | @ctl_n = (); |
320 | @plus = (); |
321 | |
322 | our $re4; |
323 | local $re4 = qr#(1)((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1})){2}(?{$^N})(|abc|def)(??{"$^R"})#; |
324 | undef $^R; |
325 | my $match = "123abc3" =~ m/^(??{$re4})$/; |
326 | my $str = join(", ", '$1 = '.$f->($1), '$2 = '.$f->($2), '$3 = '.$f->($3), '$4 = '.$f->($4),'$5 = '.$f->($5),'$^R = '.$f->($^R)); |
327 | push @ctl_n, $f->($^N); |
328 | push @plus, $f->($+); |
329 | ok($match); |
330 | if (not $match) { |
331 | # unset $str |
332 | @ctl_n = (); |
333 | @plus = (); |
334 | $str = ""; |
335 | } |
336 | iseq("@ctl_n", "1 2 undef"); |
337 | iseq("@plus", "1 2 undef"); |
338 | iseq($str, "\$1 = undef, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef, \$^R = undef"); |
339 | } |
340 | } |
341 | |
342 | } # End of sub run_tests |
343 | |
344 | 1; |