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