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 rules!
 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$// && $char !~ /\p{ASCII}/;
 179         }
 180         my $re;
 181         if ($name eq 'PUNCT') {;
 182
 183             # Sadly, this is inconsistent: \pP and \pS for the ascii range,
 184             # just \pP outside it.
 185             $re = qr/\p{Punct}|[^\P{Symbol}\P{ASCII}]/;
 186         } elsif ($name eq 'CHARNAME_CONT') {;
 187             $re = qr/\p{_Perl_Charname_Continue}/,
 188         } elsif ($name eq 'SPACE') {;
 189             $re = qr/\p{XPerlSpace}/;
 190         } elsif ($name eq 'IDFIRST') {
 191             $re = qr/[_\p{Alpha}]/;
 192         } elsif ($name eq 'PSXSPC') {
 193             $re = qr/[\v\p{Space}]/;
 194         } elsif ($name eq 'WORDCHAR') {
 195             $re = qr/\p{XPosixWord}/;
 196         } elsif ($name eq 'ALPHANUMERIC') {
 197             # Like \w, but no underscore
 198             $re = qr/\p{Alnum}/;
 199         } elsif ($name eq 'QUOTEMETA') {
 200             $re = qr/\p{_Perl_Quotemeta}/;
 201         } elsif ($name eq 'NONLATIN1_FOLD') {
 202             $re = qr/\p{Is_Non_Latin1_Fold}/;
 203         } elsif ($name eq 'NON_FINAL_FOLD') {
 204             $re = qr/\p{Is_Non_Final_Fold}/;
 205         } elsif ($name eq 'IS_IN_SOME_FOLD') {
 206             $re = qr/\p{_Perl_Any_Folds}/;
 207         } elsif ($name eq 'BACKSLASH_FOO_LBRACE_IS_META') {
 208
 209             # This is true for FOO where FOO is the varying character in:
 210             # \a{, \b{, \c{, ...
 211             # and the sequence has non-literal meaning to Perl; so it is true
 212             # for 'x' because \x{ is special, but not 'a' because \a{ isn't.
 213             $re = qr/[gkNopPx]/;
 214         } else {    # The remainder have the same name and values as Unicode
 215             $re = eval "qr/\\p{$name}/";
 216             use Carp;
 217             carp $@ if ! defined $re;
 218         }
 219         #print "$ord, $name $property, $re\n";
 220         if ($char =~ $re) {  # Add this property if matches
 221             $bits[$ord] .= '|' if $bits[$ord];
 222             $bits[$ord] .= "(1U<<_CC_$property)";
 223         }
 224     }
 225     #print __LINE__, " $ord $char $bits[$ord]\n";
 226 }
 227
 228 my $out_fh = open_new('l1_char_class_tab.h', '>',
 229                       {style => '*', by => $0,
 230                       from => "property definitions"});
 231
 232 # Output the table using fairly short names for each char.
 233 for my $ord (0..255) {
 234     my $name;
 235     my $char = chr $ord;
 236     if ($char =~ /\p{PosixGraph}/) {
 237         my $quote = $char eq "'" ? '"' : "'";
 238         $name = $quote . chr($ord) . $quote;
 239     }
 240     elsif ($char =~ /\p{XPosixGraph}/) {
 241         use charnames();
 242         $name = charnames::viacode($ord);
 243         $name =~ s/LATIN CAPITAL LETTER //
 244                 or $name =~ s/LATIN SMALL LETTER (.*)/\L$1/
 245                 or $name =~ s/ SIGN\b//
 246                 or $name =~ s/EXCLAMATION MARK/'!'/
 247                 or $name =~ s/QUESTION MARK/'?'/
 248                 or $name =~ s/QUOTATION MARK/QUOTE/
 249                 or $name =~ s/ INDICATOR//;
 250         $name =~ s/\bWITH\b/\L$&/;
 251         $name =~ s/\bONE\b/1/;
 252         $name =~ s/\b(TWO|HALF)\b/2/;
 253         $name =~ s/\bTHREE\b/3/;
 254         $name =~ s/\b QUARTER S? \b/4/x;
 255         $name =~ s/VULGAR FRACTION (.) (.)/$1\/$2/;
 256         $name =~ s/\bTILDE\b/'~'/i
 257                 or $name =~ s/\bCIRCUMFLEX\b/'^'/i
 258                 or $name =~ s/\bSTROKE\b/'\/'/i
 259                 or $name =~ s/ ABOVE\b//i;
 260     }
 261     else {
 262         use Unicode::UCD qw(prop_invmap);
 263         my ($list_ref, $map_ref, $format) = prop_invmap("Name_Alias");
 264         if ($format !~ /^s/) {
 265             use Carp;
 266             carp "Unexpected format '$format' for 'Name_Alias";
 267             last;
 268         }
 269         my $which = Unicode::UCD::search_invlist($list_ref, $ord);
 270         if (! defined $which) {
 271             use Carp;
 272             carp "No name found for code pont $ord";
 273         }
 274         else {
 275             my $map = $map_ref->[$which];
 276             if (! ref $map) {
 277                 $name = $map;
 278             }
 279             else {
 280                 # Just pick the first abbreviation if more than one
 281                 my @names = grep { $_ =~ /abbreviation/ } @$map;
 282                 $name = $names[0];
 283             }
 284             $name =~ s/:.*//;
 285         }
 286     }
 287     printf $out_fh "/* U+%02X %s */ %s,\n", $ord, $name, $bits[$ord];
 288 }
 289
 290 read_only_bottom_close_and_rename($out_fh)