This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
handy.h: New defn of isOCTAL_A() to free up bit
[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     BLANK_A
30     BLANK_L1
31     CHARNAME_CONT
32     CNTRL_A
33     CNTRL_L1
34     DIGIT_A
35     GRAPH_A
36     GRAPH_L1
37     IDFIRST_A
38     IDFIRST_L1
39     LOWER_A
40     LOWER_L1
41     PRINT_A
42     PRINT_L1
43     PSXSPC_A
44     PSXSPC_L1
45     PUNCT_A
46     PUNCT_L1
47     SPACE_A
48     SPACE_L1
49     UPPER_A
50     UPPER_L1
51     WORDCHAR_A
52     WORDCHAR_L1
53     XDIGIT_A
54     QUOTEMETA
55 );
56
57 # Read in the case fold mappings.
58 my %folded_closure;
59 my $file="lib/unicore/CaseFolding.txt";
60 open my $fh, "<", $file or die "Failed to read '$file': $!";
61 while (<$fh>) {
62     chomp;
63
64     # Lines look like (without the initial '#'
65     #0130; F; 0069 0307; # LATIN CAPITAL LETTER I WITH DOT ABOVE
66     # Get rid of comments, ignore blank or comment-only lines
67     my $line = $_ =~ s/ (?: \s* \# .* )? $ //rx;
68     next unless length $line;
69     my ($hex_from, $fold_type, @folded) = split /[\s;]+/, $line;
70
71     my $from = hex $hex_from;
72
73     # Perl only deals with C and F folds
74     next if $fold_type ne 'C' and $fold_type ne 'F';
75
76     # Get each code point in the range that participates in this line's fold.
77     # The hash has keys of each code point in the range, and values of what it
78     # folds to and what folds to it
79     foreach my $hex_fold (@folded) {
80         my $fold = hex $hex_fold;
81         push @{$folded_closure{$fold}}, $from if $fold < 256;
82         push @{$folded_closure{$from}}, $fold if $from < 256;
83     }
84 }
85
86 # Now having read all the lines, combine them into the full closure of each
87 # code point in the range by adding lists together that share a common element
88 foreach my $folded (keys %folded_closure) {
89     foreach my $from (grep { $_ < 256 } @{$folded_closure{$folded}}) {
90         push @{$folded_closure{$from}}, @{$folded_closure{$folded}};
91     }
92 }
93
94 my @bits;   # Bit map for each code point
95
96 foreach my $folded (keys %folded_closure) {
97     $bits[$folded] = "_CC_NONLATIN1_FOLD" if grep { $_ > 255 }
98                                                 @{$folded_closure{$folded}};
99 }
100
101 # For each character, calculate which properties it matches.
102 for my $ord (0..255) {
103     my $char = chr($ord);
104     utf8::upgrade($char);   # Important to use Unicode semantics!
105
106     # Look at all the properties we care about here.
107     for my $property (@properties) {
108         my $name = $property;
109
110         # Remove the suffix to get the actual property name.
111         # Currently the suffixes are '_L1', '_A', and none.
112         # If is a latin1 version, no further checking is needed.
113         if (! ($name =~ s/_L1$//)) {
114
115             # Here, isn't an _L1.  If its _A, it's automatically false for
116             # non-ascii.  The only one current one without a suffix is valid
117             # over the whole range.
118             next if $name =~ s/_A$// && $ord >= 128;
119
120         }
121         my $re;
122         if ($name eq 'PUNCT') {;
123
124             # Sadly, this is inconsistent: \pP and \pS for the ascii range,
125             # just \pP outside it.
126             $re = qr/\p{Punct}|[^\P{Symbol}\P{ASCII}]/;
127         } elsif ($name eq 'CHARNAME_CONT') {;
128             $re = qr/[-\p{XPosixWord} ():\xa0]/;
129         } elsif ($name eq 'SPACE') {;
130             $re = qr/\p{XPerlSpace}/;
131         } elsif ($name eq 'IDFIRST') {
132             $re = qr/[_\p{Alpha}]/;
133         } elsif ($name eq 'PSXSPC') {
134             $re = qr/[\v\p{Space}]/;
135         } elsif ($name eq 'WORDCHAR') {
136             $re = qr/\p{XPosixWord}/;
137         } elsif ($name eq 'ALNUMC') {
138             # Like \w, but no underscore
139             $re = qr/\p{Alnum}/;
140         } elsif ($name eq 'OCTAL') {
141             $re = qr/[0-7]/;
142         } elsif ($name eq 'QUOTEMETA') {
143             $re = qr/\p{_Perl_Quotemeta}/;
144         } else {    # The remainder have the same name and values as Unicode
145             $re = eval "qr/\\p{$name}/";
146             use Carp;
147             carp $@ if ! defined $re;
148         }
149         #print "$ord, $name $property, $re\n";
150         if ($char =~ $re) {  # Add this property if matches
151             $bits[$ord] .= '|' if $bits[$ord];
152             $bits[$ord] .= "_CC_$property";
153         }
154     }
155     #print __LINE__, " $ord $char $bits[$ord]\n";
156 }
157
158 # Names of C0 controls
159 my @C0 = qw (
160                 NUL
161                 SOH
162                 STX
163                 ETX
164                 EOT
165                 ENQ
166                 ACK
167                 BEL
168                 BS
169                 HT
170                 LF
171                 VT
172                 FF
173                 CR
174                 SO
175                 SI
176                 DLE
177                 DC1
178                 DC2
179                 DC3
180                 DC4
181                 NAK
182                 SYN
183                 ETB
184                 CAN
185                 EOM
186                 SUB
187                 ESC
188                 FS
189                 GS
190                 RS
191                 US
192             );
193
194 # Names of C1 controls, plus the adjacent DEL
195 my @C1 = qw(
196                 DEL
197                 PAD
198                 HOP
199                 BPH
200                 NBH
201                 IND
202                 NEL
203                 SSA
204                 ESA
205                 HTS
206                 HTJ
207                 VTS
208                 PLD
209                 PLU
210                 RI 
211                 SS2
212                 SS3
213                 DCS
214                 PU1
215                 PU2
216                 STS
217                 CCH
218                 MW 
219                 SPA
220                 EPA
221                 SOS
222                 SGC
223                 SCI
224                 CSI
225                 ST 
226                 OSC
227                 PM 
228                 APC
229             );
230
231 my $out_fh = open_new('l1_char_class_tab.h', '>',
232                       {style => '*', by => $0,
233                       from => "property definitions and $file"});
234
235 # Output the table using fairly short names for each char.
236 for my $ord (0..255) {
237     my $name;
238     if ($ord < 32) {    # A C0 control
239         $name = $C0[$ord];
240     } elsif ($ord > 32 && $ord < 127) { # Graphic
241         $name = "'" . chr($ord) . "'";
242     } elsif ($ord >= 127 && $ord <= 0x9f) {
243         $name = $C1[$ord - 127];    # A C1 control + DEL
244     } else {    # SPACE, or, if Latin1, shorten the name */
245         use charnames();
246         $name = charnames::viacode($ord);
247         $name =~ s/LATIN CAPITAL LETTER //
248         || $name =~ s/LATIN SMALL LETTER (.*)/\L$1/;
249     }
250     printf $out_fh "/* U+%02X %s */ %s,\n", $ord, $name, $bits[$ord];
251 }
252
253 read_only_bottom_close_and_rename($out_fh)