This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
avoid double-freeing regex code blocks
[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;
04e69edb 9use Config;
0f289c68
YO
10use 5.010;
11
12
13sub run_tests;
14
15$| = 1;
16
17
18BEGIN {
19 chdir 't' if -d 't';
6aec1cbc 20 require './test.pl'; require './charset_tools.pl';
43ece5b1 21 set_up_inc('../lib');
0f289c68
YO
22}
23
24
f8def6c7 25plan tests => 529; # Update this when adding/deleting tests.
0f289c68
YO
26
27run_tests() unless caller;
28
1008bb63
DM
29# test that runtime code without 'use re eval' is trapped
30
31sub norun {
32 like($@, qr/Eval-group not allowed at runtime/, @_);
33}
34
0f289c68
YO
35#
36# Tests start here.
37#
38sub run_tests {
39 {
f245da07 40 my $message = "Call code from qr //";
0f289c68
YO
41 local $_ = 'var="foo"';
42 $a = qr/(?{++$b})/;
43 $b = 7;
f245da07 44 ok(/$a$a/ && $b eq '9', $message);
0f289c68
YO
45
46 my $c="$a";
f245da07 47 ok(/$a$a/ && $b eq '11', $message);
0f289c68
YO
48
49 undef $@;
50 eval {/$c/};
1008bb63 51 norun("$message norun 1");
0f289c68 52
1008bb63
DM
53
54 {
55 eval {/$a$c$a/};
56 norun("$message norun 2");
57 use re "eval";
58 /$a$c$a/;
59 is($b, '14', $message);
60 }
0f289c68
YO
61
62 our $lex_a = 43;
63 our $lex_b = 17;
64 our $lex_c = 27;
65 my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/);
66
f245da07
NC
67 is($lex_res, 1, $message);
68 is($lex_a, 44, $message);
69 is($lex_c, 43, $message);
0f289c68 70
0f289c68 71 undef $@;
b30fcab9
DM
72 my $d = '(?{1})';
73 my $match = eval { /$a$c$a$d/ };
f245da07
NC
74 ok($@ && $@ =~ /Eval-group not allowed/ && !$match, $message);
75 is($b, '14', $message);
0f289c68
YO
76
77 $lex_a = 2;
78 $lex_a = 43;
79 $lex_b = 17;
80 $lex_c = 27;
81 $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/);
82
f245da07
NC
83 is($lex_res, 1, $message);
84 is($lex_a, 44, $message);
85 is($lex_c, 43, $message);
0f289c68
YO
86
87 }
88
89 {
90 our $a = bless qr /foo/ => 'Foo';
91 ok 'goodfood' =~ $a, "Reblessed qr // matches";
de26e0cc 92 is($a, '(?^:foo)', "Reblessed qr // stringifies");
0f289c68 93 my $x = "\x{3fe}";
6aec1cbc
KW
94 my $z = my $y = byte_utf8a_to_utf8n("\317\276"); # Byte representation
95 # of $x
0f289c68
YO
96 $a = qr /$x/;
97 ok $x =~ $a, "UTF-8 interpolation in qr //";
98 ok "a$a" =~ $x, "Stringified qr // preserves UTF-8";
99 ok "a$x" =~ /^a$a\z/, "Interpolated qr // preserves UTF-8";
100 ok "a$x" =~ /^a(??{$a})\z/,
101 "Postponed interpolation of qr // preserves UTF-8";
bb535cf1
NC
102
103
104 is(length qr /##/x, 9, "## in qr // doesn't corrupt memory; Bug 17776");
105
0f289c68 106 {
0f289c68
YO
107 ok "$x$x" =~ /^$x(??{$x})\z/,
108 "Postponed UTF-8 string in UTF-8 re matches UTF-8";
109 ok "$y$x" =~ /^$y(??{$x})\z/,
110 "Postponed UTF-8 string in non-UTF-8 re matches UTF-8";
111 ok "$y$x" !~ /^$y(??{$y})\z/,
112 "Postponed non-UTF-8 string in non-UTF-8 re doesn't match UTF-8";
113 ok "$x$x" !~ /^$x(??{$y})\z/,
114 "Postponed non-UTF-8 string in UTF-8 re doesn't match UTF-8";
115 ok "$y$y" =~ /^$y(??{$y})\z/,
116 "Postponed non-UTF-8 string in non-UTF-8 re matches non-UTF8";
117 ok "$x$y" =~ /^$x(??{$y})\z/,
118 "Postponed non-UTF-8 string in UTF-8 re matches non-UTF8";
119
120 $y = $z; # Reset $y after upgrade.
121 ok "$x$y" !~ /^$x(??{$x})\z/,
122 "Postponed UTF-8 string in UTF-8 re doesn't match non-UTF-8";
123 ok "$y$y" !~ /^$y(??{$x})\z/,
124 "Postponed UTF-8 string in non-UTF-8 re doesn't match non-UTF-8";
125 }
126 }
127
128
129 {
1008bb63 130 # Test if $^N and $+ work in (?{})
0f289c68
YO
131 our @ctl_n = ();
132 our @plus = ();
133 our $nested_tags;
134 $nested_tags = qr{
135 <
136 ((\w)+)
137 (?{
138 push @ctl_n, (defined $^N ? $^N : "undef");
139 push @plus, (defined $+ ? $+ : "undef");
140 })
141 >
142 (??{$nested_tags})*
143 </\s* \w+ \s*>
144 }x;
145
146
147 my $c = 0;
148 for my $test (
149 # Test structure:
150 # [ Expected result, Regex, Expected value(s) of $^N, Expected value(s) of $+ ]
151 [ 1, qr#^$nested_tags$#, "bla blubb bla", "a b a" ],
152 [ 1, qr#^($nested_tags)$#, "bla blubb <bla><blubb></blubb></bla>", "a b a" ],
153 [ 1, qr#^(|)$nested_tags$#, "bla blubb bla", "a b a" ],
154 [ 1, qr#^(?:|)$nested_tags$#, "bla blubb bla", "a b a" ],
155 [ 1, qr#^<(bl|bla)>$nested_tags<(/\1)>$#, "blubb /bla", "b /bla" ],
156 [ 1, qr#(??{"(|)"})$nested_tags$#, "bla blubb bla", "a b a" ],
157 [ 1, qr#^(??{"(bla|)"})$nested_tags$#, "bla blubb bla", "a b a" ],
158 [ 1, qr#^(??{"(|)"})(??{$nested_tags})$#, "bla blubb undef", "a b undef" ],
159 [ 1, qr#^(??{"(?:|)"})$nested_tags$#, "bla blubb bla", "a b a" ],
160 [ 1, qr#^((??{"(?:bla|)"}))((??{$nested_tags}))$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ],
161 [ 1, qr#^((??{"(?!)?"}))((??{$nested_tags}))$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ],
162 [ 1, qr#^((??{"(?:|<(/?bla)>)"}))((??{$nested_tags}))\1$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ],
163 [ 0, qr#^((??{"(?!)"}))?((??{$nested_tags}))(?!)$#, "bla blubb undef", "a b undef" ],
164
165 ) { #"#silence vim highlighting
166 $c++;
167 @ctl_n = ();
168 @plus = ();
169 my $match = (("<bla><blubb></blubb></bla>" =~ $test->[1]) ? 1 : 0);
170 push @ctl_n, (defined $^N ? $^N : "undef");
171 push @plus, (defined $+ ? $+ : "undef");
172 ok($test->[0] == $match, "match $c");
173 if ($test->[0] != $match) {
174 # unset @ctl_n and @plus
175 @ctl_n = @plus = ();
176 }
de26e0cc
NC
177 is("@ctl_n", $test->[2], "ctl_n $c");
178 is("@plus", $test->[3], "plus $c");
0f289c68
YO
179 }
180 }
181
182 {
0f289c68
YO
183 our $f;
184 local $f;
185 $f = sub {
186 defined $_[0] ? $_[0] : "undef";
187 };
188
4b0d13b9 189 like("123", qr/^(\d)(((??{1 + $^N})))+$/, 'Bug 56194');
0f289c68
YO
190
191 our @ctl_n;
192 our @plus;
193
194 my $re = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))*(?{$^N})#;
195 my $re2 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))*(?{$^N})(|a(b)c|def)(??{"$^R"})#;
196 my $re3 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})){2}(?{$^N})(|a(b)c|def)(??{"$^R"})#;
197 our $re5;
198 local $re5 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})){2}(?{$^N})#;
199 my $re6 = qr#(??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})#;
200 my $re7 = qr#(??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})#;
201 my $re8 = qr/(\d+)/;
202 my $c = 0;
203 for my $test (
204 # Test structure:
205 # [
206 # String to match
207 # Regex too match
208 # Expected values of $^N
209 # Expected values of $+
210 # Expected values of $1, $2, $3, $4 and $5
211 # ]
212 [
213 "1233",
214 qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(??{$^N})$#,
215 "1 2 3 3",
216 "1 2 3 3",
217 "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
218 ],
219 [
220 "1233",
221 qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(abc|def|)?(??{$+})$#,
222 "1 2 3 3",
223 "1 2 3 3",
224 "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
225 ],
226 [
227 "1233",
228 qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(|abc|def)?(??{$+})$#,
229 "1 2 3 3",
230 "1 2 3 3",
231 "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
232 ],
233 [
234 "1233",
235 qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(abc|def|)?(??{$^N})$#,
236 "1 2 3 3",
237 "1 2 3 3",
238 "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
239 ],
240 [
241 "1233",
242 qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(|abc|def)?(??{$^N})$#,
243 "1 2 3 3",
244 "1 2 3 3",
245 "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
246 ],
247 [
248 "123abc3",
249 qr#^($re)(|a(b)c|def)(??{$^R})$#,
250 "1 2 3 abc",
251 "1 2 3 b",
252 "\$1 = 123, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b",
253 ],
254 [
255 "123abc3",
256 qr#^($re2)$#,
257 "1 2 3 123abc3",
258 "1 2 3 b",
259 "\$1 = 123abc3, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b",
260 ],
261 [
262 "123abc3",
263 qr#^($re3)$#,
264 "1 2 123abc3",
265 "1 2 b",
266 "\$1 = 123abc3, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b",
267 ],
268 [
269 "123abc3",
270 qr#^(??{$re5})(|abc|def)(??{"$^R"})$#,
271 "1 2 abc",
272 "1 2 abc",
273 "\$1 = abc, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef",
274 ],
275 [
276 "123abc3",
277 qr#^(??{$re5})(|a(b)c|def)(??{"$^R"})$#,
278 "1 2 abc",
279 "1 2 b",
280 "\$1 = abc, \$2 = b, \$3 = undef, \$4 = undef, \$5 = undef",
281 ],
282 [
283 "1234",
284 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})))$#,
285 "1234 123 12 1 2 3 1234",
286 "1234 123 12 1 2 3 4",
287 "\$1 = 1234, \$2 = 1, \$3 = 2, \$4 = 3, \$5 = 4",
288 ],
289 [
290 "1234556",
291 qr#^(\d+)($re6)($re6)($re6)$re6(($re6)$re6)$#,
292 "1234556 123455 12345 1234 123 12 1 2 3 4 4 5 56",
293 "1234556 123455 12345 1234 123 12 1 2 3 4 4 5 5",
294 "\$1 = 1, \$2 = 2, \$3 = 3, \$4 = 4, \$5 = 56",
295 ],
296 [
297 "12345562",
298 qr#^((??{$re8}))($re7)($re7)($re7)$re7($re7)($re7(\2))$#,
299 "12345562 1234556 123455 12345 1234 123 12 1 2 3 4 4 5 62",
300 "12345562 1234556 123455 12345 1234 123 12 1 2 3 4 4 5 2",
301 "\$1 = 1, \$2 = 2, \$3 = 3, \$4 = 4, \$5 = 5",
302 ],
303 ) {
304 $c++;
305 @ctl_n = ();
306 @plus = ();
307 undef $^R;
308 my $match = $test->[0] =~ $test->[1];
309 my $str = join(", ", '$1 = '.$f->($1), '$2 = '.$f->($2), '$3 = '.$f->($3), '$4 = '.$f->($4),'$5 = '.$f->($5));
310 push @ctl_n, $f->($^N);
311 push @plus, $f->($+);
bb535cf1 312 ok($match, "match $c; Bug 56194");
0f289c68
YO
313 if (not $match) {
314 # unset $str, @ctl_n and @plus
315 $str = "";
316 @ctl_n = @plus = ();
317 }
bb535cf1
NC
318 is("@ctl_n", $test->[2], "ctl_n $c; Bug 56194");
319 is("@plus", $test->[3], "plus $c; Bug 56194");
320 is($str, $test->[4], "str $c; Bug 56194");
0f289c68 321 }
0f289c68 322
1008bb63 323 {
0f289c68
YO
324 @ctl_n = ();
325 @plus = ();
326
327 our $re4;
328 local $re4 = qr#(1)((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1})){2}(?{$^N})(|abc|def)(??{"$^R"})#;
329 undef $^R;
330 my $match = "123abc3" =~ m/^(??{$re4})$/;
331 my $str = join(", ", '$1 = '.$f->($1), '$2 = '.$f->($2), '$3 = '.$f->($3), '$4 = '.$f->($4),'$5 = '.$f->($5),'$^R = '.$f->($^R));
332 push @ctl_n, $f->($^N);
333 push @plus, $f->($+);
4b0d13b9 334 ok($match, 'Bug 56194');
0f289c68
YO
335 if (not $match) {
336 # unset $str
337 @ctl_n = ();
338 @plus = ();
339 $str = "";
340 }
4b0d13b9
NC
341 is("@ctl_n", "1 2 undef", 'Bug 56194');
342 is("@plus", "1 2 undef", 'Bug 56194');
343 is($str,
4b22688e
YO
344 "\$1 = undef, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef, \$^R = 3",
345 'Bug 56194 ($^R tweaked by 121070)');
346 }
347 {
348 undef $^R;
349 "abcd"=~/(?<Char>.)(?&Char)(?{ 42 })/;
350 is("$^R", 42, 'Bug 121070 - use of (?&Char) should not clobber $^R');
351 "abcd"=~/(?<Char>.)(?&Char)(?{ 42 })(?{ 43 })/;
352 is("$^R", 43, 'related to 121070 - use of (?&Char) should not clobber $^R');
0f289c68
YO
353 }
354 }
355
d3cec5e5
DM
356 {
357 # re evals within \U, \Q etc shouldn't be seen by the lexer
358 local our $a = "i";
359 local our $B = "J";
360 ok('(?{1})' =~ /^\Q(?{1})\E$/, '\Q(?{1})\E');
361 ok('(?{1})' =~ /^\Q(?{\E1\}\)$/, '\Q(?{\E1\}\)');
1008bb63
DM
362 eval {/^\U(??{"$a\Ea"})$/ }; norun('^\U(??{"$a\Ea"})$ norun');
363 eval {/^\L(??{"$B\Ea"})$/ }; norun('^\L(??{"$B\Ea"})$ norun');
d3cec5e5
DM
364 use re 'eval';
365 ok('Ia' =~ /^\U(??{"$a\Ea"})$/, '^\U(??{"$a\Ea"})$');
366 ok('ja' =~ /^\L(??{"$B\Ea"})$/, '^\L(??{"$B\Ea"})$');
367 }
368
a39c66b9
DM
369 {
370 # Comprehensive (hopefully) tests of closure behaviour:
371 # i.e. when do (?{}) blocks get (re)compiled, and what instances
372 # of lexical vars do they close over?
373
947535e3
DM
374 # if the pattern string gets utf8 upgraded while concatenating,
375 # make sure a literal code block is still detected (by still
376 # compiling in the absence of use re 'eval')
377
378 {
379 my $s1 = "\x{80}";
380 my $s2 = "\x{100}";
381 ok("\x{80}\x{100}" =~ /^$s1(?{1})$s2$/, "utf8 upgrade");
382 }
383
a39c66b9
DM
384 my ($cr1, $cr2, $cr3, $cr4);
385
a39c66b9
DM
386 for my $x (qw(a b c)) {
387 my $bc = ($x ne 'a');
2bd8e0da 388 my $c80 = chr(0x80);
a39c66b9
DM
389
390 # the most basic: literal code should be in same scope
391 # as the parent
392
2bd8e0da
DM
393 ok("A$x" =~ /^A(??{$x})$/, "[$x] literal code");
394 ok("\x{100}$x" =~ /^\x{100}(??{$x})$/, "[$x] literal code UTF8");
a39c66b9
DM
395
396 # the "don't recompile if pattern unchanged" mechanism
397 # shouldn't apply to code blocks - recompile every time
398 # to pick up new instances of variables
399
2bd8e0da
DM
400 my $code1 = 'B(??{$x})';
401 my $code1u = $c80 . "\x{100}" . '(??{$x})';
1008bb63
DM
402
403 eval {/^A$code1$/};
404 norun("[$x] unvarying runtime code AA norun");
405 eval {/^A$code1u$/};
406 norun("[$x] unvarying runtime code AU norun");
407 eval {/^$c80\x{100}$code1$/};
408 norun("[$x] unvarying runtime code UA norun");
409 eval {/^$c80\x{101}$code1u$/};
410 norun("[$x] unvarying runtime code UU norun");
411
412 {
413 use re 'eval';
414 ok("AB$x" =~ /^A$code1$/, "[$x] unvarying runtime code AA");
415 ok("A$c80\x{100}$x" =~ /^A$code1u$/,
416 "[$x] unvarying runtime code AU");
417 ok("$c80\x{100}B$x" =~ /^$c80\x{100}$code1$/,
418 "[$x] unvarying runtime code UA");
419 ok("$c80\x{101}$c80\x{100}$x" =~ /^$c80\x{101}$code1u$/,
420 "[$x] unvarying runtime code UU");
421 }
a39c66b9
DM
422
423 # mixed literal and run-time code blocks
424
2bd8e0da
DM
425 my $code2 = 'B(??{$x})';
426 my $code2u = $c80 . "\x{100}" . '(??{$x})';
1008bb63
DM
427
428 eval {/^A(??{$x})-$code2$/};
429 norun("[$x] literal+runtime AA norun");
430 eval {/^A(??{$x})-$code2u$/};
431 norun("[$x] literal+runtime AU norun");
432 eval {/^$c80\x{100}(??{$x})-$code2$/};
433 norun("[$x] literal+runtime UA norun");
434 eval {/^$c80\x{101}(??{$x})-$code2u$/};
435 norun("[$x] literal+runtime UU norun");
436
437 {
438 use re 'eval';
439 ok("A$x-B$x" =~ /^A(??{$x})-$code2$/,
440 "[$x] literal+runtime AA");
441 ok("A$x-$c80\x{100}$x" =~ /^A(??{$x})-$code2u$/,
442 "[$x] literal+runtime AU");
443 ok("$c80\x{100}$x-B$x" =~ /^$c80\x{100}(??{$x})-$code2$/,
444 "[$x] literal+runtime UA");
445 ok("$c80\x{101}$x-$c80\x{100}$x"
446 =~ /^$c80\x{101}(??{$x})-$code2u$/,
447 "[$x] literal+runtime UU");
448 }
fdfac248 449
a39c66b9
DM
450 # literal qr code only created once, naked
451
452 $cr1 //= qr/^A(??{$x})$/;
d63c20f2 453 ok("Aa" =~ $cr1, "[$x] literal qr once naked");
a39c66b9
DM
454
455 # literal qr code only created once, embedded with text
456
457 $cr2 //= qr/B(??{$x})$/;
346d3070 458 ok("ABa" =~ /^A$cr2/, "[$x] literal qr once embedded text");
a39c66b9
DM
459
460 # literal qr code only created once, embedded with text + lit code
461
462 $cr3 //= qr/C(??{$x})$/;
346d3070 463 ok("A$x-BCa" =~ /^A(??{$x})-B$cr3/,
a39c66b9
DM
464 "[$x] literal qr once embedded text + lit code");
465
466 # literal qr code only created once, embedded with text + run code
467
468 $cr4 //= qr/C(??{$x})$/;
469 my $code3 = 'A(??{$x})';
fbf5ab7b 470
1008bb63
DM
471 eval {/^$code3-B$cr4/};
472 norun("[$x] literal qr once embedded text + run code norun");
473 {
474 use re 'eval';
475 ok("A$x-BCa" =~ /^$code3-B$cr4/,
a39c66b9 476 "[$x] literal qr once embedded text + run code");
1008bb63 477 }
a39c66b9
DM
478
479 # literal qr code, naked
480
481 my $r1 = qr/^A(??{$x})$/;
d63c20f2 482 ok("A$x" =~ $r1, "[$x] literal qr naked");
a39c66b9
DM
483
484 # literal qr code, embedded with text
485
486 my $r2 = qr/B(??{$x})$/;
629cd4f3 487 ok("AB$x" =~ /^A$r2/, "[$x] literal qr embedded text");
a39c66b9
DM
488
489 # literal qr code, embedded with text + lit code
490
491 my $r3 = qr/C(??{$x})$/;
629cd4f3 492 ok("A$x-BC$x" =~ /^A(??{$x})-B$r3/,
a39c66b9
DM
493 "[$x] literal qr embedded text + lit code");
494
495 # literal qr code, embedded with text + run code
496
497 my $r4 = qr/C(??{$x})$/;
498 my $code4 = '(??{$x})';
fbf5ab7b 499
1008bb63
DM
500 eval {/^A$code4-B$r4/};
501 norun("[$x] literal qr embedded text + run code");
fbf5ab7b 502 {
1008bb63
DM
503 use re 'eval';
504 ok("A$x-BC$x" =~ /^A$code4-B$r4/,
505 "[$x] literal qr embedded text + run code");
fbf5ab7b
DM
506 }
507
a39c66b9
DM
508 # nested qr in different scopes
509
510 my $code5 = '(??{$x})';
629cd4f3 511 my $r5 = qr/C(??{$x})/;
fbf5ab7b 512
1008bb63
DM
513 my $r6;
514 eval {qr/$code5-C(??{$x})/}; norun("r6 norun");
515 {
516 use re 'eval';
517 $r6 = qr/$code5-C(??{$x})/;
518 }
a39c66b9
DM
519
520 my @rr5;
521 my @rr6;
522
523 for my $y (qw(d e f)) {
524
525 my $rr5 = qr/^A(??{"$x$y"})-$r5/;
526 push @rr5, $rr5;
629cd4f3 527 ok("A$x$y-C$x" =~ $rr5,
a39c66b9
DM
528 "[$x-$y] literal qr + r5");
529
530 my $rr6 = qr/^A(??{"$x$y"})-$r6/;
531 push @rr6, $rr6;
629cd4f3 532 ok("A$x$y-$x-C$x" =~ $rr6,
a39c66b9
DM
533 "[$x-$y] literal qr + r6");
534 }
535
536 for my $i (0,1,2) {
537 my $y = 'Y';
538 my $yy = (qw(d e f))[$i];
539 my $rr5 = $rr5[$i];
629cd4f3
DM
540 ok("A$x$yy-C$x" =~ $rr5, "[$x-$yy] literal qr + r5, outside");
541 ok("A$x$yy-C$x-D$x" =~ /$rr5-D(??{$x})$/,
a39c66b9
DM
542 "[$x-$yy] literal qr + r5 + lit, outside");
543
629cd4f3 544
a39c66b9
DM
545 my $rr6 = $rr6[$i];
546 push @rr6, $rr6;
629cd4f3 547 ok("A$x$yy-$x-C$x" =~ $rr6,
a39c66b9 548 "[$x-$yy] literal qr + r6, outside");
629cd4f3 549 ok("A$x$yy-$x-C$x-D$x" =~ /$rr6-D(??{$x})/,
a39c66b9
DM
550 "[$x-$yy] literal qr + r6 +lit, outside");
551 }
552 }
68e2671b
DM
553
554 # recursive subs should get lexical from the correct pad depth
555
556 sub recurse {
557 my ($n) = @_;
558 return if $n > 2;
559 ok("A$n" =~ /^A(??{$n})$/, "recurse($n)");
560 recurse($n+1);
561 }
562 recurse(0);
d63c20f2
DM
563
564 # for qr// containing run-time elements but with a compile-time
565 # code block, make sure the run-time bits are executed in the same
566 # pad they were compiled in
567 {
568 my $a = 'a'; # ensure outer and inner pads don't align
569 my $b = 'b';
570 my $c = 'c';
571 my $d = 'd';
572 my $r = qr/^$b(??{$c})$d$/;
573 ok("bcd" =~ $r, "qr with run-time elements and code block");
574 }
575
b30fcab9
DM
576 # check that cascaded embedded regexes all see their own lexical
577 # environment
578
579 {
580 my ($r1, $r2, $r3, $r4);
581 my ($x1, $x2, $x3, $x4) = (5,6,7,8);
582 { my $x1 = 1; $r1 = qr/A(??{$x1})/; }
583 { my $x2 = 2; $r2 = qr/$r1(??{$x2})/; }
584 { my $x3 = 3; $r3 = qr/$r2(??{$x3})/; }
585 { my $x4 = 4; $r4 = qr/$r3(??{$x4})/; }
586 ok("A1234" =~ /^$r4$/, "cascaded qr");
587 }
588
589 # and again, but in a loop, with no external references
590 # being maintained to the qr's
591
592 {
593 my $r = 'A';
594 for my $x (1..4) {
595 $r = qr/$r(??{$x})/;
596 }
597 my $x = 5;
598 ok("A1234" =~ /^$r$/, "cascaded qr loop");
599 }
600
601
602 # and again, but compiling the qrs in an eval so there
603 # aren't even refs to the qrs from any ops
604
605 {
606 my $r = 'A';
607 for my $x (1..4) {
608 $r = eval q[ qr/$r(??{$x})/; ];
609 }
610 my $x = 5;
611 ok("A1234" =~ /^$r$/, "cascaded qr loop");
612 }
613
87c6a48b
DM
614 # have qrs with either literal code blocks or only embedded
615 # code blocks, but not both
616
617 {
618 my ($r1, $r2, $r3, $r4);
619 my ($x1, $x3) = (7,8);
620 { my $x1 = 1; $r1 = qr/A(??{$x1})/; }
621 { $r2 = qr/${r1}2/; }
622 { my $x3 = 3; $r3 = qr/$r2(??{$x3})/; }
623 { $r4 = qr/${r3}4/; }
624 ok("A1234" =~ /^$r4$/, "cascaded qr mix 1");
625 ok("A12345" =~ /^${r4}5$/, "cascaded qr mix 2");
626 ok("A1234" =~ qr/^$r4$/ , "cascaded qr mix 3");
627 ok("A12345" =~ qr/^${r4}5$/, "cascaded qr mix 4");
628 }
629
630 # and make sure things are freed at the right time
1b54b9b1
DIM
631 {
632 sub Foo99::DESTROY { $Foo99::d++ }
633 $Foo99::d = 0;
634 my $r1;
87c6a48b 635 {
1b54b9b1
DIM
636 my $x = bless [1], 'Foo99';
637 $r1 = eval 'qr/(??{$x->[0]})/';
87c6a48b 638 }
1b54b9b1
DIM
639 my $r2 = eval 'qr/a$r1/';
640 my $x = 2;
641 ok(eval '"a1" =~ qr/^$r2$/', "match while in scope");
642 # make sure PL_reg_curpm isn't holding on to anything
643 "a" =~ /a(?{1})/;
644 is($Foo99::d, 0, "before scope exit");
87c6a48b 645 }
1b54b9b1 646 ::is($Foo99::d, 1, "after scope exit");
87c6a48b 647
d63c20f2
DM
648 # forward declared subs should Do The Right Thing with any anon CVs
649 # within them (i.e. pad_fixup_inner_anons() should work)
650
651 sub forward;
652 sub forward {
653 my $x = "a";
654 my $A = "A";
655 ok("Aa" =~ qr/^A(??{$x})$/, "forward qr compiletime");
656 ok("Aa" =~ qr/^$A(??{$x})$/, "forward qr runtime");
657 }
658 forward;
a39c66b9
DM
659 }
660
d24ca0c5
DM
661 # test that run-time embedded code, when re-fed into toker,
662 # does all the right escapes
663
664 {
b4d1421a
KW
665 my $enc;
666 $enc = eval 'use Encode; find_encoding("ascii")' unless $::IS_EBCDIC;
d24ca0c5
DM
667
668 my $x = 0;
669 my $y = 'bad';
670
671 # note that most of the strings below are single-quoted, and the
672 # things within them, like '$y', *aren't* intended to interpolate
673
674 my $s1 =
675 'a\\$y(?# (??{BEGIN{$x=1} "X1"})b(?# \Ux2\E)c\'d\\\\e\\\\Uf\\\\E';
676
677 ok(q{a$ybc'd\e\Uf\E} =~ /^$s1$/, "reparse");
678 is($x, 0, "reparse no BEGIN");
679
680 my $s2 = 'g\\$y# (??{{BEGIN{$x=2} "X3"}) \Ux3\E' . "\nh";
681
682 ok(q{a$ybc'd\\e\\Uf\\Eg$yh} =~ /^$s1$s2$/x, "reparse /x");
683 is($x, 0, "reparse /x no BEGIN");
684
685 my $b = '\\';
686 my $q = '\'';
687
688 # non-ascii in string as "<0xNNN>"
689 sub esc_str {
690 my $s = shift;
691 $s =~ s{(.)}{
692 my $c = ord($1);
6aec1cbc
KW
693 (utf8::native_to_unicode($c)< 32
694 || utf8::native_to_unicode($c) > 127)
695 ? sprintf("<0x%x>", $c) : $1;
d24ca0c5
DM
696 }ge;
697 $s;
698 }
699 sub fmt { sprintf "hairy backslashes %s [%s] =~ /^%s/",
700 $_[0], esc_str($_[1]), esc_str($_[2]);
701 }
702
703
704 for my $u (
705 [ '', '', 'blank ' ],
706 [ "\x{100}", '\x{100}', 'single' ],
707 [ "\x{100}", "\x{100}", 'double' ])
708 {
709 for my $pair (
710 [ "$b", "$b$b" ],
711 [ "$q", "$q" ],
712 [ "$b$q", "$b$b$b$q" ],
713 [ "$b$b$q", "$b$b$b$b$q" ],
714 [ "$b$b$b$q", "$b$b$b$b$b$b$q" ],
715 [ "$b$b$b$b$q","$b$b$b$b$b$b$b$b$q" ],
716 ) {
717 my ($s, $r) = @$pair;
718 $s = "9$s";
719 my $ss = "$u->[0]$s";
720
721 my $c = '9' . $r;
722 my $cc = "$u->[1]$c";
1008bb63
DM
723
724 ok($ss =~ /^$cc/, fmt("plain $u->[2]", $ss, $cc));
d24ca0c5
DM
725
726 no strict;
d24ca0c5 727 $nine = $nine = "bad";
6aec1cbc
KW
728 $ss = "$u->[0]\t${q}\x41${b}x42$s" if $::IS_ASCII;
729 $ss = "$u->[0]\t${q}\xC1${b}xC2$s" if $::IS_EBCDIC;
d24ca0c5
DM
730 for my $use_qr ('', 'qr') {
731 $c = qq[(??{my \$z='{';]
6aec1cbc
KW
732 . (($::IS_ASCII)
733 ? qq[$use_qr"$b${b}t$b$q$b${b}x41$b$b$b${b}x42"]
734 : qq[$use_qr"$b${b}t$b$q$b${b}xC1$b$b$b${b}xC2"])
d24ca0c5
DM
735 . qq[. \$nine})];
736 # (??{ qr/str/ }) goes through one less interpolation
737 # stage than (??{ qq/str/ })
738 $c =~ s{\\\\}{\\}g if ($use_qr eq 'qr');
739 $c .= $r;
740 $cc = "$u->[1]$c";
741 my $nine = 9;
1008bb63
DM
742
743 eval {/^$cc/}; norun(fmt("code norun $u->[2]", $ss, $cc));
744 {
745 use re 'eval';
746 ok($ss =~ /^$cc/, fmt("code $u->[2]", $ss, $cc));
747 }
748
b4d1421a 749 SKIP:
d24ca0c5 750 {
b4d1421a 751 skip("Encode not working on EBCDIC", 1) unless defined $enc;
d24ca0c5
DM
752 # Poor man's "use encoding 'ascii'".
753 # This causes a different code path in S_const_str()
754 # to be used
d5b4785c 755 no warnings 'deprecated';
d24ca0c5 756 local ${^ENCODING} = $enc;
d5b4785c 757 use warnings 'deprecated';
1008bb63
DM
758 use re 'eval';
759 ok($ss =~ /^$cc/, fmt("encode $u->[2]", $ss, $cc));
d24ca0c5
DM
760 }
761 }
762 }
763 }
764
765 my $code1u = "(??{qw(\x{100})})";
5c25e937 766 eval {/^$code1u$/}; norun("reparse embedded unicode norun");
1008bb63
DM
767 {
768 use re 'eval';
5c25e937 769 ok("\x{100}" =~ /^$code1u$/, "reparse embedded unicode");
1008bb63 770 }
d24ca0c5
DM
771 }
772
773 # a non-pattern literal won't get code blocks parsed at compile time;
774 # but they must get parsed later on if 'use re eval' is in scope
775 # also check that unbalanced {}'s are parsed ok
776
777 {
1008bb63
DM
778 eval q["a{" =~ '^(??{"a{"})$'];
779 norun("non-pattern literal code norun");
780 eval {/^${\'(??{"a{"})'}$/};
781 norun("runtime code with unbalanced {} norun");
782
d24ca0c5 783 use re 'eval';
2f71aec6
DM
784 ok("a{" =~ '^a(??{"{"})$', "non-pattern literal code");
785 ok("a{" =~ /^a${\'(??{"{"})'}$/, "runtime code with unbalanced {}");
d24ca0c5
DM
786 }
787
2e2e3f36
DM
788 # make sure warnings come from the right place
789
790 {
791 use warnings;
792 my ($s, $t, $w);
793 local $SIG{__WARN__} = sub { $w .= "@_" };
794
795 $w = ''; $s = 's';
796 my $r = qr/(?{$t=$s+1})/;
797 "a" =~ /a$r/;
798 like($w, qr/pat_re_eval/, "warning main file");
799
800 # do it in an eval to get predictable line numbers
801 eval q[
802
803 $r = qr/(?{$t=$s+1})/;
804 ];
805 $w = ''; $s = 's';
806 "a" =~ /a$r/;
807 like($w, qr/ at \(eval \d+\) line 3/, "warning eval A");
808
809 $w = ''; $s = 's';
810 eval q[
811 use re 'eval';
812 my $c = '(?{$t=$s+1})';
813 "a" =~ /a$c/;
814 1;
815 ];
816 like($w, qr/ at \(eval \d+\) line 1/, "warning eval B");
817 }
818
81ed78b2
DM
819 # jumbo test for:
820 # * recursion;
821 # * mixing all the different types of blocks (literal, qr/literal/,
822 # runtime);
823 # * backtracking (the Z+ alternation ensures CURLYX and full
824 # scope popping on backtracking)
825
826 {
827 sub recurse2 {
828 my ($depth)= @_;
829 return unless $depth;
830 my $s1 = '3-LMN';
831 my $r1 = qr/(??{"$s1-$depth"})/;
832
833 my $s2 = '4-PQR';
834 my $c1 = '(??{"$s2-$depth"})';
835 use re 'eval';
836 ok( "<12345-ABC-$depth-123-LMN-$depth-1234-PQR-$depth>"
837 . "<12345-ABC-$depth-123-LMN-$depth-1234-PQR-$depth>"
838 =~
839 /^<(\d|Z+)+(??{"45-ABC-$depth-"})(\d|Z+)+$r1-\d+$c1>
840 <(\d|Z+)+(??{"45-ABC-$depth-"})(\d|Z+)+$r1-\d+$c1>$/x,
841 "recurse2($depth)");
842 recurse2($depth-1);
843 }
844 recurse2(5);
845 }
846
74088413
DM
847 # nested (??{}) called from various levels of a recursive function
848
849 {
850 sub recurse3 {
851 my ($n) = @_;
852 return if $n > 3;
853 ok("A$n" =~ m{^A(??{ "0123" =~ /((??{$n}))/; $1 })$},
854 "recurse3($n)");
855 ok("A$n" !~ m{^A(??{ "0123" =~ /((??{$n}))/; "X" })$},
856 "recurse3($n) nomatch");
857 recurse3($n+1);
858 }
859 recurse3(0);
860 }
861
862 # nested (??{}) being invoked recursively via a function
863
864 {
865 my $s = '';
866 our $recurse4;
867 my @alpha = qw(A B C D E);
868 $recurse4 = sub {
869 my ($n) = @_;
870 $s .= "(n=$n:";
871 if ($n < 4) {
872 my $m = ("$alpha[$n]" . substr("0123", 0, $n+1)) =~
873 m{^([A-Z])
874 (??{
875 $s .= "1=$1:";
876 "$n-0123" =~ m{^(\d)-(((??{$recurse4->($n+1)})))};
877 $s .= "i1=$1:<=[$2]";
878 $3; # NB - not stringified
879 })
880 $
881 }x;
882 $s .= "1a=$1:";
883 $s .= $m ? 'M' : '!M';
884 }
885 my $ret = '.*?' . ($n-1);
886 $s .= "<=[$ret])";
887 return $ret;
888 };
889 $recurse4->(0);
890 my $exp = '(n=0:1=A:(n=1:1=B:(n=2:1=C:(n=3:1=D:(n=4:<=[.*?3])'
891 . 'i1=3:<=[0123]1a=D:M<=[.*?2])i1=2:<=[012]1a=C:M<=[.*?1])'
892 . 'i1=1:<=[01]1a=B:M<=[.*?0])i1=0:<=[0]1a=A:M<=[.*?-1])';
893 is($s, $exp, 'recurse4');
894 }
895
896 # single (??{}) being invoked recursively via a function
897
898 {
899 my $s = '';
900 our $recurse5;
901 my @alpha = qw(A B C D E);
902 $recurse5 = sub {
903 my ($n) = @_;
904 $s .= "(n=$n:";
905 if ($n < 4) {
906 my $m = ("$alpha[$n]" . substr("0123", 0, $n+1)) =~
907 m{^([A-Z])
908 ((??{
909 $s .= "1=$1:";
910 $recurse5->($n+1);
911 }))
912 $
913 }x;
914 $s .= "1a=$1:2=$2:";
915 $s .= $m ? 'M' : '!M';
916 }
917 my $ret = '.*?' . ($n-1);
918 $s .= "<=[$ret])";
919 return $ret;
920 };
921 $recurse5->(0);
922 my $exp = '(n=0:1=A:(n=1:1=B:(n=2:1=C:(n=3:1=D:(n=4:<=[.*?3])'
923 . '1a=D:2=0123:M<=[.*?2])1a=C:2=012:M<=[.*?1])'
924 . '1a=B:2=01:M<=[.*?0])1a=A:2=0:M<=[.*?-1])';
925 is($s, $exp, 'recurse5');
926 }
927
928
81ed78b2
DM
929 # make sure that errors during compiling run-time code get trapped
930
931 {
932 use re 'eval';
933
934 my $code = '(?{$x=})';
935 eval { "a" =~ /^a$code/ };
936 like($@, qr/syntax error at \(eval \d+\) line \d+/, 'syntax error');
937
938 $code = '(?{BEGIN{die})';
939 eval { "a" =~ /^a$code/ };
940 like($@,
941 qr/BEGIN failed--compilation aborted at \(eval \d+\) line \d+/,
942 'syntax error');
ce4bd586
BF
943
944 use utf8;
945 $code = '(?{Foo::$bar})';
946 eval { "a" =~ /^a$code/ };
947 like($@, qr/Bad name after Foo:: at \(eval \d+\) line \d+/, 'UTF8 sytax error');
81ed78b2
DM
948 }
949
732caac7
DM
950 # make sure that 'use re eval' is propagated into compiling the
951 # pattern returned by (??{})
952
953 {
954 use re 'eval';
955 my $pat = 'B(??{1})C';
956 my $A = 'A';
957 # compile-time outer code-block
958 ok("AB1CD" =~ /^A(??{$pat})D$/, "re eval propagated compile-time");
959 # run-time outer code-block
960 ok("AB1CD" =~ /^$A(??{$pat})D$/, "re eval propagated run-time");
961 }
962
197e8e6e
DM
963 # returning a ref to something that had set magic but wasn't
964 # PERL_MAGIC_qr triggered a false positive assertion failure
965 # The test is not so much concerned with it not matching,
966 # as with not failing the assertion
967
968 {
969 ok("a" !~ /^(a)(??{ \$1 })/, '(??{ ref })');
970 }
971
e4bfbed3
DM
972 # make sure the uninit warning from returning an undef var
973 # sees the right var
974
975 {
976 my ($u1, $u2);
977 my $warn = '';
978 local $SIG{__WARN__} = sub { $warn .= $_[0] };
979 $u1 =~ /(??{$u2})/ or die;
980 like($warn, qr/value \$u1 in pattern match.*\n.*value at/, 'uninit');
981 }
982
86464c5b
DM
983 # test that code blocks are called in scalar context
984
985 {
986 my @a = (0);
987 ok("" =~ /^(?{@a})$/, '(?{}) in scalar context');
988 is($^R, 1, '(?{}) in scalar context: $^R');
989 ok("1" =~ /^(??{@a})$/, '(??{}) in scalar context');
990 ok("foo" =~ /^(?(?{@a})foo|bar)$/, '(?(?{})|) in scalar context');
991 }
992
30e92347
DM
993 # BEGIN in compiled blocks shouldn't mess with $1 et al
994
995 {
996 use re 'eval';
997 my $code1 = '(B)(??{ BEGIN { "X" =~ /X/ } $1})(C)';
998 ok("ABBCA" =~ /^(.)(??{$code1})\1$/, '(?{}) BEGIN and $1');
999 my $code2 = '(B)(??{ BEGIN { "X" =~ /X/ } $1 =~ /(.)/ ? $1 : ""})(C)';
1000 ok("ABBCA" =~ /^(.)(??{$code2})\1$/, '(?{}) BEGIN and $1 mark 2');
1001 }
e4bfbed3 1002
41953474
DM
1003 # check that the optimiser is applied to code blocks: see if aelem has
1004 # been converted to aelemfast
1005
1006 {
1007 my $out;
1008 for my $prog (
1009 '/(?{$a[0]})/',
1010 'q() =~ qr/(?{$a[0]})/',
1011 'use re q(eval); q() =~ q{(?{$a[0]})}',
1012 'use re q(eval); $c = q{(?{$a[0]})}; /$c/',
1013 'use re q(eval); $c = q{(?{$a[0]})}; /(?{1;})$c/',
1014 ) {
1015 $out = runperl(switches => ["-Dt"], prog => $prog, stderr => 1);
1016 like($out, qr/aelemfast|Recompile perl with -DDEBUGGING/,
1017 "optimise: '$prog'");
1018 }
1019 }
1020
d234778b
DM
1021 # [perl #115080]
1022 # Ensure that ?pat? matches exactly once, even when the run-time
1023 # pattern changes, and even when the presence of run-time (?{}) affects
1024 # how and when patterns are recompiled
41953474 1025
d234778b
DM
1026 {
1027 my $m;
1028
1029 $m = '';
1030 for (qw(a a a)) {
1031 $m .= $_ if m?$_?;
1032 }
1033 is($m, 'a', '?pat? with a,a,a');
1034
1035 $m = '';
1036 for (qw(a b c)) {
1037 $m .= $_ if m?$_?;
1038 }
1039 is($m, 'a', '?pat? with a,b,c');
1040
1041 use re 'eval';
1042
1043 $m = '';
1044 for (qw(a a a)) {
1045 my $e = qq[(??{"$_"})];
1046 $m .= $_ if m?$e?;
1047 }
1048 is($m, 'a', '?pat? with (??{a,a,a})');
1049
1050 $m = '';
1051 for (qw(a b c)) {
1052 my $e = qq[(??{"$_"})];
1053 $m .= $_ if m?$e?;
1054 }
1055 is($m, 'a', '?pat? with (??{a,b,c})');
1056 }
41953474 1057
da1f5b59
DM
1058 {
1059 # this code won't actually fail, but it used to fail valgrind,
1060 # so its here just to make sure valgrind doesn't fail again
1061 # While examining the ops of the secret anon sub wrapped around
1062 # the qr//, the pad of the sub was in scope, so cSVOPo_sv
1063 # got the const from the wrong pad. By having lots of $s's
1064 # (aka gvsv(*s), this forces the targs of the consts which have
1065 # been moved to the pad, to have high indices.
1066
1067 sub {
1068 local our $s = "abc";
1069 my $qr = qr/^(?{1})$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s/;
1070 }->();
1071 pass("cSVOPo_sv");
1072 }
1073
491453ba
DM
1074 # [perl #115004]
1075 # code blocks in qr objects that are interpolated in arrays need
1076 # handling the same as if they were interpolated from scalar vars
1077 # (before this code would need 'use re "eval"')
1078
1079 {
1080 use Tie::Array;
1081
1082 use vars '@global';
1083 local @global;
1084 my @array;
1085 my @refs = (0, \@array, 2);
1086 my @tied;
1087 tie @tied, 'Tie::StdArray';
1088 {
1089 my $bb = 'B';
1090 my $dd = 'D';
1091 @array = ('A', qr/(??{$bb})/, 'C', qr/(??{$dd})/, 'E');
1092 @tied = @array;
1093 @global = @array;
1094 }
1095 my $bb = 'X';
1096 my $dd = 'Y';
1097 ok("A B C D E=" =~ /@array/, 'bare interpolated array match');
1098 ok("A B C D E=" =~ qr/@array/, 'qr bare interpolated array match');
1099 ok("A B C D E=" =~ /@global/, 'bare interpolated global array match');
1100 ok("A B C D E=" =~ qr/@global/,
1101 'qr bare interpolated global array match');
1102 ok("A B C D E=" =~ /@{$refs[1]}/, 'bare interpolated ref array match');
1103 ok("A B C D E=" =~ qr/@{$refs[1]}/,
1104 'qr bare interpolated ref array match');
1105 ok("A B C D E=" =~ /@tied/, 'bare interpolated tied array match');
1106 ok("A B C D E=" =~ qr/@tied/, 'qr bare interpolated tied array match');
1107 ok("aA B C D E=" =~ /^a@array=$/, 'interpolated array match');
1108 ok("aA B C D E=" =~ qr/^a@array=$/, 'qr interpolated array match');
1109 ok("aA B C D E=" =~ /^a@global=$/, 'interpolated global array match');
1110 ok("aA B C D E=" =~ qr/^a@global=$/,
1111 'qr interpolated global array match');
1112 ok("aA B C D E=" =~ /^a@{$refs[1]}=$/, 'interpolated ref array match');
1113 ok("aA B C D E=" =~ qr/^a@{$refs[1]}=$/,
1114 'qr interpolated ref array match');
1115 ok("aA B C D E=" =~ /^a@tied=$/, 'interpolated tied array match');
1116 ok("aA B C D E=" =~ qr/^a@tied=$/, 'qr interpolated tied array match');
1117
1118 {
1119 local $" = '-';
1120 ok("aA-B-C-D-E=" =~ /^a@{array}=$/,
1121 'interpolated array match with local sep');
1122 ok("aA-B-C-D-E=" =~ qr/^a@{array}=$/,
1123 'qr interpolated array match with local sep');
1124 ok("aA-B-C-D-E=" =~ /^a@{global}=$/,
1125 'interpolated global array match with local sep');
1126 ok("aA-B-C-D-E=" =~ qr/^a@{global}=$/,
1127 'qr interpolated global array match with local sep');
1128 ok("aA-B-C-D-E=" =~ /^a@{tied}=$/,
1129 'interpolated tied array match with local sep');
1130 ok("aA-B-C-D-E=" =~ qr/^a@{tied}=$/,
1131 'qr interpolated tied array match with local sep');
1132 }
1133
1134 # but don't handle the array ourselves in the presence of \Q etc
1135
1136 @array = ('A', '(?{})');
1137 @global = @array;
1138 @tied = @array;
1139 ok("aA (?{})=" =~ /^a\Q@{array}\E=$/,
1140 'interpolated array match with \Q');
1141 ok("aA (?{})=" =~ qr/^a\Q@{array}\E=$/,
1142 'qr interpolated array match with \Q');
1143 ok("aA (?{})=" =~ /^a\Q@{global}\E=$/,
1144 'interpolated global array match with \Q');
1145 ok("aA (?{})=" =~ qr/^a\Q@{global}\E=$/,
1146 'qr interpolated global array match with \Q');
1147 ok("aA (?{})=" =~ /^a\Q@{$refs[1]}\E=$/,
1148 'interpolated ref array match with \Q');
1149 ok("aA (?{})=" =~ qr/^a\Q@{$refs[1]}\E=$/,
1150 'qr interpolated ref array match with \Q');
1151 ok("aA (?{})=" =~ /^a\Q@{tied}\E=$/,
1152 'interpolated tied array match with \Q');
1153 ok("aA (?{})=" =~ qr/^a\Q@{tied}\E=$/,
1154 'qr interpolated tied array match with \Q');
1155
1156 # and check it works with an empty array
1157
1158 @array = ();
1159 @global = ();
1160 @tied = ();
1161 ok("a=" =~ /^a@array=$/, 'empty array match');
1162 ok("a=" =~ qr/^a@array=$/, 'qr empty array match');
1163 ok("a=" =~ /^a@global=$/, 'empty global array match');
1164 ok("a=" =~ qr/^a@global=$/, 'qr empty global array match');
1165 ok("a=" =~ /^a@tied=$/, 'empty tied array match');
1166 ok("a=" =~ qr/^a@tied=$/, 'qr empty tied array match');
1167 ok("a=" =~ /^a\Q@{array}\E=$/, 'empty array match with \Q');
1168 ok("a=" =~ /^a\Q@{array}\E=$/, 'empty array match with \Q');
1169 ok("a=" =~ qr/^a\Q@{global}\E=$/,
1170 'qr empty global array match with \Q');
1171 ok("a=" =~ /^a\Q@{tied}\E=$/, 'empty tied array match with \Q');
1172 ok("a=" =~ qr/^a\Q@{tied}\E=$/, 'qr empty tied array match with \Q');
1173
1174 # NB: these below are empty patterns, so they happen to use the
1175 # successful match from the line above
1176
1177 ok("a=" =~ /@array/, 'empty array pattern');
1178 ok("a=" =~ qr/@array/, 'qr empty array pattern');
1179 ok("a=" =~ /@global/, 'empty global array pattern');
1180 ok("a=" =~ qr/@global/, 'qr empty global array pattern');
1181 ok("a=" =~ /@tied/, 'empty tied pattern');
1182 ok("a=" =~ qr/@tied/, 'qr empty tied pattern');
1183 ok("a=" =~ /\Q@array\E/, 'empty array pattern with \Q');
1184 ok("a=" =~ qr/\Q@array\E/, 'qr empty array pattern with \Q');
1185 ok("a=" =~ /\Q@global\E/, 'empty global array pattern with \Q');
1186 ok("a=" =~ qr/\Q@global\E/, 'qr empty global array pattern with \Q');
1187 ok("a=" =~ /\Q@tied\E/, 'empty tied pattern with \Q');
1188 ok("a=" =~ qr/\Q@tied\E/, 'qr empty tied pattern with \Q');
1189 ok("a=" =~ //, 'completely empty pattern');
1190 ok("a=" =~ qr//, 'qr completely empty pattern');
1191 }
da1f5b59 1192
63620942
FC
1193 {
1194 { package o; use overload '""'=>sub { "abc" } }
1195 my $x = bless [],"o";
1196 my $y = \$x;
1197 (my $y_addr = "$y") =~ y/()//d; # REF(0x7fcb9c02) -> REF0x7fcb9c02
1198 # $y_addr =~ $y should be true, as should $y_addr =~ /(??{$y})/
1199 "abc$y_addr" =~ /(??{$x})(??{$y})/;
1200 is "$&", "abc$y_addr",
1201 '(??{$x}) does not leak cached qr to (??{\$x}) (match)';
1202 is scalar "abcabc" =~ /(??{$x})(??{$y})/, "",
1203 '(??{$x}) does not leak cached qr to (??{\$x}) (no match)';
1204 }
81ed78b2 1205
2685dc2d
FC
1206 {
1207 sub ReEvalTieTest::TIESCALAR {bless[], "ReEvalTieTest"}
1208 sub ReEvalTieTest::STORE{}
1209 sub ReEvalTieTest::FETCH { "$1" }
1210 tie my $t, "ReEvalTieTest";
1211 $t = bless [], "o";
1212 "aab" =~ /(a)((??{"b" =~ m|(.)|; $t}))/;
1213 is "[$1 $2]", "[a b]",
1214 '(??{$tied_former_overload}) sees the right $1 in FETCH';
1215 }
1216
e66ad350
FC
1217 {
1218 my @matchsticks;
1219 my $ref = bless \my $o, "o";
1220 my $foo = sub { push @matchsticks, scalar "abc" =~ /(??{$ref})/ };
1221 &$foo;
1222 bless \$o;
1223 () = "$ref"; # flush AMAGIC flag on main
1224 &$foo;
1225 is "@matchsticks", "1 ", 'qr magic is not cached on refs';
1226 }
1227
4cba5ac0
FC
1228 {
1229 my ($foo, $bar) = ("foo"x1000, "bar"x1000);
1230 "$foo$bar" =~ /(??{".*"})/;
1231 is "$&", "foo"x1000 . "bar"x1000,
1232 'padtmp swiping does not affect "$a$b" =~ /(??{})/'
1233 }
1234
1acab4c5
DM
1235 {
1236 # [perl #129140]
1237 # this used to cause a double-free of the code_block struct
1238 # when re-running the compilation after spotting utf8.
1239 # This test doesn't catch it, but might panic, or fail under
1240 # valgrind etc
1241
1242 my $s = '';
1243 /$s(?{})\x{100}/ for '', '';
1244 pass "RT #129140";
1245 }
1246
f8def6c7
DM
1247 # RT #130650 code blocks could get double-freed during a pattern
1248 # compilation croak
1249
1250 {
1251 # this used to panic or give ASAN errors
1252 eval 'qr/(?{})\6/';
1253 like $@, qr/Reference to nonexistent group/, "RT #130650";
1254 }
1255
1acab4c5 1256
0f289c68
YO
1257} # End of sub run_tests
1258
12591;