$start_time= time;
}
-
require 5.010_001;
use strict;
use warnings;
# Name have a different value for every named code point. Those will not,
# unless the controlling lists are changed, have their match tables written
# out. But all the ones which can be used in regular expression \p{} and \P{}
-# constructs will. Generally a property will have either its map table or its
-# match tables written but not both. Again, what gets written is controlled
-# by lists which can easily be changed. Properties have a 'Type', like
-# binary, or string, or enum depending on how many match tables there are and
-# the content of the maps. This 'Type' is different than a range 'Type', so
-# don't get confused by the two concepts having the same name.
+# constructs will. Prior to 5.14, generally a property would have either its
+# map table or its match tables written but not both. Again, what gets
+# written is controlled by lists which can easily be changed. Starting in
+# 5.14, advantage was taken of this, and all the map tables needed to
+# reconstruct the Unicode db are now written out, while suppressing the
+# Unicode .txt files that contain the data. Our tables are much more compact
+# than the .txt files, so a significant space savings was achieved.
+
+# Properties have a 'Type', like binary, or string, or enum depending on how
+# many match tables there are and the content of the maps. This 'Type' is
+# different than a range 'Type', so don't get confused by the two concepts
+# having the same name.
#
# For information about the Unicode properties, see Unicode's UAX44 document:
# As stated earlier, this program will work on any release of Unicode so far.
# Most obvious problems in earlier data have NOT been corrected except when
# necessary to make Perl or this program work reasonably. For example, no
-# folding information was given in early releases, so this program uses the
-# substitute of lower case, just so that a regular expression with the /i
-# option will do something that actually gives the right results in many
-# cases. There are also a couple other corrections for version 1.1.5,
-# commented at the point they are made. As an example of corrections that
-# weren't made (but could be) is this statement from DerivedAge.txt: "The
-# supplementary private use code points and the non-character code points were
-# assigned in version 2.0, but not specifically listed in the UCD until
-# versions 3.0 and 3.1 respectively." (To be precise it was 3.0.1 not 3.0.0)
-# More information on Unicode version glitches is further down in these
-# introductory comments.
+# folding information was given in early releases, so this program substitutes
+# lower case instead, just so that a regular expression with the /i option
+# will do something that actually gives the right results in many cases.
+# There are also a couple other corrections for version 1.1.5, commented at
+# the point they are made. As an example of corrections that weren't made
+# (but could be) is this statement from DerivedAge.txt: "The supplementary
+# private use code points and the non-character code points were assigned in
+# version 2.0, but not specifically listed in the UCD until versions 3.0 and
+# 3.1 respectively." (To be precise it was 3.0.1 not 3.0.0) More information
+# on Unicode version glitches is further down in these introductory comments.
#
# This program works on all non-provisional properties as of 6.0, though the
# files for some are suppressed from apparent lack of demand for them. You
# warn about any that it doesn't know how to handle (the -q option suppresses
# the warning).
#
-# Why have files written out for binary 'N' matches?
-# For binary properties, if you know the mapping for either Y or N; the
-# other is trivial to construct, so could be done at Perl run-time by just
-# complementing the result, instead of having a file for it. That is, if
-# someone types in \p{foo: N}, Perl could translate that to \P{foo: Y} and
-# not need a file. The problem is communicating to Perl that a given
-# property is binary. Perl can't figure it out from looking at the N (or
-# No), as some non-binary properties have these as property values. So
-# rather than inventing a way to communicate this info back to the core,
-# which would have required changes there as well, it was simpler just to
-# add the extra tables.
-#
# Why is there more than one type of range?
# This simplified things. There are some very specialized code points that
# have to be handled specially for output, such as Hangul syllable names.
# can't just take the intersection of two map tables, for example, as that
# is nonsensical.
#
-# There are no match tables generated for matches of the null string. These
-# would look like qr/\p{JSN=}/ currently without modifying the regex code.
-# Perhaps something like them could be added if necessary. The JSN does have
-# a real code point U+110B that maps to the null string, but it is a
-# contributory property, and therefore not output by default. And it's easily
-# handled so far by making the null string the default where it is a
-# possibility.
-#
# DEBUGGING
#
# This program is written so it will run under miniperl. Occasionally changes
# non_skip => 1,
# to the constructor for those files you want processed when you set this.
# Files with a first version number of 0 are special: they are always
-# processed regardless of the state of this flag.
+# processed regardless of the state of this flag. Generally, Jamo.txt and
+# UnicodeData.txt must not be skipped if you want this program to not die
+# before normal completion.
my $debug_skip = 0;
# Set to 1 to enable tracing.
# This is for a rarely used development feature that allows you to compare two
# versions of the Unicode standard without having to deal with changes caused
-# by the code points introduced in the later version. Change the 0 to a SINGLE
-# dotted Unicode release number (e.g. 2.1). Only code points introduced in
-# that release and earlier will be used; later ones are thrown away. You use
-# the version number of the earliest one you want to compare; then run this
-# program on directory structures containing each release, and compare the
-# outputs. These outputs will therefore include only the code points common
-# to both releases, and you can see the changes caused just by the underlying
-# release semantic changes. For versions earlier than 3.2, you must copy a
-# version of DAge.txt into the directory.
-my $string_compare_versions = DEBUG && 0; # e.g., v2.1;
+# by the code points introduced in the later version. Change the 0 to a
+# string containing a SINGLE dotted Unicode release number (e.g. "2.1"). Only
+# code points introduced in that release and earlier will be used; later ones
+# are thrown away. You use the version number of the earliest one you want to
+# compare; then run this program on directory structures containing each
+# release, and compare the outputs. These outputs will therefore include only
+# the code points common to both releases, and you can see the changes caused
+# just by the underlying release semantic changes. For versions earlier than
+# 3.2, you must copy a version of DAge.txt into the directory.
+my $string_compare_versions = DEBUG && 0; # e.g., "2.1";
my $compare_versions = DEBUG
&& $string_compare_versions
&& pack "C*", split /\./, $string_compare_versions;
# for any code point is available in a more compact form.
my %global_to_output_map = (
# Needed by UCD.pm, but don't want to publicize that it exists, so won't
- # get stuck supporting it if things change. Sinc it is a STRING property,
- # it normally would be listed in the pod, but INTERNAL_MAP suppresses
- # that.
+ # get stuck supporting it if things change. Since it is a STRING
+ # property, it normally would be listed in the pod, but INTERNAL_MAP
+ # suppresses that.
Unicode_1_Name => $INTERNAL_MAP,
Present_In => 0, # Suppress, as easily computed from Age
- Canonical_Combining_Class => 0, # Duplicate of CombiningClass.pl
Block => 0, # Suppress, as Blocks.txt is retained.
+
+ # Suppress, as mapping can be found instead from the
+ # Perl_Decomposition_Mapping file
+ Decomposition_Type => 0,
);
# 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.
'Other_Lowercase' => $contributory,
'Other_Math' => $contributory,
'Other_Uppercase' => $contributory,
+ 'Expands_On_NFC' => $why_no_expand,
+ 'Expands_On_NFD' => $why_no_expand,
+ 'Expands_On_NFKC' => $why_no_expand,
+ 'Expands_On_NFKD' => $why_no_expand,
);
%why_suppressed = (
'Name_Alias' => "Accessible via 'use charnames;'",
FC_NFKC_Closure => 'Supplanted in usage by NFKC_Casefold; otherwise not useful',
- Expands_On_NFC => $why_no_expand,
- Expands_On_NFD => $why_no_expand,
- Expands_On_NFKC => $why_no_expand,
- Expands_On_NFKD => $why_no_expand,
);
# The following are suppressed because they were made contributory or
# deprecated by Unicode before Perl ever thought about supporting them.
- foreach my $property ('Jamo_Short_Name', 'Grapheme_Link') {
+ foreach my $property ('Jamo_Short_Name',
+ 'Grapheme_Link',
+ 'Expands_On_NFC',
+ 'Expands_On_NFD',
+ 'Expands_On_NFKC',
+ 'Expands_On_NFKD'
+ ) {
$why_suppressed{$property} = $why_deprecated{$property};
}
if ($v_version ge 5.2.0 && $v_version lt 6.0.0) {
$why_obsolete{'ISO_Comment'} = 'Code points for it have been removed';
if ($v_version ge 6.0.0) {
- $why_deprecated{'ISO_Comment'} = 'No longer needed for chart generation; otherwise not useful, and code points for it have been removed';
+ $why_deprecated{'ISO_Comment'} = 'No longer needed for Unicode\'s internal chart generation; otherwise not useful, and code points for it have been removed';
}
}
$why_suppressed{'Script=Katakana_Or_Hiragana'} = 'Obsolete. All code points previously matched by this have been moved to "Script=Common".';
}
if ($v_version ge v6.0.0) {
- $why_suppressed{'Script=Katakana_Or_Hiragana'} .= ' Consider instead using Script_Extensions=Katakana or Script_Extensions=Hiragana (or both)"';
- $why_suppressed{'Script_Extensions=Katakana_Or_Hiragana'} = 'All code points that would be matched by this are matched by either Script_Extensions=Katakana or Script_Extensions=Hiragana"';
+ $why_suppressed{'Script=Katakana_Or_Hiragana'} .= ' Consider instead using "Script_Extensions=Katakana" or "Script_Extensions=Hiragana (or both)"';
+ $why_suppressed{'Script_Extensions=Katakana_Or_Hiragana'} = 'All code points that would be matched by this are matched by either "Script_Extensions=Katakana" or "Script_Extensions=Hiragana"';
}
# This program can create files for enumerated-like properties, such as
my @output_mapped_properties = split "\n", <<END;
END
-# If you are using the Unihan database, you need to add the properties that
-# you want to extract from it to this table. For your convenience, the
-# properties in the 6.0 PropertyAliases.txt file are listed, commented out
+# If you are using the Unihan database in a Unicode version before 5.2, you
+# need to add the properties that you want to extract from it to this table.
+# For your convenience, the properties in the 6.0 PropertyAliases.txt file are
+# listed, commented out
my @cjk_properties = split "\n", <<'END';
#cjkAccountingNumeric; kAccountingNumeric
#cjkOtherNumeric; kOtherNumeric
# Similarly for the property values. For your convenience, the lines in the
# 6.0 PropertyAliases.txt file are listed. Just remove the first BUT NOT both
-# '#' marks
+# '#' marks (for Unicode versions before 5.2)
my @cjk_property_values = split "\n", <<'END';
## @missing: 0000..10FFFF; cjkAccountingNumeric; NaN
## @missing: 0000..10FFFF; cjkCompatibilityVariant; <code point>
# 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 the Perl program only. The format and even
-# the name or existence of this file are subject to change without notice.
-# Don't use it directly.
+# This file is for internal use by core Perl only. The format and even the
+# name or existence of this file are subject to change without notice. Don't
+# use it directly.
EOF
my $DEVELOPMENT_ONLY=<<"EOF";
EOF
-my $LAST_UNICODE_CODEPOINT_STRING = "10FFFF";
-my $LAST_UNICODE_CODEPOINT = hex $LAST_UNICODE_CODEPOINT_STRING;
-my $MAX_UNICODE_CODEPOINTS = $LAST_UNICODE_CODEPOINT + 1;
+my $MAX_UNICODE_CODEPOINT_STRING = "10FFFF";
+my $MAX_UNICODE_CODEPOINT = hex $MAX_UNICODE_CODEPOINT_STRING;
+my $MAX_UNICODE_CODEPOINTS = $MAX_UNICODE_CODEPOINT + 1;
# 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/;
# depends on this ending with a semi-colon, so it can assume it is a valid
# field when the line is split() by semi-colons
my $missing_defaults_prefix =
- qr/^#\s+\@missing:\s+0000\.\.$LAST_UNICODE_CODEPOINT_STRING\s*;/;
+ qr/^#\s+\@missing:\s+0000\.\.$MAX_UNICODE_CODEPOINT_STRING\s*;/;
# Property types. Unicode has more types, but these are sufficient for our
# purposes.
my $UNKNOWN = -1; # initialized to illegal value
my $NON_STRING = 1; # Either binary or enum
my $BINARY = 2;
-my $ENUM = 3; # Include catalog
-my $STRING = 4; # Anything else: string or misc
+my $FORCED_BINARY = 3; # Not a binary property, but, besides its normal
+ # tables, additional true and false tables are
+ # generated so that false is anything matching the
+ # default value, and true is everything else.
+my $ENUM = 4; # Include catalog
+my $STRING = 5; # Anything else: string or misc
# Some input files have lines that give default values for code points not
# contained in the file. Sometimes these should be ignored.
# 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'; # 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 $RATIONAL_FORMAT = 'r';
my $STRING_FORMAT = 's';
my $DECOMP_STRING_FORMAT = 'c';
+my $STRING_WHITE_SPACE_LIST = 'sw';
my %map_table_formats = (
$BINARY_FORMAT => 'binary',
$DECIMAL_FORMAT => 'single decimal digit',
$FLOAT_FORMAT => 'floating point number',
$INTEGER_FORMAT => 'integer',
- $HEX_FORMAT => 'positive hex whole number; a code point',
+ $HEX_FORMAT => 'non-negative hex whole number; a code point',
$RATIONAL_FORMAT => 'rational: an integer or a fraction',
$STRING_FORMAT => 'string',
$DECOMP_STRING_FORMAT => 'Perl\'s internal (Normalize.pm) decomposition mapping',
+ $STRING_WHITE_SPACE_LIST => 'string, but some elements are interpreted as a list; white space occurs only as list item separators'
);
# Unicode didn't put such derived files in a separate directory at first.
my %stricter_to_file_of; # same; but for stricter mapping.
my %nv_floating_to_rational; # maps numeric values floating point numbers to
# their rational equivalent
-my %loose_property_name_of; # Loosely maps property names to standard form
+my %loose_property_name_of; # Loosely maps (non_string) property names to
+ # standard form
# Most properties are immune to caseless matching, otherwise you would get
# nonsensical results, as properties are a function of a code point, not
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.
my $perl_charname;
my $print;
my $Any;
+my $script;
# Are there conflicting names because of beginning with 'In_', or 'Is_'
my $has_In_conflicts = 0;
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;
}
main::set_access('name', \%name, 'r');
my %loose_match;
- # Determined by the constructor code if this name should match loosely or
- # not. The constructor parameters can override this, but it isn't fully
- # implemented, as should have ability to override Unicode one's via
- # something like a set_loose_match()
+ # 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;
# If the range list is empty, return a large value that isn't adjacent
# to any that could be in the range list, for simpler tests
- return $LAST_UNICODE_CODEPOINT + 2 unless scalar @{$ranges{$addr}};
+ return $MAX_UNICODE_CODEPOINT + 2 unless scalar @{$ranges{$addr}};
return $ranges{$addr}->[0]->start;
}
# Don't add an exact duplicate, as it isn't really a multiple
if ($end >= $r->[$i]->start) {
+ my $existing_value = $r->[$i]->value;
+ my $existing_type = $r->[$i]->type;
+ return if $value eq $existing_value && $type eq $existing_type;
+
+ # If the multiple value is part of an existing range, we want
+ # to split up that range, so that only the single code point
+ # is affected. To do this, we first call ourselves
+ # recursively to delete that code point from the table, having
+ # preserved its current data above. Then we call ourselves
+ # recursively again to add the new multiple, which we know by
+ # the test just above is different than the current code
+ # point's value, so it will become a range containing a single
+ # code point: just itself. Finally, we add back in the
+ # pre-existing code point, which will again be a single code
+ # point range. Because 'i' likely will have changed as a
+ # result of these operations, we can't just continue on, but
+ # do this operation recursively as well.
if ($r->[$i]->start != $r->[$i]->end) {
- Carp::my_carp_bug("$owner_name_of{$addr}Can't cope with adding a multiple record when the other range ($r->[$i]) contains more than one code point. No action taken.");
- return;
+ $self->_add_delete('-', $start, $end, "");
+ $self->_add_delete('+', $start, $end, $value, Type => $type);
+ return $self->_add_delete('+', $start, $end, $existing_value, Type => $existing_type, Replace => $MULTIPLE);
}
- return if $value eq $r->[$i]->value && $type eq $r->[$i]->type;
}
trace "Adding multiple record at $i with $start..$end, $value" if main::DEBUG && $to_trace;
# And finally, add the gap from the end of the table to the max
# possible code point
- if ($max < $LAST_UNICODE_CODEPOINT) {
- $new->add_range($max + 1, $LAST_UNICODE_CODEPOINT);
+ if ($max < $MAX_UNICODE_CODEPOINT) {
+ $new->add_range($max + 1, $MAX_UNICODE_CODEPOINT);
}
return $new;
}
my $a = $a_ranges[$i];
my $b = $b_ranges[$i];
trace "self $a; other $b" if main::DEBUG && $to_trace;
- return 0 if $a->start != $b->start || $a->end != $b->end;
+ return 0 if ! defined $b
+ || $a->start != $b->start
+ || $a->end != $b->end;
}
return 1;
}
return $try_hard if $code >= 0xFDD0 && $code <= 0xFDEF;
return $try_hard if ($code & 0xFFFE) == 0xFFFE; # includes FFFF
- return $try_hard if $code > $LAST_UNICODE_CODEPOINT; # keep in range
+ return $try_hard if $code > $MAX_UNICODE_CODEPOINT; # keep in range
return $try_hard if $code >= 0xD800 && $code <= 0xDFFF; # no surrogate
return 1;
main::set_access('property', \%property, 'r');
my %aliases;
- # Ordered list of aliases of the table's name. The first ones in the list
- # are output first in comments
+ # Ordered list of alias objects of the table's name. The first ones in
+ # the list are output first in comments
main::set_access('aliases', \%aliases, 'readable_array');
my %comment;
# files.
main::set_access('note', \%note, 'readable_array');
- my %internal_only;
- # Boolean; if set means any file that contains this table is marked as for
- # internal-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_Warning'} || 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
+ 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
# clarity. Other routines rely on the full name being first on the
$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
}
}
+ # If the short name isn't a nice one, perhaps an equivalent table has
+ # a better one.
+ if (! defined $short_name{$addr}
+ || $short_name{$addr} eq ""
+ || $short_name{$addr} eq "_")
+ {
+ my $return;
+ foreach my $follower ($self->children) { # All equivalents
+ my $follower_name = $follower->short_name;
+ next unless defined $follower_name;
+
+ # Anything (except undefined) is better than underscore or
+ # empty
+ if (! defined $return || $return eq "_") {
+ $return = $follower_name;
+ next;
+ }
+
+ # If the new follower name isn't "_" and is shorter than the
+ # current best one, prefer the new one.
+ next if $follower_name eq "_";
+ next if length $follower_name > length $return;
+ $return = $follower_name;
+ }
+ $short_name{$addr} = $return if defined $return;
+ }
+
# If no suitable external name return undef
if (! defined $short_name{$addr}) {
$$nominal_length_ptr = undef if $nominal_length_ptr;
return;
}
- # Don't allow a null external name.
+ # Don't allow a null short name.
if ($short_name{$addr} eq "") {
$short_name{$addr} = '_';
$nominal_short_name_length{$addr} = 1;
sub external_name {
# Returns the external name that this table should be known by. This
- # is usually the short_name, but not if the short_name is undefined.
+ # is usually the short_name, but not if the short_name is undefined,
+ # in which case the external_name is arbitrarily set to the
+ # underscore.
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
my $return = "";
$return .= $DEVELOPMENT_ONLY if $compare_versions;
$return .= $HEADER;
- no overloading;
- $return .= $INTERNAL_ONLY if $internal_only{pack 'J', $self};
return $return;
}
# certain number of blocks, might as well output the whole
# thing if it all will fit in one block. The number of
# ranges below is an approximate number for that.
- && $self->property->type == $BINARY
+ && ($self->property->type == $BINARY
+ || $self->property->type == $FORCED_BINARY)
# && $self->property->tables == 2 Can't do this because the
# non-binary properties, like NFDQC aren't specifiable
# by the notation
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
*$sub = sub {
use strict "refs";
my $self = shift;
- no overloading;
- return $range_list{pack 'J', $self}->$sub(@_);
+ return $self->_range_list->$sub(@_);
}
}
return if $self->carp_if_locked;
no overloading;
- return $range_list{pack 'J', $self}->$sub(@_);
+ return $self->_range_list->$sub(@_);
}
}
my %to_output_map;
# Enum as to whether or not to write out this map table:
+ # 0 don't output
# $EXTERNAL_MAP means its existence is noted in the documentation, and
# it should not be removed nor its format changed. This
# is done for those files that have traditionally been
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 a
- # 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,
+ # 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) {
# output format.
for my $code_point ($low .. $high) {
- # The pack() below can't cope with surrogates.
+ # The pack() below can't cope with surrogates. XXX This may
+ # no longer be true
if ($code_point >= 0xD800 && $code_point <= 0xDFFF) {
Carp::my_carp("Surrogate code point '$code_point' in mapping to '$map' in $self. No map created");
next;
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;
# if the Unicode one is deprecated, the Perl one will be too. Not so for
# unrelated tables. Relatedness makes generating the documentation easier.
#
-# 2) Conflicting. It may be that there will eventually be name clashes, with
+# 2) Complement.
+# Like equivalents, two tables may be the inverses of each other, the
+# intersection between them is null, and the union is every Unicode code
+# point. The two tables that occupy a binary property are necessarily like
+# this. By specifying one table as the complement of another, we can avoid
+# storing it on disk (using the other table and performing a fast
+# transform), and some memory and calculations.
+#
+# 3) Conflicting. It may be that there will eventually be name clashes, with
# the same name meaning different things. For a while, there actually were
# conflicts, but they have so far been resolved by changing Perl's or
# Unicode's definitions to match the other, but when this code was written,
my %parent;
# The parent table to this one, initially $self. This allows us to
- # distinguish between equivalent tables that are related, and those which
- # may not be, but share the same output file because they match the exact
- # same set of code points in the current Unicode release.
+ # distinguish between equivalent tables that are related (for which this
+ # is set to), and those which may not be, but share the same output file
+ # because they match the exact same set of code points in the current
+ # Unicode release.
main::set_access('parent', \%parent, 'r');
my %children;
my %complement;
# Points to the complement that this table is expressed in terms of; 0 if
# none.
- main::set_access('complement', \%complement, 'r', 's' );
+ main::set_access('complement', \%complement, 'r');
sub new {
my $class = shift;
return "Table '$name'";
}
+ sub _range_list {
+ # Returns the range list associated with this table, which will be the
+ # complement's if it has one.
+
+ my $self = shift;
+ my $complement;
+ if (($complement = $self->complement) != 0) {
+ return ~ $complement->_range_list;
+ }
+ else {
+ return $self->SUPER::_range_list;
+ }
+ }
+
sub add_alias {
# Add a synonym for this table. See the comments in the base class
Carp::my_carp_bug("Use add_alias() to set two Perl tables '$self' and '$other', equivalent.");
return;
}
- } elsif (! $other->perl_extension) {
+ } elsif ($self->property != $other->property # Depending on
+ # situation, might
+ # be better to use
+ # add_alias()
+ # instead for same
+ # property
+ && ! $other->perl_extension)
+ {
Carp::my_carp_bug("set_equivalent_to should have 'Related => 0 for equivalencing two Unicode properties. Assuming $self is not related to $other");
$related = 0;
}
# 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;
}
+ sub set_complement {
+ # Set $self to be the complement of the parameter table. $self is
+ # locked, as what it contains should all come from the other table.
+
+ my $self = shift;
+ my $other = shift;
+
+ my %args = @_;
+ Carp::carp_extra_args(\%args) if main::DEBUG && %args;
+
+ if ($other->complement != 0) {
+ Carp::my_carp_bug("Can't set $self to be the complement of $other, which itself is the complement of " . $other->complement);
+ return;
+ }
+ my $addr = do { no overloading; pack 'J', $self; };
+ $complement{$addr} = $other;
+ $self->lock;
+ return;
+ }
+
sub add_range { # Add a range to the list for this table.
my $self = shift;
# Rest of parameters passed on
return $self->_range_list->add_range(@_);
}
- sub pre_body { # Does nothing for match tables.
- return
+ 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
}
sub append_to_body { # Does nothing for match tables.
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 && @_;
# listing all possible combinations in the comment, we make
# sure that each synonym occurs at least once, and add
# commentary that the other combinations are possible.
+ # Because regular expressions don't recognize things like
+ # \p{jsn=}, only look at non-null right-hand-sides
my @property_aliases = $table_property->aliases;
- my @table_aliases = $table->aliases;
-
- Carp::my_carp_bug("$table doesn't have any names. Proceeding anyway.") unless @table_aliases;
+ my @table_aliases = grep { $_->name ne "" } $table->aliases;
# The alias lists above are already ordered in the order we
# want to output them. To ensure that each synonym is listed,
- # we must use the max of the two numbers.
- my $listed_combos = main::max(scalar @table_aliases,
- scalar @property_aliases);
+ # we must use the max of the two numbers. But if there are no
+ # legal synonyms (nothing in @table_aliases), then we don't
+ # list anything.
+ my $listed_combos = (@table_aliases)
+ ? main::max(scalar @table_aliases,
+ scalar @property_aliases)
+ : 0;
trace "$listed_combos, tables=", scalar @table_aliases, "; names=", scalar @property_aliases if main::DEBUG;
+
my $property_had_compound_name = 0;
for my $i (0 .. $listed_combos - 1) {
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++;
my $synonyms;
my $entries;
- if ($total_entries <= 1) {
+ if ($total_entries == 1) {
$synonyms = "";
$entries = 'entry';
$any_of_these = 'this'
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";
}
- $comment .= <<END;
+ if ($total_entries == 0) {
+ Carp::my_carp("No regular expression construct can match $leader, as all names for it are the null string. Creating file anyway.");
+ $comment .= <<END;
+This file returns the $code_points in Unicode Version $string_version for
+$leader, but it is inaccessible through Perl regular expressions, as
+"\\p{prop=}" is not recognized.
+END
+
+ } else {
+ $comment .= <<END;
This file returns the $code_points in Unicode Version $string_version that
$match$synonyms:
variants. Upper/lower case distinctions never matter.
END
+ }
if ($compound_name) {
$comment .= <<END;
# A boolean that gives whether the input data should declare all the
# tables used, or not. If the former, unknown ones raise a warning.
main::set_access('pre_declared_maps',
- \%pre_declared_maps, 'r');
+ \%pre_declared_maps, 'r', 's');
sub new {
# The only required parameter is the positionally first, name. All
# values should be defined for all
# properties, except those overriding this
// $v_version ge v5.1.0;
+
# Rest of parameters passed on.
$has_only_code_point_maps{$addr} = 1;
_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_Warning => 1); # Override any
- # input param
+ %args);
return unless defined $table;
}
Carp::my_carp("$self Added a match table '$name' to a string property '$self'. Changed it to a non-string property. Bad News.");
$type{$addr} = $NON_STRING;
}
- elsif ($type{$addr} != $ENUM) {
+ elsif ($type{$addr} != $ENUM && $type{$addr} != $FORCED_BINARY) {
if (scalar main::uniques(values %{$table_ref{$addr}}) > 2
&& $type{$addr} == $BINARY)
{
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;
}
my $type = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- if ($type != $ENUM && $type != $BINARY && $type != $STRING) {
+ if ($type != $ENUM
+ && $type != $BINARY
+ && $type != $FORCED_BINARY
+ && $type != $STRING)
+ {
Carp::my_carp("Unrecognized type '$type'. Type not set");
return;
}
{ no overloading; $type{pack 'J', $self} = $type; }
- return if $type != $BINARY;
+ return if $type != $BINARY && $type != $FORCED_BINARY;
my $yes = $self->table('Y');
$yes = $self->table('Yes') if ! defined $yes;
- $yes = $self->add_match_table('Y') if ! defined $yes;
- $yes->add_alias('Yes');
- $yes->add_alias('T');
- $yes->add_alias('True');
-
+ $yes = $self->add_match_table('Y', Full_Name => 'Yes')
+ if ! defined $yes;
+
+ # Add aliases in order wanted, duplicates will be ignored. We use a
+ # binary property present in all releases for its ordered lists of
+ # true/false aliases. Note, that could run into problems in
+ # outputting things in that we don't distinguish between the name and
+ # full name of these. Hopefully, if the table was already created
+ # before this code is executed, it was done with these set properly.
+ my $bm = property_ref("Bidi_Mirrored");
+ foreach my $alias ($bm->table("Y")->aliases) {
+ $yes->add_alias($alias->name);
+ }
my $no = $self->table('N');
$no = $self->table('No') if ! defined $no;
- $no = $self->add_match_table('N') if ! defined $no;
- $no->add_alias('No');
- $no->add_alias('F');
- $no->add_alias('False');
+ $no = $self->add_match_table('N', Full_Name => 'No') if ! defined $no;
+ foreach my $alias ($bm->table("N")->aliases) {
+ $no->add_alias($alias->name);
+ }
+
return;
}
# If already have figured these out, no need to do so again, but we do
# a double check on ENUMS to make sure that a string property hasn't
# improperly been classified as an ENUM, so continue on with those.
- return if $type == $STRING || $type == $BINARY;
+ return if $type == $STRING
+ || $type == $BINARY
+ || $type == $FORCED_BINARY;
# If every map is to a code point, is a string property.
if ($type == $UNKNOWN
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
my $copy = $item;
$copy = $UNDEF unless defined $copy;
- # Quote non-numbers (numbers also have optional leading '-' and
- # fractions)
- if ($copy eq "" || $copy !~ /^ -? \d+ ( \. \d+ )? $/x) {
+ # Quote non-integers (integers also have optional leading '-')
+ if ($copy eq "" || $copy !~ /^ -? \d+ $/x) {
# Escape apostrophe and backslash
$copy =~ s/ ( ['\\] ) /\\$1/xg;
# Indent array elements one level
$output .= &simple_dumper($item->[$i], $next_indent);
- $output =~ s/\n$//; # Remove trailing nl so as to
- $output .= " # [$i]\n"; # add a comment giving the
- # array index
+ $output =~ s/\n$//; # Remove any trailing nl so
+ $output .= " # [$i]\n"; # as to add a comment giving
+ # the array index
}
$output .= $indent; # Indent closing ']' to orig level
}
# These are used so much, that we set globals for them.
$gc = property_ref('General_Category');
$block = property_ref('Block');
+ $script = property_ref('Script');
# Perl adds this alias.
$gc->add_alias('Category');
my $fold = property_ref('Case_Folding');
$fold->set_file('Fold') if defined $fold;
+ # Unicode::Normalize expects this file with this name and directory.
+ my $ccc = property_ref('Canonical_Combining_Class');
+ if (defined $ccc) {
+ $ccc->set_file('CombiningClass');
+ $ccc->set_directory(File::Spec->curdir());
+ }
+
# utf8.c has a different meaning for non range-size-1 for map properties
# that this program doesn't currently handle; and even if it were changed
# to do so, some other code may be using them expecting range size 1.
my ($property, @data) = split /\s*;\s*/;
- # The full name for the ccc property value is in field 2 of the
- # remaining ones; field 1 for all other properties. Swap ccc fields 1
- # and 2. (Rightmost splice removes field 2, returning it; left splice
- # inserts that into field 1, thus shifting former field 1 to field 2.)
- splice (@data, 1, 0, splice(@data, 2, 1)) if $property eq 'ccc';
+ # The ccc property has an extra field at the beginning, which is the
+ # numeric value. Move it to be after the other two, mnemonic, fields,
+ # so that those will be used as the property value's names, and the
+ # number will be an extra alias. (Rightmost splice removes field 1-2,
+ # returning them in a slice; left splice inserts that before anything,
+ # thus shifting the former field 0 to after them.)
+ splice (@data, 0, 0, splice(@data, 1, 2)) if $property eq 'ccc';
+
+ # Field 0 is a short name unless "n/a"; field 1 is the full name. If
+ # there is no short name, use the full one in element 1
+ if ($data[0] eq "n/a") {
+ $data[0] = $data[1];
+ }
+ elsif ($data[0] ne $data[1]
+ && standardize($data[0]) eq standardize($data[1])
+ && $data[1] !~ /[[:upper:]]/)
+ {
+ # Also, there is a bug in the file in which "n/a" is omitted, and
+ # the two fields are identical except for case, and the full name
+ # is all lower case. Copy the "short" name unto the full one to
+ # give it some upper case.
- # If there is no short name, use the full one in element 1
- $data[0] = $data[1] if $data[0] eq "n/a";
+ $data[1] = $data[0];
+ }
# Earlier releases had the pseudo property 'qc' that should expand to
# the ones that replace it below.
# the little used $compare_versions feature is enabled.
my $compare_versions_range_list;
+ # These are constants to the $property_info hash in this subroutine, to
+ # avoid using a quoted-string which might have a typo.
+ my $TYPE = 'type';
+ my $DEFAULT_MAP = 'default_map';
+ my $DEFAULT_TABLE = 'default_table';
+ my $PSEUDO_MAP_TYPE = 'pseudo_map_type';
+ my $MISSINGS = 'missings';
+
sub process_generic_property_file {
# This processes a file containing property mappings and puts them
# into internal map tables. It should be used to handle any property
# If not the first time for this property, retrieve info about
# it from the cache
- if (defined ($property_info{$property_addr}{'type'})) {
- $property_type = $property_info{$property_addr}{'type'};
- $default_map = $property_info{$property_addr}{'default'};
+ if (defined ($property_info{$property_addr}{$TYPE})) {
+ $property_type = $property_info{$property_addr}{$TYPE};
+ $default_map = $property_info{$property_addr}{$DEFAULT_MAP};
$map_type
- = $property_info{$property_addr}{'pseudo_map_type'};
+ = $property_info{$property_addr}{$PSEUDO_MAP_TYPE};
$default_table
- = $property_info{$property_addr}{'default_table'};
+ = $property_info{$property_addr}{$DEFAULT_TABLE};
}
else {
# Here, is the first time for this property. Set up the
# cache.
- $property_type = $property_info{$property_addr}{'type'}
+ $property_type = $property_info{$property_addr}{$TYPE}
= $property_object->type;
$map_type
- = $property_info{$property_addr}{'pseudo_map_type'}
+ = $property_info{$property_addr}{$PSEUDO_MAP_TYPE}
= $property_object->pseudo_map_type;
# The Unicode files are set up so that if the map is not
else {
$property_object->set_type($BINARY);
$property_type
- = $property_info{$property_addr}{'type'}
+ = $property_info{$property_addr}{$TYPE}
= $BINARY;
}
}
if ($property_type == $STRING
|| $property_type == $UNKNOWN)
{
- $property_info{$addr}{'missings'} = $default;
+ $property_info{$addr}{$MISSINGS} = $default;
}
else {
- $property_info{$addr}{'missings'}
+ $property_info{$addr}{$MISSINGS}
= $property_object->table($default);
}
}
# Finished storing all the @missings defaults in the input
# file so far. Get the one for the current property.
- my $missings = $property_info{$property_addr}{'missings'};
+ my $missings = $property_info{$property_addr}{$MISSINGS};
# But we likely have separately stored what the default
# should be. (This is to accommodate versions of the
$default_table = $missings;
$default_map = $missings->full_name;
}
- $property_info{$property_addr}{'default_table'}
+ $property_info{$property_addr}{$DEFAULT_TABLE}
= $default_table;
}
elsif ($default_map ne $missings) {
}
}
- $property_info{$property_addr}{'default'}
+ $property_info{$property_addr}{$DEFAULT_MAP}
= $default_map;
# If haven't done so already, find the table corresponding
&& $property_type != $UNKNOWN)
{
$default_table = $property_info{$property_addr}
- {'default_table'}
+ {$DEFAULT_TABLE}
= $property_object->table($default_map);
}
} # End of is first time for this property
Default_Map => "",
Directory => File::Spec->curdir(),
File => 'Name',
- Internal_Only_Warning => 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_Warning => 1,
+ Fate => $INTERNAL_ONLY,
Perl_Extension => 1,
Default_Map => $CODE_POINT,
$Perl_decomp->add_comment(join_lines(<<END
This mapping is a combination of the Unicode 'Decomposition_Type' and
'Decomposition_Mapping' properties, formatted for use by normalize.pm. It is
-identical to the official Unicode 'Decomposition_Mapping' property except for
+identical to the official Unicode 'Decomposition_Mapping' property except for
two things:
1) It omits the algorithmically determinable Hangul syllable decompositions,
which normalize.pm handles algorithmically.
sub filter_v6_ucd {
- # Unicode 6.0 co-opted the name BELL for U+1F514, so change the input
- # to pretend that U+0007 is ALERT instead, and for Perl 5.14, don't
- # allow the BELL name for U+1F514, so that the old usage can be
- # deprecated for one cycle.
+ # Unicode 6.0 co-opted the name BELL for U+1F514, but we haven't
+ # accepted that yet to allow for some deprecation cycles.
return if $_ !~ /^(?:0007|1F514|070F);/;
my ($code_point, @fields) = split /\s*;\s*/, $_, -1;
if ($code_point eq '0007') {
- $fields[$CHARNAME] = "ALERT";
+ $fields[$CHARNAME] = "";
}
elsif ($code_point eq '070F') { # Unicode Corrigendum #8; see
# http://www.unicode.org/versions/corrigendum8.html
# relatively few entries in them that have different full mappings,
# and thus skip the simple mapping tables altogether.
+ # New tables with just the simple mappings that are overridden by the
+ # full ones are constructed. These are for Unicode::UCD, which
+ # requires the simple mappings. The Case_Folding table is a combined
+ # table of both the simple and full mappings, with the full ones being
+ # in the hash, and the simple ones, even those overridden by the hash,
+ # being in the base table. That same mechanism could have been
+ # employed here, except that the docs have said that the generated
+ # files are usuable directly by programs, so we dare not change the
+ # format in any way.
+
my $file= shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
# 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
$to_output_simple
= property_ref('Simple_Case_Folding')->to_output_map;
+ # If we ever wanted to show that these tables were combined, a new
+ # property method could be created, like set_combined_props()
+ property_ref('Case_Folding')->add_comment(join_lines( <<END
+This file includes both the simple and full case folding maps. The simple
+ones are in the main body of the table below, and the full ones adding to or
+overriding them are in the hash.
+END
+ ));
return;
}
{ # Closure
my %unihan_properties;
- my $iicore;
-
sub setup_unihan {
# Do any special setup for Unihan properties.
my $usource = property_ref('kIRG_USource');
$usource->set_type($STRING) if defined $usource;
- # This property is to be considered binary, so change all the values
- # to Y.
- $iicore = property_ref('kIICore');
+ # This property is to be considered binary (it says so in
+ # http://www.unicode.org/reports/tr38/)
+ my $iicore = property_ref('kIICore');
if (defined $iicore) {
- $iicore->add_match_table('Y') if ! defined $iicore->table('Y');
-
- # We have to change the default map, because the @missing line is
- # misleading, given that we are treating it as binary.
- $iicore->set_default_map('N');
- $iicore->set_type($BINARY);
+ $iicore->set_type($FORCED_BINARY);
+ $iicore->table("Y")->add_note("Forced to a binary property as per unicode.org UAX #38.");
+
+ # Unicode doesn't include the maps for this property, so don't
+ # warn that they are missing.
+ $iicore->set_pre_declared_maps(0);
+ $iicore->add_comment(join_lines( <<END
+This property contains enum values, but Unicode UAX #38 says it should be
+interpreted as binary, so Perl creates tables for both 1) its enum values,
+plus 2) true/false tables in which it is considered true for all code points
+that have a non-null value
+END
+ ));
}
return;
return;
}
- # The iicore property is supposed to be a boolean, so convert to our
- # standard boolean form.
- if (defined $iicore && $unihan_properties{$property} == $iicore) {
- $_ =~ s/$property.*/$property\tY/
- }
-
# Convert the tab separators to our standard semi-colons, and convert
# the U+HHHH notation to the rest of the standard's HHHH
s/\t/;/g;
Initialize => $sc,
Default_Map => $sc->default_map,
Pre_Declared_Maps => 0,
+ Format => $STRING_WHITE_SPACE_LIST,
);
$scx->add_comment(join_lines( <<END
The values for code points that appear in one script are just the same as for
}
}
+sub filter_script_extensions_line {
+ # The Scripts file comes with the full name for the scripts; the
+ # ScriptExtensions, with the short name. The final mapping file is a
+ # combination of these, and without adjustment, would have inconsistent
+ # entries. This filters the latter file to convert to full names.
+ # Entries look like this:
+ # 064B..0655 ; Arab Syrc # Mn [11] ARABIC FATHATAN..ARABIC HAMZA BELOW
+
+ my @fields = split /\s*;\s*/;
+ my @full_names;
+ foreach my $short_name (split " ", $fields[1]) {
+ push @full_names, $script->table($short_name)->full_name;
+ }
+ $fields[1] = join " ", @full_names;
+ $_ = join "; ", @fields;
+
+ return;
+}
+
+sub setup_v6_name_alias {
+ property_ref('Name_Alias')->add_map(7, 7, "ALERT");
+}
+
sub finish_Unicode() {
# This routine should be called after all the Unicode files have been read
# in. It:
# Add any remaining code points to the mapping, using the default for
# missing code points.
+ my $default_table;
if (defined (my $default_map = $property->default_map)) {
# Make sure there is a match table for the default
- my $default_table;
if (! defined ($default_table = $property->table($default_map))) {
$default_table = $property->add_match_table($default_map);
}
}
$default_table->set_complement($non_default_table);
}
+ else {
- # This fills in any missing values with the default. It's
- # tempting to save some time and memory in running this program
- # by skipping this step for binary tables where the default
- # is easily calculated. But it is needed for generating
- # the test file, and other changes would also be required to do
- # so.
- $property->add_map(0, $LAST_UNICODE_CODEPOINT,
- $default_map, Replace => $NO);
+ # This fills in any missing values with the default. It's not
+ # necessary to do this with binary properties, as the default
+ # is defined completely in terms of the Y table.
+ $property->add_map(0, $MAX_UNICODE_CODEPOINT,
+ $default_map, Replace => $NO);
+ }
}
# Have all we need to populate the match tables.
my $maps_should_be_defined = $property->pre_declared_maps;
foreach my $range ($property->ranges) {
my $map = $range->value;
- my $table = property_ref($property_name)->table($map);
+ my $table = $property->table($map);
if (! defined $table) {
# Integral and rational property values are not necessarily
{
Carp::my_carp("Table '$property_name=$map' should have been defined. Defining it now.")
}
- $table = property_ref($property_name)->add_match_table($map);
+ $table = $property->add_match_table($map);
}
+ next if $table->complement != 0; # Don't need to populate these
$table->add_range($range->start, $range->end);
}
- # And add the Is_ prefix synonyms for Perl 5.6 compatibility, in which
- # all properties have this optional prefix. These do not get a
- # separate entry in the pod file, because are covered by a wild-card
- # entry
+ # A forced binary property has additional true/false tables which
+ # should have been set up when it was forced into binary. The false
+ # table matches exactly the same set as the property's default table.
+ # The true table matches the complement of that. The false table is
+ # not the same as an additional set of aliases on top of the default
+ # table, so use 'set_equivalent_to'. If it were implemented as
+ # additional aliases, various things would have to be adjusted, but
+ # especially, if the user wants to get a list of names for the table
+ # using Unicode::UCD::prop_value_aliases(), s/he should get a
+ # different set depending on whether they want the default table or
+ # the false table.
+ if ($property_type == $FORCED_BINARY) {
+ $property->table('N')->set_equivalent_to($default_table,
+ Related => 1);
+ $property->table('Y')->set_complement($default_table);
+ }
+
+ # For Perl 5.6 compatibility, all properties matchable in regexes can
+ # have an optional 'Is_' prefix. This is now done in utf8_heavy.pl.
+ # But warn if this creates a conflict with a (new) Unicode property
+ # name, although it appears that Unicode has made a decision never to
+ # begin a property name with 'Is_', so this shouldn't happen.
foreach my $alias ($property->aliases) {
my $Is_name = 'Is_' . $alias->name;
- if (! defined (my $pre_existing = property_ref($Is_name))) {
- $property->add_alias($Is_name,
- Pod_Entry => 0,
- Status => $alias->status,
- Externally_Ok => 0);
- }
- else {
-
- # It seemed too much work to add in these warnings when it
- # appears that Unicode has made a decision never to begin a
- # property name with 'Is_', so this shouldn't happen, but just
- # in case, it is a warning.
+ if (defined (my $pre_existing = property_ref($Is_name))) {
Carp::my_carp(<<END
-There is already an alias named $Is_name (from " . $pre_existing . "), so not
-creating this alias for $property. The generated table and pod files do not
-warn users of this conflict.
+There is already an alias named $Is_name (from " . $pre_existing . "), so
+creating one for $property won't work. This is bad news. If it is not too
+late, get Unicode to back off. Otherwise go back to the old scheme (findable
+from the git blame log for this area of the code that suppressed individual
+aliases that conflict with the new Unicode names. Proceeding anyway.
END
);
- $has_Is_conflicts++;
}
} # End of loop through aliases for this property
} # End of loop through all Unicode properties.
# tables are deleted.
my $scx = property_ref("Script_Extensions");
- foreach my $table ($scx->tables) {
- next unless $table->name =~ /\s/; # Only the new tables have a space
- # in their names, and all do
- my @scripts = split /\s+/, $table->name;
- foreach my $script (@scripts) {
- my $script_table = $scx->table($script);
- $script_table += $table;
+ if (defined $scx) {
+ foreach my $table ($scx->tables) {
+ next unless $table->name =~ /\s/; # All the new and only the new
+ # tables have a space in their
+ # names
+ my @scripts = split /\s+/, $table->name;
+ foreach my $script (@scripts) {
+ my $script_table = $scx->table($script);
+ $script_table += $table;
+ }
+ $scx->delete_match_table($table);
}
- $scx->delete_match_table($table);
}
return;
# 'Any' is all code points. As an error check, instead of just setting it
# to be that, construct it to be the union of all the major categories
$Any = $perl->add_match_table('Any',
- Description => "[\\x{0000}-\\x{$LAST_UNICODE_CODEPOINT_STRING}]",
+ Description => "[\\x{0000}-\\x{$MAX_UNICODE_CODEPOINT_STRING}]",
Matches_All => 1);
foreach my $major_table ($gc->tables) {
$Any += $major_table;
}
- if ($Any->max != $LAST_UNICODE_CODEPOINT) {
+ if ($Any->max != $MAX_UNICODE_CODEPOINT) {
Carp::my_carp_bug("Generated highest code point ("
. sprintf("%X", $Any->max)
- . ") doesn't match expected value $LAST_UNICODE_CODEPOINT_STRING.")
+ . ") doesn't match expected value $MAX_UNICODE_CODEPOINT_STRING.")
}
if ($Any->range_count != 1 || $Any->min != 0) {
Carp::my_carp_bug("Generated table 'Any' doesn't match all code points.")
);
# Our internal-only property should be treated as more than just a
- # synonym.
- $perl->add_match_table('_CombAbove')
+ # synonym; grandfather it in to the pod.
+ $perl->add_match_table('_CombAbove', Re_Pod_Entry => 1,
+ Fate => $INTERNAL_ONLY, Status => $DISCOURAGED)
->set_equivalent_to(property_ref('ccc')->table('Above'),
Related => 1);
# Earliest releases didn't have title case. Initialize it to empty if not
# otherwise present
- my $Title = $perl->add_match_table('Title');
- $Title->add_alias('Titlecase');
+ my $Title = $perl->add_match_table('Title', Full_Name => 'Titlecase',
+ Description => '(= \p{Gc=Lt})');
my $lt = $gc->table('Lt');
# Earlier versions of mktables had this related to $lt since they have
- # identical code points, but their casefolds are not equivalent, and so
- # now must be kept as separate entities.
+ # identical code points, but their caseless equivalents are not the same,
+ # one being 'Cased' and the other being 'LC', and so now must be kept as
+ # separate entities.
$Title += $lt if defined $lt;
# If this Unicode version doesn't have Cased, set up our own. From
# one of Nonspacing_Mark (Mn), Enclosing_Mark (Me), Format (Cf),
# Modifier_Letter (Lm), or Modifier_Symbol (Sk).
- # Perl has long had an internal-only alias for this property.
- my $perl_case_ignorable = $perl->add_match_table('_Case_Ignorable');
+ # 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',
+ 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.
- my $CanonDCIJ = $perl->add_match_table('_CanonDCIJ');
+ # was in. A pod entry is grandfathered in for it
+ 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,
+ Fate => $INTERNAL_ONLY,
+ Initialize =>
+ ord('_')
+ + (property_ref('XID_Start')->table('Y') & $Word)
+ );
my $gcb = property_ref('Grapheme_Cluster_Break');
# 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
));
-
- # The combining class property used by Perl's normalize.pm is not located
- # in the normal mapping directory; create a copy for it.
- my $ccc = property_ref('Canonical_Combining_Class');
- my $perl_ccc = Property->new('Perl_ccc',
- Default_Map => $ccc->default_map,
- Full_Name => 'Perl_Canonical_Combining_Class',
- Internal_Only_Warning => 1,
- Perl_Extension => 1,
- Pod_Entry =>0,
- Type => $ENUM,
- Initialize => $ccc,
- File => 'CombiningClass',
- Directory => File::Spec->curdir(),
- );
- $perl_ccc->set_to_output_map($EXTERNAL_MAP);
- $perl_ccc->add_comment(join_lines(<<END
-This mapping is for normalize.pm. It is currently identical to the Unicode
-Canonical_Combining_Class property.
+ property_ref('Name')->add_comment(join_lines( <<END
+This file doesn't include the algorithmically determinable names. For those,
+use 'unicore/Name.pm'
END
));
- # This one match table for it is needed for calculations on output
- my $default = $perl_ccc->add_match_table($ccc->default_map,
- Initialize => $ccc->table($ccc->default_map),
- Status => $SUPPRESSED);
-
# Construct the Present_In property from the Age property.
if (-e 'DAge.txt' && defined (my $age = property_ref('Age'))) {
my $default_map = $age->default_map;
my $in = Property->new('In',
Default_Map => $default_map,
Full_Name => "Present_In",
- Internal_Only_Warning => 1,
Perl_Extension => 1,
Type => $ENUM,
Initialize => $age,
);
$in->add_comment(join_lines(<<END
-This file should not be used for any purpose. The values in this file are the
+THIS FILE SHOULD NOT BE USED FOR ANY PURPOSE. The values in this file are the
same as for $age, and not for what $in really means. This is because anything
defined in a given release should have multiple values: that release and all
higher ones. But only one value per code point can be represented in a table
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);
}
Initialize => $gc->table('Unassigned')
& property_ref('Noncharacter_Code_Point')->table('N'));
- for (my $i = 0; $i <= $LAST_UNICODE_CODEPOINT; $i++ ) {
+ for (my $i = 0; $i <= $MAX_UNICODE_CODEPOINT; $i++ ) {
$i = populate_char_info($i); # Note sets $i so may cause skips
}
}
# Construct the list of tables to get synonyms for. Start with all the
# binary and the General_Category ones.
- my @tables = grep { $_->type == $BINARY } property_ref('*');
+ my @tables = grep { $_->type == $BINARY || $_->type == $FORCED_BINARY }
+ property_ref('*');
push @tables, $gc->tables;
# If the version of Unicode includes the Script property, add its tables
- if (defined property_ref('Script')) {
- push @tables, property_ref('Script')->tables;
- }
+ push @tables, $script->tables if defined $script;
# The Block tables are kept separate because they are treated differently.
# And the earliest versions of Unicode didn't include them, so add only if
# 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
# unless they are the same table. For example, N meaning Number or
# Neutral is not likely to cause confusion, so don't add caveats to things
# like them.
- foreach my $property (grep { $_->type != $BINARY } property_ref('*')) {
+ foreach my $property (grep { $_->type != $BINARY
+ && $_->type != $FORCED_BINARY }
+ property_ref('*'))
+ {
my $yes = $property->table('Yes');
if (defined $yes) {
my $y = $property->table('Y');
=~ s/^ ( -? \d+ ) \.0+ $ /$1/x)
{
$stricter_to_file_of{$property . $integer_name}
- = $sub_filename;
+ = $sub_filename;
}
}
}
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)
# for each name each table goes by
foreach my $table ($input_table, $input_table->children) {
- # utf8_heavy.pl cannot deal with null string property values, so don't
- # output any.
- next if $table->name eq "";
+ # utf8_heavy.pl cannot deal with null string property values, so skip
+ # any tables that have no non-null names.
+ next if ! grep { $_->name ne "" } $table->aliases;
# First, gather all the info that applies to this table as a whole.
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;
+ # Skip if name is empty, as can't be accessed by regexes.
+ next if $name eq "";
+
my $entry; # Holds the left column, may include extras
my $entry_ref; # To refer to the left column's contents from
# another entry; has no extras
# Only generate one entry for all the aliases that mean true
# or false in binary properties. Append a '*' to indicate
# some are missing. (The heading comment notes this.)
- my $wild_card_mark;
+ my $rhs;
if ($type == $BINARY) {
next if $name ne 'N' && $name ne 'Y';
- $wild_card_mark = '*';
+ $rhs = "$name*";
+ }
+ elsif ($type != $FORCED_BINARY) {
+ $rhs = $name;
}
else {
- $wild_card_mark = "";
+
+ # Forced binary properties require special handling. It
+ # has two sets of tables, one set is true/false; and the
+ # other set is everything else. Entries are generated for
+ # each set. Use the Bidi_Mirrored property (which appears
+ # in all Unicode versions) to get a list of the aliases
+ # for the true/false tables. Of these, only output the N
+ # and Y ones, the same as, a regular binary property. And
+ # output all the rest, same as a non-binary property.
+ my $bm = property_ref("Bidi_Mirrored");
+ if ($name eq 'N' || $name eq 'Y') {
+ $rhs = "$name*";
+ } elsif (grep { $name eq $_->name } $bm->table("Y")->aliases,
+ $bm->table("N")->aliases)
+ {
+ next;
+ }
+ else {
+ $rhs = $name;
+ }
}
# Colon-space is used to give a little more space to be easier
# to read;
$entry = "\\p{"
. $table_property_full_name
- . ": $name$wild_card_mark}";
+ . ": $rhs}";
# But for the reference to this entry, which will go in the
# right column, where space is at a premium, use equals
# Special case the binary N tables, so that will print
# \P{single}, but use the Y table values to populate
- # 'single', as we haven't populated the N table.
+ # 'single', as we haven't likewise populated the N table.
+ # For forced binary tables, we can't just look at the N
+ # table, but must see if this table is equivalent to the N
+ # one, as there are two equivalent beasts in these
+ # properties.
my $test_table;
my $p;
- if ($type == $BINARY
- && $input_table == $property->table('No'))
+ if ( ($type == $BINARY
+ && $input_table == $property->table('No'))
+ || ($type == $FORCED_BINARY
+ && $property->table('No')->
+ is_set_equivalent_to($input_table)))
{
$test_table = $property->table('Yes');
$p = 'P';
# 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';
. $formatted_properties;
# Generate pod documentation lines for the tables that match nothing
- my $zero_matches;
+ my $zero_matches = "";
if (@zero_match_tables) {
@zero_match_tables = uniques(@zero_match_tables);
$zero_matches = join "\n\n",
map { $_ = '=item \p{' . $_->complete_name . "}" }
sort { $a->complete_name cmp $b->complete_name }
- uniques(@zero_match_tables);
+ @zero_match_tables;
$zero_matches = <<END;
=head2 Legal C<\\p{}> and C<\\P{}> constructs that match no characters
Unicode has some property-value pairs that currently don't match anything.
-This happens generally either because they are obsolete, or for symmetry with
-other forms, but no language has yet been encoded that uses them. In this
-version of Unicode, the following match zero code points:
+This happens generally either because they are obsolete, or they exist for
+symmetry with other forms, but no language has yet been encoded that uses
+them. In this version of Unicode, the following match zero code points:
=over 4
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;
# Generate a list of the formats that can appear in the map tables.
my @map_table_formats;
foreach my $format (sort keys %map_table_formats) {
- push @map_table_formats, " $format $map_table_formats{$format}\n";
+ push @map_table_formats,
+ Text::Tabs::expand("$format\t$map_table_formats{$format}\n");
}
-
+ @map_table_formats = simple_fold(\@map_table_formats,
+ ' ',
+ 8,
+ $automatic_pod_indent);
local $" = "";
# Everything is ready to assemble.
=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.)
-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 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>.)
+
+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">.
=over 4
-=item Obsolete
-
-Properties marked with $a_bold_obsolete in the table are considered
-obsolete.
-
=item Stabilized
-Obsolete properties may be stabilized. Such a determination does not indicate
+A property may be stabilized. Such a determination does not indicate
that the property should or should not be used; instead it is a declaration
that the property will not be maintained nor extended for newly encoded
characters. Such properties are marked with $a_bold_stabilized in the
=item Deprecated
-An obsolete property may be deprecated, perhaps because its original intent
+A property may be deprecated, perhaps because its original intent
has been replaced by another property, or because its specification was
somehow defective. This means that its use is strongly
discouraged, so much so that a warning will be issued if used, unless the
A deprecated property may be made unavailable in a future Perl version, so it
is best to move away from them.
+A deprecated property may also be stabilized, but this fact is not shown.
+
+=item Obsolete
+
+Properties marked with $a_bold_obsolete in the table are considered (plain)
+obsolete. Generally this designation is given to properties that Unicode once
+used for internal purposes (but not any longer).
+
=back
Some Perl extensions are present for backwards compatibility and are
-discouraged from being used, but not obsolete. $A_bold_discouraged
-flags each such entry in the table.
+discouraged from being used, but are not obsolete. $A_bold_discouraged
+flags each such entry in the table. Future Unicode versions may force
+some of these extensions to be removed without warning, replaced by another
+property with the same name that means something different. Use the
+equivalent shown instead.
@block_warning
Note that all non-essential underscores are removed in the display of the
short names below.
-B<Summary legend:>
+B<Legend summary:>
=over 4
=item B<$STRICTER> means tighter (stricter) name matching applies.
-=item B<$DISCOURAGED> means use of this form is discouraged.
+=item B<$DISCOURAGED> means use of this form is discouraged, and may not be
+stable.
=back
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
used in a regular expression. The non-Unihan ones are listed below, with the
reasons they are not accepted, perhaps with work-arounds. The short names for
the properties are listed enclosed in (parentheses).
-
-=over 4
+As described after the list, an installation can change the defaults and choose
+to accept any of these. The list is machine generated based on the
+choices made for the installation that generated this document.
@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
Perl reserves the right to change the format and even the existence of any of
those files without notice, except the ones that were in existence prior to
-release 5.13. If those change, a deprecation cycle will be done first. These
+release 5.14. If those change, a deprecation cycle will be done first. These
are:
@map_tables_actually_output
\$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 property names in loose standard form to its standard name
+# 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
+ main::write("Heavy.pl", 0, \@heavy); # The 0 means no utf8.
+ return;
+}
- # 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;
+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.
return 1 if $a->complement != 0;
return -1 if $b->complement != 0;
+ # Similarly, return a subservient table after
+ # a leader
+ return 1 if $a->leader != $a;
+ return -1 if $b->leader != $b;
+
my $cmp = length $ext_a <=> length $ext_b;
# Return result if lengths not equal
# 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.
($is_property)
? # All these types of map tables will be full because
# they will have been populated with defaults
- ($type == $ENUM || $type == $BINARY)
+ ($type == $ENUM || $type == $FORCED_BINARY)
: # A match table should match everything if its method
# shows it should
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 expected empty tables.
+ # Suppress (by skipping them) expected empty tables.
next TABLE if $expected_empty;
# And setup to later output a warning for those that aren't
# 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,
# have to have the same status to share a file, so add
# this to the bucket hash. (The reason for this latter is
# that Heavy.pl associates a status with a file.)
- my $hash = $table->hash . ';' . $table->status;
-
- # Look at each table that is in the same bucket as this
- # one would be.
- foreach my $comparison (@{$match_tables_to_write{$hash}})
- {
- if ($table->matches_identically_to($comparison)) {
- $table->set_equivalent_to($comparison,
+ # We don't check tables that are inverses of others, as it
+ # would lead to some coding complications, and checking
+ # all the regular ones should find everything.
+ if ($table->complement == 0) {
+ my $hash = $table->hash . ';' . $table->status;
+
+ # Look at each table that is in the same bucket as
+ # this one would be.
+ foreach my $comparison
+ (@{$match_tables_to_write{$hash}})
+ {
+ if ($table->matches_identically_to($comparison)) {
+ $table->set_equivalent_to($comparison,
Related => 0);
- next TABLE;
+ next TABLE;
+ }
}
- }
- # Here, not equivalent, add this table to the bucket.
- push @{$match_tables_to_write{$hash}}, $table;
+ # Here, not equivalent, add this table to the bucket.
+ push @{$match_tables_to_write{$hash}}, $table;
+ }
}
}
else {
# 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 ...
my $alias_name = $alias->name;
my $alias_standard = standardize($alias_name);
- # Set the mapping for utf8_heavy of the alias to the
+ # For utf8_heavy, set the mapping of the alias to the
# property
if (exists ($loose_property_name_of{$alias_standard}))
{
= $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)';
}
} # End of non-string-like property code
- # Don't output a mapping file if not desired.
+ # Don't write out a mapping file if not desired.
next if ! $property->to_output_map;
}
# 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;
# in the set_final_comment() for Tables
my @table_aliases = $table->aliases;
my @property_aliases = $table->property->aliases;
+
+ # Every property can be optionally be prefixed by 'Is_', so test
+ # that those work, by creating such a new alias for each
+ # pre-existing one.
+ push @property_aliases, map { Alias->new("Is_" . $_->name,
+ $_->loose_match,
+ $_->make_re_pod_entry,
+ $_->externally_ok,
+ $_->status)
+ } @property_aliases;
my $max = max(scalar @table_aliases, scalar @property_aliases);
for my $j (0 .. $max - 1) {
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',
),
Input_file->new('NameAliases.txt', v5.0.0,
Property => 'Name_Alias',
+ Pre_Handler => ($v_version ge v6.0.0)
+ ? \&setup_v6_name_alias
+ : undef,
),
Input_file->new("BidiTest.txt", v5.2.0,
- Skip => 1,
+ Skip => 'Validation Tests',
),
Input_file->new('UnihanIndicesDictionary.txt', v5.2.0,
Optional => 1,
Input_file->new('ScriptExtensions.txt', v6.0.0,
Property => 'Script_Extensions',
Pre_Handler => \&setup_script_extensions,
+ Each_Line_Handler => \&filter_script_extensions_line,
),
);
https://perl5.git.perl.org / perl5.git / blobdiff