#!perl -w
-use 5.012;
+use v5.15.8;
use strict;
use warnings;
-require 'regen/regen_lib.pl';
+require './regen/regen_lib.pl';
+require './regen/charset_translations.pl';
+use Unicode::UCD 'prop_invlist';
# 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 0x0, NULL, the last line to 0xFF. For
# an application to see if the code point "i" has a particular property, it
# just does
# 'PL_charclass[i] & BIT'
# 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
- 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
+# keys are the names of the bits; values are what generates the code points
+# that have the bit set, or 0 if \p{key} is the generator
+my %bit_names = (
+ NONLATIN1_SIMPLE_FOLD => \&Non_Latin1_Simple_Folds,
+ NONLATIN1_FOLD => \&Non_Latin1_Folds,
+ ALPHANUMERIC => 'Alnum', # Like \w, but no underscore
+ ALPHA => 'XPosixAlpha',
+ ASCII => 0,
+ BLANK => 0,
+ CASED => 0,
+ CHARNAME_CONT => '_Perl_Charname_Continue',
+ CNTRL => 0,
+ DIGIT => 0,
+ GRAPH => 0,
+ IDFIRST => \&Id_First,
+ LOWER => 'XPosixLower',
+ NON_FINAL_FOLD => \&Non_Final_Folds,
+ PRINT => 0,
+ PUNCT => \&Punct_and_Symbols,
+ QUOTEMETA => '_Perl_Quotemeta',
+ SPACE => 'XPerlSpace',
+ UPPER => 'XPosixUpper',
+ WORDCHAR => 'XPosixWord',
+ XDIGIT => 0,
+ VERTSPACE => 0,
+ IS_IN_SOME_FOLD => '_Perl_Any_Folds',
+
+ # These are the control characters that there are mnemonics for
+ MNEMONIC_CNTRL => [ ord "\a", ord "\b", ord "\e", ord "\f",
+ ord "\n", ord "\r", ord "\t" ],
);
+sub uniques {
+ # Returns non-duplicated input values. From "Perl Best Practices:
+ # Encapsulated Cleverness". p. 455 in first edition.
+
+ my %seen;
+ return grep { ! $seen{$_}++ } @_;
+}
+
+sub expand_invlist {
+ # Return the code points that are in the inversion list given by the
+ # argument
+
+ my $invlist_ref = shift;
+ my $i;
+ my @full_list;
+
+ for (my $i = 0; $i < @$invlist_ref; $i += 2) {
+ my $upper = ($i + 1) < @$invlist_ref
+ ? $invlist_ref->[$i+1] - 1 # In range
+ : $Unicode::UCD::MAX_CP; # To infinity.
+ for my $j ($invlist_ref->[$i] .. $upper) {
+ push @full_list, $j;
+ }
+ }
+
+ return @full_list;
+}
+
# Read in the case fold mappings.
my %folded_closure;
+my %simple_folded_closure;
+my @non_final_folds;
+my @non_latin1_simple_folds;
+my @folds;
+use Unicode::UCD;
+
+# 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";
-open my $fh, "<", $file or die "Failed to read '$file': $!";
-while (<$fh>) {
+
+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++;
+
+ # 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 '#'
my $from = hex $hex_from;
- # Perl only deals with C and F folds
- next if $fold_type ne 'C' and $fold_type ne 'F';
+ # Perl only deals with S, C, and F folds
+ next if $fold_type ne 'C' and $fold_type ne 'F' and $fold_type ne 'S';
# 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;
+ for my $i (0 .. @folded - 1) {
+ my $fold = hex $folded[$i];
+ if ($fold < 256) {
+ push @{$folded_closure{$fold}}, $from;
+ push @{$simple_folded_closure{$fold}}, $from if $fold_type ne 'F';
+ }
+ if ($from < 256) {
+ push @{$folded_closure{$from}}, $fold;
+ push @{$simple_folded_closure{$from}}, $fold if $fold_type ne 'F';
+ }
+
+ if (($fold_type eq 'C' || $fold_type eq 'S')
+ && ($fold < 256 != $from < 256))
+ {
+ # Fold is simple (hence can't be a non-final fold, so the 'if'
+ # above is mutualy exclusive from the 'if below) and crosses
+ # 255/256 boundary. We keep track of the Latin1 code points
+ # in such folds.
+ push @non_latin1_simple_folds, ($fold < 256)
+ ? $fold
+ : $from;
+ }
+ elsif ($i < @folded-1
+ && $fold < 256
+ && ! grep { $_ == $fold } @non_final_folds)
+ {
+ push @non_final_folds, $fold;
+
+ # Also add the upper case, which in the latin1 range folds to
+ # $fold
+ push @non_final_folds, 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
+# 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}};
}
}
+foreach my $folded (keys %simple_folded_closure) {
+ foreach my $from (grep { $_ < 256 } @{$simple_folded_closure{$folded}}) {
+ push @{$simple_folded_closure{$from}}, @{$simple_folded_closure{$folded}};
+ }
+}
-my @bits; # Bit map for each code point
+# We have the single-character folds that cross the 255/256, like KELVIN
+# SIGN => 'k', but we need the closure, so add like 'K' to it
+foreach my $folded (@non_latin1_simple_folds) {
+ foreach my $fold (@{$simple_folded_closure{$folded}}) {
+ if ($fold < 256 && ! grep { $fold == $_ } @non_latin1_simple_folds) {
+ push @non_latin1_simple_folds, $fold;
+ }
+ }
+}
-foreach my $folded (keys %folded_closure) {
- $bits[$folded] = "_CC_NONLATIN1_FOLD" if grep { $_ > 255 }
- @{$folded_closure{$folded}};
+sub Id_First {
+ my @alpha_invlist = prop_invlist("XPosixAlpha");
+ my @ids = expand_invlist(\@alpha_invlist);
+ push @ids, ord "_";
+ return sort { $a <=> $b } uniques @ids;
}
-# 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!
+sub Non_Latin1_Folds {
+ my @return;
- # Look at all the properties we care about here.
- for my $property (@properties) {
- my $name = $property;
+ foreach my $folded (keys %folded_closure) {
+ push @return, $folded if grep { $_ > 255 } @{$folded_closure{$folded}};
+ }
+ return @return;
+}
- # 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$//)) {
+sub Non_Latin1_Simple_Folds { # Latin1 code points that are folded to by
+ # non-Latin1 code points as single character
+ # folds
+ return @non_latin1_simple_folds;
+}
- # Here, isn't an _L1. If its _A, it's automatically false for
- # non-ascii. The only one current one without a suffix is valid
- # over the whole range.
- next if $name =~ s/_A$// && $ord >= 128;
+sub Non_Final_Folds {
+ return @non_final_folds;
+}
- }
- my $re;
- if ($name eq 'PUNCT') {;
-
- # Sadly, this is inconsistent: \pP and \pS for the ascii range,
- # just \pP outside it.
- $re = qr/\p{Punct}|[^\P{Symbol}\P{ASCII}]/;
- } elsif ($name eq 'CHARNAME_CONT') {;
- $re = qr/[-\w ():\xa0]/;
- } elsif ($name eq 'SPACE') {;
- $re = qr/\s/;
- } 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') {
- # Like \w, but no underscore
- $re = qr/\p{Alnum}/;
- } elsif ($name eq 'OCTAL') {
- $re = qr/[0-7]/;
- } else { # The remainder have the same name and values as Unicode
- $re = eval "qr/\\p{$name}/";
- use Carp;
- carp $@ if ! defined $re;
- }
- #print "$ord, $name $property, $re\n";
- if ($char =~ $re) { # Add this property if matches
- $bits[$ord] .= '|' if $bits[$ord];
- $bits[$ord] .= "_CC_$property";
- }
+sub Punct_and_Symbols {
+ # Sadly, this is inconsistent: \pP and \pS for the ascii range;
+ # just \pP outside it.
+
+ my @punct_invlist = prop_invlist("Punct");
+ my @return = expand_invlist(\@punct_invlist);
+
+ my @symbols_invlist = prop_invlist("Symbol");
+ my @symbols = expand_invlist(\@symbols_invlist);
+ foreach my $cp (@symbols) {
+ last if $cp > 0x7f;
+ push @return, $cp;
}
- #print __LINE__, " $ord $char $bits[$ord]\n";
+
+ return sort { $a <=> $b } uniques @return;
}
-# Names of C0 controls
-my @C0 = qw (
- NUL
- SOH
- STX
- ETX
- EOT
- ENQ
- ACK
- BEL
- BS
- HT
- LF
- VT
- FF
- CR
- SO
- SI
- DLE
- DC1
- DC2
- DC3
- DC4
- NAK
- SYN
- ETB
- CAN
- EOM
- SUB
- ESC
- FS
- GS
- RS
- US
- );
-
-# Names of C1 controls, plus the adjacent DEL
-my @C1 = qw(
- DEL
- PAD
- HOP
- BPH
- NBH
- IND
- NEL
- SSA
- ESA
- HTS
- HTJ
- VTS
- PLD
- PLU
- RI
- SS2
- SS3
- DCS
- PU1
- PU2
- STS
- CCH
- MW
- SPA
- EPA
- SOS
- SGC
- SCI
- CSI
- ST
- OSC
- PM
- APC
- );
+my @bits; # Each element is a bit map for a single code point
+
+# For each bit type, calculate which code points should have it set
+foreach my $bit_name (sort keys %bit_names) {
+ my @code_points;
+
+ my $property = $bit_name; # The bit name is the same as its property,
+ # unless overridden
+ $property = $bit_names{$bit_name} if $bit_names{$bit_name};
+
+ if (! ref $property) {
+ my @invlist = prop_invlist($property, '_perl_core_internal_ok');
+ @code_points = expand_invlist(\@invlist);
+ }
+ elsif (ref $property eq 'CODE') {
+ @code_points = &$property;
+ }
+ elsif (ref $property eq 'ARRAY') {
+ @code_points = @{$property};
+ }
+
+ foreach my $cp (@code_points) {
+ last if $cp > 0xFF;
+ $bits[$cp] .= '|' if $bits[$cp];
+ $bits[$cp] .= "(1U<<_CC_$bit_name)";
+ }
+}
my $out_fh = open_new('l1_char_class_tab.h', '>',
{style => '*', by => $0,
- from => "property definitions and $file"});
+ from => "Unicode::UCD"});
+
+print $out_fh <<END;
+/* For code points whose position is not the same as Unicode, both are shown
+ * in the comment*/
+END
# Output the table using fairly short names for each char.
-for my $ord (0..255) {
- my $name;
- if ($ord < 32) { # A C0 control
- $name = $C0[$ord];
- } elsif ($ord > 32 && $ord < 127) { # Graphic
- $name = "'" . chr($ord) . "'";
- } elsif ($ord >= 127 && $ord <= 0x9f) {
- $name = $C1[$ord - 127]; # A C1 control + DEL
- } else { # SPACE, or, if Latin1, shorten the name */
- use charnames();
- $name = charnames::viacode($ord);
- $name =~ s/LATIN CAPITAL LETTER //
- || $name =~ s/LATIN SMALL LETTER (.*)/\L$1/;
+my $is_for_ascii = 1; # get_supported_code_pages() returns the ASCII
+ # character set first
+foreach my $charset (get_supported_code_pages()) {
+ my @a2n = @{get_a2n($charset)};
+ my @out;
+ my @utf_to_i8;
+
+ if ($is_for_ascii) {
+ $is_for_ascii = 0;
+ }
+ else { # EBCDIC. Calculate mapping from UTF-EBCDIC bytes to I8
+ my $i8_to_utf_ref = get_I8_2_utf($charset);
+ for my $i (0..255) {
+ $utf_to_i8[$i8_to_utf_ref->[$i]] = $i;
+ }
+ }
+
+ print $out_fh "\n" . get_conditional_compile_line_start($charset);
+ for my $ord (0..255) {
+ my $name;
+ my $char = chr $ord;
+ if ($char =~ /\p{PosixGraph}/) {
+ my $quote = $char eq "'" ? '"' : "'";
+ $name = $quote . chr($ord) . $quote;
+ }
+ elsif ($char =~ /\p{XPosixGraph}/) {
+ use charnames();
+ $name = charnames::viacode($ord);
+ $name =~ s/LATIN CAPITAL LETTER //
+ or $name =~ s/LATIN SMALL LETTER (.*)/\L$1/
+ or $name =~ s/ SIGN\b//
+ or $name =~ s/EXCLAMATION MARK/'!'/
+ or $name =~ s/QUESTION MARK/'?'/
+ or $name =~ s/QUOTATION MARK/QUOTE/
+ or $name =~ s/ INDICATOR//;
+ $name =~ s/\bWITH\b/\L$&/;
+ $name =~ s/\bONE\b/1/;
+ $name =~ s/\b(TWO|HALF)\b/2/;
+ $name =~ s/\bTHREE\b/3/;
+ $name =~ s/\b QUARTER S? \b/4/x;
+ $name =~ s/VULGAR FRACTION (.) (.)/$1\/$2/;
+ $name =~ s/\bTILDE\b/'~'/i
+ or $name =~ s/\bCIRCUMFLEX\b/'^'/i
+ or $name =~ s/\bSTROKE\b/'\/'/i
+ or $name =~ s/ ABOVE\b//i;
+ }
+ else {
+ use Unicode::UCD qw(prop_invmap);
+ my ($list_ref, $map_ref, $format)
+ = prop_invmap("_Perl_Name_Alias", '_perl_core_internal_ok');
+ if ($format !~ /^s/) {
+ use Carp;
+ carp "Unexpected format '$format' for '_Perl_Name_Alias";
+ last;
+ }
+ my $which = Unicode::UCD::search_invlist($list_ref, $ord);
+ if (! defined $which) {
+ use Carp;
+ carp "No name found for code pont $ord";
+ }
+ else {
+ my $map = $map_ref->[$which];
+ if (! ref $map) {
+ $name = $map;
+ }
+ else {
+ # Just pick the first abbreviation if more than one
+ my @names = grep { $_ =~ /abbreviation/ } @$map;
+ $name = $names[0];
+ }
+ $name =~ s/:.*//;
+ }
+ }
+
+ my $index = $a2n[$ord];
+ my $i8;
+ $i8 = $utf_to_i8[$index] if @utf_to_i8;
+
+ $out[$index] = "/* ";
+ $out[$index] .= sprintf "0x%02X ", $index if $ord != $index;
+ $out[$index] .= sprintf "U+%02X ", $ord;
+ $out[$index] .= sprintf "I8=%02X ", $i8 if defined $i8 && $i8 != $ord;
+ $out[$index] .= "$name */ ";
+ $out[$index] .= $bits[$ord];
+
+ # For EBCDIC character sets, we also add some data for when the bytes
+ # are in UTF-EBCDIC; these are based on the fundamental
+ # characteristics of UTF-EBCDIC.
+ if (@utf_to_i8) {
+ if ($i8 >= 0xF1) {
+ $out[$index] .=
+ '|(1U<<_CC_UTF8_START_BYTE_IS_FOR_AT_LEAST_SURROGATE)';
+ }
+ }
+
+ $out[$index] .= ",\n";
}
- printf $out_fh "/* U+%02X %s */ %s,\n", $ord, $name, $bits[$ord];
+ $out[-1] =~ s/,$//; # No trailing comma in the final entry
+
+ print $out_fh join "", @out;
+ print $out_fh "\n" . get_conditional_compile_line_end();
}
read_only_bottom_close_and_rename($out_fh)
https://perl5.git.perl.org / perl5.git / blobdiff