diff options
Diffstat (limited to 't')
| -rwxr-xr-x | t/op/pat.t | 3 | ||||
| -rw-r--r-- | t/op/reg_posixcc.t | 127 |
2 files changed, 130 insertions, 0 deletions
diff --git a/t/op/pat.t b/t/op/pat.t index a2d49ac0b4..798a3da70e 100755 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -4617,6 +4617,9 @@ sub kt } 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}/} diff --git a/t/op/reg_posixcc.t b/t/op/reg_posixcc.t new file mode 100644 index 0000000000..73353993b2 --- /dev/null +++ b/t/op/reg_posixcc.t @@ -0,0 +1,127 @@ +#!perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use strict; +use warnings; +use Test::More tests => 1; +my @pats=( + "\\w", + "\\W", + "\\s", + "\\S", + "\\d", + "\\D", + "[:alnum:]", + "[:^alnum:]", + "[:alpha:]", + "[:^alpha:]", + "[:ascii:]", + "[:^ascii:]", + "[:cntrl:]", + "[:^cntrl:]", + "[:graph:]", + "[:^graph:]", + "[:lower:]", + "[:^lower:]", + "[:print:]", + "[:^print:]", + "[:punct:]", + "[:^punct:]", + "[:upper:]", + "[:^upper:]", + "[:xdigit:]", + "[:^xdigit:]", + "[:space:]", + "[:^space:]", + "[:blank:]", + "[:^blank:]" ); +sub rangify { + my $ary= shift; + my $fmt= shift || '%d'; + my $sep= shift || ' '; + my $rng= shift || '..'; + + + my $first= $ary->[0]; + my $last= $ary->[0]; + my $ret= sprintf $fmt, $first; + for my $idx (1..$#$ary) { + if ( $ary->[$idx] != $last + 1) { + if ($last!=$first) { + $ret.=sprintf "%s$fmt",$rng, $last; + } + $first= $last= $ary->[$idx]; + $ret.=sprintf "%s$fmt",$sep,$first; + } else { + $last= $ary->[$idx]; + } + } + if ( $last != $first) { + $ret.=sprintf "%s$fmt",$rng, $last; + } + return $ret; +} + +my $description = ""; +while (@pats) { + my ($yes,$no)= splice @pats,0,2; + + my %err_by_type; + my %singles; + foreach my $b (0..255) { + my %got; + for my $type ('unicode','not-unicode') { + my $str=chr($b).chr($b); + if ($type eq 'unicode') { + $str.=chr(256); + chop $str; + } + if ($str=~/[$yes][$no]/) { + push @{$err_by_type{$type}},$b; + } + $got{"[$yes]"}{$type} = $str=~/[$yes]/ ? 1 : 0; + $got{"[$no]"}{$type} = $str=~/[$no]/ ? 1 : 0; + $got{"[^$yes]"}{$type} = $str=~/[^$yes]/ ? 1 : 0; + $got{"[^$no]"}{$type} = $str=~/[^$no]/ ? 1 : 0; + } + foreach my $which ("[$yes]","[$no]","[^$yes]","[^$no]") { + if ($got{$which}{'unicode'} != $got{$which}{'not-unicode'}) { + push @{$singles{$which}},$b; + } + } + } + + + if (%err_by_type || %singles) { + $description||=" Error:\n"; + $description .= "/[$yes][$no]/\n"; + if (%err_by_type) { + foreach my $type (keys %err_by_type) { + $description .= "\tmatches $type codepoints:\t"; + $description .= rangify($err_by_type{$type}); + $description .= "\n"; + } + $description .= "\n"; + } + if (%singles) { + $description .= "Unicode/Nonunicode mismatches:\n"; + foreach my $type (keys %singles) { + $description .= "\t$type:\t"; + $description .= rangify($singles{$type}); + $description .= "\n"; + } + $description .= "\n"; + } + + } + +} +TODO: { + local $TODO = "Only works under PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS = 0"; + is( $description, "", "POSIX and perl charclasses should not depend on string type"); +}; +__DATA__ |