#!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'
# 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;
}
# 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;
#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";
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) {
https://perl5.git.perl.org / perl5.git / blobdiff