);
# Properties that this program ignores.
-my @unimplemented_properties = (
-'Unicode_Radical_Stroke' # Remove if changing to handle this one.
-);
+my @unimplemented_properties;
+
+# With this release, it is automatically handled if the Unihan db is
+# downloaded
+push @unimplemented_properties, 'Unicode_Radical_Stroke' if $v_version le v5.2.0;
# There are several types of obsolete properties defined by Unicode. These
# must be hand-edited for every new Unicode release.
# Below are files that Unicode furnishes, but this program ignores, and why
my %ignored_files = (
- 'CJKRadicals.txt' => 'Unihan data',
- 'Index.txt' => 'An index, not actual data',
- 'NamedSqProv.txt' => 'Not officially part of the Unicode standard; Append it to NamedSequences.txt if you want to process the contents.',
- 'NamesList.txt' => 'Just adds commentary',
- 'NormalizationCorrections.txt' => 'Data is already in other files.',
- 'Props.txt' => 'Adds nothing to PropList.txt; only in very early releases',
- 'ReadMe.txt' => 'Just comments',
- 'README.TXT' => 'Just comments',
- 'StandardizedVariants.txt' => 'Only for glyph changes, not a Unicode character property. Does not fit into current scheme where one code point is mapped',
- 'EmojiSources.txt' => 'Not of general utility: for Japanese legacy cell-phone applications',
- 'IndicMatraCategory.txt' => 'Provisional',
- 'IndicSyllabicCategory.txt' => 'Provisional',
+ 'CJKRadicals.txt' => 'Maps the kRSUnicode property values to corresponding code points',
+ 'Index.txt' => 'Alphabetical index of Unicode characters',
+ 'NamedSqProv.txt' => 'Named sequences proposed for inclusion in a later version of the Unicode Standard; if you need them now, you can append this file to F<NamedSequences.txt> and recompile perl',
+ 'NamesList.txt' => 'Annotated list of characters',
+ 'NormalizationCorrections.txt' => 'Documentation of corrections already incorporated into the Unicode data base',
+ 'Props.txt' => 'Only in very early releases; is a subset of F<PropList.txt> (which is used instead)',
+ 'ReadMe.txt' => 'Documentation',
+ 'StandardizedVariants.txt' => 'Certain glyph variations for character display are standardized. This lists the non-Unihan ones; the Unihan ones are also not used by Perl, and are in a separate Unicode data base L<http://www.unicode.org/ivd>',
+ 'EmojiSources.txt' => 'Maps certain Unicode code points to their legacy Japanese cell-phone values',
+ 'IndicMatraCategory.txt' => 'Provisional; for the analysis and processing of Indic scripts',
+ 'IndicSyllabicCategory.txt' => 'Provisional; for the analysis and processing of Indic scripts',
+ 'auxiliary/WordBreakTest.html' => 'Documentation of validation tests',
+ 'auxiliary/SentenceBreakTest.html' => 'Documentation of validation tests',
+ 'auxiliary/GraphemeBreakTest.html' => 'Documentation of validation tests',
+ 'auxiliary/LineBreakTest.html' => 'Documentation of validation tests',
);
### End of externally interesting definitions, except for @input_file_objects
# database, Version $string_version. Any changes made here will be lost!
EOF
-my $INTERNAL_ONLY=<<"EOF";
+my $INTERNAL_ONLY_HEADER = <<"EOF";
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# Matches legal code point. 4-6 hex numbers, If there are 6, the first
# two must be 10; if there are 5, the first must not be a 0. Written this way
-# to decrease backtracking. The first one allows the code point to be at the
-# end of a word, but to work properly, the word shouldn't end with a valid hex
-# character. The second one won't match a code point at the end of a word,
-# and doesn't have the run-on issue
+# to decrease backtracking. The first regex allows the code point to be at
+# the end of a word, but to work properly, the word shouldn't end with a valid
+# hex character. The second one won't match a code point at the end of a
+# word, and doesn't have the run-on issue
my $run_on_code_point_re =
qr/ (?: 10[0-9A-F]{4} | [1-9A-F][0-9A-F]{4} | [0-9A-F]{4} ) \b/x;
my $code_point_re = qr/\b$run_on_code_point_re/;
# if the flag is changed, the indefinite article referring to it in the
# documentation may need to be as well.
my $NORMAL = "";
-my $SUPPRESSED = 'z'; # The character should never actually be seen, since
- # it is suppressed
-my $PLACEHOLDER = 'P'; # A property that is defined as a placeholder in a
- # Unicode version that doesn't have it, but we need it
- # to be defined, if empty, to have things work.
- # Implies no pod entry generated
my $DEPRECATED = 'D';
my $a_bold_deprecated = "a 'B<$DEPRECATED>'";
my $A_bold_deprecated = "A 'B<$DEPRECATED>'";
my %status_past_participles = (
$DISCOURAGED => 'discouraged',
- $SUPPRESSED => 'should never be generated',
$STABILIZED => 'stabilized',
$OBSOLETE => 'obsolete',
$DEPRECATED => 'deprecated',
);
+# Table fates.
+my $ORDINARY = 0; # The normal fate.
+my $SUPPRESSED = 3; # The file for this table is not written out.
+my $INTERNAL_ONLY = 4; # The file for this table is written out, but it is
+ # for Perl's internal use only
+my $PLACEHOLDER = 5; # A property that is defined as a placeholder in a
+ # Unicode version that doesn't have it, but we need it
+ # to be defined, if empty, to have things work.
+ # Implies no pod entry generated
+
# The format of the values of the tables:
my $EMPTY_FORMAT = "";
my $BINARY_FORMAT = 'b';
my %Jamo_V; # Vowels
my %Jamo_T; # Trailing consonants
+# For code points whose name contains its ordinal as a '-ABCD' suffix.
+# The key is the base name of the code point, and the value is an
+# array giving all the ranges that use this base name. Each range
+# is actually a hash giving the 'low' and 'high' values of it.
+my %names_ending_in_code_point;
+my %loose_names_ending_in_code_point; # Same as above, but has blanks, dashes
+ # removed from the names
+# Inverse mapping. The list of ranges that have these kinds of
+# names. Each element contains the low, high, and base names in an
+# anonymous hash.
+my @code_points_ending_in_code_point;
+
+# Boolean: does this Unicode version have the hangul syllables, and are we
+# writing out a table for them?
+my $has_hangul_syllables = 0;
+
+# Does this Unicode version have code points whose names end in their
+# respective code points, and are we writing out a table for them? 0 for no;
+# otherwise points to first property that a table is needed for them, so that
+# if multiple tables are needed, we don't create duplicates
+my $needing_code_points_ending_in_code_point = 0;
+
my @backslash_X_tests; # List of tests read in for testing \X
my @unhandled_properties; # Will contain a list of properties found in
# the input that we didn't process.
main::set_access('non_skip', \%non_skip, 'c');
my %skip;
- # This is used to skip processing of this input file semi-permanently.
- # It is used for files that we aren't planning to process anytime soon,
- # but want to allow to be in the directory and not raise a message that we
- # are not handling. Mostly for test files. This is in contrast to the
- # non_skip element, which is supposed to be used very temporarily for
- # debugging. Sets 'optional' to 1
+ # This is used to skip processing of this input file semi-permanently,
+ # when it evaluates to true. The value should be the reason the file is
+ # being skipped. It is used for files that we aren't planning to process
+ # anytime soon, but want to allow to be in the directory and not raise a
+ # message that we are not handling. Mostly for test files. This is in
+ # contrast to the non_skip element, which is supposed to be used very
+ # temporarily for debugging. Sets 'optional' to 1. Also, files that we
+ # pretty much will never look at can be placed in the global
+ # %ignored_files instead. Ones used here will be added to that list.
main::set_access('skip', \%skip, 'c');
my %each_line_handler;
print "Warning: " . __PACKAGE__ . " constructor for $file{$addr} has useless 'non_skip' in it\n";
}
- $optional{$addr} = 1 if $skip{$addr};
+ # If skipping, set to optional, and add to list of ignored files,
+ # including its reason
+ if ($skip{$addr}) {
+ $optional{$addr} = 1;
+ $ignored_files{$file{$addr}} = $skip{$addr}
+ }
return $self;
}
# Should this name match loosely or not.
main::set_access('loose_match', \%loose_match, 'r');
- my %make_pod_entry;
- # Some aliases should not get their own entries because they are covered
- # by a wild-card, and some we want to discourage use of. Binary
- main::set_access('make_pod_entry', \%make_pod_entry, 'r');
+ my %make_re_pod_entry;
+ # Some aliases should not get their own entries in the re section of the
+ # pod, because they are covered by a wild-card, and some we want to
+ # discourage use of. Binary
+ main::set_access('make_re_pod_entry', \%make_re_pod_entry, 'r');
my %status;
# Aliases have a status, like deprecated, or even suppressed (which means
$name{$addr} = shift;
$loose_match{$addr} = shift;
- $make_pod_entry{$addr} = shift;
+ $make_re_pod_entry{$addr} = shift;
$externally_ok{$addr} = shift;
$status{$addr} = shift;
# files.
main::set_access('note', \%note, 'readable_array');
- my %internal_only;
- # Boolean; if set this table is for internal core Perl only use.
- main::set_access('internal_only', \%internal_only);
+ my %fate;
+ # Enum; there are a number of possibilities for what happens to this
+ # table: it could be normal, or suppressed, or not for external use. See
+ # values at definition for $SUPPRESSED.
+ main::set_access('fate', \%fate, 'r');
my %find_table_from_alias;
# The parent property passes this pointer to a hash which this class adds
sub new {
# All arguments are key => value pairs, which you can see below, most
- # of which match fields documented above. Otherwise: Pod_Entry,
+ # of which match fields documented above. Otherwise: Re_Pod_Entry,
# Externally_Ok, and Fuzzy apply to the names of the table, and are
# documented in the Alias package
my $complete_name = $complete_name{$addr}
= delete $args{'Complete_Name'};
$format{$addr} = delete $args{'Format'};
- $internal_only{$addr} = delete $args{'Internal_Only'} || 0;
$output_range_counts{$addr} = delete $args{'Output_Range_Counts'};
$property{$addr} = delete $args{'_Property'};
$range_list{$addr} = delete $args{'_Range_List'};
$status_info{$addr} = delete $args{'_Status_Info'} || "";
$range_size_1{$addr} = delete $args{'Range_Size_1'} || 0;
$caseless_equivalent{$addr} = delete $args{'Caseless_Equivalent'} || 0;
+ $fate{$addr} = delete $args{'Fate'} || $ORDINARY;
my $description = delete $args{'Description'};
my $externally_ok = delete $args{'Externally_Ok'};
my $loose_match = delete $args{'Fuzzy'};
my $note = delete $args{'Note'};
- my $make_pod_entry = delete $args{'Pod_Entry'};
+ my $make_re_pod_entry = delete $args{'Re_Pod_Entry'};
my $perl_extension = delete $args{'Perl_Extension'};
# Shouldn't have any left over
push @{$description{$addr}}, $description if $description;
push @{$note{$addr}}, $note if $note;
- if ($status{$addr} eq $PLACEHOLDER) {
+ if ($fate{$addr} == $PLACEHOLDER) {
# A placeholder table doesn't get documented, is a perl extension,
# and quite likely will be empty
- $make_pod_entry = 0 if ! defined $make_pod_entry;
+ $make_re_pod_entry = 0 if ! defined $make_re_pod_entry;
$perl_extension = 1 if ! defined $perl_extension;
push @tables_that_may_be_empty, $complete_name{$addr};
+ $self->add_comment(<<END);
+This is a placeholder because it is not in Version $string_version of Unicode,
+but is needed by the Perl core to work gracefully. Because it is not in this
+version of Unicode, it will not be listed in $pod_file.pod
+END
}
- elsif (! $status{$addr}) {
-
- # If hasn't set its status already, see if it is on one of the
- # lists of properties or tables that have particular statuses; if
- # not, is normal. The lists are prioritized so the most serious
- # ones are checked first
- if (exists $why_suppressed{$complete_name}
+ elsif (exists $why_suppressed{$complete_name}
# Don't suppress if overridden
&& ! grep { $_ eq $complete_name{$addr} }
@output_mapped_properties)
- {
- $status{$addr} = $SUPPRESSED;
- }
- elsif (exists $why_deprecated{$complete_name}) {
+ {
+ $fate{$addr} = $SUPPRESSED;
+ }
+ elsif ($fate{$addr} == $SUPPRESSED
+ && ! exists $why_suppressed{$property{$addr}->complete_name})
+ {
+ Carp::my_carp_bug("There is no current capability to set the reason for suppressing.");
+ # perhaps Fate => [ $SUPPRESSED, "reason" ]
+ }
+
+ # If hasn't set its status already, see if it is on one of the
+ # lists of properties or tables that have particular statuses; if
+ # not, is normal. The lists are prioritized so the most serious
+ # ones are checked first
+ if (! $status{$addr}) {
+ if (exists $why_deprecated{$complete_name}) {
$status{$addr} = $DEPRECATED;
}
elsif (exists $why_stabilized{$complete_name}) {
# Existence above doesn't necessarily mean there is a message
# associated with it. Use the most serious message.
if ($status{$addr}) {
- if ($why_suppressed{$complete_name}) {
- $status_info{$addr}
- = $why_suppressed{$complete_name};
- }
- elsif ($why_deprecated{$complete_name}) {
+ if ($why_deprecated{$complete_name}) {
$status_info{$addr}
= $why_deprecated{$complete_name};
}
$perl_extension{$addr} = $perl_extension || 0;
# Don't list a property by default that is internal only
- $make_pod_entry = 0 if ! defined $make_pod_entry
- && $name{$addr} =~ /^_/;
+ if ($fate{$addr} != $ORDINARY) {
+ $make_re_pod_entry = 0 if ! defined $make_re_pod_entry;
+ }
# By convention what typically gets printed only or first is what's
# first in the list, so put the full name there for good output
$self->add_alias($full_name{$addr},
Externally_Ok => $externally_ok,
Fuzzy => $loose_match,
- Pod_Entry => $make_pod_entry,
+ Re_Pod_Entry => $make_re_pod_entry,
Status => $status{$addr},
);
$self->add_alias($name{$addr},
Externally_Ok => $externally_ok,
Fuzzy => $loose_match,
- Pod_Entry => $make_pod_entry,
+ Re_Pod_Entry => $make_re_pod_entry,
Status => $status{$addr},
);
}
my %args = @_;
my $loose_match = delete $args{'Fuzzy'};
- my $make_pod_entry = delete $args{'Pod_Entry'};
- $make_pod_entry = $YES unless defined $make_pod_entry;
+ my $make_re_pod_entry = delete $args{'Re_Pod_Entry'};
+ $make_re_pod_entry = $YES unless defined $make_re_pod_entry;
my $externally_ok = delete $args{'Externally_Ok'};
$externally_ok = 1 unless defined $externally_ok;
splice @$list,
$insert_position,
0,
- Alias->new($name, $loose_match, $make_pod_entry,
+ Alias->new($name, $loose_match, $make_re_pod_entry,
$externally_ok, $status);
# This name may be shorter than any existing ones, so clear the cache
my $return = "";
$return .= $DEVELOPMENT_ONLY if $compare_versions;
$return .= $HEADER;
- no overloading;
- $return .= $INTERNAL_ONLY if $internal_only{pack 'J', $self};
return $return;
}
return;
}
+ sub set_fate { # Set the fate of a table
+ my $self = shift;
+ my $fate = shift;
+ my $reason = shift;
+ Carp::carp_extra_args(\@_) if main::DEBUG && @_;
+
+ my $addr = do { no overloading; pack 'J', $self; };
+
+ return if $fate{$addr} == $fate; # If no-op
+
+ # Can only change the ordinary fate.
+ if ($fate{$addr} != $ORDINARY) {
+ return;
+ }
+
+ $fate{$addr} = $fate;
+
+ # Save the reason for suppression for output
+ if ($fate == $SUPPRESSED && defined $reason) {
+ $why_suppressed{$complete_name{$addr}} = $reason;
+ }
+
+ return;
+ }
+
sub lock {
# Don't allow changes to the table from now on. This stores a stack
# trace of where it was called, so that later attempts to modify it
if defined $global_to_output_map{$full_name};
# If table says to output, do so; if says to suppress it, do so.
+ my $fate = $self->fate;
+ return $INTERNAL_MAP if $fate == $INTERNAL_ONLY;
return $EXTERNAL_MAP if grep { $_ eq $full_name } @output_mapped_properties;
- return 0 if $self->status eq $SUPPRESSED;
+ return 0 if $fate == $SUPPRESSED;
my $type = $self->property->type;
my $return = $self->SUPER::header();
- $return .= $INTERNAL_ONLY if $self->to_output_map == $INTERNAL_MAP;
+ $return .= $INTERNAL_ONLY_HEADER if $self->to_output_map == $INTERNAL_MAP;
return $return;
}
# The remaining variables are temporaries used while writing each table,
# to output special ranges.
- my $has_hangul_syllables;
my @multi_code_point_maps; # Map is to more than one code point.
- # The key is the base name of the code point, and the value is an
- # array giving all the ranges that use this base name. Each range
- # is actually a hash giving the 'low' and 'high' values of it.
- my %names_ending_in_code_point;
- my %loose_names_ending_in_code_point;
-
- # Inverse mapping. The list of ranges that have these kinds of
- # names. Each element contains the low, high, and base names in an
- # anonymous hash.
- my @code_points_ending_in_code_point;
-
sub handle_special_range {
# Called in the middle of write when it finds a range it doesn't know
# how to handle.
# No need to output the range if it maps to the default.
return if $map eq $default_map{$addr};
+ my $property = $self->property;
+
# Switch based on the map type...
if ($type == $HANGUL_SYLLABLE) {
# These are entirely algorithmically determinable based on
# some constants furnished by Unicode; for now, just set a
# flag to indicate that have them. After everything is figured
- # out, we will output the code that does the algorithm.
- $has_hangul_syllables = 1;
+ # out, we will output the code that does the algorithm. (Don't
+ # output them if not needed because we are suppressing this
+ # property.)
+ $has_hangul_syllables = 1 if $property->to_output_map;
}
elsif ($type == $CP_IN_NAME) {
- # Code points whose the name ends in their code point are also
+ # Code points whose name ends in their code point are also
# algorithmically determinable, but need information about the map
# to do so. Both the map and its inverse are stored in data
- # structures output in the file.
- push @{$names_ending_in_code_point{$map}->{'low'}}, $low;
- push @{$names_ending_in_code_point{$map}->{'high'}}, $high;
-
- my $squeezed = $map =~ s/[-\s]+//gr;
- push @{$loose_names_ending_in_code_point{$squeezed}->{'low'}}, $low;
- push @{$loose_names_ending_in_code_point{$squeezed}->{'high'}}, $high;
-
- push @code_points_ending_in_code_point, { low => $low,
- high => $high,
- name => $map
- };
+ # structures output in the file. They are stored in the mean time
+ # in global lists The lists will be written out later into Name.pm,
+ # which is created only if needed. In order to prevent duplicates
+ # in the list, only add to them for one property, should multiple
+ # ones need them.
+ if ($needing_code_points_ending_in_code_point == 0) {
+ $needing_code_points_ending_in_code_point = $property;
+ }
+ if ($property == $needing_code_points_ending_in_code_point) {
+ push @{$names_ending_in_code_point{$map}->{'low'}}, $low;
+ push @{$names_ending_in_code_point{$map}->{'high'}}, $high;
+
+ my $squeezed = $map =~ s/[-\s]+//gr;
+ push @{$loose_names_ending_in_code_point{$squeezed}->{'low'}},
+ $low;
+ push @{$loose_names_ending_in_code_point{$squeezed}->{'high'}},
+ $high;
+
+ push @code_points_ending_in_code_point, { low => $low,
+ high => $high,
+ name => $map
+ };
+ }
}
elsif ($range->type == $MULTI_CP || $range->type == $NULL) {
my $name = $self->property->swash_name;
+ # Currently there is nothing in the pre_body unless a swash is being
+ # generated.
+ return unless defined $name;
+
if (defined $swash_keys{$name}) {
Carp::my_carp(join_lines(<<END
Already created a swash name '$name' for $swash_keys{$name}. This means that
$pre_body .= join("\n", @multi_code_point_maps) . "\n);\n";
}
- if ($has_hangul_syllables || @code_points_ending_in_code_point) {
-
- # Convert these structures to output format.
- my $code_points_ending_in_code_point =
- main::simple_dumper(\@code_points_ending_in_code_point,
- ' ' x 8);
- my $names = main::simple_dumper(\%names_ending_in_code_point,
- ' ' x 8);
- my $loose_names = main::simple_dumper(\%loose_names_ending_in_code_point,
- ' ' x 8);
-
- # Do the same with the Hangul names,
- my $jamo;
- my $jamo_l;
- my $jamo_v;
- my $jamo_t;
- my $jamo_re;
- if ($has_hangul_syllables) {
-
- # Construct a regular expression of all the possible
- # combinations of the Hangul syllables.
- my @L_re; # Leading consonants
- for my $i ($LBase .. $LBase + $LCount - 1) {
- push @L_re, $Jamo{$i}
- }
- my @V_re; # Middle vowels
- for my $i ($VBase .. $VBase + $VCount - 1) {
- push @V_re, $Jamo{$i}
- }
- my @T_re; # Trailing consonants
- for my $i ($TBase + 1 .. $TBase + $TCount - 1) {
- push @T_re, $Jamo{$i}
- }
-
- # The whole re is made up of the L V T combination.
- $jamo_re = '('
- . join ('|', sort @L_re)
- . ')('
- . join ('|', sort @V_re)
- . ')('
- . join ('|', sort @T_re)
- . ')?';
-
- # These hashes needed by the algorithm were generated
- # during reading of the Jamo.txt file
- $jamo = main::simple_dumper(\%Jamo, ' ' x 8);
- $jamo_l = main::simple_dumper(\%Jamo_L, ' ' x 8);
- $jamo_v = main::simple_dumper(\%Jamo_V, ' ' x 8);
- $jamo_t = main::simple_dumper(\%Jamo_T, ' ' x 8);
- }
-
- $pre_body .= <<END;
-
-# To achieve significant memory savings when this file is read in,
-# algorithmically derivable code points are omitted from the main body below.
-# Instead, the following routines can be used to translate between name and
-# code point and vice versa
-
-{ # Closure
-
- # Matches legal code point. 4-6 hex numbers, If there are 6, the
- # first two must be '10'; if there are 5, the first must not be a '0'.
- # First can match at the end of a word provided that the end of the
- # word doesn't look like a hex number.
- my \$run_on_code_point_re = qr/$run_on_code_point_re/;
- my \$code_point_re = qr/$code_point_re/;
-
- # In the following hash, the keys are the bases of names which includes
- # the code point in the name, like CJK UNIFIED IDEOGRAPH-4E01. The values
- # of each key is another hash which is used to get the low and high ends
- # for each range of code points that apply to the name.
- my %names_ending_in_code_point = (
-$names
- );
-
- # The following hash is a copy of the previous one, except is for loose
- # matching, so each name has blanks and dashes squeezed out
- my %loose_names_ending_in_code_point = (
-$loose_names
- );
-
- # And the following array gives the inverse mapping from code points to
- # names. Lowest code points are first
- my \@code_points_ending_in_code_point = (
-$code_points_ending_in_code_point
- );
-END
- # Earlier releases didn't have Jamos. No sense outputting
- # them unless will be used.
- if ($has_hangul_syllables) {
- $pre_body .= <<END;
-
- # Convert from code point to Jamo short name for use in composing Hangul
- # syllable names
- my %Jamo = (
-$jamo
- );
-
- # Leading consonant (can be null)
- my %Jamo_L = (
-$jamo_l
- );
-
- # Vowel
- my %Jamo_V = (
-$jamo_v
- );
-
- # Optional trailing consonant
- my %Jamo_T = (
-$jamo_t
- );
-
- # Computed re that splits up a Hangul name into LVT or LV syllables
- my \$syllable_re = qr/$jamo_re/;
-
- my \$HANGUL_SYLLABLE = "HANGUL SYLLABLE ";
- my \$loose_HANGUL_SYLLABLE = "HANGULSYLLABLE";
-
- # These constants names and values were taken from the Unicode standard,
- # version 5.1, section 3.12. They are used in conjunction with Hangul
- # syllables
- my \$SBase = $SBase_string;
- my \$LBase = $LBase_string;
- my \$VBase = $VBase_string;
- my \$TBase = $TBase_string;
- my \$SCount = $SCount;
- my \$LCount = $LCount;
- my \$VCount = $VCount;
- my \$TCount = $TCount;
- my \$NCount = \$VCount * \$TCount;
-END
- } # End of has Jamos
-
- $pre_body .= << 'END';
-
- sub name_to_code_point_special {
- my ($name, $loose) = @_;
-
- # Returns undef if not one of the specially handled names; otherwise
- # returns the code point equivalent to the input name
- # $loose is non-zero if to use loose matching, 'name' in that case
- # must be input as upper case with all blanks and dashes squeezed out.
-END
- if ($has_hangul_syllables) {
- $pre_body .= << 'END';
-
- if ((! $loose && $name =~ s/$HANGUL_SYLLABLE//)
- || ($loose && $name =~ s/$loose_HANGUL_SYLLABLE//))
- {
- return if $name !~ qr/^$syllable_re$/;
- my $L = $Jamo_L{$1};
- my $V = $Jamo_V{$2};
- my $T = (defined $3) ? $Jamo_T{$3} : 0;
- return ($L * $VCount + $V) * $TCount + $T + $SBase;
- }
-END
- }
- $pre_body .= << 'END';
-
- # Name must end in 'code_point' for this to handle.
- return if (($loose && $name !~ /^ (.*?) ($run_on_code_point_re) $/x)
- || (! $loose && $name !~ /^ (.*) ($code_point_re) $/x));
-
- my $base = $1;
- my $code_point = CORE::hex $2;
- my $names_ref;
-
- if ($loose) {
- $names_ref = \%loose_names_ending_in_code_point;
- }
- else {
- return if $base !~ s/-$//;
- $names_ref = \%names_ending_in_code_point;
- }
-
- # Name must be one of the ones which has the code point in it.
- return if ! $names_ref->{$base};
-
- # Look through the list of ranges that apply to this name to see if
- # the code point is in one of them.
- for (my $i = 0; $i < scalar @{$names_ref->{$base}{'low'}}; $i++) {
- return if $names_ref->{$base}{'low'}->[$i] > $code_point;
- next if $names_ref->{$base}{'high'}->[$i] < $code_point;
-
- # Here, the code point is in the range.
- return $code_point;
- }
-
- # Here, looked like the name had a code point number in it, but
- # did not match one of the valid ones.
- return;
- }
-
- sub code_point_to_name_special {
- my $code_point = shift;
-
- # Returns the name of a code point if algorithmically determinable;
- # undef if not
-END
- if ($has_hangul_syllables) {
- $pre_body .= << 'END';
-
- # If in the Hangul range, calculate the name based on Unicode's
- # algorithm
- if ($code_point >= $SBase && $code_point <= $SBase + $SCount -1) {
- use integer;
- my $SIndex = $code_point - $SBase;
- my $L = $LBase + $SIndex / $NCount;
- my $V = $VBase + ($SIndex % $NCount) / $TCount;
- my $T = $TBase + $SIndex % $TCount;
- $name = "$HANGUL_SYLLABLE$Jamo{$L}$Jamo{$V}";
- $name .= $Jamo{$T} if $T != $TBase;
- return $name;
- }
-END
- }
- $pre_body .= << 'END';
-
- # Look through list of these code points for one in range.
- foreach my $hash (@code_points_ending_in_code_point) {
- return if $code_point < $hash->{'low'};
- if ($code_point <= $hash->{'high'}) {
- return sprintf("%s-%04X", $hash->{'name'}, $code_point);
- }
- }
- return; # None found
- }
-} # End closure
-
-END
- } # End of has hangul or code point in name maps.
-
my $format = $self->format;
my $return = <<END;
my $addr = do { no overloading; pack 'J', $self; };
# Clear the temporaries
- $has_hangul_syllables = 0;
undef @multi_code_point_maps;
- undef %names_ending_in_code_point;
- undef %loose_names_ending_in_code_point;
- undef @code_points_ending_in_code_point;
# Calculate the format of the table if not already done.
my $format = $self->format;
# Any tables that are equivalent to or children of this table must now
# instead be equivalent to or (children) to the new leader (parent),
# still equivalent. The equivalency includes their matches_all info,
- # and for related tables, their status
+ # and for related tables, their fate and status.
# All related tables are of necessity equivalent, but the converse
# isn't necessarily true
my $status = $other->status;
my $status_info = $other->status_info;
+ my $fate = $other->fate;
my $matches_all = $matches_all{other_addr};
my $caseless_equivalent = $other->caseless_equivalent;
foreach my $table ($current_leader, @{$equivalents{$leader}}) {
$parent{$table_addr} = $other;
push @{$children{$other_addr}}, $table;
$table->set_status($status, $status_info);
+
+ # This reason currently doesn't get exposed outside; otherwise
+ # would have to look up the parent's reason and use it instead.
+ $table->set_fate($fate, "Parent's fate");
+
$self->set_caseless_equivalent($caseless_equivalent);
}
}
return $self->_range_list->add_range(@_);
}
+ sub header {
+ my $self = shift;
+ Carp::carp_extra_args(\@_) if main::DEBUG && @_;
+
+ # All match tables are to be used only by the Perl core.
+ return $self->SUPER::header() . $INTERNAL_ONLY_HEADER;
+ }
+
sub pre_body { # Does nothing for match tables.
return
}
return
}
+ sub set_fate {
+ my $self = shift;
+ my $fate = shift;
+ my $reason = shift;
+ Carp::carp_extra_args(\@_) if main::DEBUG && @_;
+
+ $self->SUPER::set_fate($fate, $reason);
+
+ # All children share this fate
+ foreach my $child ($self->children) {
+ $child->set_fate($fate, $reason);
+ }
+ return;
+ }
+
sub write {
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
my $flag = $property->status
|| $table->status
|| $table_alias_object->status;
- if ($flag) {
- if ($flag ne $PLACEHOLDER) {
- $flags{$flag} = $status_past_participles{$flag};
- } else {
- $flags{$flag} = <<END;
-a placeholder because it is not in Version $string_version of Unicode, but is
-needed by the Perl core to work gracefully. Because it is not in this version
-of Unicode, it will not be listed in $pod_file.pod
-END
- }
- }
+ $flags{$flag} = $status_past_participles{$flag} if $flag;
$loose_count++;
foreach my $flag (sort keys %flags) {
$comment .= <<END;
'$flag' below means that this form is $flags{$flag}.
+Consult $pod_file.pod
END
- next if $flag eq $PLACEHOLDER;
- $comment .= "Consult $pod_file.pod\n";
}
$comment .= "\n";
}
_Alias_Hash => $table_ref{$addr},
_Property => $self,
- # gets property's status by default
+ # gets property's fate and status by default
+ Fate => $self->fate,
Status => $self->status,
_Status_Info => $self->status_info,
- %args,
- Internal_Only => 1); # Override any
- # input param
+ %args);
return unless defined $table;
}
my $addr = do { no overloading; pack 'J', $self; };
+ # Swash names are used only on regular map tables; otherwise there
+ # should be no access to the property map table from other parts of
+ # Perl.
+ return if $map{$addr}->fate != $ORDINARY;
+
return $file{$addr} if defined $file{$addr};
return $map{$addr}->external_name;
}
return;
}
+ sub set_fate {
+ my $self = shift;
+ my $fate = shift;
+ my $reason = shift; # Ignored unless suppressing
+ Carp::carp_extra_args(\@_) if main::DEBUG && @_;
+
+ my $addr = do { no overloading; pack 'J', $self; };
+ if ($fate == $SUPPRESSED) {
+ $why_suppressed{$self->complete_name} = $reason;
+ }
+
+ # Each table shares the property's fate
+ foreach my $table ($map{$addr}, $self->tables) {
+ $table->set_fate($fate, $reason);
+ }
+ return;
+ }
+
+
# Most of the accessors for a property actually apply to its map table.
# Setup up accessor functions for those, referring to %map
for my $sub (qw(
description
each_range
external_name
+ fate
file_path
format
initialize
Default_Map => "",
Directory => File::Spec->curdir(),
File => 'Name',
- Internal_Only => 1,
+ Fate => $INTERNAL_ONLY,
Perl_Extension => 1,
Range_Size_1 => \&output_perl_charnames_line,
Type => $STRING,
Directory => File::Spec->curdir(),
File => 'Decomposition',
Format => $DECOMP_STRING_FORMAT,
- Internal_Only => 1,
+ Fate => $INTERNAL_ONLY,
Perl_Extension => 1,
Default_Map => $CODE_POINT,
# The simple version's name in each mapping merely has an 's' in
# front of the full one's
- my $simple = property_ref('s' . $case);
+ my $simple_name = 's' . $case;
+ my $simple = property_ref($simple_name);
$simple->initialize($full) if $simple->to_output_map();
my $simple_only = Property->new("_s$case",
Type => $STRING,
Default_Map => $CODE_POINT,
Perl_Extension => 1,
- Description => "The simple mappings for $case for code points that have full mappings as well");
+ Fate => $INTERNAL_ONLY,
+ Description => "This contains the simple mappings for $case for just the code points that have different full mappings");
$simple_only->set_to_output_map($INTERNAL_MAP);
$simple_only->add_comment(join_lines( <<END
This file is for UCD.pm so that it can construct simple mappings that would
# Our internal-only property should be treated as more than just a
# synonym; grandfather it in to the pod.
- $perl->add_match_table('_CombAbove', Pod_Entry => 1)
+ $perl->add_match_table('_CombAbove', Re_Pod_Entry => 1,
+ Fate => $INTERNAL_ONLY, Status => $DISCOURAGED)
->set_equivalent_to(property_ref('ccc')->table('Above'),
Related => 1);
# Perl has long had an internal-only alias for this property; grandfather
# it in to the pod, but discourage its use.
my $perl_case_ignorable = $perl->add_match_table('_Case_Ignorable',
- Pod_Entry => 1);
+ Re_Pod_Entry => 1,
+ Fate => $INTERNAL_ONLY,
+ Status => $DISCOURAGED);
my $case_ignorable = property_ref('Case_Ignorable');
if (defined $case_ignorable && ! $case_ignorable->is_empty) {
$perl_case_ignorable->set_equivalent_to($case_ignorable->table('Y'),
Description => '\p{Punct} + ASCII-range \p{Symbol}',
Initialize => $gc->table('Punctuation')
+ ($ASCII & $gc->table('Symbol')),
+ Perl_Extension => 1
);
- $perl->add_match_table('PosixPunct',
+ $perl->add_match_table('PosixPunct', Perl_Extension => 1,
Description => '[-!"#$%&\'()*+,./:;<>?@[\\\]^_`{|}~]',
Initialize => $ASCII & $XPosixPunct,
);
# _CanonDCIJ is equivalent to Soft_Dotted, but if on a release earlier
# than SD appeared, construct it ourselves, based on the first release SD
# was in. A pod entry is grandfathered in for it
- my $CanonDCIJ = $perl->add_match_table('_CanonDCIJ', Pod_Entry => 1);
+ my $CanonDCIJ = $perl->add_match_table('_CanonDCIJ', Re_Pod_Entry => 1,
+ Perl_Extension => 1,
+ Fate => $INTERNAL_ONLY,
+ Status => $DISCOURAGED);
my $soft_dotted = property_ref('Soft_Dotted');
if (defined $soft_dotted && ! $soft_dotted->is_empty) {
$CanonDCIJ->set_equivalent_to($soft_dotted->table('Y'), Related => 1);
}
# These are used in Unicode's definition of \X
- my $begin = $perl->add_match_table('_X_Begin', Perl_Extension => 1);
- my $extend = $perl->add_match_table('_X_Extend', Perl_Extension => 1);
+ my $begin = $perl->add_match_table('_X_Begin', Perl_Extension => 1,
+ Fate => $INTERNAL_ONLY);
+ my $extend = $perl->add_match_table('_X_Extend', Perl_Extension => 1,
+ Fate => $INTERNAL_ONLY);
# For backward compatibility, Perl has its own definition for IDStart
# First, we include the underscore, and then the regular XID_Start also
# have to be Words
$perl->add_match_table('_Perl_IDStart',
Perl_Extension => 1,
- Internal_Only => 1,
+ Fate => $INTERNAL_ONLY,
Initialize =>
ord('_')
+ (property_ref('XID_Start')->table('Y') & $Word)
# More GCB. If we found some hangul syllables, populate a combined
# table.
- my $lv_lvt_v = $perl->add_match_table('_X_LV_LVT_V');
+ my $lv_lvt_v = $perl->add_match_table('_X_LV_LVT_V',
+ Perl_Extension => 1,
+ Fate => $INTERNAL_ONLY);
my $LV = $gcb->table('LV');
if ($LV->is_empty) {
push @tables_that_may_be_empty, $lv_lvt_v->complete_name;
Unicode_1_Name entries are used only for otherwise nameless code
points.
$alias_sentence
+This file doesn't include the algorithmically determinable names. For those,
+use 'unicore/Name.pm'
+END
+ ));
+ property_ref('Name')->add_comment(join_lines( <<END
+This file doesn't include the algorithmically determinable names. For those,
+use 'unicore/Name.pm'
END
));
my $in = Property->new('In',
Default_Map => $default_map,
Full_Name => "Present_In",
- Internal_Only => 1,
Perl_Extension => 1,
Type => $ENUM,
Initialize => $age,
foreach my $alias ($table->aliases) {
next if $alias->name =~ /^_/;
$table->add_alias('Is_' . $alias->name,
- Pod_Entry => 0,
+ Re_Pod_Entry => 0,
Status => $alias->status,
Externally_Ok => 0);
}
# No name collision, so ok to add the perl synonym.
- my $make_pod_entry;
+ my $make_re_pod_entry;
my $externally_ok;
my $status = $alias->status;
if ($nominal_property == $block) {
# we don't want people using the name without the
# 'In', so discourage that.
if ($prefix eq "") {
- $make_pod_entry = 1;
+ $make_re_pod_entry = 1;
$status = $status || $DISCOURAGED;
$externally_ok = 0;
}
elsif ($prefix eq 'In_') {
- $make_pod_entry = 0;
+ $make_re_pod_entry = 0;
$status = $status || $NORMAL;
$externally_ok = 1;
}
else {
- $make_pod_entry = 0;
+ $make_re_pod_entry = 0;
$status = $status || $DISCOURAGED;
$externally_ok = 0;
}
# The 'Is' prefix is handled in the pod by a wild
# card, and we won't use it for an external name
- $make_pod_entry = 0;
+ $make_re_pod_entry = 0;
$status = $status || $NORMAL;
$externally_ok = 0;
}
# Here, is an empty prefix, non block. This gets its
# own pod entry and can be used for an external name.
- $make_pod_entry = 1;
+ $make_re_pod_entry = 1;
$status = $status || $NORMAL;
$externally_ok = 1;
}
# Here, have found a table for $perl. Add this alias
# to it, and are done with this prefix.
$equivalent->add_alias($proposed_name,
- Pod_Entry => $make_pod_entry,
+ Re_Pod_Entry => $make_re_pod_entry,
Status => $status,
Externally_Ok => $externally_ok);
trace "adding alias perl=$proposed_name to $equivalent" if main::DEBUG && $to_trace;
# Here, $perl doesn't already have a table that is a
# synonym for this property, add one.
my $added_table = $perl->add_match_table($proposed_name,
- Pod_Entry => $make_pod_entry,
+ Re_Pod_Entry => $make_re_pod_entry,
Status => $status,
Externally_Ok => $externally_ok);
# And it will be related to the actual table, since it is
my @zero_match_tables; # List of tables that have no matches in this release
-sub make_table_pod_entries($) {
+sub make_re_pod_entries($) {
# This generates the entries for the pod file for a given table.
# Also done at this time are any children tables. The output looks like:
# \p{Common} \p{Script=Common} (Short: \p{Zyyy}) (5178)
foreach my $alias ($table->aliases) {
# Skip if not to go in pod.
- next unless $alias->make_pod_entry;
+ next unless $alias->make_re_pod_entry;
# Start gathering all the components for the entry
my $name = $alias->name;
# Create the .pod file. This generates the various subsections and then
# combines them in one big HERE document.
+ my $Is_flags_text = "If an entry has flag(s) at its beginning, like \"$DEPRECATED\", the \"Is_\" form has the same flag(s)";
+
return unless defined $pod_directory;
print "Making pod file\n" if $verbosity >= $PROGRESS;
about this.
END
}
- my $text = "If an entry has flag(s) at its beginning, like \"$DEPRECATED\", the \"Is_\" form has the same flag(s)";
+ my $text = $Is_flags_text;
$text = "$exception_message $text" if $has_Is_conflicts;
# And the 'Is_ line';
foreach my $why (sort { $why_list{$a}->[0] cmp $why_list{$b}->[0] }
keys %why_list)
{
- # Add to the output, all the properties that have that reason. Start
- # with an empty line.
- push @bad_re_properties, "\n\n";
-
+ # Add to the output, all the properties that have that reason.
my $has_item = 0; # Flag if actually output anything.
foreach my $name (@{$why_list{$why}}) {
my $short_name = $property->name;
$short_name .= '=' . $property->table($table)->name if $table;
+ # Start with an empty line.
+ push @bad_re_properties, "\n\n" unless $has_item;
+
# And add the property as an item for the reason.
push @bad_re_properties, "\n=item I<$name> ($short_name)\n";
$has_item = 1;
} # End of looping through each reason.
+ if (! @bad_re_properties) {
+ push @bad_re_properties,
+ "*** This installation accepts ALL non-Unihan properties ***";
+ }
+ else {
+ # Add =over only if non-empty to avoid an empty =over/=back section,
+ # which is considered bad form.
+ unshift @bad_re_properties, "\n=over 4\n";
+ push @bad_re_properties, "\n=back\n";
+ }
+
+ # Similiarly, generate a list of files that we don't use, grouped by the
+ # reasons why. First, create a hash whose keys are the reasons, and whose
+ # values are anonymous arrays of all the files that share that reason.
+ my %grouped_by_reason;
+ foreach my $file (keys %ignored_files) {
+ push @{$grouped_by_reason{$ignored_files{$file}}}, $file;
+ }
+
+ # Then, sort each group.
+ foreach my $group (keys %grouped_by_reason) {
+ @{$grouped_by_reason{$group}} = sort { lc $a cmp lc $b }
+ @{$grouped_by_reason{$group}} ;
+ }
+
+ # Finally, create the output text. For each reason (sorted by the
+ # alphabetically first file that has that reason)...
+ my @unused_files;
+ foreach my $reason (sort { lc $grouped_by_reason{$a}->[0]
+ cmp lc $grouped_by_reason{$b}->[0]
+ }
+ keys %grouped_by_reason)
+ {
+ # Add all the files that have that reason to the output. Start
+ # with an empty line.
+ push @unused_files, "\n\n";
+ push @unused_files, map { "\n=item F<$_> \n" }
+ @{$grouped_by_reason{$reason}};
+ # And add the reason under the list of files
+ push @unused_files, "\n$reason\n";
+ }
+
# Generate a list of the properties whose map table we output, from the
# global @map_properties.
my @map_tables_actually_output;
=head1 NAME
-$pod_file - Index of Unicode Version $string_version properties in Perl
+$pod_file - Index of Unicode Version $string_version character properties in Perl
=head1 DESCRIPTION
-There are many properties in Unicode, and Perl provides access to almost all of
-them, as well as some additional extensions and short-cut synonyms.
+This document provides information about the portion of the Unicode database
+that deals with character properties, that is the portion that is defined on
+single code points. (L</Other information in the Unicode data base>
+below briefly mentions other data that Unicode provides.)
+
+Perl can provide access to all non-provisional Unicode character properties,
+though not all are enabled by default. The omitted ones are the Unihan
+properties (accessible via the CPAN module L<Unicode::Unihan>) and certain
+deprecated or Unicode-internal properties. (An installation may choose to
+recompile Perl's tables to change this. See L<Unicode regular expression
+properties that are NOT accepted by Perl>.)
-And just about all of the few that aren't accessible through the Perl
-core are accessible through the modules: L<Unicode::Normalize> and
-L<Unicode::UCD>, and for Unihan properties, via the CPAN module
-L<Unicode::Unihan>.
+Perl also provides some additional extensions and short-cut synonyms
+for Unicode properties.
This document merely lists all available properties and does not attempt to
explain what each property really means. There is a brief description of each
-Perl extension. There is some detail about Blocks, Scripts, General_Category,
+Perl extension; see L<perlunicode/Other Properties> for more information on
+these. There is some detail about Blocks, Scripts, General_Category,
and Bidi_Class in L<perlunicode>, but to find out about the intricacies of the
-Unicode properties, refer to the Unicode standard. A good starting place is
-L<$unicode_reference_url>. More information on the Perl extensions is in
-L<perlunicode/Other Properties>.
+official Unicode properties, refer to the Unicode standard. A good starting
+place is L<$unicode_reference_url>.
Note that you can define your own properties; see
L<perlunicode/"User-Defined Character Properties">.
Titlecase_Mapping ucfirst()
Uppercase_Mapping uc()
-Case_Folding is accessible through the C</i> modifier in regular expressions.
+Also, Case_Folding is accessible through the C</i> modifier in regular
+expressions.
-The Name property is accessible through the C<\\N{}> interpolation in
-double-quoted strings and regular expressions, but both usages require a C<use
-charnames;> to be specified, which also contains related functions viacode(),
-vianame(), and string_vianame().
+And, the Name and Name_Aliases properties are accessible through the C<\\N{}>
+interpolation in double-quoted strings and regular expressions, but both
+usages require a L<use charnames;|charnames> to be specified, which also
+contains related functions viacode(), vianame(), and string_vianame().
=head1 Unicode regular expression properties that are NOT accepted by Perl
to accept any of these. The list is machine generated based on the
choices made for the installation that generated this document.
-=over 4
-
@bad_re_properties
-=back
-
An installation can choose to allow any of these to be matched by downloading
the Unicode database from L<http://www.unicode.org/Public/> to
C<\$Config{privlib}>/F<unicore/> in the Perl source tree, changing the
\$utf8::SwashInfo{'ToNAME'}{'specials_name'} = 'utf8::ToSpecNAME';
+
+=head1 Other information in the Unicode data base
+
+The Unicode data base is delivered in two different formats. The XML version
+is valid for more modern Unicode releases. The other version is a collection
+of files. The two are intended to give equivalent information. Perl uses the
+older form; this allows you to recompile Perl to use early Unicode releases.
+
+The only non-character property that Perl currently supports is Named
+Sequences, in which a sequence of code points
+is given a name and generally treated as a single entity. (Perl supports
+these via the C<\\N{...}> double-quotish construct,
+L<charnames/charnames::string_vianame(name)>, and L<Unicode::UCD/namedseq()>.
+
+Below is a list of the files in the Unicode data base that Perl doesn't
+currently use, along with very brief descriptions of their purposes.
+Some of the names of the files have been shortened from those that Unicode
+uses, in order to allow them to be distinguishable from similarly named files
+on file systems for which only the first 8 characters of a name are
+significant.
+
+=over 4
+
+@unused_files
+
+=back
+
=head1 SEE ALSO
L<$unicode_reference_url>
# Create and write Heavy.pl, which passes info about the tables to
# utf8_heavy.pl
+ # Stringify structures for output
+ my $loose_property_name_of
+ = simple_dumper(\%loose_property_name_of, ' ' x 4);
+ chomp $loose_property_name_of;
+
+ my $stricter_to_file_of = simple_dumper(\%stricter_to_file_of, ' ' x 4);
+ chomp $stricter_to_file_of;
+
+ my $loose_to_file_of = simple_dumper(\%loose_to_file_of, ' ' x 4);
+ chomp $loose_to_file_of;
+
+ my $nv_floating_to_rational
+ = simple_dumper(\%nv_floating_to_rational, ' ' x 4);
+ chomp $nv_floating_to_rational;
+
+ my $why_deprecated = simple_dumper(\%utf8::why_deprecated, ' ' x 4);
+ chomp $why_deprecated;
+
+ # We set the key to the file when we associated files with tables, but we
+ # couldn't do the same for the value then, as we might not have the file
+ # for the alternate table figured out at that time.
+ foreach my $cased (keys %caseless_equivalent_to) {
+ my @path = $caseless_equivalent_to{$cased}->file_path;
+ my $path = join '/', @path[1, -1];
+ $caseless_equivalent_to{$cased} = $path;
+ }
+ my $caseless_equivalent_to
+ = simple_dumper(\%caseless_equivalent_to, ' ' x 4);
+ chomp $caseless_equivalent_to;
+
my @heavy = <<END;
$HEADER
-$INTERNAL_ONLY
+$INTERNAL_ONLY_HEADER
# This file is for the use of utf8_heavy.pl
# Maps Unicode (not Perl single-form extensions) property names in loose
# standard form to their corresponding standard names
\%utf8::loose_property_name_of = (
-END
-
- push @heavy, simple_dumper (\%loose_property_name_of, ' ' x 4);
- push @heavy, <<END;
+$loose_property_name_of
);
# Maps property, table to file for those using stricter matching
\%utf8::stricter_to_file_of = (
-END
- push @heavy, simple_dumper (\%stricter_to_file_of, ' ' x 4);
- push @heavy, <<END;
+$stricter_to_file_of
);
# Maps property, table to file for those using loose matching
\%utf8::loose_to_file_of = (
-END
- push @heavy, simple_dumper (\%loose_to_file_of, ' ' x 4);
- push @heavy, <<END;
+$loose_to_file_of
);
# Maps floating point to fractional form
\%utf8::nv_floating_to_rational = (
-END
- push @heavy, simple_dumper (\%nv_floating_to_rational, ' ' x 4);
- push @heavy, <<END;
+$nv_floating_to_rational
);
# If a floating point number doesn't have enough digits in it to get this
# the table, so as to avoid duplication, as many property names can map to the
# file, but we only need one entry for all of them.
\%utf8::why_deprecated = (
-END
-
- push @heavy, simple_dumper (\%utf8::why_deprecated, ' ' x 4);
- push @heavy, <<END;
+$why_deprecated
);
-# A few properties have different behavior under /i matching. This maps the
+# A few properties have different behavior under /i matching. This maps
# those to substitute files to use under /i.
\%utf8::caseless_equivalent = (
+$caseless_equivalent_to
+);
+
+1;
END
- # We set the key to the file when we associated files with tables, but we
- # couldn't do the same for the value then, as we might not have the file
- # for the alternate table figured out at that time.
- foreach my $cased (keys %caseless_equivalent_to) {
- my @path = $caseless_equivalent_to{$cased}->file_path;
- my $path = join '/', @path[1, -1];
- $utf8::caseless_equivalent_to{$cased} = $path;
+ main::write("Heavy.pl", 0, \@heavy); # The 0 means no utf8.
+ return;
+}
+
+sub make_Name_pm () {
+ # Create and write Name.pm, which contains subroutines and data to use in
+ # conjunction with Name.pl
+
+ # Maybe there's nothing to do.
+ return unless $has_hangul_syllables || @code_points_ending_in_code_point;
+
+ my @name = <<END;
+$HEADER
+$INTERNAL_ONLY_HEADER
+END
+
+ # Convert these structures to output format.
+ my $code_points_ending_in_code_point =
+ main::simple_dumper(\@code_points_ending_in_code_point,
+ ' ' x 8);
+ my $names = main::simple_dumper(\%names_ending_in_code_point,
+ ' ' x 8);
+ my $loose_names = main::simple_dumper(\%loose_names_ending_in_code_point,
+ ' ' x 8);
+
+ # Do the same with the Hangul names,
+ my $jamo;
+ my $jamo_l;
+ my $jamo_v;
+ my $jamo_t;
+ my $jamo_re;
+ if ($has_hangul_syllables) {
+
+ # Construct a regular expression of all the possible
+ # combinations of the Hangul syllables.
+ my @L_re; # Leading consonants
+ for my $i ($LBase .. $LBase + $LCount - 1) {
+ push @L_re, $Jamo{$i}
+ }
+ my @V_re; # Middle vowels
+ for my $i ($VBase .. $VBase + $VCount - 1) {
+ push @V_re, $Jamo{$i}
+ }
+ my @T_re; # Trailing consonants
+ for my $i ($TBase + 1 .. $TBase + $TCount - 1) {
+ push @T_re, $Jamo{$i}
+ }
+
+ # The whole re is made up of the L V T combination.
+ $jamo_re = '('
+ . join ('|', sort @L_re)
+ . ')('
+ . join ('|', sort @V_re)
+ . ')('
+ . join ('|', sort @T_re)
+ . ')?';
+
+ # These hashes needed by the algorithm were generated
+ # during reading of the Jamo.txt file
+ $jamo = main::simple_dumper(\%Jamo, ' ' x 8);
+ $jamo_l = main::simple_dumper(\%Jamo_L, ' ' x 8);
+ $jamo_v = main::simple_dumper(\%Jamo_V, ' ' x 8);
+ $jamo_t = main::simple_dumper(\%Jamo_T, ' ' x 8);
}
- push @heavy, simple_dumper (\%utf8::caseless_equivalent_to, ' ' x 4);
- push @heavy, <<END;
-);
+
+ push @name, <<END;
+
+# This module contains machine-generated tables and code for the
+# algorithmically-determinable Unicode character names. The following
+# routines can be used to translate between name and code point and vice versa
+
+{ # Closure
+
+ # Matches legal code point. 4-6 hex numbers, If there are 6, the first
+ # two must be 10; if there are 5, the first must not be a 0. Written this
+ # way to decrease backtracking. The first regex allows the code point to
+ # be at the end of a word, but to work properly, the word shouldn't end
+ # with a valid hex character. The second one won't match a code point at
+ # the end of a word, and doesn't have the run-on issue
+ my \$run_on_code_point_re = qr/$run_on_code_point_re/;
+ my \$code_point_re = qr/$code_point_re/;
+
+ # In the following hash, the keys are the bases of names which includes
+ # the code point in the name, like CJK UNIFIED IDEOGRAPH-4E01. The values
+ # of each key is another hash which is used to get the low and high ends
+ # for each range of code points that apply to the name.
+ my %names_ending_in_code_point = (
+$names
+ );
+
+ # The following hash is a copy of the previous one, except is for loose
+ # matching, so each name has blanks and dashes squeezed out
+ my %loose_names_ending_in_code_point = (
+$loose_names
+ );
+
+ # And the following array gives the inverse mapping from code points to
+ # names. Lowest code points are first
+ my \@code_points_ending_in_code_point = (
+$code_points_ending_in_code_point
+ );
+END
+ # Earlier releases didn't have Jamos. No sense outputting
+ # them unless will be used.
+ if ($has_hangul_syllables) {
+ push @name, <<END;
+
+ # Convert from code point to Jamo short name for use in composing Hangul
+ # syllable names
+ my %Jamo = (
+$jamo
+ );
+
+ # Leading consonant (can be null)
+ my %Jamo_L = (
+$jamo_l
+ );
+
+ # Vowel
+ my %Jamo_V = (
+$jamo_v
+ );
+
+ # Optional trailing consonant
+ my %Jamo_T = (
+$jamo_t
+ );
+
+ # Computed re that splits up a Hangul name into LVT or LV syllables
+ my \$syllable_re = qr/$jamo_re/;
+
+ my \$HANGUL_SYLLABLE = "HANGUL SYLLABLE ";
+ my \$loose_HANGUL_SYLLABLE = "HANGULSYLLABLE";
+
+ # These constants names and values were taken from the Unicode standard,
+ # version 5.1, section 3.12. They are used in conjunction with Hangul
+ # syllables
+ my \$SBase = $SBase_string;
+ my \$LBase = $LBase_string;
+ my \$VBase = $VBase_string;
+ my \$TBase = $TBase_string;
+ my \$SCount = $SCount;
+ my \$LCount = $LCount;
+ my \$VCount = $VCount;
+ my \$TCount = $TCount;
+ my \$NCount = \$VCount * \$TCount;
+END
+ } # End of has Jamos
+
+ push @name, << 'END';
+
+ sub name_to_code_point_special {
+ my ($name, $loose) = @_;
+
+ # Returns undef if not one of the specially handled names; otherwise
+ # returns the code point equivalent to the input name
+ # $loose is non-zero if to use loose matching, 'name' in that case
+ # must be input as upper case with all blanks and dashes squeezed out.
+END
+ if ($has_hangul_syllables) {
+ push @name, << 'END';
+
+ if ((! $loose && $name =~ s/$HANGUL_SYLLABLE//)
+ || ($loose && $name =~ s/$loose_HANGUL_SYLLABLE//))
+ {
+ return if $name !~ qr/^$syllable_re$/;
+ my $L = $Jamo_L{$1};
+ my $V = $Jamo_V{$2};
+ my $T = (defined $3) ? $Jamo_T{$3} : 0;
+ return ($L * $VCount + $V) * $TCount + $T + $SBase;
+ }
+END
+ }
+ push @name, << 'END';
+
+ # Name must end in 'code_point' for this to handle.
+ return if (($loose && $name !~ /^ (.*?) ($run_on_code_point_re) $/x)
+ || (! $loose && $name !~ /^ (.*) ($code_point_re) $/x));
+
+ my $base = $1;
+ my $code_point = CORE::hex $2;
+ my $names_ref;
+
+ if ($loose) {
+ $names_ref = \%loose_names_ending_in_code_point;
+ }
+ else {
+ return if $base !~ s/-$//;
+ $names_ref = \%names_ending_in_code_point;
+ }
+
+ # Name must be one of the ones which has the code point in it.
+ return if ! $names_ref->{$base};
+
+ # Look through the list of ranges that apply to this name to see if
+ # the code point is in one of them.
+ for (my $i = 0; $i < scalar @{$names_ref->{$base}{'low'}}; $i++) {
+ return if $names_ref->{$base}{'low'}->[$i] > $code_point;
+ next if $names_ref->{$base}{'high'}->[$i] < $code_point;
+
+ # Here, the code point is in the range.
+ return $code_point;
+ }
+
+ # Here, looked like the name had a code point number in it, but
+ # did not match one of the valid ones.
+ return;
+ }
+
+ sub code_point_to_name_special {
+ my $code_point = shift;
+
+ # Returns the name of a code point if algorithmically determinable;
+ # undef if not
+END
+ if ($has_hangul_syllables) {
+ push @name, << 'END';
+
+ # If in the Hangul range, calculate the name based on Unicode's
+ # algorithm
+ if ($code_point >= $SBase && $code_point <= $SBase + $SCount -1) {
+ use integer;
+ my $SIndex = $code_point - $SBase;
+ my $L = $LBase + $SIndex / $NCount;
+ my $V = $VBase + ($SIndex % $NCount) / $TCount;
+ my $T = $TBase + $SIndex % $TCount;
+ $name = "$HANGUL_SYLLABLE$Jamo{$L}$Jamo{$V}";
+ $name .= $Jamo{$T} if $T != $TBase;
+ return $name;
+ }
+END
+ }
+ push @name, << 'END';
+
+ # Look through list of these code points for one in range.
+ foreach my $hash (@code_points_ending_in_code_point) {
+ return if $code_point < $hash->{'low'};
+ if ($code_point <= $hash->{'high'}) {
+ return sprintf("%s-%04X", $hash->{'name'}, $code_point);
+ }
+ }
+ return; # None found
+ }
+} # End closure
1;
END
- main::write("Heavy.pl", 0, \@heavy); # The 0 means no utf8.
+ main::write("Name.pm", 0, \@name); # The 0 means no utf8.
return;
}
+
sub write_all_tables() {
# Write out all the tables generated by this program to files, as well as
# the supporting data structures, pod file, and .t file.
# See if should suppress the table if is empty, but warn if it
# contains something.
- my $suppress_if_empty_warn_if_not = grep { $complete_name eq $_ }
- keys %why_suppress_if_empty_warn_if_not;
+ my $suppress_if_empty_warn_if_not
+ = $why_suppress_if_empty_warn_if_not{$complete_name} || 0;
# Calculate if this table should have any code points associated
# with it or not.
if ($table->is_empty) {
if ($suppress_if_empty_warn_if_not) {
- $table->set_status($SUPPRESSED,
- $why_suppress_if_empty_warn_if_not{$complete_name});
+ $table->set_fate($SUPPRESSED,
+ $suppress_if_empty_warn_if_not);
}
# Suppress (by skipping them) expected empty tables.
# this table is a child of another one to avoid duplicating
# the warning that should come from the parent one.
if (($table == $property || $table->parent == $table)
- && $table->status ne $SUPPRESSED
+ && $table->fate != $SUPPRESSED
&& ! grep { $complete_name =~ /^$_$/ }
@tables_that_may_be_empty)
{
elsif ($expected_empty) {
my $because = "";
if ($suppress_if_empty_warn_if_not) {
- $because = " because $why_suppress_if_empty_warn_if_not{$complete_name}";
+ $because = " because $suppress_if_empty_warn_if_not";
}
Carp::my_carp("Not expecting property $table$because. Generating file for it anyway.");
}
}
- if ($table->status eq $SUPPRESSED) {
+ if ($table->fate == $SUPPRESSED) {
if (! $is_property) {
my @children = $table->children;
foreach my $child (@children) {
- if ($child->status ne $SUPPRESSED) {
+ if ($child->fate != $SUPPRESSED) {
Carp::my_carp_bug("'$table' is suppressed and has a child '$child' which isn't");
}
}
# Add an entry in the pod file for the table; it also does
# the children.
- make_table_pod_entries($table) if defined $pod_directory;
+ make_re_pod_entries($table) if defined $pod_directory;
# See if the the table matches identical code points with
# something that has already been output. In that case,
# The full name of this property is stored by convention
# first in the alias array
- my $full_property_name =
- '\p{' . $property_aliases[0]->name . ': *}';
+ my $full_property_name = $property_aliases[0]->name;
my $standard_property_name = standardize($table->name);
# For each synonym ...
= $standard_property_name;
}
- # Now for the pod entry for this alias. Skip if not
+ # Now for the re pod entry for this alias. Skip if not
# outputting a pod; skip the first one, which is the
# full name so won't have an entry like: '\p{full: *}
# \p{full: *}', and skip if don't want an entry for
# this one.
next if $i == 0
|| ! defined $pod_directory
- || ! $alias->make_pod_entry;
+ || ! $alias->make_re_pod_entry;
- my $rhs = $full_property_name;
+ my $rhs = "\\p{$full_property_name: *}";
if ($property != $perl && $table->perl_extension) {
$rhs .= ' (Perl extension)';
}
# Write out the pod file
make_pod;
- # And Heavy.pl
+ # And Heavy.pl, Name.pm
make_Heavy;
+ make_Name_pm;
make_property_test_script() if $make_test_script;
return;
# pre-existing one.
push @property_aliases, map { Alias->new("Is_" . $_->name,
$_->loose_match,
- $_->make_pod_entry,
+ $_->make_re_pod_entry,
$_->externally_ok,
$_->status)
} @property_aliases;
Property => 'Bidi_Mirroring_Glyph',
),
Input_file->new("NormalizationTest.txt", v3.0.1,
- Skip => 1,
+ Skip => 'Validation Tests',
),
Input_file->new('CaseFolding.txt', v3.0.1,
Pre_Handler => \&setup_case_folding,
Handler => \&process_GCB_test,
),
Input_file->new("$AUXILIARY/LBTest.txt", v4.1.0,
- Skip => 1,
+ Skip => 'Validation Tests',
),
Input_file->new("$AUXILIARY/SBTest.txt", v4.1.0,
- Skip => 1,
+ Skip => 'Validation Tests',
),
Input_file->new("$AUXILIARY/WBTest.txt", v4.1.0,
- Skip => 1,
+ Skip => 'Validation Tests',
),
Input_file->new("$AUXILIARY/SentenceBreakProperty.txt", v4.1.0,
Property => 'Sentence_Break',
: undef,
),
Input_file->new("BidiTest.txt", v5.2.0,
- Skip => 1,
+ Skip => 'Validation Tests',
),
Input_file->new('UnihanIndicesDictionary.txt', v5.2.0,
Optional => 1,
https://perl5.git.perl.org / perl5.git / blobdiff