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)