Commit | Line | Data |
---|---|---|
da7fcca4 YO |
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 YO |
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 YO |
42 | if (not $ENV{REAL_POSIX_CC}) { |
43 | $TODO = "Only works under PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS = 0"; | |
44 | } | |
45 | ||
da7fcca4 YO |
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 YO |
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 YO |
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 YO |
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 YO |
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 YO |
106 | push @{$singles{$which}},$b; |
107 | } | |
108 | } | |
dba1316b YO |
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 YO |
120 | } |
121 | ||
122 | ||
dba1316b | 123 | if (%err_by_type || %singles || %complements) { |
da7fcca4 YO |
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 YO |
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 YO |
137 | $description .= "\t$type:\t"; |
138 | $description .= rangify($singles{$type}); | |
139 | $description .= "\n"; | |
140 | } | |
141 | $description .= "\n"; | |
142 | } | |
dba1316b YO |
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 YO |
153 | } |
154 | TODO: { | |
da7fcca4 | 155 | is( $description, "", "POSIX and perl charclasses should not depend on string type"); |
dba1316b YO |
156 | } |
157 | ||
da7fcca4 | 158 | __DATA__ |