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; |
10 | use Test::More tests => 1; |
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:]" ); |
42 | sub rangify { |
43 | my $ary= shift; |
44 | my $fmt= shift || '%d'; |
45 | my $sep= shift || ' '; |
46 | my $rng= shift || '..'; |
47 | |
48 | |
49 | my $first= $ary->[0]; |
50 | my $last= $ary->[0]; |
51 | my $ret= sprintf $fmt, $first; |
52 | for my $idx (1..$#$ary) { |
53 | if ( $ary->[$idx] != $last + 1) { |
54 | if ($last!=$first) { |
55 | $ret.=sprintf "%s$fmt",$rng, $last; |
56 | } |
57 | $first= $last= $ary->[$idx]; |
58 | $ret.=sprintf "%s$fmt",$sep,$first; |
59 | } else { |
60 | $last= $ary->[$idx]; |
61 | } |
62 | } |
63 | if ( $last != $first) { |
64 | $ret.=sprintf "%s$fmt",$rng, $last; |
65 | } |
66 | return $ret; |
67 | } |
68 | |
69 | my $description = ""; |
70 | while (@pats) { |
71 | my ($yes,$no)= splice @pats,0,2; |
72 | |
73 | my %err_by_type; |
74 | my %singles; |
75 | foreach my $b (0..255) { |
76 | my %got; |
77 | for my $type ('unicode','not-unicode') { |
78 | my $str=chr($b).chr($b); |
79 | if ($type eq 'unicode') { |
80 | $str.=chr(256); |
81 | chop $str; |
82 | } |
83 | if ($str=~/[$yes][$no]/) { |
84 | push @{$err_by_type{$type}},$b; |
85 | } |
86 | $got{"[$yes]"}{$type} = $str=~/[$yes]/ ? 1 : 0; |
87 | $got{"[$no]"}{$type} = $str=~/[$no]/ ? 1 : 0; |
88 | $got{"[^$yes]"}{$type} = $str=~/[^$yes]/ ? 1 : 0; |
89 | $got{"[^$no]"}{$type} = $str=~/[^$no]/ ? 1 : 0; |
90 | } |
91 | foreach my $which ("[$yes]","[$no]","[^$yes]","[^$no]") { |
92 | if ($got{$which}{'unicode'} != $got{$which}{'not-unicode'}) { |
93 | push @{$singles{$which}},$b; |
94 | } |
95 | } |
96 | } |
97 | |
98 | |
99 | if (%err_by_type || %singles) { |
100 | $description||=" Error:\n"; |
101 | $description .= "/[$yes][$no]/\n"; |
102 | if (%err_by_type) { |
103 | foreach my $type (keys %err_by_type) { |
104 | $description .= "\tmatches $type codepoints:\t"; |
105 | $description .= rangify($err_by_type{$type}); |
106 | $description .= "\n"; |
107 | } |
108 | $description .= "\n"; |
109 | } |
110 | if (%singles) { |
111 | $description .= "Unicode/Nonunicode mismatches:\n"; |
112 | foreach my $type (keys %singles) { |
113 | $description .= "\t$type:\t"; |
114 | $description .= rangify($singles{$type}); |
115 | $description .= "\n"; |
116 | } |
117 | $description .= "\n"; |
118 | } |
119 | |
120 | } |
121 | |
122 | } |
123 | TODO: { |
124 | local $TODO = "Only works under PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS = 0"; |
125 | is( $description, "", "POSIX and perl charclasses should not depend on string type"); |
126 | }; |
127 | __DATA__ |