#!./perl
#
# This is a home for regular expression tests that don't fit into
# the format supported by re/regexp.t. If you want to add a test
# that does fit that format, add it to re/re_tests, not here.
use strict;
use warnings;
use 5.010;
sub run_tests;
$| = 1;
BEGIN {
require q(t/CORE/test.pl);
}
plan tests => 123; # Update this when adding/deleting tests.
run_tests() unless caller;
#
# Tests start here.
#
sub run_tests {
{
my $message = "Call code from qr //";
local $_ = 'var="foo"';
$a = qr/(?{++$b})/;
$b = 7;
ok(/$a$a/ && $b eq '9', $message);
my $c="$a";
ok(/$a$a/ && $b eq '11', $message);
undef $@;
eval {/$c/};
like($@, qr/not allowed at runtime/, $message);
use re "eval";
/$a$c$a/;
is($b, '14', $message);
our $lex_a = 43;
our $lex_b = 17;
our $lex_c = 27;
my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/);
is($lex_res, 1, $message);
is($lex_a, 44, $message);
is($lex_c, 43, $message);
no re "eval";
undef $@;
my $match = eval { /$a$c$a/ };
ok($@ && $@ =~ /Eval-group not allowed/ && !$match, $message);
is($b, '14', $message);
$lex_a = 2;
$lex_a = 43;
$lex_b = 17;
$lex_c = 27;
$lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/);
is($lex_res, 1, $message);
is($lex_a, 44, $message);
is($lex_c, 43, $message);
}
{
our $a = bless qr /foo/ => 'Foo';
ok 'goodfood' =~ $a, "Reblessed qr // matches";
is($a, '(?^:foo)', "Reblessed qr // stringifies");
my $x = "\x{3fe}";
my $z = my $y = "\317\276"; # Byte representation of $x
$a = qr /$x/;
ok $x =~ $a, "UTF-8 interpolation in qr //";
ok "a$a" =~ $x, "Stringified qr // preserves UTF-8";
ok "a$x" =~ /^a$a\z/, "Interpolated qr // preserves UTF-8";
ok "a$x" =~ /^a(??{$a})\z/,
"Postponed interpolation of qr // preserves UTF-8";
is(length qr /##/x, 9, "## in qr // doesn't corrupt memory; Bug 17776");
{
use re 'eval';
ok "$x$x" =~ /^$x(??{$x})\z/,
"Postponed UTF-8 string in UTF-8 re matches UTF-8";
ok "$y$x" =~ /^$y(??{$x})\z/,
"Postponed UTF-8 string in non-UTF-8 re matches UTF-8";
ok "$y$x" !~ /^$y(??{$y})\z/,
"Postponed non-UTF-8 string in non-UTF-8 re doesn't match UTF-8";
ok "$x$x" !~ /^$x(??{$y})\z/,
"Postponed non-UTF-8 string in UTF-8 re doesn't match UTF-8";
ok "$y$y" =~ /^$y(??{$y})\z/,
"Postponed non-UTF-8 string in non-UTF-8 re matches non-UTF8";
ok "$x$y" =~ /^$x(??{$y})\z/,
"Postponed non-UTF-8 string in UTF-8 re matches non-UTF8";
$y = $z; # Reset $y after upgrade.
ok "$x$y" !~ /^$x(??{$x})\z/,
"Postponed UTF-8 string in UTF-8 re doesn't match non-UTF-8";
ok "$y$y" !~ /^$y(??{$x})\z/,
"Postponed UTF-8 string in non-UTF-8 re doesn't match non-UTF-8";
}
}
{
use re 'eval';
# Test if $^N and $+ work in (?{{})
our @ctl_n = ();
our @plus = ();
our $nested_tags;
$nested_tags = qr{
<
((\w)+)
(?{
push @ctl_n, (defined $^N ? $^N : "undef");
push @plus, (defined $+ ? $+ : "undef");
})
>
(??{$nested_tags})*
</\s* \w+ \s*>
}x;
my $c = 0;
for my $test (
# Test structure:
# [ Expected result, Regex, Expected value(s) of $^N, Expected value(s) of $+ ]
[ 1, qr#^$nested_tags$#, "bla blubb bla", "a b a" ],
[ 1, qr#^($nested_tags)$#, "bla blubb <bla><blubb></blubb></bla>", "a b a" ],
[ 1, qr#^(|)$nested_tags$#, "bla blubb bla", "a b a" ],
[ 1, qr#^(?:|)$nested_tags$#, "bla blubb bla", "a b a" ],
[ 1, qr#^<(bl|bla)>$nested_tags<(/\1)>$#, "blubb /bla", "b /bla" ],
[ 1, qr#(??{"(|)"})$nested_tags$#, "bla blubb bla", "a b a" ],
[ 1, qr#^(??{"(bla|)"})$nested_tags$#, "bla blubb bla", "a b a" ],
[ 1, qr#^(??{"(|)"})(??{$nested_tags})$#, "bla blubb undef", "a b undef" ],
[ 1, qr#^(??{"(?:|)"})$nested_tags$#, "bla blubb bla", "a b a" ],
[ 1, qr#^((??{"(?:bla|)"}))((??{$nested_tags}))$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ],
[ 1, qr#^((??{"(?!)?"}))((??{$nested_tags}))$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ],
[ 1, qr#^((??{"(?:|<(/?bla)>)"}))((??{$nested_tags}))\1$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ],
[ 0, qr#^((??{"(?!)"}))?((??{$nested_tags}))(?!)$#, "bla blubb undef", "a b undef" ],
) { #"#silence vim highlighting
$c++;
@ctl_n = ();
@plus = ();
my $match = (("<bla><blubb></blubb></bla>" =~ $test->[1]) ? 1 : 0);
push @ctl_n, (defined $^N ? $^N : "undef");
push @plus, (defined $+ ? $+ : "undef");
ok($test->[0] == $match, "match $c");
if ($test->[0] != $match) {
# unset @ctl_n and @plus
@ctl_n = @plus = ();
}
is("@ctl_n", $test->[2], "ctl_n $c");
is("@plus", $test->[3], "plus $c");
}
}
{
use re 'eval';
our $f;
local $f;
$f = sub {
defined $_[0] ? $_[0] : "undef";
};
like("123", qr/^(\d)(((??{1 + $^N})))+$/, 'Bug 56194');
our @ctl_n;
our @plus;
my $re = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))*(?{$^N})#;
my $re2 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))*(?{$^N})(|a(b)c|def)(??{"$^R"})#;
my $re3 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})){2}(?{$^N})(|a(b)c|def)(??{"$^R"})#;
our $re5;
local $re5 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})){2}(?{$^N})#;
my $re6 = qr#(??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})#;
my $re7 = qr#(??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})#;
my $re8 = qr/(\d+)/;
my $c = 0;
for my $test (
# Test structure:
# [
# String to match
# Regex too match
# Expected values of $^N
# Expected values of $+
# Expected values of $1, $2, $3, $4 and $5
# ]
[
"1233",
qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(??{$^N})$#,
"1 2 3 3",
"1 2 3 3",
"\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
],
[
"1233",
qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(abc|def|)?(??{$+})$#,
"1 2 3 3",
"1 2 3 3",
"\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
],
[
"1233",
qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(|abc|def)?(??{$+})$#,
"1 2 3 3",
"1 2 3 3",
"\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
],
[
"1233",
qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(abc|def|)?(??{$^N})$#,
"1 2 3 3",
"1 2 3 3",
"\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
],
[
"1233",
qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(|abc|def)?(??{$^N})$#,
"1 2 3 3",
"1 2 3 3",
"\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
],
[
"123abc3",
qr#^($re)(|a(b)c|def)(??{$^R})$#,
"1 2 3 abc",
"1 2 3 b",
"\$1 = 123, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b",
],
[
"123abc3",
qr#^($re2)$#,
"1 2 3 123abc3",
"1 2 3 b",
"\$1 = 123abc3, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b",
],
[
"123abc3",
qr#^($re3)$#,
"1 2 123abc3",
"1 2 b",
"\$1 = 123abc3, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b",
],
[
"123abc3",
qr#^(??{$re5})(|abc|def)(??{"$^R"})$#,
"1 2 abc",
"1 2 abc",
"\$1 = abc, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef",
],
[
"123abc3",
qr#^(??{$re5})(|a(b)c|def)(??{"$^R"})$#,
"1 2 abc",
"1 2 b",
"\$1 = abc, \$2 = b, \$3 = undef, \$4 = undef, \$5 = undef",
],
[
"1234",
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})))$#,
"1234 123 12 1 2 3 1234",
"1234 123 12 1 2 3 4",
"\$1 = 1234, \$2 = 1, \$3 = 2, \$4 = 3, \$5 = 4",
],
[
"1234556",
qr#^(\d+)($re6)($re6)($re6)$re6(($re6)$re6)$#,
"1234556 123455 12345 1234 123 12 1 2 3 4 4 5 56",
"1234556 123455 12345 1234 123 12 1 2 3 4 4 5 5",
"\$1 = 1, \$2 = 2, \$3 = 3, \$4 = 4, \$5 = 56",
],
[
"12345562",
qr#^((??{$re8}))($re7)($re7)($re7)$re7($re7)($re7(\2))$#,
"12345562 1234556 123455 12345 1234 123 12 1 2 3 4 4 5 62",
"12345562 1234556 123455 12345 1234 123 12 1 2 3 4 4 5 2",
"\$1 = 1, \$2 = 2, \$3 = 3, \$4 = 4, \$5 = 5",
],
) {
$c++;
@ctl_n = ();
@plus = ();
undef $^R;
my $match = $test->[0] =~ $test->[1];
my $str = join(", ", '$1 = '.$f->($1), '$2 = '.$f->($2), '$3 = '.$f->($3), '$4 = '.$f->($4),'$5 = '.$f->($5));
push @ctl_n, $f->($^N);
push @plus, $f->($+);
ok($match, "match $c; Bug 56194");
if (not $match) {
# unset $str, @ctl_n and @plus
$str = "";
@ctl_n = @plus = ();
}
is("@ctl_n", $test->[2], "ctl_n $c; Bug 56194");
is("@plus", $test->[3], "plus $c; Bug 56194");
is($str, $test->[4], "str $c; Bug 56194");
}
SKIP: {
if ($] le '5.010') {
skip "test segfaults on perl < 5.10", 4;
}
@ctl_n = ();
@plus = ();
our $re4;
local $re4 = qr#(1)((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1})){2}(?{$^N})(|abc|def)(??{"$^R"})#;
undef $^R;
my $match = "123abc3" =~ m/^(??{$re4})$/;
my $str = join(", ", '$1 = '.$f->($1), '$2 = '.$f->($2), '$3 = '.$f->($3), '$4 = '.$f->($4),'$5 = '.$f->($5),'$^R = '.$f->($^R));
push @ctl_n, $f->($^N);
push @plus, $f->($+);
ok($match, 'Bug 56194');
if (not $match) {
# unset $str
@ctl_n = ();
@plus = ();
$str = "";
}
is("@ctl_n", "1 2 undef", 'Bug 56194');
is("@plus", "1 2 undef", 'Bug 56194');
is($str,
"\$1 = undef, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef, \$^R = undef",
'Bug 56194');
}
}
} # End of sub run_tests
1;