[perl5.git] / regen / mk_PL_charclass.pl

#!perl -w
use v5.15.8;
use strict;
use warnings;
require 'regen/regen_lib.pl';
require 'regen/charset_translations.pl';

# 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
# an application to see if the code point "i" has a particular property, it
# just does
#    'PL_charclass[i] & BIT'
# The bit names are of the form '_CC_property_suffix', where 'CC' stands for
# character class, and 'property' is the corresponding property, and 'suffix'
# is one of '_A' to mean the property is true only if the corresponding code
# point is ASCII, and '_L1' means that the range includes any Latin1
# character (ISO-8859-1 including the C0 and C1 controls).  A property without
# these suffixes does not have different forms for both ranges.

# 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(
    NONLATIN1_SIMPLE_FOLD
    NONLATIN1_FOLD
    ALPHANUMERIC
    ALPHA
    ASCII
    BLANK
    CASED
    CHARNAME_CONT
    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 @hex_non_final_folds;
my @non_latin1_simple_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++;

                # 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 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
        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 (($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 { $_ 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}};
        }
    }

    # 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 (@{$folded_closure{$folded}}) {
            if ($fold < 256 && ! grep { $fold == $_ } @non_latin1_simple_folds) {
                push @non_latin1_simple_folds, $fold;
            }
        }
    }
}

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";
}

sub Is_Non_Latin1_Simple_Fold { # Latin1 code points that are folded to by
                                # non-Latin1 code points as single character
                                # folds
    return join("\n", map { sprintf "%X", $_ } @non_latin1_simple_folds) . "\n";
}

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 rules!

    # Look at all the properties we care about here.
    for my $property (@properties) {
        my $name = $property;

        # 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.  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$// && $char !~ /\p{ASCII}/;
        }
        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/\p{_Perl_Charname_Continue}/,
        } elsif ($name eq 'SPACE') {;
            $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/\p{XPosixWord}/;
        } elsif ($name eq 'ALPHANUMERIC') {
            # Like \w, but no underscore
            $re = qr/\p{Alnum}/;
        } elsif ($name eq 'QUOTEMETA') {
            $re = qr/\p{_Perl_Quotemeta}/;
        } elsif ($name eq 'NONLATIN1_FOLD') {
            $re = qr/\p{Is_Non_Latin1_Fold}/;
        } elsif ($name eq 'NONLATIN1_SIMPLE_FOLD') {
            $re = qr/\p{Is_Non_Latin1_Simple_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;
            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] .= "(1U<<_CC_$property)";
        }
    }
    #print __LINE__, " $ord $char $bits[$ord]\n";
}

my $out_fh = open_new('l1_char_class_tab.h', '>',
		      {style => '*', by => $0,
                      from => "property definitions"});

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.
foreach my $charset (get_supported_code_pages()) {
    my @a2n = get_a2n($charset);
    my @out;

    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("Name_Alias");
            if ($format !~ /^s/) {
                use Carp;
                carp "Unexpected format '$format' for '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];
        $out[$index] = ($ord == $index)
                    ? sprintf "/* U+%02X %s */ %s,\n", $ord, $name, $bits[$ord]
                    : sprintf "/* 0x%02X U+%02X %s */ %s,\n", $index, $ord, $name, $bits[$ord];
    }
    print $out_fh join "", @out;
    print $out_fh "\n" . get_conditional_compile_line_end();
}

read_only_bottom_close_and_rename($out_fh)
Commit	Line	Data
9c68f0ab	1	#!perl -w
b72a36d4	2	use v5.15.8;
9c68f0ab KW	3	use strict;
9c68f0ab KW	4	use warnings;
cfb8fd6a	5	require 'regen/regen_lib.pl';
29ec702e	6	require 'regen/charset_translations.pl';
9c68f0ab	7
b1909af7 KW	8	# This program outputs l1_charclass_tab.h, which defines the guts of the
b1909af7 KW	9	# PL_charclass table. Each line is a bit map of properties that the Unicode
8d4ab2a1	10	# code point at the corresponding position in the table array has. The first
b1909af7	11	# line corresponds to code point U+0000, NULL, the last line to U+00FF. For
8d4ab2a1 KW	12	# an application to see if the code point "i" has a particular property, it
8d4ab2a1 KW	13	# just does
9c68f0ab KW	14	# 'PL_charclass[i] & BIT'
	15	# The bit names are of the form '_CC_property_suffix', where 'CC' stands for
	16	# character class, and 'property' is the corresponding property, and 'suffix'
	17	# is one of '_A' to mean the property is true only if the corresponding code
	18	# point is ASCII, and '_L1' means that the range includes any Latin1
	19	# character (ISO-8859-1 including the C0 and C1 controls). A property without
	20	# these suffixes does not have different forms for both ranges.
	21
