Commit | Line | Data |
---|---|---|
da7fcca4 YO |
1 | #!perl |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
0214bff6 | 5 | require './test.pl'; |
624c42e2 | 6 | set_up_inc('../lib'); |
da7fcca4 YO |
7 | } |
8 | ||
9 | use strict; | |
10 | use warnings; | |
0214bff6 RGS |
11 | plan "no_plan"; |
12 | ||
da7fcca4 YO |
13 | my @pats=( |
14 | "\\w", | |
15 | "\\W", | |
16 | "\\s", | |
17 | "\\S", | |
18 | "\\d", | |
19 | "\\D", | |
6e80eb23 KW |
20 | "\\h", |
21 | "\\H", | |
22 | "\\v", | |
23 | "\\V", | |
da7fcca4 YO |
24 | "[:alnum:]", |
25 | "[:^alnum:]", | |
26 | "[:alpha:]", | |
27 | "[:^alpha:]", | |
28 | "[:ascii:]", | |
29 | "[:^ascii:]", | |
30 | "[:cntrl:]", | |
31 | "[:^cntrl:]", | |
32 | "[:graph:]", | |
33 | "[:^graph:]", | |
34 | "[:lower:]", | |
35 | "[:^lower:]", | |
36 | "[:print:]", | |
37 | "[:^print:]", | |
38 | "[:punct:]", | |
39 | "[:^punct:]", | |
40 | "[:upper:]", | |
41 | "[:^upper:]", | |
42 | "[:xdigit:]", | |
43 | "[:^xdigit:]", | |
44 | "[:space:]", | |
45 | "[:^space:]", | |
46 | "[:blank:]", | |
47 | "[:^blank:]" ); | |
dba1316b | 48 | |
da7fcca4 YO |
49 | sub rangify { |
50 | my $ary= shift; | |
51 | my $fmt= shift || '%d'; | |
52 | my $sep= shift || ' '; | |
53 | my $rng= shift || '..'; | |
54 | ||
55 | ||
56 | my $first= $ary->[0]; | |
57 | my $last= $ary->[0]; | |
58 | my $ret= sprintf $fmt, $first; | |
59 | for my $idx (1..$#$ary) { | |
60 | if ( $ary->[$idx] != $last + 1) { | |
61 | if ($last!=$first) { | |
62 | $ret.=sprintf "%s$fmt",$rng, $last; | |
63 | } | |
64 | $first= $last= $ary->[$idx]; | |
65 | $ret.=sprintf "%s$fmt",$sep,$first; | |
66 | } else { | |
67 | $last= $ary->[$idx]; | |
68 | } | |
69 | } | |
70 | if ( $last != $first) { | |
71 | $ret.=sprintf "%s$fmt",$rng, $last; | |
72 | } | |
73 | return $ret; | |
74 | } | |
75 | ||
9b7c43ba KW |
76 | # The bug is only fixed for /u |
77 | use feature 'unicode_strings'; | |
78 | ||
da7fcca4 YO |
79 | my $description = ""; |
80 | while (@pats) { | |
81 | my ($yes,$no)= splice @pats,0,2; | |
82 | ||
83 | my %err_by_type; | |
84 | my %singles; | |
dba1316b | 85 | my %complements; |
da7fcca4 YO |
86 | foreach my $b (0..255) { |
87 | my %got; | |
cb54b734 | 88 | my $display_b = sprintf("0x%02X", $b); |
803505a9 | 89 | for my $type ('utf8','not-utf8') { |
da7fcca4 | 90 | my $str=chr($b).chr($b); |
803505a9 | 91 | if ($type eq 'utf8') { |
da7fcca4 YO |
92 | $str.=chr(256); |
93 | chop $str; | |
94 | } | |
dba1316b | 95 | if ($str=~/[$yes][$no]/){ |
9b7c43ba KW |
96 | unlike($str,qr/[$yes][$no]/, |
97 | "chr($display_b) X 2 =~/[$yes][$no]/ should not match under $type"); | |
da7fcca4 YO |
98 | push @{$err_by_type{$type}},$b; |
99 | } | |
100 | $got{"[$yes]"}{$type} = $str=~/[$yes]/ ? 1 : 0; | |
101 | $got{"[$no]"}{$type} = $str=~/[$no]/ ? 1 : 0; | |
102 | $got{"[^$yes]"}{$type} = $str=~/[^$yes]/ ? 1 : 0; | |
103 | $got{"[^$no]"}{$type} = $str=~/[^$no]/ ? 1 : 0; | |
a8c75f4b | 104 | |
6e80eb23 | 105 | # For \w, \s, and \d, \h, \v, also test without being in character |
a8c75f4b KW |
106 | # classes. |
107 | next if $yes =~ /\[/; | |
108 | ||
109 | # The rest of this .t was written when there were many test | |
110 | # failures, so it goes to some lengths to summarize things. Now | |
111 | # those are fixed, so these missing tests just do standard | |
112 | # procedures | |
113 | ||
114 | my $chr = chr($b); | |
803505a9 | 115 | utf8::upgrade $chr if $type eq 'utf8'; |
a8c75f4b KW |
116 | ok (($chr =~ /$yes/) != ($chr =~ /$no/), |
117 | "$type: chr($display_b) isn't both $yes and $no"); | |
da7fcca4 YO |
118 | } |
119 | foreach my $which ("[$yes]","[$no]","[^$yes]","[^$no]") { | |
803505a9 KW |
120 | if ($got{$which}{'utf8'} != $got{$which}{'not-utf8'}){ |
121 | is($got{$which}{'utf8'},$got{$which}{'not-utf8'}, | |
9b7c43ba | 122 | "chr($display_b) X 2=~ /$which/ should have the same results regardless of internal string encoding"); |
da7fcca4 YO |
123 | push @{$singles{$which}},$b; |
124 | } | |
125 | } | |
dba1316b | 126 | foreach my $which ($yes,$no) { |
803505a9 | 127 | foreach my $strtype ('utf8','not-utf8') { |
dba1316b | 128 | if ($got{"[$which]"}{$strtype} == $got{"[^$which]"}{$strtype}) { |
9b7c43ba KW |
129 | isnt($got{"[$which]"}{$strtype},$got{"[^$which]"}{$strtype}, |
130 | "chr($display_b) X 2 =~ /[$which]/ should not have the same result as chr($display_b)=~/[^$which]/"); | |
dba1316b YO |
131 | push @{$complements{$which}{$strtype}},$b; |
132 | } | |
133 | } | |
134 | } | |
da7fcca4 YO |
135 | } |
136 | ||
137 | ||
dba1316b | 138 | if (%err_by_type || %singles || %complements) { |
da7fcca4 YO |
139 | $description||=" Error:\n"; |
140 | $description .= "/[$yes][$no]/\n"; | |
141 | if (%err_by_type) { | |
dba1316b | 142 | foreach my $type (sort keys %err_by_type) { |
da7fcca4 YO |
143 | $description .= "\tmatches $type codepoints:\t"; |
144 | $description .= rangify($err_by_type{$type}); | |
145 | $description .= "\n"; | |
146 | } | |
147 | $description .= "\n"; | |
148 | } | |
149 | if (%singles) { | |
150 | $description .= "Unicode/Nonunicode mismatches:\n"; | |
dba1316b | 151 | foreach my $type (sort keys %singles) { |
da7fcca4 YO |
152 | $description .= "\t$type:\t"; |
153 | $description .= rangify($singles{$type}); | |
154 | $description .= "\n"; | |
155 | } | |
156 | $description .= "\n"; | |
157 | } | |
dba1316b YO |
158 | if (%complements) { |
159 | foreach my $class (sort keys %complements) { | |
160 | foreach my $strtype (sort keys %{$complements{$class}}) { | |
161 | $description .= "\t$class has complement failures under $strtype for:\t"; | |
162 | $description .= rangify($complements{$class}{$strtype}); | |
163 | $description .= "\n"; | |
164 | } | |
165 | } | |
166 | } | |
da7fcca4 | 167 | } |
da7fcca4 | 168 | } |
da7fcca4 | 169 | __DATA__ |