This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
18ab4ad0a6d418ec7a2a52a909c3e3cb559b93d6
[perl5.git] / regen / mk_PL_charclass.pl
1 #!perl -w
2 use v5.15.8;
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     NONLATIN1_FOLD
26     ALNUMC
27     ALPHA
28     ASCII
29     BLANK
30     CHARNAME_CONT
31     CNTRL
32     DIGIT
33     GRAPH
34     IDFIRST
35     LOWER
36     NON_FINAL_FOLD
37     PRINT
38     PSXSPC
39     PUNCT
40     QUOTEMETA
41     SPACE
42     UPPER
43     WORDCHAR
44     XDIGIT
45     IS_IN_SOME_FOLD
46 );
47
48 # Read in the case fold mappings.
49 my %folded_closure;
50 my @hex_non_final_folds;
51 my @folds;
52 use Unicode::UCD;
53
54 BEGIN { # Have to do this at compile time because using user-defined \p{property}
55
56     # Use the Unicode data file if we are on an ASCII platform (which its data
57     # is for), and it is in the modern format (starting in Unicode 3.1.0) and
58     # it is available.  This avoids being affected by potential bugs
59     # introduced by other layers of Perl
60     my $file="lib/unicore/CaseFolding.txt";
61
62     if (ord('A') == 65
63         && pack("C*", split /\./, Unicode::UCD::UnicodeVersion()) ge v3.1.0
64         && open my $fh, "<", $file)
65     {
66         @folds = <$fh>;
67     }
68     else {
69         my ($invlist_ref, $invmap_ref, undef, $default)
70                                     = Unicode::UCD::prop_invmap('Case_Folding');
71         for my $i (0 .. @$invlist_ref - 1 - 1) {
72             next if $invmap_ref->[$i] == $default;
73             my $adjust = -1;
74             for my $j ($invlist_ref->[$i] .. $invlist_ref->[$i+1] -1) {
75                 $adjust++;
76
77                 # Single-code point maps go to a 'C' type
78                 if (! ref $invmap_ref->[$i]) {
79                     push @folds, sprintf("%04X; C; %04X\n",
80                                         $j,
81                                         $invmap_ref->[$i] + $adjust);
82                 }
83                 else {  # Multi-code point maps go to 'F'.  prop_invmap()
84                         # guarantees that no adjustment is needed for these,
85                         # as the range will contain just one element
86                     push @folds, sprintf("%04X; F; %s\n",
87                                         $j,
88                                         join " ", map { sprintf "%04X", $_ }
89                                                         @{$invmap_ref->[$i]});
90                 }
91             }
92         }
93     }
94
95     for (@folds) {
96         chomp;
97
98         # Lines look like (without the initial '#'
99         #0130; F; 0069 0307; # LATIN CAPITAL LETTER I WITH DOT ABOVE
100         # Get rid of comments, ignore blank or comment-only lines
101         my $line = $_ =~ s/ (?: \s* \# .* )? $ //rx;
102         next unless length $line;
103         my ($hex_from, $fold_type, @folded) = split /[\s;]+/, $line;
104
105         my $from = hex $hex_from;
106
107         # Perl only deals with C and F folds
108         next if $fold_type ne 'C' and $fold_type ne 'F';
109
110         # Get each code point in the range that participates in this line's fold.
111         # The hash has keys of each code point in the range, and values of what it
112         # folds to and what folds to it
113         for my $i (0 .. @folded - 1) {
114             my $hex_fold = $folded[$i];
115             my $fold = hex $hex_fold;
116             push @{$folded_closure{$fold}}, $from if $fold < 256;
117             push @{$folded_closure{$from}}, $fold if $from < 256;
118
119             push @hex_non_final_folds, $hex_fold if $i < @folded-1 && $fold < 256;
120         }
121     }
122
123     # Now having read all the lines, combine them into the full closure of each
124     # code point in the range by adding lists together that share a common
125     # element
126     foreach my $folded (keys %folded_closure) {
127         foreach my $from (grep { $_ < 256 } @{$folded_closure{$folded}}) {
128             push @{$folded_closure{$from}}, @{$folded_closure{$folded}};
129         }
130     }
131 }
132
133 sub Is_Non_Latin1_Fold {
134     my @return;
135
136     foreach my $folded (keys %folded_closure) {
137         push @return, sprintf("%X", $folded), if grep { $_ > 255 }
138                                                      @{$folded_closure{$folded}};
139     }
140     return join("\n", @return) . "\n";
141 }
142
143 sub Is_Non_Final_Fold {
144     return join("\n", @hex_non_final_folds) . "\n";
145 }
146
147 my @bits;   # Bit map for each code point
148
149 # For each character, calculate which properties it matches.
150 for my $ord (0..255) {
151     my $char = chr($ord);
152     utf8::upgrade($char);   # Important to use Unicode semantics!
153
154     # Look at all the properties we care about here.
155     for my $property (@properties) {
156         my $name = $property;
157
158         # Remove the suffix to get the actual property name.
159         # Currently the suffixes are '_L1', '_A', and none.
160         # If is a latin1 version, no further checking is needed.
161         if (! ($name =~ s/_L1$//)) {
162
163             # Here, isn't an _L1.  If its _A, it's automatically false for
164             # non-ascii.  The only one current one (besides ASCII) without a
165             # suffix is valid over the whole range.
166             next if $name =~ s/_A$// && $ord >= 128;
167
168         }
169         my $re;
170         if ($name eq 'PUNCT') {;
171
172             # Sadly, this is inconsistent: \pP and \pS for the ascii range,
173             # just \pP outside it.
174             $re = qr/\p{Punct}|[^\P{Symbol}\P{ASCII}]/;
175         } elsif ($name eq 'CHARNAME_CONT') {;
176             $re = qr/[-\p{XPosixWord} ():\xa0]/;
177         } elsif ($name eq 'SPACE') {;
178             $re = qr/\p{XPerlSpace}/;
179         } elsif ($name eq 'IDFIRST') {
180             $re = qr/[_\p{Alpha}]/;
181         } elsif ($name eq 'PSXSPC') {
182             $re = qr/[\v\p{Space}]/;
183         } elsif ($name eq 'WORDCHAR') {
184             $re = qr/\p{XPosixWord}/;
185         } elsif ($name eq 'ALNUMC') {
186             # Like \w, but no underscore
187             $re = qr/\p{Alnum}/;
188         } elsif ($name eq 'QUOTEMETA') {
189             $re = qr/\p{_Perl_Quotemeta}/;
190         } elsif ($name eq 'NONLATIN1_FOLD') {
191             $re = qr/\p{Is_Non_Latin1_Fold}/;
192         } elsif ($name eq 'NON_FINAL_FOLD') {
193             $re = qr/\p{Is_Non_Final_Fold}/;
194         } elsif ($name eq 'IS_IN_SOME_FOLD') {
195             $re = qr/\p{_Perl_Any_Folds}/;
196         } else {    # The remainder have the same name and values as Unicode
197             $re = eval "qr/\\p{$name}/";
198             use Carp;
199             carp $@ if ! defined $re;
200         }
201         #print "$ord, $name $property, $re\n";
202         if ($char =~ $re  # Add this property if matches
203             || ($name eq 'NON_FINAL_FOLD'
204                 # Also include chars that fold to the non-final
205                 && CORE::fc($char) =~ $re))
206         {
207             $bits[$ord] .= '|' if $bits[$ord];
208             $bits[$ord] .= "(1U<<_CC_$property)";
209         }
210     }
211     #print __LINE__, " $ord $char $bits[$ord]\n";
212 }
213
214 # Names of C0 controls
215 my @C0 = qw (
216                 NUL
217                 SOH
218                 STX
219                 ETX
220                 EOT
221                 ENQ
222                 ACK
223                 BEL
224                 BS
225                 HT
226                 LF
227                 VT
228                 FF
229                 CR
230                 SO
231                 SI
232                 DLE
233                 DC1
234                 DC2
235                 DC3
236                 DC4
237                 NAK
238                 SYN
239                 ETB
240                 CAN
241                 EOM
242                 SUB
243                 ESC
244                 FS
245                 GS
246                 RS
247                 US
248             );
249
250 # Names of C1 controls, plus the adjacent DEL
251 my @C1 = qw(
252                 DEL
253                 PAD
254                 HOP
255                 BPH
256                 NBH
257                 IND
258                 NEL
259                 SSA
260                 ESA
261                 HTS
262                 HTJ
263                 VTS
264                 PLD
265                 PLU
266                 RI 
267                 SS2
268                 SS3
269                 DCS
270                 PU1
271                 PU2
272                 STS
273                 CCH
274                 MW 
275                 SPA
276                 EPA
277                 SOS
278                 SGC
279                 SCI
280                 CSI
281                 ST 
282                 OSC
283                 PM 
284                 APC
285             );
286
287 my $out_fh = open_new('l1_char_class_tab.h', '>',
288                       {style => '*', by => $0,
289                       from => "property definitions"});
290
291 # Output the table using fairly short names for each char.
292 for my $ord (0..255) {
293     my $name;
294     if ($ord < 32) {    # A C0 control
295         $name = $C0[$ord];
296     } elsif ($ord > 32 && $ord < 127) { # Graphic
297         $name = "'" . chr($ord) . "'";
298     } elsif ($ord >= 127 && $ord <= 0x9f) {
299         $name = $C1[$ord - 127];    # A C1 control + DEL
300     } else {    # SPACE, or, if Latin1, shorten the name */
301         use charnames();
302         $name = charnames::viacode($ord);
303         $name =~ s/LATIN CAPITAL LETTER //
304         || $name =~ s/LATIN SMALL LETTER (.*)/\L$1/;
305     }
306     printf $out_fh "/* U+%02X %s */ %s,\n", $ord, $name, $bits[$ord];
307 }
308
309 read_only_bottom_close_and_rename($out_fh)