This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Eliminate nok() from ReTest.pl by refactoring all uses to other test functions.
[perl5.git] / t / re / pat_re_eval.t
CommitLineData
0f289c68
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.
6
7use strict;
8use warnings;
9use 5.010;
10
11
12sub run_tests;
13
14$| = 1;
15
16
17BEGIN {
18 chdir 't' if -d 't';
19 @INC = ('../lib','.');
20 do "re/ReTest.pl" or die $@;
21}
22
23
24plan tests => 123; # Update this when adding/deleting tests.
25
26run_tests() unless caller;
27
28#
29# Tests start here.
30#
31sub run_tests {
32 {
f245da07 33 my $message = "Call code from qr //";
0f289c68
YO
34 local $_ = 'var="foo"';
35 $a = qr/(?{++$b})/;
36 $b = 7;
f245da07 37 ok(/$a$a/ && $b eq '9', $message);
0f289c68
YO
38
39 my $c="$a";
f245da07 40 ok(/$a$a/ && $b eq '11', $message);
0f289c68
YO
41
42 undef $@;
43 eval {/$c/};
f245da07 44 like($@, qr/not allowed at runtime/, $message);
0f289c68
YO
45
46 use re "eval";
47 /$a$c$a/;
f245da07 48 is($b, '14', $message);
0f289c68
YO
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
f245da07
NC
55 is($lex_res, 1, $message);
56 is($lex_a, 44, $message);
57 is($lex_c, 43, $message);
0f289c68
YO
58
59 no re "eval";
60 undef $@;
61 my $match = eval { /$a$c$a/ };
f245da07
NC
62 ok($@ && $@ =~ /Eval-group not allowed/ && !$match, $message);
63 is($b, '14', $message);
0f289c68
YO
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
f245da07
NC
71 is($lex_res, 1, $message);
72 is($lex_a, 44, $message);
73 is($lex_c, 43, $message);
0f289c68
YO
74
75 }
76
77 {
78 our $a = bless qr /foo/ => 'Foo';
79 ok 'goodfood' =~ $a, "Reblessed qr // matches";
fb85c044 80 iseq $a, '(?^:foo)', "Reblessed qr // stringifies";
0f289c68
YO
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";
bb535cf1
NC
89
90
91 is(length qr /##/x, 9, "## in qr // doesn't corrupt memory; Bug 17776");
92
0f289c68
YO
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';
f245da07 119 # Test if $^N and $+ work in (?{{})
0f289c68
YO
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';
bb535cf1 173
0f289c68
YO
174
175 our $f;
176 local $f;
177 $f = sub {
178 defined $_[0] ? $_[0] : "undef";
179 };
180
bb535cf1 181 like("123", qr/^(\d)(((??{1 + $^N})))+$/, "Noname test; Bug 56194");
0f289c68
YO
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->($+);
bb535cf1 304 ok($match, "match $c; Bug 56194");
0f289c68
YO
305 if (not $match) {
306 # unset $str, @ctl_n and @plus
307 $str = "";
308 @ctl_n = @plus = ();
309 }
bb535cf1
NC
310 is("@ctl_n", $test->[2], "ctl_n $c; Bug 56194");
311 is("@plus", $test->[3], "plus $c; Bug 56194");
312 is($str, $test->[4], "str $c; Bug 56194");
0f289c68
YO
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->($+);
bb535cf1 329 ok($match, "Noname test; Bug 56194");
0f289c68
YO
330 if (not $match) {
331 # unset $str
332 @ctl_n = ();
333 @plus = ();
334 $str = "";
335 }
bb535cf1
NC
336 is("@ctl_n", "1 2 undef", "Noname test; Bug 56194");
337 is("@plus", "1 2 undef", "Noname test; Bug 56194");
338 is($str, "\$1 = undef, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef, \$^R = undef", "Noname test; Bug 56194");
0f289c68
YO
339 }
340 }
341
342} # End of sub run_tests
343
3441;