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