X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fop%2Fpat.t;h=0de3b14b410e364fdbc5c08f868ba6da1c198c57;hb=de8c53012b7e614137ab875e0d58a92474b317ce;hp=e1ac167f1051b3b599e68a37bd0ca13d0deab1b3;hpb=81714fb9c03d91d66b66cab6e899e81bf64a2ca7;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/op/pat.t b/t/op/pat.t index e1ac167..0de3b14 100755 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -476,27 +476,27 @@ print "not " unless $^R eq '79' and $x eq '12'; print "ok $test\n"; $test++; -print "not " unless qr/\b\v$/i eq '(?i-xsm:\bv$)'; +print "not " unless qr/\b\v$/i eq '(?i-xsm:\b\v$)'; print "ok $test\n"; $test++; -print "not " unless qr/\b\v$/s eq '(?s-xim:\bv$)'; +print "not " unless qr/\b\v$/s eq '(?s-xim:\b\v$)'; print "ok $test\n"; $test++; -print "not " unless qr/\b\v$/m eq '(?m-xis:\bv$)'; +print "not " unless qr/\b\v$/m eq '(?m-xis:\b\v$)'; print "ok $test\n"; $test++; -print "not " unless qr/\b\v$/x eq '(?x-ism:\bv$)'; +print "not " unless qr/\b\v$/x eq '(?x-ism:\b\v$)'; print "ok $test\n"; $test++; -print "not " unless qr/\b\v$/xism eq '(?msix:\bv$)'; +print "not " unless qr/\b\v$/xism eq '(?msix:\b\v$)'; print "ok $test\n"; $test++; -print "not " unless qr/\b\v$/ eq '(?-xism:\bv$)'; +print "not " unless qr/\b\v$/ eq '(?-xism:\b\v$)'; print "ok $test\n"; $test++; @@ -3665,23 +3665,61 @@ SKIP:{ $s=~s/(?'digits'\d+)\k'digits'/$+{digits}/; ok($s eq '123456','Named capture (single quotes) s///'); } +sub iseq($$;$) { + my ( $got, $expect, $name)=@_; + + $_=defined($_) ? "'$_'" : "undef" + for $got, $expect; + + my $ok= $got eq $expect; + + printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name||'unnamed'; + + printf "# Failed test at line %d\n". + "# expected: %s\n". + "# result: %s\n", + (caller)[2], $expect, $got + unless $ok; + + $test++; + return $ok; +} { my $s='foo bar baz'; - my (@k,@v,$count); + my (@k,@v,@fetch,$res); + my $count= 0; + my @names=qw($+{A} $+{B} $+{C}); if ($s=~/(?foo)\s+(?bar)?\s+(?baz)/) { while (my ($k,$v)=each(%+)) { $count++; } @k=sort keys(%+); @v=sort values(%+); + $res=1; + push @fetch, + [ "$+{A}", "$1" ], + [ "$+{B}", "$2" ], + [ "$+{C}", "$3" ], + ; + } + foreach (0..2) { + if ($fetch[$_]) { + iseq($fetch[$_][0],$fetch[$_][1],$names[$_]); + } else { + ok(0, $names[$_]); + } } - ok($count==3,"Got 3 keys in %+ via each ($count)"); - ok(@k == 3, 'Got 3 keys in %+ via keys'); - ok("@k" eq "A B C", "Got expected keys"); - ok("@v" eq "bar baz foo", "Got expected values"); + iseq($res,1,"$s~=/(?foo)\s+(?bar)?\s+(?baz)/"); + iseq($count,3,"Got 3 keys in %+ via each"); + iseq(0+@k, 3, 'Got 3 keys in %+ via keys'); + iseq("@k","A B C", "Got expected keys"); + iseq("@v","bar baz foo", "Got expected values"); + eval' + print for $+{this_key_doesnt_exist}; + '; + ok(!$@,'lvalue $+{...} should not throw an exception'); } - - + # stress test CURLYX/WHILEM. # # This test includes varying levels of nesting, and according to @@ -3689,7 +3727,9 @@ SKIP:{ # CURLYX and WHILEM blocks, except those related to LONGJMP, the # super-linear cache and warnings. It executes about 0.5M regexes -{ +if ($ENV{PERL_SKIP_PSYCHO_TEST}){ + printf "ok %d Skip: No psycho tests\n", $test++; +} else { my $r = qr/^ (?: ( (?:a|z+)+ ) @@ -3785,6 +3825,164 @@ SKIP:{ ok($ok, $msg); } +# \, breaks {3,4} +ok("xaaay" !~ /xa{3\,4}y/, "\, in a pattern"); +ok("xa{3,4}y" =~ /xa{3\,4}y/, "\, in a pattern"); + +# \c\ followed by _ +ok("x\c_y" !~ /x\c\_y/, "\_ in a pattern"); +ok("x\c\_y" =~ /x\c\_y/, "\_ in a pattern"); + +# \c\ followed by other characters +for my $c ("z", "\0", "!", chr(254), chr(256)) { + my $targ = "a\034$c"; + my $reg = "a\\c\\$c"; + ok(eval("qq/$targ/ =~ /$reg/"), "\\c\\ in pattern"); +} + +{ + my $str='abc'; + my $count=0; + my $mval=0; + my $pval=0; + while ($str=~/b/g) { $mval=$#-; $pval=$#+; $count++ } + iseq($mval,0,"\@- should be empty [RT#36046]"); + iseq($pval,0,"\@+ should be empty [RT#36046]"); + iseq($count,1,"should have matched once only [RT#36046]"); +} + +{ # Test the (*NOMATCH) pattern + our $count = 0; + 'aaab'=~/a+b?(?{$count++})(*FAIL)/; + iseq($count,9,"expect 9 for no (*NOMATCH)"); + $count = 0; + 'aaab'=~/a+b?(*NOMATCH)(?{$count++})(*FAIL)/; + iseq($count,3,"expect 3 with (*NOMATCH)"); + local $_='aaab'; + $count=0; + 1 while /.(*NOMATCH)(?{$count++})(*FAIL)/g; + iseq($count,4,"/.(*NOMATCH)/"); + $count = 0; + 'aaab'=~/a+b?(??{'(*NOMATCH)'})(?{$count++})(*FAIL)/; + iseq($count,3,"expect 3 with (*NOMATCH)"); + local $_='aaab'; + $count=0; + 1 while /.(??{'(*NOMATCH)'})(?{$count++})(*FAIL)/g; + iseq($count,4,"/.(*NOMATCH)/"); +} +{ # Test the (*CUT) pattern + our $count = 0; + 'aaab'=~/a+b?(*CUT)(?{$count++})(*FAIL)/; + iseq($count,1,"expect 1 with (*CUT)"); + local $_='aaab'; + $count=0; + 1 while /.(*CUT)(?{$count++})(*FAIL)/g; + iseq($count,4,"/.(*CUT)/"); + $_='aaabaaab'; + $count=0; + our @res=(); + 1 while /(a+b?)(*CUT)(?{$count++; push @res,$1})(*FAIL)/g; + iseq($count,2,"Expect 2 with (*CUT)" ); + iseq("@res","aaab aaab","adjacent (*CUT) works as expected" ); +} +{ # Test the (*CUT) pattern + our $count = 0; + 'aaab'=~/a+b?(*MARK)(*CUT)(?{$count++})(*FAIL)/; + iseq($count,1,"expect 1 with (*CUT)"); + local $_='aaab'; + $count=0; + 1 while /.(*MARK)(*CUT)(?{$count++})(*FAIL)/g; + iseq($count,4,"/.(*CUT)/"); + $_='aaabaaab'; + $count=0; + our @res=(); + 1 while /(a+b?)(*MARK)(*CUT)(?{$count++; push @res,$1})(*FAIL)/g; + iseq($count,2,"Expect 2 with (*CUT)" ); + iseq("@res","aaab aaab","adjacent (*CUT) works as expected" ); +} +{ # Test the (*CUT) pattern + our $count = 0; + 'aaab'=~/a*(*MARK:a)b?(*MARK:b)(*CUT:a)(?{$count++})(*FAIL)/; + iseq($count,3,"expect 3 with *MARK:a)b?(*MARK:b)(*CUT:a)"); + local $_='aaabaaab'; + $count=0; + our @res=(); + 1 while /(a*(*MARK:a)b?)(*MARK)(*CUT:a)(?{$count++; push @res,$1})(*FAIL)/g; + iseq($count,5,"Expect 5 with (*MARK:a)b?)(*MARK)(*CUT:a)" ); + iseq("@res","aaab b aaab b ","adjacent (*MARK:a)b?)(*MARK)(*CUT:a) works as expected" ); +} +{ # Test the (*COMMIT) pattern + our $count = 0; + 'aaabaaab'=~/a+b?(*COMMIT)(?{$count++})(*FAIL)/; + iseq($count,1,"expect 1 with (*COMMIT)"); + local $_='aaab'; + $count=0; + 1 while /.(*COMMIT)(?{$count++})(*FAIL)/g; + iseq($count,1,"/.(*COMMIT)/"); + $_='aaabaaab'; + $count=0; + our @res=(); + 1 while /(a+b?)(*COMMIT)(?{$count++; push @res,$1})(*FAIL)/g; + iseq($count,1,"Expect 1 with (*COMMIT)" ); + iseq("@res","aaab","adjacent (*COMMIT) works as expected" ); +} +{ + # Test named commits and the $REGERROR var + our $REGERROR; + for my $name ('',':foo') + { + for my $pat ("(*NOMATCH$name)","(*MARK$name)(*CUT)", + "(*CUT$name)","(*COMMIT$name)") + { + for my $suffix ('(*FAIL)','') + { + 'aaaab'=~/a+b$pat$suffix/; + iseq( + $REGERROR, + ($suffix ? ($name ? 'foo' : "1") : ""), + "Test $pat and \$REGERROR $suffix" + ); + } + } + } +} +{ + # Test named commits and the $REGERROR var + package Fnorble; + our $REGERROR; + for my $name ('',':foo') + { + for my $pat ("(*NOMATCH$name)","(*MARK$name)(*CUT)", + "(*CUT$name)","(*COMMIT$name)") + { + for my $suffix ('(*FAIL)','') + { + 'aaaab'=~/a+b$pat$suffix/; + ::iseq( + $REGERROR, + ($suffix ? ($name ? 'foo' : "1") : ""), + "Test $pat and \$REGERROR $suffix" + ); + } + } + } +} +{ + # Test named commits and the $REGERROR var + our $REGERROR; + for $word (qw(bar baz bop)) { + $REGERROR=""; + "aaaaa$word"=~/a+(?:bar(*COMMIT:bar)|baz(*COMMIT:baz)|bop(*COMMIT:bop))(*FAIL)/; + iseq($REGERROR,$word); + } +} +{ #Regression test for perlbug 40684 + my $s = "abc\ndef"; + my $rex = qr'^abc$'m; + ok($s =~ m/$rex/); + ok($s =~ m/^abc$/m); +} +#------------------------------------------------------------------- # Keep the following tests last -- they may crash perl @@ -3795,6 +3993,20 @@ ok((q(a)x 100) =~ /^(??{'(.)'x 100})/, "Regexp /^(??{'(.)'x 100})/ crashes older perls") or print "# Unexpected outcome: should pass or crash perl\n"; +{ + $_="ns1ns1ns1"; + s/ns(?=\d)/ns_/g; + iseq($_,"ns_1ns_1ns_1"); + $_="ns1"; + s/ns(?=\d)/ns_/; + iseq($_,"ns_1"); + $_="123"; + s/(?=\d+)|(?<=\d)/!Bang!/g; + iseq($_,"!Bang!1!Bang!2!Bang!3!Bang!"); +} + +# Put new tests above the line, not here. + # Don't forget to update this! -BEGIN{print "1..1270\n"}; +BEGIN{print "1..1347\n"};