t/pod/diag.t Test completeness of perldiag.pod
t/porting/checkcase.t Check whether we are case-insensitive-fs-friendly
t/README Instructions for regression tests
-t/re/pat.t See if esoteric patterns work
-t/re/pat_thr.t See if esoteric patterns work in another thread
t/re/pat_advanced.t See if advanced esoteric patterns work
t/re/pat_advanced_thr.t See if advanced esoteric patterns work in another thread
t/re/pat_psycho.t See if insane esoteric and slow patterns work
t/re/pat_psycho_thr.t See if insane esoteric and slow patterns work in another thread
+t/re/pat_re_eval.t See if esoteric patterns using re 'eval' work
+t/re/pat_re_eval_thr.t See if esoteric patterns using re 'eval' work in another thread
t/re/pat_rt_report.t See if esoteric patterns from rt reports work
t/re/pat_rt_report_thr.t See if esoteric patterns from rt reports work in another thread
+t/re/pat.t See if esoteric patterns work
+t/re/pat_thr.t See if esoteric patterns work in another thread
t/re/qr_gc.t See if qr doesn't leak
t/re/qrstack.t See if qr expands the stack properly
t/re/qr.t See if qr works
t/re/reg_posixcc.t See if posix character classes behave consistantly
t/re/reg_unsafe.t Check for unsafe match vars
t/re/re.t See if exportable 're' funcs in universal.c work
-t/re/re_tests Regular expressions for regexp.t
t/re/ReTest.pl Test utilities for the t/re/pat*.t tests (used by do)
+t/re/re_tests Regular expressions for regexp.t
t/re/rxcode.t See if /(?{ code })/ works
t/re/subst_amp.t See if $&-related substitution works
t/re/substr.t See if substr works
}
-plan tests => 305; # Update this when adding/deleting tests.
+plan tests => 293; # Update this when adding/deleting tests.
run_tests() unless caller;
{
local $Message = q !Check $`, $&, $'!;
$_ = 'abcdefghi';
- /def/; # optimized up to cmd
+ /def/; # optimized up to cmd
iseq "$`:$&:$'", 'abc:def:ghi';
no warnings 'void';
- /cde/ + 0; # optimized only to spat
+ /cde/ + 0; # optimized only to spat
iseq "$`:$&:$'", 'ab:cde:fghi';
- /[d][e][f]/; # not optimized
+ /[d][e][f]/; # not optimized
iseq "$`:$&:$'", 'abc:def:ghi';
}
'ax13876y25677mcb' => 0, # not b.
'ax13876y35677nbc' => 0, # Num too big
'ax13876y25677y21378obc' => 1,
- 'ax13876y25677y21378zbc' => 0, # Not followed by [k-o]
+ 'ax13876y25677y21378zbc' => 0, # Not followed by [k-o]
'ax13876y25677y21378y21378kbc' => 1,
'ax13876y25677y21378y21378kcb' => 0, # Not b.
'ax13876y25677y21378y21378y21378kbc' => 0, # 5 runs
m/
(
\(
- (?{ $c = 1 }) # Initialize
+ (?{ $c = 1 }) # Initialize
(?:
(?(?{ $c == 0 }) # PREVIOUS iteration was OK, stop the loop
(?!
- ) # Fail: will unwind one iteration back
- )
+ ) # Fail: will unwind one iteration back
+ )
(?:
- [^()]+ # Match a big chunk
+ [^()]+ # Match a big chunk
(?=
[()]
- ) # Do not try to match subchunks
+ ) # Do not try to match subchunks
|
\(
(?{ ++$c })
\)
(?{ --$c })
)
- )+ # This may not match with different subblocks
+ )+ # This may not match with different subblocks
)
(?(?{ $c != 0 })
(?!
- ) # Fail
- ) # Otherwise the chunk 1 may succeed with $c>0
+ ) # Fail
+ ) # Otherwise the chunk 1 may succeed with $c>0
/xg;
}
}
{
- my @ans = ('a/b' =~ m%(.*/)?(.*)%); # Stack may be bad
+ my @ans = ('a/b' =~ m%(.*/)?(.*)%); # Stack may be bad
iseq "@ans", 'a/ b', "Stack may be bad";
}
}
{
- local $Message = "Call code from qr //";
- $a = qr/(?{++$b})/;
- $b = 7;
- ok /$a$a/ && $b eq '9';
-
- $c="$a";
- ok /$a$a/ && $b eq '11';
-
- undef $@;
- eval {/$c/};
- ok $@ && $@ =~ /not allowed at runtime/;
-
- use re "eval";
- /$a$c$a/;
- iseq $b, '14';
-
- our $lex_a = 43;
- our $lex_b = 17;
- our $lex_c = 27;
- my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/);
-
- iseq $lex_res, 1;
- iseq $lex_a, 44;
- iseq $lex_c, 43;
-
- no re "eval";
- undef $@;
- my $match = eval { /$a$c$a/ };
- ok $@ && $@ =~ /Eval-group not allowed/ && !$match;
- iseq $b, '14';
-
- $lex_a = 2;
- $lex_a = 43;
- $lex_b = 17;
- $lex_c = 27;
- $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/);
-
- iseq $lex_res, 1;
- iseq $lex_a, 44;
- iseq $lex_c, 43;
-
- }
-
-
- {
no warnings 'closure';
local $Message = '(?{ $var } refers to package vars';
package aa;
main::iseq $::c, 3;
}
-
{
must_die 'q(a:[b]:) =~ /[x[:foo:]]/',
'POSIX class \[:[^:]+:\] unknown in regex',
iseq "@_", "";
}
-
+
{
local $Message = '@- and @+ tests';
package S;
use overload '""' => sub {'Object S'};
sub new {bless []}
-
+
local $::Message = "Ref stringification";
::ok do { \my $v} =~ /^SCALAR/, "Scalar ref stringification";
::ok do {\\my $v} =~ /^REF/, "Ref ref stringification";
}
-plan tests => 1185; # Update this when adding/deleting tests.
+plan tests => 1146; # Update this when adding/deleting tests.
run_tests() unless caller;
ok s/(\d+)\s*([\w\-]+)/$1 . uc $2/e;
ok my ($latin) = /^(.+)(?:\s+\d)/;
iseq $latin, "stra\337e";
- ok $latin =~ s/stra\337e/straße/;
+ ok $latin =~ s/stra\337e/straße/;
#
# Previous code follows, but outcommented - there were no tests.
#
my $lower = "\N{LATIN SMALL LETTER A WITH GRAVE}";
my $UPPER = "\N{LATIN CAPITAL LETTER A WITH GRAVE}";
-
+
ok $lower =~ m/$UPPER/i;
ok $UPPER =~ m/$lower/i;
ok $lower =~ m/[$UPPER]/i;
ok $sigma =~ /$SIGMA/i;
ok $sigma =~ /$Sigma/i;
ok $sigma =~ /$sigma/i;
-
+
ok $SIGMA =~ /[$SIGMA]/i;
ok $SIGMA =~ /[$Sigma]/i;
ok $SIGMA =~ /[$sigma]/i;
ok "\N{LATIN SMALL LETTER SHARP S}" =~ /ss/i;
ok "\N{LATIN SMALL LETTER SHARP S}" =~ /SS/i;
-
+
local $Message = "Unoptimized named sequence in class";
ok "ss" =~ /[\N{LATIN SMALL LETTER SHARP S}x]/i;
ok "SS" =~ /[\N{LATIN SMALL LETTER SHARP S}x]/i;
my $t1 = "Q003\n\n\x{e4}\x{f6}\n\nQ004\n\n\x{e7}";
my $r1 = "";
while ($t1 =~ / \G ( .+? ) \n\s+ ( .+? ) ( $ | \n\s+ ) /xgcs) {
- $r1 .= $1 . $2;
+ $r1 .= $1 . $2;
}
my $t2 = $t1 . "\x{100}"; # Repeat with a larger char
my $r2 = "";
while ($t2 =~ / \G ( .+? ) \n\s+ ( .+? ) ( $ | \n\s+ ) /xgcs) {
- $r2 .= $1 . $2;
+ $r2 .= $1 . $2;
}
$r2 =~ s/\x{100}//;
-
+
{
local $\;
$_ = 'aaaaaaaaaa';
# To: perl-unicode@perl.org
local $Message = 'Markus Kuhn 2003-02-26';
-
+
my $x = "\x{2019}\nk";
ok $x =~ s/(\S)\n(\S)/$1 $2/sg;
ok $x eq "\x{2019} k";
{
- BEGIN {
- unshift @INC, 'lib';
- }
+ BEGIN {
+ unshift @INC, 'lib';
+ }
use Cname;
-
+
ok 'fooB' =~ /\N{foo}[\N{B}\N{b}]/, "Passthrough charname";
my $test = 1233;
#
'Empty string charname produces NOTHING node';
ok '' =~ /\N{EMPTY-STR}/,
'Empty string charname produces NOTHING node';
-
+
}
'Intermixed named and unicode escapes';
ok "\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042}" =~
/[\N{SPACE}\N{U+0041}][\N{SPACE}\N{U+0042}]/,
- 'Intermixed named and unicode escapes';
+ 'Intermixed named and unicode escapes';
}
ok $s eq '123456', 'Named capture (angle brackets) s///';
$s = '123453456';
$s =~ s/(?'digits'\d+)\k'digits'/$+{digits}/;
- ok $s eq '123456', 'Named capture (single quotes) s///';
+ ok $s eq '123456', 'Named capture (single quotes) s///';
}
for my $name ('', ':foo') {
for my $pat ("(*PRUNE$name)",
($name ? "(*MARK$name)" : "") . "(*SKIP$name)",
- "(*COMMIT$name)") {
+ "(*COMMIT$name)") {
for my $suffix ('(*FAIL)', '') {
'aaaab' =~ /a+b$pat$suffix/;
iseq $REGERROR,
for my $name ('', ':foo') {
for my $pat ("(*PRUNE$name)",
($name ? "(*MARK$name)" : "") . "(*SKIP$name)",
- "(*COMMIT$name)") {
+ "(*COMMIT$name)") {
for my $suffix ('(*FAIL)','') {
'aaaab' =~ /a+b$pat$suffix/;
::iseq $REGERROR,
"Test $pat and \$REGERROR $suffix";
}
}
- }
- }
+ }
+ }
{
"aaaaa$word" =~
/a+(?:bar(*COMMIT:bar)|baz(*COMMIT:baz)|bop(*COMMIT:bop))(*FAIL)/;
iseq $REGERROR, $word;
- }
+ }
}
{
ok "foobarbarxyz" =~ qr/(foo)(bar)\g{-1}xyz/;
ok "foobarbarxyz" =~ qr/(foo${qr_barR1})xyz/;
ok "foobarbarxyz" =~ qr/(foo(bar)\g{-1})xyz/;
- }
+ }
{
local $Message = '$REGMARK';
our @r = ();
our ($REGMARK, $REGERROR);
ok 'foofoo' =~ /foo (*MARK:foo) (?{push @r,$REGMARK}) /x;
- iseq "@r","foo";
+ iseq "@r","foo";
iseq $REGMARK, "foo";
ok 'foofoo' !~ /foo (*MARK:foo) (*FAIL) /x;
ok !$REGMARK;
$x = "abc.def.ghi.jkl";
$x =~ s/.*\K\..*//;
iseq $x, "abc.def.ghi";
-
+
$x = "one two three four";
$x =~ s/o+ \Kthree//g;
iseq $x, "one two four";
-
+
$x = "abcde";
$x =~ s/(.)\K/$1/g;
iseq $x, "aabbccddee";
}
iseq $res, "1",
"Check that (?|...) doesnt cause dupe entries in the names array";
-
+
$res = "";
if ('11' =~ /(?|(?<digit>1)|(?<digit>2))(?&digit)/) {
$res = "@{$- {digit}}";
local $Message = "ASCII pattern that really is UTF-8";
my @w;
local $SIG {__WARN__} = sub {push @w, "@_"};
- my $c = qq (\x{DF});
+ my $c = qq (\x{DF});
ok $c =~ /${c}|\x{100}/;
ok @w == 0;
- }
+ }
{
iseq "$1$2", "foobar";
{
'foooooobaaaaar' =~ /$qr/;
- iseq "$1$2", 'foooooobaaaaar';
+ iseq "$1$2", 'foooooobaaaaar';
}
iseq "$1$2", "foobar";
}
s/\H/H/g;
s/\h/h/g;
iseq $_, "hhHHhHhhHH";
- }
+ }
{
{
local $_;
($_ = 'abc') =~ /(abc)/g;
- $_ = '123';
+ $_ = '123';
iseq "$1", 'abc', "/g leads to unsafe match vars: $1";
}
{
# more TRIE/AHOCORASICK problems with mixed utf8 / latin-1 and case folding
- for my $chr (160 .. 255) {
- my $chr_byte = chr($chr);
- my $chr_utf8 = chr($chr); utf8::upgrade($chr_utf8);
- my $rx = qr{$chr_byte|X}i;
- ok($chr_utf8 =~ $rx, "utf8/latin, codepoint $chr");
- }
+ for my $chr (160 .. 255) {
+ my $chr_byte = chr($chr);
+ my $chr_utf8 = chr($chr); utf8::upgrade($chr_utf8);
+ my $rx = qr{$chr_byte|X}i;
+ ok($chr_utf8 =~ $rx, "utf8/latin, codepoint $chr");
+ }
}
{
SKIP: {
# XXX: This set of tests is essentially broken, POSIX character classes
- # should not have differing definitions under Unicode.
+ # should not have differing definitions under Unicode.
# There are property names for that.
skip "Tests assume ASCII", 4 unless $IS_ASCII;
my @isPunct = grep {/[[:punct:]]/ != /\p{IsPunct}/}
map {chr} 0x80 .. 0xff;
- iseq join ('', @isPunct), "\xa1\xab\xb7\xbb\xbf", # ¡ « · » ¿
+ iseq join ('', @isPunct), "\xa1\xab\xb7\xbb\xbf", # ¡ « · » ¿
'IsPunct disagrees with [:punct:] outside ASCII';
my @isPunctLatin1 = eval q {
skip "Eval failed ($@)", 1 if $@;
skip "PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS set to 0", 1
if !$ENV{PERL_TEST_LEGACY_POSIX_CC};
- iseq join ('', @isPunctLatin1), '',
+ iseq join ('', @isPunctLatin1), '',
'IsPunct agrees with [:punct:] with explicit Latin1';
- }
+ }
#
# Keep the following tests last -- they may crash perl
iseq $_, "!Bang!1!Bang!2!Bang!3!Bang!";
}
- {
- use re 'eval';
- local $Message = '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 = ();
- }
- iseq("@ctl_n", $test->[2], "ctl_n $c");
- iseq("@plus", $test->[3], "plus $c");
- }
- }
-
} # End of sub run_tests
1;
--- /dev/null
+#!./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 {
+ chdir 't' if -d 't';
+ @INC = ('../lib','.');
+ do "re/ReTest.pl" or die $@;
+}
+
+
+plan tests => 123; # Update this when adding/deleting tests.
+
+run_tests() unless caller;
+
+#
+# Tests start here.
+#
+sub run_tests {
+ {
+ local $Message = "Call code from qr //";
+ local $_ = 'var="foo"';
+ $a = qr/(?{++$b})/;
+ $b = 7;
+ ok /$a$a/ && $b eq '9';
+
+ my $c="$a";
+ ok /$a$a/ && $b eq '11';
+
+ undef $@;
+ eval {/$c/};
+ ok $@ && $@ =~ /not allowed at runtime/;
+
+ use re "eval";
+ /$a$c$a/;
+ iseq $b, '14';
+
+ our $lex_a = 43;
+ our $lex_b = 17;
+ our $lex_c = 27;
+ my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/);
+
+ iseq $lex_res, 1;
+ iseq $lex_a, 44;
+ iseq $lex_c, 43;
+
+ no re "eval";
+ undef $@;
+ my $match = eval { /$a$c$a/ };
+ ok $@ && $@ =~ /Eval-group not allowed/ && !$match;
+ iseq $b, '14';
+
+ $lex_a = 2;
+ $lex_a = 43;
+ $lex_b = 17;
+ $lex_c = 27;
+ $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/);
+
+ iseq $lex_res, 1;
+ iseq $lex_a, 44;
+ iseq $lex_c, 43;
+
+ }
+
+ {
+ our $a = bless qr /foo/ => 'Foo';
+ ok 'goodfood' =~ $a, "Reblessed qr // matches";
+ iseq $a, '(?-xism: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";
+ {
+ local $BugId = '17776';
+ iseq length qr /##/x, 12, "## in qr // doesn't corrupt memory";
+ }
+ {
+ 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';
+ local $Message = '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 = ();
+ }
+ iseq("@ctl_n", $test->[2], "ctl_n $c");
+ iseq("@plus", $test->[3], "plus $c");
+ }
+ }
+
+ {
+ use re 'eval';
+ local $BugId = '56194';
+
+ our $f;
+ local $f;
+ $f = sub {
+ defined $_[0] ? $_[0] : "undef";
+ };
+
+ ok("123" =~ m/^(\d)(((??{1 + $^N})))+$/);
+
+ 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");
+ if (not $match) {
+ # unset $str, @ctl_n and @plus
+ $str = "";
+ @ctl_n = @plus = ();
+ }
+ iseq("@ctl_n", $test->[2], "ctl_n $c");
+ iseq("@plus", $test->[3], "plus $c");
+ iseq($str, $test->[4], "str $c");
+ }
+ 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);
+ if (not $match) {
+ # unset $str
+ @ctl_n = ();
+ @plus = ();
+ $str = "";
+ }
+ iseq("@ctl_n", "1 2 undef");
+ iseq("@plus", "1 2 undef");
+ iseq($str, "\$1 = undef, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef, \$^R = undef");
+ }
+ }
+
+} # End of sub run_tests
+
+1;
--- /dev/null
+#!./perl
+
+chdir 't' if -d 't';
+@INC = ('../lib', '.');
+
+require 'thread_it.pl';
+thread_it(qw(re pat_re_eval.t));
}
-plan tests => 2525; # Update this when adding/deleting tests.
+plan tests => 2510; # Update this when adding/deleting tests.
run_tests() unless caller;
}
}
-
- {
- our $a = bless qr /foo/ => 'Foo';
- ok 'goodfood' =~ $a, "Reblessed qr // matches";
- iseq $a, '(?-xism: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";
- {
- local $BugId = '17776';
- iseq length qr /##/x, 12, "## in qr // doesn't corrupt memory";
- }
- {
- 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";
- }
- }
-
-
{
local $PatchId = '18179';
my $s = "\x{100}" x 5;
https://perl5.git.perl.org / perl5.git / commitdiff