Commit | Line | Data |
da7fcca4 |
1 | #!perl |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
6 | } |
7 | |
8 | use strict; |
9 | use warnings; |
dba1316b |
10 | use Test::More 'no_plan'; # otherwise it would 38401 tests, which is, uh, a lot. :-) |
da7fcca4 |
11 | my @pats=( |
12 | "\\w", |
13 | "\\W", |
14 | "\\s", |
15 | "\\S", |
16 | "\\d", |
17 | "\\D", |
18 | "[:alnum:]", |
19 | "[:^alnum:]", |
20 | "[:alpha:]", |
21 | "[:^alpha:]", |
22 | "[:ascii:]", |
23 | "[:^ascii:]", |
24 | "[:cntrl:]", |
25 | "[:^cntrl:]", |
26 | "[:graph:]", |
27 | "[:^graph:]", |
28 | "[:lower:]", |
29 | "[:^lower:]", |
30 | "[:print:]", |
31 | "[:^print:]", |
32 | "[:punct:]", |
33 | "[:^punct:]", |
34 | "[:upper:]", |
35 | "[:^upper:]", |
36 | "[:xdigit:]", |
37 | "[:^xdigit:]", |
38 | "[:space:]", |
39 | "[:^space:]", |
40 | "[:blank:]", |
41 | "[:^blank:]" ); |
dba1316b |
42 | if (not $ENV{REAL_POSIX_CC}) { |
43 | $TODO = "Only works under PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS = 0"; |
44 | } |
45 | |
da7fcca4 |
46 | sub rangify { |
47 | my $ary= shift; |
48 | my $fmt= shift || '%d'; |
49 | my $sep= shift || ' '; |
50 | my $rng= shift || '..'; |
51 | |
52 | |
53 | my $first= $ary->[0]; |
54 | my $last= $ary->[0]; |
55 | my $ret= sprintf $fmt, $first; |
56 | for my $idx (1..$#$ary) { |
57 | if ( $ary->[$idx] != $last + 1) { |
58 | if ($last!=$first) { |
59 | $ret.=sprintf "%s$fmt",$rng, $last; |
60 | } |
61 | $first= $last= $ary->[$idx]; |
62 | $ret.=sprintf "%s$fmt",$sep,$first; |
63 | } else { |
64 | $last= $ary->[$idx]; |
65 | } |
66 | } |
67 | if ( $last != $first) { |
68 | $ret.=sprintf "%s$fmt",$rng, $last; |
69 | } |
70 | return $ret; |
71 | } |
72 | |
73 | my $description = ""; |
74 | while (@pats) { |
75 | my ($yes,$no)= splice @pats,0,2; |
76 | |
77 | my %err_by_type; |
78 | my %singles; |
dba1316b |
79 | my %complements; |
da7fcca4 |
80 | foreach my $b (0..255) { |
81 | my %got; |
82 | for my $type ('unicode','not-unicode') { |
83 | my $str=chr($b).chr($b); |
84 | if ($type eq 'unicode') { |
85 | $str.=chr(256); |
86 | chop $str; |
87 | } |
dba1316b |
88 | if ($str=~/[$yes][$no]/){ |
89 | TODO: { |
90 | unlike($str,qr/[$yes][$no]/, |
91 | "chr($b)=~/[$yes][$no]/ should not match under $type"); |
92 | } |
da7fcca4 |
93 | push @{$err_by_type{$type}},$b; |
94 | } |
95 | $got{"[$yes]"}{$type} = $str=~/[$yes]/ ? 1 : 0; |
96 | $got{"[$no]"}{$type} = $str=~/[$no]/ ? 1 : 0; |
97 | $got{"[^$yes]"}{$type} = $str=~/[^$yes]/ ? 1 : 0; |
98 | $got{"[^$no]"}{$type} = $str=~/[^$no]/ ? 1 : 0; |
99 | } |
100 | foreach my $which ("[$yes]","[$no]","[^$yes]","[^$no]") { |
dba1316b |
101 | if ($got{$which}{'unicode'} != $got{$which}{'not-unicode'}){ |
102 | TODO: { |
103 | is($got{$which}{'unicode'},$got{$which}{'not-unicode'}, |
104 | "chr($b)=~/$which/ should have the same results regardless of internal string encoding"); |
105 | } |
da7fcca4 |
106 | push @{$singles{$which}},$b; |
107 | } |
108 | } |
dba1316b |
109 | foreach my $which ($yes,$no) { |
110 | foreach my $strtype ('unicode','not-unicode') { |
111 | if ($got{"[$which]"}{$strtype} == $got{"[^$which]"}{$strtype}) { |
112 | TODO: { |
113 | isnt($got{"[$which]"}{$strtype},$got{"[^$which]"}{$strtype}, |
114 | "chr($b)=~/[$which]/ should not have the same result as chr($b)=~/[^$which]/"); |
115 | } |
116 | push @{$complements{$which}{$strtype}},$b; |
117 | } |
118 | } |
119 | } |
da7fcca4 |
120 | } |
121 | |
122 | |
dba1316b |
123 | if (%err_by_type || %singles || %complements) { |
da7fcca4 |
124 | $description||=" Error:\n"; |
125 | $description .= "/[$yes][$no]/\n"; |
126 | if (%err_by_type) { |
dba1316b |
127 | foreach my $type (sort keys %err_by_type) { |
da7fcca4 |
128 | $description .= "\tmatches $type codepoints:\t"; |
129 | $description .= rangify($err_by_type{$type}); |
130 | $description .= "\n"; |
131 | } |
132 | $description .= "\n"; |
133 | } |
134 | if (%singles) { |
135 | $description .= "Unicode/Nonunicode mismatches:\n"; |
dba1316b |
136 | foreach my $type (sort keys %singles) { |
da7fcca4 |
137 | $description .= "\t$type:\t"; |
138 | $description .= rangify($singles{$type}); |
139 | $description .= "\n"; |
140 | } |
141 | $description .= "\n"; |
142 | } |
dba1316b |
143 | if (%complements) { |
144 | foreach my $class (sort keys %complements) { |
145 | foreach my $strtype (sort keys %{$complements{$class}}) { |
146 | $description .= "\t$class has complement failures under $strtype for:\t"; |
147 | $description .= rangify($complements{$class}{$strtype}); |
148 | $description .= "\n"; |
149 | } |
150 | } |
151 | } |
da7fcca4 |
152 | } |
da7fcca4 |
153 | } |
154 | TODO: { |
da7fcca4 |
155 | is( $description, "", "POSIX and perl charclasses should not depend on string type"); |
dba1316b |
156 | } |
157 | |
da7fcca4 |
158 | __DATA__ |