b1909af7 KW	22	# This program need be run only when adding new properties to it, or upon a
b1909af7 KW	23	# new Unicode release, to make sure things haven't been changed by it.
9c68f0ab KW	24
9c68f0ab KW	25	my @properties = qw(
f12c0118	26	NONLATIN1_SIMPLE_FOLD
62841d05	27	NONLATIN1_FOLD
15861f94	28	ALPHANUMERIC
f4cdb42c	29	ALPHA
e48bdfbc	30	ASCII
f4cdb42c	31	BLANK
b0d691b2	32	CASED
9c68f0ab	33	CHARNAME_CONT
f4cdb42c KW	34	CNTRL
	35	DIGIT
	36	GRAPH
	37	IDFIRST
	38	LOWER
b72a36d4	39	NON_FINAL_FOLD
f4cdb42c KW	40	PRINT
	41	PSXSPC
	42	PUNCT
9a022f3a	43	QUOTEMETA
f4cdb42c KW	44	SPACE
	45	UPPER
	46	WORDCHAR
	47	XDIGIT
a0947d7b	48	VERTSPACE
f7993745	49	IS_IN_SOME_FOLD
4d68ffa0	50	BACKSLASH_FOO_LBRACE_IS_META
9c68f0ab KW	51	);
9c68f0ab KW	52
00c072cf KW	53	# Read in the case fold mappings.
00c072cf KW	54	my %folded_closure;
62841d05	55	my @hex_non_final_folds;
f12c0118	56	my @non_latin1_simple_folds;
dbe1ba6b KW	57	my @folds;
	58	use Unicode::UCD;
	59
