From: Abigail Date: Tue, 18 Nov 2008 09:29:05 +0000 (+0100) Subject: Improve and restructure t/op/pat.t and split out some unicode related tests into... X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=84281c3142b669e898404773f536776423f8c11b;p=p5sagit%2Fp5-mst-13.2.git Improve and restructure t/op/pat.t and split out some unicode related tests into a new test file Subject: t/op/pat.t Message-ID: <20081118082905.GJ3172@almanda> With tweaks: Seems the new harness is quite picky about # signs in test names, and doesnt like SKIP and TODO to be used together. p4raw-id: //depot/perl@34882 --- diff --git a/MANIFEST b/MANIFEST index f4d7106..0906ddb 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4045,6 +4045,8 @@ t/op/regexp_notrie.t See if regular expressions work without trie optimisation t/op/regexp_qr_embed.t See if regular expressions work with embedded qr// t/op/regexp_qr_embed_thr.t See if regular expressions work with embedded qr// in another thread t/op/regexp_qr.t See if regular expressions work as qr// +t/op/regexp_unicode_prop.t See if unicode properties work in regular expressions as expected +t/op/regexp_unicode_prop_thr.t See if unicode properties work in regular expressions as expected under threads t/op/regexp.t See if regular expressions work t/op/regexp_trielist.t See if regular expressions work with trie optimisation t/op/reg_fold.t See if case folding works properly diff --git a/t/op/pat.t b/t/op/pat.t index bdb5128..040c671 100755 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -4,3925 +4,3196 @@ # the format supported by op/regexp.t. If you want to add a test # that does fit that format, add it to op/re_tests, not here. +use strict; +use warnings; +use 5.010; + + +sub run_tests; + $| = 1; -# Test counter output is generated by a BEGIN block at bottom of file +my $EXPECTED_TESTS = 3864; # Update this when adding/deleting tests. BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } +our $TODO; our $Message = "Noname test"; - +our $Error; +our $DiePattern; +our $WarnPattern; +our $BugId; +our $PatchId; +our $running_as_thread; + +my $ordA = ord ('A'); # This defines ASCII/UTF-8 vs EBCDIC/UTF-EBCDIC +# This defined the platform. +my $IS_ASCII = $ordA == 65; +my $IS_EBCDIC = $ordA == 193; + +use vars '%Config'; eval 'use Config'; # Defaults assumed if this fails -run_tests() unless caller; - -sub run_tests { - -$x = "abc\ndef\n"; - -if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";} -if ($x !~ /^def/) {print "ok 2\n";} else {print "not ok 2\n";} - -# used to be a test for $* -if ($x =~ /^def/m) {print "ok 3\n";} else {print "not ok 3\n";} - -$_ = '123'; -if (/^([0-9][0-9]*)/) {print "ok 4\n";} else {print "not ok 4\n";} - -if ($x =~ /^xxx/) {print "not ok 5\n";} else {print "ok 5\n";} -if ($x !~ /^abc/) {print "not ok 6\n";} else {print "ok 6\n";} - -if ($x =~ /def/) {print "ok 7\n";} else {print "not ok 7\n";} -if ($x !~ /def/) {print "not ok 8\n";} else {print "ok 8\n";} - -if ($x !~ /.def/) {print "ok 9\n";} else {print "not ok 9\n";} -if ($x =~ /.def/) {print "not ok 10\n";} else {print "ok 10\n";} - -if ($x =~ /\ndef/) {print "ok 11\n";} else {print "not ok 11\n";} -if ($x !~ /\ndef/) {print "not ok 12\n";} else {print "ok 12\n";} - -$_ = 'aaabbbccc'; -if (/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc') { - print "ok 13\n"; -} else { - print "not ok 13\n"; -} -if (/(a+b+c+)/ && $1 eq 'aaabbbccc') { - print "ok 14\n"; -} else { - print "not ok 14\n"; -} - -if (/a+b?c+/) {print "not ok 15\n";} else {print "ok 15\n";} - -$_ = 'aaabccc'; -if (/a+b?c+/) {print "ok 16\n";} else {print "not ok 16\n";} -if (/a*b+c*/) {print "ok 17\n";} else {print "not ok 17\n";} - -$_ = 'aaaccc'; -if (/a*b?c*/) {print "ok 18\n";} else {print "not ok 18\n";} -if (/a*b+c*/) {print "not ok 19\n";} else {print "ok 19\n";} - -$_ = 'abcdef'; -if (/bcd|xyz/) {print "ok 20\n";} else {print "not ok 20\n";} -if (/xyz|bcd/) {print "ok 21\n";} else {print "not ok 21\n";} - -if (m|bc/*d|) {print "ok 22\n";} else {print "not ok 22\n";} - -if (/^$_$/) {print "ok 23\n";} else {print "not ok 23\n";} - -# used to be a test for $* -if ("ab\ncd\n" =~ /^cd/m) {print "ok 24\n";} else {print "not ok 24\n";} +my $test = 0; -$XXX{123} = 123; -$XXX{234} = 234; -$XXX{345} = 345; +print "1..$EXPECTED_TESTS\n"; -@XXX = ('ok 25','not ok 25', 'ok 26','not ok 26','not ok 27'); -while ($_ = shift(@XXX)) { - ?(.*)? && (print $1,"\n"); - /not/ && reset; - if (/not ok 26/) { - if ($^O eq 'VMS') { - $_ = shift(@XXX); - } - else { - reset 'X'; - } - } -} +run_tests unless caller (); -if ($^O ne 'VMS') { - while (($key,$val) = each(%XXX)) { - print "not ok 27\n"; - exit; - } +END { } -print "ok 27\n"; - -'cde' =~ /[^ab]*/; -'xyz' =~ //; -if ($& eq 'xyz') {print "ok 28\n";} else {print "not ok 28\n";} - -$foo = '[^ab]*'; -'cde' =~ /$foo/; -'xyz' =~ //; -if ($& eq 'xyz') {print "ok 29\n";} else {print "not ok 29\n";} - -$foo = '[^ab]*'; -'cde' =~ /$foo/; -'xyz' =~ /$null/; -if ($& eq 'xyz') {print "ok 30\n";} else {print "not ok 30\n";} - -$_ = 'abcdefghi'; -/def/; # optimized up to cmd -if ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 31\n";} else {print "not ok 31\n";} - -/cde/ + 0; # optimized only to spat -if ("$`:$&:$'" eq 'ab:cde:fghi') {print "ok 32\n";} else {print "not ok 32\n";} - -/[d][e][f]/; # not optimized -if ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 33\n";} else {print "not ok 33\n";} - -$_ = 'now is the {time for all} good men to come to.'; -/ {([^}]*)}/; -if ($1 eq 'time for all') {print "ok 34\n";} else {print "not ok 34 $1\n";} - -$_ = 'xxx {3,4} yyy zzz'; -print /( {3,4})/ ? "ok 35\n" : "not ok 35\n"; -print $1 eq ' ' ? "ok 36\n" : "not ok 36\n"; -print /( {4,})/ ? "not ok 37\n" : "ok 37\n"; -print /( {2,3}.)/ ? "ok 38\n" : "not ok 38\n"; -print $1 eq ' y' ? "ok 39\n" : "not ok 39\n"; -print /(y{2,3}.)/ ? "ok 40\n" : "not ok 40\n"; -print $1 eq 'yyy ' ? "ok 41\n" : "not ok 41\n"; -print /x {3,4}/ ? "not ok 42\n" : "ok 42\n"; -print /^xxx {3,4}/ ? "not ok 43\n" : "ok 43\n"; - -$_ = "now is the time for all good men to come to."; -@words = /(\w+)/g; -print join(':',@words) eq "now:is:the:time:for:all:good:men:to:come:to" - ? "ok 44\n" - : "not ok 44\n"; - -@words = (); -while (/\w+/g) { - push(@words, $&); -} -print join(':',@words) eq "now:is:the:time:for:all:good:men:to:come:to" - ? "ok 45\n" - : "not ok 45\n"; - -@words = (); -pos = 0; -while (/to/g) { - push(@words, $&); -} -print join(':',@words) eq "to:to" - ? "ok 46\n" - : "not ok 46 `@words'\n"; - -pos $_ = 0; -@words = /to/g; -print join(':',@words) eq "to:to" - ? "ok 47\n" - : "not ok 47 `@words'\n"; - -$_ = "abcdefghi"; - -$pat1 = 'def'; -$pat2 = '^def'; -$pat3 = '.def.'; -$pat4 = 'abc'; -$pat5 = '^abc'; -$pat6 = 'abc$'; -$pat7 = 'ghi'; -$pat8 = '\w*ghi'; -$pat9 = 'ghi$'; - -$t1=$t2=$t3=$t4=$t5=$t6=$t7=$t8=$t9=0; - -for $iter (1..5) { - $t1++ if /$pat1/o; - $t2++ if /$pat2/o; - $t3++ if /$pat3/o; - $t4++ if /$pat4/o; - $t5++ if /$pat5/o; - $t6++ if /$pat6/o; - $t7++ if /$pat7/o; - $t8++ if /$pat8/o; - $t9++ if /$pat9/o; +sub pretty { + my ($mess) = @_; + $mess =~ s/\n/\\n/g; + $mess =~ s/\r/\\r/g; + $mess =~ s/\t/\\t/g; + $mess =~ s/([\00-\37\177])/sprintf '\%03o', ord $1/eg; + $mess =~ s/#/\\#/g; + $mess; } -$x = "$t1$t2$t3$t4$t5$t6$t7$t8$t9"; -print $x eq '505550555' ? "ok 48\n" : "not ok 48 $x\n"; - -$xyz = 'xyz'; -print "abc" =~ /^abc$|$xyz/ ? "ok 49\n" : "not ok 49\n"; - -# perl 4.009 says "unmatched ()" -eval '"abc" =~ /a(bc$)|$xyz/; $result = "$&:$1"'; -print $@ eq "" ? "ok 50\n" : "not ok 50\n"; -print $result eq "abc:bc" ? "ok 51\n" : "not ok 51\n"; - - -$_="abcfooabcbar"; -$x=/abc/g; -print $` eq "" ? "ok 52\n" : "not ok 52\n" if $x; -$x=/abc/g; -print $` eq "abcfoo" ? "ok 53\n" : "not ok 53\n" if $x; -$x=/abc/g; -print $x == 0 ? "ok 54\n" : "not ok 54\n"; -pos = 0; -$x=/ABC/gi; -print $` eq "" ? "ok 55\n" : "not ok 55\n" if $x; -$x=/ABC/gi; -print $` eq "abcfoo" ? "ok 56\n" : "not ok 56\n" if $x; -$x=/ABC/gi; -print $x == 0 ? "ok 57\n" : "not ok 57\n"; -pos = 0; -$x=/abc/g; -print $' eq "fooabcbar" ? "ok 58\n" : "not ok 58\n" if $x; -$x=/abc/g; -print $' eq "bar" ? "ok 59\n" : "not ok 59\n" if $x; -$_ .= ''; -@x=/abc/g; -print scalar @x == 2 ? "ok 60\n" : "not ok 60\n"; - -$_ = "abdc"; -pos $_ = 2; -/\Gc/gc; -print "not " if (pos $_) != 2; -print "ok 61\n"; -/\Gc/g; -print "not " if defined pos $_; -print "ok 62\n"; - -$out = 1; -'abc' =~ m'a(?{ $out = 2 })b'; -print "not " if $out != 2; -print "ok 63\n"; - -$out = 1; -'abc' =~ m'a(?{ $out = 3 })c'; -print "not " if $out != 1; -print "ok 64\n"; - -$_ = 'foobar1 bar2 foobar3 barfoobar5 foobar6'; -@out = /(? 1, - 'ax13876y25677mcb' => 0, # not b. - 'ax13876y35677nbc' => 0, # Num too big - 'ax13876y25677y21378obc' => 1, - 'ax13876y25677y21378zbc' => 0, # Not followed by [k-o] - 'ax13876y25677y21378y21378kbc' => 1, - 'ax13876y25677y21378y21378kcb' => 0, # Not b. - 'ax13876y25677y21378y21378y21378kbc' => 0, # 5 runs - ); - -for ( keys %ans ) { - print "# const-len `$_' not => $ans{$_}\nnot " - if $ans{$_} xor /a(?=([yx]($long_constant_len)){2,4}[k-o]).*b./o; - print "ok $test\n"; - $test++; - print "# var-len `$_' not => $ans{$_}\nnot " - if $ans{$_} xor /a(?=([yx]($long_var_len)){2,4}[k-o]).*b./o; - print "ok $test\n"; - $test++; -} +sub _ok { + my ($ok, $mess, $error) = @_; + safe_globals(); + $mess = pretty ($mess // $Message); + $mess .= "; Bug $BugId" if defined $BugId; + $mess .= "; Patch $PatchId" if defined $PatchId; + $mess .= " # TODO $TODO" if defined $TODO; -$_ = " a (bla()) and x(y b((l)u((e))) and b(l(e)e)e"; -$expect = "(bla()) ((l)u((e))) (l(e)e)"; - -sub matchit { - m/ - ( - \( - (?{ $c = 1 }) # Initialize - (?: - (?(?{ $c == 0 }) # PREVIOUS iteration was OK, stop the loop - (?! - ) # Fail: will unwind one iteration back - ) - (?: - [^()]+ # Match a big chunk - (?= - [()] - ) # Do not try to match subchunks - | - \( - (?{ ++$c }) - | - \) - (?{ --$c }) - ) - )+ # This may not match with different subblocks - ) - (?(?{ $c != 0 }) - (?! - ) # Fail - ) # Otherwise the chunk 1 may succeed with $c>0 - /xg; -} + my $line_nr = (caller(1)) [2]; -@ans = (); -push @ans, $res while $res = matchit; - -print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne "1 1 1"; -print "ok $test\n"; -$test++; - -@ans = matchit; - -print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne $expect; -print "ok $test\n"; -$test++; - -print "not " unless "abc" =~ /^(??{"a"})b/; -print "ok $test\n"; -$test++; - -my $matched; -$matched = qr/\((?:(?>[^()]+)|(??{$matched}))*\)/; - -@ans = @ans1 = (); -push(@ans, $res), push(@ans1, $&) while $res = m/$matched/g; - -print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne "1 1 1"; -print "ok $test\n"; -$test++; - -print "# ans1='@ans1'\n# expect='$expect'\nnot " if "@ans1" ne $expect; -print "ok $test\n"; -$test++; - -@ans = m/$matched/g; - -print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne $expect; -print "ok $test\n"; -$test++; - -@ans = ('a/b' =~ m%(.*/)?(.*)%); # Stack may be bad -print "not " if "@ans" ne 'a/ b'; -print "ok $test\n"; -$test++; - -$code = '{$blah = 45}'; -$blah = 12; -eval { /(?$code)/ }; -print "not " unless $@ and $@ =~ /not allowed at runtime/ and $blah == 12; -print "ok $test\n"; -$test++; - -for $code ('{$blah = 45}','=xx') { - $blah = 12; - $res = eval { "xx" =~ /(?$code)/o }; - if ($code eq '=xx') { - print "#'$@','$res','$blah'\nnot " unless not $@ and $res; - } else { - print "#'$@','$res','$blah'\nnot " unless $@ and $@ =~ /not allowed at runtime/ and $blah == 12; - } - print "ok $test\n"; - $test++; -} + printf "%sok %d - %s\n", + ($ok ? "" : "not "), + ++ $test, + "$mess\tLine $line_nr"; -$code = '{$blah = 45}'; -$blah = 12; -eval "/(?$code)/"; -print "not " if $blah != 45; -print "ok $test\n"; -$test++; - -$blah = 12; -/(?{$blah = 45})/; -print "not " if $blah != 45; -print "ok $test\n"; -$test++; - -$x = 'banana'; -$x =~ /.a/g; -print "not " unless pos($x) == 2; -print "ok $test\n"; -$test++; - -$x =~ /.z/gc; -print "not " unless pos($x) == 2; -print "ok $test\n"; -$test++; - -sub f { - my $p = $_[0]; - return $p; -} + unless ($ok) { + print "# Failed test at line $line_nr\n" unless defined $TODO; + if ($error //= $Error) { + no warnings 'utf8'; + chomp $error; + $error = join "\n#", map {pretty $_} split /\n\h*#/ => $error; + $error = "# $error" unless $error =~ /^\h*#/; + print $error, "\n"; + } + } -$x =~ /.a/g; -print "not " unless f(pos($x)) == 4; -print "ok $test\n"; -$test++; - -$x = $^R = 67; -'foot' =~ /foo(?{$x = 12; 75})[t]/; -print "not " unless $^R eq '75'; -print "ok $test\n"; -$test++; - -$x = $^R = 67; -'foot' =~ /foo(?{$x = 12; 75})[xy]/; -print "not " unless $^R eq '67' and $x eq '12'; -print "ok $test\n"; -$test++; - -$x = $^R = 67; -'foot' =~ /foo(?{ $^R + 12 })((?{ $x = 12; $^R + 17 })[xy])?/; -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:\b\v$)'; -print "ok $test\n"; -$test++; - -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:\b\v$)'; -print "ok $test\n"; -$test++; - -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:\b\v$)'; -print "ok $test\n"; -$test++; - -print "not " unless qr/\b\v$/ eq '(?-xism:\b\v$)'; -print "ok $test\n"; -$test++; - -$_ = 'xabcx'; -foreach $ans ('', 'c') { - /(?<=(?=a)..)((?=c)|.)/g; - print "# \$1 ='$1'\n# \$ans='$ans'\nnot " unless $1 eq $ans; - print "ok $test\n"; - $test++; + return $ok; } -$_ = 'a'; -foreach $ans ('', 'a', '') { - /^|a|$/g; - print "# \$& ='$&'\n# \$ans='$ans'\nnot " unless $& eq $ans; - print "ok $test\n"; - $test++; -} +# Force scalar context on the pattern match +sub ok ($;$$) {_ok $_ [0], $_ [1], $_ [2]} +sub nok ($;$$) {_ok !$_ [0], "Failed: " . ($_ [1] // $Message), $_ [2]} -sub prefixify { - my($v,$a,$b,$res) = @_; - $v =~ s/\Q$a\E/$b/; - print "not " unless $res eq $v; - print "ok $test\n"; - $test++; -} -prefixify('/a/b/lib/arch', "/a/b/lib", 'X/lib', 'X/lib/arch'); -prefixify('/a/b/man/arch', "/a/b/man", 'X/man', 'X/man/arch'); - -$_ = 'var="foo"'; -/(\")/; -print "not " unless $1 and /$1/; -print "ok $test\n"; -$test++; - -$a=qr/(?{++$b})/; -$b = 7; -/$a$a/; -print "not " unless $b eq '9'; -print "ok $test\n"; -$test++; - -{ - $c="$a"; - /$a$a/; - iseq($b, '11'); -} -{ - use re "eval"; - /$a$c$a/; - iseq($b, '14'); - - local $lex_a = 2; - my $lex_a = 43; - my $lex_b = 17; - my $lex_c = 27; - my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/); - print "not " unless $lex_res eq '1'; - print "ok $test\n"; - $test++; - print "not " unless $lex_a eq '44'; - print "ok $test\n"; - $test++; - print "not " unless $lex_c eq '43'; - print "ok $test\n"; - $test++; - - - no re "eval"; - $match = eval { /$a$c$a/ }; - # FIXME - split this one. That would require removing a lot of hard coded - # test numbers. - ok($b eq '14' and $@ =~ /Eval-group not allowed/ and not $match); +sub skip { + my $why = shift; + safe_globals(); + $why =~ s/\n.*//s; + $why .= "; Bug $BugId" if defined $BugId; + # seems like the new harness code doesnt like todo and skip to be mixed. + # which seems like a bug in the harness to me. -- dmq + #$why .= " # TODO $TODO" if defined $TODO; + + my $n = shift // 1; + my $line_nr = (caller(0)) [2]; + for (1 .. $n) { + ++ $test; + #print "not " if defined $TODO; + print "ok $test # skip $why\tLine $line_nr\n"; + } + no warnings "exiting"; + last SKIP; } -{ - local $lex_a = 2; - my $lex_a = 43; - my $lex_b = 17; - my $lex_c = 27; - my $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/); - print "not " unless $lex_res eq '1'; - print "ok $test\n"; - $test++; - print "not " unless $lex_a eq '44'; - print "ok $test\n"; - $test++; - print "not " unless $lex_c eq '43'; - print "ok $test\n"; - $test++; -} +sub iseq ($$;$) { + my ($got, $expect, $name) = @_; + + $_ = defined ($_) ? "'$_'" : "undef" for $got, $expect; + + my $ok = $got eq $expect; + my $error = "# expected: $expect\n" . + "# result: $got"; -{ - package aa; - $c = 2; - $::c = 3; - '' =~ /(?{ $c = 4 })/; - print "not " unless $c == 4; -} -print "ok $test\n"; -$test++; -print "not " unless $c == 3; -print "ok $test\n"; -$test++; - -sub must_warn_pat { - my $warn_pat = shift; - return sub { print "not " unless $_[0] =~ /$warn_pat/ } -} + _ok $ok, $name, $error; +} -sub must_warn { - my ($warn_pat, $code) = @_; - local %SIG; - eval 'BEGIN { use warnings; $SIG{__WARN__} = $warn_pat };' . $code; - print "ok $test\n"; - $test++; -} +sub isneq ($$;$) { + my ($got, $expect, $name) = @_; + my $todo = $TODO ? " # TODO $TODO" : ''; + + $_ = defined ($_) ? "'$_'" : "undef" for $got, $expect; + + my $ok = $got ne $expect; + my $error = "# results are equal ($got)"; + _ok $ok, $name, $error; +} -sub make_must_warn { - my $warn_pat = shift; - return sub { must_warn(must_warn_pat($warn_pat)) } -} -my $for_future = make_must_warn('reserved for future extensions'); - -&$for_future('q(a:[b]:) =~ /[x[:foo:]]/'); - -#&$for_future('q(a=[b]=) =~ /[x[=foo=]]/'); -print "ok $test\n"; $test++; # now a fatal croak - -#&$for_future('q(a.[b].) =~ /[x[.foo.]]/'); -print "ok $test\n"; $test++; # now a fatal croak - -# test if failure of patterns returns empty list -$_ = 'aaa'; -@_ = /bbb/; -print "not " if @_; -print "ok $test\n"; -$test++; - -@_ = /bbb/g; -print "not " if @_; -print "ok $test\n"; -$test++; - -@_ = /(bbb)/; -print "not " if @_; -print "ok $test\n"; -$test++; - -@_ = /(bbb)/g; -print "not " if @_; -print "ok $test\n"; -$test++; - -/a(?=.$)/; -print "not " if $#+ != 0 or $#- != 0; -print "ok $test\n"; -$test++; - -print "not " if $+[0] != 2 or $-[0] != 1; -print "ok $test\n"; -$test++; - -print "not " - if defined $+[1] or defined $-[1] or defined $+[2] or defined $-[2]; -print "ok $test\n"; -$test++; - -/a(a)(a)/; -print "not " if $#+ != 2 or $#- != 2; -print "ok $test\n"; -$test++; - -print "not " if $+[0] != 3 or $-[0] != 0; -print "ok $test\n"; -$test++; - -print "not " if $+[1] != 2 or $-[1] != 1; -print "ok $test\n"; -$test++; - -print "not " if $+[2] != 3 or $-[2] != 2; -print "ok $test\n"; -$test++; - -print "not " - if defined $+[3] or defined $-[3] or defined $+[4] or defined $-[4]; -print "ok $test\n"; -$test++; - -/.(a)(b)?(a)/; -print "not " if $#+ != 3 or $#- != 3; -print "ok $test\n"; -$test++; - -print "not " if $+[0] != 3 or $-[0] != 0; -print "ok $test\n"; -$test++; - -print "not " if $+[1] != 2 or $-[1] != 1; -print "ok $test\n"; -$test++; - -print "not " if $+[3] != 3 or $-[3] != 2; -print "ok $test\n"; -$test++; - -print "not " - if defined $+[2] or defined $-[2] or defined $+[4] or defined $-[4]; -print "ok $test\n"; -$test++; - -/.(a)/; -print "not " if $#+ != 1 or $#- != 1; -print "ok $test\n"; -$test++; - -print "not " if $+[0] != 2 or $-[0] != 0; -print "ok $test\n"; -$test++; - -print "not " if $+[1] != 2 or $-[1] != 1; -print "ok $test\n"; -$test++; - -print "not " - if defined $+[2] or defined $-[2] or defined $+[3] or defined $-[3]; -print "ok $test\n"; -$test++; - -eval { $+[0] = 13; }; -print "not " - if $@ !~ /^Modification of a read-only value attempted/; -print "ok $test\n"; -$test++; - -eval { $-[0] = 13; }; -print "not " - if $@ !~ /^Modification of a read-only value attempted/; -print "ok $test\n"; -$test++; - -eval { @+ = (7, 6, 5); }; -print "not " - if $@ !~ /^Modification of a read-only value attempted/; -print "ok $test\n"; -$test++; - -eval { @- = qw(foo bar); }; -print "not " - if $@ !~ /^Modification of a read-only value attempted/; -print "ok $test\n"; -$test++; - -/.(a)(ba*)?/; -print "#$#-..$#+\nnot " if $#+ != 2 or $#- != 1; -print "ok $test\n"; -$test++; - -$_ = 'aaa'; -pos = 1; -@a = /\Ga/g; -print "not " unless "@a" eq "a a"; -print "ok $test\n"; -$test++; - -$str = 'abcde'; -pos $str = 2; - -print "not " if $str =~ /^\G/; -print "ok $test\n"; -$test++; - -print "not " if $str =~ /^.\G/; -print "ok $test\n"; -$test++; - -print "not " unless $str =~ /^..\G/; -print "ok $test\n"; -$test++; - -print "not " if $str =~ /^...\G/; -print "ok $test\n"; -$test++; - -{ - local $TODO = $::running_as_thread; - ok($str =~ /.\G./ and $& eq 'bc'); +sub eval_ok ($;$) { + my ($code, $name) = @_; + local $@; + if (ref $code) { + _ok eval {&$code} && !$@, $name; + } + else { + _ok eval ($code) && !$@, $name; + } } -print "not " unless $str =~ /\G../ and $& eq 'cd'; -print "ok $test\n"; -$test++; - -undef $foo; undef $bar; -print "#'$str','$foo','$bar'\nnot " - unless $str =~ /b(?{$foo = $_; $bar = pos})c/ - and $foo eq 'abcde' and $bar eq 2; -print "ok $test\n"; -$test++; - -undef $foo; undef $bar; -pos $str = undef; -print "#'$str','$foo','$bar'\nnot " - unless $str =~ /b(?{$foo = $_; $bar = pos})c/g - and $foo eq 'abcde' and $bar eq 2 and pos $str eq 3; -print "ok $test\n"; -$test++; - -$_ = $str; - -undef $foo; undef $bar; -print "#'$str','$foo','$bar'\nnot " - unless /b(?{$foo = $_; $bar = pos})c/ - and $foo eq 'abcde' and $bar eq 2; -print "ok $test\n"; -$test++; - -undef $foo; undef $bar; -print "#'$str','$foo','$bar'\nnot " - unless /b(?{$foo = $_; $bar = pos})c/g - and $foo eq 'abcde' and $bar eq 2 and pos eq 3; -print "ok $test\n"; -$test++; - -undef $foo; undef $bar; -pos = undef; -1 while /b(?{$foo = $_; $bar = pos})c/g; -print "#'$str','$foo','$bar'\nnot " - unless $foo eq 'abcde' and $bar eq 2 and not defined pos; -print "ok $test\n"; -$test++; - -undef $foo; undef $bar; -$_ = 'abcde|abcde'; -print "#'$str','$foo','$bar','$_'\nnot " - unless s/b(?{$foo = $_; $bar = pos})c/x/g and $foo eq 'abcde|abcde' - and $bar eq 8 and $_ eq 'axde|axde'; -print "ok $test\n"; -$test++; - -@res = (); -# List context: -$_ = 'abcde|abcde'; -@dummy = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g; -@res = map {defined $_ ? "'$_'" : 'undef'} @res; -$res = "@res"; -print "#'@res' '$_'\nnot " - unless "@res" eq "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'"; -print "ok $test\n"; -$test++; - -@res = (); -@dummy = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g; -@res = map {defined $_ ? "'$_'" : 'undef'} @res; -$res = "@res"; -print "#'@res' '$_'\nnot " - unless "@res" eq - "'' 'ab' 'cde|abcde' " . - "'' 'abc' 'de|abcde' " . - "'abcd' 'e|' 'abcde' " . - "'abcde|' 'ab' 'cde' " . - "'abcde|' 'abc' 'de'" ; -print "ok $test\n"; -$test++; - -#Some more \G anchor checks -$foo='aabbccddeeffgg'; - -pos($foo)=1; - -$foo=~/.\G(..)/g; -{ - local $TODO = $::running_as_thread; - iseq($1,'ab'); +sub must_die { + my ($code, $pattern, $name) = @_; + $pattern //= $DiePattern; + undef $@; + ref $code ? &$code : eval $code; + my $r = $@ && $@ =~ /$pattern/; + _ok $r, $name // $Message // "\$\@ =~ /$pattern/"; } -pos($foo) += 1; -$foo=~/.\G(..)/g; -{ - local $TODO = $::running_as_thread; - iseq($1, 'cc'); +sub must_warn { + my ($code, $pattern, $name) = @_; + $pattern //= $WarnPattern; + my $w; + local $SIG {__WARN__} = sub {$w .= join "" => @_}; + use warnings 'all'; + ref $code ? &$code : eval $code; + my $r = $w && $w =~ /$pattern/; + $w //= "UNDEF"; + _ok $r, $name // $Message // "Got warning /$pattern/", + "# expected: /$pattern/\n" . + "# result: $w"; +} + +sub may_not_warn { + my ($code, $name) = @_; + my $w; + local $SIG {__WARN__} = sub {$w .= join "" => @_}; + use warnings 'all'; + ref $code ? &$code : eval $code; + _ok !$w, $name // ($Message ? "$Message (did not warn)" + : "Did not warn"), + "Got warning '$w'"; } -pos($foo) += 1; -$foo=~/.\G(..)/g; -{ - local $TODO = $::running_as_thread; - iseq($1, 'de'); -} -{ - local $TODO = $::running_as_thread; - ok($foo =~ /\Gef/g); -} +# +# Tests start here. +# +sub run_tests { -undef pos $foo; - -$foo=~/\G(..)/g; -print "not " unless($1 eq 'aa'); -print "ok $test\n"; -$test++; - -$foo=~/\G(..)/g; -print "not " unless($1 eq 'bb'); -print "ok $test\n"; -$test++; - -pos($foo)=5; -$foo=~/\G(..)/g; -print "not " unless($1 eq 'cd'); -print "ok $test\n"; -$test++; - -$_='123x123'; -@res = /(\d*|x)/g; -print "not " unless('123||x|123|' eq join '|', @res); -print "ok $test\n"; -$test++; - -# see if matching against temporaries (created via pp_helem()) is safe -{ foo => "ok $test\n".$^X }->{foo} =~ /^(.*)\n/g; -print "$1\n"; -$test++; - -# See if $i work inside (?{}) in the presense of saved substrings and -# changing $_ -@a = qw(foo bar); -@b = (); -s/(\w)(?{push @b, $1})/,$1,/g for @a; - -print "# \@b='@b', expect 'f o o b a r'\nnot " unless("@b" eq "f o o b a r"); -print "ok $test\n"; -$test++; - -print "not " unless("@a" eq ",f,,o,,o, ,b,,a,,r,"); -print "ok $test\n"; -$test++; - -$brackets = qr{ - { (?> [^{}]+ | (??{ $brackets }) )* } - }x; - -"{{}" =~ $brackets; -print "ok $test\n"; # Did we survive? -$test++; - -"something { long { and } hairy" =~ $brackets; -print "ok $test\n"; # Did we survive? -$test++; - -"something { long { and } hairy" =~ m/((??{ $brackets }))/; -print "not " unless $1 eq "{ and }"; -print "ok $test\n"; -$test++; - -$_ = "a-a\nxbb"; -pos=1; -m/^-.*bb/mg and print "not "; -print "ok $test\n"; -$test++; - -$text = "aaXbXcc"; -pos($text)=0; -$text =~ /\GXb*X/g and print 'not '; -print "ok $test\n"; -$test++; - -$text = "xA\n" x 500; -$text =~ /^\s*A/m and print 'not '; -print "ok $test\n"; -$test++; - -$text = "abc dbf"; -@res = ($text =~ /.*?(b).*?\b/g); -"@res" eq 'b b' or print 'not '; -print "ok $test\n"; -$test++; - -@a = map chr,0..255; - -@b = grep(/\S/,@a); -@c = grep(/[^\s]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\S/,@a); -@c = grep(/[\S]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\s/,@a); -@c = grep(/[^\S]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\s/,@a); -@c = grep(/[\s]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\D/,@a); -@c = grep(/[^\d]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\D/,@a); -@c = grep(/[\D]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\d/,@a); -@c = grep(/[^\D]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\d/,@a); -@c = grep(/[\d]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\W/,@a); -@c = grep(/[^\w]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\W/,@a); -@c = grep(/[\W]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\w/,@a); -@c = grep(/[^\W]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\w/,@a); -@c = grep(/[\w]/,@a); -iseq("@b","@c"); - -# see if backtracking optimization works correctly -"\n\n" =~ /\n $ \n/x or print "not "; -print "ok $test\n"; -$test++; - -"\n\n" =~ /\n* $ \n/x or print "not "; -print "ok $test\n"; -$test++; - -"\n\n" =~ /\n+ $ \n/x or print "not "; -print "ok $test\n"; -$test++; - -[] =~ /^ARRAY/ or print "# [] \nnot "; -print "ok $test\n"; -$test++; - -eval << 'EOE'; -{ - package S; - use overload '""' => sub { 'Object S' }; - sub new { bless [] } -} -$a = 'S'->new; -EOE - -$a and $a =~ /^Object\sS/ or print "# '$a' \nnot "; -print "ok $test\n"; -$test++; - -# test result of match used as match (!) -'a1b' =~ ('xyz' =~ /y/) and $` eq 'a' or print "not "; -print "ok $test\n"; -$test++; - -'a1b' =~ ('xyz' =~ /t/) and $` eq 'a' or print "not "; -print "ok $test\n"; -$test++; - -$w = 0; -{ - local $SIG{__WARN__} = sub { $w = 1 }; - local $^W = 1; - $w = 1 if ("1\n" x 102) =~ /^\s*\n/m; -} -print $w ? "not " : "", "ok $test\n"; -$test++; - -my %space = ( spc => " ", - tab => "\t", - cr => "\r", - lf => "\n", - ff => "\f", -# There's no \v but the vertical tabulator seems miraculously -# be 11 both in ASCII and EBCDIC. - vt => chr(11), - false => "space" ); - -my @space0 = sort grep { $space{$_} =~ /\s/ } keys %space; -my @space1 = sort grep { $space{$_} =~ /[[:space:]]/ } keys %space; -my @space2 = sort grep { $space{$_} =~ /[[:blank:]]/ } keys %space; - -print "not " unless "@space0" eq "cr ff lf spc tab"; -print "ok $test # @space0\n"; -$test++; - -print "not " unless "@space1" eq "cr ff lf spc tab vt"; -print "ok $test # @space1\n"; -$test++; - -print "not " unless "@space2" eq "spc tab"; -print "ok $test # @space2\n"; -$test++; - -# bugid 20001021.005 - this caused a SEGV -print "not " unless undef =~ /^([^\/]*)(.*)$/; -print "ok $test\n"; -$test++; - -# bugid 20000731.001 - -print "not " unless "A \x{263a} B z C" =~ /A . B (??{ "z" }) C/; -print "ok $test\n"; -$test++; - -my $ordA = ord('A'); - -$_ = "a\x{100}b"; -if (/(.)(\C)(\C)(.)/) { - print "ok 232\n"; - if ($1 eq "a") { - print "ok 233\n"; - } else { - print "not ok 233\n"; - } - if ($ordA == 65) { # ASCII (or equivalent), should be UTF-8 - if ($2 eq "\xC4") { - print "ok 234\n"; - } else { - print "not ok 234\n"; - } - if ($3 eq "\x80") { - print "ok 235\n"; - } else { - print "not ok 235\n"; - } - } elsif ($ordA == 193) { # EBCDIC (or equivalent), should be UTF-EBCDIC - if ($2 eq "\x8C") { - print "ok 234\n"; - } else { - print "not ok 234\n"; - } - if ($3 eq "\x41") { - print "ok 235\n"; - } else { - print "not ok 235\n"; - } - } else { - for (234..235) { - print "not ok $_ # ord('A') == $ordA\n"; - } - } - if ($4 eq "b") { - print "ok 236\n"; - } else { - print "not ok 236\n"; - } -} else { - for (232..236) { - print "not ok $_\n"; - } -} -$_ = "\x{100}"; -if (/(\C)/g) { - print "ok 237\n"; - # currently \C are still tagged as UTF-8 - if ($ordA == 65) { - if ($1 eq "\xC4") { - print "ok 238\n"; - } else { - print "not ok 238\n"; - } - } elsif ($ordA == 193) { - if ($1 eq "\x8C") { - print "ok 238\n"; - } else { - print "not ok 238\n"; - } - } else { - print "not ok 238 # ord('A') == $ordA\n"; - } -} else { - for (237..238) { - print "not ok $_\n"; - } -} -if (/(\C)/g) { - print "ok 239\n"; - # currently \C are still tagged as UTF-8 - if ($ordA == 65) { - if ($1 eq "\x80") { - print "ok 240\n"; - } else { - print "not ok 240\n"; - } - } elsif ($ordA == 193) { - if ($1 eq "\x41") { - print "ok 240\n"; - } else { - print "not ok 240\n"; - } - } else { - print "not ok 240 # ord('A') == $ordA\n"; - } -} else { - for (239..240) { - print "not ok $_\n"; - } -} + { -{ - # japhy -- added 03/03/2001 - () = (my $str = "abc") =~ /(...)/; - $str = "def"; - print "not " if $1 ne "abc"; - print "ok 241\n"; -} + my $x = "abc\ndef\n"; -# The 242 and 243 go with the 244 and 245. -# The trick is that in EBCDIC the explicit numeric range should match -# (as also in non-EBCDIC) but the explicit alphabetic range should not match. + ok $x =~ /^abc/, qq ["$x" =~ /^abc/]; + ok $x !~ /^def/, qq ["$x" !~ /^def/]; -if ("\x8e" =~ /[\x89-\x91]/) { - print "ok 242\n"; -} else { - print "not ok 242\n"; -} + # used to be a test for $* + ok $x =~ /^def/m, qq ["$x" =~ /^def/m]; -if ("\xce" =~ /[\xc9-\xd1]/) { - print "ok 243\n"; -} else { - print "not ok 243\n"; -} + nok $x =~ /^xxx/, qq ["$x" =~ /^xxx/]; + nok $x !~ /^abc/, qq ["$x" !~ /^abc/]; -# In most places these tests would succeed since \x8e does not -# in most character sets match 'i' or 'j' nor would \xce match -# 'I' or 'J', but strictly speaking these tests are here for -# the good of EBCDIC, so let's test these only there. -if (ord('i') == 0x89 && ord('J') == 0xd1) { # EBCDIC - if ("\x8e" !~ /[i-j]/) { - print "ok 244\n"; - } else { - print "not ok 244\n"; - } - if ("\xce" !~ /[I-J]/) { - print "ok 245\n"; - } else { - print "not ok 245\n"; - } -} else { - for (244..245) { - print "ok $_ # Skip: only in EBCDIC\n"; - } -} + ok $x =~ /def/, qq ["$x" =~ /def/]; + nok $x !~ /def/, qq ["$x" !~ /def/]; -print "not " unless "\x{ab}" =~ /\x{ab}/; -print "ok 246\n"; + ok $x !~ /.def/, qq ["$x" !~ /.def/]; + nok $x =~ /.def/, qq ["$x" =~ /.def/]; -print "not " unless "\x{abcd}" =~ /\x{abcd}/; -print "ok 247\n"; + ok $x =~ /\ndef/, qq ["$x" =~ /\ndef/]; + nok $x !~ /\ndef/, qq ["$x" !~ /\ndef/]; + } -{ - # bug id 20001008.001 + { + $_ = '123'; + ok /^([0-9][0-9]*)/, qq [\$_ = '$_'; /^([0-9][0-9]*)/]; + } - $test = 248; - my @x = ("stra\337e 138","stra\337e 138"); - for (@x) { - s/(\d+)\s*([\w\-]+)/$1 . uc $2/e; - my($latin) = /^(.+)(?:\s+\d)/; - print $latin eq "stra\337e" ? "ok $test\n" : # 248,249 - "#latin[$latin]\nnot ok $test\n"; - $test++; - $latin =~ s/stra\337e/straße/; # \303\237 after the 2nd a - use utf8; # needed for the raw UTF-8 - $latin =~ s!(s)tr(?:aß|s+e)!$1tr.!; # \303\237 after the a + { + $_ = 'aaabbbccc'; + ok /(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc', + qq [\$_ = '$_'; /(a*b*)(c*)/]; + ok /(a+b+c+)/ && $1 eq 'aaabbbccc', qq [\$_ = '$_'; /(a+b+c+)/]; + nok /a+b?c+/, qq [\$_ = '$_'; /a+b?c+/]; + + $_ = 'aaabccc'; + ok /a+b?c+/, qq [\$_ = '$_'; /a+b?c+/]; + ok /a*b?c*/, qq [\$_ = '$_'; /a*b?c*/]; + + $_ = 'aaaccc'; + ok /a*b?c*/, qq [\$_ = '$_'; /a*b?c*/]; + nok /a*b+c*/, qq [\$_ = '$_'; /a*b+c*/]; + + $_ = 'abcdef'; + ok /bcd|xyz/, qq [\$_ = '$_'; /bcd|xyz/]; + ok /xyz|bcd/, qq [\$_ = '$_'; /xyz|bcd/]; + ok m|bc/*d|, qq [\$_ = '$_'; m|bc/*d|]; + ok /^$_$/, qq [\$_ = '$_'; /^\$_\$/]; } -} -{ - print "not " unless "ba\xd4c" =~ /([a\xd4]+)/ && $1 eq "a\xd4"; - print "ok 250\n"; + { + # used to be a test for $* + ok "ab\ncd\n" =~ /^cd/m, qq ["ab\ncd\n" =~ /^cd/m]; + } - print "not " unless "ba\xd4c" =~ /([a\xd4]+)/ && $1 eq "a\x{d4}"; - print "ok 251\n"; + { + our %XXX = map {($_ => $_)} 123, 234, 345; + + our @XXX = ('ok 1','not ok 1', 'ok 2','not ok 2','not ok 3'); + while ($_ = shift(@XXX)) { + my $f = index ($_, 'not') >= 0 ? \&nok : \&ok; + my $r = ?(.*)?; + &$f ($r, "?(.*)?"); + /not/ && reset; + if (/not ok 2/) { + if ($^O eq 'VMS') { + $_ = shift(@XXX); + } + else { + reset 'X'; + } + } + } - print "not " unless "ba\x{d4}c" =~ /([a\xd4]+)/ && $1 eq "a\x{d4}"; - print "ok 252\n"; + SKIP: { + if ($^O eq 'VMS') { + skip "Reset 'X'", 1; + } + ok !keys %XXX, "%XXX is empty"; + } - print "not " unless "ba\x{d4}c" =~ /([a\xd4]+)/ && $1 eq "a\xd4"; - print "ok 253\n"; + } - print "not " unless "ba\xd4c" =~ /([a\x{d4}]+)/ && $1 eq "a\xd4"; - print "ok 254\n"; + { + local $Message = "Test empty pattern"; + my $xyz = 'xyz'; + my $cde = 'cde'; + + $cde =~ /[^ab]*/; + $xyz =~ //; + iseq $&, $xyz; + + my $foo = '[^ab]*'; + $cde =~ /$foo/; + $xyz =~ //; + iseq $&, $xyz; + + $cde =~ /$foo/; + my $null; + no warnings 'uninitialized'; + $xyz =~ /$null/; + iseq $&, $xyz; + + $null = ""; + $xyz =~ /$null/; + iseq $&, $xyz; + } - print "not " unless "ba\xd4c" =~ /([a\x{d4}]+)/ && $1 eq "a\x{d4}"; - print "ok 255\n"; + { + local $Message = q !Check $`, $&, $'!; + $_ = 'abcdefghi'; + /def/; # optimized up to cmd + iseq "$`:$&:$'", 'abc:def:ghi'; - print "not " unless "ba\x{d4}c" =~ /([a\x{d4}]+)/ && $1 eq "a\x{d4}"; - print "ok 256\n"; + no warnings 'void'; + /cde/ + 0; # optimized only to spat + iseq "$`:$&:$'", 'ab:cde:fghi'; - print "not " unless "ba\x{d4}c" =~ /([a\x{d4}]+)/ && $1 eq "a\xd4"; - print "ok 257\n"; -} + /[d][e][f]/; # not optimized + iseq "$`:$&:$'", 'abc:def:ghi'; + } -{ - # the first half of 20001028.003 + { + $_ = 'now is the {time for all} good men to come to.'; + / {([^}]*)}/; + iseq $1, 'time for all', "Match braces"; + } - my $X = chr(1448); - my ($Y) = $X =~ /(.*)/; - print "not " unless $Y eq v1448 && length($Y) == 1; - print "ok 258\n"; -} + { + local $Message = "{N,M} quantifier"; + $_ = 'xxx {3,4} yyy zzz'; + ok /( {3,4})/; + iseq $1, ' '; + ok !/( {4,})/; + ok /( {2,3}.)/; + iseq $1, ' y'; + ok /(y{2,3}.)/; + iseq $1, 'yyy '; + ok !/x {3,4}/; + ok !/^xxx {3,4}/; + } -{ - # 20001108.001 + { + local $Message = "Test /g"; + local $" = ":"; + $_ = "now is the time for all good men to come to."; + my @words = /(\w+)/g; + my $exp = "now:is:the:time:for:all:good:men:to:come:to"; - my $X = "Szab\x{f3},Bal\x{e1}zs"; - my $Y = $X; - $Y =~ s/(B)/$1/ for 0..3; - print "not " unless $Y eq $X && $X eq "Szab\x{f3},Bal\x{e1}zs"; - print "ok 259\n"; -} + iseq "@words", $exp; -{ - # the second half of 20001028.003 + @words = (); + while (/\w+/g) { + push (@words, $&); + } + iseq "@words", $exp; - my $X = ''; - $X =~ s/^/chr(1488)/e; - print "not " unless length $X == 1 && ord($X) == 1488; - print "ok 260\n"; -} + @words = (); + pos = 0; + while (/to/g) { + push(@words, $&); + } + iseq "@words", "to:to"; -{ - # 20000517.001 + pos $_ = 0; + @words = /to/g; + iseq "@words", "to:to"; + } - my $x = "\x{100}A"; + { + $_ = "abcdefghi"; + + my $pat1 = 'def'; + my $pat2 = '^def'; + my $pat3 = '.def.'; + my $pat4 = 'abc'; + my $pat5 = '^abc'; + my $pat6 = 'abc$'; + my $pat7 = 'ghi'; + my $pat8 = '\w*ghi'; + my $pat9 = 'ghi$'; + + my $t1 = my $t2 = my $t3 = my $t4 = my $t5 = + my $t6 = my $t7 = my $t8 = my $t9 = 0; + + for my $iter (1 .. 5) { + $t1++ if /$pat1/o; + $t2++ if /$pat2/o; + $t3++ if /$pat3/o; + $t4++ if /$pat4/o; + $t5++ if /$pat5/o; + $t6++ if /$pat6/o; + $t7++ if /$pat7/o; + $t8++ if /$pat8/o; + $t9++ if /$pat9/o; + } + my $x = "$t1$t2$t3$t4$t5$t6$t7$t8$t9"; + iseq $x, '505550555', "Test /o"; + } - $x =~ s/A/B/; - print "not " unless $x eq "\x{100}B" && length($x) == 2; - print "ok 261\n"; -} + SKIP: { + my $xyz = 'xyz'; + ok "abc" =~ /^abc$|$xyz/, "| after \$"; -{ - # bug id 20001230.002 + # perl 4.009 says "unmatched ()" + local $Message = '$ inside ()'; - print "not " unless "École" =~ /^\C\C(.)/ && $1 eq 'c'; - print "ok 262\n"; + my $result; + eval '"abc" =~ /a(bc$)|$xyz/; $result = "$&:$1"'; + iseq $@, "" or skip "eval failed", 1; + iseq $result, "abc:bc"; + } - print "not " unless "École" =~ /^\C\C(c)/; - print "ok 263\n"; -} -SKIP: { - $test = 264; # till 575 - - use charnames ":full"; - - # This is far from complete testing, there are dozens of character - # classes in Unicode. The mixing of literals and \N{...} is - # intentional so that in non-Latin-1 places we test the native - # characters, not the Unicode code points. - - my %s = ( - "a" => 'Ll', - "\N{CYRILLIC SMALL LETTER A}" => 'Ll', - "A" => 'Lu', - "\N{GREEK CAPITAL LETTER ALPHA}" => 'Lu', - "\N{HIRAGANA LETTER SMALL A}" => 'Lo', - "\N{COMBINING GRAVE ACCENT}" => 'Mn', - "0" => 'Nd', - "\N{ARABIC-INDIC DIGIT ZERO}" => 'Nd', - "_" => 'N', - "!" => 'P', - " " => 'Zs', - "\0" => 'Cc', - ); - - for my $char (map { s/^\S+ //; $_ } - sort map { sprintf("%06x", ord($_))." $_" } keys %s) { - my $class = $s{$char}; - my $code = sprintf("%06x", ord($char)); - printf "#\n# 0x$code\n#\n"; - print "# IsAlpha\n"; - if ($class =~ /^[LM]/) { - print "not " unless $char =~ /\p{IsAlpha}/; - print "ok $test\n"; $test++; - print "not " if $char =~ /\P{IsAlpha}/; - print "ok $test\n"; $test++; - } else { - print "not " if $char =~ /\p{IsAlpha}/; - print "ok $test\n"; $test++; - print "not " unless $char =~ /\P{IsAlpha}/; - print "ok $test\n"; $test++; - } - print "# IsAlnum\n"; - if ($class =~ /^[LMN]/ && $char ne "_") { - print "not " unless $char =~ /\p{IsAlnum}/; - print "ok $test\n"; $test++; - print "not " if $char =~ /\P{IsAlnum}/; - print "ok $test\n"; $test++; - } else { - print "not " if $char =~ /\p{IsAlnum}/; - print "ok $test\n"; $test++; - print "not " unless $char =~ /\P{IsAlnum}/; - print "ok $test\n"; $test++; - } - print "# IsASCII\n"; - if (ord("A") == 193) { - print "ok $test # Skip: in EBCDIC\n"; $test++; - print "ok $test # Skip: in EBCDIC\n"; $test++; - } else { - if ($code le '00007f') { - print "not " unless $char =~ /\p{IsASCII}/; - print "ok $test\n"; $test++; - print "not " if $char =~ /\P{IsASCII}/; - print "ok $test\n"; $test++; - } else { - print "not " if $char =~ /\p{IsASCII}/; - print "ok $test\n"; $test++; - print "not " unless $char =~ /\P{IsASCII}/; - print "ok $test\n"; $test++; - } - } - print "# IsCntrl\n"; - if ($class =~ /^C/) { - print "not " unless $char =~ /\p{IsCntrl}/; - print "ok $test\n"; $test++; - print "not " if $char =~ /\P{IsCntrl}/; - print "ok $test\n"; $test++; - } else { - print "not " if $char =~ /\p{IsCntrl}/; - print "ok $test\n"; $test++; - print "not " unless $char =~ /\P{IsCntrl}/; - print "ok $test\n"; $test++; - } - print "# IsBlank\n"; - if ($class =~ /^Z[lp]/ || $char eq " ") { - print "not " unless $char =~ /\p{IsBlank}/; - print "ok $test\n"; $test++; - print "not " if $char =~ /\P{IsBlank}/; - print "ok $test\n"; $test++; - } else { - print "not " if $char =~ /\p{IsBlank}/; - print "ok $test\n"; $test++; - print "not " unless $char =~ /\P{IsBlank}/; - print "ok $test\n"; $test++; - } - print "# IsDigit\n"; - if ($class =~ /^Nd$/) { - print "not " unless $char =~ /\p{IsDigit}/; - print "ok $test\n"; $test++; - print "not " if $char =~ /\P{IsDigit}/; - print "ok $test\n"; $test++; - } else { - print "not " if $char =~ /\p{IsDigit}/; - print "ok $test\n"; $test++; - print "not " unless $char =~ /\P{IsDigit}/; - print "ok $test\n"; $test++; - } - print "# IsGraph\n"; - if ($class =~ /^([LMNPS])|Co/) { - print "not " unless $char =~ /\p{IsGraph}/; - print "ok $test\n"; $test++; - print "not " if $char =~ /\P{IsGraph}/; - print "ok $test\n"; $test++; - } else { - print "not " if $char =~ /\p{IsGraph}/; - print "ok $test\n"; $test++; - print "not " unless $char =~ /\P{IsGraph}/; - print "ok $test\n"; $test++; - } - print "# IsLower\n"; - if ($class =~ /^Ll$/) { - print "not " unless $char =~ /\p{IsLower}/; - print "ok $test\n"; $test++; - print "not " if $char =~ /\P{IsLower}/; - print "ok $test\n"; $test++; - } else { - print "not " if $char =~ /\p{IsLower}/; - print "ok $test\n"; $test++; - print "not " unless $char =~ /\P{IsLower}/; - print "ok $test\n"; $test++; - } - print "# IsPrint\n"; - if ($class =~ /^([LMNPS])|Co|Zs/) { - print "not " unless $char =~ /\p{IsPrint}/; - print "ok $test\n"; $test++; - print "not " if $char =~ /\P{IsPrint}/; - print "ok $test\n"; $test++; - } else { - print "not " if $char =~ /\p{IsPrint}/; - print "ok $test\n"; $test++; - print "not " unless $char =~ /\P{IsPrint}/; - print "ok $test\n"; $test++; - } - print "# IsPunct\n"; - if ($class =~ /^P/ || $char eq "_") { - print "not " unless $char =~ /\p{IsPunct}/; - print "ok $test\n"; $test++; - print "not " if $char =~ /\P{IsPunct}/; - print "ok $test\n"; $test++; - } else { - print "not " if $char =~ /\p{IsPunct}/; - print "ok $test\n"; $test++; - print "not " unless $char =~ /\P{IsPunct}/; - print "ok $test\n"; $test++; - } - print "# IsSpace\n"; - if ($class =~ /^Z/ || ($code =~ /^(0009|000A|000B|000C|000D)$/)) { - print "not " unless $char =~ /\p{IsSpace}/; - print "ok $test\n"; $test++; - print "not " if $char =~ /\P{IsSpace}/; - print "ok $test\n"; $test++; - } else { - print "not " if $char =~ /\p{IsSpace}/; - print "ok $test\n"; $test++; - print "not " unless $char =~ /\P{IsSpace}/; - print "ok $test\n"; $test++; - } - print "# IsUpper\n"; - if ($class =~ /^L[ut]/) { - print "not " unless $char =~ /\p{IsUpper}/; - print "ok $test\n"; $test++; - print "not " if $char =~ /\P{IsUpper}/; - print "ok $test\n"; $test++; - } else { - print "not " if $char =~ /\p{IsUpper}/; - print "ok $test\n"; $test++; - print "not " unless $char =~ /\P{IsUpper}/; - print "ok $test\n"; $test++; - } - print "# IsWord\n"; - if ($class =~ /^[LMN]/ || $char eq "_") { - print "not " unless $char =~ /\p{IsWord}/; - print "ok $test\n"; $test++; - print "not " if $char =~ /\P{IsWord}/; - print "ok $test\n"; $test++; - } else { - print "not " if $char =~ /\p{IsWord}/; - print "ok $test\n"; $test++; - print "not " unless $char =~ /\P{IsWord}/; - print "ok $test\n"; $test++; - } + { + local $Message = "Scalar /g"; + $_ = "abcfooabcbar"; + + ok /abc/g && $` eq ""; + ok /abc/g && $` eq "abcfoo"; + ok !/abc/g; + + local $Message = "Scalar /gi"; + pos = 0; + ok /ABC/gi && $` eq ""; + ok /ABC/gi && $` eq "abcfoo"; + ok !/ABC/gi; + + local $Message = "Scalar /g"; + pos = 0; + ok /abc/g && $' eq "fooabcbar"; + ok /abc/g && $' eq "bar"; + + $_ .= ''; + my @x = /abc/g; + iseq @x, 2, "/g reset after assignment"; } -} -{ - $_ = "abc\x{100}\x{200}\x{300}\x{380}\x{400}defg"; - - if (/(.\x{300})./) { - print "ok 576\n"; + { + local $Message = '/g, \G and pos'; + $_ = "abdc"; + pos $_ = 2; + /\Gc/gc; + iseq pos $_, 2; + /\Gc/g; + ok !defined pos $_; + } - print "not " unless $` eq "abc\x{100}" && length($`) == 4; - print "ok 577\n"; + { + local $Message = '(?{ })'; + our $out = 1; + 'abc' =~ m'a(?{ $out = 2 })b'; + iseq $out, 2; + + $out = 1; + 'abc' =~ m'a(?{ $out = 3 })c'; + iseq $out, 1; + } - print "not " unless $& eq "\x{200}\x{300}\x{380}" && length($&) == 3; - print "ok 578\n"; - print "not " unless $' eq "\x{400}defg" && length($') == 5; - print "ok 579\n"; + { + $_ = 'foobar1 bar2 foobar3 barfoobar5 foobar6'; + my @out = /(? 32767; + ok "ba$a=" =~ /b(?:a|b)+=/; + } + } - print "ok 581\n"; -} -{ - $test = 582; - - # bugid 20010410.006 - for my $rx ( - '/(.*?)\{(.*?)\}/csg', - '/(.*?)\{(.*?)\}/cg', - '/(.*?)\{(.*?)\}/sg', - '/(.*?)\{(.*?)\}/g', - '/(.+?)\{(.+?)\}/csg', - ) - { - my($input, $i); - - $i = 0; - $input = "a{b}c{d}"; - eval < 1, + 'ax13876y25677mcb' => 0, # not b. + 'ax13876y35677nbc' => 0, # Num too big + 'ax13876y25677y21378obc' => 1, + 'ax13876y25677y21378zbc' => 0, # Not followed by [k-o] + 'ax13876y25677y21378y21378kbc' => 1, + 'ax13876y25677y21378y21378kcb' => 0, # Not b. + 'ax13876y25677y21378y21378y21378kbc' => 0, # 5 runs + ); + + local $Message = "20000 nodes"; + for (keys %ans) { + local $Error = "const-len '$_'"; + ok !($ans{$_} xor /a(?=([yx]($long_constant_len)){2,4}[k-o]).*b./o); + + local $Error = "var-len '$_'"; + ok !($ans{$_} xor /a(?=([yx]($long_var_len)){2,4}[k-o]).*b./o); + } } -} -{ - # from Robin Houston - - my $x = "\x{10FFFD}"; - $x =~ s/(.)/$1/g; - print "not " unless ord($x) == 0x10FFFD && length($x) == 1; - print "ok 587\n"; -} + { + local $Message = "Complicated backtracking"; + $_ = " a (bla()) and x(y b((l)u((e))) and b(l(e)e)e"; + my $expect = "(bla()) ((l)u((e))) (l(e)e)"; + + use vars '$c'; + sub matchit { + m/ + ( + \( + (?{ $c = 1 }) # Initialize + (?: + (?(?{ $c == 0 }) # PREVIOUS iteration was OK, stop the loop + (?! + ) # Fail: will unwind one iteration back + ) + (?: + [^()]+ # Match a big chunk + (?= + [()] + ) # Do not try to match subchunks + | + \( + (?{ ++$c }) + | + \) + (?{ --$c }) + ) + )+ # This may not match with different subblocks + ) + (?(?{ $c != 0 }) + (?! + ) # Fail + ) # Otherwise the chunk 1 may succeed with $c>0 + /xg; + } -{ - my $x = "\x7f"; + my @ans = (); + my $res; + push @ans, $res while $res = matchit; + iseq "@ans", "1 1 1"; - print "not " if $x =~ /[\x80-\xff]/; - print "ok 588\n"; + @ans = matchit; + iseq "@ans", $expect; - print "not " if $x =~ /[\x80-\x{100}]/; - print "ok 589\n"; + local $Message = "Recursion with (??{ })"; + our $matched; + $matched = qr/\((?:(?>[^()]+)|(??{$matched}))*\)/; - print "not " if $x =~ /[\x{100}]/; - print "ok 590\n"; + @ans = my @ans1 = (); + push (@ans, $res), push (@ans1, $&) while $res = m/$matched/g; - print "not " if $x =~ /\p{InLatin1Supplement}/; - print "ok 591\n"; + iseq "@ans", "1 1 1"; + iseq "@ans1", $expect; - print "not " unless $x =~ /\P{InLatin1Supplement}/; - print "ok 592\n"; + @ans = m/$matched/g; + iseq "@ans", $expect; - print "not " if $x =~ /\p{InLatinExtendedA}/; - print "ok 593\n"; + } - print "not " unless $x =~ /\P{InLatinExtendedA}/; - print "ok 594\n"; -} + { + ok "abc" =~ /^(??{"a"})b/, '"abc" =~ /^(??{"a"})b/'; + } -{ - my $x = "\x80"; + { + my @ans = ('a/b' =~ m%(.*/)?(.*)%); # Stack may be bad + iseq "@ans", 'a/ b', "Stack may be bad"; + } - print "not " unless $x =~ /[\x80-\xff]/; - print "ok 595\n"; + { + local $Message = "Eval-group not allowed at runtime"; + my $code = '{$blah = 45}'; + our $blah = 12; + eval { /(?$code)/ }; + ok $@ && $@ =~ /not allowed at runtime/ && $blah == 12; + + for $code ('{$blah = 45}','=xx') { + $blah = 12; + my $res = eval { "xx" =~ /(?$code)/o }; + no warnings 'uninitialized'; + local $Error = "'$@', '$res', '$blah'"; + if ($code eq '=xx') { + ok !$@ && $res; + } + else { + ok $@ && $@ =~ /not allowed at runtime/ && $blah == 12; + } + } - print "not " unless $x =~ /[\x80-\x{100}]/; - print "ok 596\n"; + $code = '{$blah = 45}'; + $blah = 12; + eval "/(?$code)/"; + iseq $blah, 45; - print "not " if $x =~ /[\x{100}]/; - print "ok 597\n"; + $blah = 12; + /(?{$blah = 45})/; + iseq $blah, 45; + } - print "not " unless $x =~ /\p{InLatin1Supplement}/; - print "ok 598\n"; + { + local $Message = "Pos checks"; + my $x = 'banana'; + $x =~ /.a/g; + iseq pos ($x), 2; - print "not " if $x =~ /\P{InLatin1Supplement}/; - print "ok 599\n"; + $x =~ /.z/gc; + iseq pos ($x), 2; - print "not " if $x =~ /\p{InLatinExtendedA}/; - print "ok 600\n"; + sub f { + my $p = $_[0]; + return $p; + } - print "not " unless $x =~ /\P{InLatinExtendedA}/; - print "ok 601\n"; -} + $x =~ /.a/g; + iseq f (pos ($x)), 4; + } -{ - my $x = "\xff"; + { + local $Message = 'Checking $^R'; + our $x = $^R = 67; + 'foot' =~ /foo(?{$x = 12; 75})[t]/; + iseq $^R, 75; + + $x = $^R = 67; + 'foot' =~ /foo(?{$x = 12; 75})[xy]/; + ok $^R eq '67' && $x eq '12'; + + $x = $^R = 67; + 'foot' =~ /foo(?{ $^R + 12 })((?{ $x = 12; $^R + 17 })[xy])?/; + ok $^R eq '79' && $x eq '12'; + } - print "not " unless $x =~ /[\x80-\xff]/; - print "ok 602\n"; + { + iseq qr/\b\v$/i, '(?i-xsm:\b\v$)', 'qr/\b\v$/i'; + iseq qr/\b\v$/s, '(?s-xim:\b\v$)', 'qr/\b\v$/s'; + iseq qr/\b\v$/m, '(?m-xis:\b\v$)', 'qr/\b\v$/m'; + iseq qr/\b\v$/x, '(?x-ism:\b\v$)', 'qr/\b\v$/x'; + iseq qr/\b\v$/xism, '(?msix:\b\v$)', 'qr/\b\v$/xism'; + iseq qr/\b\v$/, '(?-xism:\b\v$)', 'qr/\b\v$/'; + } - print "not " unless $x =~ /[\x80-\x{100}]/; - print "ok 603\n"; - print "not " if $x =~ /[\x{100}]/; - print "ok 604\n"; + { + local $Message = "Look around"; + $_ = 'xabcx'; + SKIP: + foreach my $ans ('', 'c') { + ok /(?<=(?=a)..)((?=c)|.)/g or skip "Match failed", 1; + iseq $1, $ans; + } + } - # the next two tests must be ignored on EBCDIC - print "not " unless $x =~ /\p{InLatin1Supplement}/ or ord("A") == 193; - print "ok 605\n"; + { + local $Message = "Empty clause"; + $_ = 'a'; + foreach my $ans ('', 'a', '') { + ok /^|a|$/g or skip "Match failed", 1; + iseq $&, $ans; + } + } - print "not " if $x =~ /\P{InLatin1Supplement}/ and ord("A") != 193; - print "ok 606\n"; + { + local $Message = "Prefixify"; + sub prefixify { + SKIP: { + my ($v, $a, $b, $res) = @_; + ok $v =~ s/\Q$a\E/$b/ or skip "Match failed", 1; + iseq $v, $res; + } + } - print "not " if $x =~ /\p{InLatinExtendedA}/; - print "ok 607\n"; + prefixify ('/a/b/lib/arch', "/a/b/lib", 'X/lib', 'X/lib/arch'); + prefixify ('/a/b/man/arch', "/a/b/man", 'X/man', 'X/man/arch'); + } - print "not " unless $x =~ /\P{InLatinExtendedA}/; - print "ok 608\n"; -} + { + $_ = 'var="foo"'; + /(\")/; + ok $1 && /$1/, "Capture a quote"; + } -{ - my $x = "\x{100}"; + { + 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; - print "not " if $x =~ /[\x80-\xff]/; - print "ok 609\n"; + } - print "not " unless $x =~ /[\x80-\x{100}]/; - print "ok 610\n"; - print "not " unless $x =~ /[\x{100}]/; - print "ok 611\n"; + { + no warnings 'closure'; + local $Message = '(?{ $var } refers to package vars'; + package aa; + our $c = 2; + $::c = 3; + '' =~ /(?{ $c = 4 })/; + main::iseq $c, 4; + main::iseq $::c, 3; + } - print "not " if $x =~ /\p{InLatin1Supplement}/; - print "ok 612\n"; - print "not " unless $x =~ /\P{InLatin1Supplement}/; - print "ok 613\n"; + { + must_die 'q(a:[b]:) =~ /[x[:foo:]]/', + 'POSIX class \[:[^:]+:\] unknown in regex', + 'POSIX class [: :] must have valid name'; + + for my $d (qw [= .]) { + must_die "/[[${d}foo${d}]]/", + "\QPOSIX syntax [$d $d] is reserved for future extensions", + "POSIX syntax [[$d $d]] is an error"; + } + } - print "not " unless $x =~ /\p{InLatinExtendedA}/; - print "ok 614\n"; - print "not " if $x =~ /\P{InLatinExtendedA}/; - print "ok 615\n"; -} + { + # test if failure of patterns returns empty list + local $Message = "Failed pattern returns empty list"; + $_ = 'aaa'; + @_ = /bbb/; + iseq "@_", ""; -{ - # from japhy - my $w; - use warnings; - local $SIG{__WARN__} = sub { $w .= shift }; - - $w = ""; - eval 'qr/(?c)/'; - print "not " if $w !~ /^Useless \(\?c\)/; - print "ok 616\n"; - - $w = ""; - eval 'qr/(?-c)/'; - print "not " if $w !~ /^Useless \(\?-c\)/; - print "ok 617\n"; - - $w = ""; - eval 'qr/(?g)/'; - print "not " if $w !~ /^Useless \(\?g\)/; - print "ok 618\n"; - - $w = ""; - eval 'qr/(?-g)/'; - print "not " if $w !~ /^Useless \(\?-g\)/; - print "ok 619\n"; - - $w = ""; - eval 'qr/(?o)/'; - print "not " if $w !~ /^Useless \(\?o\)/; - print "ok 620\n"; - - $w = ""; - eval 'qr/(?-o)/'; - print "not " if $w !~ /^Useless \(\?-o\)/; - print "ok 621\n"; - - # now test multi-error regexes - - $w = ""; - eval 'qr/(?g-o)/'; - print "not " if $w !~ /^Useless \(\?g\).*\nUseless \(\?-o\)/; - print "ok 622\n"; - - $w = ""; - eval 'qr/(?g-c)/'; - print "not " if $w !~ /^Useless \(\?g\).*\nUseless \(\?-c\)/; - print "ok 623\n"; - - $w = ""; - eval 'qr/(?o-cg)/'; # (?c) means (?g) error won't be thrown - print "not " if $w !~ /^Useless \(\?o\).*\nUseless \(\?-c\)/; - print "ok 624\n"; - - $w = ""; - eval 'qr/(?ogc)/'; - print "not " if $w !~ /^Useless \(\?o\).*\nUseless \(\?g\).*\nUseless \(\?c\)/; - print "ok 625\n"; -} + @_ = /bbb/g; + iseq "@_", ""; -# More Unicode "class" tests + @_ = /(bbb)/; + iseq "@_", ""; -{ - use charnames ':full'; + @_ = /(bbb)/g; + iseq "@_", ""; + } - print "not " unless "\N{LATIN CAPITAL LETTER A}" =~ /\p{InBasicLatin}/; - print "ok 626\n"; + + { + local $Message = '@- and @+ tests'; + + /a(?=.$)/; + iseq $#+, 0; + iseq $#-, 0; + iseq $+ [0], 2; + iseq $- [0], 1; + ok !defined $+ [1] && !defined $- [1] && + !defined $+ [2] && !defined $- [2]; + + /a(a)(a)/; + iseq $#+, 2; + iseq $#-, 2; + iseq $+ [0], 3; + iseq $- [0], 0; + iseq $+ [1], 2; + iseq $- [1], 1; + iseq $+ [2], 3; + iseq $- [2], 2; + ok !defined $+ [3] && !defined $- [3] && + !defined $+ [4] && !defined $- [4]; + + + /.(a)(b)?(a)/; + iseq $#+, 3; + iseq $#-, 3; + iseq $+ [1], 2; + iseq $- [1], 1; + iseq $+ [3], 3; + iseq $- [3], 2; + ok !defined $+ [2] && !defined $- [2] && + !defined $+ [4] && !defined $- [4]; + + + /.(a)/; + iseq $#+, 1; + iseq $#-, 1; + iseq $+ [0], 2; + iseq $- [0], 0; + iseq $+ [1], 2; + iseq $- [1], 1; + ok !defined $+ [2] && !defined $- [2] && + !defined $+ [3] && !defined $- [3]; + + /.(a)(ba*)?/; + iseq $#+, 2; + iseq $#-, 1; + } - print "not " unless "\N{LATIN CAPITAL LETTER A WITH GRAVE}" =~ /\p{InLatin1Supplement}/; - print "ok 627\n"; - print "not " unless "\N{LATIN CAPITAL LETTER A WITH MACRON}" =~ /\p{InLatinExtendedA}/; - print "ok 628\n"; + { + local $DiePattern = '^Modification of a read-only value attempted'; + local $Message = 'Elements of @- and @+ are read-only'; + must_die '$+[0] = 13'; + must_die '$-[0] = 13'; + must_die '@+ = (7, 6, 5)'; + must_die '@- = qw (foo bar)'; + } - print "not " unless "\N{LATIN SMALL LETTER B WITH STROKE}" =~ /\p{InLatinExtendedB}/; - print "ok 629\n"; - print "not " unless "\N{KATAKANA LETTER SMALL A}" =~ /\p{InKatakana}/; - print "ok 630\n"; -} + { + local $Message = '\G testing'; + $_ = 'aaa'; + pos = 1; + my @a = /\Ga/g; + iseq "@a", "a a"; + + my $str = 'abcde'; + pos $str = 2; + ok $str !~ /^\G/; + ok $str !~ /^.\G/; + ok $str =~ /^..\G/; + ok $str !~ /^...\G/; + ok $str =~ /\G../ && $& eq 'cd'; + + local $TODO = $running_as_thread; + ok $str =~ /.\G./ && $& eq 'bc'; + } -$_ = "foo"; - -eval <<"EOT"; die if $@; - /f - o\r - o - \$ - /x && print "ok 631\n"; -EOT - -eval <<"EOT"; die if $@; - /f - o - o - \$\r - /x && print "ok 632\n"; -EOT - -#test /o feature -sub test_o { $_[0] =~/$_[1]/o; return $1} -if(test_o('abc','(.)..') eq 'a') { - print "ok 633\n"; -} else { - print "not ok 633\n"; -} -if(test_o('abc','..(.)') eq 'a') { - print "ok 634\n"; -} else { - print "not ok 634\n"; -} -# 635..639: ID 20010619.003 (only the space character is -# supposed to be [:print:], not the whole isprint()). - -print "not " if "\n" =~ /[[:print:]]/; -print "ok 635\n"; - -print "not " if "\t" =~ /[[:print:]]/; -print "ok 636\n"; - -# Amazingly vertical tabulator is the same in ASCII and EBCDIC. -print "not " if "\014" =~ /[[:print:]]/; -print "ok 637\n"; - -print "not " if "\r" =~ /[[:print:]]/; -print "ok 638\n"; - -print "not " unless " " =~ /[[:print:]]/; -print "ok 639\n"; - -## -## Test basic $^N usage outside of a regex -## -$x = "abcdef"; -$T="ok 640\n";if ($x =~ /cde/ and not defined $^N) {print $T} else {print "not $T"}; -$T="ok 641\n";if ($x =~ /(cde)/ and $^N eq "cde") {print $T} else {print "not $T"}; -$T="ok 642\n";if ($x =~ /(c)(d)(e)/ and $^N eq "e") {print $T} else {print "not $T"}; -$T="ok 643\n";if ($x =~ /(c(d)e)/ and $^N eq "cde") {print $T} else {print "not $T"}; -$T="ok 644\n";if ($x =~ /(foo)|(c(d)e)/ and $^N eq "cde") {print $T} else {print "not $T"}; -$T="ok 645\n";if ($x =~ /(c(d)e)|(foo)/ and $^N eq "cde") {print $T} else {print "not $T"}; -$T="ok 646\n";if ($x =~ /(c(d)e)|(abc)/ and $^N eq "abc") {print $T} else {print "not $T"}; -$T="ok 647\n";if ($x =~ /(c(d)e)|(abc)x/ and $^N eq "cde") {print $T} else {print "not $T"}; -$T="ok 648\n";if ($x =~ /(c(d)e)(abc)?/ and $^N eq "cde") {print $T} else {print "not $T"}; -$T="ok 649\n";if ($x =~ /(?:c(d)e)/ and $^N eq "d" ) {print $T} else {print "not $T"}; -$T="ok 650\n";if ($x =~ /(?:c(d)e)(?:f)/ and $^N eq "d" ) {print $T} else {print "not $T"}; -$T="ok 651\n";if ($x =~ /(?:([abc])|([def]))*/ and $^N eq "f" ){print $T} else {print "not $T"}; -$T="ok 652\n";if ($x =~ /(?:([ace])|([bdf]))*/ and $^N eq "f" ){print $T} else {print "not $T"}; -$T="ok 653\n";if ($x =~ /(([ace])|([bd]))*/ and $^N eq "e" ){print $T} else {print "not $T"}; -{ - $T="ok 654\n";if($x =~ /(([ace])|([bdf]))*/ and $^N eq "f" ){print $T} else {print "not $T"}; -} -## test to see if $^N is automatically localized -- it should now -## have the value set in test 653 -$T="ok 655\n";if ($^N eq "e" ){print $T} else {print "not $T"}; - -## -## Now test inside (?{...}) -## -$T="ok 656\n";if ($x =~ /a([abc])(?{$y=$^N})c/ and $y eq "b" ){print $T} else {print "not $T"}; -$T="ok 657\n";if ($x =~ /a([abc]+)(?{$y=$^N})d/ and $y eq "bc"){print $T} else {print "not $T"}; -$T="ok 658\n";if ($x =~ /a([abcdefg]+)(?{$y=$^N})d/ and $y eq "bc"){print $T} else {print "not $T"}; -$T="ok 659\n";if ($x =~ /(a([abcdefg]+)(?{$y=$^N})d)(?{$z=$^N})e/ and $y eq "bc" and $z eq "abcd") - {print $T} else {print "not $T"}; -$T="ok 660\n";if ($x =~ /(a([abcdefg]+)(?{$y=$^N})de)(?{$z=$^N})/ and $y eq "bc" and $z eq "abcde") - {print $T} else {print "not $T"}; - -# Test the Unicode script classes - -print "not " unless chr(0x100) =~ /\p{IsLatin}/; # outside Latin-1 -print "ok 661\n"; - -print "not " unless chr(0x212b) =~ /\p{IsLatin}/; # Angstrom sign, very outside -print "ok 662\n"; - -print "not " unless chr(0x5d0) =~ /\p{IsHebrew}/; # inside InHebrew -print "ok 663\n"; - -print "not " unless chr(0xfb4f) =~ /\p{IsHebrew}/; # outside InHebrew -print "ok 664\n"; - -# # singleton (not in a range, this test must be ignored on EBCDIC) -# print "not " unless chr(0xb5) =~ /\p{IsGreek}/ or ord("A") == 193; -# print "ok 665\n"; -print "ok 665 # 0xb5 moved from Greek to Common with Unicode 4.0.1\n"; - -print "not " unless chr(0x37a) =~ /\p{IsGreek}/; # singleton -print "ok 666\n"; - -print "not " unless chr(0x386) =~ /\p{IsGreek}/; # singleton -print "ok 667\n"; - -print "not " unless chr(0x387) =~ /\P{IsGreek}/; # not there -print "ok 668\n"; - -print "not " unless chr(0x388) =~ /\p{IsGreek}/; # range -print "ok 669\n"; - -print "not " unless chr(0x38a) =~ /\p{IsGreek}/; # range -print "ok 670\n"; - -print "not " unless chr(0x38b) =~ /\P{IsGreek}/; # not there -print "ok 671\n"; - -print "not " unless chr(0x38c) =~ /\p{IsGreek}/; # singleton -print "ok 672\n"; - -if (ord("A") == 65) { -## -## Test [:cntrl:]... -## -## Should probably put in tests for all the POSIX stuff, but not sure how to -## guarantee a specific locale...... -## - $AllBytes = join('', map { chr($_) } 0..255); - ($x = $AllBytes) =~ s/[[:cntrl:]]//g; - if ($x ne join('', map { chr($_) } 0x20..0x7E, 0x80..0xFF)) { - print "not "; - } - print "ok 673\n"; - - ($x = $AllBytes) =~ s/[^[:cntrl:]]//g; - if ($x ne join('', map { chr($_) } 0..0x1F, 0x7F)) { print "not " } - print "ok 674\n"; -} else { - print "ok $_ # Skip: EBCDIC\n" for 673..674; -} + { + local $Message = 'pos inside (?{ })'; + my $str = 'abcde'; + our ($foo, $bar); + ok $str =~ /b(?{$foo = $_; $bar = pos})c/; + iseq $foo, $str; + iseq $bar, 2; + ok !defined pos ($str); + + undef $foo; + undef $bar; + pos $str = undef; + ok $str =~ /b(?{$foo = $_; $bar = pos})c/g; + iseq $foo, $str; + iseq $bar, 2; + iseq pos ($str), 3; + + $_ = $str; + undef $foo; + undef $bar; + ok /b(?{$foo = $_; $bar = pos})c/; + iseq $foo, $str; + iseq $bar, 2; + + undef $foo; + undef $bar; + ok /b(?{$foo = $_; $bar = pos})c/g; + iseq $foo, $str; + iseq $bar, 2; + iseq pos, 3; + + undef $foo; + undef $bar; + pos = undef; + 1 while /b(?{$foo = $_; $bar = pos})c/g; + iseq $foo, $str; + iseq $bar, 2; + ok !defined pos; + + undef $foo; + undef $bar; + $_ = 'abcde|abcde'; + ok s/b(?{$foo = $_; $bar = pos})c/x/g; + iseq $foo, 'abcde|abcde'; + iseq $bar, 8; + iseq $_, 'axde|axde'; + + # List context: + $_ = 'abcde|abcde'; + our @res; + () = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g; + @res = map {defined $_ ? "'$_'" : 'undef'} @res; + iseq "@res", "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'"; + + @res = (); + () = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g; + @res = map {defined $_ ? "'$_'" : 'undef'} @res; + iseq "@res", "'' 'ab' 'cde|abcde' " . + "'' 'abc' 'de|abcde' " . + "'abcd' 'e|' 'abcde' " . + "'abcde|' 'ab' 'cde' " . + "'abcde|' 'abc' 'de'" ; + } -# With /s modifier UTF8 chars were interpreted as bytes -{ - my $a = "Hello \x{263A} World"; - - my @a = ($a =~ /./gs); - - print "not " unless $#a == 12; - print "ok 675\n"; -} -@a = ("foo\nbar" =~ /./g); -print "ok 676\n" if @a == 6 && "@a" eq "f o o b a r"; + { + local $Message = '\G anchor checks'; + my $foo = 'aabbccddeeffgg'; + pos ($foo) = 1; + { + local $TODO = $running_as_thread; + no warnings 'uninitialized'; + ok $foo =~ /.\G(..)/g; + iseq $1, 'ab'; -@a = ("foo\nbar" =~ /./gs); -print "ok 677\n" if @a == 7 && "@a" eq "f o o \n b a r"; + pos ($foo) += 1; + ok $foo =~ /.\G(..)/g; + iseq $1, 'cc'; -@a = ("foo\nbar" =~ /\C/g); -print "ok 678\n" if @a == 7 && "@a" eq "f o o \n b a r"; + pos ($foo) += 1; + ok $foo =~ /.\G(..)/g; + iseq $1, 'de'; -@a = ("foo\nbar" =~ /\C/gs); -print "ok 679\n" if @a == 7 && "@a" eq "f o o \n b a r"; + ok $foo =~ /\Gef/g; + } -@a = ("foo\n\x{100}bar" =~ /./g); -print "ok 680\n" if @a == 7 && "@a" eq "f o o \x{100} b a r"; + undef pos $foo; + ok $foo =~ /\G(..)/g; + iseq $1, 'aa'; -@a = ("foo\n\x{100}bar" =~ /./gs); -print "ok 681\n" if @a == 8 && "@a" eq "f o o \n \x{100} b a r"; + ok $foo =~ /\G(..)/g; + iseq $1, 'bb'; -($a, $b) = map { chr } ord('A') == 65 ? (0xc4, 0x80) : (0x8c, 0x41); + pos ($foo) = 5; + ok $foo =~ /\G(..)/g; + iseq $1, 'cd'; + } -@a = ("foo\n\x{100}bar" =~ /\C/g); -print "ok 682\n" if @a == 9 && "@a" eq "f o o \n $a $b b a r"; -@a = ("foo\n\x{100}bar" =~ /\C/gs); -print "ok 683\n" if @a == 9 && "@a" eq "f o o \n $a $b b a r"; + { + $_ = '123x123'; + my @res = /(\d*|x)/g; + local $" = '|'; + iseq "@res", "123||x|123|", "0 match in alternation"; + } -{ - # [ID 20010814.004] pos() doesn't work when using =~m// in list context - $_ = "ababacadaea"; - $a = join ":", /b./gc; - $b = join ":", /a./gc; - $c = pos; - print "$a $b $c" eq 'ba:ba ad:ae 10' ? "ok 684\n" : "not ok 684\t# $a $b $c\n"; -} -{ - # [ID 20010407.006] matching utf8 return values from functions does not work + { + local $Message = "Match against temporaries (created via pp_helem())" . + " is safe"; + ok {foo => "bar\n" . $^X} -> {foo} =~ /^(.*)\n/g; + iseq $1, "bar"; + } - package ID_20010407_006; - sub x { - "a\x{1234}"; + { + local $Message = 'package $i inside (?{ }), ' . + 'saved substrings and changing $_'; + our @a = qw [foo bar]; + our @b = (); + s/(\w)(?{push @b, $1})/,$1,/g for @a; + iseq "@b", "f o o b a r"; + iseq "@a", ",f,,o,,o, ,b,,a,,r,"; + + local $Message = 'lexical $i inside (?{ }), ' . + 'saved substrings and changing $_'; + no warnings 'closure'; + my @c = qw [foo bar]; + my @d = (); + s/(\w)(?{push @d, $1})/,$1,/g for @c; + iseq "@d", "f o o b a r"; + iseq "@c", ",f,,o,,o, ,b,,a,,r,"; } - my $x = x; - my $y; - - $x =~ /(..)/; $y = $1; - print "not " unless length($y) == 2 && $y eq $x; - print "ok 685\n"; - x =~ /(..)/; $y = $1; - print "not " unless length($y) == 2 && $y eq $x; - print "ok 686\n"; -} + { + local $Message = 'Brackets'; + our $brackets; + $brackets = qr { + { (?> [^{}]+ | (??{ $brackets }) )* } + }x; + + ok "{{}" =~ $brackets; + iseq $&, "{}"; + ok "something { long { and } hairy" =~ $brackets; + iseq $&, "{ and }"; + ok "something { long { and } hairy" =~ m/((??{ $brackets }))/; + iseq $&, "{ and }"; + } -$test = 687; + { + $_ = "a-a\nxbb"; + pos = 1; + nok m/^-.*bb/mg, '$_ = "a-a\nxbb"; m/^-.*bb/mg'; + } -# Force scalar context on the pattern match -sub ok ($;$) { - my($ok, $name) = @_; - my $todo = $TODO ? " # TODO $TODO" : ''; - printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, - ($name||$Message)."$todo\tLine ".((caller)[2]); + { + local $Message = '\G anchor checks'; + my $text = "aaXbXcc"; + pos ($text) = 0; + ok $text !~ /\GXb*X/g; + } - printf "# Failed test at line %d\n", (caller)[2] unless $ok; - $test++; - return $ok; -} + { + $_ = "xA\n" x 500; + nok /^\s*A/m, '$_ = "xA\n" x 500; /^\s*A/m"'; -sub skip { - my $why = shift; - $why =~ s/\n.*//s; - my $n = @_ ? shift : 1; - for (1..$n) { - print "ok $test # skip: $why\n"; - $test++; + my $text = "abc dbf"; + my @res = ($text =~ /.*?(b).*?\b/g); + iseq "@res", "b b", '\b is not special'; } - local $^W = 0; - last SKIP; -} - -{ - # Check that \x## works. 5.6.1 and 5.005_03 fail some of these. - $x = "\x4e" . "E"; - ok ($x =~ /^\x4EE$/, "Check only 2 bytes of hex are matched."); - $x = "\x4e" . "i"; - ok ($x =~ /^\x4Ei$/, "Check that invalid hex digit stops it (2)"); - $x = "\x4" . "j"; - ok ($x =~ /^\x4j$/, "Check that invalid hex digit stops it (1)"); - - $x = "\x0" . "k"; - ok ($x =~ /^\xk$/, "Check that invalid hex digit stops it (0)"); + { + local $Message = '\S, [\S], \s, [\s]'; + my @a = map chr, 0 .. 255; + my @b = grep /\S/, @a; + my @c = grep /[^\s]/, @a; + iseq "@b", "@c"; + + @b = grep /\S/, @a; + @c = grep /[\S]/, @a; + iseq "@b", "@c"; + + @b = grep /\s/, @a; + @c = grep /[^\S]/, @a; + iseq "@b", "@c"; + + @b = grep /\s/, @a; + @c = grep /[\s]/, @a; + iseq "@b", "@c"; + } + { + local $Message = '\D, [\D], \d, [\d]'; + my @a = map chr, 0 .. 255; + my @b = grep /\D/, @a; + my @c = grep /[^\d]/, @a; + iseq "@b", "@c"; + + @b = grep /\D/, @a; + @c = grep /[\D]/, @a; + iseq "@b", "@c"; + + @b = grep /\d/, @a; + @c = grep /[^\D]/, @a; + iseq "@b", "@c"; + + @b = grep /\d/, @a; + @c = grep /[\d]/, @a; + iseq "@b", "@c"; + } + { + local $Message = '\W, [\W], \w, [\w]'; + my @a = map chr, 0 .. 255; + my @b = grep /\W/, @a; + my @c = grep /[^\w]/, @a; + iseq "@b", "@c"; + + @b = grep /\W/, @a; + @c = grep /[\W]/, @a; + iseq "@b", "@c"; + + @b = grep /\w/, @a; + @c = grep /[^\W]/, @a; + iseq "@b", "@c"; + + @b = grep /\w/, @a; + @c = grep /[\w]/, @a; + iseq "@b", "@c"; + } - $x = "\x0" . "x"; - ok ($x =~ /^\xx$/, "\\xx isn't to be treated as \\0"); - $x = "\x0" . "xa"; - ok ($x =~ /^\xxa$/, "\\xxa isn't to be treated as \\xa"); + { + # see if backtracking optimization works correctly + local $Message = 'Backtrack optimization'; + ok "\n\n" =~ /\n $ \n/x; + ok "\n\n" =~ /\n* $ \n/x; + ok "\n\n" =~ /\n+ $ \n/x; + ok "\n\n" =~ /\n? $ \n/x; + ok "\n\n" =~ /\n*? $ \n/x; + ok "\n\n" =~ /\n+? $ \n/x; + ok "\n\n" =~ /\n?? $ \n/x; + ok "\n\n" !~ /\n*+ $ \n/x; + ok "\n\n" !~ /\n++ $ \n/x; + ok "\n\n" =~ /\n?+ $ \n/x; + } - $x = "\x9" . "_b"; - ok ($x =~ /^\x9_b$/, "\\x9_b isn't to be treated as \\x9b"); - print "# and now again in [] ranges\n"; + { + 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"; + ::ok [] =~ /^ARRAY/, "Array ref stringification"; + ::ok {} =~ /^HASH/, "Hash ref stringification"; + ::ok 'S' -> new =~ /^Object S/, "Object stringification"; + } - $x = "\x4e" . "E"; - ok ($x =~ /^[\x4EE]{2}$/, "Check only 2 bytes of hex are matched."); - $x = "\x4e" . "i"; - ok ($x =~ /^[\x4Ei]{2}$/, "Check that invalid hex digit stops it (2)"); + { + local $Message = "Test result of match used as match"; + ok 'a1b' =~ ('xyz' =~ /y/); + iseq $`, 'a'; + ok 'a1b' =~ ('xyz' =~ /t/); + iseq $`, 'a'; + } - $x = "\x4" . "j"; - ok ($x =~ /^[\x4j]{2}$/, "Check that invalid hex digit stops it (1)"); - $x = "\x0" . "k"; - ok ($x =~ /^[\xk]{2}$/, "Check that invalid hex digit stops it (0)"); + { + local $Message = '"1" is not \s'; + may_not_warn sub {ok ("1\n" x 102) !~ /^\s*\n/m}; + } - $x = "\x0" . "x"; - ok ($x =~ /^[\xx]{2}$/, "\\xx isn't to be treated as \\0"); - $x = "\x0" . "xa"; - ok ($x =~ /^[\xxa]{3}$/, "\\xxa isn't to be treated as \\xa"); + { + local $Message = '\s, [[:space:]] and [[:blank:]]'; + my %space = (spc => " ", + tab => "\t", + cr => "\r", + lf => "\n", + ff => "\f", + # There's no \v but the vertical tabulator seems miraculously + # be 11 both in ASCII and EBCDIC. + vt => chr(11), + false => "space"); + + my @space0 = sort grep {$space {$_} =~ /\s/ } keys %space; + my @space1 = sort grep {$space {$_} =~ /[[:space:]]/} keys %space; + my @space2 = sort grep {$space {$_} =~ /[[:blank:]]/} keys %space; + + iseq "@space0", "cr ff lf spc tab"; + iseq "@space1", "cr ff lf spc tab vt"; + iseq "@space2", "spc tab"; + } - $x = "\x9" . "_b"; - ok ($x =~ /^[\x9_b]{3}$/, "\\x9_b isn't to be treated as \\x9b"); -} + { + local $BugId = '20000731.001'; + ok "A \x{263a} B z C" =~ /A . B (??{ "z" }) C/, + "Match UTF-8 char in presense of (??{ })"; + } -{ - # Check that \x{##} works. 5.6.1 fails quite a few of these. - $x = "\x9b"; - ok ($x =~ /^\x{9_b}$/, "\\x{9_b} is to be treated as \\x9b"); + { + local $BugId = '20001021.005'; + no warnings 'uninitialized'; + ok undef =~ /^([^\/]*)(.*)$/, "Used to cause a SEGV"; + } - $x = "\x9b" . "y"; - ok ($x =~ /^\x{9_b}y$/, "\\x{9_b} is to be treated as \\x9b (again)"); - $x = "\x9b" . "y"; - ok ($x =~ /^\x{9b_}y$/, "\\x{9b_} is to be treated as \\x9b"); + SKIP: + { + local $Message = '\C matches octet'; + $_ = "a\x{100}b"; + ok /(.)(\C)(\C)(.)/ or skip q [\C doesn't match], 4; + iseq $1, "a"; + if ($IS_ASCII) { # ASCII (or equivalent), should be UTF-8 + iseq $2, "\xC4"; + iseq $3, "\x80"; + } + elsif ($IS_EBCDIC) { # EBCDIC (or equivalent), should be UTF-EBCDIC + iseq $2, "\x8C"; + iseq $3, "\x41"; + } + else { + SKIP: { + ok 0, "Unexpected platform", "ord ('A') = $ordA"; + skip "Unexpected platform"; + } + } + iseq $4, "b"; + } - $x = "\x9b" . "y"; - ok ($x =~ /^\x{9_bq}y$/, "\\x{9_bc} is to be treated as \\x9b"); - $x = "\x0" . "y"; - ok ($x =~ /^\x{x9b}y$/, "\\x{x9b} is to be treated as \\x0"); - - $x = "\x0" . "y"; - ok ($x =~ /^\x{0x9b}y$/, "\\x{0x9b} is to be treated as \\x0"); + SKIP: + { + local $Message = '\C matches octet'; + $_ = "\x{100}"; + ok /(\C)/g or skip q [\C doesn't match], 2; + if ($IS_ASCII) { + iseq $1, "\xC4"; + } + elsif ($IS_EBCDIC) { + iseq $1, "\x8C"; + } + else { + ok 0, "Unexpected platform", "ord ('A') = $ordA"; + } + ok /(\C)/g or skip q [\C doesn't match]; + if ($IS_ASCII) { + iseq $1, "\x80"; + } + elsif ($IS_EBCDIC) { + iseq $1, "\x41"; + } + else { + ok 0, "Unexpected platform", "ord ('A') = $ordA"; + } + } - $x = "\x9b" . "y"; - ok ($x =~ /^\x{09b}y$/, "\\x{09b} is to be treated as \\x9b"); - print "# and now again in [] ranges\n"; + { + # Japhy -- added 03/03/2001 + () = (my $str = "abc") =~ /(...)/; + $str = "def"; + iseq $1, "abc", 'Changing subject does not modify $1'; + } - $x = "\x9b"; - ok ($x =~ /^[\x{9_b}]$/, "\\x{9_b} is to be treated as \\x9b"); - $x = "\x9b" . "y"; - ok ($x =~ /^[\x{9_b}y]{2}$/, "\\x{9_b} is to be treated as \\x9b (again)"); + SKIP: + { + # The trick is that in EBCDIC the explicit numeric range should + # match (as also in non-EBCDIC) but the explicit alphabetic range + # should not match. + ok "\x8e" =~ /[\x89-\x91]/, '"\x8e" =~ /[\x89-\x91]/'; + ok "\xce" =~ /[\xc9-\xd1]/, '"\xce" =~ /[\xc9-\xd1]/'; + + skip "Not an EBCDIC platform", 2 unless ord ('i') == 0x89 && + ord ('J') == 0xd1; + + # In most places these tests would succeed since \x8e does not + # in most character sets match 'i' or 'j' nor would \xce match + # 'I' or 'J', but strictly speaking these tests are here for + # the good of EBCDIC, so let's test these only there. + nok "\x8e" !~ /[i-j]/, '"\x8e" !~ /[i-j]/'; + nok "\xce" !~ /[I-J]/, '"\xce" !~ /[I-J]/'; + } - $x = "\x9b" . "y"; - ok ($x =~ /^[\x{9b_}y]{2}$/, "\\x{9b_} is to be treated as \\x9b"); - $x = "\x9b" . "y"; - ok ($x =~ /^[\x{9_bq}y]{2}$/, "\\x{9_bc} is to be treated as \\x9b"); + { + ok "\x{ab}" =~ /\x{ab}/, '"\x{ab}" =~ /\x{ab}/ '; + ok "\x{abcd}" =~ /\x{abcd}/, '"\x{abcd}" =~ /\x{abcd}/'; + } - $x = "\x0" . "y"; - ok ($x =~ /^[\x{x9b}y]{2}$/, "\\x{x9b} is to be treated as \\x0"); - $x = "\x0" . "y"; - ok ($x =~ /^[\x{0x9b}y]{2}$/, "\\x{0x9b} is to be treated as \\x0"); + { + local $Message = 'bug id 20001008.001'; + + my @x = ("stra\337e 138", "stra\337e 138"); + for (@x) { + 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/; + # + # Previous code follows, but outcommented - there were no tests. + # + # $latin =~ s/stra\337e/straße/; # \303\237 after the 2nd a + # use utf8; # needed for the raw UTF-8 + # $latin =~ s!(s)tr(?:aß|s+e)!$1tr.!; # \303\237 after the a + } + } - $x = "\x9b" . "y"; - ok ($x =~ /^[\x{09b}y]{2}$/, "\\x{09b} is to be treated as \\x9b"); -} -{ - # high bit bug -- japhy - my $x = "ab\200d"; - $x =~ /.*?\200/ or print "not "; - print "ok 715\n"; -} + { + local $Message = 'Test \x escapes'; + ok "ba\xd4c" =~ /([a\xd4]+)/ && $1 eq "a\xd4"; + ok "ba\xd4c" =~ /([a\xd4]+)/ && $1 eq "a\x{d4}"; + ok "ba\x{d4}c" =~ /([a\xd4]+)/ && $1 eq "a\x{d4}"; + ok "ba\x{d4}c" =~ /([a\xd4]+)/ && $1 eq "a\xd4"; + ok "ba\xd4c" =~ /([a\x{d4}]+)/ && $1 eq "a\xd4"; + ok "ba\xd4c" =~ /([a\x{d4}]+)/ && $1 eq "a\x{d4}"; + ok "ba\x{d4}c" =~ /([a\x{d4}]+)/ && $1 eq "a\x{d4}"; + ok "ba\x{d4}c" =~ /([a\x{d4}]+)/ && $1 eq "a\xd4"; + } -print "# some Unicode properties\n"; -{ - # Dashes, underbars, case. - print "not " unless "\x80" =~ /\p{in-latin1_SUPPLEMENT}/; - print "ok 716\n"; + { + local $BugId = '20001028.003'; + + # Fist half of the bug. + local $Message = 'HEBREW ACCENT QADMA matched by .*'; + my $X = chr (1448); + ok my ($Y) = $X =~ /(.*)/; + iseq $Y, v1448; + iseq length ($Y), 1; + + # Second half of the bug. + $Message = 'HEBREW ACCENT QADMA in replacement'; + $X = ''; + $X =~ s/^/chr(1488)/e; + iseq length $X, 1; + iseq ord ($X), 1488; + } - # Complement, leading and trailing whitespace. - print "not " unless "\x80" =~ /\P{ ^ In Latin 1 Supplement }/; - print "ok 717\n"; - # No ^In, dashes, case, dash, any intervening (word-break) whitespace. - # (well, newlines don't work...) - print "not " unless "\x80" =~ /\p{latin-1 supplement}/; - print "ok 718\n"; -} + { + local $BugId = '20001108.001'; + local $Message = 'Repeated s///'; + my $X = "Szab\x{f3},Bal\x{e1}zs"; + my $Y = $X; + $Y =~ s/(B)/$1/ for 0 .. 3; + iseq $Y, $X; + iseq $X, "Szab\x{f3},Bal\x{e1}zs"; + } -{ - print "not " unless "a" =~ /\pL/; - print "ok 719\n"; - print "not " unless "a" =~ /\p{IsLl}/; - print "ok 720\n"; + { + local $BugId = '20000517.001'; + local $Message = 's/// on UTF-8 string'; + my $x = "\x{100}A"; + $x =~ s/A/B/; + iseq $x, "\x{100}B"; + iseq length $x, 2; + } - print "not " if "a" =~ /\p{IsLu}/; - print "ok 721\n"; - print "not " unless "a" =~ /\p{Ll}/; - print "ok 722\n"; + { + local $BugId = '20001230.002'; + local $Message = '\C and É'; + ok "École" =~ /^\C\C(.)/ && $1 eq 'c'; + ok "École" =~ /^\C\C(c)/; + } - print "not " if "a" =~ /\p{Lu}/; - print "ok 723\n"; - print "not " unless "A" =~ /\pL/; - print "ok 724\n"; + SKIP: + { + local $Message = 'Match code points > 255'; + $_ = "abc\x{100}\x{200}\x{300}\x{380}\x{400}defg"; + ok /(.\x{300})./ or skip "No match", 4; + ok $` eq "abc\x{100}" && length ($`) == 4; + ok $& eq "\x{200}\x{300}\x{380}" && length ($&) == 3; + ok $' eq "\x{400}defg" && length ($') == 5; + ok $1 eq "\x{200}\x{300}" && length ($1) == 2; + } - print "not " unless "A" =~ /\p{IsLu}/; - print "ok 725\n"; - print "not " if "A" =~ /\p{IsLl}/; - print "ok 726\n"; + { + # The original bug report had 'no utf8' here but that was irrelevant. + local $BugId = '20010306.008'; + local $Message = "Don't dump core"; + my $a = "a\x{1234}"; + ok $a =~ m/\w/; # used to core dump. + } - print "not " unless "A" =~ /\p{Lu}/; - print "ok 727\n"; - print "not " if "A" =~ /\p{Ll}/; - print "ok 728\n"; + { + local $BugId = '20010410.006'; + local $Message = '/g in scalar context'; + for my $rx ('/(.*?)\{(.*?)\}/csg', + '/(.*?)\{(.*?)\}/cg', + '/(.*?)\{(.*?)\}/sg', + '/(.*?)\{(.*?)\}/g', + '/(.+?)\{(.+?)\}/csg',) { + my $i = 0; + my $input = "a{b}c{d}"; + eval <<" --"; + while (eval \$input =~ $rx) { + \$i ++; + } + -- + iseq $i, 2; + } + } - print "not " if "a" =~ /\PL/; - print "ok 729\n"; - print "not " if "a" =~ /\P{IsLl}/; - print "ok 730\n"; + { + my $x = "\x{10FFFD}"; + $x =~ s/(.)/$1/g; + ok ord($x) == 0x10FFFD && length($x) == 1, "From Robin Houston"; + } - print "not " unless "a" =~ /\P{IsLu}/; - print "ok 731\n"; - print "not " if "a" =~ /\P{Ll}/; - print "ok 732\n"; + { + my %d = ( + "7f" => [0, 0, 0], + "80" => [1, 1, 0], + "ff" => [1, 1, 0], + "100" => [0, 1, 1], + ); + SKIP: + while (my ($code, $match) = each %d) { + local $Message = "Properties of \\x$code"; + my $char = eval qq ["\\x{$code}"]; + my $i = 0; + ok (($char =~ /[\x80-\xff]/) xor !$$match [$i ++]); + ok (($char =~ /[\x80-\x{100}]/) xor !$$match [$i ++]); + ok (($char =~ /[\x{100}]/) xor !$$match [$i ++]); + } + } - print "not " unless "a" =~ /\P{Lu}/; - print "ok 733\n"; - print "not " if "A" =~ /\PL/; - print "ok 734\n"; + { + # From Japhy + local $Message; + must_warn 'qr/(?c)/', '^Useless \(\?c\)'; + must_warn 'qr/(?-c)/', '^Useless \(\?-c\)'; + must_warn 'qr/(?g)/', '^Useless \(\?g\)'; + must_warn 'qr/(?-g)/', '^Useless \(\?-g\)'; + must_warn 'qr/(?o)/', '^Useless \(\?o\)'; + must_warn 'qr/(?-o)/', '^Useless \(\?-o\)'; + + # Now test multi-error regexes + must_warn 'qr/(?g-o)/', '^Useless \(\?g\).*\nUseless \(\?-o\)'; + must_warn 'qr/(?g-c)/', '^Useless \(\?g\).*\nUseless \(\?-c\)'; + # (?c) means (?g) error won't be thrown + must_warn 'qr/(?o-cg)/', '^Useless \(\?o\).*\nUseless \(\?-c\)'; + must_warn 'qr/(?ogc)/', '^Useless \(\?o\).*\nUseless \(\?g\).*\n' . + 'Useless \(\?c\)'; + } - print "not " if "A" =~ /\P{IsLu}/; - print "ok 735\n"; - print "not " unless "A" =~ /\P{IsLl}/; - print "ok 736\n"; + { + local $Message = "/x tests"; + $_ = "foo"; + eval_ok <<" --"; + /f + o\r + o + \$ + /x + -- + eval_ok <<" --"; + /f + o + o + \$\r + /x + -- + } - print "not " if "A" =~ /\P{Lu}/; - print "ok 737\n"; - print "not " unless "A" =~ /\P{Ll}/; - print "ok 738\n"; + { + local $Message = "/o feature"; + sub test_o {$_ [0] =~ /$_[1]/o; return $1} + iseq test_o ('abc', '(.)..'), 'a'; + iseq test_o ('abc', '..(.)'), 'a'; + } -} -{ - print "not " if "a" =~ /\p{Common}/; - print "ok 739\n"; + { + local $BugId = "20010619.003"; + # Amazingly vertical tabulator is the same in ASCII and EBCDIC. + for ("\n", "\t", "\014", "\r") { + ok !/[[:print:]]/, "'$_' not in [[:print:]]"; + } + for (" ") { + ok /[[:print:]]/, "'$_' in [[:print:]]"; + } + } - print "not " unless "1" =~ /\p{Common}/; - print "ok 740\n"; -} -{ - print "not " if "a" =~ /\p{Inherited}/; - print "ok 741\n"; + { + # Test basic $^N usage outside of a regex + local $Message = '$^N usage outside of a regex'; + my $x = "abcdef"; + ok ($x =~ /cde/ and !defined $^N); + ok ($x =~ /(cde)/ and $^N eq "cde"); + ok ($x =~ /(c)(d)(e)/ and $^N eq "e"); + ok ($x =~ /(c(d)e)/ and $^N eq "cde"); + ok ($x =~ /(foo)|(c(d)e)/ and $^N eq "cde"); + ok ($x =~ /(c(d)e)|(foo)/ and $^N eq "cde"); + ok ($x =~ /(c(d)e)|(abc)/ and $^N eq "abc"); + ok ($x =~ /(c(d)e)|(abc)x/ and $^N eq "cde"); + ok ($x =~ /(c(d)e)(abc)?/ and $^N eq "cde"); + ok ($x =~ /(?:c(d)e)/ and $^N eq "d"); + ok ($x =~ /(?:c(d)e)(?:f)/ and $^N eq "d"); + ok ($x =~ /(?:([abc])|([def]))*/ and $^N eq "f"); + ok ($x =~ /(?:([ace])|([bdf]))*/ and $^N eq "f"); + ok ($x =~ /(([ace])|([bd]))*/ and $^N eq "e"); + {ok ($x =~ /(([ace])|([bdf]))*/ and $^N eq "f");} + ## Test to see if $^N is automatically localized -- it should now + ## have the value set in the previous test. + iseq $^N, "e", '$^N is automatically localized'; + + # Now test inside (?{ ... }) + local $Message = '$^N usage inside (?{ ... })'; + our ($y, $z); + ok ($x =~ /a([abc])(?{$y=$^N})c/ and $y eq "b"); + ok ($x =~ /a([abc]+)(?{$y=$^N})d/ and $y eq "bc"); + ok ($x =~ /a([abcdefg]+)(?{$y=$^N})d/ and $y eq "bc"); + ok ($x =~ /(a([abcdefg]+)(?{$y=$^N})d)(?{$z=$^N})e/ and $y eq "bc" + and $z eq "abcd"); + ok ($x =~ /(a([abcdefg]+)(?{$y=$^N})de)(?{$z=$^N})/ and $y eq "bc" + and $z eq "abcde"); - print "not " unless "\x{300}" =~ /\p{Inherited}/; - print "ok 742\n"; -} + } -{ - # L& and LC are the same - print "not " unless "a" =~ /\p{LC}/ and "a" =~ /\p{L&}/; - print "ok 743\n"; - print "not " if "1" =~ /\p{LC}/ or "1" =~ /\p{L&}/; - print "ok 744\n"; -} + SKIP: + { + ## Should probably put in tests for all the POSIX stuff, + ## but not sure how to guarantee a specific locale...... -{ - print "not " unless "a" =~ /\p{Lowercase Letter}/; - print "ok 745\n"; + skip "Not an ASCII platform", 2 unless $IS_ASCII; + local $Message = 'Test [[:cntrl:]]'; + my $AllBytes = join "" => map {chr} 0 .. 255; + (my $x = $AllBytes) =~ s/[[:cntrl:]]//g; + iseq $x, join "", map {chr} 0x20 .. 0x7E, 0x80 .. 0xFF; - print "not " if "A" =~ /\p{lowercaseletter}/; - print "ok 746\n"; -} + ($x = $AllBytes) =~ s/[^[:cntrl:]]//g; + iseq $x, join "", map {chr} 0x00 .. 0x1F, 0x7F; + } -{ - print "not " unless "\x{AC00}" =~ /\p{HangulSyllables}/; - print "ok 747\n"; -} -{ - # Script=, Block=, Category= + { + # With /s modifier UTF8 chars were interpreted as bytes + local $Message = "UTF-8 chars aren't bytes"; + my $a = "Hello \x{263A} World"; + my @a = ($a =~ /./gs); + iseq $#a, 12; + } - print "not " unless "\x{0100}" =~ /\p{Script=Latin}/; - print "ok 748\n"; - print "not " unless "\x{0100}" =~ /\p{Block=LatinExtendedA}/; - print "ok 749\n"; + { + local $Message = '. matches \n with /s'; + my $str1 = "foo\nbar"; + my $str2 = "foo\n\x{100}bar"; + my ($a, $b) = map {chr} $IS_ASCII ? (0xc4, 0x80) : (0x8c, 0x41); + my @a; + @a = $str1 =~ /./g; iseq @a, 6; iseq "@a", "f o o b a r"; + @a = $str1 =~ /./gs; iseq @a, 7; iseq "@a", "f o o \n b a r"; + @a = $str1 =~ /\C/g; iseq @a, 7; iseq "@a", "f o o \n b a r"; + @a = $str1 =~ /\C/gs; iseq @a, 7; iseq "@a", "f o o \n b a r"; + @a = $str2 =~ /./g; iseq @a, 7; iseq "@a", "f o o \x{100} b a r"; + @a = $str2 =~ /./gs; iseq @a, 8; iseq "@a", "f o o \n \x{100} b a r"; + @a = $str2 =~ /\C/g; iseq @a, 9; iseq "@a", "f o o \n $a $b b a r"; + @a = $str2 =~ /\C/gs; iseq @a, 9; iseq "@a", "f o o \n $a $b b a r"; + } - print "not " unless "\x{0100}" =~ /\p{Category=UppercaseLetter}/; - print "ok 750\n"; -} -{ - print "# the basic character classes and Unicode \n"; + { + # [ID 20010814.004] pos() doesn't work when using =~m// in list context + local $BugId = '20010814.004'; + $_ = "ababacadaea"; + my $a = join ":", /b./gc; + my $b = join ":", /a./gc; + my $c = pos; + iseq "$a $b $c", 'ba:ba ad:ae 10', "pos() works with () = m//"; + } - # 0100;LATIN CAPITAL LETTER A WITH MACRON;Lu;0;L;0041 0304;;;;N;LATIN CAPITAL LETTER A MACRON;;;0101; - print "not " unless "\x{0100}" =~ /\w/; - print "ok 751\n"; - # 0660;ARABIC-INDIC DIGIT ZERO;Nd;0;AN;;0;0;0;N;;;;; - print "not " unless "\x{0660}" =~ /\d/; - print "ok 752\n"; + { + # [ID 20010407.006] matching utf8 return values from + # functions does not work + local $BugId = '20010407.006'; + local $Message = 'UTF-8 return values from functions'; + package ID_20010407_006; + sub x {"a\x{1234}"} + my $x = x; + my $y; + ::ok $x =~ /(..)/; + $y = $1; + ::ok length ($y) == 2 && $y eq $x; + ::ok x =~ /(..)/; + $y = $1; + ::ok length ($y) == 2 && $y eq $x; + } - # 1680;OGHAM SPACE MARK;Zs;0;WS;;;;;N;;;;; - print "not " unless "\x{1680}" =~ /\s/; - print "ok 753\n"; -} -{ - print "# folding matches and Unicode\n"; + { + no warnings 'digit'; + # Check that \x## works. 5.6.1 and 5.005_03 fail some of these. + my $x; + $x = "\x4e" . "E"; + ok ($x =~ /^\x4EE$/, "Check only 2 bytes of hex are matched."); - print "not " unless "a\x{100}" =~ /A/i; - print "ok 754\n"; + $x = "\x4e" . "i"; + ok ($x =~ /^\x4Ei$/, "Check that invalid hex digit stops it (2)"); - print "not " unless "A\x{100}" =~ /a/i; - print "ok 755\n"; + $x = "\x4" . "j"; + ok ($x =~ /^\x4j$/, "Check that invalid hex digit stops it (1)"); - print "not " unless "a\x{100}" =~ /a/i; - print "ok 756\n"; + $x = "\x0" . "k"; + ok ($x =~ /^\xk$/, "Check that invalid hex digit stops it (0)"); - print "not " unless "A\x{100}" =~ /A/i; - print "ok 757\n"; + $x = "\x0" . "x"; + ok ($x =~ /^\xx$/, "\\xx isn't to be treated as \\0"); - print "not " unless "\x{101}a" =~ /\x{100}/i; - print "ok 758\n"; + $x = "\x0" . "xa"; + ok ($x =~ /^\xxa$/, "\\xxa isn't to be treated as \\xa"); - print "not " unless "\x{100}a" =~ /\x{100}/i; - print "ok 759\n"; + $x = "\x9" . "_b"; + ok ($x =~ /^\x9_b$/, "\\x9_b isn't to be treated as \\x9b"); - print "not " unless "\x{101}a" =~ /\x{101}/i; - print "ok 760\n"; + # and now again in [] ranges - print "not " unless "\x{100}a" =~ /\x{101}/i; - print "ok 761\n"; + $x = "\x4e" . "E"; + ok ($x =~ /^[\x4EE]{2}$/, "Check only 2 bytes of hex are matched."); - print "not " unless "a\x{100}" =~ /A\x{100}/i; - print "ok 762\n"; + $x = "\x4e" . "i"; + ok ($x =~ /^[\x4Ei]{2}$/, "Check that invalid hex digit stops it (2)"); - print "not " unless "A\x{100}" =~ /a\x{100}/i; - print "ok 763\n"; + $x = "\x4" . "j"; + ok ($x =~ /^[\x4j]{2}$/, "Check that invalid hex digit stops it (1)"); - print "not " unless "a\x{100}" =~ /a\x{100}/i; - print "ok 764\n"; + $x = "\x0" . "k"; + ok ($x =~ /^[\xk]{2}$/, "Check that invalid hex digit stops it (0)"); - print "not " unless "A\x{100}" =~ /A\x{100}/i; - print "ok 765\n"; + $x = "\x0" . "x"; + ok ($x =~ /^[\xx]{2}$/, "\\xx isn't to be treated as \\0"); - print "not " unless "a\x{100}" =~ /[A]/i; - print "ok 766\n"; + $x = "\x0" . "xa"; + ok ($x =~ /^[\xxa]{3}$/, "\\xxa isn't to be treated as \\xa"); - print "not " unless "A\x{100}" =~ /[a]/i; - print "ok 767\n"; + $x = "\x9" . "_b"; + ok ($x =~ /^[\x9_b]{3}$/, "\\x9_b isn't to be treated as \\x9b"); - print "not " unless "a\x{100}" =~ /[a]/i; - print "ok 768\n"; + # Check that \x{##} works. 5.6.1 fails quite a few of these. - print "not " unless "A\x{100}" =~ /[A]/i; - print "ok 769\n"; + $x = "\x9b"; + ok ($x =~ /^\x{9_b}$/, "\\x{9_b} is to be treated as \\x9b"); - print "not " unless "\x{101}a" =~ /[\x{100}]/i; - print "ok 770\n"; + $x = "\x9b" . "y"; + ok ($x =~ /^\x{9_b}y$/, "\\x{9_b} is to be treated as \\x9b (again)"); - print "not " unless "\x{100}a" =~ /[\x{100}]/i; - print "ok 771\n"; + $x = "\x9b" . "y"; + ok ($x =~ /^\x{9b_}y$/, "\\x{9b_} is to be treated as \\x9b"); - print "not " unless "\x{101}a" =~ /[\x{101}]/i; - print "ok 772\n"; + $x = "\x9b" . "y"; + ok ($x =~ /^\x{9_bq}y$/, "\\x{9_bc} is to be treated as \\x9b"); - print "not " unless "\x{100}a" =~ /[\x{101}]/i; - print "ok 773\n"; + $x = "\x0" . "y"; + ok ($x =~ /^\x{x9b}y$/, "\\x{x9b} is to be treated as \\x0"); -} + $x = "\x0" . "y"; + ok ($x =~ /^\x{0x9b}y$/, "\\x{0x9b} is to be treated as \\x0"); -{ - use charnames ':full'; + $x = "\x9b" . "y"; + ok ($x =~ /^\x{09b}y$/, "\\x{09b} is to be treated as \\x9b"); - print "# LATIN LETTER A WITH GRAVE\n"; - my $lower = "\N{LATIN SMALL LETTER A WITH GRAVE}"; - my $UPPER = "\N{LATIN CAPITAL LETTER A WITH GRAVE}"; + $x = "\x9b"; + ok ($x =~ /^[\x{9_b}]$/, "\\x{9_b} is to be treated as \\x9b"); - print $lower =~ m/$UPPER/i ? "ok 774\n" : "not ok 774\n"; - print $UPPER =~ m/$lower/i ? "ok 775\n" : "not ok 775\n"; - print $lower =~ m/[$UPPER]/i ? "ok 776\n" : "not ok 776\n"; - print $UPPER =~ m/[$lower]/i ? "ok 777\n" : "not ok 777\n"; + $x = "\x9b" . "y"; + ok ($x =~ /^[\x{9_b}y]{2}$/, + "\\x{9_b} is to be treated as \\x9b (again)"); - print "# GREEK LETTER ALPHA WITH VRACHY\n"; + $x = "\x9b" . "y"; + ok ($x =~ /^[\x{9b_}y]{2}$/, "\\x{9b_} is to be treated as \\x9b"); - $lower = "\N{GREEK CAPITAL LETTER ALPHA WITH VRACHY}"; - $UPPER = "\N{GREEK SMALL LETTER ALPHA WITH VRACHY}"; + $x = "\x9b" . "y"; + ok ($x =~ /^[\x{9_bq}y]{2}$/, "\\x{9_bc} is to be treated as \\x9b"); - print $lower =~ m/$UPPER/i ? "ok 778\n" : "not ok 778\n"; - print $UPPER =~ m/$lower/i ? "ok 779\n" : "not ok 779\n"; - print $lower =~ m/[$UPPER]/i ? "ok 780\n" : "not ok 780\n"; - print $UPPER =~ m/[$lower]/i ? "ok 781\n" : "not ok 781\n"; + $x = "\x0" . "y"; + ok ($x =~ /^[\x{x9b}y]{2}$/, "\\x{x9b} is to be treated as \\x0"); - print "# LATIN LETTER Y WITH DIAERESIS\n"; + $x = "\x0" . "y"; + ok ($x =~ /^[\x{0x9b}y]{2}$/, "\\x{0x9b} is to be treated as \\x0"); - $lower = "\N{LATIN CAPITAL LETTER Y WITH DIAERESIS}"; - $UPPER = "\N{LATIN SMALL LETTER Y WITH DIAERESIS}"; - print $lower =~ m/$UPPER/i ? "ok 782\n" : "not ok 782\n"; - print $UPPER =~ m/$lower/i ? "ok 783\n" : "not ok 783\n"; - print $lower =~ m/[$UPPER]/i ? "ok 784\n" : "not ok 784\n"; - print $UPPER =~ m/[$lower]/i ? "ok 785\n" : "not ok 785\n"; -} + $x = "\x9b" . "y"; + ok ($x =~ /^[\x{09b}y]{2}$/, "\\x{09b} is to be treated as \\x9b"); -{ - use warnings; - use charnames ':full'; - - print "# GREEK CAPITAL LETTER SIGMA vs COMBINING GREEK PERISPOMENI\n"; + } - my $SIGMA = "\N{GREEK CAPITAL LETTER SIGMA}"; - my $char = "\N{COMBINING GREEK PERISPOMENI}"; - # Before #13843 this was failing by matching falsely. - print "_:$char:_" =~ m/_:$SIGMA:_/i ? "not ok 786\n" : "ok 786\n"; -} + { + # High bit bug -- japhy + my $x = "ab\200d"; + ok $x =~ /.*?\200/, "High bit fine"; + } -{ - print "# \\X\n"; - - use charnames ':full'; - - print "a!" =~ /^(\X)!/ && $1 eq "a" ? - "ok 787\n" : "not ok 787 # $1\n"; - print "\xDF!" =~ /^(\X)!/ && $1 eq "\xDF" ? - "ok 788\n" : "not ok 788 # $1\n"; - print "\x{100}!" =~ /^(\X)!/ && $1 eq "\x{100}" ? - "ok 789\n" : "not ok 789 # $1\n"; - print "\x{100}\x{300}!" =~ /^(\X)!/ && $1 eq "\x{100}\x{300}" ? - "ok 790\n" : "not ok 790 # $1\n"; - print "\N{LATIN CAPITAL LETTER E}!" =~ /^(\X)!/ && - $1 eq "\N{LATIN CAPITAL LETTER E}" ? - "ok 791\n" : "not ok 791 # $1\n"; - print "\N{LATIN CAPITAL LETTER E}\N{COMBINING GRAVE ACCENT}!" =~ - /^(\X)!/ && - $1 eq "\N{LATIN CAPITAL LETTER E}\N{COMBINING GRAVE ACCENT}" ? - "ok 792\n" : "not ok 792 # $1\n"; -} -{ - print "#\\C and \\X\n"; + { + # The basic character classes and Unicode + ok "\x{0100}" =~ /\w/, 'LATIN CAPITAL LETTER A WITH MACRON in /\w/'; + ok "\x{0660}" =~ /\d/, 'ARABIC-INDIC DIGIT ZERO in /\d/'; + ok "\x{1680}" =~ /\s/, 'OGHAM SPACE MARK in /\s/'; + } - print "!abc!" =~ /a\Cc/ ? "ok 793\n" : "not ok 793\n"; - print "!abc!" =~ /a\Xc/ ? "ok 794\n" : "not ok 794\n"; -} -{ - print "# FINAL SIGMA\n"; + { + local $Message = "Folding matches and Unicode"; + ok "a\x{100}" =~ /A/i; + ok "A\x{100}" =~ /a/i; + ok "a\x{100}" =~ /a/i; + ok "A\x{100}" =~ /A/i; + ok "\x{101}a" =~ /\x{100}/i; + ok "\x{100}a" =~ /\x{100}/i; + ok "\x{101}a" =~ /\x{101}/i; + ok "\x{100}a" =~ /\x{101}/i; + ok "a\x{100}" =~ /A\x{100}/i; + ok "A\x{100}" =~ /a\x{100}/i; + ok "a\x{100}" =~ /a\x{100}/i; + ok "A\x{100}" =~ /A\x{100}/i; + ok "a\x{100}" =~ /[A]/i; + ok "A\x{100}" =~ /[a]/i; + ok "a\x{100}" =~ /[a]/i; + ok "A\x{100}" =~ /[A]/i; + ok "\x{101}a" =~ /[\x{100}]/i; + ok "\x{100}a" =~ /[\x{100}]/i; + ok "\x{101}a" =~ /[\x{101}]/i; + ok "\x{100}a" =~ /[\x{101}]/i; + } - my $SIGMA = "\x{03A3}"; # CAPITAL - my $Sigma = "\x{03C2}"; # SMALL FINAL - my $sigma = "\x{03C3}"; # SMALL - print $SIGMA =~ /$SIGMA/i ? "ok 795\n" : "not ok 795\n"; - print $SIGMA =~ /$Sigma/i ? "ok 796\n" : "not ok 796\n"; - print $SIGMA =~ /$sigma/i ? "ok 797\n" : "not ok 797\n"; + { + use charnames ':full'; + local $Message = "Folding 'LATIN LETTER A WITH GRAVE'"; - print $Sigma =~ /$SIGMA/i ? "ok 798\n" : "not ok 798\n"; - print $Sigma =~ /$Sigma/i ? "ok 799\n" : "not ok 799\n"; - print $Sigma =~ /$sigma/i ? "ok 800\n" : "not ok 800\n"; + 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 $UPPER =~ m/[$lower]/i; - print $sigma =~ /$SIGMA/i ? "ok 801\n" : "not ok 801\n"; - print $sigma =~ /$Sigma/i ? "ok 802\n" : "not ok 802\n"; - print $sigma =~ /$sigma/i ? "ok 803\n" : "not ok 803\n"; - - print $SIGMA =~ /[$SIGMA]/i ? "ok 804\n" : "not ok 804\n"; - print $SIGMA =~ /[$Sigma]/i ? "ok 805\n" : "not ok 805\n"; - print $SIGMA =~ /[$sigma]/i ? "ok 806\n" : "not ok 806\n"; + local $Message = "Folding 'GREEK LETTER ALPHA WITH VRACHY'"; - print $Sigma =~ /[$SIGMA]/i ? "ok 807\n" : "not ok 807\n"; - print $Sigma =~ /[$Sigma]/i ? "ok 808\n" : "not ok 808\n"; - print $Sigma =~ /[$sigma]/i ? "ok 809\n" : "not ok 809\n"; + $lower = "\N{GREEK CAPITAL LETTER ALPHA WITH VRACHY}"; + $UPPER = "\N{GREEK SMALL LETTER ALPHA WITH VRACHY}"; - print $sigma =~ /[$SIGMA]/i ? "ok 810\n" : "not ok 810\n"; - print $sigma =~ /[$Sigma]/i ? "ok 811\n" : "not ok 811\n"; - print $sigma =~ /[$sigma]/i ? "ok 812\n" : "not ok 812\n"; -} + ok $lower =~ m/$UPPER/i; + ok $UPPER =~ m/$lower/i; + ok $lower =~ m/[$UPPER]/i; + ok $UPPER =~ m/[$lower]/i; -{ - print "# parlez-vous?\n"; - - use charnames ':full'; - - print "fran\N{LATIN SMALL LETTER C}ais" =~ - /fran.ais/ && - $& eq "francais" ? - "ok 813\n" : "not ok 813\n"; - - print "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ - /fran.ais/ && - $& eq "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" ? - "ok 814\n" : "not ok 814\n"; - - print "fran\N{LATIN SMALL LETTER C}ais" =~ - /fran\Cais/ && - $& eq "francais" ? - "ok 815\n" : "not ok 815\n"; - - print "franc\N{COMBINING CEDILLA}ais" =~ - /franc\C\Cais/ ? # COMBINING CEDILLA is two bytes when encoded - "ok 816\n" : "not ok 816\n"; - - print "fran\N{LATIN SMALL LETTER C}ais" =~ - /fran\Xais/ && - $& eq "francais" ? - "ok 817\n" : "not ok 817\n"; - - print "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ - /fran\Xais/ && - $& eq "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" ? - "ok 818\n" : "not ok 818\n"; - - print "franc\N{COMBINING CEDILLA}ais" =~ - /fran\Xais/ && - $& eq "franc\N{COMBINING CEDILLA}ais" ? - "ok 819\n" : "not ok 819\n"; - - print "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ - /fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais/ && - $& eq "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" ? - "ok 820\n" : "not ok 820\n"; - - print "franc\N{COMBINING CEDILLA}ais" =~ - /franc\N{COMBINING CEDILLA}ais/ && - $& eq "franc\N{COMBINING CEDILLA}ais" ? - "ok 821\n" : "not ok 821\n"; - - print "fran\N{LATIN SMALL LETTER C}ais" =~ - /fran(?:c\N{COMBINING CEDILLA}?|\N{LATIN SMALL LETTER C WITH CEDILLA})ais/ && - $& eq "francais" ? - "ok 822\n" : "not ok 822\n"; - - print "fran\N{LATIN SMALL LETTER C}ais" =~ - /fran(?:c\N{COMBINING CEDILLA}?|\N{LATIN SMALL LETTER C WITH CEDILLA})ais/ && - $& eq "francais" ? - "ok 823\n" : "not ok 823\n"; - - print "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ - /fran(?:c\N{COMBINING CEDILLA}?|\N{LATIN SMALL LETTER C WITH CEDILLA})ais/ && - $& eq "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" ? - "ok 824\n" : "not ok 824\n"; - - print "franc\N{COMBINING CEDILLA}ais" =~ - /fran(?:c\N{COMBINING CEDILLA}?|\N{LATIN SMALL LETTER C WITH CEDILLA})ais/ && - $& eq "franc\N{COMBINING CEDILLA}ais" ? - "ok 825\n" : "not ok 825\n"; -} + local $Message = "Folding 'LATIN LETTER Y WITH DIAERESIS'"; -{ - print "# Does lingering (and useless) UTF8 flag mess up /i matching?\n"; + $lower = "\N{LATIN SMALL LETTER Y WITH DIAERESIS}"; + $UPPER = "\N{LATIN CAPITAL LETTER Y WITH DIAERESIS}"; - { - my $regex = "ABcde"; - my $string = "abcDE\x{100}"; - chop($string); - if ($string =~ m/$regex/i) { - print "ok 826\n"; - } else { - print "not ok 826\n"; - } + ok $lower =~ m/$UPPER/i; + ok $UPPER =~ m/$lower/i; + ok $lower =~ m/[$UPPER]/i; + ok $UPPER =~ m/[$lower]/i; } - { - my $regex = "ABcde\x{100}"; - my $string = "abcDE"; - chop($regex); - if ($string =~ m/$regex/i) { - print "ok 827\n"; - } else { - print "not ok 827\n"; - } - } { - my $regex = "ABcde\x{100}"; - my $string = "abcDE\x{100}"; - chop($regex); - chop($string); - if ($string =~ m/$regex/i) { - print "ok 828\n"; - } else { - print "not ok 828\n"; - } - } -} - -{ - print "# more SIGMAs\n"; - - my $SIGMA = "\x{03A3}"; # CAPITAL - my $Sigma = "\x{03C2}"; # SMALL FINAL - my $sigma = "\x{03C3}"; # SMALL - - my $S3 = "$SIGMA$Sigma$sigma"; + use charnames ':full'; + local $PatchId = "13843"; + local $Message = "GREEK CAPITAL LETTER SIGMA vs " . + "COMBINING GREEK PERISPOMENI"; - print ":$S3:" =~ /:(($SIGMA)+):/i && $1 eq $S3 && $2 eq $sigma ? - "ok 829\n" : "not ok 829\n"; - print ":$S3:" =~ /:(($Sigma)+):/i && $1 eq $S3 && $2 eq $sigma ? - "ok 830\n" : "not ok 830\n"; - print ":$S3:" =~ /:(($sigma)+):/i && $1 eq $S3 && $2 eq $sigma ? - "ok 831\n" : "not ok 831\n"; + my $SIGMA = "\N{GREEK CAPITAL LETTER SIGMA}"; + my $char = "\N{COMBINING GREEK PERISPOMENI}"; - print ":$S3:" =~ /:(([$SIGMA])+):/i && $1 eq $S3 && $2 eq $sigma ? - "ok 832\n" : "not ok 832\n"; - print ":$S3:" =~ /:(([$Sigma])+):/i && $1 eq $S3 && $2 eq $sigma ? - "ok 833\n" : "not ok 833\n"; - print ":$S3:" =~ /:(([$sigma])+):/i && $1 eq $S3 && $2 eq $sigma ? - "ok 834\n" : "not ok 834\n"; -} + may_not_warn sub {ok "_:$char:_" !~ m/_:$SIGMA:_/i}; + } -{ - print "# LATIN SMALL LETTER SHARP S\n"; - use charnames ':full'; + { + local $Message = '\X'; + use charnames ':full'; + + ok "a!" =~ /^(\X)!/ && $1 eq "a"; + ok "\xDF!" =~ /^(\X)!/ && $1 eq "\xDF"; + ok "\x{100}!" =~ /^(\X)!/ && $1 eq "\x{100}"; + ok "\x{100}\x{300}!" =~ /^(\X)!/ && $1 eq "\x{100}\x{300}"; + ok "\N{LATIN CAPITAL LETTER E}!" =~ /^(\X)!/ && + $1 eq "\N{LATIN CAPITAL LETTER E}"; + ok "\N{LATIN CAPITAL LETTER E}\N{COMBINING GRAVE ACCENT}!" + =~ /^(\X)!/ && + $1 eq "\N{LATIN CAPITAL LETTER E}\N{COMBINING GRAVE ACCENT}"; + + local $Message = '\C and \X'; + ok "!abc!" =~ /a\Cc/; + ok "!abc!" =~ /a\Xc/; + } - $test= 835; - ok("\N{LATIN SMALL LETTER SHARP S}" =~ /\N{LATIN SMALL LETTER SHARP S}/); - ok("\N{LATIN SMALL LETTER SHARP S}" =~ /\N{LATIN SMALL LETTER SHARP S}/i); + { + local $Message = "Final Sigma"; - ok("\N{LATIN SMALL LETTER SHARP S}" =~ /[\N{LATIN SMALL LETTER SHARP S}]/); - ok("\N{LATIN SMALL LETTER SHARP S}" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i); + my $SIGMA = "\x{03A3}"; # CAPITAL + my $Sigma = "\x{03C2}"; # SMALL FINAL + my $sigma = "\x{03C3}"; # SMALL - ok("ss" =~ /\N{LATIN SMALL LETTER SHARP S}/i); - ok("SS" =~ /\N{LATIN SMALL LETTER SHARP S}/i); - ok("ss" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i); - ok("SS" =~ /[\N{LATIN SMALL LETTER SHARP S}]/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); -} + ok $Sigma =~ /$SIGMA/i; + ok $Sigma =~ /$Sigma/i; + ok $Sigma =~ /$sigma/i; -{ - print "# more whitespace: U+0085, U+2028, U+2029\n"; + ok $sigma =~ /$SIGMA/i; + ok $sigma =~ /$Sigma/i; + ok $sigma =~ /$sigma/i; + + ok $SIGMA =~ /[$SIGMA]/i; + ok $SIGMA =~ /[$Sigma]/i; + ok $SIGMA =~ /[$sigma]/i; - # U+0085 needs to be forced to be Unicode, the \x{100} does that. - if ($ordA == 193) { - print "<\x{100}\x{0085}>" =~ /<\x{100}e>/ ? "ok 845\n" : "not ok 845\n"; - } else { - print "<\x{100}\x{0085}>" =~ /<\x{100}\s>/ ? "ok 845\n" : "not ok 845\n"; - } - print "<\x{2028}>" =~ /<\s>/ ? "ok 846\n" : "not ok 846\n"; - print "<\x{2029}>" =~ /<\s>/ ? "ok 847\n" : "not ok 847\n"; -} + ok $Sigma =~ /[$SIGMA]/i; + ok $Sigma =~ /[$Sigma]/i; + ok $Sigma =~ /[$sigma]/i; -{ - print "# . with /s should work on characters, as opposed to bytes\n"; + ok $sigma =~ /[$SIGMA]/i; + ok $sigma =~ /[$Sigma]/i; + ok $sigma =~ /[$sigma]/i; - my $s = "\x{e4}\x{100}"; + local $Message = "More final Sigma"; - # This is not expected to match: the point is that - # neither should we get "Malformed UTF-8" warnings. - print $s =~ /\G(.+?)\n/gcs ? - "not ok 848\n" : "ok 848\n"; + my $S3 = "$SIGMA$Sigma$sigma"; - my @c; + ok ":$S3:" =~ /:(($SIGMA)+):/i && $1 eq $S3 && $2 eq $sigma; + ok ":$S3:" =~ /:(($Sigma)+):/i && $1 eq $S3 && $2 eq $sigma; + ok ":$S3:" =~ /:(($sigma)+):/i && $1 eq $S3 && $2 eq $sigma; - while ($s =~ /\G(.)/gs) { - push @c, $1; + ok ":$S3:" =~ /:(([$SIGMA])+):/i && $1 eq $S3 && $2 eq $sigma; + ok ":$S3:" =~ /:(([$Sigma])+):/i && $1 eq $S3 && $2 eq $sigma; + ok ":$S3:" =~ /:(([$sigma])+):/i && $1 eq $S3 && $2 eq $sigma; } - print join("", @c) eq $s ? "ok 849\n" : "not ok 849\n"; - - my $t1 = "Q003\n\n\x{e4}\x{f6}\n\nQ004\n\n\x{e7}"; # test only chars < 256 - my $r1 = ""; - while ($t1 =~ / \G ( .+? ) \n\s+ ( .+? ) ( $ | \n\s+ ) /xgcs) { - $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; + { + use charnames ':full'; + local $Message = "Parlez-Vous " . + "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais?"; + + ok "Fran\N{LATIN SMALL LETTER C}ais" =~ /Fran.ais/ && + $& eq "Francais"; + ok "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ /Fran.ais/ && + $& eq "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais"; + ok "Fran\N{LATIN SMALL LETTER C}ais" =~ /Fran\Cais/ && + $& eq "Francais"; + # COMBINING CEDILLA is two bytes when encoded + ok "Franc\N{COMBINING CEDILLA}ais" =~ /Franc\C\Cais/; + ok "Fran\N{LATIN SMALL LETTER C}ais" =~ /Fran\Xais/ && + $& eq "Francais"; + ok "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ /Fran\Xais/ && + $& eq "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais"; + ok "Franc\N{COMBINING CEDILLA}ais" =~ /Fran\Xais/ && + $& eq "Franc\N{COMBINING CEDILLA}ais"; + ok "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ + /Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais/ && + $& eq "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais"; + ok "Franc\N{COMBINING CEDILLA}ais" =~ /Franc\N{COMBINING CEDILLA}ais/ && + $& eq "Franc\N{COMBINING CEDILLA}ais"; + + my @f = ( + ["Fran\N{LATIN SMALL LETTER C}ais", "Francais"], + ["Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais", + "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais"], + ["Franc\N{COMBINING CEDILLA}ais", "Franc\N{COMBINING CEDILLA}ais"], + ); + foreach my $entry (@f) { + my ($subject, $match) = @$entry; + ok $subject =~ /Fran(?:c\N{COMBINING CEDILLA}?| + \N{LATIN SMALL LETTER C WITH CEDILLA})ais/x && + $& eq $match; + } } - $r2 =~ s/\x{100}//; - print $r1 eq $r2 ? "ok 850\n" : "not ok 850\n"; -} -{ - print "# Unicode lookbehind\n"; - - print "A\x{100}B" =~ /(?<=A.)B/ ? "ok 851\n" : "not ok 851\n"; - print "A\x{200}\x{300}B" =~ /(?<=A..)B/ ? "ok 852\n" : "not ok 852\n"; - print "\x{400}AB" =~ /(?<=\x{400}.)B/ ? "ok 853\n" : "not ok 853\n"; - print "\x{500\x{600}}B" =~ /(?<=\x{500}.)B/ ? "ok 854\n" : "not ok 854\n"; -} -{ - print "# UTF-8 hash keys and /\$/\n"; - # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2002-01/msg01327.html - - my $u = "a\x{100}"; - my $v = substr($u,0,1); - my $w = substr($u,1,1); - my %u = ( $u => $u, $v => $v, $w => $w ); - my $i = 855; - for (keys %u) { - my $m1 = /^\w*$/ ? 1 : 0; - my $m2 = $u{$_}=~/^\w*$/ ? 1 : 0; - print $m1 == $m2 ? "ok $i\n" : "not ok $i # $m1 $m2\n"; - $i++; + { + local $Message = "Lingering (and useless) UTF8 flag doesn't mess up /i"; + my $pat = "ABcde"; + my $str = "abcDE\x{100}"; + chop $str; + ok $str =~ /$pat/i; + + $pat = "ABcde\x{100}"; + $str = "abcDE"; + chop $pat; + ok $str =~ /$pat/i; + + $pat = "ABcde\x{100}"; + $str = "abcDE\x{100}"; + chop $pat; + chop $str; + ok $str =~ /$pat/i; } -} -{ - print "# [ID 20020124.005]\n"; - # Fixed by #14795. - my $i = 858; - for my $char ("a", "\x{df}", "\x{100}"){ - $x = "$char b $char"; - $x =~ s{($char)}{ - "c" =~ /c/; - "x"; - }ge; - print substr($x,0,1) eq substr($x,-1,1) ? - "ok $i\n" : "not ok $i # debug: $x\n"; - $i++; - } -} -{ - print "# SEGV in s/// and UTF-8\n"; - $s = "s#\x{100}" x 4; - $s =~ s/[^\w]/ /g; - if ($ENV{REAL_POSIX_CC}) { - print $s eq "s " x 4 ? "ok 861\n" : "not ok 861\n"; - } else { - print $s eq "s \x{100}" x 4 ? "ok 861\n" : "not ok 861\n"; + { + use charnames ':full'; + local $Message = "LATIN SMALL LETTER SHARP S " . + "(\N{LATIN SMALL LETTER SHARP S})"; + + ok "\N{LATIN SMALL LETTER SHARP S}" =~ + /\N{LATIN SMALL LETTER SHARP S}/; + ok "\N{LATIN SMALL LETTER SHARP S}" =~ + /\N{LATIN SMALL LETTER SHARP S}/i; + ok "\N{LATIN SMALL LETTER SHARP S}" =~ + /[\N{LATIN SMALL LETTER SHARP S}]/; + ok "\N{LATIN SMALL LETTER SHARP S}" =~ + /[\N{LATIN SMALL LETTER SHARP S}]/i; + + ok "ss" =~ /\N{LATIN SMALL LETTER SHARP S}/i; + ok "SS" =~ /\N{LATIN SMALL LETTER SHARP S}/i; + ok "ss" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i; + ok "SS" =~ /[\N{LATIN SMALL LETTER SHARP S}]/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; + ok "\N{LATIN SMALL LETTER SHARP S}" =~ + /[\N{LATIN SMALL LETTER SHARP S}x]/; + ok "\N{LATIN SMALL LETTER SHARP S}" =~ + /[\N{LATIN SMALL LETTER SHARP S}x]/i; } -} -{ - print "# UTF-8 bug (maybe alreayd known?)\n"; - my $u; - $u = "foo"; - $u =~ s/./\x{100}/g; - print $u eq "\x{100}\x{100}\x{100}" ? "ok 862\n" : "not ok 862\n"; + { + # More whitespace: U+0085, U+2028, U+2029\n"; + + # U+0085, U+00A0 need to be forced to be Unicode, the \x{100} does that. + SKIP: { + skip "EBCDIC platform", 4 if $IS_EBCDIC; + # Do \x{0015} and \x{0041} match \s in EBCDIC? + ok "<\x{100}\x{0085}>" =~ /<\x{100}\s>/, '\x{0085} in \s'; + ok "<\x{0085}>" =~ /<\v>/, '\x{0085} in \v'; + ok "<\x{100}\x{00A0}>" =~ /<\x{100}\s>/, '\x{00A0} in \s'; + ok "<\x{00A0}>" =~ /<\h>/, '\x{00A0} in \h'; + } + my @h = map {sprintf "%05x" => $_} 0x01680, 0x0180E, 0x02000 .. 0x0200A, + 0x0202F, 0x0205F, 0x03000; + my @v = map {sprintf "%05x" => $_} 0x02028, 0x02029; + + my @H = map {sprintf "%05x" => $_} 0x01361, 0x0200B, 0x02408, 0x02420, + 0x0303F, 0xE0020; + my @V = map {sprintf "%05x" => $_} 0x0008A .. 0x0008D, 0x00348, 0x10100, + 0xE005F, 0xE007C; + + for my $hex (@h) { + my $str = eval qq ["<\\x{$hex}>"]; + ok $str =~ /<\s>/, "\\x{$hex} in \\s"; + ok $str =~ /<\h>/, "\\x{$hex} in \\h"; + ok $str !~ /<\v>/, "\\x{$hex} not in \\v"; + } - $u = "foobar"; - $u =~ s/[ao]/\x{100}/g; - print $u eq "f\x{100}\x{100}b\x{100}r" ? "ok 863\n" : "not ok 863\n"; + for my $hex (@v) { + my $str = eval qq ["<\\x{$hex}>"]; + ok $str =~ /<\s>/, "\\x{$hex} in \\s"; + ok $str =~ /<\v>/, "\\x{$hex} in \\v"; + ok $str !~ /<\h>/, "\\x{$hex} not in \\h"; + } - $u =~ s/\x{100}/e/g; - print $u eq "feeber" ? "ok 864\n" : "not ok 864\n"; -} + for my $hex (@H) { + my $str = eval qq ["<\\x{$hex}>"]; + ok $str =~ /<\S>/, "\\x{$hex} in \\S"; + ok $str =~ /<\H>/, "\\x{$hex} in \\H"; + } -{ - print "# UTF-8 bug with s///\n"; - # check utf8/non-utf8 mixtures - # try to force all float/anchored check combinations - my $c = "\x{100}"; - $test = 865; - my $subst; - for my $re ( - "xx.*$c", "x.*$c$c", "$c.*xx", "$c$c.*x", "xx.*(?=$c)", "(?=$c).*xx", - ) { - print "xxx" =~ /$re/ ? "not ok $test\n" : "ok $test\n"; - ++$test; - print +($subst = "xxx") =~ s/$re// ? "not ok $test\n" : "ok $test\n"; - ++$test; - } - for my $re ("xx.*$c*", "$c*.*xx") { - print "xxx" =~ /$re/ ? "ok $test\n" : "not ok $test\n"; - ++$test; - ($subst = "xxx") =~ s/$re//; - print $subst eq '' ? "ok $test\n" : "not ok $test\t# $subst\n"; - ++$test; - } - for my $re ("xxy*", "y*xx") { - print "xx$c" =~ /$re/ ? "ok $test\n" : "not ok $test\n"; - ++$test; - ($subst = "xx$c") =~ s/$re//; - print $subst eq $c ? "ok $test\n" : "not ok $test\n"; - ++$test; - print "xy$c" =~ /$re/ ? "not ok $test\n" : "ok $test\n"; - ++$test; - print +($subst = "xy$c") =~ /$re/ ? "not ok $test\n" : "ok $test\n"; - ++$test; - } - for my $re ("xy$c*z", "x$c*yz") { - print "xyz" =~ /$re/ ? "ok $test\n" : "not ok $test\n"; - ++$test; - ($subst = "xyz") =~ s/$re//; - print $subst eq '' ? "ok $test\n" : "not ok $test\n"; - ++$test; + for my $hex (@V) { + my $str = eval qq ["<\\x{$hex}>"]; + ok $str =~ /<\S>/, "\\x{$hex} in \\S"; + ok $str =~ /<\V>/, "\\x{$hex} in \\V"; + } } -} - -{ - print "# qr/.../x\n"; - $test = 893; - my $R = qr/ A B C # D E/x; - print eval {"ABCDE" =~ $R} ? "ok $test\n" : "not ok $test\n"; - $test++; + { + # . with /s should work on characters, as opposed to bytes + local $Message = ". with /s works on characters, not bytes"; - print eval {"ABCDE" =~ m/$R/} ? "ok $test\n" : "not ok $test\n"; - $test++; + my $s = "\x{e4}\x{100}"; + # This is not expected to match: the point is that + # neither should we get "Malformed UTF-8" warnings. + may_not_warn sub {$s =~ /\G(.+?)\n/gcs}, "No 'Malformed UTF-8' warning"; - print eval {"ABCDE" =~ m/($R)/} ? "ok $test\n" : "not ok $test\n"; - $test++; -} + my @c; + push @c => $1 while $s =~ /\G(.)/gs; -{ - print "# illegal Unicode properties\n"; - $test = 896; + local $" = ""; + iseq "@c", $s; - print eval { "a" =~ /\pq / } ? "not ok $test\n" : "ok $test\n"; - $test++; + # Test only chars < 256 + 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; + } - print eval { "a" =~ /\p{qrst} / } ? "not ok $test\n" : "ok $test\n"; - $test++; -} + my $t2 = $t1 . "\x{100}"; # Repeat with a larger char + my $r2 = ""; + while ($t2 =~ / \G ( .+? ) \n\s+ ( .+? ) ( $ | \n\s+ ) /xgcs) { + $r2 .= $1 . $2; + } + $r2 =~ s/\x{100}//; -{ - print "# [ID 20020412.005] wrong pmop flags checked when empty pattern\n"; - # requires reuse of last successful pattern - $test = 898; - $test =~ /\d/; - for (0 .. 1) { - my $match = ?? + 0; - if ($match != $_) { - print "ok $test\n"; - } else { - printf "not ok %s\t# 'match once' %s on %s iteration\n", $test, - $match ? 'succeeded' : 'failed', $_ ? 'second' : 'first'; - } - ++$test; - } - $test =~ /(\d)/; - my $result = join '', $test =~ //g; - if ($result eq $test) { - print "ok $test\n"; - } else { - printf "not ok %s\t# expected '%s', got '%s'\n", $test, $test, $result; - } - ++$test; -} + iseq $r1, $r2; + } -print "# user-defined character properties\n"; -sub InKana1 { - return <<'END'; -3040 309F -30A0 30FF -END -} + { + local $Message = "Unicode lookbehind"; + ok "A\x{100}B" =~ /(?<=A.)B/; + ok "A\x{200}\x{300}B" =~ /(?<=A..)B/; + ok "\x{400}AB" =~ /(?<=\x{400}.)B/; + ok "\x{500}\x{600}B" =~ /(?<=\x{500}.)B/; + + # Original code also contained: + # ok "\x{500\x{600}}B" =~ /(?<=\x{500}.)B/; + # but that looks like a typo. + } -sub InKana2 { - return <<'END'; -+utf8::InHiragana -+utf8::InKatakana -END -} -sub InKana3 { - return <<'END'; -+utf8::InHiragana -+utf8::InKatakana --utf8::IsCn -END -} + { + local $Message = 'UTF-8 hash keys and /$/'; + # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters + # /2002-01/msg01327.html + + my $u = "a\x{100}"; + my $v = substr ($u, 0, 1); + my $w = substr ($u, 1, 1); + my %u = ($u => $u, $v => $v, $w => $w); + for (keys %u) { + my $m1 = /^\w*$/ ? 1 : 0; + my $m2 = $u {$_} =~ /^\w*$/ ? 1 : 0; + iseq $m1, $m2; + } + } -sub InNotKana { - return <<'END'; -!utf8::InHiragana --utf8::InKatakana -+utf8::IsCn -END -} -$test = 901; + { + local $BugId = "20020124.005"; + local $PatchId = "14795"; + local $Message = "s///eg"; + + for my $char ("a", "\x{df}", "\x{100}") { + my $x = "$char b $char"; + $x =~ s{($char)}{ + "c" =~ /c/; + "x"; + }ge; + iseq substr ($x, 0, 1), substr ($x, -1, 1); + } + } -print "\x{3040}" =~ /\p{InKana1}/ ? "ok $test\n" : "not ok $test\n"; $test++; -print "\x{303F}" =~ /\P{InKana1}/ ? "ok $test\n" : "not ok $test\n"; $test++; -print "\x{3040}" =~ /\p{InKana2}/ ? "ok $test\n" : "not ok $test\n"; $test++; -print "\x{303F}" =~ /\P{InKana2}/ ? "ok $test\n" : "not ok $test\n"; $test++; + { + local $Message = "No SEGV in s/// and UTF-8"; + my $s = "s#\x{100}" x 4; + ok $s =~ s/[^\w]/ /g; + if ($ENV {REAL_POSIX_CC}) { + iseq $s, "s " x 4; + } + else { + iseq $s, "s \x{100}" x 4; + } + } -print "\x{3041}" =~ /\p{InKana3}/ ? "ok $test\n" : "not ok $test\n"; $test++; -print "\x{3040}" =~ /\P{InKana3}/ ? "ok $test\n" : "not ok $test\n"; $test++; -print "\x{3040}" =~ /\p{InNotKana}/ ? "ok $test\n" : "not ok $test\n"; $test++; -print "\x{3041}" =~ /\P{InNotKana}/ ? "ok $test\n" : "not ok $test\n"; $test++; + { + local $Message = "UTF-8 bug (maybe already known?)"; + my $u = "foo"; + $u =~ s/./\x{100}/g; + iseq $u, "\x{100}\x{100}\x{100}"; -sub InConsonant { # Not EBCDIC-aware. - return < fail\n"; - ++$test; - print +(!$r or pos($s) == $len + 1) ? "ok $test\n" - : "not ok $test\t# <$type x $len> pos @{[ pos($s) ]}\n"; - ++$test; - } + $u =~ s/\x{100}/e/g; + iseq $u, "feeber"; } -} -$test = 923; -$a = bless qr/foo/, 'Foo'; -print(('goodfood' =~ $a ? '' : 'not '), - "ok $test\t# reblessed qr// matches\n"); -++$test; + { + local $Message = "UTF-8 bug with s///"; + # check utf8/non-utf8 mixtures + # try to force all float/anchored check combinations + + my $c = "\x{100}"; + my $subst; + for my $re ("xx.*$c", "x.*$c$c", "$c.*xx", "$c$c.*x", + "xx.*(?=$c)", "(?=$c).*xx",) { + ok "xxx" !~ /$re/; + ok +($subst = "xxx") !~ s/$re//; + } + for my $re ("xx.*$c*", "$c*.*xx") { + ok "xxx" =~ /$re/; + ok +($subst = "xxx") =~ s/$re//; + iseq $subst, ""; + } + for my $re ("xxy*", "y*xx") { + ok "xx$c" =~ /$re/; + ok +($subst = "xx$c") =~ s/$re//; + iseq $subst, $c; + ok "xy$c" !~ /$re/; + ok +($subst = "xy$c") !~ s/$re//; + } + for my $re ("xy$c*z", "x$c*yz") { + ok "xyz" =~ /$re/; + ok +($subst = "xyz") =~ s/$re//; + iseq $subst, ""; + } + } -print(($a eq '(?-xism:foo)' ? '' : 'not '), - "ok $test\t# reblessed qr// stringizes\n"); -++$test; -$x = "\x{3fe}"; -$z=$y = "\317\276"; # $y is byte representation of $x + { + local $Message = "qr /.../x"; + my $R = qr / A B C # D E/x; + ok "ABCDE" =~ $R && $& eq "ABC"; + ok "ABCDE" =~ /$R/ && $& eq "ABC"; + ok "ABCDE" =~ m/$R/ && $& eq "ABC"; + ok "ABCDE" =~ /($R)/ && $1 eq "ABC"; + ok "ABCDE" =~ m/($R)/ && $1 eq "ABC"; + } -$a = qr/$x/; -print(($x =~ $a ? '' : 'not '), "ok $test - utf8 interpolation in qr//\n"); -++$test; -print(("a$a" =~ $x ? '' : 'not '), - "ok $test - stringifed qr// preserves utf8\n"); -++$test; + { + local $BugId = "20020412.005"; + local $Message = "Correct pmop flags checked when empty pattern"; + + # Requires reuse of last successful pattern. + my $num = 123; + $num =~ /\d/; + for (0 .. 1) { + my $match = ?? + 0; + ok $match != $_, $Message, + sprintf "'match one' %s on %s iteration" => + $match ? 'succeeded' : 'failed', + $_ ? 'second' : 'first'; + } + $num =~ /(\d)/; + my $result = join "" => $num =~ //g; + iseq $result, $num; + } -print(("a$x" =~ /^a$a\z/ ? '' : 'not '), - "ok $test - interpolated qr// preserves utf8\n"); -++$test; -print(("a$x" =~ /^a(??{$a})\z/ ? '' : 'not '), - "ok $test - postponed interpolation of qr// preserves utf8\n"); -++$test; + { + local $BugId = '20020630.002'; + local $Message = 'UTF-8 regex matches above 32k'; + for (['byte', "\x{ff}"], ['utf8', "\x{1ff}"]) { + my ($type, $char) = @$_; + for my $len (32000, 32768, 33000) { + my $s = $char . "f" x $len; + my $r = $s =~ /$char([f]*)/gc; + ok $r, $Message, "<$type x $len>"; + ok !$r || pos ($s) == $len + 1, $Message, + "<$type x $len>; pos = @{[pos $s]}"; + } + } + } -print((length(qr/##/x) == 12 ? '' : 'not '), - "ok $test - ## in qr// doesn't corrupt memory [perl #17776]\n"); -++$test; -{ use re 'eval'; + { + 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"; + } + } -print(("$x$x" =~ /^$x(??{$x})\z/ ? '' : 'not '), - "ok $test - postponed utf8 string in utf8 re matches utf8\n"); -++$test; -print(("$y$x" =~ /^$y(??{$x})\z/ ? '' : 'not '), - "ok $test - postponed utf8 string in non-utf8 re matches utf8\n"); -++$test; + { + local $PatchId = '18179'; + my $s = "\x{100}" x 5; + my $ok = $s =~ /(\x{100}{4})/; + my ($ord, $len) = (ord $1, length $1); + ok $ok && $ord == 0x100 && $len == 4, "No panic: end_shift"; + } -print(("$y$x" !~ /^$y(??{$y})\z/ ? '' : 'not '), - "ok $test - postponed non-utf8 string in non-utf8 re doesn't match utf8\n"); -++$test; -print(("$x$x" !~ /^$x(??{$y})\z/ ? '' : 'not '), - "ok $test - postponed non-utf8 string in utf8 re doesn't match utf8\n"); -++$test; + { + local $BugId = '15763'; + our $a = "x\x{100}"; + chop $a; # Leaves the UTF-8 flag + $a .= "y"; # 1 byte before 'y'. -print(("$y$y" =~ /^$y(??{$y})\z/ ? '' : 'not '), - "ok $test - postponed non-utf8 string in non-utf8 re matches non-utf8\n"); -++$test; + ok $a =~ /^\C/, 'match one \C on 1-byte UTF-8'; + ok $a =~ /^\C{1}/, 'match \C{1}'; -print(("$x$y" =~ /^$x(??{$y})\z/ ? '' : 'not '), - "ok $test - postponed non-utf8 string in utf8 re matches non-utf8\n"); -++$test; -$y = $z; # reset $y after upgrade + ok $a =~ /^\Cy/, 'match \Cy'; + ok $a =~ /^\C{1}y/, 'match \C{1}y'; -print(("$x$y" !~ /^$x(??{$x})\z/ ? '' : 'not '), - "ok $test - postponed utf8 string in utf8 re doesn't match non-utf8\n"); -++$test; -$y = $z; # reset $y after upgrade + ok $a !~ /^\C\Cy/, q {don't match two \Cy}; + ok $a !~ /^\C{2}y/, q {don't match \C{2}y}; -print(("$y$y" !~ /^$y(??{$x})\z/ ? '' : 'not '), - "ok $test - postponed utf8 string in non-utf8 re doesn't match non-utf8\n"); -++$test; + $a = "\x{100}y"; # 2 bytes before "y" -} # no re 'eval' + ok $a =~ /^\C/, 'match one \C on 2-byte UTF-8'; + ok $a =~ /^\C{1}/, 'match \C{1}'; + ok $a =~ /^\C\C/, 'match two \C'; + ok $a =~ /^\C{2}/, 'match \C{2}'; -print "# more user-defined character properties\n"; + ok $a =~ /^\C\C\C/, 'match three \C on 2-byte UTF-8 and a byte'; + ok $a =~ /^\C{3}/, 'match \C{3}'; -sub IsSyriac1 { - return <<'END'; -0712 072C -0730 074A -END -} + ok $a =~ /^\C\Cy/, 'match two \C'; + ok $a =~ /^\C{2}y/, 'match \C{2}'; -ok("\x{0712}" =~ /\p{IsSyriac1}/, '\x{0712}, \p{IsSyriac1}'); -ok("\x{072F}" =~ /\P{IsSyriac1}/, '\x{072F}, \P{IsSyriac1}'); + ok $a !~ /^\C\C\Cy/, q {don't match three \Cy}; + ok $a !~ /^\C{2}\Cy/, q {don't match \C{2}\Cy}; + ok $a !~ /^\C{3}y/, q {don't match \C{3}y}; -sub Syriac1 { - return <<'END'; -0712 072C -0730 074A -END -} + $a = "\x{1000}y"; # 3 bytes before "y" -ok("\x{0712}" =~ /\p{Syriac1}/, '\x{0712}, \p{Syriac1}'); -ok("\x{072F}" =~ /\P{Syriac1}/, '\x{072F}, \p{Syriac1}'); + ok $a =~ /^\C/, 'match one \C on three-byte UTF-8'; + ok $a =~ /^\C{1}/, 'match \C{1}'; + ok $a =~ /^\C\C/, 'match two \C'; + ok $a =~ /^\C{2}/, 'match \C{2}'; + ok $a =~ /^\C\C\C/, 'match three \C'; + ok $a =~ /^\C{3}/, 'match \C{3}'; -print "# user-defined character properties may lack \\n at the end\n"; -sub InGreekSmall { return "03B1\t03C9" } -sub InGreekCapital { return "0391\t03A9\n-03A2" } + ok $a =~ /^\C\C\C\C/, 'match four \C on three-byte UTF-8 and a byte'; + ok $a =~ /^\C{4}/, 'match \C{4}'; -ok("\x{03C0}" =~ /\p{InGreekSmall}/, "Small pi"); -ok("\x{03C2}" =~ /\p{InGreekSmall}/, "Final sigma"); -ok("\x{03A0}" =~ /\p{InGreekCapital}/, "Capital PI"); -ok("\x{03A2}" =~ /\P{InGreekCapital}/, "Reserved"); + ok $a =~ /^\C\C\Cy/, 'match three \Cy'; + ok $a =~ /^\C{3}y/, 'match \C{3}y'; -sub AsciiHexAndDash { - return <<'END'; -+utf8::ASCII_Hex_Digit -+utf8::Dash -END -} + ok $a !~ /^\C\C\C\Cy/, q {don't match four \Cy}; + ok $a !~ /^\C{4}y/, q {don't match \C{4}y}; + } -ok("-" =~ /\p{Dash}/, "'-' is Dash"); -ok("A" =~ /\p{ASCII_Hex_Digit}/, "'A' is ASCII_Hex_Digit"); -ok("-" =~ /\p{AsciiHexAndDash}/, "'-' is AsciiHexAndDash"); -ok("A" =~ /\p{AsciiHexAndDash}/, "'A' is AsciiHexAndDash"); - -{ - print "# Change #18179\n"; - # previously failed with "panic: end_shift - my $s = "\x{100}" x 5; - my $ok = $s =~ /(\x{100}{4})/; - my($ord, $len) = (ord $1, length $1); - print +($ok && $ord == 0x100 && $len == 4) - ? "ok $test\n" : "not ok $test\t# [#18179] $ok/$ord/$len\n"; - ++$test; -} + + { + local $\; + $_ = 'aaaaaaaaaa'; + utf8::upgrade($_); chop $_; $\="\n"; + ok /[^\s]+/, 'm/[^\s]/ utf8'; + ok /[^\d]+/, 'm/[^\d]/ utf8'; + ok +($a = $_, $_ =~ s/[^\s]+/./g), 's/[^\s]/ utf8'; + ok +($a = $_, $a =~ s/[^\d]+/./g), 's/[^\s]/ utf8'; + } -{ - print "# [perl #15763]\n"; - $a = "x\x{100}"; - chop $a; # but leaves the UTF-8 flag - $a .= "y"; # 1 byte before "y" + { + local $BugId = '15397'; + local $Message = 'UTF-8 matching'; + ok "\x{100}" =~ /\x{100}/; + ok "\x{100}" =~ /(\x{100})/; + ok "\x{100}" =~ /(\x{100}){1}/; + ok "\x{100}\x{100}" =~ /(\x{100}){2}/; + ok "\x{100}\x{100}" =~ /(\x{100})(\x{100})/; + } - ok($a =~ /^\C/, 'match one \C on 1-byte UTF-8'); - ok($a =~ /^\C{1}/, 'match \C{1}'); - ok($a =~ /^\Cy/, 'match \Cy'); - ok($a =~ /^\C{1}y/, 'match \C{1}y'); + { + local $BugId = '7471'; + local $Message = 'Neither ()* nor ()*? sets $1 when matched 0 times'; + local $_ = 'CD'; + ok /(AB)*?CD/ && !defined $1; + ok /(AB)*CD/ && !defined $1; + } - $a = "\x{100}y"; # 2 bytes before "y" - ok($a =~ /^\C/, 'match one \C on 2-byte UTF-8'); - ok($a =~ /^\C{1}/, 'match \C{1}'); - ok($a =~ /^\C\C/, 'match two \C'); - ok($a =~ /^\C{2}/, 'match \C{2}'); + { + local $BugId = '3547'; + local $Message = "Caching shouldn't prevent match"; + my $pattern = "^(b+?|a){1,2}c"; + ok "bac" =~ /$pattern/ && $1 eq 'a'; + ok "bbac" =~ /$pattern/ && $1 eq 'a'; + ok "bbbac" =~ /$pattern/ && $1 eq 'a'; + ok "bbbbac" =~ /$pattern/ && $1 eq 'a'; + } - ok($a =~ /^\C\C\C/, 'match three \C on 2-byte UTF-8 and a byte'); - ok($a =~ /^\C{3}/, 'match \C{3}'); - ok($a =~ /^\C\Cy/, 'match two \C'); - ok($a =~ /^\C{2}y/, 'match \C{2}'); - ok($a !~ /^\C\C\Cy/, q{don't match three \Cy}); - ok($a !~ /^\C{2}\Cy/, q{don't match \C{3}y}); + { + local $BugId = '18232'; + local $Message = '$1 should keep UTF-8 ness'; + ok "\x{100}" =~ /(.)/; + iseq $1, "\x{100}", '$1 is UTF-8'; + { 'a' =~ /./; } + iseq $1, "\x{100}", '$1 is still UTF-8'; + isneq $1, "\xC4\x80", '$1 is not non-UTF-8'; + } - $a = "\x{1000}y"; # 3 bytes before "y" - ok($a =~ /^\C/, 'match one \C on three-byte UTF-8'); - ok($a =~ /^\C{1}/, 'match \C{1}'); - ok($a =~ /^\C\C/, 'match two \C'); - ok($a =~ /^\C{2}/, 'match \C{2}'); - ok($a =~ /^\C\C\C/, 'match three \C'); - ok($a =~ /^\C{3}/, 'match \C{3}'); + { + local $BugId = '19767'; + local $Message = "Optimizer doesn't prematurely reject match"; + use utf8; - ok($a =~ /^\C\C\C\C/, 'match four \C on three-byte UTF-8 and a byte'); - ok($a =~ /^\C{4}/, 'match \C{4}'); + my $attr = 'Name-1'; + my $NormalChar = qr /[\p{IsDigit}\p{IsLower}\p{IsUpper}]/; + my $NormalWord = qr /${NormalChar}+?/; + my $PredNameHyphen = qr /^${NormalWord}(\-${NormalWord})*?$/; - ok($a =~ /^\C\C\Cy/, 'match three \Cy'); - ok($a =~ /^\C{3}y/, 'match \C{3}y'); + $attr =~ /^$/; + ok $attr =~ $PredNameHyphen; # Original test. - ok($a !~ /^\C\C\C\C\y/, q{don't match four \Cy}); - ok($a !~ /^\C{4}y/, q{don't match \C{4}y}); -} + "a" =~ m/[b]/; + ok "0" =~ /\p{N}+\z/; # Variant. + } -{ - local $\; - $_ = 'aaaaaaaaaa'; - utf8::upgrade($_); chop $_; $\="\n"; - ok(/[^\s]+/, "m/[^\s]/ utf8"); - ok(/[^\d]+/, "m/[^\d]/ utf8"); - ok(($a = $_, $_ =~ s/[^\s]+/./g), "s/[^\s]/ utf8"); - ok(($a = $_, $a =~ s/[^\d]+/./g), "s/[^\s]/ utf8"); -} -ok("\x{100}" =~ /\x{100}/, "[perl #15397]"); -ok("\x{100}" =~ /(\x{100})/, "[perl #15397]"); -ok("\x{100}" =~ /(\x{100}){1}/, "[perl #15397]"); -ok("\x{100}\x{100}" =~ /(\x{100}){2}/, "[perl #15397]"); -ok("\x{100}\x{100}" =~ /(\x{100})(\x{100})/, "[perl #15397]"); - -$x = "CD"; -$x =~ /(AB)*?CD/; -ok(!defined $1, "[perl #7471]"); - -$x = "CD"; -$x =~ /(AB)*CD/; -ok(!defined $1, "[perl #7471]"); - -$pattern = "^(b+?|a){1,2}c"; -ok("bac" =~ /$pattern/ && $1 eq 'a', "[perl #3547]"); -ok("bbac" =~ /$pattern/ && $1 eq 'a', "[perl #3547]"); -ok("bbbac" =~ /$pattern/ && $1 eq 'a', "[perl #3547]"); -ok("bbbbac" =~ /$pattern/ && $1 eq 'a', "[perl #3547]"); - -{ - # [perl #18232] - "\x{100}" =~ /(.)/; - ok( $1 eq "\x{100}", '$1 is utf-8 [perl #18232]' ); - { 'a' =~ /./; } - ok( $1 eq "\x{100}", '$1 is still utf-8' ); - ok( $1 ne "\xC4\x80", '$1 is not non-utf-8' ); -} + { + local $BugId = '20683'; + local $Message = "(??{ }) doesn't return stale values"; + our $p = 1; + foreach (1, 2, 3, 4) { + $p ++ if /(??{ $p })/ + } + iseq $p, 5; -{ - use utf8; - my $attr = 'Name-1' ; + { + package P; + $a = 1; + sub TIESCALAR {bless []} + sub FETCH {$a ++} + } + tie $p, "P"; + foreach (1, 2, 3, 4) { + /(??{ $p })/ + } + iseq $p, 5; + } - my $NormalChar = qr/[\p{IsDigit}\p{IsLower}\p{IsUpper}]/; - my $NormalWord = qr/${NormalChar}+?/; - my $PredNameHyphen = qr/^${NormalWord}(\-${NormalWord})*?$/; - $attr =~ /^$/; - ok( $attr =~ $PredNameHyphen, "[perl #19767] original test" ); -} + { + # Subject: Odd regexp behavior + # From: Markus Kuhn + # Date: Wed, 26 Feb 2003 16:53:12 +0000 + # Message-Id: + # To: perl-unicode@perl.org -{ - use utf8; - "a" =~ m/[b]/; - ok ( "0" =~ /\p{N}+\z/, "[perl #19767] variant test" ); -} + 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"; -{ + $x = "b\nk"; + ok $x =~ s/(\S)\n(\S)/$1 $2/sg; + ok $x eq "b k"; - $p = 1; - foreach (1,2,3,4) { - $p++ if /(??{ $p })/ - } - iseq ($p, 5, "[perl #20683] (??{ }) returns stale values"); - { package P; $a=1; sub TIESCALAR { bless[] } sub FETCH { $a++ } } - tie $p, P; - foreach (1,2,3,4) { - /(??{ $p })/ + ok "\x{2019}" =~ /\S/; } - iseq ( $p, 5, "(??{ }) returns stale values"); -} - -{ - # Subject: Odd regexp behavior - # From: Markus Kuhn - # Date: Wed, 26 Feb 2003 16:53:12 +0000 - # Message-Id: - # To: perl-unicode@perl.org - - $x = "\x{2019}\nk"; $x =~ s/(\S)\n(\S)/$1 $2/sg; - ok($x eq "\x{2019} k", "Markus Kuhn 2003-02-26"); - $x = "b\nk"; $x =~ s/(\S)\n(\S)/$1 $2/sg; - ok($x eq "b k", "Markus Kuhn 2003-02-26"); - ok("\x{2019}" =~ /\S/, "Markus Kuhn 2003-02-26"); -} + { + local $BugId = '21411'; + local $Message = "(??{ .. }) in split doesn't corrupt its stack"; + our $i; + ok '-1-3-5-' eq join '', split /((??{$i++}))/, '-1-3-5-'; + no warnings 'deprecated', 'syntax'; + split /(?{'WOW'})/, 'abc'; + local $" = "|"; + iseq "@_", "a|b|c"; + } -{ - my $i; - ok('-1-3-5-' eq join('', split /((??{$i++}))/, '-1-3-5-'), - "[perl #21411] (??{ .. }) corrupts split's stack"); - split /(?{'WOW'})/, 'abc'; - ok('a|b|c' eq join ('|', @_), - "[perl #21411] (?{ .. }) version of the above"); -} -{ - # XXX DAPM 13-Apr-06. Recursive split is still broken. It's only luck it - # hasn't been crashing. Disable this test until it is fixed properly. - # XXX also check what it returns rather than just doing ok(1,...) - # split /(?{ split "" })/, "abc"; - ok(1,'cache_re & "(?{": it dumps core in 5.6.1 & 5.8.0'); -} + { + # XXX DAPM 13-Apr-06. Recursive split is still broken. It's only luck it + # hasn't been crashing. Disable this test until it is fixed properly. + # XXX also check what it returns rather than just doing ok(1,...) + # split /(?{ split "" })/, "abc"; + local $TODO = "Recursive split is still broken"; + ok 0, 'cache_re & "(?{": it dumps core in 5.6.1 & 5.8.0'; + } -{ - ok("\x{100}\n" =~ /\x{100}\n$/, "UTF8 length cache and fbm_compile"); -} -{ - package Str; - use overload q/""/ => sub { ${$_[0]}; }; - sub new { my ($c, $v) = @_; bless \$v, $c; } + { + ok "\x{100}\n" =~ /\x{100}\n$/, "UTF-8 length cache and fbm_compile"; + } - package main; - $_ = Str->new("a\x{100}/\x{100}b"); - ok(join(":", /\b(.)\x{100}/g) eq "a:/", "re_intuit_start and PL_bostr"); -} -{ - $_ = "code: 'x' { '...' }\n"; study; - my @x; push @x, $& while m/'[^\']*'/gx; - ok(join(":", @x) eq "'x':'...'", - "[perl #17757] Parse::RecDescent triggers infinite loop"); -} + { + package Str; + use overload q /""/ => sub {${$_ [0]};}; + sub new {my ($c, $v) = @_; bless \$v, $c;} -{ - my $re = qq/^([^X]*)X/; - utf8::upgrade($re); - ok("\x{100}X" =~ /$re/, "S_cl_and ANYOF_UNICODE & ANYOF_INVERTED"); -} + package main; + $_ = Str -> new ("a\x{100}/\x{100}b"); + ok join (":", /\b(.)\x{100}/g) eq "a:/", "re_intuit_start and PL_bostr"; + } -# bug #22354 -sub func ($) { - ok( "a\nb" !~ /^b/, $_[0] ); - ok( "a\nb" =~ /^b/m, "$_[0] - with /m" ); -} -func "standalone"; -$_ = "x"; s/x/func "in subst"/e; -$_ = "x"; s/x/func "in multiline subst"/em; -#$_ = "x"; /x(?{func "in regexp"})/; -#$_ = "x"; /x(?{func "in multiline regexp"})/m; -# bug RT#19049 -$_="abcdef\n"; -@x = m/./g; -ok("abcde" eq "$`", 'RT#19049 - global match not setting $`'); + { + local $BugId = '17757'; + $_ = "code: 'x' { '...' }\n"; study; + my @x; push @x, $& while m/'[^\']*'/gx; + local $" = ":"; + iseq "@x", "'x':'...'", "Parse::RecDescent triggered infinite loop"; + } -ok("123\x{100}" =~ /^.*1.*23\x{100}$/, 'uft8 + multiple floating substr'); -# LATIN SMALL/CAPITAL LETTER A WITH MACRON -ok(" \x{101}" =~ qr/\x{100}/i, - "<20030808193656.5109.1@llama.ni-s.u-net.com>"); + { + my $re = qq /^([^X]*)X/; + utf8::upgrade ($re); + ok "\x{100}X" =~ /$re/, "S_cl_and ANYOF_UNICODE & ANYOF_INVERTED"; + } -# LATIN SMALL/CAPITAL LETTER A WITH RING BELOW -ok(" \x{1E01}" =~ qr/\x{1E00}/i, - "<20030808193656.5109.1@llama.ni-s.u-net.com>"); -# DESERET SMALL/CAPITAL LETTER LONG I -ok(" \x{10428}" =~ qr/\x{10400}/i, - "<20030808193656.5109.1@llama.ni-s.u-net.com>"); + { + local $BugId = '22354'; + sub func ($) { + ok "a\nb" !~ /^b/, "Propagated modifier; $_[0]"; + ok "a\nb" =~ /^b/m, "Propagated modifier; $_[0] - with /m"; + } + func "standalone"; + $_ = "x"; s/x/func "in subst"/e; + $_ = "x"; s/x/func "in multiline subst"/em; + + # + # Next two give 'panic: malloc'. + # Outcommented, using two TODOs. + # + local $TODO = 'panic: malloc'; + local $Message = 'Postponed regexp and propaged modifier'; + # ok 0 for 1 .. 2; + SKIP: { + skip "panic: malloc", 2; + $_ = "x"; /x(?{func "in regexp"})/; + $_ = "x"; /x(?{func "in multiline regexp"})/m; + } + } -# LATIN SMALL/CAPITAL LETTER A WITH RING BELOW + 'X' -ok(" \x{1E01}x" =~ qr/\x{1E00}X/i, - "<20030808193656.5109.1@llama.ni-s.u-net.com>"); -{ - # [perl #23769] Unicode regex broken on simple example - # regrepeat() didn't handle UTF-8 EXACT case right. + { + local $BugId = '19049'; + $_ = "abcdef\n"; + my @x = m/./g; + iseq "abcde", $`, 'Global match sets $`'; + } - my $s = "\x{a0}\x{a0}\x{a0}\x{100}"; chop $s; - ok($s =~ /\x{a0}/, "[perl #23769]"); - ok($s =~ /\x{a0}+/, "[perl #23769]"); - ok($s =~ /\x{a0}\x{a0}/, "[perl #23769]"); + { + ok "123\x{100}" =~ /^.*1.*23\x{100}$/, + 'UTF-8 + multiple floating substr'; + } - ok("aaa\x{100}" =~ /(a+)/, "[perl #23769] easy invariant"); - ok($1 eq "aaa", "[perl #23769]"); - ok("\xa0\xa0\xa0\x{100}" =~ /(\xa0+)/, "[perl #23769] regrepeat invariant"); - ok($1 eq "\xa0\xa0\xa0", "[perl #23769]"); + { + local $Message = '<20030808193656.5109.1@llama.ni-s.u-net.com>'; - ok("ababab\x{100} " =~ /((?:ab)+)/, "[perl #23769] hard invariant"); - ok($1 eq "ababab", "[perl #23769]"); + # LATIN SMALL/CAPITAL LETTER A WITH MACRON + ok " \x{101}" =~ qr/\x{100}/i; - ok("\xa0\xa1\xa0\xa1\xa0\xa1\x{100}" =~ /((?:\xa0\xa1)+)/, "[perl #23769] hard variant"); - ok($1 eq "\xa0\xa1\xa0\xa1\xa0\xa1", "[perl #23769]"); + # LATIN SMALL/CAPITAL LETTER A WITH RING BELOW + ok " \x{1E01}" =~ qr/\x{1E00}/i; - ok("aaa\x{100} " =~ /(a+?)/, "[perl #23769] easy invariant"); - ok($1 eq "a", "[perl #23769]"); + # DESERET SMALL/CAPITAL LETTER LONG I + ok " \x{10428}" =~ qr/\x{10400}/i; - ok("\xa0\xa0\xa0\x{100} " =~ /(\xa0+?)/, "[perl #23769] regrepeat variant"); - ok($1 eq "\xa0", "[perl #23769]"); + # LATIN SMALL/CAPITAL LETTER A WITH RING BELOW + 'X' + ok " \x{1E01}x" =~ qr/\x{1E00}X/i; + } - ok("ababab\x{100} " =~ /((?:ab)+?)/, "[perl #23769] hard invariant"); - ok($1 eq "ab", "[perl #23769]"); - ok("\xa0\xa1\xa0\xa1\xa0\xa1\x{100}" =~ /((?:\xa0\xa1)+?)/, "[perl #23769] hard variant"); - ok($1 eq "\xa0\xa1", "[perl #23769]"); + { + # [perl #23769] Unicode regex broken on simple example + # regrepeat() didn't handle UTF-8 EXACT case right. + local $BugId = '23769'; + my $Mess = 'regrepeat() handles UTF-8 EXACT case right'; + local $Message = $Mess; - ok("\xc4\xc4\xc4" !~ /(\x{100}+)/, "[perl #23769] don't match first byte of utf8 representation"); - ok("\xc4\xc4\xc4" !~ /(\x{100}+?)/, "[perl #23769] don't match first byte of utf8 representation"); -} + my $s = "\x{a0}\x{a0}\x{a0}\x{100}"; chop $s; -for (120 .. 130) { - my $head = 'x' x $_; - for my $tail ('\x{0061}', '\x{1234}') { - ok( - eval qq{ "$head$tail" =~ /$head$tail/ }, - '\x{...} misparsed in regexp near 127 char EXACT limit' - ); - } -} + ok $s =~ /\x{a0}/; + ok $s =~ /\x{a0}+/; + ok $s =~ /\x{a0}\x{a0}/; -# perl #25269: panic: pp_match start/end pointers -ok("a-bc" eq eval { - my($x, $y) = "bca" =~ /^(?=.*(a)).*(bc)/; - "$x-$y"; -}, 'captures can move backwards in string'); - -# perl #27940: \cA not recognized in character classes -ok("a\cAb" =~ /\cA/, '\cA in pattern'); -ok("a\cAb" =~ /[\cA]/, '\cA in character class'); -ok("a\cAb" =~ /[\cA-\cB]/, '\cA in character class range'); -ok("abc" =~ /[^\cA-\cB]/, '\cA in negated character class range'); -ok("a\cBb" =~ /[\cA-\cC]/, '\cB in character class range'); -ok("a\cCbc" =~ /[^\cA-\cB]/, '\cC in negated character class range'); -ok("a\cAb" =~ /(??{"\cA"})/, '\cA in ??{} pattern'); -ok("ab" !~ /a\cIb/x, '\cI in pattern'); - -# perl #28532: optional zero-width match at end of string is ignored -ok(("abc" =~ /^abc(\z)?/) && defined($1), - 'optional zero-width match at end of string'); -ok(("abc" =~ /^abc(\z)??/) && !defined($1), - 'optional zero-width match at end of string'); - - - -{ # TRIE related - my @got=(); - "words"=~/(word|word|word)(?{push @got,$1})s$/; - ok(@got==1,"TRIE optimation is working") or warn "# @got"; - @got=(); - "words"=~/(word|word|word)(?{push @got,$1})s$/i; - ok(@got==1,"TRIEF optimisation is working") or warn "# @got"; - - my @nums=map {int rand 1000} 1..100; - my $re="(".(join "|",@nums).")"; - $re=qr/\b$re\b/; - - foreach (@nums) { - ok($_=~/$re/,"Trie nums"); - } - $_=join " ", @nums; - @got=(); - push @got,$1 while /$re/g; - - my %count; - $count{$_}++ for @got; - my $ok=1; - for (@nums) { - $ok=0 if --$count{$_}<0; - } - ok($ok,"Trie min count matches"); -} + $Message = "$Mess (easy variant)"; + ok "aaa\x{100}" =~ /(a+)/; + iseq $1, "aaa"; + $Message = "$Mess (easy invariant)"; + ok "aaa\x{100} " =~ /(a+?)/; + iseq $1, "a"; -# TRIE related -# LATIN SMALL/CAPITAL LETTER A WITH MACRON -ok(("foba \x{101}foo" =~ qr/(foo|\x{100}foo|bar)/i) && $1 eq "\x{101}foo", - "TRIEF + LATIN SMALL/CAPITAL LETTER A WITH MACRON"); + $Message = "$Mess (regrepeat variant)"; + ok "\xa0\xa0\xa0\x{100} " =~ /(\xa0+?)/; + iseq $1, "\xa0"; -# LATIN SMALL/CAPITAL LETTER A WITH RING BELOW -ok(("foba \x{1E01}foo" =~ qr/(foo|\x{1E00}foo|bar)/i) && $1 eq "\x{1E01}foo", - "TRIEF + LATIN SMALL/CAPITAL LETTER A WITH RING BELOW"); + $Message = "$Mess (regrepeat invariant)"; + ok "\xa0\xa0\xa0\x{100}" =~ /(\xa0+)/; + iseq $1, "\xa0\xa0\xa0"; -# DESERET SMALL/CAPITAL LETTER LONG I -ok(("foba \x{10428}foo" =~ qr/(foo|\x{10400}foo|bar)/i) && $1 eq "\x{10428}foo", - "TRIEF + DESERET SMALL/CAPITAL LETTER LONG I"); + $Message = "$Mess (hard variant)"; + ok "\xa0\xa1\xa0\xa1\xa0\xa1\x{100}" =~ /((?:\xa0\xa1)+?)/; + iseq $1, "\xa0\xa1"; -# LATIN SMALL/CAPITAL LETTER A WITH RING BELOW + 'X' -ok(("foba \x{1E01}xfoo" =~ qr/(foo|\x{1E00}Xfoo|bar)/i) && $1 eq "\x{1E01}xfoo", - "TRIEF + LATIN SMALL/CAPITAL LETTER A WITH RING BELOW + 'X'"); + $Message = "$Mess (hard invariant)"; + ok "ababab\x{100} " =~ /((?:ab)+)/; + iseq $1, 'ababab'; -{# TRIE related + ok "\xa0\xa1\xa0\xa1\xa0\xa1\x{100}" =~ /((?:\xa0\xa1)+)/; + iseq $1, "\xa0\xa1\xa0\xa1\xa0\xa1"; -use charnames ':full'; + ok "ababab\x{100} " =~ /((?:ab)+?)/; + iseq $1, "ab"; -$s="\N{LATIN SMALL LETTER SHARP S}"; -ok(("foba ba$s" =~ qr/(foo|Ba$s|bar)/i) - && $1 eq "ba$s", - "TRIEF + LATIN SMALL LETTER SHARP S =~ ss"); -ok(("foba ba$s" =~ qr/(Ba$s|foo|bar)/i) - && $1 eq "ba$s", - "TRIEF + LATIN SMALL LETTER SHARP S =~ ss"); -ok(("foba ba$s" =~ qr/(foo|bar|Ba$s)/i) - && $1 eq "ba$s", - "TRIEF + LATIN SMALL LETTER SHARP S =~ ss"); + $Message = "Don't match first byte of UTF-8 representation"; + ok "\xc4\xc4\xc4" !~ /(\x{100}+)/; + ok "\xc4\xc4\xc4" !~ /(\x{100}+?)/; + ok "\xc4\xc4\xc4" !~ /(\x{100}++)/; + } -ok(("foba ba$s" =~ qr/(foo|Bass|bar)/i) - && $1 eq "ba$s", - "TRIEF + LATIN SMALL LETTER SHARP S =~ ss"); -ok(("foba ba$s" =~ qr/(foo|BaSS|bar)/i) - && $1 eq "ba$s", - "TRIEF + LATIN SMALL LETTER SHARP S =~ SS"); + { + for (120 .. 130) { + my $head = 'x' x $_; + local $Message = q [Don't misparse \x{...} in regexp ] . + q [near 127 char EXACT limit]; + for my $tail ('\x{0061}', '\x{1234}', '\x61') { + eval_ok qq ["$head$tail" =~ /$head$tail/]; + } + local $Message = q [Don't misparse \N{...} in regexp ] . + q [near 127 char EXACT limit]; + for my $tail ('\N{SNOWFLAKE}') { + eval_ok qq [use charnames ':full'; + "$head$tail" =~ /$head$tail/]; + } + } + } -ok(("foba ba${s}pxySS$s$s" =~ qr/(b(?:a${s}t|a${s}f|a${s}p)[xy]+$s*)/i) - && $1 eq "ba${s}pxySS$s$s", - "COMMON PREFIX TRIEF + LATIN SMALL LETTER SHARP S"); - -} + { + # perl panic: pp_match start/end pointers + local $BugId = '25269'; + iseq "a-bc", eval {my ($x, $y) = "bca" =~ /^(?=.*(a)).*(bc)/; "$x-$y"}, + 'Captures can move backwards in string'; + } -print "# set PERL_SKIP_PSYCHO_TEST to skip this test\n"; -if (!$ENV{PERL_SKIP_PSYCHO_TEST}){ - my @normal=qw(these are some normal words); - my $psycho=join "|",@normal,map chr $_,255..20000; - ok(('these'=~/($psycho)/) && $1 eq 'these','Pyscho'); -} else { - ok(1,'Skipped Psycho'); -} + { + local $BugId = '27940'; # \cA not recognized in character classes + ok "a\cAb" =~ /\cA/, '\cA in pattern'; + ok "a\cAb" =~ /[\cA]/, '\cA in character class'; + ok "a\cAb" =~ /[\cA-\cB]/, '\cA in character class range'; + ok "abc" =~ /[^\cA-\cB]/, '\cA in negated character class range'; + ok "a\cBb" =~ /[\cA-\cC]/, '\cB in character class range'; + ok "a\cCbc" =~ /[^\cA-\cB]/, '\cC in negated character class range'; + ok "a\cAb" =~ /(??{"\cA"})/, '\cA in ??{} pattern'; + ok "ab" !~ /a\cIb/x, '\cI in pattern'; + } -# [perl #36207] mixed utf8 / latin-1 and case folding -{ - my $utf8 = "\xe9\x{100}"; chop $utf8; - my $latin1 = "\xe9"; + { + # perl #28532: optional zero-width match at end of string is ignored + local $BugId = '28532'; + ok "abc" =~ /^abc(\z)?/ && defined($1), + 'Optional zero-width match at end of string'; + ok "abc" =~ /^abc(\z)??/ && !defined($1), + 'Optional zero-width match at end of string'; + } - ok($utf8 =~ /\xe9/i, "utf8/latin"); - ok($utf8 =~ /$latin1/i, "utf8/latin runtime"); - ok($utf8 =~ /(abc|\xe9)/i, "utf8/latin trie"); - ok($utf8 =~ /(abc|$latin1)/i, "utf8/latin trie runtime"); - ok("\xe9" =~ /$utf8/i, "# latin/utf8"); - ok("\xe9" =~ /(abc|$utf8)/i, "# latin/utf8 trie"); - ok($latin1 =~ /$utf8/i, "# latin/utf8 runtime"); - ok($latin1 =~ /(abc|$utf8)/i, "# latin/utf8 trie runtime"); -} -# [perl #37038] Global regular matches generate invalid pointers + { # TRIE related + our @got = (); + "words" =~ /(word|word|word)(?{push @got, $1})s$/; + iseq @got, 1, "TRIE optimation"; -{ - my $s = "abcd"; - $s =~ /(..)(..)/g; - $s = $1; - $s = $2; - ok($s eq 'cd', - "# assigning to original string should not corrupt match vars"); -} + @got = (); + "words" =~ /(word|word|word)(?{push @got,$1})s$/i; + iseq @got, 1,"TRIEF optimisation"; + + my @nums = map {int rand 1000} 1 .. 100; + my $re = "(" . (join "|", @nums) . ")"; + $re = qr/\b$re\b/; + + foreach (@nums) { + ok $_ =~ /$re/, "Trie nums"; + } -{ - package wooosh; - sub gloople { - "!"; + $_ = join " ", @nums; + @got = (); + push @got, $1 while /$re/g; + + my %count; + $count {$_} ++ for @got; + my $ok = 1; + for (@nums) { + $ok = 0 if --$count {$_} < 0; + } + ok $ok, "Trie min count matches"; } - package main; - - my $aeek = bless {}, 'wooosh'; - eval {$aeek->gloople() =~ /(.)/g;}; - ok($@ eq "", "//g match against return value of sub") or print "# $@\n"; -} -{ - sub gloople { - "!"; + + { + # TRIE related + # LATIN SMALL/CAPITAL LETTER A WITH MACRON + ok "foba \x{101}foo" =~ qr/(foo|\x{100}foo|bar)/i && + $1 eq "\x{101}foo", + "TRIEF + LATIN SMALL/CAPITAL LETTER A WITH MACRON"; + + # LATIN SMALL/CAPITAL LETTER A WITH RING BELOW + ok "foba \x{1E01}foo" =~ qr/(foo|\x{1E00}foo|bar)/i && + $1 eq "\x{1E01}foo", + "TRIEF + LATIN SMALL/CAPITAL LETTER A WITH RING BELOW"; + + # DESERET SMALL/CAPITAL LETTER LONG I + ok "foba \x{10428}foo" =~ qr/(foo|\x{10400}foo|bar)/i && + $1 eq "\x{10428}foo", + "TRIEF + DESERET SMALL/CAPITAL LETTER LONG I"; + + # LATIN SMALL/CAPITAL LETTER A WITH RING BELOW + 'X' + ok "foba \x{1E01}xfoo" =~ qr/(foo|\x{1E00}Xfoo|bar)/i && + $1 eq "\x{1E01}xfoo", + "TRIEF + LATIN SMALL/CAPITAL LETTER A WITH RING BELOW + 'X'"; + + use charnames ':full'; + + my $s = "\N{LATIN SMALL LETTER SHARP S}"; + ok "foba ba$s" =~ qr/(foo|Ba$s|bar)/i && $1 eq "ba$s", + "TRIEF + LATIN SMALL LETTER SHARP S =~ ss"; + ok "foba ba$s" =~ qr/(Ba$s|foo|bar)/i && $1 eq "ba$s", + "TRIEF + LATIN SMALL LETTER SHARP S =~ ss"; + ok "foba ba$s" =~ qr/(foo|bar|Ba$s)/i && $1 eq "ba$s", + "TRIEF + LATIN SMALL LETTER SHARP S =~ ss"; + + ok "foba ba$s" =~ qr/(foo|Bass|bar)/i && $1 eq "ba$s", + "TRIEF + LATIN SMALL LETTER SHARP S =~ ss"; + + ok "foba ba$s" =~ qr/(foo|BaSS|bar)/i && $1 eq "ba$s", + "TRIEF + LATIN SMALL LETTER SHARP S =~ SS"; + + ok "foba ba${s}pxySS$s$s" =~ qr/(b(?:a${s}t|a${s}f|a${s}p)[xy]+$s*)/i + && $1 eq "ba${s}pxySS$s$s", + "COMMON PREFIX TRIEF + LATIN SMALL LETTER SHARP S"; } - eval {gloople() =~ /(.)/g;}; - ok($@ eq "", "# 26410 didn't affect sub calls for some reason") - or print "# $@\n"; -} -{ - local $TODO = "See changes 26925-26928, which reverted change 26410"; - package lv; - $var = "abc"; - sub variable : lvalue { $var } - - package main; - my $o = bless [], "lv"; - my $f = ""; - eval { for (1..2) { $f .= $1 if $o->variable =~ /(.)/g } }; - ok($f eq "ab", "pos retained between calls") or print "# $@\n"; -} -{ - local $TODO = "See changes 26925-26928, which reverted change 26410"; - $var = "abc"; - sub variable : lvalue { $var } + SKIP: + { + print "# Set PERL_SKIP_PSYCHO_TEST to skip this test\n"; + my @normal = qw [the are some normal words]; - my $f = ""; - eval { for (1..2) { $f .= $1 if variable() =~ /(.)/g } }; - ok($f eq "ab", "pos retained between calls") or print "# $@\n"; -} + skip "Skipped Psycho", 2 * @normal if $ENV {PERL_SKIP_PSYCHO_TEST}; -# [perl #37836] Simple Regex causes SEGV when run on specific data -if ($ordA == 193) { - print "ok $test # Skip: in EBCDIC\n"; $test++; -} else { - no warnings 'utf8'; - $_ = pack('U0C2', 0xa2, 0xf8); # ill-formed UTF-8 - my $ret = 0; - eval { $ret = s/[\0]+//g }; - ok($ret == 0, "ill-formed UTF-8 doesn't match NUL in class"); -} + local $" = "|"; -{ # [perl #38293] chr(65535) should be allowed in regexes - no warnings 'utf8'; # to allow non-characters - my($c, $r, $s); + my @psycho = (@normal, map chr $_, 255 .. 20000); + my $psycho1 = "@psycho"; + for (my $i = @psycho; -- $i;) { + my $j = int rand (1 + $i); + @psycho [$i, $j] = @psycho [$j, $i]; + } + my $psycho2 = "@psycho"; - $c = chr 0xffff; - $c =~ s/$c//g; - ok($c eq "", "U+FFFF, parsed as atom"); + foreach my $word (@normal) { + ok $word =~ /($psycho1)/ && $1 eq $word, 'Psycho'; + ok $word =~ /($psycho2)/ && $1 eq $word, 'Psycho'; + } + } - $c = chr 0xffff; - $r = "\\$c"; - $c =~ s/$r//g; - ok($c eq "", "U+FFFF backslashed, parsed as atom"); - $c = chr 0xffff; - $c =~ s/[$c]//g; - ok($c eq "", "U+FFFF, parsed in class"); + { + local $BugId = '36207'; + my $utf8 = "\xe9\x{100}"; chop $utf8; + my $latin1 = "\xe9"; + + ok $utf8 =~ /\xe9/i, "utf8/latin"; + ok $utf8 =~ /$latin1/i, "utf8/latin runtime"; + ok $utf8 =~ /(abc|\xe9)/i, "utf8/latin trie"; + ok $utf8 =~ /(abc|$latin1)/i, "utf8/latin trie runtime"; + + ok "\xe9" =~ /$utf8/i, "latin/utf8"; + ok "\xe9" =~ /(abc|$utf8)/i, "latin/utf8 trie"; + ok $latin1 =~ /$utf8/i, "latin/utf8 runtime"; + ok $latin1 =~ /(abc|$utf8)/i, "latin/utf8 trie runtime"; + } - $c = chr 0xffff; - $r = "[\\$c]"; - $c =~ s/$r//g; - ok($c eq "", "U+FFFF backslashed, parsed in class"); - $s = "A\x{ffff}B"; - $s =~ s/\x{ffff}//i; - ok($s eq "AB", "U+FFFF, EXACTF"); + { + local $BugId = '37038'; + my $s = "abcd"; + $s =~ /(..)(..)/g; + $s = $1; + $s = $2; + iseq $2, 'cd', + "Assigning to original string does not corrupt match vars"; + } - $s = "\x{ffff}A"; - $s =~ s/\bA//; - ok($s eq "\x{ffff}", "U+FFFF, BOUND"); - $s = "\x{ffff}!"; - $s =~ s/\B!//; - ok($s eq "\x{ffff}", "U+FFFF, NBOUND"); -} # non-characters end + { + { + package wooosh; + sub gloople {"!"} + } + my $aeek = bless {} => 'wooosh'; + eval_ok sub {$aeek -> gloople () =~ /(.)/g}, + "//g match against return value of sub"; -{ - # https://rt.perl.org/rt3/Ticket/Display.html?id=39583 - - # The printing characters - my @chars = ("A".."Z"); - my $delim = ","; - my $size = 32771 - 4; - my $str = ''; - - # create some random junk. Inefficient, but it works. - for ($i = 0 ; $i < $size ; $i++) { - $str .= $chars[int(rand(@chars))]; - } - - $str .= ($delim x 4); - my $res; - my $matched; - if ($str =~ s/^(.*?)${delim}{4}//s) { - $res = $1; - $matched=1; - } - ok($matched,'pattern matches'); - ok(length($str)==0,"Empty string"); - ok(defined($res) && length($res)==$size,"\$1 is correct size"); -} + sub gloople {"!"} + eval_ok sub {gloople () =~ /(.)/g}, + "26410 didn't affect sub calls for some reason"; + } -{ # related to [perl #27940] - ok("\0-A" =~ /\c@-A/, '@- should not be interpolated in a pattern'); - ok("\0\0A" =~ /\c@+A/, '@+ should not be interpolated in a pattern'); - ok("X\@-A" =~ /X@-A/, '@- should not be interpolated in a pattern'); - ok("X\@\@A" =~ /X@+A/, '@+ should not be interpolated in a pattern'); - - ok("X\0A" =~ /X\c@?A/, '\c@?'); - ok("X\0A" =~ /X\c@*A/, '\c@*'); - ok("X\0A" =~ /X\c@(A)/, '\c@('); - ok("X\0A" =~ /X(\c@)A/, '\c@)'); - ok("X\0A" =~ /X\c@|ZA/, '\c@|'); - - ok("X\@A" =~ /X@?A/, '@?'); - ok("X\@A" =~ /X@*A/, '@*'); - ok("X\@A" =~ /X@(A)/, '@('); - ok("X\@A" =~ /X(@)A/, '@)'); - ok("X\@A" =~ /X@|ZA/, '@|'); - - local $" = ','; # non-whitespace and non-RE-specific - ok('abc' =~ /(.)(.)(.)/, 'the last successful match is bogus'); - ok("A@+B" =~ /A@{+}B/, 'interpolation of @+ in /@{+}/'); - ok("A@-B" =~ /A@{-}B/, 'interpolation of @- in /@{-}/'); - ok("A@+B" =~ /A@{+}B/x, 'interpolation of @+ in /@{+}/x'); - ok("A@-B" =~ /A@{-}B/x, 'interpolation of @- in /@{-}/x'); -} -{ - use lib 'lib'; - use Cname; - - ok('fooB'=~/\N{foo}[\N{B}\N{b}]/,"Passthrough charname"); - $test=1233; my $handle=make_must_warn('Ignoring excess chars from'); - $handle->('q(xxWxx) =~ /[\N{WARN}]/'); - { - my $code; - my $w=""; - local $SIG{__WARN__} = sub { $w.=shift }; - eval($code=<<'EOFTEST') or die "$@\n$code\n"; + { + local $TODO = "See changes 26925-26928, which reverted change 26410"; { - use warnings; - - #1234 - ok("\0" !~ /[\N{EMPTY-STR}XY]/, - "Zerolength charname in charclass doesnt match \0"); + package lv; + our $var = "abc"; + sub variable : lvalue {$var} + } + my $o = bless [] => 'lv'; + my $f = ""; + my $r = eval { + for (1 .. 2) { + $f .= $1 if $o -> variable =~ /(.)/g; + } 1; + }; + if ($r) { + iseq $f, "ab", "pos() retained between calls"; + } + else { + local $TODO; + ok 0, "Code failed: $@"; + } + + our $var = "abc"; + sub variable : lvalue {$var} + my $g = ""; + my $s = eval { + for (1 .. 2) { + $g .= $1 if variable =~ /(.)/g; + } + 1; + }; + if ($s) { + iseq $g, "ab", "pos() retained between calls"; + } + else { + local $TODO; + ok 0, "Code failed: $@"; } -EOFTEST - ok($w=~/Ignoring zero length/, - "Got expected zero length warning"); - warn $code; - } - $handle= make_must_warn('Ignoring zero length'); - $handle->('qq(\\0) =~ /[\N{EMPTY-STR}XY]/'); - ok('AB'=~/(\N{EVIL})/ && $1 eq 'A',"Charname caching $1"); - ok('ABC'=~/(\N{EVIL})/,"Charname caching $1"); - ok('xy'=~/x\N{EMPTY-STR}y/, 'Empty string charname produces NOTHING node'); - ok(''=~/\N{EMPTY-STR}/, 'Empty string charname produces NOTHING node 2'); - -} -{ - print "# MORE LATIN SMALL LETTER SHARP S\n"; - - use charnames ':full'; - - #see also test #835 - ok("ss" =~ /[\N{LATIN SMALL LETTER SHARP S}x]/i, - "unoptimized named sequence in class 1"); - ok("SS" =~ /[\N{LATIN SMALL LETTER SHARP S}x]/i, - "unoptimized named sequence in class 2"); - ok("\N{LATIN SMALL LETTER SHARP S}" =~ /[\N{LATIN SMALL LETTER SHARP S}x]/, - "unoptimized named sequence in class 3"); - ok("\N{LATIN SMALL LETTER SHARP S}" =~ /[\N{LATIN SMALL LETTER SHARP S}x]/i, - "unoptimized named sequence in class 4"); - - ok('aabc' !~ /a\N{PLUS SIGN}b/,'/a\N{PLUS SIGN}b/ against aabc'); - ok('a+bc' =~ /a\N{PLUS SIGN}b/,'/a\N{PLUS SIGN}b/ against a+bc'); - ok('a+bc' =~ /a\N{PLUS SIGN}b/,'/a\N{PLUS SIGN}b/ against a+bc'); - - ok(' A B'=~/\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042}/, - 'Intermixed named and unicode escapes 1'); - 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 2'); - ok("\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042} 3"=~ - /[\N{SPACE}\N{U+0041}][\N{SPACE}\N{U+0042}]/, - 'Intermixed named and unicode escapes'); -} -$brackets = qr{ - { (?> [^{}]+ | (??{ $brackets }) )* } - }x; -ok("{b{c}d" !~ m/^((??{ $brackets }))/, "bracket mismatch"); - -SKIP:{ - our @stack=(); - my @expect=qw( - stuff1 - stuff2 - and - right - - <> - <<>> - <and><<<>>> - ); - - local $_='<<and><<<>>>>'; - ok(/^(<((?:(?>[^<>]+)|(?1))*)>(?{push @stack, $2 }))$/, - "Recursion should match"); - ok(@stack==@expect) - or skip("Won't test individual results as count isn't equal", - 0+@expect); - foreach my $idx (@expect) { - ok($expect[$idx] eq $stack[$idx], - "Expecting '$expect' at stack pos #$idx"); + + + SKIP: + { + local $BugId = '37836'; + skip "In EBCDIC" if $IS_EBCDIC; + no warnings 'utf8'; + $_ = pack 'U0C2', 0xa2, 0xf8; # Ill-formed UTF-8 + my $ret = 0; + eval_ok sub {!($ret = s/[\0]+//g)}, + "Ill-formed UTF-8 doesn't match NUL in class"; } - -} -{ - my $s='123453456'; - $s=~s/(?\d+)\k/$+{digits}/; - 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///'); -} -{ - my @ary = ( - pack('U', 0x00F1), # n-tilde - '_'.pack('U', 0x00F1), # _ + n-tilde - 'c'.pack('U', 0x0327), # c + cedilla - pack('U*', 0x00F1, 0x0327), # n-tilde + cedilla - 'a'.pack('U', 0x00B2), # a + superscript two - pack('U', 0x0391), # ALPHA - pack('U', 0x0391).'2', # ALPHA + 2 - pack('U', 0x0391).'_', # ALPHA + _ - ); - for my $uni (@ary) { - my ($r1, $c1, $r2, $c2) = eval qq{ - use utf8; - scalar("..foo foo.." =~ /(?'${uni}'foo) \\k'${uni}'/), - \$+{${uni}}, - scalar("..bar bar.." =~ /(?<${uni}>bar) \\k<${uni}>/), - \$+{${uni}}; - }; - ok($r1, "Named capture UTF (?'')"); - ok(defined $c1 && $c1 eq 'foo', "Named capture UTF \%+"); - ok($r2, "Named capture UTF (?<>)"); - ok(defined $c2 && $c2 eq 'bar', "Named capture UTF \%+"); + + { + # chr(65535) should be allowed in regexes + local $BugId = '38293'; + no warnings 'utf8'; # To allow non-characters + my ($c, $r, $s); + + $c = chr 0xffff; + $c =~ s/$c//g; + ok $c eq "", "U+FFFF, parsed as atom"; + + $c = chr 0xffff; + $r = "\\$c"; + $c =~ s/$r//g; + ok $c eq "", "U+FFFF backslashed, parsed as atom"; + + $c = chr 0xffff; + $c =~ s/[$c]//g; + ok $c eq "", "U+FFFF, parsed in class"; + + $c = chr 0xffff; + $r = "[\\$c]"; + $c =~ s/$r//g; + ok $c eq "", "U+FFFF backslashed, parsed in class"; + + $s = "A\x{ffff}B"; + $s =~ s/\x{ffff}//i; + ok $s eq "AB", "U+FFFF, EXACTF"; + + $s = "\x{ffff}A"; + $s =~ s/\bA//; + ok $s eq "\x{ffff}", "U+FFFF, BOUND"; + + $s = "\x{ffff}!"; + $s =~ s/\B!//; + ok $s eq "\x{ffff}", "U+FFFF, NBOUND"; } -} -sub iseq($$;$) { - my ( $got, $expect, $name)=@_; - my $todo = $TODO ? " # TODO $TODO" : ''; - - $_=defined($_) ? "'$_'" : "undef" - for $got, $expect; + + { + local $BugId = '39583'; - my $ok= $got eq $expect; + # The printing characters + my @chars = ("A" .. "Z"); + my $delim = ","; + my $size = 32771 - 4; + my $str = ''; + + # Create some random junk. Inefficient, but it works. + for (my $i = 0; $i < $size; $ i++) { + $str .= $chars [rand @chars]; + } + + $str .= ($delim x 4); + my $res; + my $matched; + ok $str =~ s/^(.*?)${delim}{4}//s, "Pattern matches"; + iseq $str, "", "Empty string"; + ok defined $1 && length ($1) == $size, '$1 is correct size'; + } + + + { + local $BugId = '27940'; + ok "\0-A" =~ /\c@-A/, '@- should not be interpolated in a pattern'; + ok "\0\0A" =~ /\c@+A/, '@+ should not be interpolated in a pattern'; + ok "X\@-A" =~ /X@-A/, '@- should not be interpolated in a pattern'; + ok "X\@\@A" =~ /X@+A/, '@+ should not be interpolated in a pattern'; + + ok "X\0A" =~ /X\c@?A/, '\c@?'; + ok "X\0A" =~ /X\c@*A/, '\c@*'; + ok "X\0A" =~ /X\c@(A)/, '\c@('; + ok "X\0A" =~ /X(\c@)A/, '\c@)'; + ok "X\0A" =~ /X\c@|ZA/, '\c@|'; + + ok "X\@A" =~ /X@?A/, '@?'; + ok "X\@A" =~ /X@*A/, '@*'; + ok "X\@A" =~ /X@(A)/, '@('; + ok "X\@A" =~ /X(@)A/, '@)'; + ok "X\@A" =~ /X@|ZA/, '@|'; + + local $" = ','; # non-whitespace and non-RE-specific + ok 'abc' =~ /(.)(.)(.)/, 'The last successful match is bogus'; + ok "A@+B" =~ /A@{+}B/, 'Interpolation of @+ in /@{+}/'; + ok "A@-B" =~ /A@{-}B/, 'Interpolation of @- in /@{-}/'; + ok "A@+B" =~ /A@{+}B/x, 'Interpolation of @+ in /@{+}/x'; + ok "A@-B" =~ /A@{-}B/x, 'Interpolation of @- in /@{-}/x'; + } + + + { + use lib 'lib'; + use Cname; - printf "%sok %d - %s$todo\n", ($ok ? "" : "not "), $test, - ($name||$Message)."\tLine ".((caller)[2]); + ok 'fooB' =~ /\N{foo}[\N{B}\N{b}]/, "Passthrough charname"; + my $test = 1233; + # + # Why doesn't must_warn work here? + # + my $w; + local $SIG {__WARN__} = sub {$w .= "@_"}; + eval 'q(xxWxx) =~ /[\N{WARN}]/'; + ok $w && $w =~ /^Ignoring excess chars from/, + "Ignoring excess chars warning"; + + undef $w; + eval q [ok "\0" !~ /[\N{EMPTY-STR}XY]/, + "Zerolength charname in charclass doesn't match \\0"]; + ok $w && $w =~ /^Ignoring zero length/, + 'Ignoring zero length \N{%} in character class warning'; + + ok 'AB' =~ /(\N{EVIL})/ && $1 eq 'A', 'Charname caching $1'; + ok 'ABC' =~ /(\N{EVIL})/, 'Charname caching $1'; + ok 'xy' =~ /x\N{EMPTY-STR}y/, + 'Empty string charname produces NOTHING node'; + ok '' =~ /\N{EMPTY-STR}/, + 'Empty string charname produces NOTHING node'; + + } - no warnings 'utf8'; - 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,@fetch,$res); - my $count= 0; - my @names=qw($+{A} $+{B} $+{C}); - if ($s=~/(?foo)\s+(?bar)?\s+(?baz)/) { - while (my ($k,$v)=each(%+)) { - $count++; + { + use charnames ':full'; + + ok 'aabc' !~ /a\N{PLUS SIGN}b/, '/a\N{PLUS SIGN}b/ against aabc'; + ok 'a+bc' =~ /a\N{PLUS SIGN}b/, '/a\N{PLUS SIGN}b/ against a+bc'; + + ok ' A B' =~ /\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042}/, + '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'; + 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'; + } + + + { + our $brackets; + $brackets = qr{ + { (?> [^{}]+ | (??{ $brackets }) )* } + }x; + + ok "{b{c}d" !~ m/^((??{ $brackets }))/, "Bracket mismatch"; + + SKIP: { + our @stack = (); + my @expect = qw ( + stuff1 + stuff2 + and + right + + <> + <<>> + <and><<<>>> + ); + + local $_ = '<<and><<<>>>>'; + ok /^(<((?:(?>[^<>]+)|(?1))*)>(?{push @stack, $2 }))$/, + "Recursion matches"; + iseq @stack, @expect, "Right amount of matches" + or skip "Won't test individual results as count isn't equal", + 0 + @expect; + my $idx = 0; + foreach my $expect (@expect) { + iseq $stack [$idx], $expect, + "Expecting '$expect' at stack pos #$idx"; + $idx ++; + } } - @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[$_]); + } + + + { + my $s = '123453456'; + $s =~ s/(?\d+)\k/$+{digits}/; + 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///'; + } + + + { + my @ary = ( + pack('U', 0x00F1), # n-tilde + '_'.pack('U', 0x00F1), # _ + n-tilde + 'c'.pack('U', 0x0327), # c + cedilla + pack('U*', 0x00F1, 0x0327), # n-tilde + cedilla + 'a'.pack('U', 0x00B2), # a + superscript two + pack('U', 0x0391), # ALPHA + pack('U', 0x0391).'2', # ALPHA + 2 + pack('U', 0x0391).'_', # ALPHA + _ + ); + + for my $uni (@ary) { + my ($r1, $c1, $r2, $c2) = eval qq { + use utf8; + scalar ("..foo foo.." =~ /(?'${uni}'foo) \\k'${uni}'/), + \$+{${uni}}, + scalar ("..bar bar.." =~ /(?<${uni}>bar) \\k<${uni}>/), + \$+{${uni}}; + }; + ok $r1, "Named capture UTF (?'')"; + ok defined $c1 && $c1 eq 'foo', "Named capture UTF \%+"; + ok $r2, "Named capture UTF (?<>)"; + ok defined $c2 && $c2 eq 'bar', "Named capture UTF \%+"; } } - 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'); -} -{ - # - # Almost the same as the block above, except that the capture is nested. - # - my $s = 'foo bar baz'; - my (@k,@v,@fetch,$res); - my $count = 0; - my @names = qw($+{A} $+{B} $+{C} $+{D}); - if ($s =~ /(?(?foo)\s+(?bar)?\s+(?baz))/) { - while (my ($k,$v) = each(%+)) { - $count++; - } - @k = sort keys(%+); - @v = sort values(%+); - $res = 1; - push @fetch, - [ "$+{A}", "$2" ], - [ "$+{B}", "$3" ], - [ "$+{C}", "$4" ], - [ "$+{D}", $1 ], - ; - } - foreach (0..3) { - if ($fetch[$_]) { - iseq($fetch[$_][0],$fetch[$_][1],$names[$_]); - } else { - ok(0, $names[$_]); - } - } - iseq($res,1,"$s~=/(?(?foo)\s+(?bar)?\s+(?baz))/"); - iseq($count,4,"Got 4 keys in %+ via each -- bug 50496"); - iseq(0+@k, 4, 'Got 4 keys in %+ via keys -- bug 50496'); - iseq("@k","A B C D", "Got expected keys -- bug 50496"); - iseq("@v","bar baz foo foo bar baz", "Got expected values -- bug = 50496"); - eval' - print for $+{this_key_doesnt_exist}; - '; - ok(!$@,'lvalue $+{...} should not throw an exception'); -} -{ - my $s='foo bar baz'; - my @res; - if ('1234'=~/(?1)(?2)(?3)(?4)/) { - foreach my $name (sort keys(%-)) { - my $ary = $-{$name}; - foreach my $idx (0..$#$ary) { - push @res,"$name:$idx:$ary->[$idx]"; + + + { + my $s = 'foo bar baz'; + 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[$_]; } } + 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 ' + no warnings "uninitialized"; + print for $+ {this_key_doesnt_exist}; + '; + ok !$@, 'lvalue $+ {...} should not throw an exception'; } - my @expect=qw(A:0:1 A:1:3 B:0:2 B:1:4); - iseq("@res","@expect","Check %-"); - 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 -# profiling done against build 28905, exercises every code line in the -# 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 { - print "# set PERL_SKIP_PSYCHO_TEST to skip this test\n"; - my $r = qr/^ - (?: - ( (?:a|z+)+ ) - (?: - ( (?:b|z+){3,}? ) - ( - (?: - (?: - (?:c|z+){1,1}?z - )? - (?:c|z+){1,1} - )* - ) - (?:z*){2,} - ( (?:z+|d)+ ) - (?: - ( (?:e|z+)+ ) - )* - ( (?:f|z+)+ ) - )* - ( (?:z+|g)+ ) - (?: - ( (?:h|z+)+ ) - )* - ( (?:i|z+)+ ) - )+ - ( (?:j|z+)+ ) - (?: - ( (?:k|z+)+ ) - )* - ( (?:l|z+)+ ) - $/x; - - - my $ok = 1; - my $msg = "CURLYX stress test"; - OUTER: - for my $a ("x","a","aa") { - for my $b ("x","bbb","bbbb") { - my $bs = $a.$b; - for my $c ("x","c","cc") { - my $cs = $bs.$c; - for my $d ("x","d","dd") { - my $ds = $cs.$d; - for my $e ("x","e","ee") { - my $es = $ds.$e; - for my $f ("x","f","ff") { - my $fs = $es.$f; - for my $g ("x","g","gg") { - my $gs = $fs.$g; - for my $h ("x","h","hh") { - my $hs = $gs.$h; - for my $i ("x","i","ii") { - my $is = $hs.$i; - for my $j ("x","j","jj") { - my $js = $is.$j; - for my $k ("x","k","kk") { - my $ks = $js.$k; - for my $l ("x","l","ll") { - my $ls = $ks.$l; - if ($ls =~ $r) { - if ($ls =~ /x/) { - $msg .= ": unexpected match for [$ls]"; - $ok = 0; - last OUTER; - } - my $cap = "$1$2$3$4$5$6$7$8$9$10$11$12"; - unless ($ls eq $cap) { - $msg .= ": capture: [$ls], got [$cap]"; - $ok = 0; - last OUTER; - } - } - else { - unless ($ls =~ /x/) { - $msg = ": failed for [$ls]"; - $ok = 0; - last OUTER; + + + { + # + # Almost the same as the block above, except that the capture is nested. + # + local $BugId = '50496'; + my $s = 'foo bar baz'; + my (@k, @v, @fetch, $res); + my $count = 0; + my @names = qw ($+{A} $+{B} $+{C} $+{D}); + if ($s =~ /(?(?foo)\s+(?bar)?\s+(?baz))/) { + while (my ($k,$v) = each(%+)) { + $count++; + } + @k = sort keys (%+); + @v = sort values (%+); + $res = 1; + push @fetch, + ["$+{A}", "$2"], + ["$+{B}", "$3"], + ["$+{C}", "$4"], + ["$+{D}", "$1"], + ; + } + foreach (0 .. 3) { + if ($fetch [$_]) { + iseq $fetch [$_] [0], $fetch [$_] [1], $names [$_]; + } else { + ok 0, $names [$_]; + } + } + iseq $res, 1, "'$s' =~ /(?(?foo)\\s+(?bar)?\\s+(?baz))/"; + iseq $count, 4, "Got 4 keys in %+ via each"; + iseq @k, 4, 'Got 4 keys in %+ via keys'; + iseq "@k", "A B C D", "Got expected keys"; + iseq "@v", "bar baz foo foo bar baz", "Got expected values"; + eval ' + no warnings "uninitialized"; + print for $+ {this_key_doesnt_exist}; + '; + ok !$@,'lvalue $+ {...} should not throw an exception'; + } + + + { + my $s = 'foo bar baz'; + my @res; + if ('1234' =~ /(?1)(?2)(?3)(?4)/) { + foreach my $name (sort keys(%-)) { + my $ary = $- {$name}; + foreach my $idx (0 .. $#$ary) { + push @res, "$name:$idx:$ary->[$idx]"; + } + } + } + my @expect = qw (A:0:1 A:1:3 B:0:2 B:1:4); + iseq "@res", "@expect", "Check %-"; + eval' + no warnings "uninitialized"; + print for $- {this_key_doesnt_exist}; + '; + ok !$@,'lvalue $- {...} should not throw an exception'; + } + + + SKIP: + { + # stress test CURLYX/WHILEM. + # + # This test includes varying levels of nesting, and according to + # profiling done against build 28905, exercises every code line in the + # CURLYX and WHILEM blocks, except those related to LONGJMP, the + # super-linear cache and warnings. It executes about 0.5M regexes + + skip "No psycho tests" if $ENV {PERL_SKIP_PSYCHO_TEST}; + print "# Set PERL_SKIP_PSYCHO_TEST to skip this test\n"; + my $r = qr/^ + (?: + ( (?:a|z+)+ ) + (?: + ( (?:b|z+){3,}? ) + ( + (?: + (?: + (?:c|z+){1,1}?z + )? + (?:c|z+){1,1} + )* + ) + (?:z*){2,} + ( (?:z+|d)+ ) + (?: + ( (?:e|z+)+ ) + )* + ( (?:f|z+)+ ) + )* + ( (?:z+|g)+ ) + (?: + ( (?:h|z+)+ ) + )* + ( (?:i|z+)+ ) + )+ + ( (?:j|z+)+ ) + (?: + ( (?:k|z+)+ ) + )* + ( (?:l|z+)+ ) + $/x; + + my $ok = 1; + my $msg = "CURLYX stress test"; + OUTER: + for my $a ("x","a","aa") { + for my $b ("x","bbb","bbbb") { + my $bs = $a.$b; + for my $c ("x","c","cc") { + my $cs = $bs.$c; + for my $d ("x","d","dd") { + my $ds = $cs.$d; + for my $e ("x","e","ee") { + my $es = $ds.$e; + for my $f ("x","f","ff") { + my $fs = $es.$f; + for my $g ("x","g","gg") { + my $gs = $fs.$g; + for my $h ("x","h","hh") { + my $hs = $gs.$h; + for my $i ("x","i","ii") { + my $is = $hs.$i; + for my $j ("x","j","jj") { + my $js = $is.$j; + for my $k ("x","k","kk") { + my $ks = $js.$k; + for my $l ("x","l","ll") { + my $ls = $ks.$l; + if ($ls =~ $r) { + if ($ls =~ /x/) { + $msg .= ": unexpected match for [$ls]"; + $ok = 0; + last OUTER; + } + my $cap = "$1$2$3$4$5$6$7$8$9$10$11$12"; + unless ($ls eq $cap) { + $msg .= ": capture: [$ls], got [$cap]"; + $ok = 0; + last OUTER; + } + } + else { + unless ($ls =~ /x/) { + $msg = ": failed for [$ls]"; + $ok = 0; + last OUTER; + } + } + } + } } } } @@ -3932,803 +3203,892 @@ if ($ENV{PERL_SKIP_PSYCHO_TEST}){ } } } - } } - } + ok($ok, $msg); } - } - 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"); + { + # \, 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"; + } + } + -# \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"); -} + { + local $BugId = '36046'; + 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'; + iseq $pval, 0, '@+ should be empty'; + iseq $count, 1, 'Should have matched once only'; + } -{ - 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 (*PRUNE) pattern - our $count = 0; - 'aaab'=~/a+b?(?{$count++})(*FAIL)/; - iseq($count,9,"expect 9 for no (*PRUNE)"); - $count = 0; - 'aaab'=~/a+b?(*PRUNE)(?{$count++})(*FAIL)/; - iseq($count,3,"expect 3 with (*PRUNE)"); - local $_='aaab'; - $count=0; - 1 while /.(*PRUNE)(?{$count++})(*FAIL)/g; - iseq($count,4,"/.(*PRUNE)/"); - $count = 0; - 'aaab'=~/a+b?(??{'(*PRUNE)'})(?{$count++})(*FAIL)/; - iseq($count,3,"expect 3 with (*PRUNE)"); - local $_='aaab'; - $count=0; - 1 while /.(??{'(*PRUNE)'})(?{$count++})(*FAIL)/g; - iseq($count,4,"/.(*PRUNE)/"); -} -{ # Test the (*SKIP) pattern - our $count = 0; - 'aaab'=~/a+b?(*SKIP)(?{$count++})(*FAIL)/; - iseq($count,1,"expect 1 with (*SKIP)"); - local $_='aaab'; - $count=0; - 1 while /.(*SKIP)(?{$count++})(*FAIL)/g; - iseq($count,4,"/.(*SKIP)/"); - $_='aaabaaab'; - $count=0; - our @res=(); - 1 while /(a+b?)(*SKIP)(?{$count++; push @res,$1})(*FAIL)/g; - iseq($count,2,"Expect 2 with (*SKIP)" ); - iseq("@res","aaab aaab","adjacent (*SKIP) works as expected" ); -} -{ # Test the (*SKIP) pattern - our $count = 0; - 'aaab'=~/a+b?(*MARK:foo)(*SKIP)(?{$count++})(*FAIL)/; - iseq($count,1,"expect 1 with (*SKIP)"); - local $_='aaab'; - $count=0; - 1 while /.(*MARK:foo)(*SKIP)(?{$count++})(*FAIL)/g; - iseq($count,4,"/.(*SKIP)/"); - $_='aaabaaab'; - $count=0; - our @res=(); - 1 while /(a+b?)(*MARK:foo)(*SKIP)(?{$count++; push @res,$1})(*FAIL)/g; - iseq($count,2,"Expect 2 with (*SKIP)" ); - iseq("@res","aaab aaab","adjacent (*SKIP) works as expected" ); -} -{ # Test the (*SKIP) pattern - our $count = 0; - 'aaab'=~/a*(*MARK:a)b?(*MARK:b)(*SKIP:a)(?{$count++})(*FAIL)/; - iseq($count,3,"expect 3 with *MARK:a)b?(*MARK:b)(*SKIP:a)"); - local $_='aaabaaab'; - $count=0; - our @res=(); - 1 while /(a*(*MARK:a)b?)(*MARK:x)(*SKIP:a)(?{$count++; push @res,$1})(*FAIL)/g; - iseq($count,5,"Expect 5 with (*MARK:a)b?)(*MARK:x)(*SKIP:a)" ); - iseq("@res","aaab b aaab b ","adjacent (*MARK:a)b?)(*MARK:x)(*SKIP: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 ("(*PRUNE$name)", - ($name? "(*MARK$name)" : "") - . "(*SKIP$name)", - "(*COMMIT$name)") - { - for my $suffix ('(*FAIL)','') - { - 'aaaab'=~/a+b$pat$suffix/; - iseq( - $REGERROR, - ($suffix ? ($name ? 'foo' : "1") : ""), - "Test $pat and \$REGERROR $suffix" - ); + { # Test the (*PRUNE) pattern + our $count = 0; + 'aaab' =~ /a+b?(?{$count++})(*FAIL)/; + iseq $count, 9, "Expect 9 for no (*PRUNE)"; + $count = 0; + 'aaab' =~ /a+b?(*PRUNE)(?{$count++})(*FAIL)/; + iseq $count, 3, "Expect 3 with (*PRUNE)"; + local $_ = 'aaab'; + $count = 0; + 1 while /.(*PRUNE)(?{$count++})(*FAIL)/g; + iseq $count, 4, "/.(*PRUNE)/"; + $count = 0; + 'aaab' =~ /a+b?(??{'(*PRUNE)'})(?{$count++})(*FAIL)/; + iseq $count, 3, "Expect 3 with (*PRUNE)"; + local $_ = 'aaab'; + $count = 0; + 1 while /.(??{'(*PRUNE)'})(?{$count++})(*FAIL)/g; + iseq $count, 4, "/.(*PRUNE)/"; + } + + + { # Test the (*SKIP) pattern + our $count = 0; + 'aaab' =~ /a+b?(*SKIP)(?{$count++})(*FAIL)/; + iseq $count, 1, "Expect 1 with (*SKIP)"; + local $_ = 'aaab'; + $count = 0; + 1 while /.(*SKIP)(?{$count++})(*FAIL)/g; + iseq $count, 4, "/.(*SKIP)/"; + $_ = 'aaabaaab'; + $count = 0; + our @res = (); + 1 while /(a+b?)(*SKIP)(?{$count++; push @res,$1})(*FAIL)/g; + iseq $count, 2, "Expect 2 with (*SKIP)"; + iseq "@res", "aaab aaab", "Adjacent (*SKIP) works as expected"; + } + + + { # Test the (*SKIP) pattern + our $count = 0; + 'aaab' =~ /a+b?(*MARK:foo)(*SKIP)(?{$count++})(*FAIL)/; + iseq $count, 1, "Expect 1 with (*SKIP)"; + local $_ = 'aaab'; + $count = 0; + 1 while /.(*MARK:foo)(*SKIP)(?{$count++})(*FAIL)/g; + iseq $count, 4, "/.(*SKIP)/"; + $_ = 'aaabaaab'; + $count = 0; + our @res = (); + 1 while /(a+b?)(*MARK:foo)(*SKIP)(?{$count++; push @res,$1})(*FAIL)/g; + iseq $count, 2, "Expect 2 with (*SKIP)"; + iseq "@res", "aaab aaab", "Adjacent (*SKIP) works as expected"; + } + + + { # Test the (*SKIP) pattern + our $count = 0; + 'aaab' =~ /a*(*MARK:a)b?(*MARK:b)(*SKIP:a)(?{$count++})(*FAIL)/; + iseq $count, 3, "Expect 3 with *MARK:a)b?(*MARK:b)(*SKIP:a)"; + local $_ = 'aaabaaab'; + $count = 0; + our @res = (); + 1 while + /(a*(*MARK:a)b?)(*MARK:x)(*SKIP:a)(?{$count++; push @res,$1})(*FAIL)/g; + iseq $count, 5, "Expect 5 with (*MARK:a)b?)(*MARK:x)(*SKIP:a)"; + iseq "@res", "aaab b aaab b ", + "Adjacent (*MARK:a)b?)(*MARK:x)(*SKIP: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 ("(*PRUNE$name)", + ($name ? "(*MARK$name)" : "") . "(*SKIP$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 ("(*PRUNE$name)", - ($name? "(*MARK$name)" : "") - . "(*SKIP$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 ("(*PRUNE$name)", + ($name ? "(*MARK$name)" : "") . "(*SKIP$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 - local $Message = "\$REGERROR"; - 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 - local $Message = "RT#40684 tests:"; - my $s = "abc\ndef"; - my $rex = qr'^abc$'m; - ok($s =~ m/$rex/); - ok($s =~ m/^abc$/m); -} -{ - #Mindnumbingly simple test of (*THEN) - for ("ABC","BAX") { - ok(/A (*THEN) X | B (*THEN) C/x,"Simple (*THEN) test"); + + + { + # Test named commits and the $REGERROR var + local $Message = '$REGERROR'; + our $REGERROR; + for my $word (qw (bar baz bop)) { + $REGERROR = ""; + "aaaaa$word" =~ + /a+(?:bar(*COMMIT:bar)|baz(*COMMIT:baz)|bop(*COMMIT:bop))(*FAIL)/; + iseq $REGERROR, $word; + } } -} -{ - local $Message = "Relative Recursion"; - my $parens=qr/(\((?:[^()]++|(?-1))*+\))/; - local $_='foo((2*3)+4-3) + bar(2*(3+4)-1*(2-3))'; - my ($all,$one,$two)=('','',''); - if (/foo $parens \s* \+ \s* bar $parens/x) { - $all=$&; - $one=$1; - $two=$2; - } - iseq($one, '((2*3)+4-3)'); - iseq($two, '(2*(3+4)-1*(2-3))'); - iseq($all, 'foo((2*3)+4-3) + bar(2*(3+4)-1*(2-3))'); - iseq($all, $_); -} -{ - my $spaces=" "; - local $_=join 'bar',$spaces,$spaces; - our $count=0; - s/(?>\s+bar)(?{$count++})//g; - iseq($_,$spaces,"SUSPEND final string"); - iseq($count,1,"Optimiser should have prevented more than one match"); -} -{ - local $Message = "RT#36909 test"; - $^R = 'Nothing'; + { - local $^R = "Bad"; - ok('x foofoo y' =~ m{ - (foo) # $^R correctly set - (?{ "last regexp code result" }) - }x); - iseq($^R,'last regexp code result'); + local $BugId = '40684'; + local $Message = '/m in precompiled regexp'; + my $s = "abc\ndef"; + my $rex = qr'^abc$'m; + ok $s =~ m/$rex/; + ok $s =~ m/^abc$/m; } - iseq($^R,'Nothing'); + + { - local $^R = "Bad"; + #Mindnumbingly simple test of (*THEN) + for ("ABC","BAX") { + ok /A (*THEN) X | B (*THEN) C/x, "Simple (*THEN) test"; + } + } + - ok('x foofoo y' =~ m{ - (?:foo|bar)+ # $^R correctly set - (?{"last regexp code result"}) - }x); - iseq($^R,'last regexp code result'); + { + local $Message = "Relative Recursion"; + my $parens = qr/(\((?:[^()]++|(?-1))*+\))/; + local $_ = 'foo((2*3)+4-3) + bar(2*(3+4)-1*(2-3))'; + my ($all, $one, $two) = ('', '', ''); + ok /foo $parens \s* \+ \s* bar $parens/x; + iseq $1, '((2*3)+4-3)'; + iseq $2, '(2*(3+4)-1*(2-3))'; + iseq $&, 'foo((2*3)+4-3) + bar(2*(3+4)-1*(2-3))'; + iseq $&, $_; } - iseq($^R,'Nothing'); { - local $^R = "Bad"; - ok('x foofoo y' =~ m{ - (foo|bar)\1+ # $^R undefined - (?{"last regexp code result"}) - }x); - iseq($^R,'last regexp code result'); + my $spaces=" "; + local $_ = join 'bar', $spaces, $spaces; + our $count = 0; + s/(?>\s+bar)(?{$count++})//g; + iseq $_, $spaces, "SUSPEND final string"; + iseq $count, 1, "Optimiser should have prevented more than one match"; } - iseq($^R,'Nothing'); { - local $^R = "Bad"; - ok('x foofoo y' =~ m{ - (foo|bar)\1 # this time without the + - (?{"last regexp code result"}) - }x); - iseq($^R,'last regexp code result'); + local $BugId = '36909'; + local $Message = '(?: ... )? should not lose $^R'; + $^R = 'Nothing'; + { + local $^R = "Bad"; + ok 'x foofoo y' =~ m { + (foo) # $^R correctly set + (?{ "last regexp code result" }) + }x; + iseq $^R, 'last regexp code result'; + } + iseq $^R, 'Nothing'; + + { + local $^R = "Bad"; + + ok 'x foofoo y' =~ m { + (?:foo|bar)+ # $^R correctly set + (?{ "last regexp code result" }) + }x; + iseq $^R, 'last regexp code result'; + } + iseq $^R, 'Nothing'; + + { + local $^R = "Bad"; + ok 'x foofoo y' =~ m { + (foo|bar)\1+ # $^R undefined + (?{ "last regexp code result" }) + }x; + iseq $^R, 'last regexp code result'; + } + iseq $^R, 'Nothing'; + + { + local $^R = "Bad"; + ok 'x foofoo y' =~ m { + (foo|bar)\1 # This time without the + + (?{"last regexp code result"}) + }x; + iseq $^R, 'last regexp code result'; + } + iseq $^R, 'Nothing'; } - iseq($^R,'Nothing'); -} -{ - local $Message="RT 22395"; - local $TODO = "Should be L+1 not L*(L+3)/2 (L=$l)"; - our $count; - for my $l (10,100,1000) { - $count=0; - ('a' x $l) =~ /(.*)(?{$count++})[bc]/; - iseq( $count, $l + 1); + + + { + local $BugId = '22395'; + local $Message = 'Match is linear, not quadratic'; + our $count; + for my $l (10, 100, 1000) { + $count = 0; + ('a' x $l) =~ /(.*)(?{$count++})[bc]/; + local $TODO = "Should be L+1 not L*(L+3)/2 (L=$l)"; + iseq $count, $l + 1; + } } -} -{ - local $Message = "RT#22614"; - local $_='ab'; - our @len=(); - /(.){1,}(?{push @len,0+@-})(.){1,}(?{})^/; - iseq("@len","2 2 2"); -} -{ - local $Message = "RT#18209"; - my $text = ' word1 word2 word3 word4 word5 word6 '; - - my @words = ('word1', 'word3', 'word5'); - my $count; - foreach my $word (@words){ - $text =~ s/$word\s//gi; # Leave a space to seperate words in the resultant str. - # The following block is not working. - if($&){ - $count++; + + + { + local $BugId = '22614'; + local $Message = '@-/@+ should not have undefined values'; + local $_ = 'ab'; + our @len = (); + /(.){1,}(?{push @len,0+@-})(.){1,}(?{})^/; + iseq "@len", "2 2 2"; + } + + + { + local $BugId = '18209'; + local $Message = '$& set on s///'; + my $text = ' word1 word2 word3 word4 word5 word6 '; + + my @words = ('word1', 'word3', 'word5'); + my $count; + foreach my $word (@words) { + $text =~ s/$word\s//gi; # Leave a space to seperate words + # in the resultant str. + # The following block is not working. + if ($&) { + $count ++; + } + # End bad block } - # End bad block + iseq $count, 3; + iseq $text, ' word2 word4 word6 '; } - iseq($count,3); - iseq($text,' word2 word4 word6 '); -} -{ - # RT#6893 - local $_= qq(A\nB\nC\n); - my @res; - while (m#(\G|\n)([^\n]*)\n#gsx) - { - push @res,"$2"; - last if @res>3; - } - iseq("@res","A B C","RT#6893: /g pattern shouldn't infinite loop"); -} -{ - # From Message-ID: <877ixs6oa6.fsf@k75.linux.bogus> - my $dow_name= "nada"; - my $parser = "(\$dow_name) = \$time_string =~ /(D\x{e9}\\ C\x{e9}adaoin|D\x{e9}\\ Sathairn|\\w+|\x{100})/"; - my $time_string = "D\x{e9} C\x{e9}adaoin"; - eval $parser; - ok(!$@,"Test Eval worked"); - iseq($dow_name,$time_string,"UTF8 trie common prefix extraction"); -} -{ - my $v; - ($v='bar')=~/(\w+)/g; - $v='foo'; - iseq("$1",'bar','$1 is safe after /g - may fail due to specialized config in pp_hot.c') -} -{ - local $Message = "http://nntp.perl.org/group/perl.perl5.porters/118663"; - my $qr_barR1 = qr/(bar)\g-1/; - ok("foobarbarxyz" =~ $qr_barR1); - ok("foobarbarxyz" =~ qr/foo${qr_barR1}xyz/); - ok("foobarbarxyz" =~ qr/(foo)${qr_barR1}xyz/); - 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 = "RT#41010"; - my @tails=('','(?(1))','(|)','()?'); - my @quants=('*','+'); - my $doit=sub { - my $pats= shift; - for (@_) { - for my $pat (@$pats) { - for my $quant (@quants) { - for my $tail (@tails) { - my $re = "($pat$quant\$)$tail"; - ok(/$re/ && $1 eq $_,"'$_'=~/$re/"); - ok(/$re/m && $1 eq $_,"'$_'=~/$re/m"); + { + # RT#6893 + local $BugId = '6893'; + local $_ = qq (A\nB\nC\n); + my @res; + while (m#(\G|\n)([^\n]*)\n#gsx) { + push @res, "$2"; + last if @res > 3; + } + iseq "@res", "A B C", "/g pattern shouldn't infinite loop"; + } + + + { + # From Message-ID: <877ixs6oa6.fsf@k75.linux.bogus> + my $dow_name = "nada"; + my $parser = "(\$dow_name) = \$time_string =~ /(D\x{e9}\\ " . + "C\x{e9}adaoin|D\x{e9}\\ Sathairn|\\w+|\x{100})/"; + my $time_string = "D\x{e9} C\x{e9}adaoin"; + eval $parser; + ok !$@, "Test Eval worked"; + iseq $dow_name, $time_string, "UTF-8 trie common prefix extraction"; + } + + + { + my $v; + ($v = 'bar') =~ /(\w+)/g; + $v = 'foo'; + iseq "$1", 'bar', '$1 is safe after /g - may fail due ' . + 'to specialized config in pp_hot.c' + } + + + { + local $Message = "http://nntp.perl.org/group/perl.perl5.porters/118663"; + my $qr_barR1 = qr/(bar)\g-1/; + ok "foobarbarxyz" =~ $qr_barR1; + ok "foobarbarxyz" =~ qr/foo${qr_barR1}xyz/; + ok "foobarbarxyz" =~ qr/(foo)${qr_barR1}xyz/; + ok "foobarbarxyz" =~ qr/(foo)(bar)\g{-1}xyz/; + ok "foobarbarxyz" =~ qr/(foo${qr_barR1})xyz/; + ok "foobarbarxyz" =~ qr/(foo(bar)\g{-1})xyz/; + } + + + { + local $BugId = '41010'; + local $Message = 'No optimizer bug'; + my @tails = ('', '(?(1))', '(|)', '()?'); + my @quants = ('*','+'); + my $doit = sub { + my $pats = shift; + for (@_) { + for my $pat (@$pats) { + for my $quant (@quants) { + for my $tail (@tails) { + my $re = "($pat$quant\$)$tail"; + ok /$re/ && $1 eq $_, "'$_' =~ /$re/"; + ok /$re/m && $1 eq $_, "'$_' =~ /$re/m"; + } } } } - } - }; - - my @dpats=( - '\d', - '[1234567890]', - '(1|[23]|4|[56]|[78]|[90])', - '(?:1|[23]|4|[56]|[78]|[90])', - '(1|2|3|4|5|6|7|8|9|0)', - '(?:1|2|3|4|5|6|7|8|9|0)', - ); - my @spats=('[ ]',' ','( |\t)','(?: |\t)','[ \t]','\s'); - my @sstrs=(' '); - my @dstrs=('12345'); - $doit->(\@spats,@sstrs); - $doit->(\@dpats,@dstrs); -} -{ - local $Message = "\$REGMARK"; - our @r=(); - ok('foofoo' =~ /foo (*MARK:foo) (?{push @r,$REGMARK}) /x); - iseq("@r","foo"); - iseq($REGMARK,"foo"); - ok('foofoo' !~ /foo (*MARK:foo) (*FAIL) /x); - ok(!$REGMARK); - iseq($REGERROR,'foo'); -} -{ - my $x; - $x = "abc.def.ghi.jkl"; - $x =~ s/.*\K\..*//; - ok($x eq "abc.def.ghi"); - - $x = "one two three four"; - $x =~ s/o+ \Kthree//g; - ok($x eq "one two four"); - - $x = "abcde"; - $x =~ s/(.)\K/$1/g; - ok($x eq "aabbccddee"); -} -sub kt -{ - return '4' if $_[0] eq '09028623'; -} + }; + + my @dpats = ('\d', + '[1234567890]', + '(1|[23]|4|[56]|[78]|[90])', + '(?:1|[23]|4|[56]|[78]|[90])', + '(1|2|3|4|5|6|7|8|9|0)', + '(?:1|2|3|4|5|6|7|8|9|0)'); + my @spats = ('[ ]', ' ', '( |\t)', '(?: |\t)', '[ \t]', '\s'); + my @sstrs = (' '); + my @dstrs = ('12345'); + $doit -> (\@spats, @sstrs); + $doit -> (\@dpats, @dstrs); + } -{ # Nested EVAL using PL_curpm (via $1 or friends) - my $re; - our $grabit = qr/ ([0-6][0-9]{7}) (??{ kt $1 }) [890] /x; - $re = qr/^ ( (??{ $grabit }) ) $ /x; - my @res = '0902862349' =~ $re; - iseq(join("-",@res),"0902862349", - 'PL_curpm is set properly on nested eval'); - - our $qr = qr/ (o) (??{ $1 }) /x; - ok( 'boob'=~/( b (??{ $qr }) b )/x && 1, - "PL_curpm, nested eval"); -} -{ - use charnames ":full"; - ok("\N{ROMAN NUMERAL ONE}" =~ /\p{Alphabetic}/, "I =~ Alphabetic"); - ok("\N{ROMAN NUMERAL ONE}" =~ /\p{Uppercase}/, "I =~ Uppercase"); - ok("\N{ROMAN NUMERAL ONE}" !~ /\p{Lowercase}/, "I !~ Lowercase"); - ok("\N{ROMAN NUMERAL ONE}" =~ /\p{IDStart}/, "I =~ ID_Start"); - ok("\N{ROMAN NUMERAL ONE}" =~ /\p{IDContinue}/, "I =~ ID_Continue"); - ok("\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Alphabetic}/, "i =~ Alphabetic"); - ok("\N{SMALL ROMAN NUMERAL ONE}" !~ /\p{Uppercase}/, "i !~ Uppercase"); - ok("\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Lowercase}/, "i =~ Lowercase"); - ok("\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{IDStart}/, "i =~ ID_Start"); - ok("\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{IDContinue}/, "i =~ ID_Continue"); -} + { + local $Message = '$REGMARK'; + our @r = (); + our ($REGMARK, $REGERROR); + ok 'foofoo' =~ /foo (*MARK:foo) (?{push @r,$REGMARK}) /x; + iseq "@r","foo"; + iseq $REGMARK, "foo"; + ok 'foofoo' !~ /foo (*MARK:foo) (*FAIL) /x; + ok !$REGMARK; + iseq $REGERROR, 'foo'; + } + -{ -# requirement of Unicode Technical Standard #18, 1.7 Code Points -# cf. http://www.unicode.org/reports/tr18/#Supplementary_Characters - for my $u (0x7FF, 0x800, 0xFFFF, 0x10000) { - no warnings 'utf8'; # oops - my $c = chr $u; - my $x = sprintf '%04X', $u; - ok( "A${c}B" =~ /A[\0-\x{10000}]B/, "unicode range - $x"); + { + local $Message = '\K test'; + my $x; + $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"; + } + + + { + sub kt { + return '4' if $_[0] eq '09028623'; + } + # Nested EVAL using PL_curpm (via $1 or friends) + my $re; + our $grabit = qr/ ([0-6][0-9]{7}) (??{ kt $1 }) [890] /x; + $re = qr/^ ( (??{ $grabit }) ) $ /x; + my @res = '0902862349' =~ $re; + iseq join ("-", @res), "0902862349", + 'PL_curpm is set properly on nested eval'; + + our $qr = qr/ (o) (??{ $1 }) /x; + ok 'boob'=~/( b (??{ $qr }) b )/x && 1, "PL_curpm, nested eval"; } -} -{ - my $res=""; - if ('1' =~ /(?|(?1)|(?2))/) { - $res = "@{$- {digit}}"; + { + use charnames ":full"; + ok "\N{ROMAN NUMERAL ONE}" =~ /\p{Alphabetic}/, "I =~ Alphabetic"; + ok "\N{ROMAN NUMERAL ONE}" =~ /\p{Uppercase}/, "I =~ Uppercase"; + ok "\N{ROMAN NUMERAL ONE}" !~ /\p{Lowercase}/, "I !~ Lowercase"; + ok "\N{ROMAN NUMERAL ONE}" =~ /\p{IDStart}/, "I =~ ID_Start"; + ok "\N{ROMAN NUMERAL ONE}" =~ /\p{IDContinue}/, "I =~ ID_Continue"; + ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Alphabetic}/, "i =~ Alphabetic"; + ok "\N{SMALL ROMAN NUMERAL ONE}" !~ /\p{Uppercase}/, "i !~ Uppercase"; + ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Lowercase}/, "i =~ Lowercase"; + ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{IDStart}/, "i =~ ID_Start"; + ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{IDContinue}/, "i =~ ID_Continue" } - iseq($res,"1", - "Check that (?|...) doesnt cause dupe entries in the names array"); - #--- - $res=""; - if ('11' =~ /(?|(?1)|(?2))(?&digit)/) { - $res = "@{$- {digit}}"; + + + { + # requirement of Unicode Technical Standard #18, 1.7 Code Points + # cf. http://www.unicode.org/reports/tr18/#Supplementary_Characters + for my $u (0x7FF, 0x800, 0xFFFF, 0x10000) { + no warnings 'utf8'; # oops + my $c = chr $u; + my $x = sprintf '%04X', $u; + ok "A${c}B" =~ /A[\0-\x{10000}]B/, "Unicode range - $x"; + } } - iseq($res, "1", - "Check that (?&..) to a buffer inside a (?|...) goes to the leftmost"); -} -{ - use warnings; - local $Message = "ASCII pattern that really is utf8"; - my @w; - local $SIG{__WARN__}=sub{push @w,"@_"}; - my $c=qq(\x{DF}); - ok($c=~/${c}|\x{100}/); - ok(@w==0); -} -{ - local $Message = "corruption of match results of qr// across scopes"; - my $qr=qr/(fo+)(ba+r)/; - 'foobar'=~/$qr/; - iseq("$1$2","foobar"); - { - 'foooooobaaaaar'=~/$qr/; - iseq("$1$2",'foooooobaaaaar'); - } - iseq("$1$2","foobar"); -} -{ - local $Message = "HORIZWS"; - local $_="\t \r\n \n \t".chr(11)."\n"; - s/\H/H/g; - s/\h/h/g; - iseq($_,"hhHHhHhhHH"); - $_="\t \r\n \n \t".chr(11)."\n"; - utf8::upgrade($_); - s/\H/H/g; - s/\h/h/g; - iseq($_,"hhHHhHhhHH"); -} -{ - local $Message = "Various whitespace special patterns"; - my @h=map { chr( $_ ) } ( - 0x09, 0x20, 0xa0, 0x1680, 0x180e, 0x2000, 0x2001, 0x2002, - 0x2003, 0x2004, 0x2005, 0x2006, 0x2007, 0x2008, 0x2009, 0x200a, - 0x202f, 0x205f, 0x3000 - ); - my @v=map { chr( $_ ) } ( 0x0a, 0x0b, 0x0c, 0x0d, 0x85, 0x2028, 0x2029 ); - my @lb=( "\x0D\x0A", - map { chr( $_ ) } ( 0x0A..0x0D,0x85,0x2028,0x2029 )); - foreach my $t ([\@h,qr/\h/,qr/\h+/],[\@v,qr/\v/,qr/\v+/],[\@lb,qr/\R/,qr/\R+/],){ - my $ary=shift @$t; - foreach my $pat (@$t) { - foreach my $str (@$ary) { - ok($str=~/($pat)/,$pat); - iseq($1,$str,$pat); - utf8::upgrade($str); - ok($str=~/($pat)/,"Upgraded string - $pat"); - iseq($1,$str,"Upgraded string - $pat"); + + { + my $res=""; + + if ('1' =~ /(?|(?1)|(?2))/) { + $res = "@{$- {digit}}"; + } + iseq $res, "1", + "Check that (?|...) doesnt cause dupe entries in the names array"; + + $res = ""; + if ('11' =~ /(?|(?1)|(?2))(?&digit)/) { + $res = "@{$- {digit}}"; + } + iseq $res, "1", "Check that (?&..) to a buffer inside " . + "a (?|...) goes to the leftmost"; + } + + + { + use warnings; + local $Message = "ASCII pattern that really is UTF-8"; + my @w; + local $SIG {__WARN__} = sub {push @w, "@_"}; + my $c = qq (\x{DF}); + ok $c =~ /${c}|\x{100}/; + ok @w == 0; + } + + + { + local $Message = "Corruption of match results of qr// across scopes"; + my $qr = qr/(fo+)(ba+r)/; + 'foobar' =~ /$qr/; + iseq "$1$2", "foobar"; + { + 'foooooobaaaaar' =~ /$qr/; + iseq "$1$2", 'foooooobaaaaar'; + } + iseq "$1$2", "foobar"; + } + + + { + local $Message = "HORIZWS"; + local $_ = "\t \r\n \n \t".chr(11)."\n"; + s/\H/H/g; + s/\h/h/g; + iseq $_, "hhHHhHhhHH"; + $_ = "\t \r\n \n \t" . chr (11) . "\n"; + utf8::upgrade ($_); + s/\H/H/g; + s/\h/h/g; + iseq $_, "hhHHhHhhHH"; + } + + + { + local $Message = "Various whitespace special patterns"; + my @h = map {chr $_} 0x09, 0x20, 0xa0, 0x1680, 0x180e, 0x2000, + 0x2001, 0x2002, 0x2003, 0x2004, 0x2005, 0x2006, + 0x2007, 0x2008, 0x2009, 0x200a, 0x202f, 0x205f, + 0x3000; + my @v = map {chr $_} 0x0a, 0x0b, 0x0c, 0x0d, 0x85, 0x2028, + 0x2029; + my @lb = ("\x0D\x0A", map {chr $_} 0x0A .. 0x0D, 0x85, 0x2028, 0x2029); + foreach my $t ([\@h, qr/\h/, qr/\h+/], + [\@v, qr/\v/, qr/\v+/], + [\@lb, qr/\R/, qr/\R+/],) { + my $ary = shift @$t; + foreach my $pat (@$t) { + foreach my $str (@$ary) { + ok $str =~ /($pat)/, $pat; + iseq $1, $str, $pat; + utf8::upgrade ($str); + ok $str =~ /($pat)/, "Upgraded string - $pat"; + iseq $1, $str, "Upgraded string - $pat"; + } } } } -} -{ - local $Message = "Check that \\xDF match properly in its various forms"; - # test that \xDF matches properly. this is pretty hacky stuff, - # but its actually needed. the malarky with '-' is to prevent - # compilation caching from playing any role in the test. - my @df= (chr(0xDF),'-',chr(0xDF)); - utf8::upgrade($df[2]); - my @strs= ('ss','sS','Ss','SS',chr(0xDF)); - my @ss= map { ("$_", "$_") } @strs; - utf8::upgrade($ss[$_*2+1]) for 0..$#strs; - - for my $ssi (0..$#ss) { - for my $dfi (0..$#df) { - my $pat= $df[$dfi]; - my $str= $ss[$ssi]; - my $utf_df= ($dfi > 1) ? 'utf8' : ''; - my $utf_ss= ($ssi % 2) ? 'utf8' : ''; - (my $sstr=$str)=~s/\xDF/\\xDF/; - - if ($utf_df || $utf_ss || length($ss[$ssi])==1) { - my $ret= $str=~/$pat/i; - next if $pat eq '-'; - ok($ret, - "\"$sstr\"=~/\\xDF/i (str is @{[$utf_ss||'latin']}, pat is @{[$utf_df||'latin']})"); - } else { - my $ret= $str !~ /$pat/i; - next if $pat eq '-'; - ok($ret, - "\"$sstr\"!~/\\xDF/i (str is @{[$utf_ss||'latin']}, pat is @{[$utf_df||'latin']})"); + + + { + local $Message = "Check that \\xDF match properly in its various forms"; + # Test that \xDF matches properly. this is pretty hacky stuff, + # but its actually needed. The malarky with '-' is to prevent + # compilation caching from playing any role in the test. + my @df = (chr (0xDF), '-', chr (0xDF)); + utf8::upgrade ($df [2]); + my @strs = ('ss', 'sS', 'Ss', 'SS', chr (0xDF)); + my @ss = map {("$_", "$_")} @strs; + utf8::upgrade ($ss [$_ * 2 + 1]) for 0 .. $#strs; + + for my $ssi (0 .. $#ss) { + for my $dfi (0 .. $#df) { + my $pat = $df [$dfi]; + my $str = $ss [$ssi]; + my $utf_df = ($dfi > 1) ? 'utf8' : ''; + my $utf_ss = ($ssi % 2) ? 'utf8' : ''; + (my $sstr = $str) =~ s/\xDF/\\xDF/; + + if ($utf_df || $utf_ss || length ($ss [$ssi]) == 1) { + my $ret = $str =~ /$pat/i; + next if $pat eq '-'; + ok $ret, "\"$sstr\" =~ /\\xDF/i " . + "(str is @{[$utf_ss||'latin']}, pat is " . + "@{[$utf_df||'latin']})"; + } + else { + my $ret = $str !~ /$pat/i; + next if $pat eq '-'; + ok $ret, "\"$sstr\" !~ /\\xDF/i " . + "(str is @{[$utf_ss||'latin']}, pat is " . + "@{[$utf_df||'latin']})"; + } } } } -} -{ - local $Message = "BBC(Bleadperl Breaks CPAN) Today: String::Multibyte"; - my $re = qr/(?:[\x00-\xFF]{4})/; - my $hyp = "\0\0\0-"; - my $esc = "\0\0\0\\"; - my $str = "$esc$hyp$hyp$esc$esc"; - my @a = ($str =~ /\G(?:\Q$esc$esc\E|\Q$esc$hyp\E|$re)/g); - iseq(0+@a,3); - iseq(join('=', @a),"$esc$hyp=$hyp=$esc$esc"); -} -# test for keys in %+ and %- -{ - my $_ = "abcdef"; - /(?a)|(?b)/; - iseq( (join ",", sort keys %+), "foo" ); - iseq( (join ",", sort keys %-), "foo" ); - iseq( (join ",", sort values %+), "a" ); - iseq( (join ",", sort map "@$_", values %-), "a " ); - /(?a)(?b)(?.)/; - iseq( (join ",", sort keys %+), "bar,quux" ); - iseq( (join ",", sort keys %-), "bar,quux" ); - iseq( (join ",", sort values %+), "a,c" ); # leftmost - iseq( (join ",", sort map "@$_", values %-), "a b,c" ); - /(?a)(?c)?/; # second buffer won't capture - iseq( (join ",", sort keys %+), "un" ); - iseq( (join ",", sort keys %-), "deux,un" ); - iseq( (join ",", sort values %+), "a" ); - iseq( (join ",", sort map "@$_", values %-), ",a" ); -} + { + local $Message = "BBC(Bleadperl Breaks CPAN) Today: String::Multibyte"; + my $re = qr/(?:[\x00-\xFF]{4})/; + my $hyp = "\0\0\0-"; + my $esc = "\0\0\0\\"; -# length() on captures, the numbered ones end up in Perl_magic_len -{ - my $_ = "aoeu \xe6var ook"; - /^ \w+ \s (?\S+)/x; + my $str = "$esc$hyp$hyp$esc$esc"; + my @a = ($str =~ /\G(?:\Q$esc$esc\E|\Q$esc$hyp\E|$re)/g); - iseq( length($`), 0, 'length $`' ); - iseq( length($'), 4, q[length $'] ); - iseq( length($&), 9, 'length $&' ); - iseq( length($1), 4, 'length $1' ); - iseq( length($+{eek}), 4, 'length $+{eek} == length $1' ); -} + iseq @a,3; + local $" = "="; + iseq "@a","$esc$hyp=$hyp=$esc$esc"; + } -{ - my $ok=-1; - - $ok=exists($-{x}) ? 1 : 0 - if 'bar'=~/(?foo)|bar/; - iseq($ok,1,'$-{x} exists after "bar"=~/(?foo)|bar/'); - iseq(scalar(%+), 0, 'scalar %+ == 0 after "bar"=~/(?foo)|bar/'); - iseq(scalar(%-), 1, 'scalar %- == 1 after "bar"=~/(?foo)|bar/'); - - $ok=-1; - $ok=exists($+{x}) ? 1 : 0 - if 'bar'=~/(?foo)|bar/; - iseq($ok,0,'$+{x} not exists after "bar"=~/(?foo)|bar/'); - iseq(scalar(%+), 0, 'scalar %+ == 0 after "bar"=~/(?foo)|bar/'); - iseq(scalar(%-), 1, 'scalar %- == 1 after "bar"=~/(?foo)|bar/'); - - $ok=-1; - $ok=exists($-{x}) ? 1 : 0 - if 'foo'=~/(?foo)|bar/; - iseq($ok,1,'$-{x} exists after "foo"=~/(?foo)|bar/'); - iseq(scalar(%+), 1, 'scalar %+ == 1 after "foo"=~/(?foo)|bar/'); - iseq(scalar(%-), 1, 'scalar %- == 1 after "foo"=~/(?foo)|bar/'); - - $ok=-1; - $ok=exists($+{x}) ? 1 : 0 - if 'foo'=~/(?foo)|bar/; - iseq($ok,1,'$+{x} exists after "foo"=~/(?foo)|bar/'); -} -{ - local $_; - ($_ = 'abc')=~/(abc)/g; - $_ = '123'; - iseq("$1",'abc',"/g leads to unsafe match vars: $1"); -} -{ - local $Message="Message-ID: <20070818091501.7eff4831@r2d2>"; - my $str= ""; - for(0..5){ - my @x; - $str .= "@x"; # this should ALWAYS be the empty string - 'a'=~/(a|)/; - push @x,1; - } - iseq(length($str),"0","Trie scope error, string should be empty"); - $str=""; - my @foo = ('a')x5; - for (@foo) { - my @bar; - $str .= "@bar"; - s/a|/push @bar, 1/e; - } - iseq(length($str),"0","Trie scope error, string should be empty"); -} -{ -# [perl #45605] Regexp failure with utf8-flagged and byte-flagged string - my $utf_8 = "\xd6schel"; - utf8::upgrade($utf_8); - $utf_8 =~ m{(\xd6|Ö)schel}; - iseq($1,"\xd6","#45605"); -} + { + # Test for keys in %+ and %- + local $Message = 'Test keys in %+ and %-'; + no warnings 'uninitialized'; + my $_ = "abcdef"; + /(?a)|(?b)/; + iseq ((join ",", sort keys %+), "foo"); + iseq ((join ",", sort keys %-), "foo"); + iseq ((join ",", sort values %+), "a"); + iseq ((join ",", sort map "@$_", values %-), "a "); + /(?a)(?b)(?.)/; + iseq ((join ",", sort keys %+), "bar,quux"); + iseq ((join ",", sort keys %-), "bar,quux"); + iseq ((join ",", sort values %+), "a,c"); # leftmost + iseq ((join ",", sort map "@$_", values %-), "a b,c"); + /(?a)(?c)?/; # second buffer won't capture + iseq ((join ",", sort keys %+), "un"); + iseq ((join ",", sort keys %-), "deux,un"); + iseq ((join ",", sort values %+), "a"); + iseq ((join ",", sort map "@$_", values %-), ",a"); + } + + + { + # length() on captures, the numbered ones end up in Perl_magic_len + my $_ = "aoeu \xe6var ook"; + /^ \w+ \s (?\S+)/x; + + iseq length ($`), 0, q[length $`]; + iseq length ($'), 4, q[length $']; + iseq length ($&), 9, q[length $&]; + iseq length ($1), 4, q[length $1]; + iseq length ($+{eek}), 4, q[length $+{eek} == length $1]; + } + + + { + my $ok = -1; + + $ok = exists ($-{x}) ? 1 : 0 if 'bar' =~ /(?foo)|bar/; + iseq $ok, 1, '$-{x} exists after "bar"=~/(?foo)|bar/'; + iseq scalar (%+), 0, 'scalar %+ == 0 after "bar"=~/(?foo)|bar/'; + iseq scalar (%-), 1, 'scalar %- == 1 after "bar"=~/(?foo)|bar/'; + + $ok = -1; + $ok = exists ($+{x}) ? 1 : 0 if 'bar' =~ /(?foo)|bar/; + iseq $ok, 0, '$+{x} not exists after "bar"=~/(?foo)|bar/'; + iseq scalar (%+), 0, 'scalar %+ == 0 after "bar"=~/(?foo)|bar/'; + iseq scalar (%-), 1, 'scalar %- == 1 after "bar"=~/(?foo)|bar/'; + + $ok = -1; + $ok = exists ($-{x}) ? 1 : 0 if 'foo' =~ /(?foo)|bar/; + iseq $ok, 1, '$-{x} exists after "foo"=~/(?foo)|bar/'; + iseq scalar (%+), 1, 'scalar %+ == 1 after "foo"=~/(?foo)|bar/'; + iseq scalar (%-), 1, 'scalar %- == 1 after "foo"=~/(?foo)|bar/'; + + $ok = -1; + $ok = exists ($+{x}) ? 1 : 0 if 'foo'=~/(?foo)|bar/; + iseq $ok, 1, '$+{x} exists after "foo"=~/(?foo)|bar/'; + } + + + { + local $_; + ($_ = 'abc') =~ /(abc)/g; + $_ = '123'; + iseq "$1", 'abc', "/g leads to unsafe match vars: $1"; + } + + + { + local $Message = 'Message-ID: <20070818091501.7eff4831@r2d2>'; + my $str = ""; + for (0 .. 5) { + my @x; + $str .= "@x"; # this should ALWAYS be the empty string + 'a' =~ /(a|)/; + push @x, 1; + } + iseq length ($str), 0, "Trie scope error, string should be empty"; + $str = ""; + my @foo = ('a') x 5; + for (@foo) { + my @bar; + $str .= "@bar"; + s/a|/push @bar, 1/e; + } + iseq length ($str), 0, "Trie scope error, string should be empty"; + } + -{ - # Regardless of utf8ness any character matches itself when - # doing a case insensitive match. See also [perl #36207] - for my $o (0..255) { - my @ch=(chr($o),chr($o)); - utf8::upgrade($ch[1]); - for my $u_str (0,1) { - for my $u_pat (0,1) { - ok( $ch[$u_str]=~/\Q$ch[$u_pat]\E/i, - "\$c=~/\$c/i : chr($o) : u_str=$u_str u_pat=$u_pat"); - ok( $ch[$u_str]=~/\Q$ch[$u_pat]\E|xyz/i, - "# \$c=~/\$c|xyz/i : chr($o) : u_str=$u_str u_pat=$u_pat"); + { + local $BugId = '45605'; + # [perl #45605] Regexp failure with utf8-flagged and byte-flagged string + + my $utf_8 = "\xd6schel"; + utf8::upgrade ($utf_8); + $utf_8 =~ m {(\xd6|Ö)schel}; + iseq $1, "\xd6", "Upgrade error"; + } + + + { + # Regardless of utf8ness any character matches itself when + # doing a case insensitive match. See also [perl #36207] + local $BugId = '36207'; + for my $o (0 .. 255) { + my @ch = (chr ($o), chr ($o)); + utf8::upgrade ($ch [1]); + for my $u_str (0, 1) { + for my $u_pat (0, 1) { + ok $ch [$u_str] =~ /\Q$ch[$u_pat]\E/i, + "\$c =~ /\$c/i : chr ($o) : u_str = $u_str u_pat = $u_pat"; + ok $ch [$u_str] =~ /\Q$ch[$u_pat]\E|xyz/i, + "\$c=~/\$c|xyz/i : chr($o) : u_str = $u_str u_pat = $u_pat"; + } } } } -} -{ - my $a = 3; "" =~ /(??{ $a })/; - my $b = $a; - iseq($b, $a, "copy of scalar used for postponed subexpression"); -} -{ - local $Message = "\$REGMARK in replacement -- Bug #49190"; - my $_ = "A"; - s/(*:B)A/$REGMARK/; - iseq $_, "B"; - $_ = "CCCCBAA"; - s/(*:X)A+|(*:Y)B+|(*:Z)C+/$REGMARK/g; - iseq $_, "ZYX"; -} -{ - our @ctl_n=(); - our @plus=(); - our $nested_tags; - $nested_tags = qr{ - < - (\w+) - (?{ - push @ctl_n,$^N; - push @plus,$+; - }) - > - (??{$nested_tags})* - - }x; - - my $match= '' =~ m/^$nested_tags$/; - ok($match,'nested construct matches'); - iseq("@ctl_n","bla blubb",'$^N inside of (?{}) works as expected'); - iseq("@plus","bla blubb",'$+ inside of (?{}) works as expected'); -} -# test for bug #52658 -{ - my $reg = '../xxx/'; - my @te = ($reg =~ m{^(/?(?:\.\./)*)}, $reg =~ s/(x)/'b'/eg > 1 ? '##' : '++'); - #print "with bug: (0)=$te[0] (1)=$te[1] reg=$reg\n"; - iseq($reg, '../bbb/'); - iseq($te[0], '../'); -} -SKIP: { - # XXX: This set of tests is essentially broken, POSIX character classes - # should not have differing definitions under unicode. - # There are property names for that. - unless ($ordA == 65) { skip("Assumes ASCII", 4) } - - my @notIsPunct = grep {/[[:punct:]]/ and not /\p{IsPunct}/} - map {chr} 0x20..0x7f; - iseq( join('', @notIsPunct), '$+<=>^`|~', - '[:punct:] disagress with IsPunct on Symbols'); - - my @isPrint = grep {not/[[:print:]]/ and /\p{IsPrint}/} - map {chr} 0..0x1f, 0x7f..0x9f; - iseq( join('', @isPrint), "\x09\x0a\x0b\x0c\x0d\x85", - 'IsPrint disagrees with [:print:] on control characters'); - - my @isPunct = grep {/[[:punct:]]/ != /\p{IsPunct}/} - map {chr} 0x80..0xff; - iseq( join('', @isPunct), "\xa1\xab\xb7\xbb\xbf", # ¡ « · » ¿ - 'IsPunct disagrees with [:punct:] outside ASCII'); - - my @isPunctLatin1 = eval q{ - use encoding 'latin1'; - grep {/[[:punct:]]/ != /\p{IsPunct}/} map {chr} 0x80..0xff; - }; - if( $@ ){ skip( $@, 1); } - if( $ENV{REAL_POSIX_CC} ) { skip ('PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS set to 0',1); } - iseq( join('', @isPunctLatin1), '', - 'IsPunct agrees with [:punct:] with explicit Latin1'); -} - -# [perl #60034] -{ - my $a = "xyzt" x 8192; - local $TODO = "#60034"; - ok($a =~ /\A(?>[a-z])*\z/, '(?>) does not cause wrongness on long string'); - my $b = $a . chr 256; - chop $b; - undef $TODO; - iseq($a, $b); - $TODO = "#60034"; - ok($b =~ /\A(?>[a-z])*\z/, - '(?>) does not cause wrongness on long string with UTF-8'); -} + { + our $a = 3; "" =~ /(??{ $a })/; + our $b = $a; + iseq $b, $a, "Copy of scalar used for postponed subexpression"; + } -# Test counter is at bottom of file. Put new tests above here. -#------------------------------------------------------------------- -# Keep the following tests last -- they may crash perl -{ - # RT#19049 / RT#38869 - my @list = ( - 'ab cdef', # matches regex - ( 'e' x 40000 ) .'ab c' # matches not, but 'ab c' matches part of it - ); - my $y; - my $x; - foreach (@list) { - m/ab(.+)cd/i; # the ignore-case seems to be important - $y = $1; # use $1, which might not be from the last match! - $x = substr($list[0],$-[0],$+[0]-$-[0]); - } - iseq($y,' ', - 'pattern in a loop, failure should not affect previous success'); - iseq($x,'ab cd', - 'pattern in a loop, failure should not affect previous success'); -} + { + local $BugId = '49190'; + local $Message = '$REGMARK in replacement'; + our $REGMARK; + my $_ = "A"; + ok s/(*:B)A/$REGMARK/; + iseq $_, "B"; + $_ = "CCCCBAA"; + ok s/(*:X)A+|(*:Y)B+|(*:Z)C+/$REGMARK/g; + iseq $_, "ZYX"; + } -ok(("a" x (2**15 - 10)) =~ /^()(a|bb)*$/, "Recursive stack cracker: #24274") - or print "# Unexpected outcome: should pass or crash perl\n"; - -ok((q(a)x 100) =~ /^(??{'(.)'x 100})/, - "Regexp /^(??{'(.)'x 100})/ crashes older perls") - or print "# Unexpected outcome: should pass or crash perl\n"; - -eval '/\k/'; -ok($@=~/\QSequence \k... not terminated in regex;\E/); - -{ - local $Message = "substitution with lookahead (possible segv)"; - $_="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!"); -} -# [perl #45337] utf8 + "[a]a{2}" + /$.../ = panic: sv_len_utf8 cache + { + our @ctl_n = (); + our @plus = (); + our $nested_tags; + $nested_tags = qr{ + < + (\w+) + (?{ + push @ctl_n,$^N; + push @plus,$+; + }) + > + (??{$nested_tags})* + + }x; + + my $match = '' =~ m/^$nested_tags$/; + ok $match, 'nested construct matches'; + iseq "@ctl_n", "bla blubb", '$^N inside of (?{}) works as expected'; + iseq "@plus", "bla blubb", '$+ inside of (?{}) works as expected'; + } + -{ - local ${^UTF8CACHE} = -1; - my $s="[a]a{2}"; - utf8::upgrade $s; - ok("aaa" =~ /$s/, "#45337"); -} + { + local $BugId = '52658'; + local $Message = 'Substitution evaluation in list context'; + my $reg = '../xxx/'; + my @te = ($reg =~ m{^(/?(?:\.\./)*)}, + $reg =~ s/(x)/'b'/eg > 1 ? '##' : '++'); + iseq $reg, '../bbb/'; + iseq $te [0], '../'; + } -# Put new tests above the dotted line about a page above this comment -iseq(0+$::test,$::TestCount,"Got the right number of tests!"); -} # end of sub pat_tests + SKIP: { + # XXX: This set of tests is essentially broken, POSIX character classes + # should not have differing definitions under Unicode. + # There are property names for that. + skip "Tests assume ASCII", 4 unless $IS_ASCII; + + my @notIsPunct = grep {/[[:punct:]]/ and not /\p{IsPunct}/} + map {chr} 0x20 .. 0x7f; + iseq join ('', @notIsPunct), '$+<=>^`|~', + '[:punct:] disagress with IsPunct on Symbols'; + + my @isPrint = grep {not /[[:print:]]/ and /\p{IsPrint}/} + map {chr} 0 .. 0x1f, 0x7f .. 0x9f; + iseq join ('', @isPrint), "\x09\x0a\x0b\x0c\x0d\x85", + 'IsPrint disagrees with [:print:] on control characters'; + + my @isPunct = grep {/[[:punct:]]/ != /\p{IsPunct}/} + map {chr} 0x80 .. 0xff; + iseq join ('', @isPunct), "\xa1\xab\xb7\xbb\xbf", # ¡ « · » ¿ + 'IsPunct disagrees with [:punct:] outside ASCII'; + + my @isPunctLatin1 = eval q { + use encoding 'latin1'; + grep {/[[:punct:]]/ != /\p{IsPunct}/} map {chr} 0x80 .. 0xff; + }; + skip "Eval failed ($@)", 1 if $@; + skip "PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS set to 0", 1 + if $ENV {REAL_POSIX_CC}; + iseq join ('', @isPunctLatin1), '', + 'IsPunct agrees with [:punct:] with explicit Latin1'; + } -# Don't forget to update this! -BEGIN { - $::TestCount = 4038; - print "1..$::TestCount\n"; -} -"Truth"; + { + local $BugId = '60034'; + local $TODO = "See bug 60034"; + my $a = "xyzt" x 8192; + ok $a =~ /\A(?>[a-z])*\z/, + '(?>) does not cause wrongness on long string'; + my $b = $a . chr 256; + chop $b; + { + local $TODO; + iseq $a, $b; + } + ok $b =~ /\A(?>[a-z])*\z/, + '(?>) does not cause wrongness on long string with UTF-8'; + } + + + # + # Keep the following tests last -- they may crash perl + # + print "# Tests that follow may crash perl\n"; + { + local $BugId = '19049/38869'; + local $Message = 'Pattern in a loop, failure should not ' . + 'affect previous success'; + my @list = ( + 'ab cdef', # Matches regex + ('e' x 40000 ) .'ab c' # Matches not, but 'ab c' matches part of it + ); + my $y; + my $x; + foreach (@list) { + m/ab(.+)cd/i; # The ignore-case seems to be important + $y = $1; # Use $1, which might not be from the last match! + $x = substr ($list [0], $- [0], $+ [0] - $- [0]); + } + iseq $y, ' '; + iseq $x, 'ab cd'; + } + + + { + local $BugId = '24274'; + + ok (("a" x (2 ** 15 - 10)) =~ /^()(a|bb)*$/, "Recursive stack cracker"); + ok ((q(a)x 100) =~ /^(??{'(.)'x 100})/, + "Regexp /^(??{'(.)'x 100})/ crashes older perls"); + } + + + { + eval '/\k/'; + ok $@ =~ /\QSequence \k... not terminated in regex;\E/, + 'Lone \k not allowed'; + } + + + { + local $Message = "Substitution with lookahead (possible segv)"; + $_ = "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!"; + } + + + { + # [perl #45337] utf8 + "[a]a{2}" + /$.../ = panic: sv_len_utf8 cache + local $BugId = '45337'; + local ${^UTF8CACHE} = -1; + local $Message = "Shouldn't panic"; + my $s = "[a]a{2}"; + utf8::upgrade $s; + ok "aaa" =~ /$s/; + } + + # + # This should be the last test. + # + iseq $test + 1, $EXPECTED_TESTS, "Got the right number of tests!"; + +} # End of sub run_tests + +1; diff --git a/t/op/regexp_unicode_prop.t b/t/op/regexp_unicode_prop.t new file mode 100644 index 0000000..8cc09f1 --- /dev/null +++ b/t/op/regexp_unicode_prop.t @@ -0,0 +1,303 @@ +#!./perl +# +# Tests that have to do with checking whether characters have (or not have) +# certain Unicode properties; belong (or not belong) to blocks, scripts, etc. +# + +use strict; +use warnings; +use 5.010; + +my $IS_EBCDIC = ord ('A') == 193; + +sub run_tests; + +# +# This is the data to test. +# +# This is a hash; keys are the property to test. +# Values are arrays containing characters to test. The characters can +# have the following formats: +# '\N{CHARACTER NAME}' - Use character with that name +# '\x{1234}' - Use character with that hex escape +# '0x1234' - Use chr() to get that character +# "a" - Character to use +# +# If a character entry starts with ! the character does not belong to the class +# +# If the class is just single letter, we use both \pL and \p{L} +# + +use charnames ':full'; + +my @CLASSES = ( + L => ["a", "A"], + Ll => ["b", "!B"], + Lu => ["!c", "C"], + IsLl => ["d", "!D"], + IsLu => ["!e", "E"], + LC => ["f", "!1"], + 'L&' => ["g", "!2"], + 'Lowercase Letter' => ["h", "!H"], + + Common => ["!i", "3"], + Inherited => ["!j", '\x{300}'], + + InBasicLatin => ['\N{LATIN CAPITAL LETTER A}'], + InLatin1Supplement => ['\N{LATIN CAPITAL LETTER A WITH GRAVE}'], + InLatinExtendedA => ['\N{LATIN CAPITAL LETTER A WITH MACRON}'], + InLatinExtendedB => ['\N{LATIN SMALL LETTER B WITH STROKE}'], + InKatakana => ['\N{KATAKANA LETTER SMALL A}'], + IsLatin => ["0x100", "0x212b"], + IsHebrew => ["0x5d0", "0xfb4f"], + IsGreek => ["0x37a", "0x386", "!0x387", "0x388", + "0x38a", "!0x38b", "0x38c"], + HangulSyllables => ['\x{AC00}'], + 'Script=Latin' => ['\x{0100}'], + 'Block=LatinExtendedA' => ['\x{0100}'], + 'Category=UppercaseLetter' => ['\x{0100}'], + + # + # It's ok to repeat class names. + # + InLatin1Supplement => + $IS_EBCDIC ? ['!\x{7f}', '\x{80}', '!\x{100}'] + : ['!\x{7f}', '\x{80}', '\x{ff}', '!\x{100}'], + InLatinExtendedA => + ['!\x{7f}', '!\x{80}', '!\x{ff}', '\x{100}'], + + # + # Properties are case-insensitive, and may have whitespace, + # dashes and underscores. + # + 'in-latin1_SUPPLEMENT' => ['\x{80}', + '\N{LATIN SMALL LETTER Y WITH DIAERESIS}'], + ' ^ In Latin 1 Supplement ' + => ['!\x{80}', '\N{COFFIN}'], + 'latin-1 supplement' => ['\x{80}', "0xDF"], + +); + +my @USER_DEFINED_PROPERTIES = ( + # + # User defined properties + # + InKana1 => ['\x{3040}', '!\x{303F}'], + InKana2 => ['\x{3040}', '!\x{303F}'], + InKana3 => ['\x{3041}', '!\x{3040}'], + InNotKana => ['\x{3040}', '!\x{3041}'], + InConsonant => ['d', '!e'], + IsSyriac1 => ['\x{0712}', '!\x{072F}'], + Syriac1 => ['\x{0712}', '!\x{072F}'], + '# User-defined character properties my lack \n at the end', + InGreekSmall => ['\N{GREEK SMALL LETTER PI}', + '\N{GREEK SMALL LETTER FINAL SIGMA}'], + InGreekCapital => ['\N{GREEK CAPITAL LETTER PI}', '!\x{03A2}'], + Dash => ['-'], + ASCII_Hex_Digit => ['!-', 'A'], + AsciiHexAndDash => ['-', 'A'], +); + + +# +# From the short properties we populate POSIX-like classes. +# +my %SHORT_PROPERTIES = ( + 'Ll' => ['m', '\N{CYRILLIC SMALL LETTER A}'], + 'Lu' => ['M', '\N{GREEK CAPITAL LETTER ALPHA}'], + 'Lo' => ['\N{HIRAGANA LETTER SMALL A}'], + 'Mn' => ['\N{COMBINING GRAVE ACCENT}'], + 'Nd' => ["0", '\N{ARABIC-INDIC DIGIT ZERO}'], + 'Pc' => ["_"], + 'Po' => ["!"], + 'Zs' => [" "], + 'Cc' => ['\x{00}'], +); + +# +# Illegal properties +# +my @ILLEGAL_PROPERTIES = qw [q qrst]; + +my %d; + +while (my ($class, $chars) = each %SHORT_PROPERTIES) { + push @{$d {IsAlpha}} => map {$class =~ /^[LM]/ ? $_ : "!$_"} @$chars; + push @{$d {IsAlnum}} => map {$class =~ /^[LMN]./ ? $_ : "!$_"} @$chars; + push @{$d {IsASCII}} => map {length ($_) == 1 || $_ eq '\x{00}' + ? $_ : "!$_"} @$chars; + push @{$d {IsCntrl}} => map {$class =~ /^C/ ? $_ : "!$_"} @$chars; + push @{$d {IsBlank}} => map {$class =~ /^Z[lps]/ ? $_ : "!$_"} @$chars; + push @{$d {IsDigit}} => map {$class =~ /^Nd$/ ? $_ : "!$_"} @$chars; + push @{$d {IsGraph}} => map {$class =~ /^([LMNPS]|Co)/ + ? $_ : "!$_"} @$chars; + push @{$d {IsPrint}} => map {$class =~ /^([LMNPS]|Co|Zs)/ + ? $_ : "!$_"} @$chars; + push @{$d {IsLower}} => map {$class =~ /^Ll$/ ? $_ : "!$_"} @$chars; + push @{$d {IsUpper}} => map {$class =~ /^L[ut]/ ? $_ : "!$_"} @$chars; + push @{$d {IsPunct}} => map {$class =~ /^P/ ? $_ : "!$_"} @$chars; + push @{$d {IsWord}} => map {$class =~ /^[LMN]/ || $_ eq "_" + ? $_ : "!$_"} @$chars; + push @{$d {IsSpace}} => map {$class =~ /^Z/ || + length ($_) == 1 && ord ($_) >= 0x09 + && ord ($_) <= 0x0D + ? $_ : "!$_"} @$chars; +} + +delete $d {IsASCII} if $IS_EBCDIC; + +push @CLASSES => "# Short properties" => %SHORT_PROPERTIES, + "# POSIX like properties" => %d, + "# User defined properties" => @USER_DEFINED_PROPERTIES; + + +# +# Calculate the number of tests. +# +my $count = 0; +for (my $i = 0; $i < @CLASSES; $i += 2) { + $i ++, redo if $CLASSES [$i] =~ /^\h*#\h*(.*)/; + $count += (length $CLASSES [$i] == 1 ? 4 : 2) * @{$CLASSES [$i + 1]}; +} +$count += 2 * @ILLEGAL_PROPERTIES; +$count += 2 * grep {length $_ == 1} @ILLEGAL_PROPERTIES; + +my $tests = 0; + +say "1..$count"; + +run_tests unless caller (); + +sub match { + my ($char, $match, $nomatch) = @_; + + my ($str, $name); + + given ($char) { + when (/^\\/) { + $str = eval qq ["$char"]; + $name = qq ["$char"]; + } + when (/^0x([0-9A-Fa-f]+)$/) { + $str = chr hex $1; + $name = "chr ($char)"; + } + default { + $str = $char; + $name = qq ["$char"]; + } + } + + print "not " unless $str =~ /$match/; + print "ok ", ++ $tests, " - $name =~ /$match/\n"; + print "not " unless $str !~ /$nomatch/; + print "ok ", ++ $tests, " - $name !~ /$nomatch/\n"; +} + +sub run_tests { + + while (@CLASSES) { + my $class = shift @CLASSES; + if ($class =~ /^\h*#\h*(.*)/) { + print "# $1\n"; + next; + } + last unless @CLASSES; + my $chars = shift @CLASSES; + my @in = grep {!/^!./} @$chars; + my @out = map {s/^!(?=.)//; $_} grep { /^!./} @$chars; + my $in_pat = eval qq ['\\p{$class}']; + my $out_pat = eval qq ['\\P{$class}']; + + match $_, $in_pat, $out_pat for @in; + match $_, $out_pat, $in_pat for @out; + + if (1 == length $class) { + my $in_pat = eval qq ['\\p$class']; + my $out_pat = eval qq ['\\P$class']; + + match $_, $in_pat, $out_pat for @in; + match $_, $out_pat, $in_pat for @out; + } + } + + + my $pat = qr /^Can't find Unicode property definition/; + print "# Illegal properties\n"; + foreach my $p (@ILLEGAL_PROPERTIES) { + undef $@; + my $r = eval "'a' =~ /\\p{$p}/; 1"; + print "not " unless !$r && $@ && $@ =~ $pat; + print "ok ", ++ $tests, " - Unknown Unicode property \\p{$p}\n"; + undef $@; + my $s = eval "'a' =~ /\\P{$p}/; 1"; + print "not " unless !$s && $@ && $@ =~ $pat; + print "ok ", ++ $tests, " - Unknown Unicode property \\P{$p}\n"; + if (length $p == 1) { + undef $@; + my $r = eval "'a' =~ /\\p$p/; 1"; + print "not " unless !$r && $@ && $@ =~ $pat; + print "ok ", ++ $tests, " - Unknown Unicode property \\p$p\n"; + undef $@; + my $s = eval "'a' =~ /\\P$p/; 1"; + print "not " unless !$s && $@ && $@ =~ $pat; + print "ok ", ++ $tests, " - Unknown Unicode property \\P$p\n"; + } + } +} + + +# +# User defined properties +# + +sub InKana1 {<<'--'} +3040 309F +30A0 30FF +-- + +sub InKana2 {<<'--'} ++utf8::InHiragana ++utf8::InKatakana +-- + +sub InKana3 {<<'--'} ++utf8::InHiragana ++utf8::InKatakana +-utf8::IsCn +-- + +sub InNotKana {<<'--'} +!utf8::InHiragana +-utf8::InKatakana ++utf8::IsCn +-- + +sub InConsonant {<<'--'} # Not EBCDIC-aware. +0061 007f +-0061 +-0065 +-0069 +-006f +-0075 +-- + +sub IsSyriac1 {<<'--'} +0712 072C +0730 074A +-- + +sub Syriac1 {<<'--'} +0712 072C +0730 074A +-- + +sub InGreekSmall {return "03B1\t03C9"} +sub InGreekCapital {return "0391\t03A9\n-03A2"} + +sub AsciiHexAndDash {<<'--'} ++utf8::ASCII_Hex_Digit ++utf8::Dash +-- + +__END__ diff --git a/t/op/regexp_unicode_prop_thr.t b/t/op/regexp_unicode_prop_thr.t new file mode 100644 index 0000000..e66aa7c Binary files /dev/null and b/t/op/regexp_unicode_prop_thr.t differ