Mercurial > repo
comparison perl-5.22.2/regen/mk_PL_charclass.pl @ 8045:a16537d2fe07
<xfix> tar xf perl-5.22.2.tar.gz # Ah, whatever, I\'m doing it anyway
author | HackBot |
---|---|
date | Sat, 14 May 2016 14:54:38 +0000 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
8044:711c038a7dce | 8045:a16537d2fe07 |
---|---|
1 #!perl -w | |
2 use v5.15.8; | |
3 use strict; | |
4 use warnings; | |
5 require 'regen/regen_lib.pl'; | |
6 require 'regen/charset_translations.pl'; | |
7 | |
8 # This program outputs l1_charclass_tab.h, which defines the guts of the | |
9 # PL_charclass table. Each line is a bit map of properties that the Unicode | |
10 # code point at the corresponding position in the table array has. The first | |
11 # line corresponds to code point U+0000, NULL, the last line to U+00FF. For | |
12 # an application to see if the code point "i" has a particular property, it | |
13 # just does | |
14 # 'PL_charclass[i] & BIT' | |
15 # The bit names are of the form '_CC_property_suffix', where 'CC' stands for | |
16 # character class, and 'property' is the corresponding property, and 'suffix' | |
17 # is one of '_A' to mean the property is true only if the corresponding code | |
18 # point is ASCII, and '_L1' means that the range includes any Latin1 | |
19 # character (ISO-8859-1 including the C0 and C1 controls). A property without | |
20 # these suffixes does not have different forms for both ranges. | |
21 | |
22 # This program need be run only when adding new properties to it, or upon a | |
23 # new Unicode release, to make sure things haven't been changed by it. | |
24 | |
25 my @properties = qw( | |
26 NONLATIN1_SIMPLE_FOLD | |
27 NONLATIN1_FOLD | |
28 ALPHANUMERIC | |
29 ALPHA | |
30 ASCII | |
31 BLANK | |
32 CASED | |
33 CHARNAME_CONT | |
34 CNTRL | |
35 DIGIT | |
36 GRAPH | |
37 IDFIRST | |
38 LOWER | |
39 NON_FINAL_FOLD | |
40 PRINT | |
41 PUNCT | |
42 QUOTEMETA | |
43 SPACE | |
44 UPPER | |
45 WORDCHAR | |
46 XDIGIT | |
47 VERTSPACE | |
48 IS_IN_SOME_FOLD | |
49 MNEMONIC_CNTRL | |
50 ); | |
51 | |
52 # Read in the case fold mappings. | |
53 my %folded_closure; | |
54 my @hex_non_final_folds; | |
55 my @non_latin1_simple_folds; | |
56 my @folds; | |
57 use Unicode::UCD; | |
58 | |
59 BEGIN { # Have to do this at compile time because using user-defined \p{property} | |
60 | |
61 # Use the Unicode data file if we are on an ASCII platform (which its data | |
62 # is for), and it is in the modern format (starting in Unicode 3.1.0) and | |
63 # it is available. This avoids being affected by potential bugs | |
64 # introduced by other layers of Perl | |
65 my $file="lib/unicore/CaseFolding.txt"; | |
66 | |
67 if (ord('A') == 65 | |
68 && pack("C*", split /\./, Unicode::UCD::UnicodeVersion()) ge v3.1.0 | |
69 && open my $fh, "<", $file) | |
70 { | |
71 @folds = <$fh>; | |
72 } | |
73 else { | |
74 my ($invlist_ref, $invmap_ref, undef, $default) | |
75 = Unicode::UCD::prop_invmap('Case_Folding'); | |
76 for my $i (0 .. @$invlist_ref - 1 - 1) { | |
77 next if $invmap_ref->[$i] == $default; | |
78 my $adjust = -1; | |
79 for my $j ($invlist_ref->[$i] .. $invlist_ref->[$i+1] -1) { | |
80 $adjust++; | |
81 | |
82 # Single-code point maps go to a 'C' type | |
83 if (! ref $invmap_ref->[$i]) { | |
84 push @folds, sprintf("%04X; C; %04X\n", | |
85 $j, | |
86 $invmap_ref->[$i] + $adjust); | |
87 } | |
88 else { # Multi-code point maps go to 'F'. prop_invmap() | |
89 # guarantees that no adjustment is needed for these, | |
90 # as the range will contain just one element | |
91 push @folds, sprintf("%04X; F; %s\n", | |
92 $j, | |
93 join " ", map { sprintf "%04X", $_ } | |
94 @{$invmap_ref->[$i]}); | |
95 } | |
96 } | |
97 } | |
98 } | |
99 | |
100 for (@folds) { | |
101 chomp; | |
102 | |
103 # Lines look like (without the initial '#' | |
104 #0130; F; 0069 0307; # LATIN CAPITAL LETTER I WITH DOT ABOVE | |
105 # Get rid of comments, ignore blank or comment-only lines | |
106 my $line = $_ =~ s/ (?: \s* \# .* )? $ //rx; | |
107 next unless length $line; | |
108 my ($hex_from, $fold_type, @folded) = split /[\s;]+/, $line; | |
109 | |
110 my $from = hex $hex_from; | |
111 | |
112 # Perl only deals with S, C, and F folds | |
113 next if $fold_type ne 'C' and $fold_type ne 'F' and $fold_type ne 'S'; | |
114 | |
115 # Get each code point in the range that participates in this line's fold. | |
116 # The hash has keys of each code point in the range, and values of what it | |
117 # folds to and what folds to it | |
118 for my $i (0 .. @folded - 1) { | |
119 my $hex_fold = $folded[$i]; | |
120 my $fold = hex $hex_fold; | |
121 push @{$folded_closure{$fold}}, $from if $fold < 256; | |
122 push @{$folded_closure{$from}}, $fold if $from < 256; | |
123 | |
124 if (($fold_type eq 'C' || $fold_type eq 'S') | |
125 && ($fold < 256 != $from < 256)) | |
126 { | |
127 # Fold is simple (hence can't be a non-final fold, so the 'if' | |
128 # above is mutualy exclusive from the 'if below) and crosses | |
129 # 255/256 boundary. We keep track of the Latin1 code points | |
130 # in such folds. | |
131 push @non_latin1_simple_folds, ($fold < 256) | |
132 ? $fold | |
133 : $from; | |
134 } | |
135 elsif ($i < @folded-1 | |
136 && $fold < 256 | |
137 && ! grep { $_ eq $hex_fold } @hex_non_final_folds) | |
138 { | |
139 push @hex_non_final_folds, $hex_fold; | |
140 | |
141 # Also add the upper case, which in the latin1 range folds to | |
142 # $fold | |
143 push @hex_non_final_folds, sprintf "%04X", ord uc chr $fold; | |
144 } | |
145 } | |
146 } | |
147 | |
148 # Now having read all the lines, combine them into the full closure of each | |
149 # code point in the range by adding lists together that share a common | |
150 # element | |
151 foreach my $folded (keys %folded_closure) { | |
152 foreach my $from (grep { $_ < 256 } @{$folded_closure{$folded}}) { | |
153 push @{$folded_closure{$from}}, @{$folded_closure{$folded}}; | |
154 } | |
155 } | |
156 | |
157 # We have the single-character folds that cross the 255/256, like KELVIN | |
158 # SIGN => 'k', but we need the closure, so add like 'K' to it | |
159 foreach my $folded (@non_latin1_simple_folds) { | |
160 foreach my $fold (@{$folded_closure{$folded}}) { | |
161 if ($fold < 256 && ! grep { $fold == $_ } @non_latin1_simple_folds) { | |
162 push @non_latin1_simple_folds, $fold; | |
163 } | |
164 } | |
165 } | |
166 } | |
167 | |
168 sub Is_Non_Latin1_Fold { | |
169 my @return; | |
170 | |
171 foreach my $folded (keys %folded_closure) { | |
172 push @return, sprintf("%X", $folded), if grep { $_ > 255 } | |
173 @{$folded_closure{$folded}}; | |
174 } | |
175 return join("\n", @return) . "\n"; | |
176 } | |
177 | |
178 sub Is_Non_Latin1_Simple_Fold { # Latin1 code points that are folded to by | |
179 # non-Latin1 code points as single character | |
180 # folds | |
181 return join("\n", map { sprintf "%X", $_ } @non_latin1_simple_folds) . "\n"; | |
182 } | |
183 | |
184 sub Is_Non_Final_Fold { | |
185 return join("\n", @hex_non_final_folds) . "\n"; | |
186 } | |
187 | |
188 my @bits; # Bit map for each code point | |
189 | |
190 # For each character, calculate which properties it matches. | |
191 for my $ord (0..255) { | |
192 my $char = chr($ord); | |
193 utf8::upgrade($char); # Important to use Unicode rules! | |
194 | |
195 # Look at all the properties we care about here. | |
196 for my $property (@properties) { | |
197 my $name = $property; | |
198 | |
199 # Remove the suffix to get the actual property name. | |
200 # Currently the suffixes are '_L1', '_A', and none. | |
201 # If is a latin1 version, no further checking is needed. | |
202 if (! ($name =~ s/_L1$//)) { | |
203 | |
204 # Here, isn't an _L1. If its _A, it's automatically false for | |
205 # non-ascii. The only current ones (besides ASCII) without a | |
206 # suffix are valid over the whole range. | |
207 next if $name =~ s/_A$// && $char !~ /\p{ASCII}/; | |
208 } | |
209 my $re; | |
210 if ($name eq 'PUNCT') {; | |
211 | |
212 # Sadly, this is inconsistent: \pP and \pS for the ascii range, | |
213 # just \pP outside it. | |
214 $re = qr/\p{Punct}|[^\P{Symbol}\P{ASCII}]/; | |
215 } elsif ($name eq 'CHARNAME_CONT') {; | |
216 $re = qr/\p{_Perl_Charname_Continue}/, | |
217 } elsif ($name eq 'SPACE') {; | |
218 $re = qr/\p{XPerlSpace}/; | |
219 } elsif ($name eq 'IDFIRST') { | |
220 $re = qr/[_\p{Alpha}]/; | |
221 } elsif ($name eq 'WORDCHAR') { | |
222 $re = qr/\p{XPosixWord}/; | |
223 } elsif ($name eq 'ALPHANUMERIC') { | |
224 # Like \w, but no underscore | |
225 $re = qr/\p{Alnum}/; | |
226 } elsif ($name eq 'QUOTEMETA') { | |
227 $re = qr/\p{_Perl_Quotemeta}/; | |
228 } elsif ($name eq 'NONLATIN1_FOLD') { | |
229 $re = qr/\p{Is_Non_Latin1_Fold}/; | |
230 } elsif ($name eq 'NONLATIN1_SIMPLE_FOLD') { | |
231 $re = qr/\p{Is_Non_Latin1_Simple_Fold}/; | |
232 } elsif ($name eq 'NON_FINAL_FOLD') { | |
233 $re = qr/\p{Is_Non_Final_Fold}/; | |
234 } elsif ($name eq 'IS_IN_SOME_FOLD') { | |
235 $re = qr/\p{_Perl_Any_Folds}/; | |
236 } elsif ($name eq 'MNEMONIC_CNTRL') { | |
237 # These are the control characters that there are mnemonics for | |
238 $re = qr/[\a\b\e\f\n\r\t]/; | |
239 } else { # The remainder have the same name and values as Unicode | |
240 $re = eval "qr/\\p{$name}/"; | |
241 use Carp; | |
242 carp $@ if ! defined $re; | |
243 } | |
244 #print "$ord, $name $property, $re\n"; | |
245 if ($char =~ $re) { # Add this property if matches | |
246 $bits[$ord] .= '|' if $bits[$ord]; | |
247 $bits[$ord] .= "(1U<<_CC_$property)"; | |
248 } | |
249 } | |
250 #print __LINE__, " $ord $char $bits[$ord]\n"; | |
251 } | |
252 | |
253 my $out_fh = open_new('l1_char_class_tab.h', '>', | |
254 {style => '*', by => $0, | |
255 from => "property definitions"}); | |
256 | |
257 print $out_fh <<END; | |
258 /* For code points whose position is not the same as Unicode, both are shown | |
259 * in the comment*/ | |
260 END | |
261 | |
262 # Output the table using fairly short names for each char. | |
263 foreach my $charset (get_supported_code_pages()) { | |
264 my @a2n = @{get_a2n($charset)}; | |
265 my @out; | |
266 | |
267 print $out_fh "\n" . get_conditional_compile_line_start($charset); | |
268 for my $ord (0..255) { | |
269 my $name; | |
270 my $char = chr $ord; | |
271 if ($char =~ /\p{PosixGraph}/) { | |
272 my $quote = $char eq "'" ? '"' : "'"; | |
273 $name = $quote . chr($ord) . $quote; | |
274 } | |
275 elsif ($char =~ /\p{XPosixGraph}/) { | |
276 use charnames(); | |
277 $name = charnames::viacode($ord); | |
278 $name =~ s/LATIN CAPITAL LETTER // | |
279 or $name =~ s/LATIN SMALL LETTER (.*)/\L$1/ | |
280 or $name =~ s/ SIGN\b// | |
281 or $name =~ s/EXCLAMATION MARK/'!'/ | |
282 or $name =~ s/QUESTION MARK/'?'/ | |
283 or $name =~ s/QUOTATION MARK/QUOTE/ | |
284 or $name =~ s/ INDICATOR//; | |
285 $name =~ s/\bWITH\b/\L$&/; | |
286 $name =~ s/\bONE\b/1/; | |
287 $name =~ s/\b(TWO|HALF)\b/2/; | |
288 $name =~ s/\bTHREE\b/3/; | |
289 $name =~ s/\b QUARTER S? \b/4/x; | |
290 $name =~ s/VULGAR FRACTION (.) (.)/$1\/$2/; | |
291 $name =~ s/\bTILDE\b/'~'/i | |
292 or $name =~ s/\bCIRCUMFLEX\b/'^'/i | |
293 or $name =~ s/\bSTROKE\b/'\/'/i | |
294 or $name =~ s/ ABOVE\b//i; | |
295 } | |
296 else { | |
297 use Unicode::UCD qw(prop_invmap); | |
298 my ($list_ref, $map_ref, $format) = prop_invmap("Name_Alias"); | |
299 if ($format !~ /^s/) { | |
300 use Carp; | |
301 carp "Unexpected format '$format' for 'Name_Alias"; | |
302 last; | |
303 } | |
304 my $which = Unicode::UCD::search_invlist($list_ref, $ord); | |
305 if (! defined $which) { | |
306 use Carp; | |
307 carp "No name found for code pont $ord"; | |
308 } | |
309 else { | |
310 my $map = $map_ref->[$which]; | |
311 if (! ref $map) { | |
312 $name = $map; | |
313 } | |
314 else { | |
315 # Just pick the first abbreviation if more than one | |
316 my @names = grep { $_ =~ /abbreviation/ } @$map; | |
317 $name = $names[0]; | |
318 } | |
319 $name =~ s/:.*//; | |
320 } | |
321 } | |
322 my $index = $a2n[$ord]; | |
323 $out[$index] = ($ord == $index) | |
324 ? sprintf "/* U+%02X %s */ %s,\n", $ord, $name, $bits[$ord] | |
325 : sprintf "/* 0x%02X U+%02X %s */ %s,\n", $index, $ord, $name, $bits[$ord]; | |
326 } | |
327 print $out_fh join "", @out; | |
328 print $out_fh "\n" . get_conditional_compile_line_end(); | |
329 } | |
330 | |
331 read_only_bottom_close_and_rename($out_fh) |