Commit | Line | Data |
---|---|---|
9c68f0ab | 1 | #!perl -w |
b72a36d4 | 2 | use v5.15.8; |
9c68f0ab KW |
3 | use strict; |
4 | use warnings; | |
3d7c117d MB |
5 | require './regen/regen_lib.pl'; |
6 | require './regen/charset_translations.pl'; | |
9c68f0ab | 7 | |
b1909af7 KW |
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 | |
8d4ab2a1 | 10 | # code point at the corresponding position in the table array has. The first |
b1909af7 | 11 | # line corresponds to code point U+0000, NULL, the last line to U+00FF. For |
8d4ab2a1 KW |
12 | # an application to see if the code point "i" has a particular property, it |
13 | # just does | |
9c68f0ab KW |
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 | ||
b1909af7 KW |
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. | |
9c68f0ab KW |
24 | |
25 | my @properties = qw( | |
f12c0118 | 26 | NONLATIN1_SIMPLE_FOLD |
62841d05 | 27 | NONLATIN1_FOLD |
15861f94 | 28 | ALPHANUMERIC |
f4cdb42c | 29 | ALPHA |
e48bdfbc | 30 | ASCII |
f4cdb42c | 31 | BLANK |
b0d691b2 | 32 | CASED |
9c68f0ab | 33 | CHARNAME_CONT |
f4cdb42c KW |
34 | CNTRL |
35 | DIGIT | |
36 | GRAPH | |
37 | IDFIRST | |
38 | LOWER | |
b72a36d4 | 39 | NON_FINAL_FOLD |
f4cdb42c | 40 | |
f4cdb42c | 41 | PUNCT |
9a022f3a | 42 | QUOTEMETA |
f4cdb42c KW |
43 | SPACE |
44 | UPPER | |
45 | WORDCHAR | |
46 | XDIGIT | |
a0947d7b | 47 | VERTSPACE |
f7993745 | 48 | IS_IN_SOME_FOLD |
8e35b056 | 49 | MNEMONIC_CNTRL |
9c68f0ab KW |
50 | ); |
51 | ||
00c072cf KW |
52 | # Read in the case fold mappings. |
53 | my %folded_closure; | |
377a5857 | 54 | my %simple_folded_closure; |
62841d05 | 55 | my @hex_non_final_folds; |
f12c0118 | 56 | my @non_latin1_simple_folds; |
dbe1ba6b KW |
57 | my @folds; |
58 | use Unicode::UCD; | |
59 | ||
62841d05 KW |
60 | BEGIN { # Have to do this at compile time because using user-defined \p{property} |
61 | ||
4ef0bd69 KW |
62 | # Use the Unicode data file if we are on an ASCII platform (which its data |
63 | # is for), and it is in the modern format (starting in Unicode 3.1.0) and | |
64 | # it is available. This avoids being affected by potential bugs | |
65 | # introduced by other layers of Perl | |
66 | my $file="lib/unicore/CaseFolding.txt"; | |
67 | ||
68 | if (ord('A') == 65 | |
69 | && pack("C*", split /\./, Unicode::UCD::UnicodeVersion()) ge v3.1.0 | |
70 | && open my $fh, "<", $file) | |
71 | { | |
72 | @folds = <$fh>; | |
73 | } | |
74 | else { | |
75 | my ($invlist_ref, $invmap_ref, undef, $default) | |
dbe1ba6b | 76 | = Unicode::UCD::prop_invmap('Case_Folding'); |
4ef0bd69 KW |
77 | for my $i (0 .. @$invlist_ref - 1 - 1) { |
78 | next if $invmap_ref->[$i] == $default; | |
79 | my $adjust = -1; | |
80 | for my $j ($invlist_ref->[$i] .. $invlist_ref->[$i+1] -1) { | |
81 | $adjust++; | |
82 | ||
83 | # Single-code point maps go to a 'C' type | |
84 | if (! ref $invmap_ref->[$i]) { | |
85 | push @folds, sprintf("%04X; C; %04X\n", | |
86 | $j, | |
87 | $invmap_ref->[$i] + $adjust); | |
88 | } | |
89 | else { # Multi-code point maps go to 'F'. prop_invmap() | |
90 | # guarantees that no adjustment is needed for these, | |
91 | # as the range will contain just one element | |
92 | push @folds, sprintf("%04X; F; %s\n", | |
93 | $j, | |
94 | join " ", map { sprintf "%04X", $_ } | |
95 | @{$invmap_ref->[$i]}); | |
96 | } | |
dbe1ba6b KW |
97 | } |
98 | } | |
99 | } | |
dbe1ba6b | 100 | |
4ef0bd69 KW |
101 | for (@folds) { |
102 | chomp; | |
00c072cf | 103 | |
4ef0bd69 KW |
104 | # Lines look like (without the initial '#' |
105 | #0130; F; 0069 0307; # LATIN CAPITAL LETTER I WITH DOT ABOVE | |
106 | # Get rid of comments, ignore blank or comment-only lines | |
107 | my $line = $_ =~ s/ (?: \s* \# .* )? $ //rx; | |
108 | next unless length $line; | |
109 | my ($hex_from, $fold_type, @folded) = split /[\s;]+/, $line; | |
00c072cf | 110 | |
4ef0bd69 | 111 | my $from = hex $hex_from; |
00c072cf | 112 | |
f12c0118 KW |
113 | # Perl only deals with S, C, and F folds |
114 | next if $fold_type ne 'C' and $fold_type ne 'F' and $fold_type ne 'S'; | |
00c072cf | 115 | |
4ef0bd69 KW |
116 | # Get each code point in the range that participates in this line's fold. |
117 | # The hash has keys of each code point in the range, and values of what it | |
118 | # folds to and what folds to it | |
119 | for my $i (0 .. @folded - 1) { | |
120 | my $hex_fold = $folded[$i]; | |
121 | my $fold = hex $hex_fold; | |
377a5857 KW |
122 | if ($fold < 256) { |
123 | push @{$folded_closure{$fold}}, $from; | |
124 | push @{$simple_folded_closure{$fold}}, $from if $fold_type ne 'F'; | |
125 | } | |
126 | if ($from < 256) { | |
127 | push @{$folded_closure{$from}}, $fold; | |
128 | push @{$simple_folded_closure{$from}}, $fold if $fold_type ne 'F'; | |
129 | } | |
62841d05 | 130 | |
f12c0118 KW |
131 | if (($fold_type eq 'C' || $fold_type eq 'S') |
132 | && ($fold < 256 != $from < 256)) | |
133 | { | |
134 | # Fold is simple (hence can't be a non-final fold, so the 'if' | |
135 | # above is mutualy exclusive from the 'if below) and crosses | |
136 | # 255/256 boundary. We keep track of the Latin1 code points | |
137 | # in such folds. | |
138 | push @non_latin1_simple_folds, ($fold < 256) | |
139 | ? $fold | |
140 | : $from; | |
141 | } | |
142 | elsif ($i < @folded-1 | |
143 | && $fold < 256 | |
144 | && ! grep { $_ eq $hex_fold } @hex_non_final_folds) | |
07725c18 KW |
145 | { |
146 | push @hex_non_final_folds, $hex_fold; | |
147 | ||
148 | # Also add the upper case, which in the latin1 range folds to | |
149 | # $fold | |
150 | push @hex_non_final_folds, sprintf "%04X", ord uc chr $fold; | |
151 | } | |
4ef0bd69 | 152 | } |
00c072cf | 153 | } |
00c072cf | 154 | |
4ef0bd69 KW |
155 | # Now having read all the lines, combine them into the full closure of each |
156 | # code point in the range by adding lists together that share a common | |
157 | # element | |
158 | foreach my $folded (keys %folded_closure) { | |
159 | foreach my $from (grep { $_ < 256 } @{$folded_closure{$folded}}) { | |
160 | push @{$folded_closure{$from}}, @{$folded_closure{$folded}}; | |
161 | } | |
00c072cf | 162 | } |
377a5857 KW |
163 | foreach my $folded (keys %simple_folded_closure) { |
164 | foreach my $from (grep { $_ < 256 } @{$simple_folded_closure{$folded}}) { | |
165 | push @{$simple_folded_closure{$from}}, @{$simple_folded_closure{$folded}}; | |
166 | } | |
167 | } | |
f12c0118 KW |
168 | |
169 | # We have the single-character folds that cross the 255/256, like KELVIN | |
170 | # SIGN => 'k', but we need the closure, so add like 'K' to it | |
171 | foreach my $folded (@non_latin1_simple_folds) { | |
377a5857 | 172 | foreach my $fold (@{$simple_folded_closure{$folded}}) { |
f12c0118 KW |
173 | if ($fold < 256 && ! grep { $fold == $_ } @non_latin1_simple_folds) { |
174 | push @non_latin1_simple_folds, $fold; | |
175 | } | |
176 | } | |
177 | } | |
00c072cf KW |
178 | } |
179 | ||
62841d05 KW |
180 | sub Is_Non_Latin1_Fold { |
181 | my @return; | |
182 | ||
183 | foreach my $folded (keys %folded_closure) { | |
184 | push @return, sprintf("%X", $folded), if grep { $_ > 255 } | |
185 | @{$folded_closure{$folded}}; | |
186 | } | |
187 | return join("\n", @return) . "\n"; | |
00c072cf KW |
188 | } |
189 | ||
f12c0118 KW |
190 | sub Is_Non_Latin1_Simple_Fold { # Latin1 code points that are folded to by |
191 | # non-Latin1 code points as single character | |
192 | # folds | |
193 | return join("\n", map { sprintf "%X", $_ } @non_latin1_simple_folds) . "\n"; | |
194 | } | |
195 | ||
62841d05 KW |
196 | sub Is_Non_Final_Fold { |
197 | return join("\n", @hex_non_final_folds) . "\n"; | |
198 | } | |
199 | ||
200 | my @bits; # Bit map for each code point | |
201 | ||
b1909af7 | 202 | # For each character, calculate which properties it matches. |
9c68f0ab KW |
203 | for my $ord (0..255) { |
204 | my $char = chr($ord); | |
850b7ec9 | 205 | utf8::upgrade($char); # Important to use Unicode rules! |
b1909af7 KW |
206 | |
207 | # Look at all the properties we care about here. | |
9c68f0ab KW |
208 | for my $property (@properties) { |
209 | my $name = $property; | |
210 | ||
b1909af7 KW |
211 | # Remove the suffix to get the actual property name. |
212 | # Currently the suffixes are '_L1', '_A', and none. | |
9c68f0ab KW |
213 | # If is a latin1 version, no further checking is needed. |
214 | if (! ($name =~ s/_L1$//)) { | |
215 | ||
b1909af7 | 216 | # Here, isn't an _L1. If its _A, it's automatically false for |
a0947d7b KW |
217 | # non-ascii. The only current ones (besides ASCII) without a |
218 | # suffix are valid over the whole range. | |
620ee5ce | 219 | next if $name =~ s/_A$// && $char !~ /\p{ASCII}/; |
9c68f0ab KW |
220 | } |
221 | my $re; | |
222 | if ($name eq 'PUNCT') {; | |
223 | ||
224 | # Sadly, this is inconsistent: \pP and \pS for the ascii range, | |
225 | # just \pP outside it. | |
226 | $re = qr/\p{Punct}|[^\P{Symbol}\P{ASCII}]/; | |
227 | } elsif ($name eq 'CHARNAME_CONT') {; | |
699ffc5e | 228 | $re = qr/\p{_Perl_Charname_Continue}/, |
9c68f0ab | 229 | } elsif ($name eq 'SPACE') {; |
c6e8e4a9 | 230 | $re = qr/\p{XPerlSpace}/; |
9c68f0ab | 231 | } elsif ($name eq 'IDFIRST') { |
44bc4f26 | 232 | $re = qr/[_\p{XPosixAlpha}]/; |
9c68f0ab | 233 | } elsif ($name eq 'WORDCHAR') { |
c6e8e4a9 | 234 | $re = qr/\p{XPosixWord}/; |
44bc4f26 KW |
235 | } elsif ($name eq 'LOWER') { |
236 | $re = qr/\p{XPosixLower}/; | |
237 | } elsif ($name eq 'UPPER') { | |
238 | $re = qr/\p{XPosixUpper}/; | |
15861f94 | 239 | } elsif ($name eq 'ALPHANUMERIC') { |
9c68f0ab | 240 | # Like \w, but no underscore |
aedd44b5 | 241 | $re = qr/\p{Alnum}/; |
44bc4f26 KW |
242 | } elsif ($name eq 'ALPHA') { |
243 | $re = qr/\p{XPosixAlpha}/; | |
9a022f3a KW |
244 | } elsif ($name eq 'QUOTEMETA') { |
245 | $re = qr/\p{_Perl_Quotemeta}/; | |
62841d05 KW |
246 | } elsif ($name eq 'NONLATIN1_FOLD') { |
247 | $re = qr/\p{Is_Non_Latin1_Fold}/; | |
f12c0118 KW |
248 | } elsif ($name eq 'NONLATIN1_SIMPLE_FOLD') { |
249 | $re = qr/\p{Is_Non_Latin1_Simple_Fold}/; | |
b72a36d4 | 250 | } elsif ($name eq 'NON_FINAL_FOLD') { |
62841d05 | 251 | $re = qr/\p{Is_Non_Final_Fold}/; |
f7993745 KW |
252 | } elsif ($name eq 'IS_IN_SOME_FOLD') { |
253 | $re = qr/\p{_Perl_Any_Folds}/; | |
8e35b056 KW |
254 | } elsif ($name eq 'MNEMONIC_CNTRL') { |
255 | # These are the control characters that there are mnemonics for | |
256 | $re = qr/[\a\b\e\f\n\r\t]/; | |
9c68f0ab KW |
257 | } else { # The remainder have the same name and values as Unicode |
258 | $re = eval "qr/\\p{$name}/"; | |
259 | use Carp; | |
260 | carp $@ if ! defined $re; | |
261 | } | |
12eccaf1 | 262 | #print STDERR __LINE__, ": $ord, $name $property, $re\n"; |
07725c18 | 263 | if ($char =~ $re) { # Add this property if matches |
9c68f0ab | 264 | $bits[$ord] .= '|' if $bits[$ord]; |
265c1f46 | 265 | $bits[$ord] .= "(1U<<_CC_$property)"; |
9c68f0ab KW |
266 | } |
267 | } | |
268 | #print __LINE__, " $ord $char $bits[$ord]\n"; | |
269 | } | |
270 | ||
cc49830d | 271 | my $out_fh = open_new('l1_char_class_tab.h', '>', |
b1909af7 | 272 | {style => '*', by => $0, |
dbe1ba6b | 273 | from => "property definitions"}); |
cfb8fd6a | 274 | |
29ec702e KW |
275 | print $out_fh <<END; |
276 | /* For code points whose position is not the same as Unicode, both are shown | |
277 | * in the comment*/ | |
278 | END | |
279 | ||
9c68f0ab | 280 | # Output the table using fairly short names for each char. |
073c22b3 KW |
281 | my $is_for_ascii = 1; # get_supported_code_pages() returns the ASCII |
282 | # character set first | |
29ec702e | 283 | foreach my $charset (get_supported_code_pages()) { |
c30a0cf2 | 284 | my @a2n = @{get_a2n($charset)}; |
29ec702e | 285 | my @out; |
073c22b3 KW |
286 | my @utf_to_i8; |
287 | ||
288 | if ($is_for_ascii) { | |
289 | $is_for_ascii = 0; | |
290 | } | |
291 | else { # EBCDIC. Calculate mapping from UTF-EBCDIC bytes to I8 | |
292 | my $i8_to_utf_ref = get_I8_2_utf($charset); | |
293 | for my $i (0..255) { | |
294 | $utf_to_i8[$i8_to_utf_ref->[$i]] = $i; | |
295 | } | |
296 | } | |
29ec702e KW |
297 | |
298 | print $out_fh "\n" . get_conditional_compile_line_start($charset); | |
64d34faf KW |
299 | for my $ord (0..255) { |
300 | my $name; | |
301 | my $char = chr $ord; | |
302 | if ($char =~ /\p{PosixGraph}/) { | |
303 | my $quote = $char eq "'" ? '"' : "'"; | |
304 | $name = $quote . chr($ord) . $quote; | |
620ee5ce | 305 | } |
64d34faf KW |
306 | elsif ($char =~ /\p{XPosixGraph}/) { |
307 | use charnames(); | |
308 | $name = charnames::viacode($ord); | |
309 | $name =~ s/LATIN CAPITAL LETTER // | |
310 | or $name =~ s/LATIN SMALL LETTER (.*)/\L$1/ | |
311 | or $name =~ s/ SIGN\b// | |
312 | or $name =~ s/EXCLAMATION MARK/'!'/ | |
313 | or $name =~ s/QUESTION MARK/'?'/ | |
314 | or $name =~ s/QUOTATION MARK/QUOTE/ | |
315 | or $name =~ s/ INDICATOR//; | |
316 | $name =~ s/\bWITH\b/\L$&/; | |
317 | $name =~ s/\bONE\b/1/; | |
318 | $name =~ s/\b(TWO|HALF)\b/2/; | |
319 | $name =~ s/\bTHREE\b/3/; | |
320 | $name =~ s/\b QUARTER S? \b/4/x; | |
321 | $name =~ s/VULGAR FRACTION (.) (.)/$1\/$2/; | |
322 | $name =~ s/\bTILDE\b/'~'/i | |
323 | or $name =~ s/\bCIRCUMFLEX\b/'^'/i | |
324 | or $name =~ s/\bSTROKE\b/'\/'/i | |
325 | or $name =~ s/ ABOVE\b//i; | |
620ee5ce KW |
326 | } |
327 | else { | |
64d34faf | 328 | use Unicode::UCD qw(prop_invmap); |
ce8d64d9 KW |
329 | my ($list_ref, $map_ref, $format) |
330 | = prop_invmap("_Perl_Name_Alias", '_perl_core_internal_ok'); | |
64d34faf KW |
331 | if ($format !~ /^s/) { |
332 | use Carp; | |
ce8d64d9 | 333 | carp "Unexpected format '$format' for '_Perl_Name_Alias"; |
64d34faf KW |
334 | last; |
335 | } | |
336 | my $which = Unicode::UCD::search_invlist($list_ref, $ord); | |
337 | if (! defined $which) { | |
338 | use Carp; | |
339 | carp "No name found for code pont $ord"; | |
620ee5ce KW |
340 | } |
341 | else { | |
64d34faf KW |
342 | my $map = $map_ref->[$which]; |
343 | if (! ref $map) { | |
344 | $name = $map; | |
345 | } | |
346 | else { | |
347 | # Just pick the first abbreviation if more than one | |
348 | my @names = grep { $_ =~ /abbreviation/ } @$map; | |
349 | $name = $names[0]; | |
350 | } | |
351 | $name =~ s/:.*//; | |
620ee5ce | 352 | } |
620ee5ce | 353 | } |
c93ea49e | 354 | |
64d34faf | 355 | my $index = $a2n[$ord]; |
073c22b3 KW |
356 | my $i8; |
357 | $i8 = $utf_to_i8[$index] if @utf_to_i8; | |
358 | ||
c93ea49e KW |
359 | $out[$index] = "/* "; |
360 | $out[$index] .= sprintf "0x%02X ", $index if $ord != $index; | |
361 | $out[$index] .= sprintf "U+%02X ", $ord; | |
0f191379 | 362 | $out[$index] .= sprintf "I8=%02X ", $i8 if defined $i8 && $i8 != $ord; |
c93ea49e KW |
363 | $out[$index] .= "$name */ "; |
364 | $out[$index] .= $bits[$ord]; | |
073c22b3 KW |
365 | |
366 | # For EBCDIC character sets, we also add some data for when the bytes | |
367 | # are in UTF-EBCDIC; these are based on the fundamental | |
368 | # characteristics of UTF-EBCDIC. | |
369 | if (@utf_to_i8) { | |
370 | if ($i8 >= 0xC5 && $i8 != 0xE0) { | |
371 | $out[$index] .= '|(1U<<_CC_UTF8_IS_START)'; | |
372 | if ($i8 <= 0xC7) { | |
373 | $out[$index] .= '|(1U<<_CC_UTF8_IS_DOWNGRADEABLE_START)'; | |
374 | } | |
375 | } | |
376 | if (($i8 & 0xE0) == 0xA0) { | |
377 | $out[$index] .= '|(1U<<_CC_UTF8_IS_CONTINUATION)'; | |
378 | } | |
5d5376e2 KW |
379 | if ($i8 >= 0xF1) { |
380 | $out[$index] .= | |
381 | '|(1U<<_CC_UTF8_START_BYTE_IS_FOR_AT_LEAST_SURROGATE)'; | |
382 | } | |
073c22b3 KW |
383 | } |
384 | ||
c93ea49e | 385 | $out[$index] .= ",\n"; |
9c68f0ab | 386 | } |
e8368231 KW |
387 | $out[-1] =~ s/,$//; # No trailing comma in the final entry |
388 | ||
29ec702e KW |
389 | print $out_fh join "", @out; |
390 | print $out_fh "\n" . get_conditional_compile_line_end(); | |
9c68f0ab KW |
391 | } |
392 | ||
cfb8fd6a | 393 | read_only_bottom_close_and_rename($out_fh) |