62841d05 KW	60	BEGIN { # Have to do this at compile time because using user-defined \p{property}
62841d05 KW	61
4ef0bd69 KW	62	# Use the Unicode data file if we are on an ASCII platform (which its data
	63	# is for), and it is in the modern format (starting in Unicode 3.1.0) and
	64	# it is available. This avoids being affected by potential bugs
	65	# introduced by other layers of Perl
	66	my $file="lib/unicore/CaseFolding.txt";
	67
	68	if (ord('A') == 65
	69	&& pack("C*", split /\./, Unicode::UCD::UnicodeVersion()) ge v3.1.0
	70	&& open my $fh, "<", $file)
	71	{
	72	@folds = <$fh>;
	73	}
	74	else {
	75	my ($invlist_ref, $invmap_ref, undef, $default)
dbe1ba6b	76	= Unicode::UCD::prop_invmap('Case_Folding');
4ef0bd69 KW	77	for my $i (0 .. @$invlist_ref - 1 - 1) {
	78	next if $invmap_ref->[$i] == $default;
	79	my $adjust = -1;
	80	for my $j ($invlist_ref->[$i] .. $invlist_ref->[$i+1] -1) {
	81	$adjust++;
	82
	83	# Single-code point maps go to a 'C' type
	84	if (! ref $invmap_ref->[$i]) {
	85	push @folds, sprintf("%04X; C; %04X\n",
	86	$j,
	87	$invmap_ref->[$i] + $adjust);
	88	}
	89	else { # Multi-code point maps go to 'F'. prop_invmap()
	90	# guarantees that no adjustment is needed for these,
	91	# as the range will contain just one element
	92	push @folds, sprintf("%04X; F; %s\n",
	93	$j,
	94	join " ", map { sprintf "%04X", $_ }
	95	@{$invmap_ref->[$i]});
	96	}
dbe1ba6b KW	97	}
	98	}
	99	}
dbe1ba6b	100
4ef0bd69 KW	101	for (@folds) {
4ef0bd69 KW	102	chomp;
00c072cf	103
4ef0bd69 KW	104	# Lines look like (without the initial '#'
	105	#0130; F; 0069 0307; # LATIN CAPITAL LETTER I WITH DOT ABOVE
	106	# Get rid of comments, ignore blank or comment-only lines
	107	my $line = $_ =~ s/ (?: \s* \# .* )? $ //rx;
	108	next unless length $line;
	109	my ($hex_from, $fold_type, @folded) = split /[\s;]+/, $line;
00c072cf	110
4ef0bd69	111	my $from = hex $hex_from;
00c072cf	112
f12c0118 KW	113	# Perl only deals with S, C, and F folds
f12c0118 KW	114	next if $fold_type ne 'C' and $fold_type ne 'F' and $fold_type ne 'S';
00c072cf	115
4ef0bd69 KW	116	# Get each code point in the range that participates in this line's fold.
	117	# The hash has keys of each code point in the range, and values of what it
	118	# folds to and what folds to it
	119	for my $i (0 .. @folded - 1) {
	120	my $hex_fold = $folded[$i];
	121	my $fold = hex $hex_fold;
	122	push @{$folded_closure{$fold}}, $from if $fold < 256;
	123	push @{$folded_closure{$from}}, $fold if $from < 256;
62841d05	124
f12c0118 KW	125	if (($fold_type eq 'C' \|\| $fold_type eq 'S')
	126	&& ($fold < 256 != $from < 256))
	127	{
	128	# Fold is simple (hence can't be a non-final fold, so the 'if'
	129	# above is mutualy exclusive from the 'if below) and crosses
	130	# 255/256 boundary. We keep track of the Latin1 code points
	131	# in such folds.
	132	push @non_latin1_simple_folds, ($fold < 256)
	133	? $fold
	134	: $from;
	135	}
	136	elsif ($i < @folded-1
	137	&& $fold < 256
	138	&& ! grep { $_ eq $hex_fold } @hex_non_final_folds)
07725c18 KW	139	{
	140	push @hex_non_final_folds, $hex_fold;
	141
	142	# Also add the upper case, which in the latin1 range folds to
	143	# $fold
	144	push @hex_non_final_folds, sprintf "%04X", ord uc chr $fold;
	145	}
4ef0bd69	146	}
00c072cf	147	}
00c072cf	148
4ef0bd69 KW	149	# Now having read all the lines, combine them into the full closure of each
	150	# code point in the range by adding lists together that share a common
	151	# element
	152	foreach my $folded (keys %folded_closure) {
	153	foreach my $from (grep { $_ < 256 } @{$folded_closure{$folded}}) {
	154	push @{$folded_closure{$from}}, @{$folded_closure{$folded}};
	155	}
00c072cf	156	}
f12c0118 KW	157
	158	# We have the single-character folds that cross the 255/256, like KELVIN
	159	# SIGN => 'k', but we need the closure, so add like 'K' to it
	160	foreach my $folded (@non_latin1_simple_folds) {
	161	foreach my $fold (@{$folded_closure{$folded}}) {
	162	if ($fold < 256 && ! grep { $fold == $_ } @non_latin1_simple_folds) {
	163	push @non_latin1_simple_folds, $fold;
	164	}
	165	}
	166	}
00c072cf KW	167	}
00c072cf KW	168
62841d05 KW	169	sub Is_Non_Latin1_Fold {
	170	my @return;
	171
	172	foreach my $folded (keys %folded_closure) {
	173	push @return, sprintf("%X", $folded), if grep { $_ > 255 }
	174	@{$folded_closure{$folded}};
	175	}
	176	return join("\n", @return) . "\n";
00c072cf KW	177	}
00c072cf KW	178
f12c0118 KW	179	sub Is_Non_Latin1_Simple_Fold { # Latin1 code points that are folded to by
	180	# non-Latin1 code points as single character
	181	# folds
	182	return join("\n", map { sprintf "%X", $_ } @non_latin1_simple_folds) . "\n";
	183	}
	184
62841d05 KW	185	sub Is_Non_Final_Fold {
	186	return join("\n", @hex_non_final_folds) . "\n";
	187	}
	188
	189	my @bits; # Bit map for each code point
	190
b1909af7	191	# For each character, calculate which properties it matches.
9c68f0ab KW	192	for my $ord (0..255) {
9c68f0ab KW	193	my $char = chr($ord);
850b7ec9	194	utf8::upgrade($char); # Important to use Unicode rules!
b1909af7 KW	195
b1909af7 KW	196	# Look at all the properties we care about here.
9c68f0ab KW	197	for my $property (@properties) {
	198	my $name = $property;
	199
b1909af7 KW	200	# Remove the suffix to get the actual property name.
b1909af7 KW	201	# Currently the suffixes are '_L1', '_A', and none.
9c68f0ab KW	202	# If is a latin1 version, no further checking is needed.
	203	if (! ($name =~ s/_L1$//)) {
	204
b1909af7	205	# Here, isn't an _L1. If its _A, it's automatically false for
a0947d7b KW	206	# non-ascii. The only current ones (besides ASCII) without a
a0947d7b KW	207	# suffix are valid over the whole range.
620ee5ce	208	next if $name =~ s/_A$// && $char !~ /\p{ASCII}/;
9c68f0ab KW	209	}
	210	my $re;
	211	if ($name eq 'PUNCT') {;
	212
	213	# Sadly, this is inconsistent: \pP and \pS for the ascii range,
	214	# just \pP outside it.
	215	$re = qr/\p{Punct}\|[^\P{Symbol}\P{ASCII}]/;
	216	} elsif ($name eq 'CHARNAME_CONT') {;
699ffc5e	217	$re = qr/\p{_Perl_Charname_Continue}/,
9c68f0ab	218	} elsif ($name eq 'SPACE') {;
c6e8e4a9	219	$re = qr/\p{XPerlSpace}/;
9c68f0ab KW	220	} elsif ($name eq 'IDFIRST') {
	221	$re = qr/[_\p{Alpha}]/;
	222	} elsif ($name eq 'PSXSPC') {
	223	$re = qr/[\v\p{Space}]/;
	224	} elsif ($name eq 'WORDCHAR') {
c6e8e4a9	225	$re = qr/\p{XPosixWord}/;
15861f94	226	} elsif ($name eq 'ALPHANUMERIC') {
9c68f0ab	227	# Like \w, but no underscore
aedd44b5	228	$re = qr/\p{Alnum}/;
9a022f3a KW	229	} elsif ($name eq 'QUOTEMETA') {
9a022f3a KW	230	$re = qr/\p{_Perl_Quotemeta}/;
62841d05 KW	231	} elsif ($name eq 'NONLATIN1_FOLD') {
62841d05 KW	232	$re = qr/\p{Is_Non_Latin1_Fold}/;
f12c0118 KW	233	} elsif ($name eq 'NONLATIN1_SIMPLE_FOLD') {
f12c0118 KW	234	$re = qr/\p{Is_Non_Latin1_Simple_Fold}/;
b72a36d4	235	} elsif ($name eq 'NON_FINAL_FOLD') {
62841d05	236	$re = qr/\p{Is_Non_Final_Fold}/;
f7993745 KW	237	} elsif ($name eq 'IS_IN_SOME_FOLD') {
f7993745 KW	238	$re = qr/\p{_Perl_Any_Folds}/;
4d68ffa0 KW	239	} elsif ($name eq 'BACKSLASH_FOO_LBRACE_IS_META') {
	240
	241	# This is true for FOO where FOO is the varying character in:
	242	# \a{, \b{, \c{, ...
	243	# and the sequence has non-literal meaning to Perl; so it is true
	244	# for 'x' because \x{ is special, but not 'a' because \a{ isn't.
	245	$re = qr/[gkNopPx]/;
9c68f0ab KW	246	} else { # The remainder have the same name and values as Unicode
	247	$re = eval "qr/\\p{$name}/";
	248	use Carp;
	249	carp $@ if ! defined $re;
	250	}
	251	#print "$ord, $name $property, $re\n";
07725c18	252	if ($char =~ $re) { # Add this property if matches
9c68f0ab	253	$bits[$ord] .= '\|' if $bits[$ord];
265c1f46	254	$bits[$ord] .= "(1U<<_CC_$property)";
9c68f0ab KW	255	}
	256	}
	257	#print __LINE__, " $ord $char $bits[$ord]\n";
	258	}
	259
cc49830d	260	my $out_fh = open_new('l1_char_class_tab.h', '>',
b1909af7	261	{style => '*', by => $0,
dbe1ba6b	262	from => "property definitions"});
cfb8fd6a	263
29ec702e KW	264	print $out_fh <<END;
	265	/* For code points whose position is not the same as Unicode, both are shown
	266	* in the comment*/
	267	END
	268
9c68f0ab	269	# Output the table using fairly short names for each char.
29ec702e KW	270	foreach my $charset (get_supported_code_pages()) {
	271	my @a2n = get_a2n($charset);
	272	my @out;
	273
	274	print $out_fh "\n" . get_conditional_compile_line_start($charset);
64d34faf KW	275	for my $ord (0..255) {
	276	my $name;
	277	my $char = chr $ord;
	278	if ($char =~ /\p{PosixGraph}/) {
	279	my $quote = $char eq "'" ? '"' : "'";
	280	$name = $quote . chr($ord) . $quote;
620ee5ce	281	}
64d34faf KW	282	elsif ($char =~ /\p{XPosixGraph}/) {
	283	use charnames();
	284	$name = charnames::viacode($ord);
	285	$name =~ s/LATIN CAPITAL LETTER //
	286	or $name =~ s/LATIN SMALL LETTER (.*)/\L$1/
	287	or $name =~ s/ SIGN\b//
	288	or $name =~ s/EXCLAMATION MARK/'!'/
	289	or $name =~ s/QUESTION MARK/'?'/
	290	or $name =~ s/QUOTATION MARK/QUOTE/
	291	or $name =~ s/ INDICATOR//;
	292	$name =~ s/\bWITH\b/\L$&/;
	293	$name =~ s/\bONE\b/1/;
	294	$name =~ s/\b(TWO\|HALF)\b/2/;
	295	$name =~ s/\bTHREE\b/3/;
	296	$name =~ s/\b QUARTER S? \b/4/x;
	297	$name =~ s/VULGAR FRACTION (.) (.)/$1\/$2/;
	298	$name =~ s/\bTILDE\b/'~'/i
	299	or $name =~ s/\bCIRCUMFLEX\b/'^'/i
	300	or $name =~ s/\bSTROKE\b/'\/'/i
	301	or $name =~ s/ ABOVE\b//i;
620ee5ce KW	302	}
620ee5ce KW	303	else {
64d34faf KW	304	use Unicode::UCD qw(prop_invmap);
	305	my ($list_ref, $map_ref, $format) = prop_invmap("Name_Alias");
	306	if ($format !~ /^s/) {
	307	use Carp;
	308	carp "Unexpected format '$format' for 'Name_Alias";
	309	last;
	310	}
	311	my $which = Unicode::UCD::search_invlist($list_ref, $ord);
	312	if (! defined $which) {
	313	use Carp;
	314	carp "No name found for code pont $ord";
620ee5ce KW	315	}
620ee5ce KW	316	else {
64d34faf KW	317	my $map = $map_ref->[$which];
	318	if (! ref $map) {
	319	$name = $map;
	320	}
	321	else {
	322	# Just pick the first abbreviation if more than one
	323	my @names = grep { $_ =~ /abbreviation/ } @$map;
	324	$name = $names[0];
	325	}
	326	$name =~ s/:.*//;
620ee5ce	327	}
620ee5ce	328	}
64d34faf KW	329	my $index = $a2n[$ord];
	330	$out[$index] = ($ord == $index)
	331	? sprintf "/* U+%02X %s */ %s,\n", $ord, $name, $bits[$ord]
	332	: sprintf "/* 0x%02X U+%02X %s */ %s,\n", $index, $ord, $name, $bits[$ord];
9c68f0ab	333	}
29ec702e KW	334	print $out_fh join "", @out;
29ec702e KW	335	print $out_fh "\n" . get_conditional_compile_line_end();
9c68f0ab KW	336	}
9c68f0ab KW	337
cfb8fd6a	338	read_only_bottom_close_and_rename($out_fh)