This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
handy.h: l1_charclass.h: Add bit for matching ASCII
[perl5.git] / regen / mk_PL_charclass.pl
1 #!perl -w
2 use 5.012;
3 use strict;
4 use warnings;
5 require 'regen/regen_lib.pl';
6
7 # This program outputs l1_charclass_tab.h, which defines the guts of the
8 # PL_charclass table.  Each line is a bit map of properties that the Unicode
9 # code point at the corresponding position in the table array has.  The first
10 # line corresponds to code point U+0000, NULL, the last line to U+00FF.  For
11 # an application to see if the code point "i" has a particular property, it
12 # just does
13 #    'PL_charclass[i] & BIT'
14 # The bit names are of the form '_CC_property_suffix', where 'CC' stands for
15 # character class, and 'property' is the corresponding property, and 'suffix'
16 # is one of '_A' to mean the property is true only if the corresponding code
17 # point is ASCII, and '_L1' means that the range includes any Latin1
18 # character (ISO-8859-1 including the C0 and C1 controls).  A property without
19 # these suffixes does not have different forms for both ranges.
20
21 # This program need be run only when adding new properties to it, or upon a
22 # new Unicode release, to make sure things haven't been changed by it.
23
24 my @properties = qw(
25     ALNUMC_A
26     ALNUMC_L1
27     ALPHA_A
28     ALPHA_L1
29     ASCII
30     BLANK_A
31     BLANK_L1
32     CHARNAME_CONT
33     CNTRL_A
34     CNTRL_L1
35     DIGIT_A
36     GRAPH_A
37     GRAPH_L1
38     IDFIRST_A
39     IDFIRST_L1
40     LOWER_A
41     LOWER_L1
42     PRINT_A
43     PRINT_L1
44     PSXSPC_A
45     PSXSPC_L1
46     PUNCT_A
47     PUNCT_L1
48     SPACE_A
49     SPACE_L1
50     UPPER_A
51     UPPER_L1
52     WORDCHAR_A
53     WORDCHAR_L1
54     XDIGIT_A
55     QUOTEMETA
56 );
57
58 # Read in the case fold mappings.
59 my %folded_closure;
60 my $file="lib/unicore/CaseFolding.txt";
61 my @folds;
62 use Unicode::UCD;
63
64 # Use the Unicode data file if we are on an ASCII platform (which its data is
65 # for), and it is in the modern format (starting in Unicode 3.1.0) and it is
66 # available.  This avoids being affected by potential bugs introduced by other
67 # layers of Perl
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)
76                                     = Unicode::UCD::prop_invmap('Case_Folding');
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             }
97         }
98     }
99 }
100
101 for (@folds) {
102     chomp;
103
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;
110
111     my $from = hex $hex_from;
112
113     # Perl only deals with C and F folds
114     next if $fold_type ne 'C' and $fold_type ne 'F';
115
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     foreach my $hex_fold (@folded) {
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 }
125
126 # Now having read all the lines, combine them into the full closure of each
127 # code point in the range by adding lists together that share a common element
128 foreach my $folded (keys %folded_closure) {
129     foreach my $from (grep { $_ < 256 } @{$folded_closure{$folded}}) {
130         push @{$folded_closure{$from}}, @{$folded_closure{$folded}};
131     }
132 }
133
134 my @bits;   # Bit map for each code point
135
136 foreach my $folded (keys %folded_closure) {
137     $bits[$folded] = "_CC_NONLATIN1_FOLD" if grep { $_ > 255 }
138                                                 @{$folded_closure{$folded}};
139 }
140
141 # For each character, calculate which properties it matches.
142 for my $ord (0..255) {
143     my $char = chr($ord);
144     utf8::upgrade($char);   # Important to use Unicode semantics!
145
146     # Look at all the properties we care about here.
147     for my $property (@properties) {
148         my $name = $property;
149
150         # Remove the suffix to get the actual property name.
151         # Currently the suffixes are '_L1', '_A', and none.
152         # If is a latin1 version, no further checking is needed.
153         if (! ($name =~ s/_L1$//)) {
154
155             # Here, isn't an _L1.  If its _A, it's automatically false for
156             # non-ascii.  The only one current one (besides ASCII) without a
157             # suffix is valid over the whole range.
158             next if $name =~ s/_A$// && $ord >= 128;
159
160         }
161         my $re;
162         if ($name eq 'PUNCT') {;
163
164             # Sadly, this is inconsistent: \pP and \pS for the ascii range,
165             # just \pP outside it.
166             $re = qr/\p{Punct}|[^\P{Symbol}\P{ASCII}]/;
167         } elsif ($name eq 'CHARNAME_CONT') {;
168             $re = qr/[-\p{XPosixWord} ():\xa0]/;
169         } elsif ($name eq 'SPACE') {;
170             $re = qr/\p{XPerlSpace}/;
171         } elsif ($name eq 'IDFIRST') {
172             $re = qr/[_\p{Alpha}]/;
173         } elsif ($name eq 'PSXSPC') {
174             $re = qr/[\v\p{Space}]/;
175         } elsif ($name eq 'WORDCHAR') {
176             $re = qr/\p{XPosixWord}/;
177         } elsif ($name eq 'ALNUMC') {
178             # Like \w, but no underscore
179             $re = qr/\p{Alnum}/;
180         } elsif ($name eq 'OCTAL') {
181             $re = qr/[0-7]/;
182         } elsif ($name eq 'QUOTEMETA') {
183             $re = qr/\p{_Perl_Quotemeta}/;
184         } else {    # The remainder have the same name and values as Unicode
185             $re = eval "qr/\\p{$name}/";
186             use Carp;
187             carp $@ if ! defined $re;
188         }
189         #print "$ord, $name $property, $re\n";
190         if ($char =~ $re) {  # Add this property if matches
191             $bits[$ord] .= '|' if $bits[$ord];
192             $bits[$ord] .= "_CC_$property";
193         }
194     }
195     #print __LINE__, " $ord $char $bits[$ord]\n";
196 }
197
198 # Names of C0 controls
199 my @C0 = qw (
200                 NUL
201                 SOH
202                 STX
203                 ETX
204                 EOT
205                 ENQ
206                 ACK
207                 BEL
208                 BS
209                 HT
210                 LF
211                 VT
212                 FF
213                 CR
214                 SO
215                 SI
216                 DLE
217                 DC1
218                 DC2
219                 DC3
220                 DC4
221                 NAK
222                 SYN
223                 ETB
224                 CAN
225                 EOM
226                 SUB
227                 ESC
228                 FS
229                 GS
230                 RS
231                 US
232             );
233
234 # Names of C1 controls, plus the adjacent DEL
235 my @C1 = qw(
236                 DEL
237                 PAD
238                 HOP
239                 BPH
240                 NBH
241                 IND
242                 NEL
243                 SSA
244                 ESA
245                 HTS
246                 HTJ
247                 VTS
248                 PLD
249                 PLU
250                 RI 
251                 SS2
252                 SS3
253                 DCS
254                 PU1
255                 PU2
256                 STS
257                 CCH
258                 MW 
259                 SPA
260                 EPA
261                 SOS
262                 SGC
263                 SCI
264                 CSI
265                 ST 
266                 OSC
267                 PM 
268                 APC
269             );
270
271 my $out_fh = open_new('l1_char_class_tab.h', '>',
272                       {style => '*', by => $0,
273                       from => "property definitions"});
274
275 # Output the table using fairly short names for each char.
276 for my $ord (0..255) {
277     my $name;
278     if ($ord < 32) {    # A C0 control
279         $name = $C0[$ord];
280     } elsif ($ord > 32 && $ord < 127) { # Graphic
281         $name = "'" . chr($ord) . "'";
282     } elsif ($ord >= 127 && $ord <= 0x9f) {
283         $name = $C1[$ord - 127];    # A C1 control + DEL
284     } else {    # SPACE, or, if Latin1, shorten the name */
285         use charnames();
286         $name = charnames::viacode($ord);
287         $name =~ s/LATIN CAPITAL LETTER //
288         || $name =~ s/LATIN SMALL LETTER (.*)/\L$1/;
289     }
290     printf $out_fh "/* U+%02X %s */ %s,\n", $ord, $name, $bits[$ord];
291 }
292
293 read_only_bottom_close_and_rename($out_fh)