This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ensure regex evals report the right location
[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 Config;
10 use 5.010;
11
12
13 sub run_tests;
14
15 $| = 1;
16
17
18 BEGIN {
19     chdir 't' if -d 't';
20     @INC = ('../lib','.');
21     require './test.pl';
22     skip_all_if_miniperl("no dynamic loading on miniperl, no re");
23 }
24
25
26 plan tests => 355;  # Update this when adding/deleting tests.
27
28 run_tests() unless caller;
29
30 #
31 # Tests start here.
32 #
33 sub run_tests {
34     {
35         my $message =  "Call code from qr //";
36         local $_ = 'var="foo"';
37         $a = qr/(?{++$b})/;
38         $b = 7;
39         ok(/$a$a/ && $b eq '9', $message);
40
41         my $c="$a";
42         ok(/$a$a/ && $b eq '11', $message);
43
44         undef $@;
45         eval {/$c/};
46         like($@, qr/not allowed at runtime/, $message);
47
48         use re "eval";
49         /$a$c$a/;
50         is($b, '14', $message);
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
57         is($lex_res, 1, $message);
58         is($lex_a, 44, $message);
59         is($lex_c, 43, $message);
60
61         no re "eval";
62         undef $@;
63         my $d = '(?{1})';
64         my $match = eval { /$a$c$a$d/ };
65         ok($@ && $@ =~ /Eval-group not allowed/ && !$match, $message);
66         is($b, '14', $message);
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
74         is($lex_res, 1, $message);
75         is($lex_a, 44, $message);
76         is($lex_c, 43, $message);
77
78     }
79
80     {
81         our $a = bless qr /foo/ => 'Foo';
82         ok 'goodfood' =~ $a,     "Reblessed qr // matches";
83         is($a, '(?^:foo)', "Reblessed qr // stringifies");
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";
92
93
94         is(length qr /##/x, 9, "## in qr // doesn't corrupt memory; Bug 17776");
95
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';
122         # Test if $^N and $+ work in (?{{})
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             }
169             is("@ctl_n", $test->[2], "ctl_n $c");
170             is("@plus", $test->[3], "plus $c");
171         }
172     }
173
174     {
175         use re 'eval';
176
177
178         our $f;
179         local $f;
180         $f = sub {
181             defined $_[0] ? $_[0] : "undef";
182         };
183
184         like("123", qr/^(\d)(((??{1 + $^N})))+$/, 'Bug 56194');
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->($+);
307             ok($match, "match $c; Bug 56194");
308             if (not $match) {
309                 # unset $str, @ctl_n and @plus
310                 $str = "";
311                 @ctl_n = @plus = ();
312             }
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");
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->($+);
332             ok($match, 'Bug 56194');
333             if (not $match) {
334                 # unset $str
335                 @ctl_n = ();
336                 @plus = ();
337                 $str = "";
338             }
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');
344        }
345     }
346
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
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
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
373         my ($cr1, $cr2, $cr3, $cr4);
374
375         for my $x (qw(a b c)) {
376             my $bc = ($x ne 'a');
377             my $c80 = chr(0x80);
378
379             # the most basic: literal code should be in same scope
380             # as the parent
381
382             ok("A$x"       =~ /^A(??{$x})$/,       "[$x] literal code");
383             ok("\x{100}$x" =~ /^\x{100}(??{$x})$/, "[$x] literal code UTF8");
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
389             use re 'eval';
390
391             my $code1  = 'B(??{$x})';
392             my $code1u = $c80 . "\x{100}" . '(??{$x})';
393             ok("AB$x" =~ /^A$code1$/, "[$x] unvarying runtime code AA");
394             ok("A$c80\x{100}$x" =~ /^A$code1u$/,
395                                         "[$x] unvarying runtime code AU");
396             ok("$c80\x{100}B$x" =~ /^$c80\x{100}$code1$/,
397                                         "[$x] unvarying runtime code UA");
398             ok("$c80\x{101}$c80\x{100}$x" =~ /^$c80\x{101}$code1u$/,
399                                         "[$x] unvarying runtime code UU");
400
401             # mixed literal and run-time code blocks
402
403             my $code2  = 'B(??{$x})';
404             my $code2u = $c80 . "\x{100}" . '(??{$x})';
405             ok("A$x-B$x" =~ /^A(??{$x})-$code2$/,
406                                         "[$x] literal+runtime AA");
407             ok("A$x-$c80\x{100}$x" =~ /^A(??{$x})-$code2u$/,
408                                         "[$x] literal+runtime AU");
409             ok("$c80\x{100}$x-B$x" =~ /^$c80\x{100}(??{$x})-$code2$/,
410                                         "[$x] literal+runtime UA");
411             ok("$c80\x{101}$x-$c80\x{100}$x"
412                                         =~ /^$c80\x{101}(??{$x})-$code2u$/,
413                                         "[$x] literal+runtime UU");
414
415             no re 'eval';
416
417             # literal qr code only created once, naked
418
419             $cr1 //= qr/^A(??{$x})$/;
420             ok("Aa" =~ $cr1, "[$x] literal qr once naked");
421
422             # literal qr code only created once, embedded with text
423
424             $cr2 //= qr/B(??{$x})$/;
425             ok("ABa" =~ /^A$cr2/, "[$x] literal qr once embedded text");
426
427             # literal qr code only created once, embedded with text + lit code
428
429             $cr3 //= qr/C(??{$x})$/;
430             ok("A$x-BCa" =~ /^A(??{$x})-B$cr3/,
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})';
437
438             use re 'eval';
439             ok("A$x-BCa" =~ /^$code3-B$cr4/,
440                             "[$x] literal qr once embedded text + run code");
441             no re 'eval';
442
443             # literal qr code, naked
444
445             my $r1 = qr/^A(??{$x})$/;
446             ok("A$x" =~ $r1, "[$x] literal qr naked");
447
448             # literal qr code, embedded with text
449
450             my $r2 = qr/B(??{$x})$/;
451             ok("AB$x" =~ /^A$r2/, "[$x] literal qr embedded text");
452
453             # literal qr code, embedded with text + lit code
454
455             my $r3 = qr/C(??{$x})$/;
456             ok("A$x-BC$x" =~ /^A(??{$x})-B$r3/,
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})';
463
464             use re 'eval';
465             ok("A$x-BC$x" =~ /^A$code4-B$r4/,
466                                 "[$x] literal qr embedded text + run code");
467             no re 'eval';
468
469             {
470                 eval { "A$x-BC$x" =~ /^A$code4-B$r4/ };
471                 like($@, qr/Eval-group not allowed/, "runtime code5");
472             }
473
474
475             # nested qr in different scopes
476
477             my $code5 = '(??{$x})';
478             my $r5 = qr/C(??{$x})/;
479
480             use re 'eval';
481             my $r6 = qr/$code5-C(??{$x})/;
482             no re 'eval';
483
484             my @rr5;
485             my @rr6;
486
487             for my $y (qw(d e f)) {
488
489                 my $rr5 = qr/^A(??{"$x$y"})-$r5/;
490                 push @rr5, $rr5;
491                 ok("A$x$y-C$x" =~ $rr5,
492                                 "[$x-$y] literal qr + r5");
493
494                 my $rr6 = qr/^A(??{"$x$y"})-$r6/;
495                 push @rr6, $rr6;
496                 ok("A$x$y-$x-C$x" =~ $rr6,
497                                 "[$x-$y] literal qr + r6");
498             }
499
500             for my $i (0,1,2) {
501                 my $y = 'Y';
502                 my $yy = (qw(d e f))[$i];
503                 my $rr5 = $rr5[$i];
504                 ok("A$x$yy-C$x" =~ $rr5, "[$x-$yy] literal qr + r5, outside");
505                 ok("A$x$yy-C$x-D$x" =~ /$rr5-D(??{$x})$/,
506                                 "[$x-$yy] literal qr + r5 + lit, outside");
507
508
509                 my $rr6 = $rr6[$i];
510                 push @rr6, $rr6;
511                 ok("A$x$yy-$x-C$x" =~ $rr6,
512                                 "[$x-$yy] literal qr + r6, outside");
513                 ok("A$x$yy-$x-C$x-D$x" =~ /$rr6-D(??{$x})/,
514                                 "[$x-$yy] literal qr + r6 +lit, outside");
515             }
516         }
517
518         # recursive subs should get lexical from the correct pad depth
519
520         sub recurse {
521             my ($n) = @_;
522             return if $n > 2;
523             ok("A$n" =~ /^A(??{$n})$/, "recurse($n)");
524             recurse($n+1);
525         }
526         recurse(0);
527
528         # for qr// containing run-time elements but with a compile-time
529         # code block, make sure the run-time bits are executed in the same
530         # pad they were compiled in
531         {
532             my $a = 'a'; # ensure outer and inner pads don't align
533             my $b = 'b';
534             my $c = 'c';
535             my $d = 'd';
536             my $r = qr/^$b(??{$c})$d$/;
537             ok("bcd" =~ $r, "qr with run-time elements and code block");
538         }
539
540         # check that cascaded embedded regexes all see their own lexical
541         # environment
542
543         {
544             my ($r1, $r2, $r3, $r4);
545             my ($x1, $x2, $x3, $x4) = (5,6,7,8);
546             { my $x1 = 1; $r1 = qr/A(??{$x1})/; }
547             { my $x2 = 2; $r2 = qr/$r1(??{$x2})/; }
548             { my $x3 = 3; $r3 = qr/$r2(??{$x3})/; }
549             { my $x4 = 4; $r4 = qr/$r3(??{$x4})/; }
550             ok("A1234" =~ /^$r4$/, "cascaded qr");
551         }
552
553         # and again, but in a loop, with no external references
554         # being maintained to the qr's
555
556         {
557             my $r = 'A';
558             for my $x (1..4) {
559                 $r = qr/$r(??{$x})/;
560             }
561             my $x = 5;
562             ok("A1234" =~ /^$r$/, "cascaded qr loop");
563         }
564
565
566         # and again, but compiling the qrs in an eval so there
567         # aren't even refs to the qrs from any ops
568
569         {
570             my $r = 'A';
571             for my $x (1..4) {
572                 $r = eval q[ qr/$r(??{$x})/; ];
573             }
574             my $x = 5;
575             ok("A1234" =~ /^$r$/, "cascaded qr loop");
576         }
577
578         # have qrs with either literal code blocks or only embedded
579         # code blocks, but not both
580
581         {
582             my ($r1, $r2, $r3, $r4);
583             my ($x1, $x3) = (7,8);
584             { my $x1 = 1; $r1 = qr/A(??{$x1})/; }
585             {             $r2 = qr/${r1}2/; }
586             { my $x3 = 3; $r3 = qr/$r2(??{$x3})/; }
587             {             $r4 = qr/${r3}4/; }
588             ok("A1234"  =~   /^$r4$/,    "cascaded qr mix 1");
589             ok("A12345" =~   /^${r4}5$/, "cascaded qr mix 2");
590             ok("A1234"  =~ qr/^$r4$/   , "cascaded qr mix 3");
591             ok("A12345" =~ qr/^${r4}5$/, "cascaded qr mix 4");
592         }
593
594         # and make sure things are freed at the right time
595
596         SKIP: {
597             if ($Config{mad}) {
598                 skip "MAD doesn't free eval CVs", 3;
599             }
600
601             {
602                 sub Foo99::DESTROY { $Foo99::d++ }
603                 $Foo99::d = 0;
604                 my $r1;
605                 {
606                     my $x = bless [1], 'Foo99';
607                     $r1 = eval 'qr/(??{$x->[0]})/';
608                 }
609                 my $r2 = eval 'qr/a$r1/';
610                 my $x = 2;
611                 ok(eval '"a1" =~ qr/^$r2$/', "match while in scope");
612                 # make sure PL_reg_curpm isn't holding on to anything
613                 "a" =~ /a(?{1})/;
614                 is($Foo99::d, 0, "before scope exit");
615             }
616             ::is($Foo99::d, 1, "after scope exit");
617         }
618
619         # forward declared subs should Do The Right Thing with any anon CVs
620         # within them (i.e. pad_fixup_inner_anons() should work)
621
622         sub forward;
623         sub forward {
624             my $x = "a";
625             my $A = "A";
626             ok("Aa" =~ qr/^A(??{$x})$/,  "forward qr compiletime");
627             ok("Aa" =~ qr/^$A(??{$x})$/, "forward qr runtime");
628         }
629         forward;
630     }
631
632     # test that run-time embedded code, when re-fed into toker,
633     # does all the right escapes
634
635     {
636         use re 'eval';
637
638         my $enc = eval 'use Encode; find_encoding("ascii")';
639
640         my $x = 0;
641         my $y = 'bad';
642
643         # note that most of the strings below are single-quoted, and the
644         # things within them, like '$y', *aren't* intended to interpolate
645
646         my $s1 =
647             'a\\$y(?# (??{BEGIN{$x=1} "X1"})b(?# \Ux2\E)c\'d\\\\e\\\\Uf\\\\E';
648
649         ok(q{a$ybc'd\e\Uf\E} =~ /^$s1$/, "reparse");
650         is($x, 0, "reparse no BEGIN");
651
652         my $s2 = 'g\\$y# (??{{BEGIN{$x=2} "X3"}) \Ux3\E'  . "\nh";
653
654         ok(q{a$ybc'd\\e\\Uf\\Eg$yh} =~ /^$s1$s2$/x, "reparse /x");
655         is($x, 0, "reparse /x no BEGIN");
656
657         my $b = '\\';
658         my $q = '\'';
659
660         #  non-ascii in string as "<0xNNN>"
661         sub esc_str {
662             my $s = shift;
663             $s =~ s{(.)}{
664                         my $c = ord($1);
665                         ($c< 32 || $c > 127) ? sprintf("<0x%x>", $c) : $1;
666                 }ge;
667             $s;
668         }
669         sub  fmt { sprintf "hairy backslashes %s [%s] =~ /^%s/",
670                         $_[0], esc_str($_[1]), esc_str($_[2]);
671         }
672
673
674         for my $u (
675             [ '',  '', 'blank ' ],
676             [ "\x{100}", '\x{100}', 'single' ],
677             [ "\x{100}", "\x{100}", 'double' ])
678         {
679             for my $pair (
680                     [ "$b",        "$b$b"               ],
681                     [ "$q",        "$q"                 ],
682                     [ "$b$q",      "$b$b$b$q"           ],
683                     [ "$b$b$q",    "$b$b$b$b$q"         ],
684                     [ "$b$b$b$q",  "$b$b$b$b$b$b$q"     ],
685                     [ "$b$b$b$b$q","$b$b$b$b$b$b$b$b$q" ],
686             ) {
687                 my ($s, $r) = @$pair;
688                 $s = "9$s";
689                 my $ss = "$u->[0]$s";
690
691                 my $c = '9' . $r;
692                 my $cc = "$u->[1]$c";
693                 ok($ss =~ /^$cc/, fmt("plain $u->[2]", $ss, $cc));
694
695                 no strict;
696                 my $chr41 = "\x41";
697                 $ss = "$u->[0]\t${q}$chr41${b}x42$s";
698                 $nine = $nine = "bad";
699                 for my $use_qr ('', 'qr') {
700                     $c =  qq[(??{my \$z='{';]
701                         . qq[$use_qr"$b${b}t$b$q$b${b}x41$b$b$b${b}x42"]
702                         . qq[. \$nine})];
703                     # (??{ qr/str/ }) goes through one less interpolation
704                     # stage than  (??{ qq/str/ })
705                     $c =~ s{\\\\}{\\}g if ($use_qr eq 'qr');
706                     $c .= $r;
707                     $cc = "$u->[1]$c";
708                     my $nine = 9;
709                     ok($ss =~ /^$cc/, fmt("code   $u->[2]", $ss, $cc));
710                     {
711                         # Poor man's "use encoding 'ascii'".
712                         # This causes a different code path in S_const_str()
713                         # to be used
714                         local ${^ENCODING} = $enc;
715                         ok($ss =~ /^$cc/, fmt("encode $u->[2]", $ss, $cc));
716                     }
717                 }
718             }
719         }
720
721         my $code1u = "(??{qw(\x{100})})";
722         ok("\x{100}" =~ /^$code1u$/, "reparse embeded unicode");
723     }
724
725     # a non-pattern literal won't get code blocks parsed at compile time;
726     # but they must get parsed later on if 'use re eval' is in scope
727     # also check that unbalanced {}'s are parsed ok
728
729     {
730         use re 'eval';
731         ok("a{" =~ '^(??{"a{"})$', "non-pattern literal code");
732         ok("a{" =~ /^${\'(??{"a{"})'}$/, "runtime code with unbalanced {}");
733     }
734
735     # make sure warnings come from the right place
736
737     {
738         use warnings;
739         my ($s, $t, $w);
740         local $SIG{__WARN__} = sub { $w .= "@_" };
741
742         $w = ''; $s = 's';
743         my $r = qr/(?{$t=$s+1})/;
744         "a" =~ /a$r/;
745         like($w, qr/pat_re_eval/, "warning main file");
746
747         # do it in an eval to get predictable line numbers
748         eval q[
749
750             $r = qr/(?{$t=$s+1})/;
751         ];
752         $w = ''; $s = 's';
753         "a" =~ /a$r/;
754         like($w, qr/ at \(eval \d+\) line 3/, "warning eval A");
755
756         $w = ''; $s = 's';
757         eval q[
758             use re 'eval';
759             my $c = '(?{$t=$s+1})';
760             "a" =~ /a$c/;
761             1;
762         ];
763         like($w, qr/ at \(eval \d+\) line 1/, "warning eval B");
764     }
765
766 } # End of sub run_tests
767
768 1;