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