This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pmruntime: make more use of Perl_re_op_compile
[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';
20 @INC = ('../lib','.');
90b541eb 21 require './test.pl';
0669fd04 22 skip_all_if_miniperl("no dynamic loading on miniperl, no re");
0f289c68
YO
23}
24
25
fbf5ab7b 26plan tests => 255; # Update this when adding/deleting tests.
0f289c68
YO
27
28run_tests() unless caller;
29
30#
31# Tests start here.
32#
33sub run_tests {
34 {
f245da07 35 my $message = "Call code from qr //";
0f289c68
YO
36 local $_ = 'var="foo"';
37 $a = qr/(?{++$b})/;
38 $b = 7;
f245da07 39 ok(/$a$a/ && $b eq '9', $message);
0f289c68
YO
40
41 my $c="$a";
f245da07 42 ok(/$a$a/ && $b eq '11', $message);
0f289c68
YO
43
44 undef $@;
45 eval {/$c/};
f245da07 46 like($@, qr/not allowed at runtime/, $message);
0f289c68
YO
47
48 use re "eval";
49 /$a$c$a/;
f245da07 50 is($b, '14', $message);
0f289c68
YO
51
52 our $lex_a = 43;
53 our $lex_b = 17;
54 our $lex_c = 27;
55 my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/);
56
f245da07
NC
57 is($lex_res, 1, $message);
58 is($lex_a, 44, $message);
59 is($lex_c, 43, $message);
0f289c68
YO
60
61 no re "eval";
62 undef $@;
b30fcab9
DM
63 my $d = '(?{1})';
64 my $match = eval { /$a$c$a$d/ };
f245da07
NC
65 ok($@ && $@ =~ /Eval-group not allowed/ && !$match, $message);
66 is($b, '14', $message);
0f289c68
YO
67
68 $lex_a = 2;
69 $lex_a = 43;
70 $lex_b = 17;
71 $lex_c = 27;
72 $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/);
73
f245da07
NC
74 is($lex_res, 1, $message);
75 is($lex_a, 44, $message);
76 is($lex_c, 43, $message);
0f289c68
YO
77
78 }
79
80 {
81 our $a = bless qr /foo/ => 'Foo';
82 ok 'goodfood' =~ $a, "Reblessed qr // matches";
de26e0cc 83 is($a, '(?^:foo)', "Reblessed qr // stringifies");
0f289c68
YO
84 my $x = "\x{3fe}";
85 my $z = my $y = "\317\276"; # Byte representation of $x
86 $a = qr /$x/;
87 ok $x =~ $a, "UTF-8 interpolation in qr //";
88 ok "a$a" =~ $x, "Stringified qr // preserves UTF-8";
89 ok "a$x" =~ /^a$a\z/, "Interpolated qr // preserves UTF-8";
90 ok "a$x" =~ /^a(??{$a})\z/,
91 "Postponed interpolation of qr // preserves UTF-8";
bb535cf1
NC
92
93
94 is(length qr /##/x, 9, "## in qr // doesn't corrupt memory; Bug 17776");
95
0f289c68
YO
96 {
97 use re 'eval';
98 ok "$x$x" =~ /^$x(??{$x})\z/,
99 "Postponed UTF-8 string in UTF-8 re matches UTF-8";
100 ok "$y$x" =~ /^$y(??{$x})\z/,
101 "Postponed UTF-8 string in non-UTF-8 re matches UTF-8";
102 ok "$y$x" !~ /^$y(??{$y})\z/,
103 "Postponed non-UTF-8 string in non-UTF-8 re doesn't match UTF-8";
104 ok "$x$x" !~ /^$x(??{$y})\z/,
105 "Postponed non-UTF-8 string in UTF-8 re doesn't match UTF-8";
106 ok "$y$y" =~ /^$y(??{$y})\z/,
107 "Postponed non-UTF-8 string in non-UTF-8 re matches non-UTF8";
108 ok "$x$y" =~ /^$x(??{$y})\z/,
109 "Postponed non-UTF-8 string in UTF-8 re matches non-UTF8";
110
111 $y = $z; # Reset $y after upgrade.
112 ok "$x$y" !~ /^$x(??{$x})\z/,
113 "Postponed UTF-8 string in UTF-8 re doesn't match non-UTF-8";
114 ok "$y$y" !~ /^$y(??{$x})\z/,
115 "Postponed UTF-8 string in non-UTF-8 re doesn't match non-UTF-8";
116 }
117 }
118
119
120 {
121 use re 'eval';
f245da07 122 # Test if $^N and $+ work in (?{{})
0f289c68
YO
123 our @ctl_n = ();
124 our @plus = ();
125 our $nested_tags;
126 $nested_tags = qr{
127 <
128 ((\w)+)
129 (?{
130 push @ctl_n, (defined $^N ? $^N : "undef");
131 push @plus, (defined $+ ? $+ : "undef");
132 })
133 >
134 (??{$nested_tags})*
135 </\s* \w+ \s*>
136 }x;
137
138
139 my $c = 0;
140 for my $test (
141 # Test structure:
142 # [ Expected result, Regex, Expected value(s) of $^N, Expected value(s) of $+ ]
143 [ 1, qr#^$nested_tags$#, "bla blubb bla", "a b a" ],
144 [ 1, qr#^($nested_tags)$#, "bla blubb <bla><blubb></blubb></bla>", "a b a" ],
145 [ 1, qr#^(|)$nested_tags$#, "bla blubb bla", "a b a" ],
146 [ 1, qr#^(?:|)$nested_tags$#, "bla blubb bla", "a b a" ],
147 [ 1, qr#^<(bl|bla)>$nested_tags<(/\1)>$#, "blubb /bla", "b /bla" ],
148 [ 1, qr#(??{"(|)"})$nested_tags$#, "bla blubb bla", "a b a" ],
149 [ 1, qr#^(??{"(bla|)"})$nested_tags$#, "bla blubb bla", "a b a" ],
150 [ 1, qr#^(??{"(|)"})(??{$nested_tags})$#, "bla blubb undef", "a b undef" ],
151 [ 1, qr#^(??{"(?:|)"})$nested_tags$#, "bla blubb bla", "a b a" ],
152 [ 1, qr#^((??{"(?:bla|)"}))((??{$nested_tags}))$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ],
153 [ 1, qr#^((??{"(?!)?"}))((??{$nested_tags}))$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ],
154 [ 1, qr#^((??{"(?:|<(/?bla)>)"}))((??{$nested_tags}))\1$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ],
155 [ 0, qr#^((??{"(?!)"}))?((??{$nested_tags}))(?!)$#, "bla blubb undef", "a b undef" ],
156
157 ) { #"#silence vim highlighting
158 $c++;
159 @ctl_n = ();
160 @plus = ();
161 my $match = (("<bla><blubb></blubb></bla>" =~ $test->[1]) ? 1 : 0);
162 push @ctl_n, (defined $^N ? $^N : "undef");
163 push @plus, (defined $+ ? $+ : "undef");
164 ok($test->[0] == $match, "match $c");
165 if ($test->[0] != $match) {
166 # unset @ctl_n and @plus
167 @ctl_n = @plus = ();
168 }
de26e0cc
NC
169 is("@ctl_n", $test->[2], "ctl_n $c");
170 is("@plus", $test->[3], "plus $c");
0f289c68
YO
171 }
172 }
173
174 {
175 use re 'eval';
bb535cf1 176
0f289c68
YO
177
178 our $f;
179 local $f;
180 $f = sub {
181 defined $_[0] ? $_[0] : "undef";
182 };
183
4b0d13b9 184 like("123", qr/^(\d)(((??{1 + $^N})))+$/, 'Bug 56194');
0f289c68
YO
185
186 our @ctl_n;
187 our @plus;
188
189 my $re = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))*(?{$^N})#;
190 my $re2 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))*(?{$^N})(|a(b)c|def)(??{"$^R"})#;
191 my $re3 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})){2}(?{$^N})(|a(b)c|def)(??{"$^R"})#;
192 our $re5;
193 local $re5 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})){2}(?{$^N})#;
194 my $re6 = qr#(??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})#;
195 my $re7 = qr#(??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})#;
196 my $re8 = qr/(\d+)/;
197 my $c = 0;
198 for my $test (
199 # Test structure:
200 # [
201 # String to match
202 # Regex too match
203 # Expected values of $^N
204 # Expected values of $+
205 # Expected values of $1, $2, $3, $4 and $5
206 # ]
207 [
208 "1233",
209 qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(??{$^N})$#,
210 "1 2 3 3",
211 "1 2 3 3",
212 "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
213 ],
214 [
215 "1233",
216 qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(abc|def|)?(??{$+})$#,
217 "1 2 3 3",
218 "1 2 3 3",
219 "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
220 ],
221 [
222 "1233",
223 qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(|abc|def)?(??{$+})$#,
224 "1 2 3 3",
225 "1 2 3 3",
226 "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
227 ],
228 [
229 "1233",
230 qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(abc|def|)?(??{$^N})$#,
231 "1 2 3 3",
232 "1 2 3 3",
233 "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
234 ],
235 [
236 "1233",
237 qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(|abc|def)?(??{$^N})$#,
238 "1 2 3 3",
239 "1 2 3 3",
240 "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
241 ],
242 [
243 "123abc3",
244 qr#^($re)(|a(b)c|def)(??{$^R})$#,
245 "1 2 3 abc",
246 "1 2 3 b",
247 "\$1 = 123, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b",
248 ],
249 [
250 "123abc3",
251 qr#^($re2)$#,
252 "1 2 3 123abc3",
253 "1 2 3 b",
254 "\$1 = 123abc3, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b",
255 ],
256 [
257 "123abc3",
258 qr#^($re3)$#,
259 "1 2 123abc3",
260 "1 2 b",
261 "\$1 = 123abc3, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b",
262 ],
263 [
264 "123abc3",
265 qr#^(??{$re5})(|abc|def)(??{"$^R"})$#,
266 "1 2 abc",
267 "1 2 abc",
268 "\$1 = abc, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef",
269 ],
270 [
271 "123abc3",
272 qr#^(??{$re5})(|a(b)c|def)(??{"$^R"})$#,
273 "1 2 abc",
274 "1 2 b",
275 "\$1 = abc, \$2 = b, \$3 = undef, \$4 = undef, \$5 = undef",
276 ],
277 [
278 "1234",
279 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})))$#,
280 "1234 123 12 1 2 3 1234",
281 "1234 123 12 1 2 3 4",
282 "\$1 = 1234, \$2 = 1, \$3 = 2, \$4 = 3, \$5 = 4",
283 ],
284 [
285 "1234556",
286 qr#^(\d+)($re6)($re6)($re6)$re6(($re6)$re6)$#,
287 "1234556 123455 12345 1234 123 12 1 2 3 4 4 5 56",
288 "1234556 123455 12345 1234 123 12 1 2 3 4 4 5 5",
289 "\$1 = 1, \$2 = 2, \$3 = 3, \$4 = 4, \$5 = 56",
290 ],
291 [
292 "12345562",
293 qr#^((??{$re8}))($re7)($re7)($re7)$re7($re7)($re7(\2))$#,
294 "12345562 1234556 123455 12345 1234 123 12 1 2 3 4 4 5 62",
295 "12345562 1234556 123455 12345 1234 123 12 1 2 3 4 4 5 2",
296 "\$1 = 1, \$2 = 2, \$3 = 3, \$4 = 4, \$5 = 5",
297 ],
298 ) {
299 $c++;
300 @ctl_n = ();
301 @plus = ();
302 undef $^R;
303 my $match = $test->[0] =~ $test->[1];
304 my $str = join(", ", '$1 = '.$f->($1), '$2 = '.$f->($2), '$3 = '.$f->($3), '$4 = '.$f->($4),'$5 = '.$f->($5));
305 push @ctl_n, $f->($^N);
306 push @plus, $f->($+);
bb535cf1 307 ok($match, "match $c; Bug 56194");
0f289c68
YO
308 if (not $match) {
309 # unset $str, @ctl_n and @plus
310 $str = "";
311 @ctl_n = @plus = ();
312 }
bb535cf1
NC
313 is("@ctl_n", $test->[2], "ctl_n $c; Bug 56194");
314 is("@plus", $test->[3], "plus $c; Bug 56194");
315 is($str, $test->[4], "str $c; Bug 56194");
0f289c68
YO
316 }
317 SKIP: {
318 if ($] le '5.010') {
319 skip "test segfaults on perl < 5.10", 4;
320 }
321
322 @ctl_n = ();
323 @plus = ();
324
325 our $re4;
326 local $re4 = qr#(1)((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1})){2}(?{$^N})(|abc|def)(??{"$^R"})#;
327 undef $^R;
328 my $match = "123abc3" =~ m/^(??{$re4})$/;
329 my $str = join(", ", '$1 = '.$f->($1), '$2 = '.$f->($2), '$3 = '.$f->($3), '$4 = '.$f->($4),'$5 = '.$f->($5),'$^R = '.$f->($^R));
330 push @ctl_n, $f->($^N);
331 push @plus, $f->($+);
4b0d13b9 332 ok($match, 'Bug 56194');
0f289c68
YO
333 if (not $match) {
334 # unset $str
335 @ctl_n = ();
336 @plus = ();
337 $str = "";
338 }
4b0d13b9
NC
339 is("@ctl_n", "1 2 undef", 'Bug 56194');
340 is("@plus", "1 2 undef", 'Bug 56194');
341 is($str,
342 "\$1 = undef, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef, \$^R = undef",
343 'Bug 56194');
0f289c68
YO
344 }
345 }
346
d3cec5e5
DM
347 {
348 # re evals within \U, \Q etc shouldn't be seen by the lexer
349 local our $a = "i";
350 local our $B = "J";
351 ok('(?{1})' =~ /^\Q(?{1})\E$/, '\Q(?{1})\E');
352 ok('(?{1})' =~ /^\Q(?{\E1\}\)$/, '\Q(?{\E1\}\)');
353 use re 'eval';
354 ok('Ia' =~ /^\U(??{"$a\Ea"})$/, '^\U(??{"$a\Ea"})$');
355 ok('ja' =~ /^\L(??{"$B\Ea"})$/, '^\L(??{"$B\Ea"})$');
356 }
357
a39c66b9
DM
358 {
359 # Comprehensive (hopefully) tests of closure behaviour:
360 # i.e. when do (?{}) blocks get (re)compiled, and what instances
361 # of lexical vars do they close over?
362
947535e3
DM
363 # if the pattern string gets utf8 upgraded while concatenating,
364 # make sure a literal code block is still detected (by still
365 # compiling in the absence of use re 'eval')
366
367 {
368 my $s1 = "\x{80}";
369 my $s2 = "\x{100}";
370 ok("\x{80}\x{100}" =~ /^$s1(?{1})$s2$/, "utf8 upgrade");
371 }
372
a39c66b9
DM
373 my ($cr1, $cr2, $cr3, $cr4);
374
a39c66b9
DM
375 for my $x (qw(a b c)) {
376 my $bc = ($x ne 'a');
2bd8e0da 377 my $c80 = chr(0x80);
a39c66b9
DM
378
379 # the most basic: literal code should be in same scope
380 # as the parent
381
2bd8e0da
DM
382 ok("A$x" =~ /^A(??{$x})$/, "[$x] literal code");
383 ok("\x{100}$x" =~ /^\x{100}(??{$x})$/, "[$x] literal code UTF8");
a39c66b9
DM
384
385 # the "don't recompile if pattern unchanged" mechanism
386 # shouldn't apply to code blocks - recompile every time
387 # to pick up new instances of variables
388
fdfac248
DM
389 use re 'eval';
390
2bd8e0da
DM
391 my $code1 = 'B(??{$x})';
392 my $code1u = $c80 . "\x{100}" . '(??{$x})';
629cd4f3
DM
393 ok("AB$x" =~ /^A$code1$/, "[$x] unvarying runtime code AA");
394 ok("A$c80\x{100}$x" =~ /^A$code1u$/,
2bd8e0da 395 "[$x] unvarying runtime code AU");
629cd4f3 396 ok("$c80\x{100}B$x" =~ /^$c80\x{100}$code1$/,
2bd8e0da 397 "[$x] unvarying runtime code UA");
629cd4f3 398 ok("$c80\x{101}$c80\x{100}$x" =~ /^$c80\x{101}$code1u$/,
2bd8e0da 399 "[$x] unvarying runtime code UU");
a39c66b9
DM
400
401 # mixed literal and run-time code blocks
402
2bd8e0da
DM
403 my $code2 = 'B(??{$x})';
404 my $code2u = $c80 . "\x{100}" . '(??{$x})';
629cd4f3 405 ok("A$x-B$x" =~ /^A(??{$x})-$code2$/,
2bd8e0da 406 "[$x] literal+runtime AA");
629cd4f3 407 ok("A$x-$c80\x{100}$x" =~ /^A(??{$x})-$code2u$/,
2bd8e0da 408 "[$x] literal+runtime AU");
629cd4f3 409 ok("$c80\x{100}$x-B$x" =~ /^$c80\x{100}(??{$x})-$code2$/,
2bd8e0da 410 "[$x] literal+runtime UA");
629cd4f3 411 ok("$c80\x{101}$x-$c80\x{100}$x"
2bd8e0da
DM
412 =~ /^$c80\x{101}(??{$x})-$code2u$/,
413 "[$x] literal+runtime UU");
a39c66b9 414
fdfac248
DM
415 no re 'eval';
416
a39c66b9
DM
417 # literal qr code only created once, naked
418
419 $cr1 //= qr/^A(??{$x})$/;
d63c20f2 420 ok("Aa" =~ $cr1, "[$x] literal qr once naked");
a39c66b9
DM
421
422 # literal qr code only created once, embedded with text
423
424 $cr2 //= qr/B(??{$x})$/;
346d3070 425 ok("ABa" =~ /^A$cr2/, "[$x] literal qr once embedded text");
a39c66b9
DM
426
427 # literal qr code only created once, embedded with text + lit code
428
429 $cr3 //= qr/C(??{$x})$/;
346d3070 430 ok("A$x-BCa" =~ /^A(??{$x})-B$cr3/,
a39c66b9
DM
431 "[$x] literal qr once embedded text + lit code");
432
433 # literal qr code only created once, embedded with text + run code
434
435 $cr4 //= qr/C(??{$x})$/;
436 my $code3 = 'A(??{$x})';
fbf5ab7b
DM
437
438 use re 'eval';
629cd4f3 439 ok("A$x-BCa" =~ /^$code3-B$cr4/,
a39c66b9 440 "[$x] literal qr once embedded text + run code");
fdfac248 441 no re 'eval';
a39c66b9
DM
442
443 # literal qr code, naked
444
445 my $r1 = qr/^A(??{$x})$/;
d63c20f2 446 ok("A$x" =~ $r1, "[$x] literal qr naked");
a39c66b9
DM
447
448 # literal qr code, embedded with text
449
450 my $r2 = qr/B(??{$x})$/;
629cd4f3 451 ok("AB$x" =~ /^A$r2/, "[$x] literal qr embedded text");
a39c66b9
DM
452
453 # literal qr code, embedded with text + lit code
454
455 my $r3 = qr/C(??{$x})$/;
629cd4f3 456 ok("A$x-BC$x" =~ /^A(??{$x})-B$r3/,
a39c66b9
DM
457 "[$x] literal qr embedded text + lit code");
458
459 # literal qr code, embedded with text + run code
460
461 my $r4 = qr/C(??{$x})$/;
462 my $code4 = '(??{$x})';
fbf5ab7b
DM
463
464 use re 'eval';
629cd4f3 465 ok("A$x-BC$x" =~ /^A$code4-B$r4/,
a39c66b9 466 "[$x] literal qr embedded text + run code");
fbf5ab7b
DM
467 no re 'eval';
468
469 {
470 local $::TODO = 're_eval not yet secure!!';
471 eval { "A$x-BC$x" =~ /^A$code4-B$r4/ };
472 like($@, qr/Eval-group not allowed/, "runtime code5");
473 }
474
a39c66b9
DM
475
476 # nested qr in different scopes
477
478 my $code5 = '(??{$x})';
629cd4f3 479 my $r5 = qr/C(??{$x})/;
fbf5ab7b 480
fdfac248 481 use re 'eval';
629cd4f3 482 my $r6 = qr/$code5-C(??{$x})/;
fdfac248 483 no re 'eval';
a39c66b9
DM
484
485 my @rr5;
486 my @rr6;
487
488 for my $y (qw(d e f)) {
489
490 my $rr5 = qr/^A(??{"$x$y"})-$r5/;
491 push @rr5, $rr5;
629cd4f3 492 ok("A$x$y-C$x" =~ $rr5,
a39c66b9
DM
493 "[$x-$y] literal qr + r5");
494
495 my $rr6 = qr/^A(??{"$x$y"})-$r6/;
496 push @rr6, $rr6;
629cd4f3 497 ok("A$x$y-$x-C$x" =~ $rr6,
a39c66b9
DM
498 "[$x-$y] literal qr + r6");
499 }
500
501 for my $i (0,1,2) {
502 my $y = 'Y';
503 my $yy = (qw(d e f))[$i];
504 my $rr5 = $rr5[$i];
629cd4f3
DM
505 ok("A$x$yy-C$x" =~ $rr5, "[$x-$yy] literal qr + r5, outside");
506 ok("A$x$yy-C$x-D$x" =~ /$rr5-D(??{$x})$/,
a39c66b9
DM
507 "[$x-$yy] literal qr + r5 + lit, outside");
508
629cd4f3 509
a39c66b9
DM
510 my $rr6 = $rr6[$i];
511 push @rr6, $rr6;
629cd4f3 512 ok("A$x$yy-$x-C$x" =~ $rr6,
a39c66b9 513 "[$x-$yy] literal qr + r6, outside");
629cd4f3 514 ok("A$x$yy-$x-C$x-D$x" =~ /$rr6-D(??{$x})/,
a39c66b9
DM
515 "[$x-$yy] literal qr + r6 +lit, outside");
516 }
517 }
68e2671b
DM
518
519 # recursive subs should get lexical from the correct pad depth
520
521 sub recurse {
522 my ($n) = @_;
523 return if $n > 2;
524 ok("A$n" =~ /^A(??{$n})$/, "recurse($n)");
525 recurse($n+1);
526 }
527 recurse(0);
d63c20f2
DM
528
529 # for qr// containing run-time elements but with a compile-time
530 # code block, make sure the run-time bits are executed in the same
531 # pad they were compiled in
532 {
533 my $a = 'a'; # ensure outer and inner pads don't align
534 my $b = 'b';
535 my $c = 'c';
536 my $d = 'd';
537 my $r = qr/^$b(??{$c})$d$/;
538 ok("bcd" =~ $r, "qr with run-time elements and code block");
539 }
540
b30fcab9
DM
541 # check that cascaded embedded regexes all see their own lexical
542 # environment
543
544 {
545 my ($r1, $r2, $r3, $r4);
546 my ($x1, $x2, $x3, $x4) = (5,6,7,8);
547 { my $x1 = 1; $r1 = qr/A(??{$x1})/; }
548 { my $x2 = 2; $r2 = qr/$r1(??{$x2})/; }
549 { my $x3 = 3; $r3 = qr/$r2(??{$x3})/; }
550 { my $x4 = 4; $r4 = qr/$r3(??{$x4})/; }
551 ok("A1234" =~ /^$r4$/, "cascaded qr");
552 }
553
554 # and again, but in a loop, with no external references
555 # being maintained to the qr's
556
557 {
558 my $r = 'A';
559 for my $x (1..4) {
560 $r = qr/$r(??{$x})/;
561 }
562 my $x = 5;
563 ok("A1234" =~ /^$r$/, "cascaded qr loop");
564 }
565
566
567 # and again, but compiling the qrs in an eval so there
568 # aren't even refs to the qrs from any ops
569
570 {
571 my $r = 'A';
572 for my $x (1..4) {
573 $r = eval q[ qr/$r(??{$x})/; ];
574 }
575 my $x = 5;
576 ok("A1234" =~ /^$r$/, "cascaded qr loop");
577 }
578
87c6a48b
DM
579 # have qrs with either literal code blocks or only embedded
580 # code blocks, but not both
581
582 {
583 my ($r1, $r2, $r3, $r4);
584 my ($x1, $x3) = (7,8);
585 { my $x1 = 1; $r1 = qr/A(??{$x1})/; }
586 { $r2 = qr/${r1}2/; }
587 { my $x3 = 3; $r3 = qr/$r2(??{$x3})/; }
588 { $r4 = qr/${r3}4/; }
589 ok("A1234" =~ /^$r4$/, "cascaded qr mix 1");
590 ok("A12345" =~ /^${r4}5$/, "cascaded qr mix 2");
591 ok("A1234" =~ qr/^$r4$/ , "cascaded qr mix 3");
592 ok("A12345" =~ qr/^${r4}5$/, "cascaded qr mix 4");
593 }
594
595 # and make sure things are freed at the right time
596
04e69edb
DM
597 SKIP: {
598 if ($Config{mad}) {
599 skip "MAD doesn't free eval CVs", 3;
600 }
87c6a48b
DM
601
602 {
171982db
DM
603 sub Foo99::DESTROY { $Foo99::d++ }
604 $Foo99::d = 0;
87c6a48b
DM
605 my $r1;
606 {
171982db 607 my $x = bless [1], 'Foo99';
87c6a48b
DM
608 $r1 = eval 'qr/(??{$x->[0]})/';
609 }
610 my $r2 = eval 'qr/a$r1/';
611 my $x = 2;
171982db 612 ok(eval '"a1" =~ qr/^$r2$/', "match while in scope");
87c6a48b
DM
613 # make sure PL_reg_curpm isn't holding on to anything
614 "a" =~ /a(?{1})/;
171982db 615 is($Foo99::d, 0, "before scope exit");
87c6a48b 616 }
171982db 617 ::is($Foo99::d, 1, "after scope exit");
87c6a48b
DM
618 }
619
d63c20f2
DM
620 # forward declared subs should Do The Right Thing with any anon CVs
621 # within them (i.e. pad_fixup_inner_anons() should work)
622
623 sub forward;
624 sub forward {
625 my $x = "a";
626 my $A = "A";
627 ok("Aa" =~ qr/^A(??{$x})$/, "forward qr compiletime");
628 ok("Aa" =~ qr/^$A(??{$x})$/, "forward qr runtime");
629 }
630 forward;
a39c66b9
DM
631 }
632
0f289c68
YO
633} # End of sub run_tests
634
6351;