X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/29c22b52682692a630218342d1997c803a3b487b..df14fc1356c4b115f6728bf48e976bd98e8c29b0:/regen/mk_PL_charclass.pl diff --git a/regen/mk_PL_charclass.pl b/regen/mk_PL_charclass.pl index 0d161f3..63c06bc 100644 --- a/regen/mk_PL_charclass.pl +++ b/regen/mk_PL_charclass.pl @@ -1,14 +1,13 @@ #!perl -w -use 5.012; +use v5.15.8; use strict; use warnings; require 'regen/regen_lib.pl'; -# This program outputs the 256 lines that form the guts of the PL_charclass -# table. The output should be used to manually replace the table contents in -# l1_charclass_tab.h. Each line is a bit map of properties that the Unicode +# This program outputs l1_charclass_tab.h, which defines the guts of the +# PL_charclass table. Each line is a bit map of properties that the Unicode # code point at the corresponding position in the table array has. The first -# line corresponds to code point U+0000, NULL, the last line to U=00FF. For +# line corresponds to code point U+0000, NULL, the last line to U+00FF. For # an application to see if the code point "i" has a particular property, it # just does # 'PL_charclass[i] & BIT' @@ -19,98 +18,163 @@ require 'regen/regen_lib.pl'; # character (ISO-8859-1 including the C0 and C1 controls). A property without # these suffixes does not have different forms for both ranges. -# The data in the table is pretty well set in stone, so that this program need -# be run only when adding new properties to it. +# This program need be run only when adding new properties to it, or upon a +# new Unicode release, to make sure things haven't been changed by it. my @properties = qw( - ALNUMC_A - ALNUMC_L1 - ALPHA_A - ALPHA_L1 - BLANK_A - BLANK_L1 + NONLATIN1_FOLD + ALPHANUMERIC + ALPHA + ASCII + BLANK + CASED CHARNAME_CONT - CNTRL_A - CNTRL_L1 - DIGIT_A - GRAPH_A - GRAPH_L1 - IDFIRST_A - IDFIRST_L1 - LOWER_A - LOWER_L1 - OCTAL_A - PRINT_A - PRINT_L1 - PSXSPC_A - PSXSPC_L1 - PUNCT_A - PUNCT_L1 - SPACE_A - SPACE_L1 - UPPER_A - UPPER_L1 - WORDCHAR_A - WORDCHAR_L1 - XDIGIT_A + CNTRL + DIGIT + GRAPH + IDFIRST + LOWER + NON_FINAL_FOLD + PRINT + PSXSPC + PUNCT + QUOTEMETA + SPACE + UPPER + WORDCHAR + XDIGIT + VERTSPACE + IS_IN_SOME_FOLD + BACKSLASH_FOO_LBRACE_IS_META ); # Read in the case fold mappings. my %folded_closure; -my $file="lib/unicore/CaseFolding.txt"; -open my $fh, "<", $file or die "Failed to read '$file': $!"; -while (<$fh>) { - chomp; - - # Lines look like (without the initial '#' - #0130; F; 0069 0307; # LATIN CAPITAL LETTER I WITH DOT ABOVE - my ($line, $comment) = split / \s+ \# \s+ /x, $_; - next if $line eq "" || substr($line, 0, 1) eq '#'; - my ($hex_from, $fold_type, @folded) = split /[\s;]+/, $line; - - my $from = hex $hex_from; - - # Perl only deals with C and F folds - next if $fold_type ne 'C' and $fold_type ne 'F'; - - # Get each code point in the range that participates in this line's fold. - # The hash has keys of each code point in the range, and values of what it - # folds to and what folds to it - foreach my $hex_fold (@folded) { - my $fold = hex $hex_fold; - push @{$folded_closure{$fold}}, $from if $fold < 256; - push @{$folded_closure{$from}}, $fold if $from < 256; +my @hex_non_final_folds; +my @folds; +use Unicode::UCD; + +BEGIN { # Have to do this at compile time because using user-defined \p{property} + + # Use the Unicode data file if we are on an ASCII platform (which its data + # is for), and it is in the modern format (starting in Unicode 3.1.0) and + # it is available. This avoids being affected by potential bugs + # introduced by other layers of Perl + my $file="lib/unicore/CaseFolding.txt"; + + if (ord('A') == 65 + && pack("C*", split /\./, Unicode::UCD::UnicodeVersion()) ge v3.1.0 + && open my $fh, "<", $file) + { + @folds = <$fh>; } -} + else { + my ($invlist_ref, $invmap_ref, undef, $default) + = Unicode::UCD::prop_invmap('Case_Folding'); + for my $i (0 .. @$invlist_ref - 1 - 1) { + next if $invmap_ref->[$i] == $default; + my $adjust = -1; + for my $j ($invlist_ref->[$i] .. $invlist_ref->[$i+1] -1) { + $adjust++; -# Now having read all the lines, combine them into the full closure of each -# code point in the range by adding lists together that share a common element -foreach my $folded (keys %folded_closure) { - foreach my $from (grep { $_ < 256 } @{$folded_closure{$folded}}) { - push @{$folded_closure{$from}}, @{$folded_closure{$folded}}; + # Single-code point maps go to a 'C' type + if (! ref $invmap_ref->[$i]) { + push @folds, sprintf("%04X; C; %04X\n", + $j, + $invmap_ref->[$i] + $adjust); + } + else { # Multi-code point maps go to 'F'. prop_invmap() + # guarantees that no adjustment is needed for these, + # as the range will contain just one element + push @folds, sprintf("%04X; F; %s\n", + $j, + join " ", map { sprintf "%04X", $_ } + @{$invmap_ref->[$i]}); + } + } + } + } + + for (@folds) { + chomp; + + # Lines look like (without the initial '#' + #0130; F; 0069 0307; # LATIN CAPITAL LETTER I WITH DOT ABOVE + # Get rid of comments, ignore blank or comment-only lines + my $line = $_ =~ s/ (?: \s* \# .* )? $ //rx; + next unless length $line; + my ($hex_from, $fold_type, @folded) = split /[\s;]+/, $line; + + my $from = hex $hex_from; + + # Perl only deals with C and F folds + next if $fold_type ne 'C' and $fold_type ne 'F'; + + # Get each code point in the range that participates in this line's fold. + # The hash has keys of each code point in the range, and values of what it + # folds to and what folds to it + for my $i (0 .. @folded - 1) { + my $hex_fold = $folded[$i]; + my $fold = hex $hex_fold; + push @{$folded_closure{$fold}}, $from if $fold < 256; + push @{$folded_closure{$from}}, $fold if $from < 256; + + if ($i < @folded-1 + && $fold < 256 + && ! grep { $_ eq $hex_fold } @hex_non_final_folds) + { + push @hex_non_final_folds, $hex_fold; + + # Also add the upper case, which in the latin1 range folds to + # $fold + push @hex_non_final_folds, sprintf "%04X", ord uc chr $fold; + } + } + } + + # Now having read all the lines, combine them into the full closure of each + # code point in the range by adding lists together that share a common + # element + foreach my $folded (keys %folded_closure) { + foreach my $from (grep { $_ < 256 } @{$folded_closure{$folded}}) { + push @{$folded_closure{$from}}, @{$folded_closure{$folded}}; + } } } -my @bits; # Bit map for each code point +sub Is_Non_Latin1_Fold { + my @return; + + foreach my $folded (keys %folded_closure) { + push @return, sprintf("%X", $folded), if grep { $_ > 255 } + @{$folded_closure{$folded}}; + } + return join("\n", @return) . "\n"; +} -foreach my $folded (keys %folded_closure) { - $bits[$folded] = "_CC_NONLATIN1_FOLD" if grep { $_ > 255 } - @{$folded_closure{$folded}}; +sub Is_Non_Final_Fold { + return join("\n", @hex_non_final_folds) . "\n"; } +my @bits; # Bit map for each code point + +# For each character, calculate which properties it matches. for my $ord (0..255) { my $char = chr($ord); utf8::upgrade($char); # Important to use Unicode semantics! + + # Look at all the properties we care about here. for my $property (@properties) { my $name = $property; - # The property name that corresponds to this doesn't have a suffix. + # Remove the suffix to get the actual property name. + # Currently the suffixes are '_L1', '_A', and none. # If is a latin1 version, no further checking is needed. if (! ($name =~ s/_L1$//)) { - # Here, isn't an L1. It's either a special one or the suffix ends - # in _A. In the latter case, it's automatically false for - # non-ascii. The one current special is valid over the whole range. + # Here, isn't an _L1. If its _A, it's automatically false for + # non-ascii. The only current ones (besides ASCII) without a + # suffix are valid over the whole range. next if $name =~ s/_A$// && $ord >= 128; } @@ -121,20 +185,33 @@ for my $ord (0..255) { # just \pP outside it. $re = qr/\p{Punct}|[^\P{Symbol}\P{ASCII}]/; } elsif ($name eq 'CHARNAME_CONT') {; - $re = qr/[-\w ():\xa0]/; + $re = qr/\p{_Perl_Charname_Continue}/, } elsif ($name eq 'SPACE') {; - $re = qr/\s/; + $re = qr/\p{XPerlSpace}/; } elsif ($name eq 'IDFIRST') { $re = qr/[_\p{Alpha}]/; } elsif ($name eq 'PSXSPC') { $re = qr/[\v\p{Space}]/; } elsif ($name eq 'WORDCHAR') { - $re = qr/\w/; - } elsif ($name eq 'ALNUMC') { + $re = qr/\p{XPosixWord}/; + } elsif ($name eq 'ALPHANUMERIC') { # Like \w, but no underscore $re = qr/\p{Alnum}/; - } elsif ($name eq 'OCTAL') { - $re = qr/[0-7]/; + } elsif ($name eq 'QUOTEMETA') { + $re = qr/\p{_Perl_Quotemeta}/; + } elsif ($name eq 'NONLATIN1_FOLD') { + $re = qr/\p{Is_Non_Latin1_Fold}/; + } elsif ($name eq 'NON_FINAL_FOLD') { + $re = qr/\p{Is_Non_Final_Fold}/; + } elsif ($name eq 'IS_IN_SOME_FOLD') { + $re = qr/\p{_Perl_Any_Folds}/; + } elsif ($name eq 'BACKSLASH_FOO_LBRACE_IS_META') { + + # This is true for FOO where FOO is the varying character in: + # \a{, \b{, \c{, ... + # and the sequence has non-literal meaning to Perl; so it is true + # for 'x' because \x{ is special, but not 'a' because \a{ isn't. + $re = qr/[gkNopPx]/; } else { # The remainder have the same name and values as Unicode $re = eval "qr/\\p{$name}/"; use Carp; @@ -143,7 +220,7 @@ for my $ord (0..255) { #print "$ord, $name $property, $re\n"; if ($char =~ $re) { # Add this property if matches $bits[$ord] .= '|' if $bits[$ord]; - $bits[$ord] .= "_CC_$property"; + $bits[$ord] .= "(1U<<_CC_$property)"; } } #print __LINE__, " $ord $char $bits[$ord]\n"; @@ -222,8 +299,9 @@ my @C1 = qw( APC ); -my $out_fh = open_new('l1_char_class_tab.h'); -print $out_fh read_only_top(lang => 'C', style => '*', by => $0, from => $file); +my $out_fh = open_new('l1_char_class_tab.h', '>', + {style => '*', by => $0, + from => "property definitions"}); # Output the table using fairly short names for each char. for my $ord (0..255) {