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