From: Yves Orton Date: Sat, 19 Sep 2009 17:40:52 +0000 (+0200) Subject: dropped a test by accident the last go, so ressurect the pat_re_eval.t anyway, and... X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0f289c68de322445a34feb41ea8f00b7bf9c85de;p=p5sagit%2Fp5-mst-13.2.git dropped a test by accident the last go, so ressurect the pat_re_eval.t anyway, and resort and update the MANIFEST --- diff --git a/MANIFEST b/MANIFEST index 161d93b..47d70e0 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4431,14 +4431,16 @@ t/perl.supp Perl valgrind suppressions 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 @@ -4462,8 +4464,8 @@ t/re/reg_pmod.t See if regexp /p modifier works as expected 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 diff --git a/t/re/pat.t b/t/re/pat.t index 0f19719..314e52b 100644 --- a/t/re/pat.t +++ b/t/re/pat.t @@ -21,7 +21,7 @@ BEGIN { } -plan tests => 305; # Update this when adding/deleting tests. +plan tests => 293; # Update this when adding/deleting tests. run_tests() unless caller; @@ -141,14 +141,14 @@ sub run_tests { { 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'; } @@ -348,7 +348,7 @@ sub run_tests { '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 @@ -374,17 +374,17 @@ sub run_tests { 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 }) @@ -392,12 +392,12 @@ sub run_tests { \) (?{ --$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; } @@ -429,7 +429,7 @@ sub run_tests { } { - 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"; } @@ -546,51 +546,6 @@ sub run_tests { } { - 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; @@ -601,7 +556,6 @@ sub run_tests { main::iseq $::c, 3; } - { must_die 'q(a:[b]:) =~ /[x[:foo:]]/', 'POSIX class \[:[^:]+:\] unknown in regex', @@ -632,7 +586,7 @@ sub run_tests { iseq "@_", ""; } - + { local $Message = '@- and @+ tests'; @@ -969,7 +923,7 @@ sub run_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"; diff --git a/t/re/pat_advanced.t b/t/re/pat_advanced.t index 811a04b..73098e9 100644 --- a/t/re/pat_advanced.t +++ b/t/re/pat_advanced.t @@ -21,7 +21,7 @@ BEGIN { } -plan tests => 1185; # Update this when adding/deleting tests. +plan tests => 1146; # Update this when adding/deleting tests. run_tests() unless caller; @@ -123,7 +123,7 @@ sub run_tests { 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. # @@ -454,7 +454,7 @@ sub run_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; @@ -533,7 +533,7 @@ sub run_tests { ok $sigma =~ /$SIGMA/i; ok $sigma =~ /$Sigma/i; ok $sigma =~ /$sigma/i; - + ok $SIGMA =~ /[$SIGMA]/i; ok $SIGMA =~ /[$Sigma]/i; ok $SIGMA =~ /[$sigma]/i; @@ -641,7 +641,7 @@ sub run_tests { 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; @@ -720,13 +720,13 @@ sub run_tests { 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}//; @@ -836,7 +836,7 @@ sub run_tests { - + { local $\; $_ = 'aaaaaaaaaa'; @@ -858,7 +858,7 @@ sub run_tests { # 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"; @@ -1018,11 +1018,11 @@ sub run_tests { { - BEGIN { - unshift @INC, 'lib'; - } + BEGIN { + unshift @INC, 'lib'; + } use Cname; - + ok 'fooB' =~ /\N{foo}[\N{B}\N{b}]/, "Passthrough charname"; my $test = 1233; # @@ -1046,7 +1046,7 @@ sub run_tests { 'Empty string charname produces NOTHING node'; ok '' =~ /\N{EMPTY-STR}/, 'Empty string charname produces NOTHING node'; - + } @@ -1063,7 +1063,7 @@ sub run_tests { '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'; } @@ -1110,7 +1110,7 @@ sub run_tests { 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///'; } @@ -1271,7 +1271,7 @@ sub run_tests { 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, @@ -1290,7 +1290,7 @@ sub run_tests { 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, @@ -1298,8 +1298,8 @@ sub run_tests { "Test $pat and \$REGERROR $suffix"; } } - } - } + } + } { @@ -1311,7 +1311,7 @@ sub run_tests { "aaaaa$word" =~ /a+(?:bar(*COMMIT:bar)|baz(*COMMIT:baz)|bop(*COMMIT:bop))(*FAIL)/; iseq $REGERROR, $word; - } + } } { @@ -1374,14 +1374,14 @@ sub run_tests { 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; @@ -1395,11 +1395,11 @@ sub run_tests { $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"; @@ -1458,7 +1458,7 @@ sub run_tests { } iseq $res, "1", "Check that (?|...) doesnt cause dupe entries in the names array"; - + $res = ""; if ('11' =~ /(?|(?1)|(?2))(?&digit)/) { $res = "@{$- {digit}}"; @@ -1473,10 +1473,10 @@ sub run_tests { 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; - } + } { @@ -1486,7 +1486,7 @@ sub run_tests { iseq "$1$2", "foobar"; { 'foooooobaaaaar' =~ /$qr/; - iseq "$1$2", 'foooooobaaaaar'; + iseq "$1$2", 'foooooobaaaaar'; } iseq "$1$2", "foobar"; } @@ -1503,7 +1503,7 @@ sub run_tests { s/\H/H/g; s/\h/h/g; iseq $_, "hhHHhHhhHH"; - } + } { @@ -1650,7 +1650,7 @@ sub run_tests { { local $_; ($_ = 'abc') =~ /(abc)/g; - $_ = '123'; + $_ = '123'; iseq "$1", 'abc', "/g leads to unsafe match vars: $1"; } @@ -1678,12 +1678,12 @@ sub run_tests { { # 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"); + } } { @@ -1718,7 +1718,7 @@ sub run_tests { 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; @@ -1734,7 +1734,7 @@ sub run_tests { 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 { @@ -1744,9 +1744,9 @@ sub run_tests { 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 @@ -1771,60 +1771,6 @@ sub run_tests { 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})* - - }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 ", "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 ", "a b " ], - [ 1, qr#^((??{"(?!)?"}))((??{$nested_tags}))$#, "bla blubb ", "a b " ], - [ 1, qr#^((??{"(?:|<(/?bla)>)"}))((??{$nested_tags}))\1$#, "bla blubb ", "a b " ], - [ 0, qr#^((??{"(?!)"}))?((??{$nested_tags}))(?!)$#, "bla blubb undef", "a b undef" ], - - ) { #"#silence vim highlighting - $c++; - @ctl_n = (); - @plus = (); - my $match = (("" =~ $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; diff --git a/t/re/pat_re_eval.t b/t/re/pat_re_eval.t new file mode 100644 index 0000000..fab828d --- /dev/null +++ b/t/re/pat_re_eval.t @@ -0,0 +1,344 @@ +#!./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})* + + }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 ", "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 ", "a b " ], + [ 1, qr#^((??{"(?!)?"}))((??{$nested_tags}))$#, "bla blubb ", "a b " ], + [ 1, qr#^((??{"(?:|<(/?bla)>)"}))((??{$nested_tags}))\1$#, "bla blubb ", "a b " ], + [ 0, qr#^((??{"(?!)"}))?((??{$nested_tags}))(?!)$#, "bla blubb undef", "a b undef" ], + + ) { #"#silence vim highlighting + $c++; + @ctl_n = (); + @plus = (); + my $match = (("" =~ $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; diff --git a/t/re/pat_re_eval_thr.t b/t/re/pat_re_eval_thr.t new file mode 100644 index 0000000..706bfbf --- /dev/null +++ b/t/re/pat_re_eval_thr.t @@ -0,0 +1,7 @@ +#!./perl + +chdir 't' if -d 't'; +@INC = ('../lib', '.'); + +require 'thread_it.pl'; +thread_it(qw(re pat_re_eval.t)); diff --git a/t/re/pat_rt_report.t b/t/re/pat_rt_report.t index 28c36d6..92f4acc 100644 --- a/t/re/pat_rt_report.t +++ b/t/re/pat_rt_report.t @@ -21,7 +21,7 @@ BEGIN { } -plan tests => 2525; # Update this when adding/deleting tests. +plan tests => 2510; # Update this when adding/deleting tests. run_tests() unless caller; @@ -255,47 +255,6 @@ sub run_tests { } } - - { - 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;