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     do "re/ReTest.pl" or die $@;
  21 }
  22
  23
  24 plan tests => 123;  # Update this when adding/deleting tests.
  25
  26 run_tests() unless caller;
  27
  28 #
  29 # Tests start here.
  30 #
  31 sub run_tests {
  32     {
  33         local $Message =  "Call code from qr //";
  34         local $_ = 'var="foo"';
  35         $a = qr/(?{++$b})/;
  36         $b = 7;
  37         ok /$a$a/ && $b eq '9';
  38
  39         my $c="$a";
  40         ok /$a$a/ && $b eq '11';
  41
  42         undef $@;
  43         eval {/$c/};
  44         ok $@ && $@ =~ /not allowed at runtime/;
  45
  46         use re "eval";
  47         /$a$c$a/;
  48         iseq $b, '14';
  49
  50         our $lex_a = 43;
  51         our $lex_b = 17;
  52         our $lex_c = 27;
  53         my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/);
  54
  55         iseq $lex_res, 1;
  56         iseq $lex_a, 44;
  57         iseq $lex_c, 43;
  58
  59         no re "eval";
  60         undef $@;
  61         my $match = eval { /$a$c$a/ };
  62         ok $@ && $@ =~ /Eval-group not allowed/ && !$match;
  63         iseq $b, '14';
  64
  65         $lex_a = 2;
  66         $lex_a = 43;
  67         $lex_b = 17;
  68         $lex_c = 27;
  69         $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/);
  70
  71         iseq $lex_res, 1;
  72         iseq $lex_a, 44;
  73         iseq $lex_c, 43;
  74
  75     }
  76
  77     {
  78         our $a = bless qr /foo/ => 'Foo';
  79         ok 'goodfood' =~ $a,     "Reblessed qr // matches";
  80         iseq $a, '(?^:foo)', "Reblessed qr // stringifies";
  81         my $x = "\x{3fe}";
  82         my $z = my $y = "\317\276";  # Byte representation of $x
  83         $a = qr /$x/;
  84         ok $x =~ $a, "UTF-8 interpolation in qr //";
  85         ok "a$a" =~ $x, "Stringified qr // preserves UTF-8";
  86         ok "a$x" =~ /^a$a\z/, "Interpolated qr // preserves UTF-8";
  87         ok "a$x" =~ /^a(??{$a})\z/,
  88                         "Postponed interpolation of qr // preserves UTF-8";
  89         {
  90             local $BugId = '17776';
  91             iseq length qr /##/x, 9, "## in qr // doesn't corrupt memory";
  92         }
  93         {
  94             use re 'eval';
  95             ok "$x$x" =~ /^$x(??{$x})\z/,
  96                "Postponed UTF-8 string in UTF-8 re matches UTF-8";
  97             ok "$y$x" =~ /^$y(??{$x})\z/,
  98                "Postponed UTF-8 string in non-UTF-8 re matches UTF-8";
  99             ok "$y$x" !~ /^$y(??{$y})\z/,
 100                "Postponed non-UTF-8 string in non-UTF-8 re doesn't match UTF-8";
 101             ok "$x$x" !~ /^$x(??{$y})\z/,
 102                "Postponed non-UTF-8 string in UTF-8 re doesn't match UTF-8";
 103             ok "$y$y" =~ /^$y(??{$y})\z/,
 104                "Postponed non-UTF-8 string in non-UTF-8 re matches non-UTF8";
 105             ok "$x$y" =~ /^$x(??{$y})\z/,
 106                "Postponed non-UTF-8 string in UTF-8 re matches non-UTF8";
 107
 108             $y = $z;  # Reset $y after upgrade.
 109             ok "$x$y" !~ /^$x(??{$x})\z/,
 110                "Postponed UTF-8 string in UTF-8 re doesn't match non-UTF-8";
 111             ok "$y$y" !~ /^$y(??{$x})\z/,
 112                "Postponed UTF-8 string in non-UTF-8 re doesn't match non-UTF-8";
 113         }
 114     }
 115
 116
 117     {
 118         use re 'eval';
 119         local $Message = 'Test if $^N and $+ work in (?{{})';
 120         our @ctl_n = ();
 121         our @plus = ();
 122         our $nested_tags;
 123         $nested_tags = qr{
 124             <
 125                ((\w)+)
 126                (?{
 127                        push @ctl_n, (defined $^N ? $^N : "undef");
 128                        push @plus, (defined $+ ? $+ : "undef");
 129                })
 130             >
 131             (??{$nested_tags})*
 132             </\s* \w+ \s*>
 133         }x;
 134
 135
 136         my $c = 0;
 137         for my $test (
 138             # Test structure:
 139             #  [ Expected result, Regex, Expected value(s) of $^N, Expected value(s) of $+ ]
 140             [ 1, qr#^$nested_tags$#, "bla blubb bla", "a b a" ],
 141             [ 1, qr#^($nested_tags)$#, "bla blubb <bla><blubb></blubb></bla>", "a b a" ],
 142             [ 1, qr#^(|)$nested_tags$#, "bla blubb bla", "a b a" ],
 143             [ 1, qr#^(?:|)$nested_tags$#, "bla blubb bla", "a b a" ],
 144             [ 1, qr#^<(bl|bla)>$nested_tags<(/\1)>$#, "blubb /bla", "b /bla" ],
 145             [ 1, qr#(??{"(|)"})$nested_tags$#, "bla blubb bla", "a b a" ],
 146             [ 1, qr#^(??{"(bla|)"})$nested_tags$#, "bla blubb bla", "a b a" ],
 147             [ 1, qr#^(??{"(|)"})(??{$nested_tags})$#, "bla blubb undef", "a b undef" ],
 148             [ 1, qr#^(??{"(?:|)"})$nested_tags$#, "bla blubb bla", "a b a" ],
 149             [ 1, qr#^((??{"(?:bla|)"}))((??{$nested_tags}))$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ],
 150             [ 1, qr#^((??{"(?!)?"}))((??{$nested_tags}))$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ],
 151             [ 1, qr#^((??{"(?:|<(/?bla)>)"}))((??{$nested_tags}))\1$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ],
 152             [ 0, qr#^((??{"(?!)"}))?((??{$nested_tags}))(?!)$#, "bla blubb undef", "a b undef" ],
 153
 154         ) { #"#silence vim highlighting
 155             $c++;
 156             @ctl_n = ();
 157             @plus = ();
 158             my $match = (("<bla><blubb></blubb></bla>" =~ $test->[1]) ? 1 : 0);
 159             push @ctl_n, (defined $^N ? $^N : "undef");
 160             push @plus, (defined $+ ? $+ : "undef");
 161             ok($test->[0] == $match, "match $c");
 162             if ($test->[0] != $match) {
 163               # unset @ctl_n and @plus
 164               @ctl_n = @plus = ();
 165             }
 166             iseq("@ctl_n", $test->[2], "ctl_n $c");
 167             iseq("@plus", $test->[3], "plus $c");
 168         }
 169     }
 170
 171     {
 172         use re 'eval';
 173         local $BugId = '56194';
 174
 175         our $f;
 176         local $f;
 177         $f = sub {
 178             defined $_[0] ? $_[0] : "undef";
 179         };
 180
 181         ok("123" =~ m/^(\d)(((??{1 + $^N})))+$/);
 182
 183         our @ctl_n;
 184         our @plus;
 185
 186         my $re  = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))*(?{$^N})#;
 187         my $re2 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))*(?{$^N})(|a(b)c|def)(??{"$^R"})#;
 188         my $re3 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})){2}(?{$^N})(|a(b)c|def)(??{"$^R"})#;
 189         our $re5;
 190         local $re5 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})){2}(?{$^N})#;
 191         my $re6 = qr#(??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})#;
 192         my $re7 = qr#(??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})#;
 193         my $re8 = qr/(\d+)/;
 194         my $c = 0;
 195         for my $test (
 196              # Test structure:
 197              #  [
 198              #    String to match
 199              #    Regex too match
 200              #    Expected values of $^N
 201              #    Expected values of $+
 202              #    Expected values of $1, $2, $3, $4 and $5
 203              #  ]
 204              [
 205                   "1233",
 206                   qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(??{$^N})$#,
 207                   "1 2 3 3",
 208                   "1 2 3 3",
 209                   "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
 210              ],
 211              [
 212                   "1233",
 213                   qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(abc|def|)?(??{$+})$#,
 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|)?(??{$^N})$#,
 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                   "123abc3",
 241                    qr#^($re)(|a(b)c|def)(??{$^R})$#,
 242                    "1 2 3 abc",
 243                    "1 2 3 b",
 244                    "\$1 = 123, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b",
 245               ],
 246               [
 247                   "123abc3",
 248                    qr#^($re2)$#,
 249                    "1 2 3 123abc3",
 250                    "1 2 3 b",
 251                    "\$1 = 123abc3, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b",
 252               ],
 253               [
 254                   "123abc3",
 255                    qr#^($re3)$#,
 256                    "1 2 123abc3",
 257                    "1 2 b",
 258                    "\$1 = 123abc3, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b",
 259               ],
 260               [
 261                   "123abc3",
 262                    qr#^(??{$re5})(|abc|def)(??{"$^R"})$#,
 263                    "1 2 abc",
 264                    "1 2 abc",
 265                    "\$1 = abc, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef",
 266               ],
 267               [
 268                   "123abc3",
 269                    qr#^(??{$re5})(|a(b)c|def)(??{"$^R"})$#,
 270                    "1 2 abc",
 271                    "1 2 b",
 272                    "\$1 = abc, \$2 = b, \$3 = undef, \$4 = undef, \$5 = undef",
 273               ],
 274               [
 275                   "1234",
 276                    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})))$#,
 277                    "1234 123 12 1 2 3 1234",
 278                    "1234 123 12 1 2 3 4",
 279                    "\$1 = 1234, \$2 = 1, \$3 = 2, \$4 = 3, \$5 = 4",
 280               ],
 281               [
 282                    "1234556",
 283                    qr#^(\d+)($re6)($re6)($re6)$re6(($re6)$re6)$#,
 284                    "1234556 123455 12345 1234 123 12 1 2 3 4 4 5 56",
 285                    "1234556 123455 12345 1234 123 12 1 2 3 4 4 5 5",
 286                    "\$1 = 1, \$2 = 2, \$3 = 3, \$4 = 4, \$5 = 56",
 287               ],
 288               [
 289                   "12345562",
 290                    qr#^((??{$re8}))($re7)($re7)($re7)$re7($re7)($re7(\2))$#,
 291                    "12345562 1234556 123455 12345 1234 123 12 1 2 3 4 4 5 62",
 292                    "12345562 1234556 123455 12345 1234 123 12 1 2 3 4 4 5 2",
 293                    "\$1 = 1, \$2 = 2, \$3 = 3, \$4 = 4, \$5 = 5",
 294               ],
 295         ) {
 296             $c++;
 297             @ctl_n = ();
 298             @plus = ();
 299             undef $^R;
 300             my $match = $test->[0] =~ $test->[1];
 301             my $str = join(", ", '$1 = '.$f->($1), '$2 = '.$f->($2), '$3 = '.$f->($3), '$4 = '.$f->($4),'$5 = '.$f->($5));
 302             push @ctl_n, $f->($^N);
 303             push @plus, $f->($+);
 304             ok($match, "match $c");
 305             if (not $match) {
 306                 # unset $str, @ctl_n and @plus
 307                 $str = "";
 308                 @ctl_n = @plus = ();
 309             }
 310             iseq("@ctl_n", $test->[2], "ctl_n $c");
 311             iseq("@plus", $test->[3], "plus $c");
 312             iseq($str, $test->[4], "str $c");
 313         }
 314         SKIP: {
 315             if ($] le '5.010') {
 316                 skip "test segfaults on perl < 5.10", 4;
 317             }
 318
 319             @ctl_n = ();
 320             @plus = ();
 321
 322             our $re4;
 323             local $re4 = qr#(1)((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1})){2}(?{$^N})(|abc|def)(??{"$^R"})#;
 324             undef $^R;
 325             my $match = "123abc3" =~ m/^(??{$re4})$/;
 326             my $str = join(", ", '$1 = '.$f->($1), '$2 = '.$f->($2), '$3 = '.$f->($3), '$4 = '.$f->($4),'$5 = '.$f->($5),'$^R = '.$f->($^R));
 327             push @ctl_n, $f->($^N);
 328             push @plus, $f->($+);
 329             ok($match);
 330             if (not $match) {
 331                 # unset $str
 332                 @ctl_n = ();
 333                 @plus = ();
 334                 $str = "";
 335             }
 336             iseq("@ctl_n", "1 2 undef");
 337             iseq("@plus", "1 2 undef");
 338             iseq($str, "\$1 = undef, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef, \$^R = undef");
 339        }
 340     }
 341
 342 } # End of sub run_tests
 343
 344 1;