t/re/pat_re_eval.t

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