# compatible, but that has now been abandoned, and newer constructs are used
# as convenient.
+# NOTE: this script can run quite slowly in older/slower systems.
+# It can also consume a lot of memory (128 MB or more), you may need
+# to raise your process resource limits (e.g. in bash, "ulimit -a"
+# to inspect, and "ulimit -d ..." or "ulimit -m ..." to set)
+
my $start_time;
BEGIN { # Get the time the script started running; do it at compilation to
# get it as close as possible
sub NON_ASCII_PLATFORM { ord("A") != 65 }
+# When a new version of Unicode is published, unfortunately the algorithms for
+# dealing with various bounds, like \b{gcb}, \b{lb} may have to be updated
+# manually. The changes may or may not be backward compatible with older
+# releases. The code is in regen/mk_invlist.pl and regexec.c. Make the
+# changes, then come back here and set the variable below to what version the
+# code is expecting. If a newer version of Unicode is being compiled than
+# expected, a warning will be generated. If an older version is being
+# compiled, any bounds tests that fail in the generated test file (-maketest
+# option) will be marked as TODO.
+my $version_of_mk_invlist_bounds = v10.0.0;
+
##########################################################################
#
# mktables -- create the runtime Perl Unicode files (lib/unicore/.../*.pl),
#
# trace ... if main::DEBUG && $to_trace;
#
+# main::stack_trace() will display what its name implies
+#
# If there is just one or a few files that you're debugging, you can easily
# cause most everything else to be skipped. Change the line
#
#
# A NOTE ON UNIHAN
#
-# This program can generate tables from the Unihan database. But that db
+# This program can generate tables from the Unihan database. But that DB
# isn't normally available, so it is marked as optional. Prior to version
# 5.2, this database was in a single file, Unihan.txt. In 5.2 the database
# was split into 8 different files, all beginning with the letters 'Unihan'.
# handled by Unicode::Normalize, nor will it compile when presented a version
# that has them. However, you can trivially get it to compile by simply
# ignoring those decompositions, by changing the croak to a carp. At the time
-# of this writing, the line (in cpan/Unicode-Normalize/Normalize.pm or
-# cpan/Unicode-Normalize/mkheader) reads
+# of this writing, the line (in dist/Unicode-Normalize/Normalize.pm or
+# dist/Unicode-Normalize/mkheader) reads
#
# croak("Weird Canonical Decomposition of U+$h");
#
}
}
+sub stack_trace() {
+ local $to_trace = 1 if main::DEBUG;
+ my $line = (caller(0))[2];
+ my $i = 1;
+
+ # Accumulate the stack trace
+ while (1) {
+ my ($pkg, $file, $caller_line, $caller) = caller $i++;
+
+ last unless defined $caller;
+
+ trace "called from $caller() at line $line";
+ $line = $caller_line;
+ }
+}
+
# 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. You probably also want
-# to use the -annotate option when using this. 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";
+# to use the -annotate option when using this. Run this program on a unicore
+# containing the starting release you want to compare. Save that output
+# structure. Then, switching to a unicore with the ending release, change the
+# 0 in the $string_compare_versions definition just below to a string
+# containing a SINGLE dotted Unicode release number (e.g. "2.1") corresponding
+# to the starting release. This program will then compile, but throw away all
+# code points introduced after the starting release. Finally use a diff tool
+# to compare the two directory structures. They 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 && ""; # e.g., "2.1";
my $compare_versions = DEBUG
&& $string_compare_versions
&& pack "C*", split /\./, $string_compare_versions;
$verbosity = 0;
}
elsif ($arg eq '-w') {
- $write_unchanged_files = 1; # update the files even if havent changed
+ # update the files even if they haven't changed
+ $write_unchanged_files = 1;
}
elsif ($arg eq '-check') {
my $this = shift @ARGV;
chomp $string_version;
my $v_version = pack "C*", split /\./, $string_version; # v string
+my $unicode_version = ($compare_versions)
+ ? ( "$string_compare_versions (using "
+ . "$string_version rules)")
+ : $string_version;
+
# The following are the complete names of properties with property values that
# are known to not match any code points in some versions of Unicode, but that
# may change in the future so they should be matchable, hence an empty file is
# existence is not noted in the comment.
'Decomposition_Mapping' => 'Accessible via Unicode::Normalize or prop_invmap() or charprop() in Unicode::UCD::',
- 'Indic_Matra_Category' => "Withdrawn by Unicode while still provisional",
-
# Don't suppress ISO_Comment, as otherwise special handling is needed
# to differentiate between it and gc=c, which can be written as 'isc',
# which is the same characters as ISO_Comment's short name.
Word_Break => 'Other',
);
-# Below are files that Unicode furnishes, but this program ignores, and why.
-# NormalizationCorrections.txt requires some more explanation. It documents
-# the cumulative fixes to erroneous normalizations in earlier Unicode
-# versions. Its main purpose is so that someone running on an earlier version
-# can use this file to override what got published in that earlier release.
-# It would be easy for mktables to read and handle this file. But all the
-# corrections in it should already be in the other files for the release it
-# is. To get it to actually mean something useful, someone would have to be
-# using an earlier Unicode release, and copy it to the files for that release
-# and recomplile. So far there has been no demand to do that, so this hasn't
-# been implemented.
-my %ignored_files = (
- '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',
- 'NamesList.html' => 'Describes the format and contents of F<NamesList.txt>',
- '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>',
- 'StandardizedVariants.html' => 'Provides a visual display of the standard variant sequences derived from F<StandardizedVariants.txt>.',
- 'EmojiSources.txt' => 'Maps certain Unicode code points to their legacy Japanese cell-phone values',
- 'USourceData.txt' => 'Documentation of status and cross reference of proposals for encoding by Unicode of Unihan characters',
- 'USourceGlyphs.pdf' => 'Pictures of the characters in F<USourceData.txt>',
- '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
my $HEADER=<<"EOF";
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by $0 from the Unicode
-# database, Version $string_version. Any changes made here will be lost!
+# database, Version $unicode_version. Any changes made here will be lost!
EOF
my $INTERNAL_ONLY_HEADER = <<"EOF";
my $MAX_UNICODE_CODEPOINT = hex $MAX_UNICODE_CODEPOINT_STRING;
my $MAX_UNICODE_CODEPOINTS = $MAX_UNICODE_CODEPOINT + 1;
-# We work with above-Unicode code points, up to UV_MAX. But when you get
-# that high, above IV_MAX, some operations don't work, and you can easily get
-# overflow. Therefore for internal use, we use a much smaller number,
-# translating it to UV_MAX only for output. The exact number is immaterial
-# (all Unicode code points are treated exactly the same), but the algorithm
-# requires it to be at least 2 * $MAX_UNICODE_CODEPOINTS + 1;
+# We work with above-Unicode code points, up to IV_MAX, but we may want to use
+# sentinels above that number. Therefore for internal use, we use a much
+# smaller number, translating it to IV_MAX only for output. The exact number
+# is immaterial (all Unicode code points are treated exactly the same), but
+# the algorithm requires it to be at least 2 * $MAX_UNICODE_CODEPOINTS + 1;
my $MAX_WORKING_CODEPOINTS= $MAX_UNICODE_CODEPOINT * 8;
my $MAX_WORKING_CODEPOINT = $MAX_WORKING_CODEPOINTS - 1;
my $MAX_WORKING_CODEPOINT_STRING = sprintf("%X", $MAX_WORKING_CODEPOINT);
-my $MAX_PLATFORM_CODEPOINT = ~0;
+my $MAX_PLATFORM_CODEPOINT = ~0 >> 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
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/;
-# This matches the beginning of the line in the Unicode db files that give the
+# This matches the beginning of the line in the Unicode DB files that give the
# defaults for code points not listed (i.e., missing) in the file. The code
# 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
# unlikely that they will ever change.
my %caseless_equivalent_to;
+# This is the range of characters that were in Release 1 of Unicode, and
+# removed in Release 2 (replaced with the current Hangul syllables starting at
+# U+AC00). The range was reused starting in Release 3 for other purposes.
+my $FIRST_REMOVED_HANGUL_SYLLABLE = 0x3400;
+my $FINAL_REMOVED_HANGUL_SYLLABLE = 0x4DFF;
+
# 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. The '_string' versions are so generated tables can retain the
my $needing_code_points_ending_in_code_point = 0;
my @backslash_X_tests; # List of tests read in for testing \X
+my @LB_tests; # List of tests read in for testing \b{lb}
my @SB_tests; # List of tests read in for testing \b{sb}
my @WB_tests; # List of tests read in for testing \b{wb}
my @unhandled_properties; # Will contain a list of properties found in
my %potential_files; # Generated list of all .txt files in the directory
# structure so we can warn if something is being
# ignored.
+my @missing_early_files; # Generated list of absent files that we need to
+ # proceed in compiling this early Unicode version
my @files_actually_output; # List of files we generated.
my @more_Names; # Some code point names are compound; this is used
# to store the extra components of them.
my $MAX_FLOATING_SLOP = 10 ** - $MIN_FRACTION_LENGTH; # And in floating terms
# These store references to certain commonly used property objects
+my $age;
my $ccc;
my $gc;
my $perl;
my $print;
my $All;
my $Assigned; # All assigned characters in this Unicode release
+my $DI; # Default_Ignorable_Code_Point property
+my $NChar; # Noncharacter_Code_Point property
my $script;
# Are there conflicting names because of beginning with 'In_', or 'Is_'
# after all the input has been processed. But most can be skipped, as they
# have the same descriptive phrases, such as being unassigned
my @viacode; # Contains the 1 million character names
+my @age; # And their ages ("" if none)
my @printable; # boolean: And are those characters printable?
my @annotate_char_type; # Contains a type of those characters, specifically
# for the purposes of annotation.
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
$viacode[$i] = $perl_charname->value_of($i) || "";
+ $age[$i] = (defined $age)
+ ? (($age->value_of($i) =~ / ^ \d+ \. \d+ $ /x)
+ ? $age->value_of($i)
+ : "")
+ : "";
# A character is generally printable if Unicode says it is,
# but below we make sure that most Unicode general category 'C' types
# aren't.
$printable[$i] = $print->contains($i);
+ # But the characters in this range were removed in v2.0 and replaced by
+ # different ones later. Modern fonts will be for the replacement
+ # characters, so suppress printing them.
+ if (($v_version lt v2.0
+ || ($compare_versions && $compare_versions lt v2.0))
+ && ( $i >= $FIRST_REMOVED_HANGUL_SYLLABLE
+ && $i <= $FINAL_REMOVED_HANGUL_SYLLABLE))
+ {
+ $printable[$i] = 0;
+ }
+
$annotate_char_type[$i] = $perl_charname->type_of($i) || 0;
# Only these two regular types are treated specially for annotations
# point of the range.
my $end;
if (! $viacode[$i]) {
- my $nonchar;
if ($i > $MAX_UNICODE_CODEPOINT) {
$viacode[$i] = 'Above-Unicode';
$annotate_char_type[$i] = $ABOVE_UNICODE_TYPE;
$printable[$i] = 0;
$end = $gc->table('Private_Use')->containing_range($i)->end;
}
- elsif ((defined ($nonchar =
- Property::property_ref('Noncharacter_Code_Point'))
- && $nonchar->table('Y')->contains($i)))
- {
+ elsif ($NChar->contains($i)) {
$viacode[$i] = 'Noncharacter';
$annotate_char_type[$i] = $NONCHARACTER_TYPE;
$printable[$i] = 0;
- $end = property_ref('Noncharacter_Code_Point')->table('Y')->
- containing_range($i)->end;
+ $end = $NChar->containing_range($i)->end;
}
elsif ($gc-> table('Control')->contains($i)) {
- $viacode[$i] = property_ref('Name_Alias')->value_of($i) || 'Control';
+ my $name_ref = property_ref('Name_Alias');
+ $name_ref = property_ref('Unicode_1_Name') if ! defined $name_ref;
+ $viacode[$i] = (defined $name_ref)
+ ? $name_ref->value_of($i)
+ : 'Control';
$annotate_char_type[$i] = $CONTROL_TYPE;
$printable[$i] = 0;
}
elsif ($gc-> table('Unassigned')->contains($i)) {
$annotate_char_type[$i] = $UNASSIGNED_TYPE;
$printable[$i] = 0;
- if ($v_version lt v2.0.0) { # No blocks in earliest releases
- $viacode[$i] = 'Unassigned';
+ $viacode[$i] = 'Unassigned';
+
+ if (defined $block) { # No blocks in earliest releases
+ $viacode[$i] .= ', block=' . $block-> value_of($i);
$end = $gc-> table('Unassigned')->containing_range($i)->end;
- }
- else {
- $viacode[$i] = 'Unassigned, block=' . $block-> value_of($i);
# Because we name the unassigned by the blocks they are in, it
# can't go past the end of that block, and it also can't go
$unassigned_sans_noncharacters->
containing_range($i)->end);
}
+ else {
+ $end = $i + 1;
+ while ($unassigned_sans_noncharacters->contains($end)) {
+ $end++;
+ }
+ $end--;
+ }
}
elsif ($perl->table('_Perl_Surrogate')->contains($i)) {
$viacode[$i] = 'Surrogate';
# appended to the name, do that.
elsif ($annotate_char_type[$i] == $CP_IN_NAME) {
$viacode[$i] .= sprintf("-%04X", $i);
- $end = $perl_charname->containing_range($i)->end;
+
+ my $limit = $perl_charname->containing_range($i)->end;
+ if (defined $age) {
+ # Do all these as groups of the same age, instead of individually,
+ # because their names are so meaningless, and there are typically
+ # large quantities of them.
+ $end = $i + 1;
+ while ($end <= $limit && $age->value_of($end) == $age[$i]) {
+ $end++;
+ }
+ $end--;
+ }
+ else {
+ $end = $limit;
+ }
}
# And here, has a name, but if it's a hangul syllable one, replace it with
# 1) call before the first line is read, for pre processing
# 2) call to adjust each line of the input before the main handler gets
# them. This can be automatically generated, if appropriately simple
-# enough, by specifiying a Properties parameter in the constructor.
+# enough, by specifying a Properties parameter in the constructor.
# 3) call upon EOF before the main handler exits its loop
# 4) call at the end, for post processing
#
# each_line_handler()s. So, if the format of the line is not in the desired
# format for the main handler, these are used to do that adjusting. They can
# be stacked (by enclosing them in an [ anonymous array ] in the constructor,
-# so the $_ output of one is used as the input to the next. The eof handler
+# so the $_ output of one is used as the input to the next. The EOF handler
# is also stackable, but none of the others are, but could easily be changed
# to be so.
#
+# Some properties are used by the Perl core but aren't defined until later
+# Unicode releases. The perl interpreter would have problems working when
+# compiled with an earlier Unicode version that doesn't have them, so we need
+# to define them somehow for those releases. The 'Early' constructor
+# parameter can be used to automatically handle this. It is essentially
+# ignored if the Unicode version being compiled has a data file for this
+# property. Either code to execute or a file to read can be specified.
+# Details are at the %early definition.
+#
# Most of the handlers can call insert_lines() or insert_adjusted_lines()
# which insert the parameters as lines to be processed before the next input
# file line is read. This allows the EOF handler(s) to flush buffers, for
# not otherwise be processed, and to not raise a warning about not being
# handled. In the constructor call, any value that evaluates to a numeric
# 0 or undef means don't skip. Any other value is a string giving the
- # reason it is being skippped, and this will appear in generated pod.
+ # reason it is being skipped, and this will appear in generated pod.
# However, an empty string reason will suppress the pod entry.
# Internally, calls that evaluate to numeric 0 are changed into undef to
# distinguish them from an empty string call.
# 'handler'
main::set_access('each_line_handler', \%each_line_handler, 'c');
+ my %retain_trailing_comments;
+ # This is used to not discard the comments that end data lines. This
+ # would be used only for files with non-typical syntax, and most code here
+ # assumes that comments have been stripped, so special handlers would have
+ # to be written. It is assumed that the code will use these in
+ # single-quoted contexts, and so any "'" marks in the comment will be
+ # prefixed by a backslash.
+ main::set_access('retain_trailing_comments', \%retain_trailing_comments, 'c');
+
my %properties; # Optional ordered list of the properties that occur in each
# meaningful line of the input file. If present, an appropriate
# each_line_handler() is automatically generated and pushed onto the stack
# of such handlers. This is useful when a file contains multiple
- # proerties per line, but no other special considerations are necessary.
+ # properties per line, but no other special considerations are necessary.
# The special value "<ignored>" means to discard the corresponding input
# field.
# Any @missing lines in the file should also match this syntax; no such
# storage of '@missing' defaults lines
main::set_access('missings', \%missings);
+ my %early;
+ # Used for properties that must be defined (for Perl's purposes) on
+ # versions of Unicode earlier than Unicode itself defines them. The
+ # parameter is an array (it would be better to be a hash, but not worth
+ # bothering about due to its rare use).
+ #
+ # The first element is either a code reference to call when in a release
+ # earlier than the Unicode file is available in, or it is an alternate
+ # file to use instead of the non-existent one. This file must have been
+ # plunked down in the same directory as mktables. Should you be compiling
+ # on a release that needs such a file, mktables will abort the
+ # compilation, and tell you where to get the necessary file(s), and what
+ # name(s) to use to store them as.
+ # In the case of specifying an alternate file, the array must contain two
+ # further elements:
+ #
+ # [1] is the name of the property that will be generated by this file.
+ # The class automatically takes the input file and excludes any code
+ # points in it that were not assigned in the Unicode version being
+ # compiled. It then uses this result to define the property in the given
+ # version. Since the property doesn't actually exist in the Unicode
+ # version being compiled, this should be a name accessible only by core
+ # perl. If it is the same name as the regular property, the constructor
+ # will mark the output table as a $PLACEHOLDER so that it doesn't actually
+ # get output, and so will be unusable by non-core code. Otherwise it gets
+ # marked as $INTERNAL_ONLY.
+ #
+ # [2] is a property value to assign (only when compiling Unicode 1.1.5) to
+ # the Hangul syllables in that release (which were ripped out in version
+ # 2) for the given property . (Hence it is ignored except when compiling
+ # version 1. You only get one value that applies to all of them, which
+ # may not be the actual reality, but probably nobody cares anyway for
+ # these obsolete characters.)
+ #
+ # [3] if present is the default value for the property to assign for code
+ # points not given in the input. If not present, the default from the
+ # normal property is used
+ #
+ # [-1] If there is an extra final element that is the string 'ONLY_EARLY'.
+ # it means to not add the name in [1] as an alias to the property name
+ # used for these. Normally, when compiling Unicode versions that don't
+ # invoke the early handling, the name is added as a synonym.
+ #
+ # Not all files can be handled in the above way, and so the code ref
+ # alternative is available. It can do whatever it needs to. The other
+ # array elements are optional in this case, and the code is free to use or
+ # ignore them if they are present.
+ #
+ # Internally, the constructor unshifts a 0 or 1 onto this array to
+ # indicate if an early alternative is actually being used or not. This
+ # makes for easier testing later on.
+ main::set_access('early', \%early, 'c');
+
+ my %only_early;
+ main::set_access('only_early', \%only_early, 'c');
+
my %required_even_in_debug_skip;
# debug_skip is used to speed up compilation during debugging by skipping
# processing files that are not needed for the task at hand. However,
# Set defaults
$handler{$addr} = \&main::process_generic_property_file;
+ $retain_trailing_comments{$addr} = 0;
$non_skip{$addr} = 0;
$skip{$addr} = undef;
$has_missings_defaults{$addr} = $NO_DEFAULTS;
$eof_handler{$addr} = [ ];
$errors{$addr} = { };
$missings{$addr} = [ ];
+ $early{$addr} = [ ];
$optional{$addr} = [ ];
# Two positional parameters.
}
my $progress;
+ my $function_instead_of_file = 0;
+
+ if ($early{$addr}->@* && $early{$addr}[-1] eq 'ONLY_EARLY') {
+ $only_early{$addr} = 1;
+ pop $early{$addr}->@*;
+ }
+
+ # If we are compiling a Unicode release earlier than the file became
+ # available, the constructor may have supplied a substitute
+ if ($first_released{$addr} gt $v_version && $early{$addr}->@*) {
+
+ # Yes, we have a substitute, that we will use; mark it so
+ unshift $early{$addr}->@*, 1;
+
+ # See the definition of %early for what the array elements mean.
+ # Note that we have just unshifted onto the array, so the numbers
+ # below are +1 of those in the %early description.
+ # If we have a property this defines, create a table and default
+ # map for it now (at essentially compile time), so that it will be
+ # available for the whole of run time. (We will want to add this
+ # name as an alias when we are using the official property name;
+ # but this must be deferred until run(), because at construction
+ # time the official names have yet to be defined.)
+ if ($early{$addr}[2]) {
+ my $fate = ($property{$addr}
+ && $property{$addr} eq $early{$addr}[2])
+ ? $PLACEHOLDER
+ : $INTERNAL_ONLY;
+ my $prop_object = Property->new($early{$addr}[2],
+ Fate => $fate,
+ Perl_Extension => 1,
+ );
+
+ # If not specified by the constructor, use the default mapping
+ # for the regular property for this substitute one.
+ if ($early{$addr}[4]) {
+ $prop_object->set_default_map($early{$addr}[4]);
+ }
+ elsif ( defined $property{$addr}
+ && defined $default_mapping{$property{$addr}})
+ {
+ $prop_object
+ ->set_default_map($default_mapping{$property{$addr}});
+ }
+ }
+
+ if (ref $early{$addr}[1] eq 'CODE') {
+ $function_instead_of_file = 1;
+
+ # If the first element of the array is a code ref, the others
+ # are optional.
+ $handler{$addr} = $early{$addr}[1];
+ $property{$addr} = $early{$addr}[2]
+ if defined $early{$addr}[2];
+ $progress = "substitute $file{$addr}";
+
+ undef $file{$addr};
+ }
+ else { # Specifying a substitute file
+
+ if (! main::file_exists($early{$addr}[1])) {
+
+ # If we don't see the substitute file, generate an error
+ # message giving the needed things, and add it to the list
+ # of such to output before actual processing happens
+ # (hence the user finds out all of them in one run).
+ # Instead of creating a general method for NameAliases,
+ # hard-code it here, as there is unlikely to ever be a
+ # second one which needs special handling.
+ my $string_version = ($file{$addr} eq "NameAliases.txt")
+ ? 'at least 6.1 (the later, the better)'
+ : sprintf "%vd", $first_released{$addr};
+ push @missing_early_files, <<END;
+'$file{$addr}' version $string_version should be copied to '$early{$addr}[1]'.
+END
+ ;
+ return;
+ }
+ $progress = $early{$addr}[1];
+ $progress .= ", substituting for $file{$addr}" if $file{$addr};
+ $file{$addr} = $early{$addr}[1];
+ $property{$addr} = $early{$addr}[2];
- if ($first_released{$addr} le $v_version) {
+ # Ignore code points not in the version being compiled
+ push $each_line_handler{$addr}->@*, \&_exclude_unassigned;
+
+ if ( $v_version lt v2.0 # Hanguls in this release ...
+ && defined $early{$addr}[3]) # ... need special treatment
+ {
+ push $eof_handler{$addr}->@*, \&_fixup_obsolete_hanguls;
+ }
+ }
+
+ # And this substitute is valid for all releases.
+ $first_released{$addr} = v0;
+ }
+ else { # Normal behavior
$progress = $file{$addr};
+ unshift $early{$addr}->@*, 0; # No substitute
}
my $file = $file{$addr};
else {
$in_this_release{$addr} = $first_released{$addr} le $v_version;
- # Check that the file for this object exists
- if (! main::file_exists($file))
+ # Check that the file for this object (possibly using a substitute
+ # for early releases) exists or we have a function alternative
+ if ( ! $function_instead_of_file
+ && ! main::file_exists($file))
{
# Here there is nothing available for this release. This is
# fine if we aren't expecting anything in this release.
# once per file, as it destroy's the EOF handlers
# flag to make sure extracted files are processed early
- state $seen_non_extracted_non_age = 0;
+ state $seen_non_extracted = 0;
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
$handle{$addr} = 'pretend_is_open';
}
else {
- if ($seen_non_extracted_non_age) {
+ if ($seen_non_extracted) {
if ($file =~ /$EXTRACTED/i) # Some platforms may change the
# case of the file's name
{
# We only do this check for generic property files
&& $handler{$addr} == \&main::process_generic_property_file
- && $file !~ /$EXTRACTED/i
- && lc($file) ne 'dage.txt')
+ && $file !~ /$EXTRACTED/i)
{
# We don't set this (by the 'if' above) if we have no
# extracted directory, so if running on an early version,
# this test won't work. Not worth worrying about.
- $seen_non_extracted_non_age = 1;
+ $seen_non_extracted = 1;
}
# Mark the file as having being processed, and warn if it
Carp::my_carp("Was not expecting '$file'.")
if $exists && ! $in_this_release{$addr};
+ # If there is special handling for compiling Unicode releases
+ # earlier than the first one in which Unicode defines this
+ # property ...
+ if ($early{$addr}->@* > 1) {
+
+ # Mark as processed any substitute file that would be used in
+ # such a release
+ $fkey = File::Spec->rel2abs($early{$addr}[1]);
+ delete $potential_files{lc($fkey)};
+
+ # As commented in the constructor code, when using the
+ # official property, we still have to allow the publicly
+ # inaccessible early name so that the core code which uses it
+ # will work regardless.
+ if ( ! $only_early{$addr}
+ && ! $early{$addr}[0]
+ && $early{$addr}->@* > 2)
+ {
+ my $early_property_name = $early{$addr}[2];
+ if ($property{$addr} ne $early_property_name) {
+ main::property_ref($property{$addr})
+ ->add_alias($early_property_name);
+ }
+ }
+ }
+
# We may be skipping this file ...
if (defined $skip{$addr}) {
# substitute file instead of the official one (though the code
# could be extended to do so).
if ($in_this_release{$addr}
+ && ! $early{$addr}[0]
&& lc($file) ne 'unicodedata.txt')
{
if ($file !~ /^Unihan/i) {
next;
}
- # Remove comments and trailing space, and skip this line if the
- # result is empty
- s/#.*//;
+ # Unless to keep, remove comments. If to keep, ignore
+ # comment-only lines
+ if ($retain_trailing_comments{$addr}) {
+ next if / ^ \s* \# /x;
+
+ # But escape any single quotes (done in both the comment and
+ # non-comment portion; this could be a bug someday, but not
+ # likely)
+ s/'/\\'/g;
+ }
+ else {
+ s/#.*//;
+ }
+
+ # Remove trailing space, and skip this line if the result is empty
s/\s+$//;
next if /^$/;
# Not currently used, not fully tested.
# sub peek {
-# # Non-destructive look-ahead one non-adjusted, non-comment, non-blank
+# # Non-destructive lookahead one non-adjusted, non-comment, non-blank
# # record. Not callable from an each_line_handler(), nor does it call
# # an each_line_handler() on the line.
#
return @return;
}
+ sub _exclude_unassigned {
+
+ # Takes the range in $_ and excludes code points that aren't assigned
+ # in this release
+
+ state $skip_inserted_count = 0;
+
+ # Ignore recursive calls.
+ if ($skip_inserted_count) {
+ $skip_inserted_count--;
+ return;
+ }
+
+ # Find what code points are assigned in this release
+ main::calculate_Assigned() if ! defined $Assigned;
+
+ my $self = shift;
+ my $addr = do { no overloading; pack 'J', $self; };
+ Carp::carp_extra_args(\@_) if main::DEBUG && @_;
+
+ my ($range, @remainder)
+ = split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields
+
+ # Examine the range.
+ if ($range =~ /^ ($code_point_re) (?:\.\. ($code_point_re) )? $/x)
+ {
+ my $low = hex $1;
+ my $high = (defined $2) ? hex $2 : $low;
+
+ # Split the range into subranges of just those code points in it
+ # that are assigned.
+ my @ranges = (Range_List->new(Initialize
+ => Range->new($low, $high)) & $Assigned)->ranges;
+
+ # Do nothing if nothing in the original range is assigned in this
+ # release; handle normally if everything is in this release.
+ if (! @ranges) {
+ $_ = "";
+ }
+ elsif (@ranges != 1) {
+
+ # Here, some code points in the original range aren't in this
+ # release; @ranges gives the ones that are. Create fake input
+ # lines for each of the ranges, and set things up so that when
+ # this routine is called on that fake input, it will do
+ # nothing.
+ $skip_inserted_count = @ranges;
+ my $remainder = join ";", @remainder;
+ for my $range (@ranges) {
+ $self->insert_lines(sprintf("%04X..%04X;%s",
+ $range->start, $range->end, $remainder));
+ }
+ $_ = ""; # The original range is now defunct.
+ }
+ }
+
+ return;
+ }
+
+ sub _fixup_obsolete_hanguls {
+
+ # This is called only when compiling Unicode version 1. All Unicode
+ # data for subsequent releases assumes that the code points that were
+ # Hangul syllables in this release only are something else, so if
+ # using such data, we have to override it
+
+ my $self = shift;
+ my $addr = do { no overloading; pack 'J', $self; };
+ Carp::carp_extra_args(\@_) if main::DEBUG && @_;
+
+ my $object = main::property_ref($property{$addr});
+ $object->add_map($FIRST_REMOVED_HANGUL_SYLLABLE,
+ $FINAL_REMOVED_HANGUL_SYLLABLE,
+ $early{$addr}[3], # Passed-in value for these
+ Replace => $UNCONDITIONALLY);
+ }
+
sub _insert_property_into_line {
# Add a property field to $_, if this file requires it.
# .
# .
# 'U'));
+ # It is best to leave the final value be the one that matches the
+ # above-Unicode code points.
my $class = shift;
return $self->_add_delete('+', @_);
}
+ sub replace_map {
+ # Replace a range
+
+ my $self = shift;
+
+ return $self->_add_delete('+', @_, Replace => $UNCONDITIONALLY);
+ }
+
sub add_duplicate {
# Adds entry to a range list which can duplicate an existing entry
# used to override calculations.
main::set_access('format', \%format, 'r', 'p_s');
+ my %has_dependency;
+ # A boolean that gives whether some other table in this property is
+ # defined as the complement of this table. This is a crude, but currently
+ # sufficient, mechanism to make this table not get destroyed before what
+ # is dependent on it is. Other dependencies could be added, so the name
+ # was chosen to reflect a more general situation than actually is
+ # currently the case.
+ main::set_access('has_dependency', \%has_dependency, 'r', 's');
+
sub new {
# All arguments are key => value pairs, which you can see below, most
# of which match fields documented above. Otherwise: Re_Pod_Entry,
$note{$addr} = [ ];
$file_path{$addr} = [ ];
$locked{$addr} = "";
+ $has_dependency{$addr} = 0;
push @{$description{$addr}}, $description if $description;
push @{$note{$addr}}, $note if $note;
}
# Look at each alias
+ my $is_last_resort = 0;
+ my $deprecated_or_discouraged
+ = qr/ ^ (?: $DEPRECATED | $DISCOURAGED ) $/x;
foreach my $alias ($self->aliases()) {
# Don't use an alias that isn't ok to use for an external name.
my $name = main::Standardize($alias->name);
trace $self, $name if main::DEBUG && $to_trace;
- # Take the first one, or a shorter one that isn't numeric. This
+ # Take the first one, or any non-deprecated non-discouraged one
+ # over one that is, or a shorter one that isn't numeric. This
# relies on numeric aliases always being last in the array
# returned by aliases(). Any alpha one will have precedence.
- if (! defined $short_name{$addr}
+ if ( ! defined $short_name{$addr}
+ || ( $is_last_resort
+ && $alias->status !~ $deprecated_or_discouraged)
|| ($name =~ /\D/
&& length($name) < length($short_name{$addr})))
{
($short_name{$addr} = $name) =~ s/ (?<= . ) _ (?= . ) //xg;
$nominal_short_name_length{$addr} = length $name;
+ $is_last_resort = $alias->status =~ $deprecated_or_discouraged;
}
}
# 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 "_")
+ if ( $self->can('children')
+ && ( ! defined $short_name{$addr}
+ || $short_name{$addr} eq ""
+ || $short_name{$addr} eq "_"))
{
my $return;
foreach my $follower ($self->children) { # All equivalents
}
if ($write_as_invlist) {
+ if ( $previous_end > 0
+ && $output_range_counts{$addr})
+ {
+ my $complement_count = $start - $previous_end - 1;
+ if ($complement_count > 1) {
+ $OUT[-1] = merge_single_annotation_line(
+ $OUT[-1],
+ "#"
+ . (" " x 17)
+ . "["
+ . main::clarify_code_point_count(
+ $complement_count)
+ . "] in complement\n",
+ $comment_indent);
+ }
+ }
# Inversion list format has a single number per line,
# the starting code point of a range that matches the
$range_name = "Hangul Syllable";
}
- if ($i != $start || $range_end < $end) {
+ # If the annotation would just repeat what's
+ # already being output as the range, skip it.
+ # (When an inversion list is being written, it
+ # isn't a repeat, as that always is in
+ # decimal)
+ if ( $write_as_invlist
+ || $i != $start
+ || $range_end < $end)
+ {
if ($range_end < $MAX_WORKING_CODEPOINT)
{
$annotation = sprintf "%04X..%04X",
else { # Indent if not displaying code points
$annotation = " " x 4;
}
- $annotation .= " $range_name" if $range_name;
+
+ if ($range_name) {
+ $annotation .= " $age[$i]" if $age[$i];
+ $annotation .= " $range_name";
+ }
# Include the number of code points in the
# range
}
if ($include_cp) {
- $annotation = sprintf "%04X", $i;
+ $annotation = sprintf "%04X %s", $i, $age[$i];
if ($use_adjustments) {
$annotation .= " => $output_value";
}
sub set_default_map {
# Define what code points that are missing from the input files should
- # map to
+ # map to. The optional second parameter 'full_name' indicates to
+ # force using the full name of the map instead of its standard name.
my $self = shift;
my $map = shift;
+ my $use_full_name = shift // 0;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
+ if ($use_full_name && $use_full_name ne 'full_name') {
+ Carp::my_carp_bug("Second parameter to set_default_map() if"
+ . " present, must be 'full_name'");
+ }
+
my $addr = do { no overloading; pack 'J', $self; };
# Convert the input to the standard equivalent, if any (won't have any
# for $STRING properties)
- my $standard = $self->_find_table_from_alias->{$map};
- $map = $standard->name if defined $standard;
+ my $standard = $self->property->table($map);
+ if (defined $standard) {
+ $map = ($use_full_name)
+ ? $standard->full_name
+ : $standard->name;
+ }
# Warn if there already is a non-equivalent default map for this
# property. Note that a default map can be a ref, which means that
else {
$cp = "one of the $code_points";
}
- $cp .= " in Unicode Version $string_version for which the mapping is not to $map_to";
+ $cp .= " in Unicode Version $unicode_version for which the mapping is not to $map_to";
}
my $comment = "";
# Accessors for the underlying list that should fail if locked.
for my $sub (qw(
add_duplicate
+ replace_map
))
{
no strict "refs";
# 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;
+ my $complement = $self->complement;
+
+ # In order to avoid re-complementing on each access, only do the
+ # complement the first time, and store the result in this table's
+ # range list to use henceforth. However, this wouldn't work if the
+ # controlling (complement) table changed after we do this, so lock it.
+ # Currently, the value of the complement isn't needed until after it
+ # is fully constructed, so this works. If this were to change, the
+ # each_range iteration functionality would no longer work on this
+ # complement.
+ if ($complement != 0 && $self->SUPER::_range_list->count == 0) {
+ $self->_set_range_list($self->SUPER::_range_list
+ + ~ $complement->_range_list);
+ $complement->lock;
}
+
+ return $self->SUPER::_range_list;
}
sub add_alias {
}
my $addr = do { no overloading; pack 'J', $self; };
$complement{$addr} = $other;
+
+ # Be sure the other property knows we are depending on them; or the
+ # other table if it is one in the current property.
+ if ($self->property != $other->property) {
+ $other->property->set_has_dependency(1);
+ }
+ else {
+ $other->set_has_dependency(1);
+ }
$self->lock;
return;
}
version of Unicode uses this file. Each one is listed in a separate group
below. It could be that the tables will match the same set of code points in
other Unicode releases, or it could be purely coincidence that they happen to
-be the same in Unicode $string_version, and hence may not in other versions.
+be the same in Unicode $unicode_version, and hence may not in other versions.
END
}
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
+$unicode_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
+$unicode_version that
$match$synonyms:
$matches_comment
main::set_access('pre_declared_maps',
\%pre_declared_maps, 'r', 's');
+ my %has_dependency;
+ # A boolean that gives whether some table somewhere is defined as the
+ # complement of a table in this property. This is a crude, but currently
+ # sufficient, mechanism to make this property not get destroyed before
+ # what is dependent on it is. Other dependencies could be added, so the
+ # name was chosen to reflect a more general situation than actually is
+ # currently the case.
+ main::set_access('has_dependency', \%has_dependency, 'r', 's');
+
sub new {
# The only required parameter is the positionally first, name. All
# other parameters are key => value pairs. See the documentation just
$has_only_code_point_maps{$addr} = 1;
$table_ref{$addr} = { };
$unique_maps{$addr} = { };
+ $has_dependency{$addr} = 0;
$map{$addr} = Map_Table->new($name,
Full_Name => $full_name{$addr},
range_count
ranges
range_size_1
+ replace_map
reset_each_range
set_comment
set_default_map
return ! _operator_equal($self, $other);
}
+sub substitute_PropertyAliases($) {
+ # Deal with early releases that don't have the crucial PropertyAliases.txt
+ # file.
+
+ my $file_object = shift;
+ $file_object->insert_lines(get_old_property_aliases());
+
+ process_PropertyAliases($file_object);
+}
+
+
sub process_PropertyAliases($) {
# This reads in the PropertyAliases.txt file, which contains almost all
# the character properties in Unicode and their equivalent aliases:
my $file= shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- # This whole file was non-existent in early releases, so use our own
- # internal one.
- $file->insert_lines(get_old_property_aliases())
- if ! -e 'PropertyAliases.txt';
-
# Add any cjk properties that may have been defined.
$file->insert_lines(@cjk_properties);
# This line is defective in early Perls. The property in Unihan.txt
# is kRSUnicode.
- if ($v_version lt v5.2.0 && $full eq 'Unicode_Radical_Stroke') {
+ if ($full eq 'Unicode_Radical_Stroke' && @data < 3) {
push @data, qw(cjkRSUnicode kRSUnicode);
}
Property->new('JSN', Full_Name => 'Jamo_Short_Name');
}
- # These two properties must be defined in all releases so we can generate
- # the tables from them to make regex \X work, but suppress their output so
- # aren't application visible prior to releases where they should be
- if (! defined property_ref('GCB')) {
- Property->new('GCB', Full_Name => 'Grapheme_Cluster_Break',
- Fate => $PLACEHOLDER);
- }
- if (! defined property_ref('hst')) {
- Property->new('hst', Full_Name => 'Hangul_Syllable_Type',
- Fate => $PLACEHOLDER);
- }
-
# These are used so much, that we set globals for them.
$gc = property_ref('General_Category');
$block = property_ref('Block');
$script = property_ref('Script');
+ $age = property_ref('Age');
# Perl adds this alias.
$gc->add_alias('Category');
# for non-assigned code points; 'AL' for assigned.
if (file_exists("${EXTRACTED}DLineBreak.txt") || -e 'LineBreak.txt') {
my $lb = property_ref('Line_Break');
- if ($v_version gt 3.2.0) {
+ if (file_exists("${EXTRACTED}DLineBreak.txt")) {
$lb->set_default_map('Unknown');
}
else {
- my $default = Multi_Default->new( 'Unknown' => '$gc->table("Cn")',
- 'AL');
+ my $default = Multi_Default->new('AL' => '~ $gc->table("Cn")',
+ 'Unknown',
+ );
$lb->set_default_map($default);
}
}
return @return;
}
+sub substitute_PropValueAliases($) {
+ # Deal with early releases that don't have the crucial
+ # PropValueAliases.txt file.
+
+ my $file_object = shift;
+ $file_object->insert_lines(get_old_property_value_aliases());
+
+ process_PropValueAliases($file_object);
+}
+
sub process_PropValueAliases {
# This file contains values that properties look like:
# bc ; AL ; Arabic_Letter
my $file= shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- # This whole file was non-existent in early releases, so use our own
- # internal one if necessary.
- if (! -e 'PropValueAliases.txt') {
- $file->insert_lines(get_old_property_value_aliases());
- }
-
if ($v_version lt 4.0.0) {
$file->insert_lines(split /\n/, <<'END'
-hst; L ; Leading_Jamo
-hst; LV ; LV_Syllable
-hst; LVT ; LVT_Syllable
-hst; NA ; Not_Applicable
-hst; T ; Trailing_Jamo
-hst; V ; Vowel_Jamo
+Hangul_Syllable_Type; L ; Leading_Jamo
+Hangul_Syllable_Type; LV ; LV_Syllable
+Hangul_Syllable_Type; LVT ; LVT_Syllable
+Hangul_Syllable_Type; NA ; Not_Applicable
+Hangul_Syllable_Type; T ; Trailing_Jamo
+Hangul_Syllable_Type; V ; Vowel_Jamo
END
);
}
if ($v_version lt 4.1.0) {
$file->insert_lines(split /\n/, <<'END'
-GCB; CN ; Control
-GCB; CR ; CR
-GCB; EX ; Extend
-GCB; L ; L
-GCB; LF ; LF
-GCB; LV ; LV
-GCB; LVT ; LVT
-GCB; T ; T
-GCB; V ; V
-GCB; XX ; Other
+_Perl_GCB; CN ; Control
+_Perl_GCB; CR ; CR
+_Perl_GCB; EX ; Extend
+_Perl_GCB; L ; L
+_Perl_GCB; LF ; LF
+_Perl_GCB; LV ; LV
+_Perl_GCB; LVT ; LVT
+_Perl_GCB; T ; T
+_Perl_GCB; V ; V
+_Perl_GCB; XX ; Other
END
);
}
# As noted in the comments early in the program, it generates tables for
# the default values for all releases, even those for which the concept
# didn't exist at the time. Here we add those if missing.
- my $age = property_ref('age');
if (defined $age && ! defined $age->table('Unassigned')) {
$age->add_match_table('Unassigned');
}
END
}
- if (-e 'LineBreak.txt') {
- push @return, split /\n/, <<'END';
+ if (-e 'LineBreak.txt' || -e 'LBsubst.txt') {
+ my @lb = split /\n/, <<'END';
lb ; AI ; Ambiguous
lb ; AL ; Alphabetic
lb ; B2 ; Break_Both
lb ; XX ; Unknown
lb ; ZW ; ZWSpace
END
+ # If this Unicode version predates the lb property, we use our
+ # substitute one
+ if (-e 'LBsubst.txt') {
+ $_ = s/^lb/_Perl_LB/r for @lb;
+ }
+ push @return, @lb;
}
if (-e 'DNormalizationProps.txt') {
}
{ # Closure
- # This is used to store the range list of all the code points usable when
- # 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 $low = hex $1;
my $high = (defined $2) ? hex $2 : $low;
- # For the very specialized case of comparing two Unicode
- # versions...
- if (DEBUG && $compare_versions) {
- if ($property_name eq 'Age') {
-
- # Only allow code points at least as old as the version
- # specified.
- my $age = pack "C*", split(/\./, $map); # v string
- next LINE if $age gt $compare_versions;
- }
- else {
-
- # Again, we throw out code points younger than those of
- # the specified version. By now, the Age property is
- # populated. We use the intersection of each input range
- # with this property to find what code points in it are
- # valid. To do the intersection, we have to convert the
- # Age property map to a Range_list. We only have to do
- # this once.
- if (! defined $compare_versions_range_list) {
- my $age = property_ref('Age');
- if (! -e 'DAge.txt') {
- croak "Need to have 'DAge.txt' file to do version comparison";
- }
- elsif ($age->count == 0) {
- croak "The 'Age' table is empty, but its file exists";
- }
- $compare_versions_range_list
- = Range_List->new(Initialize => $age);
- }
-
- # An undefined map is always 'Y'
- $map = 'Y' if ! defined $map;
-
- # Calculate the intersection of the input range with the
- # code points that are known in the specified version
- my @ranges = ($compare_versions_range_list
- & Range->new($low, $high))->ranges;
-
- # If the intersection is empty, throw away this range
- next LINE unless @ranges;
-
- # Only examine the first range this time through the loop.
- my $this_range = shift @ranges;
-
- # Put any remaining ranges in the queue to be processed
- # later. Note that there is unnecessary work here, as we
- # will do the intersection again for each of these ranges
- # during some future iteration of the LINE loop, but this
- # code is not used in production. The later intersections
- # are guaranteed to not splinter, so this will not become
- # an infinite loop.
- my $line = join ';', $property_name, $map;
- foreach my $range (@ranges) {
- $file->insert_adjusted_lines(sprintf("%04X..%04X; %s",
- $range->start,
- $range->end,
- $line));
- }
-
- # And set things up so that the below will process this first
- # range, like any other.
- $low = $this_range->start;
- $high = $this_range->end;
- }
- } # End of $compare_versions
-
# If changing to a new property, get the things constant per
# property
if ($previous_property_name ne $property_name) {
my $file = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- # Create a new property specially located that is a combination of the
+ # Create a new property specially located that is a combination of
# various Name properties: Name, Unicode_1_Name, Named Sequences, and
- # Name_Alias properties. (The final duplicates elements of the
- # first.) A comment for it will later be constructed based on the
- # actual properties present and used
+ # _Perl_Name_Alias properties. (The final one duplicates elements of the
+ # first, and starting in v6.1, is the same as the 'Name_Alias
+ # property.) A comment for the new property will later be constructed
+ # based on the actual properties present and used
$perl_charname = Property->new('Perl_Charnames',
Default_Map => "",
Directory => File::Spec->curdir(),
. $CMD_DELIM
. $fields[$CHARNAME];
}
- elsif ($fields[$CHARNAME] =~ /^CJK/) {
+ elsif ($fields[$CATEGORY] eq 'Lo') { # Is a letter
+
+ # All the CJK ranges like this have the name given as a
+ # special case in the next code line. And for the others, we
+ # hope that Unicode continues to use the correct name in
+ # future releases, so we don't have to make further special
+ # cases.
+ my $name = ($fields[$CHARNAME] =~ /^CJK/)
+ ? 'CJK UNIFIED IDEOGRAPH'
+ : uc $fields[$CHARNAME];
# The name for these contains the code point itself, and all
# are defined to have the same base name, regardless of what
. '='
. $CP_IN_NAME
. $CMD_DELIM
- . 'CJK UNIFIED IDEOGRAPH';
+ . $name;
}
elsif ($fields[$CATEGORY] eq 'Co'
return;
}
+sub process_LB_test {
+
+ my $file = shift;
+ Carp::carp_extra_args(\@_) if main::DEBUG && @_;
+
+ while ($file->next_line) {
+ push @LB_tests, $_;
+ }
+
+ return;
+}
+
sub process_SB_test {
my $file = shift;
}
}
+sub filter_substitute_lb {
+ # Used on Unicodes that predate the LB property, where there is a
+ # substitute file. This just does the regular ea_lb handling for such
+ # files, and then substitutes the long property value name for the short
+ # one that comes with the file. (The other break files have the long
+ # names in them, so this is the odd one out.) The reason for doing this
+ # kludge is that regen/mk_invlists.pl is expecting the long name. This
+ # also fixes the typo 'Inseperable' that leads to problems.
+
+ filter_early_ea_lb;
+ return unless $_;
+
+ my @fields = split /\s*;\s*/;
+ $fields[1] = property_ref('_Perl_LB')->table($fields[1])->full_name;
+ $fields[1] = 'Inseparable' if lc $fields[1] eq 'inseperable';
+ $_ = join '; ', @fields;
+}
+
sub filter_old_style_arabic_shaping {
# Early versions used a different term for the later one.
# not being right at all.
if ($v_version lt v2.0.0) {
my $property = property_ref($file->property);
- $file->insert_lines("3400..4DFF; LVT\n");
+ $file->insert_lines(sprintf("%04X..%04X; LVT\n",
+ $FIRST_REMOVED_HANGUL_SYLLABLE,
+ $FINAL_REMOVED_HANGUL_SYLLABLE));
push @tables_that_may_be_empty, $property->table('LV')->complete_name;
return;
}
generate_hst($file);
}
- return;
+ main::process_generic_property_file($file);
}
-sub setup_early_name_alias {
- my $file= shift;
- Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- # This has the effect of pretending that the Name_Alias property was
- # available in all Unicode releases. Strictly speaking, this property
- # should not be availabe in early releases, but doing this allows
- # charnames.pm to work on older releases without change. Prior to v5.16
- # it had these names hard-coded inside it. Unicode 6.1 came along and
- # created these names, and so they were removed from charnames.
+sub fixup_early_perl_name_alias {
- my $aliases = property_ref('Name_Alias');
- if (! defined $aliases) {
- $aliases = Property->new('Name_Alias', Default_Map => "");
- }
+ # Different versions of Unicode have varying support for the name synonyms
+ # below. Just include everything. As of 6.1, all these are correct in
+ # the Unicode-supplied file.
- $file->insert_lines(get_old_name_aliases());
+ my $file= shift;
+ Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- return;
-}
-sub get_old_name_aliases () {
+ # ALERT did not come along until 6.0, at which point it became preferred
+ # over BELL. By inserting it last in early releases, BELL is preferred
+ # over it; and vice-vers in 6.0
+ my $type_for_bell = ($v_version lt v6.0.0)
+ ? 'correction'
+ : 'alternate';
+ $file->insert_lines(split /\n/, <<END
+0007;BELL; $type_for_bell
+000A;LINE FEED (LF);alternate
+000C;FORM FEED (FF);alternate
+000D;CARRIAGE RETURN (CR);alternate
+0085;NEXT LINE (NEL);alternate
+END
+
+ );
- # The Unicode_1_Name field, contains most of these names. One would
- # expect, given the field's name, that its values would be fixed across
- # versions, giving the true Unicode version 1 name for the character.
- # Sadly, this is not the case. Actually Version 1.1.5 had no names for
- # any of the controls; Version 2.0 introduced names for the C0 controls,
- # and 3.0 introduced C1 names. 3.0.1 removed the name INDEX; and 3.2
- # changed some names: it
+ # One might think that the the 'Unicode_1_Name' field, could work for most
+ # of the above names, but sadly that field varies depending on the
+ # release. Version 1.1.5 had no names for any of the controls; Version
+ # 2.0 introduced names for the C0 controls, and 3.0 introduced C1 names.
+ # 3.0.1 removed the name INDEX; and 3.2 changed some names:
# changed to parenthesized versions like "NEXT LINE" to
# "NEXT LINE (NEL)";
# changed PARTIAL LINE DOWN to PARTIAL LINE FORWARD
# changed PARTIAL LINE UP to PARTIAL LINE BACKWARD;;
# changed e.g. FILE SEPARATOR to INFORMATION SEPARATOR FOUR
- # This list contains all the names that were defined so that
- # charnames::vianame(), etc. understand them all EVEN if this version of
- # Unicode didn't specify them (this could be construed as a bug).
- # mktables elsewhere gives preference to the Unicode_1_Name field over
- # these names, so that viacode() will return the correct value for that
- # version of Unicode, except when that version doesn't define a name,
- # viacode() will return one anyway (this also could be construed as a
- # bug). But these potential "bugs" allow for the smooth working of code
- # on earlier Unicode releases.
-
- my @return = split /\n/, <<'END';
-0000;NULL;control
-0000;NUL;abbreviation
-0001;START OF HEADING;control
-0001;SOH;abbreviation
-0002;START OF TEXT;control
-0002;STX;abbreviation
-0003;END OF TEXT;control
-0003;ETX;abbreviation
-0004;END OF TRANSMISSION;control
-0004;EOT;abbreviation
-0005;ENQUIRY;control
-0005;ENQ;abbreviation
-0006;ACKNOWLEDGE;control
-0006;ACK;abbreviation
-0007;BELL;control
-0007;BEL;abbreviation
-0008;BACKSPACE;control
-0008;BS;abbreviation
-0009;CHARACTER TABULATION;control
-0009;HORIZONTAL TABULATION;control
-0009;HT;abbreviation
-0009;TAB;abbreviation
-000A;LINE FEED;control
-000A;LINE FEED (LF);control
-000A;NEW LINE;control
-000A;END OF LINE;control
-000A;LF;abbreviation
-000A;NL;abbreviation
-000A;EOL;abbreviation
-000B;LINE TABULATION;control
-000B;VERTICAL TABULATION;control
-000B;VT;abbreviation
-000C;FORM FEED;control
-000C;FORM FEED (FF);control
-000C;FF;abbreviation
-000D;CARRIAGE RETURN;control
-000D;CARRIAGE RETURN (CR);control
-000D;CR;abbreviation
-000E;SHIFT OUT;control
-000E;LOCKING-SHIFT ONE;control
-000E;SO;abbreviation
-000F;SHIFT IN;control
-000F;LOCKING-SHIFT ZERO;control
-000F;SI;abbreviation
-0010;DATA LINK ESCAPE;control
-0010;DLE;abbreviation
-0011;DEVICE CONTROL ONE;control
-0011;DC1;abbreviation
-0012;DEVICE CONTROL TWO;control
-0012;DC2;abbreviation
-0013;DEVICE CONTROL THREE;control
-0013;DC3;abbreviation
-0014;DEVICE CONTROL FOUR;control
-0014;DC4;abbreviation
-0015;NEGATIVE ACKNOWLEDGE;control
-0015;NAK;abbreviation
-0016;SYNCHRONOUS IDLE;control
-0016;SYN;abbreviation
-0017;END OF TRANSMISSION BLOCK;control
-0017;ETB;abbreviation
-0018;CANCEL;control
-0018;CAN;abbreviation
-0019;END OF MEDIUM;control
-0019;EOM;abbreviation
-001A;SUBSTITUTE;control
-001A;SUB;abbreviation
-001B;ESCAPE;control
-001B;ESC;abbreviation
-001C;INFORMATION SEPARATOR FOUR;control
-001C;FILE SEPARATOR;control
-001C;FS;abbreviation
-001D;INFORMATION SEPARATOR THREE;control
-001D;GROUP SEPARATOR;control
-001D;GS;abbreviation
-001E;INFORMATION SEPARATOR TWO;control
-001E;RECORD SEPARATOR;control
-001E;RS;abbreviation
-001F;INFORMATION SEPARATOR ONE;control
-001F;UNIT SEPARATOR;control
-001F;US;abbreviation
-0020;SP;abbreviation
-007F;DELETE;control
-007F;DEL;abbreviation
-0080;PADDING CHARACTER;figment
-0080;PAD;abbreviation
-0081;HIGH OCTET PRESET;figment
-0081;HOP;abbreviation
-0082;BREAK PERMITTED HERE;control
-0082;BPH;abbreviation
-0083;NO BREAK HERE;control
-0083;NBH;abbreviation
-0084;INDEX;control
-0084;IND;abbreviation
-0085;NEXT LINE;control
-0085;NEXT LINE (NEL);control
-0085;NEL;abbreviation
-0086;START OF SELECTED AREA;control
-0086;SSA;abbreviation
-0087;END OF SELECTED AREA;control
-0087;ESA;abbreviation
-0088;CHARACTER TABULATION SET;control
-0088;HORIZONTAL TABULATION SET;control
-0088;HTS;abbreviation
-0089;CHARACTER TABULATION WITH JUSTIFICATION;control
-0089;HORIZONTAL TABULATION WITH JUSTIFICATION;control
-0089;HTJ;abbreviation
-008A;LINE TABULATION SET;control
-008A;VERTICAL TABULATION SET;control
-008A;VTS;abbreviation
-008B;PARTIAL LINE FORWARD;control
-008B;PARTIAL LINE DOWN;control
-008B;PLD;abbreviation
-008C;PARTIAL LINE BACKWARD;control
-008C;PARTIAL LINE UP;control
-008C;PLU;abbreviation
-008D;REVERSE LINE FEED;control
-008D;REVERSE INDEX;control
-008D;RI;abbreviation
-008E;SINGLE SHIFT TWO;control
-008E;SINGLE-SHIFT-2;control
-008E;SS2;abbreviation
-008F;SINGLE SHIFT THREE;control
-008F;SINGLE-SHIFT-3;control
-008F;SS3;abbreviation
-0090;DEVICE CONTROL STRING;control
-0090;DCS;abbreviation
-0091;PRIVATE USE ONE;control
-0091;PRIVATE USE-1;control
-0091;PU1;abbreviation
-0092;PRIVATE USE TWO;control
-0092;PRIVATE USE-2;control
-0092;PU2;abbreviation
-0093;SET TRANSMIT STATE;control
-0093;STS;abbreviation
-0094;CANCEL CHARACTER;control
-0094;CCH;abbreviation
-0095;MESSAGE WAITING;control
-0095;MW;abbreviation
-0096;START OF GUARDED AREA;control
-0096;START OF PROTECTED AREA;control
-0096;SPA;abbreviation
-0097;END OF GUARDED AREA;control
-0097;END OF PROTECTED AREA;control
-0097;EPA;abbreviation
-0098;START OF STRING;control
-0098;SOS;abbreviation
-0099;SINGLE GRAPHIC CHARACTER INTRODUCER;figment
-0099;SGC;abbreviation
-009A;SINGLE CHARACTER INTRODUCER;control
-009A;SCI;abbreviation
-009B;CONTROL SEQUENCE INTRODUCER;control
-009B;CSI;abbreviation
-009C;STRING TERMINATOR;control
-009C;ST;abbreviation
-009D;OPERATING SYSTEM COMMAND;control
-009D;OSC;abbreviation
-009E;PRIVACY MESSAGE;control
-009E;PM;abbreviation
-009F;APPLICATION PROGRAM COMMAND;control
-009F;APC;abbreviation
-00A0;NBSP;abbreviation
-00AD;SHY;abbreviation
-200B;ZWSP;abbreviation
-200C;ZWNJ;abbreviation
-200D;ZWJ;abbreviation
-200E;LRM;abbreviation
-200F;RLM;abbreviation
-202A;LRE;abbreviation
-202B;RLE;abbreviation
-202C;PDF;abbreviation
-202D;LRO;abbreviation
-202E;RLO;abbreviation
-FEFF;BYTE ORDER MARK;alternate
-FEFF;BOM;abbreviation
-FEFF;ZWNBSP;abbreviation
-END
-
- if ($v_version ge v3.0.0) {
- push @return, split /\n/, <<'END';
-180B; FVS1; abbreviation
-180C; FVS2; abbreviation
-180D; FVS3; abbreviation
-180E; MVS; abbreviation
-202F; NNBSP; abbreviation
-END
- }
-
- if ($v_version ge v3.2.0) {
- push @return, split /\n/, <<'END';
-034F; CGJ; abbreviation
-205F; MMSP; abbreviation
-2060; WJ; abbreviation
-END
- # Add in VS1..VS16
- my $cp = 0xFE00 - 1;
- for my $i (1..16) {
- push @return, sprintf("%04X; VS%d; abbreviation", $cp + $i, $i);
- }
- }
- if ($v_version ge v4.0.0) { # Add in VS17..VS256
- my $cp = 0xE0100 - 17;
- for my $i (17..256) {
- push @return, sprintf("%04X; VS%d; abbreviation", $cp + $i, $i);
- }
- }
-
- # ALERT did not come along until 6.0, at which point it became preferred
- # over BELL, and was never in the Unicode_1_Name field. For the same
- # reasons, that the other names are made known to all releases by this
- # function, we make ALERT known too. By inserting it
- # last in early releases, BELL is preferred over it; and vice-vers in 6.0
- my $alert = '0007; ALERT; control';
- if ($v_version lt v6.0.0) {
- push @return, $alert;
- }
- else {
- unshift @return, $alert;
- }
+ #
+ # All these are present in the 6.1 NameAliases.txt
- return @return;
+ return;
}
sub filter_later_version_name_alias_line {
sub filter_early_version_name_alias_line {
# Early versions did not have the trailing alias type field; implicitly it
- # was 'correction'. But our synthetic lines we add in this program do
- # have it, so test for the type field.
- $_ .= "; correction" if $_ !~ /;.*;/;
+ # was 'correction'.
+ $_ .= "; correction";
filter_later_version_name_alias_line;
return;
# For each property, fill in any missing mappings, and calculate the re
# match tables. If a property has more than one missing mapping, the
- # default is a reference to a data structure, and requires data from other
- # properties to resolve. The sort is used to cause these to be processed
- # last, after all the other properties have been calculated.
+ # default is a reference to a data structure, and may require data from
+ # other properties to resolve. The sort is used to cause these to be
+ # processed last, after all the other properties have been calculated.
# (Fortunately, the missing properties so far don't depend on each other.)
foreach my $property
(sort { (defined $a->default_map && ref $a->default_map) ? 1 : -1 }
END
));
+ # Make sure this assumption in perl core code is valid in this Unicode
+ # release, with known exceptions
+ foreach my $range (property_ref('Numeric-Type')->table('Decimal')->ranges) {
+ next if $range->end - $range->start == 9;
+ next if $range->start == 0x1D7CE; # This whole range was added in 3.1
+ next if $range->end == 0x19DA && $v_version eq v5.2.0;
+ next if $range->end - $range->start < 9 && $v_version le 4.0.0;
+ Carp::my_carp("Range $range unexpectedly doesn't contain 10"
+ . " decimal digits. Code in regcomp.c assumes it does,"
+ . " and will have to be fixed. Proceeding anyway.");
+ }
+
Property->new('Legacy_Case_Folding',
File => "Fold",
Directory => $map_directory,
return $Nl;
}
-sub calculate_Assigned() { # Calculate the gc != Cn code points; may be
+sub calculate_Assigned() { # Set $Assigned to the gc != Cn code points; may be
# called before the Cn's are completely filled.
# Works on Unicodes earlier than ones that
# explicitly specify Cn.
}
}
+sub calculate_DI() { # Set $DI to a Range_List equivalent to the
+ # Default_Ignorable_Code_Point property. Works on
+ # Unicodes earlier than ones that explicitly specify
+ # DI.
+ return if defined $DI;
+
+ if (defined (my $di = property_ref('Default_Ignorable_Code_Point'))) {
+ $DI = $di->table('Y');
+ }
+ else {
+ $DI = Range_List->new(Initialize => [ 0x180B .. 0x180D,
+ 0x2060 .. 0x206F,
+ 0xFE00 .. 0xFE0F,
+ 0xFFF0 .. 0xFFFB,
+ ]);
+ if ($v_version ge v2.0) {
+ $DI += $gc->table('Cf')
+ + $gc->table('Cs');
+
+ # These are above the Unicode version 1 max
+ $DI->add_range(0xE0000, 0xE0FFF);
+ }
+ $DI += $gc->table('Cc')
+ - ord("\t")
+ - utf8::unicode_to_native(0x0A) # LINE FEED
+ - utf8::unicode_to_native(0x0B) # VERTICAL TAB
+ - ord("\f")
+ - utf8::unicode_to_native(0x0D) # CARRIAGE RETURN
+ - utf8::unicode_to_native(0x85); # NEL
+ }
+}
+
+sub calculate_NChar() { # Create a Perl extension match table which is the
+ # same as the Noncharacter_Code_Point property, and
+ # set $NChar to point to it. Works on Unicodes
+ # earlier than ones that explicitly specify NChar
+ return if defined $NChar;
+
+ $NChar = $perl->add_match_table('_Perl_Nchar',
+ Perl_Extension => 1,
+ Fate => $INTERNAL_ONLY);
+ if (defined (my $off_nchar = property_ref('NChar'))) {
+ $NChar->initialize($off_nchar->table('Y'));
+ }
+ else {
+ $NChar->initialize([ 0xFFFE .. 0xFFFF ]);
+ if ($v_version ge v2.0) { # First release with these nchars
+ for (my $i = 0x1FFFE; $i <= 0x10FFFE; $i += 0x10000) {
+ $NChar += [ $i .. $i+1 ];
+ }
+ }
+ }
+}
+
+sub handle_compare_versions () {
+ # This fixes things up for the $compare_versions capability, where we
+ # compare Unicode version X with version Y (with Y > X), and we are
+ # running it on the Unicode Data for version Y.
+ #
+ # It works by calculating the code points whose meaning has been specified
+ # after release X, by using the Age property. The complement of this set
+ # is the set of code points whose meaning is unchanged between the
+ # releases. This is the set the program restricts itself to. It includes
+ # everything whose meaning has been specified by the time version X came
+ # along, plus those still unassigned by the time of version Y. (We will
+ # continue to use the word 'assigned' to mean 'meaning has been
+ # specified', as it's shorter and is accurate in all cases except the
+ # Noncharacter code points.)
+ #
+ # This function is run after all the properties specified by Unicode have
+ # been calculated for release Y. This makes sure we get all the nuances
+ # of Y's rules. (It is done before the Perl extensions are calculated, as
+ # those are based entirely on the Unicode ones.) But doing it after the
+ # Unicode table calculations means we have to fix up the Unicode tables.
+ # We do this by subtracting the code points that have been assigned since
+ # X (which is actually done by ANDing each table of assigned code points
+ # with the set of unchanged code points). Most Unicode properties are of
+ # the form such that all unassigned code points have a default, grab-bag,
+ # property value which is changed when the code point gets assigned. For
+ # these, we just remove the changed code points from the table for the
+ # latter property value, and add them back in to the grab-bag one. A few
+ # other properties are not entirely of this form and have values for some
+ # or all unassigned code points that are not the grab-bag one. These have
+ # to be handled specially, and are hard-coded in to this routine based on
+ # manual inspection of the Unicode character database. A list of the
+ # outlier code points is made for each of these properties, and those
+ # outliers are excluded from adding and removing from tables.
+ #
+ # Note that there are glitches when comparing against Unicode 1.1, as some
+ # Hangul syllables in it were later ripped out and eventually replaced
+ # with other things.
+
+ print "Fixing up for version comparison\n" if $verbosity >= $PROGRESS;
+
+ my $after_first_version = "All matching code points were added after "
+ . "Unicode $string_compare_versions";
+
+ # Calculate the delta as those code points that have been newly assigned
+ # since the first compare version.
+ my $delta = Range_List->new();
+ foreach my $table ($age->tables) {
+ use version;
+ next if $table == $age->table('Unassigned');
+ next if version->parse($table->name)
+ le version->parse($string_compare_versions);
+ $delta += $table;
+ }
+ if ($delta->is_empty) {
+ die ("No changes; perhaps you need a 'DAge.txt' file?");
+ }
+
+ my $unchanged = ~ $delta;
+
+ calculate_Assigned() if ! defined $Assigned;
+ $Assigned &= $unchanged;
+
+ # $Assigned now contains the code points that were assigned as of Unicode
+ # version X.
+
+ # A block is all or nothing. If nothing is assigned in it, it all goes
+ # back to the No_Block pool; but if even one code point is assigned, the
+ # block is retained.
+ my $no_block = $block->table('No_Block');
+ foreach my $this_block ($block->tables) {
+ next if $this_block == $no_block
+ || ! ($this_block & $Assigned)->is_empty;
+ $this_block->set_fate($SUPPRESSED, $after_first_version);
+ foreach my $range ($this_block->ranges) {
+ $block->replace_map($range->start, $range->end, 'No_Block')
+ }
+ $no_block += $this_block;
+ }
+
+ my @special_delta_properties; # List of properties that have to be
+ # handled specially.
+ my %restricted_delta; # Keys are the entries in
+ # @special_delta_properties; values
+ # are the range list of the code points
+ # that behave normally when they get
+ # assigned.
+
+ # In the next three properties, the Default Ignorable code points are
+ # outliers.
+ calculate_DI();
+ $DI &= $unchanged;
+
+ push @special_delta_properties, property_ref('_Perl_GCB');
+ $restricted_delta{$special_delta_properties[-1]} = ~ $DI;
+
+ if (defined (my $cwnfkcc = property_ref('Changes_When_NFKC_Casefolded')))
+ {
+ push @special_delta_properties, $cwnfkcc;
+ $restricted_delta{$special_delta_properties[-1]} = ~ $DI;
+ }
+
+ calculate_NChar(); # Non-character code points
+ $NChar &= $unchanged;
+
+ # This may have to be updated from time-to-time to get the most accurate
+ # results.
+ my $default_BC_non_LtoR = Range_List->new(Initialize =>
+ # These came from the comments in v8.0 DBidiClass.txt
+ [ # AL
+ 0x0600 .. 0x07BF,
+ 0x08A0 .. 0x08FF,
+ 0xFB50 .. 0xFDCF,
+ 0xFDF0 .. 0xFDFF,
+ 0xFE70 .. 0xFEFF,
+ 0x1EE00 .. 0x1EEFF,
+ # R
+ 0x0590 .. 0x05FF,
+ 0x07C0 .. 0x089F,
+ 0xFB1D .. 0xFB4F,
+ 0x10800 .. 0x10FFF,
+ 0x1E800 .. 0x1EDFF,
+ 0x1EF00 .. 0x1EFFF,
+ # ET
+ 0x20A0 .. 0x20CF,
+ ]
+ );
+ $default_BC_non_LtoR += $DI + $NChar;
+ push @special_delta_properties, property_ref('BidiClass');
+ $restricted_delta{$special_delta_properties[-1]} = ~ $default_BC_non_LtoR;
+
+ if (defined (my $eaw = property_ref('East_Asian_Width'))) {
+
+ my $default_EA_width_W = Range_List->new(Initialize =>
+ # From comments in v8.0 EastAsianWidth.txt
+ [
+ 0x3400 .. 0x4DBF,
+ 0x4E00 .. 0x9FFF,
+ 0xF900 .. 0xFAFF,
+ 0x20000 .. 0x2A6DF,
+ 0x2A700 .. 0x2B73F,
+ 0x2B740 .. 0x2B81F,
+ 0x2B820 .. 0x2CEAF,
+ 0x2F800 .. 0x2FA1F,
+ 0x20000 .. 0x2FFFD,
+ 0x30000 .. 0x3FFFD,
+ ]
+ );
+ push @special_delta_properties, $eaw;
+ $restricted_delta{$special_delta_properties[-1]}
+ = ~ $default_EA_width_W;
+
+ # Line break came along in the same release as East_Asian_Width, and
+ # the non-grab-bag default set is a superset of the EAW one.
+ if (defined (my $lb = property_ref('Line_Break'))) {
+ my $default_LB_non_XX = Range_List->new(Initialize =>
+ # From comments in v8.0 LineBreak.txt
+ [ 0x20A0 .. 0x20CF ]);
+ $default_LB_non_XX += $default_EA_width_W;
+ push @special_delta_properties, $lb;
+ $restricted_delta{$special_delta_properties[-1]}
+ = ~ $default_LB_non_XX;
+ }
+ }
+
+ # Go through every property, skipping those we've already worked on, those
+ # that are immutable, and the perl ones that will be calculated after this
+ # routine has done its fixup.
+ foreach my $property (property_ref('*')) {
+ next if $property == $perl # Done later in the program
+ || $property == $block # Done just above
+ || $property == $DI # Done just above
+ || $property == $NChar # Done just above
+
+ # The next two are invariant across Unicode versions
+ || $property == property_ref('Pattern_Syntax')
+ || $property == property_ref('Pattern_White_Space');
+
+ # Find the grab-bag value.
+ my $default_map = $property->default_map;
+
+ if (! $property->to_create_match_tables) {
+
+ # Here there aren't any match tables. So far, all such properties
+ # have a default map, and don't require special handling. Just
+ # change each newly assigned code point back to the default map,
+ # as if they were unassigned.
+ foreach my $range ($delta->ranges) {
+ $property->add_map($range->start,
+ $range->end,
+ $default_map,
+ Replace => $UNCONDITIONALLY);
+ }
+ }
+ else { # Here there are match tables. Find the one (if any) for the
+ # grab-bag value that unassigned code points go to.
+ my $default_table;
+ if (defined $default_map) {
+ $default_table = $property->table($default_map);
+ }
+
+ # If some code points don't go back to the the grab-bag when they
+ # are considered unassigned, exclude them from the list that does
+ # that.
+ my $this_delta = $delta;
+ my $this_unchanged = $unchanged;
+ if (grep { $_ == $property } @special_delta_properties) {
+ $this_delta = $delta & $restricted_delta{$property};
+ $this_unchanged = ~ $this_delta;
+ }
+
+ # Fix up each match table for this property.
+ foreach my $table ($property->tables) {
+ if (defined $default_table && $table == $default_table) {
+
+ # The code points assigned after release X (the ones we
+ # are excluding in this routine) go back on to the default
+ # (grab-bag) table. However, some of these tables don't
+ # actually exist, but are specified solely by the other
+ # tables. (In a binary property, we don't need to
+ # actually have an 'N' table, as it's just the complement
+ # of the 'Y' table.) Such tables will be locked, so just
+ # skip those.
+ $table += $this_delta unless $table->locked;
+ }
+ else {
+
+ # Here the table is not for the default value. We need to
+ # subtract the code points we are ignoring for this
+ # comparison (the deltas) from it. But if the table
+ # started out with nothing, no need to exclude anything,
+ # and want to skip it here anyway, so it gets listed
+ # properly in the pod.
+ next if $table->is_empty;
+
+ # Save the deltas for later, before we do the subtraction
+ my $deltas = $table & $this_delta;
+
+ $table &= $this_unchanged;
+
+ # Suppress the table if the subtraction left it with
+ # nothing in it
+ if ($table->is_empty) {
+ if ($property->type == $BINARY) {
+ push @tables_that_may_be_empty, $table->complete_name;
+ }
+ else {
+ $table->set_fate($SUPPRESSED, $after_first_version);
+ }
+ }
+
+ # Now we add the removed code points to the property's
+ # map, as they should now map to the grab-bag default
+ # property (which they did in the first comparison
+ # version). But we don't have to do this if the map is
+ # only for internal use.
+ if (defined $default_map && $property->to_output_map) {
+
+ # The gc property has pseudo property values whose names
+ # have length 1. These are the union of all the
+ # property values whose name is longer than 1 and
+ # whose first letter is all the same. The replacement
+ # is done once for the longer-named tables.
+ next if $property == $gc && length $table->name == 1;
+
+ foreach my $range ($deltas->ranges) {
+ $property->add_map($range->start,
+ $range->end,
+ $default_map,
+ Replace => $UNCONDITIONALLY);
+ }
+ }
+ }
+ }
+ }
+ }
+
+ # The above code doesn't work on 'gc=C', as it is a superset of the default
+ # ('Cn') table. It's easiest to just special case it here.
+ my $C = $gc->table('C');
+ $C += $gc->table('Cn');
+
+ return;
+}
+
sub compile_perl() {
# Create perl-defined tables. Almost all are part of the pseudo-property
# named 'perl' internally to this program. Many of these are recommended
my $Word = $perl->add_match_table('Word', Full_Name => 'XPosixWord',
Description => '\w, including beyond ASCII;'
- . ' = \p{Alnum} + \pM + \p{Pc}',
+ . ' = \p{Alnum} + \pM + \p{Pc}'
+ . ' + \p{Join_Control}',
Initialize => $Alnum + $gc->table('Mark'),
);
my $Pc = $gc->table('Connector_Punctuation'); # 'Pc' Not in release 1
);
$Space->add_alias('XPerlSpace'); # Pre-existing synonyms
$Space->add_alias('SpacePerl');
+ $Space->add_alias('Space') if $v_version lt v4.1.0;
my $Posix_space = $perl->add_match_table("PosixSpace",
Description => "\\t, \\n, \\cK, \\f, \\r, and ' '. (\\cK is vertical tab)",
);
my $perl_surrogate = $perl->add_match_table('_Perl_Surrogate');
- if (defined (my $Cs = $gc->table('Cs'))) {
+ my $Cs = $gc->table('Cs');
+ if (defined $Cs && ! $Cs->is_empty) {
$perl_surrogate += $Cs;
}
else {
+ ord("(")
+ ord(")")
+ ord("-")
- + utf8::unicode_to_native(0xA0) # NBSP
);
- my @composition = ('Name', 'Unicode_1_Name', 'Name_Alias');
+ my @composition = ('Name', 'Unicode_1_Name', '_Perl_Name_Alias');
if (@named_sequences) {
push @composition, 'Named_Sequence';
my $alias_sentence = "";
my %abbreviations;
- my $alias = property_ref('Name_Alias');
- $perl_charname->set_proxy_for('Name_Alias');
-
- # Add each entry in Name_Alias to Perl_Charnames. Where these go with
- # respect to any existing entry depends on the entry type. Corrections go
- # before said entry, as they should be returned in preference over the
- # existing entry. (A correction to a correction should be later in the
- # Name_Alias table, so it will correctly precede the erroneous correction
- # in Perl_Charnames.)
+ my $alias = property_ref('_Perl_Name_Alias');
+ $perl_charname->set_proxy_for('_Perl_Name_Alias');
+
+ # Add each entry in _Perl_Name_Alias to Perl_Charnames. Where these go
+ # with respect to any existing entry depends on the entry type.
+ # Corrections go before said entry, as they should be returned in
+ # preference over the existing entry. (A correction to a correction
+ # should be later in the _Perl_Name_Alias table, so it will correctly
+ # precede the erroneous correction in Perl_Charnames.)
#
# Abbreviations go after everything else, so they are saved temporarily in
# a hash for later.
$perl_charname->add_duplicate($code_point, $value, Replace => $replace_type);
}
$alias_sentence = <<END;
-The Name_Alias property adds duplicate code point entries that are
+The _Perl_Name_Alias property adds duplicate code point entries that are
alternatives to the original name. If an addition is a corrected
name, it will be physically first in the table. The original (less correct,
but still valid) name will be next; then any alternatives, in no particular
Replace => $before_or_after);
}
- # But in this version only, the ALERT has precedence over BELL, the
- # Unicode_1_Name that would otherwise have precedence.
- if ($v_version eq v6.0.0) {
- $perl_charname->add_duplicate(7, 'ALERT', Replace => $MULTIPLE_BEFORE);
- }
-
# Now that have everything added, add in abbreviations after
# everything else. Sort so results don't change between runs of this
# program
));
# Construct the Present_In property from the Age property.
- if (-e 'DAge.txt' && defined (my $age = property_ref('Age'))) {
+ if (-e 'DAge.txt' && defined $age) {
my $default_map = $age->default_map;
my $in = Property->new('In',
Default_Map => $default_map,
if ($v_version ge v2.0) {
$quotemeta += $gc->table('Cf')
+ $gc->table('Cs');
+
+ # These are above the Unicode version 1 max
+ $quotemeta->add_range(0xE0000, 0xE0FFF);
}
$quotemeta += $gc->table('Cc')
- $Space;
0x2060 .. 0x206F,
0xFE00 .. 0xFE0F,
0xFFF0 .. 0xFFFB,
- 0xE0000 .. 0xE0FFF,
]);
- $quotemeta += $temp & $Assigned;
+ $temp->add_range(0xE0000, 0xE0FFF) if $v_version ge v2.0;
+ $quotemeta += $temp;
}
+ calculate_DI();
+ $quotemeta += $DI;
- my $nchar = $perl->add_match_table('_Perl_Nchar',
- Perl_Extension => 1,
- Fate => $INTERNAL_ONLY);
- if (defined (my $off_nchar = property_ref('Nchar'))) {
- $nchar->initialize($off_nchar->table('Y'));
- }
- else {
- $nchar->initialize([ 0xFFFE .. 0xFFFF ]);
- if ($v_version ge v2.0) { # First release with these nchars
- for (my $i = 0x1FFFE; $i <= 0x10FFFE; $i += 0x10000) {
- $nchar += [ $i .. $i+1 ];
- }
- }
- }
+ calculate_NChar();
# Finished creating all the perl properties. All non-internal non-string
# ones have a synonym of 'Is_' prefixed. (Internal properties begin with
}
}
+ # Perl tailors the WordBreak property so that \b{wb} doesn't split
+ # adjacent spaces into separate words. First create a copy of the regular
+ # WB property as '_Perl_WB'. (On Unicode releases earlier than when WB
+ # was defined for, this will already have been done by the substitute file
+ # portion for 'Input_file' code for WB.)
+ my $perl_wb = property_ref('_Perl_WB');
+ if (! defined $perl_wb) {
+ $perl_wb = Property->new('_Perl_WB',
+ Fate => $INTERNAL_ONLY,
+ Perl_Extension => 1,
+ Directory => $map_directory,
+ Type => $STRING);
+ my $wb = property_ref('Word_Break');
+ $perl_wb->initialize($wb);
+ $perl_wb->set_default_map($wb->default_map);
+ }
+
+ # And simply replace the mappings of horizontal space characters that
+ # otherwise would map to the default to instead map to our tailoring.
+ my $default = $perl_wb->default_map;
+ for my $range ($Blank->ranges) {
+ for my $i ($range->start .. $range->end) {
+ next unless $perl_wb->value_of($i) eq $default;
+ $perl_wb->add_map($i, $i, 'Perl_Tailored_HSpace',
+ Replace => $UNCONDITIONALLY);
+ }
+ }
+
+ # Create a version of the LineBreak property with the mappings that are
+ # omitted in the default algorithm remapped to what
+ # http://www.unicode.org/reports/tr14 says they should be.
+ #
+ # Original Resolved General_Category
+ # AI, SG, XX AL Any
+ # SA CM Only Mn or Mc
+ # SA AL Any except Mn and Mc
+ # CJ NS Any
+ #
+ # All property values are also written out in their long form, as
+ # regen/mk_invlist.pl expects that. This also fixes occurrences of the
+ # typo in early Unicode versions: 'inseperable'.
+ my $perl_lb = property_ref('_Perl_LB');
+ if (! defined $perl_lb) {
+ $perl_lb = Property->new('_Perl_LB',
+ Fate => $INTERNAL_ONLY,
+ Perl_Extension => 1,
+ Directory => $map_directory,
+ Type => $STRING);
+ my $lb = property_ref('Line_Break');
+
+ # Populate from $lb, but use full name and fix typo.
+ foreach my $range ($lb->ranges) {
+ my $full_name = $lb->table($range->value)->full_name;
+ $full_name = 'Inseparable'
+ if standardize($full_name) eq 'inseperable';
+ $perl_lb->add_map($range->start, $range->end, $full_name);
+ }
+ }
+
+ $perl_lb->set_default_map('Alphabetic', 'full_name'); # XX -> AL
+
+ for my $range ($perl_lb->ranges) {
+ my $value = standardize($range->value);
+ if ( $value eq standardize('Unknown')
+ || $value eq standardize('Ambiguous')
+ || $value eq standardize('Surrogate'))
+ {
+ $perl_lb->add_map($range->start, $range->end, 'Alphabetic',
+ Replace => $UNCONDITIONALLY);
+ }
+ elsif ($value eq standardize('Conditional_Japanese_Starter')) {
+ $perl_lb->add_map($range->start, $range->end, 'Nonstarter',
+ Replace => $UNCONDITIONALLY);
+ }
+ elsif ($value eq standardize('Complex_Context')) {
+ for my $i ($range->start .. $range->end) {
+ my $gc_val = $gc->value_of($i);
+ if ($gc_val eq 'Mn' || $gc_val eq 'Mc') {
+ $perl_lb->add_map($i, $i, 'Combining_Mark',
+ Replace => $UNCONDITIONALLY);
+ }
+ else {
+ $perl_lb->add_map($i, $i, 'Alphabetic',
+ Replace => $UNCONDITIONALLY);
+ }
+ }
+ }
+ }
+
# Here done with all the basic stuff. Ready to populate the information
# about each character if annotating them.
if ($annotate) {
# can give different annotations for each.
$unassigned_sans_noncharacters = Range_List->new(
Initialize => $gc->table('Unassigned'));
- if (defined (my $nonchars = property_ref('Noncharacter_Code_Point'))) {
- $unassigned_sans_noncharacters &= $nonchars->table('N');
- }
+ $unassigned_sans_noncharacters &= (~ $NChar);
for (my $i = 0; $i <= $MAX_UNICODE_CODEPOINT + 1; $i++ ) {
$i = populate_char_info($i); # Note sets $i so may cause skips
# the single-form, \p{name}. These are:
# All the binary property Y tables, so that \p{Name=Y} gets \p{Name} and
# \p{Is_Name} as synonyms
- # \p{Script=Value} gets \p{Value}, \p{Is_Value} as synonyms
+ # \p{Script_Extensions=Value} gets \p{Value}, \p{Is_Value} as synonyms
# \p{General_Category=Value} gets \p{Value}, \p{Is_Value} as synonyms
# \p{Block=Value} gets \p{In_Value} as a synonym, and, if there is no
# conflict, \p{Value} and \p{Is_Value} as well
property_ref('*');
push @tables, $gc->tables;
- # If the version of Unicode includes the Script property, add its tables
- push @tables, $script->tables if defined $script;
+ # If the version of Unicode includes the Script Extensions (preferably),
+ # or Script property, add its tables
+ my $scx = property_ref("Script_Extensions");
+ if (defined $scx) {
+ push @tables, $scx->tables;
+ }
+ else {
+ 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
if (! defined $pre_existing) {
- # No name collision, so ok to add the perl synonym.
+ # No name collision, so OK to add the perl synonym.
my $make_re_pod_entry;
my $ok_as_filename;
my $status = $alias->status;
if ($nominal_property == $block) {
- # For block properties, the 'In' form is preferred for
- # external use; the pod file contains wild cards for
- # this and the 'Is' form so no entries for those; and
- # we don't want people using the name without the
- # 'In', so discourage that.
+ # For block properties, only the compound form is
+ # preferred for external use; the others are
+ # discouraged. The pod file contains wild cards for
+ # the 'In' and 'Is' forms so no entries for those; and
+ # we don't want people using the name without any
+ # prefix, so discourage that.
if ($prefix eq "") {
$make_re_pod_entry = 1;
$status = $status || $DISCOURAGED;
}
elsif ($prefix eq 'In_') {
$make_re_pod_entry = 0;
- $status = $status || $NORMAL;
+ $status = $status || $DISCOURAGED;
$ok_as_filename = 1;
}
else {
next;
}
- # Here, there is a name collision, but it still could be ok if
+ # Here, there is a name collision, but it still could be OK if
# the tables match the identical set of code points, in which
# case, we can combine the names. Compare each table's code
# point list to see if they are identical.
# And if this is a compound form name, see if there is a
# single form equivalent
my $single_form;
- if ($table_property != $perl) {
+ if ($table_property != $perl && $table_property != $block) {
# Special case the binary N tables, so that will print
# \P{single}, but use the Y table values to populate
Carp::my_carp("Bad news. $property and $ucd_pod{$standard}->{'property'} have unexpected output status and perl-extension combinations. Proceeding anyway.");
}
- # We modifiy the info column of the one being output to
+ # We modify the info column of the one being output to
# indicate the ambiguity. Set $which to point to that one's
# info.
my $which;
'\p{Block: *}'
. (($has_In_conflicts)
? " $exception_message"
- : ""));
+ : ""),
+ $DISCOURAGED);
@block_warning = << "END";
-Matches in the Block property have shortcuts that begin with "In_". For
-example, C<\\p{Block=Latin1}> can be written as C<\\p{In_Latin1}>. For
-backward compatibility, if there is no conflict with another shortcut, these
-may also be written as C<\\p{Latin1}> or C<\\p{Is_Latin1}>. But, N.B., there
-are numerous such conflicting shortcuts. Use of these forms for Block is
-discouraged, and are flagged as such, not only because of the potential
-confusion as to what is meant, but also because a later release of Unicode may
-preempt the shortcut, and your program would no longer be correct. Use the
-"In_" form instead to avoid this, or even more clearly, use the compound form,
-e.g., C<\\p{blk:latin1}>. See L<perlunicode/"Blocks"> for more information
-about this.
+In particular, matches in the Block property have single forms
+defined by Perl that begin with C<"In_">, C<"Is_>, or even with no prefix at
+all, Like all B<DISCOURAGED> forms, these are not stable. For example,
+C<\\p{Block=Deseret}> can currently be written as C<\\p{In_Deseret}>,
+C<\\p{Is_Deseret}>, or C<\\p{Deseret}>. But, a new Unicode version may
+come along that would force Perl to change the meaning of one or more of
+these, and your program would no longer be correct. Currently there are no
+such conflicts with the form that begins C<"In_">, but there are many with the
+other two shortcuts, and Unicode continues to define new properties that begin
+with C<"In">, so it's quite possible that a conflict will occur in the future.
+The compound form is guaranteed to not become obsolete, and its meaning is
+clearer anyway. See L<perlunicode/"Blocks"> for more information about this.
END
}
my $text = $Is_flags_text;
push @bad_re_properties, "\n=back\n";
}
- # Similiarly, generate a list of files that we don't use, grouped by the
+ # Similarly, generate a list of files that we don't use, grouped by the
# reasons why (Don't output if the reason is empty). First, create a hash
# whose keys are the reasons, and whose values are anonymous arrays of all
# the files that share that reason.
=head1 NAME
-$pod_file - Index of Unicode Version $string_version character properties in Perl
+$pod_file - Index of Unicode Version $unicode_version character properties in Perl
=head1 DESCRIPTION
obsolete. Generally this designation is given to properties that Unicode once
used for internal purposes (but not any longer).
-=back
+=item Discouraged
+
+This is not actually a Unicode-specified obsolescence, but applies to certain
+Perl extensions that are present for backwards compatibility, but are
+discouraged from being used. These are not obsolete, but their meanings are
+not stable. Future Unicode versions could force any of these extensions to be
+removed without warning, replaced by another property with the same name that
+means something different. $A_bold_discouraged flags each such entry in the
+table. Use the equivalent shown instead.
-Some Perl extensions are present for backwards compatibility and are
-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
=back
-@block_warning
+=back
The table below has two columns. The left column contains the C<\\p{}>
constructs to look up, possibly preceded by the flags mentioned above; and
=over 4
-=item *
-
-B<*> is a wild-card
-
-=item *
+=item Z<>B<*> is a wild-card
-B<(\\d+)> in the info column gives the number of Unicode code points matched
+=item B<(\\d+)> in the info column gives the number of Unicode code points matched
by this property.
-=item *
-
-B<$DEPRECATED> means this is deprecated.
-
-=item *
-
-B<$OBSOLETE> means this is obsolete.
+=item B<$DEPRECATED> means this is deprecated.
-=item *
+=item B<$OBSOLETE> means this is obsolete.
-B<$STABILIZED> means this is stabilized.
+=item B<$STABILIZED> means this is stabilized.
-=item *
+=item B<$STRICTER> means tighter (stricter) name matching applies.
-B<$STRICTER> means tighter (stricter) name matching applies.
-
-=item *
-
-B<$DISCOURAGED> means use of this form is discouraged, and may not be
+=item B<$DISCOURAGED> means use of this form is discouraged, and may not be
stable.
=back
foreach my $prop_alias ($property->aliases) {
my $prop_alias_name = standardize($prop_alias->name);
- # If no =value, there's just one combination possibe for this
+ # If no =value, there's just one combination possible for this
if (! $value_name) {
# The property may be suppressed, but there may be a proxy
# the children.
make_re_pod_entries($table) if defined $pod_directory;
- # See if the the table matches identical code points with
+ # See if the table matches identical code points with
# something that has already been output. In that case,
# no need to have two files with the same code points in
# them. We use the table's hash() method to store these
# the table. That is, all the property-values given
# by this table. By agreement with Unicode::UCD,
# if the name and full name are identical, and there
- # are no other names, drop the duplcate entry to save
+ # are no other names, drop the duplicate entry to save
# memory.
if (@values_list == 2
&& $values_list[0] eq $values_list[1])
sub generate_tests($$$$$) {
# This used only for making the test script. It generates test cases that
- # are expected to compile successfully in perl. Note that the lhs and
- # rhs are assumed to already be as randomized as the caller wants.
+ # are expected to compile successfully in perl. Note that the LHS and
+ # RHS are assumed to already be as randomized as the caller wants.
my $lhs = shift; # The property: what's to the left of the colon
# or equals separator
my $rhs = shift; # The property value; what's to the right
my $valid_code = shift; # A code point that's known to be in the
- # table given by lhs=rhs; undef if table is
+ # table given by LHS=RHS; undef if table is
# empty
my $invalid_code = shift; # A code point known to not be in the table;
# undef if the table is all code points
# colon or equals separator
my $rhs = shift; # The property value; what's to the right
my $already_in_error = shift; # Boolean; if true it's known that the
- # unmodified lhs and rhs will cause an error.
+ # unmodified LHS and RHS will cause an error.
# This routine should not force another one
# Get the colon or equal
my $separator = generate_separator($lhs);
# Since this is an error only, don't bother to randomly decide whether to
- # put the error on the left or right side; and assume that the rhs is
+ # put the error on the left or right side; and assume that the RHS is
# loosely matched, again for convenience rather than rigor.
$rhs = randomize_loose_name($rhs, 'ERROR') unless $already_in_error;
# or multiple lines. main::write doesn't count the lines.
my @output;
+ push @output, <<'EOF_CODE';
+Error('\p{Script=InGreek}'); # Bug #69018
+Test_GCB("1100 $nobreak 1161"); # Bug #70940
+Expect(0, 0x2028, '\p{Print}', ""); # Bug # 71722
+Expect(0, 0x2029, '\p{Print}', ""); # Bug # 71722
+Expect(1, 0xFF10, '\p{XDigit}', ""); # Bug # 71726
+
+# Make sure this gets tested; it was not part of the official test suite at
+# the time this was added. Note that this is as it would appear in the
+# official suite, and gets modified to check for the perl tailoring by
+# Test_WB()
+Test_WB("$breakable 0020 $breakable 0020 $breakable 0308 $breakable");
+Test_LB("$nobreak 200B $nobreak 0020 $nobreak 0020 $breakable 2060 $breakable");
+EOF_CODE
+
# Sort these so get results in same order on different runs of this
# program
- foreach my $property (sort { $a->name cmp $b->name } property_ref('*')) {
- foreach my $table (sort { $a->name cmp $b->name } $property->tables) {
+ foreach my $property (sort { $a->has_dependency <=> $b->has_dependency
+ or
+ lc $a->name cmp lc $b->name
+ } property_ref('*'))
+ {
+ foreach my $table (sort { $a->has_dependency <=> $b->has_dependency
+ or
+ lc $a->name cmp lc $b->name
+ } $property->tables)
+ {
# Find code points that match, and don't match this table.
my $valid = $table->get_valid_code_point;
# conflating is possible. In our example, we
# don't want 2/3 matching 7/10, if there is
# a 7/10 code point.
+
+ # First, integers are not in the rationals
+ # table. Don't generate an error if this
+ # rounds to an integer using the given
+ # precision.
+ my $round = sprintf "%.0f", $table_name;
+ next PLACE if abs($table_name - $round)
+ < $MAX_FLOATING_SLOP;
+
+ # Here, isn't close enough to an integer to be
+ # confusable with one. Now, see it it's
+ # "close" to a known rational
for my $existing
(keys %nv_floating_to_rational)
{
}
}
}
- }
- }
+ $table->DESTROY();
+ }
+ $property->DESTROY();
+ }
+
+ # Make any test of the boundary (break) properties TODO if the code
+ # doesn't match the version being compiled
+ my $TODO_FAILING_BREAKS = ($version_of_mk_invlist_bounds ne $v_version)
+ ? "\nsub TODO_FAILING_BREAKS { 1 }\n"
+ : "\nsub TODO_FAILING_BREAKS { 0 }\n";
+
+ @output= map {
+ map s/^/ /mgr,
+ map "$_;\n",
+ split /;\n/, $_
+ } @output;
+
+ # Cause there to be 'if' statements to only execute a portion of this
+ # long-running test each time, so that we can have a bunch of .t's running
+ # in parallel
+ my $chunks = 10 # Number of test files
+ - 1 # For GCB & SB
+ - 1 # For WB
+ - 4; # LB split into this many files
+ my @output_chunked;
+ my $chunk_count=0;
+ my $chunk_size= int(@output / $chunks) + 1;
+ while (@output) {
+ $chunk_count++;
+ my @chunk= splice @output, 0, $chunk_size;
+ push @output_chunked,
+ "if (!\$::TESTCHUNK or \$::TESTCHUNK == $chunk_count) {\n",
+ @chunk,
+ "}\n";
+ }
+
+ $chunk_count++;
+ push @output_chunked,
+ "if (!\$::TESTCHUNK or \$::TESTCHUNK == $chunk_count) {\n",
+ (map {" Test_GCB('$_');\n"} @backslash_X_tests),
+ (map {" Test_SB('$_');\n"} @SB_tests),
+ "}\n";
+
+
+ $chunk_size= int(@LB_tests / 4) + 1;
+ @LB_tests = map {" Test_LB('$_');\n"} @LB_tests;
+ while (@LB_tests) {
+ $chunk_count++;
+ my @chunk= splice @LB_tests, 0, $chunk_size;
+ push @output_chunked,
+ "if (!\$::TESTCHUNK or \$::TESTCHUNK == $chunk_count) {\n",
+ @chunk,
+ "}\n";
+ }
+
+ $chunk_count++;
+ push @output_chunked,
+ "if (!\$::TESTCHUNK or \$::TESTCHUNK == $chunk_count) {\n",
+ (map {" Test_WB('$_');\n"} @WB_tests),
+ "}\n";
&write($t_path,
0, # Not utf8;
[$HEADER,
+ $TODO_FAILING_BREAKS,
<DATA>,
- @output,
- (map {"Test_GCB('$_');\n"} @backslash_X_tests),
- (map {"Test_SB('$_');\n"} @SB_tests),
- (map {"Test_WB('$_');\n"} @WB_tests),
- "Finished();\n"
+ @output_chunked,
+ "Finished();\n",
]);
return;
# Skip reasons, so will be exact same text and hence the files with each
# reason will get grouped together in perluniprops.
+my $Documentation = "Documentation";
my $Indic_Skip
= "Provisional; for the analysis and processing of Indic scripts";
my $Validation = "Validation Tests";
+my $Validation_Documentation = "Documentation of validation Tests";
# This is a list of the input files and how to handle them. The files are
# processed in their order in this list. Some reordering is possible if
-# desired, but the v0 files should be first, and the extracted before the
-# others except DAge.txt (as data in an extracted file can be over-ridden by
-# the non-extracted. Some other files depend on data derived from an earlier
-# file, like UnicodeData requires data from Jamo, and the case changing and
-# folding requires data from Unicode. Mostly, it is safest to order by first
-# version releases in (except the Jamo). DAge.txt is read before the
-# extracted ones because of the rarely used feature $compare_versions. In the
-# unlikely event that there were ever an extracted file that contained the Age
-# property information, it would have to go in front of DAge.
+# desired, but the PropertyAliases and PropValueAliases files should be first,
+# and the extracted before the others (as data in an extracted file can be
+# over-ridden by the non-extracted. Some other files depend on data derived
+# from an earlier file, like UnicodeData requires data from Jamo, and the case
+# changing and folding requires data from Unicode. Mostly, it is safest to
+# order by first version releases in (except the Jamo).
#
# The version strings allow the program to know whether to expect a file or
# not, but if a file exists in the directory, it will be processed, even if it
# is in a version earlier than expected, so you can copy files from a later
# release into an earlier release's directory.
my @input_file_objects = (
- Input_file->new('PropertyAliases.txt', v0,
+ Input_file->new('PropertyAliases.txt', v3.2,
Handler => \&process_PropertyAliases,
+ Early => [ \&substitute_PropertyAliases ],
Required_Even_in_Debug_Skip => 1,
),
Input_file->new(undef, v0, # No file associated with this
Progress_Message => 'Finishing property setup',
Handler => \&finish_property_setup,
),
- Input_file->new('PropValueAliases.txt', v0,
+ Input_file->new('PropValueAliases.txt', v3.2,
Handler => \&process_PropValueAliases,
+ Early => [ \&substitute_PropValueAliases ],
Has_Missings_Defaults => $NOT_IGNORED,
Required_Even_in_Debug_Skip => 1,
),
- Input_file->new('DAge.txt', v3.2.0,
- Has_Missings_Defaults => $NOT_IGNORED,
- Property => 'Age'
- ),
Input_file->new("${EXTRACTED}DGeneralCategory.txt", v3.1.0,
Property => 'General_Category',
),
Property => 'Joining_Type',
Has_Missings_Defaults => $NOT_IGNORED,
),
+ Input_file->new("${EXTRACTED}DName.txt", v10.0.0,
+ Skip => 'This file adds no new information not already'
+ . ' present in other files',
+ # And it's unnecessary programmer work to handle this new
+ # format. Previous Derived files actually had bug fixes
+ # in them that were useful, but that should not be the
+ # case here.
+ ),
Input_file->new('Jamo.txt', v2.0.0,
Property => 'Jamo_Short_Name',
Each_Line_Handler => \&filter_jamo_line,
],
EOF_Handler => \&EOF_UnicodeData,
),
+ Input_file->new('CJKXREF.TXT', v1.1.5,
+ Withdrawn => v2.0.0,
+ Skip => 'Gives the mapping of CJK code points '
+ . 'between Unicode and various other standards',
+ ),
Input_file->new('ArabicShaping.txt', v2.0.0,
Each_Line_Handler =>
($v_version lt 4.1.0)
Has_Missings_Defaults => $NOT_IGNORED,
Each_Line_Handler => \&filter_blocks_lines
),
+ Input_file->new('Index.txt', v2.0.0,
+ Skip => 'Alphabetical index of Unicode characters',
+ ),
+ Input_file->new('NamesList.txt', v2.0.0,
+ Skip => 'Annotated list of characters',
+ ),
Input_file->new('PropList.txt', v2.0.0,
Each_Line_Handler => (($v_version lt v3.1.0)
? \&filter_old_style_proplist
: undef),
),
+ Input_file->new('Props.txt', v2.0.0,
+ Withdrawn => v3.0.0,
+ Skip => 'A subset of F<PropList.txt> (which is used instead)',
+ ),
+ Input_file->new('ReadMe.txt', v2.0.0,
+ Skip => $Documentation,
+ ),
Input_file->new('Unihan.txt', v2.0.0,
Withdrawn => v5.2.0,
Construction_Time_Handler => \&construct_unihan,
Has_Missings_Defaults => $NOT_IGNORED,
Property => 'Line_Break',
# Early versions had problematic syntax
- Each_Line_Handler => (($v_version lt v3.1.0)
- ? \&filter_early_ea_lb
- : undef),
+ Each_Line_Handler => ($v_version ge v3.1.0)
+ ? undef
+ : ($v_version lt v3.0.0)
+ ? \&filter_substitute_lb
+ : \&filter_early_ea_lb,
+ # Must use long names for property values see comments at
+ # sub filter_substitute_lb
+ Early => [ "LBsubst.txt", '_Perl_LB', 'Alphabetic',
+ 'Alphabetic', # default to this because XX ->
+ # AL
+
+ # Don't use _Perl_LB as a synonym for
+ # Line_Break in later perls, as it is tailored
+ # and isn't the same as Line_Break
+ 'ONLY_EARLY' ],
),
Input_file->new('EastAsianWidth.txt', v3.0.0,
Property => 'East_Asian_Width',
Input_file->new('CompositionExclusions.txt', v3.0.0,
Property => 'Composition_Exclusion',
),
+ Input_file->new('UnicodeData.html', v3.0.0,
+ Withdrawn => v4.0.1,
+ Skip => $Documentation,
+ ),
Input_file->new('BidiMirroring.txt', v3.0.1,
Property => 'Bidi_Mirroring_Glyph',
Has_Missings_Defaults => ($v_version lt v6.2.0)
# null string
: $IGNORED,
),
+ Input_file->new('NamesList.html', v3.0.0,
+ Skip => 'Describes the format and contents of '
+ . 'F<NamesList.txt>',
+ ),
+ Input_file->new('UnicodeCharacterDatabase.html', v3.0.0,
+ Withdrawn => v5.1,
+ Skip => $Documentation,
+ ),
Input_file->new('CaseFolding.txt', v3.0.1,
Pre_Handler => \&setup_case_folding,
Each_Line_Handler =>
? $NOT_IGNORED
: $NO_DEFAULTS),
),
+ Input_file->new('DProperties.html', v3.1.0,
+ Withdrawn => v3.2.0,
+ Skip => $Documentation,
+ ),
+ Input_file->new('PropList.html', v3.1.0,
+ Withdrawn => v5.1,
+ Skip => $Documentation,
+ ),
Input_file->new('Scripts.txt', v3.1.0,
Property => 'Script',
Each_Line_Handler => (($v_version le v4.0.0)
? \&filter_old_style_normalization_lines
: undef),
),
- Input_file->new('HangulSyllableType.txt', v0,
+ Input_file->new('DerivedProperties.html', v3.1.1,
+ Withdrawn => v5.1,
+ Skip => $Documentation,
+ ),
+ Input_file->new('DAge.txt', v3.2.0,
+ Has_Missings_Defaults => $NOT_IGNORED,
+ Property => 'Age'
+ ),
+ Input_file->new('HangulSyllableType.txt', v4.0,
Has_Missings_Defaults => $NOT_IGNORED,
- Property => 'Hangul_Syllable_Type',
- Pre_Handler => ($v_version lt v4.0.0)
- ? \&generate_hst
- : undef,
+ Early => [ \&generate_hst, 'Hangul_Syllable_Type' ],
+ Property => 'Hangul_Syllable_Type'
+ ),
+ Input_file->new('NormalizationCorrections.txt', v3.2.0,
+ # This documents the cumulative fixes to erroneous
+ # normalizations in earlier Unicode versions. Its main
+ # purpose is so that someone running on an earlier
+ # version can use this file to override what got
+ # published in that earlier release. It would be easy
+ # for mktables to handle this file. But all the
+ # corrections in it should already be in the other files
+ # for the release it is. To get it to actually mean
+ # something useful, someone would have to be using an
+ # earlier Unicode release, and copy it into the directory
+ # for that release and recompile. So far there has been
+ # no demand to do that, so this hasn't been implemented.
+ Skip => 'Documentation of corrections already '
+ . 'incorporated into the Unicode data base',
+ ),
+ Input_file->new('StandardizedVariants.html', v3.2.0,
+ Skip => 'Obsoleted as of Unicode 9.0, but previously '
+ . 'provided a visual display of the standard '
+ . 'variant sequences derived from '
+ . 'F<StandardizedVariants.txt>.',
+ # I don't know why the html came earlier than the
+ # .txt, but both are skipped anyway, so it doesn't
+ # matter.
+ ),
+ Input_file->new('StandardizedVariants.txt', v4.0.0,
+ Skip => '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>',
+ ),
+ Input_file->new('UCD.html', v4.0.0,
+ Withdrawn => v5.2,
+ Skip => $Documentation,
),
Input_file->new("$AUXILIARY/WordBreakProperty.txt", v4.1.0,
+ Early => [ "WBsubst.txt", '_Perl_WB', 'ALetter',
+
+ # Don't use _Perl_WB as a synonym for
+ # Word_Break in later perls, as it is tailored
+ # and isn't the same as Word_Break
+ 'ONLY_EARLY' ],
Property => 'Word_Break',
Has_Missings_Defaults => $NOT_IGNORED,
),
- Input_file->new("$AUXILIARY/GraphemeBreakProperty.txt", v0,
+ Input_file->new("$AUXILIARY/GraphemeBreakProperty.txt", v4.1,
+ Early => [ \&generate_GCB, '_Perl_GCB' ],
Property => 'Grapheme_Cluster_Break',
Has_Missings_Defaults => $NOT_IGNORED,
- Pre_Handler => ($v_version lt v4.1.0)
- ? \&generate_GCB
- : undef,
),
Input_file->new("$AUXILIARY/GCBTest.txt", v4.1.0,
Handler => \&process_GCB_test,
+ retain_trailing_comments => 1,
+ ),
+ Input_file->new("$AUXILIARY/GraphemeBreakTest.html", v4.1.0,
+ Skip => $Validation_Documentation,
),
Input_file->new("$AUXILIARY/SBTest.txt", v4.1.0,
Handler => \&process_SB_test,
+ retain_trailing_comments => 1,
+ ),
+ Input_file->new("$AUXILIARY/SentenceBreakTest.html", v4.1.0,
+ Skip => $Validation_Documentation,
),
Input_file->new("$AUXILIARY/WBTest.txt", v4.1.0,
Handler => \&process_WB_test,
+ retain_trailing_comments => 1,
+ ),
+ Input_file->new("$AUXILIARY/WordBreakTest.html", v4.1.0,
+ Skip => $Validation_Documentation,
),
Input_file->new("$AUXILIARY/SentenceBreakProperty.txt", v4.1.0,
Property => 'Sentence_Break',
+ Early => [ "SBsubst.txt", '_Perl_SB', 'OLetter' ],
Has_Missings_Defaults => $NOT_IGNORED,
),
Input_file->new('NamedSequences.txt', v4.1.0,
Handler => \&process_NamedSequences
),
- Input_file->new('NameAliases.txt', v0,
+ Input_file->new('Unihan.html', v4.1.0,
+ Withdrawn => v5.2,
+ Skip => $Documentation,
+ ),
+ Input_file->new('NameAliases.txt', v5.0,
Property => 'Name_Alias',
- Pre_Handler => ($v_version le v6.0.0)
- ? \&setup_early_name_alias
- : undef,
Each_Line_Handler => ($v_version le v6.0.0)
? \&filter_early_version_name_alias_line
: \&filter_later_version_name_alias_line,
),
+ # NameAliases.txt came along in v5.0. The above constructor handles
+ # this. But until 6.1, it was lacking some information needed by core
+ # perl. The constructor below handles that. It is either a kludge or
+ # clever, depending on your point of view. The 'Withdrawn' parameter
+ # indicates not to use it at all starting in 6.1 (so the above
+ # constructor applies), and the 'v6.1' parameter indicates to use the
+ # Early parameter before 6.1. Therefore 'Early" is always used,
+ # yielding the internal-only property '_Perl_Name_Alias', which it
+ # gets from a NameAliases.txt from 6.1 or later stored in
+ # N_Asubst.txt. In combination with the above constructor,
+ # 'Name_Alias' is publicly accessible starting with v5.0, and the
+ # better 6.1 version is accessible to perl core in all releases.
+ Input_file->new("NameAliases.txt", v6.1,
+ Withdrawn => v6.1,
+ Early => [ "N_Asubst.txt", '_Perl_Name_Alias', "" ],
+ Property => 'Name_Alias',
+ EOF_Handler => \&fixup_early_perl_name_alias,
+ Each_Line_Handler =>
+ \&filter_later_version_name_alias_line,
+ ),
+ Input_file->new('NamedSqProv.txt', v5.0.0,
+ Skip => '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',
+ ),
Input_file->new("$AUXILIARY/LBTest.txt", v5.1.0,
- Skip => $Validation,
+ Handler => \&process_LB_test,
+ retain_trailing_comments => 1,
+ ),
+ Input_file->new("$AUXILIARY/LineBreakTest.html", v5.1.0,
+ Skip => $Validation_Documentation,
),
Input_file->new("BidiTest.txt", v5.2.0,
Skip => $Validation,
Optional => "",
Each_Line_Handler => \&filter_unihan_line,
),
+ Input_file->new('CJKRadicals.txt', v5.2.0,
+ Skip => 'Maps the kRSUnicode property values to '
+ . 'corresponding code points',
+ ),
+ Input_file->new('EmojiSources.txt', v6.0.0,
+ Skip => 'Maps certain Unicode code points to their '
+ . 'legacy Japanese cell-phone values',
+ ),
Input_file->new('ScriptExtensions.txt', v6.0.0,
Property => 'Script_Extensions',
Pre_Handler => \&setup_script_extensions,
? $Indic_Skip
: 0),
),
+ Input_file->new('USourceData.txt', v6.2.0,
+ Skip => 'Documentation of status and cross reference of '
+ . 'proposals for encoding by Unicode of Unihan '
+ . 'characters',
+ ),
+ Input_file->new('USourceGlyphs.pdf', v6.2.0,
+ Skip => 'Pictures of the characters in F<USourceData.txt>',
+ ),
Input_file->new('BidiBrackets.txt', v6.3.0,
Properties => [ 'Bidi_Paired_Bracket',
'Bidi_Paired_Bracket_Type'
Property => 'Indic_Positional_Category',
Has_Missings_Defaults => $NOT_IGNORED,
),
+ Input_file->new('TangutSources.txt', v9.0.0,
+ Skip => 'Specifies source mappings for Tangut ideographs'
+ . ' and components. This data file also includes'
+ . ' informative radical-stroke values that are used'
+ . ' internally by Unicode',
+ ),
+ Input_file->new('VerticalOrientation.txt', v10.0.0,
+ Property => 'Vertical_Orientation',
+ Has_Missings_Defaults => $NOT_IGNORED,
+ ),
+ Input_file->new('NushuSources.txt', v10.0.0,
+ Skip => 'Specifies source material for Nushu characters',
+ ),
);
# End of all the preliminaries.
# Do it...
+if (@missing_early_files) {
+ print simple_fold(join_lines(<<END
+
+The compilation cannot be completed because one or more required input files,
+listed below, are missing. This is because you are compiling Unicode version
+$unicode_version, which predates the existence of these file(s). To fully
+function, perl needs the data that these files would have contained if they
+had been in this release. To work around this, create copies of later
+versions of the missing files in the directory containing '$0'. (Perl will
+make the necessary adjustments to the data to compensate for it not being the
+same version as is being compiled.) The files are available from unicode.org,
+via either ftp or http. If using http, they will be under
+www.unicode.org/versions/. Below are listed the source file name of each
+missing file, the Unicode version to copy it from, and the name to store it
+as. (Note that the listed source file name may not be exactly the one that
+Unicode calls it. If you don't find it, you can look it up in 'README.perl'
+to get the correct name.)
+END
+ ));
+ print simple_fold(join_lines("\n$_")) for @missing_early_files;
+ exit 2;
+}
+
if ($compare_versions) {
Carp::my_carp(<<END
Warning. \$compare_versions is set. Output is not suitable for production
}
# Put into %potential_files a list of all the files in the directory structure
-# that could be inputs to this program, excluding those that we should ignore.
-# Use absolute file names because it makes it easier across machine types.
-my @ignored_files_full_names = map { File::Spec->rel2abs(
- internal_file_to_platform($_))
- } keys %ignored_files;
+# that could be inputs to this program
File::Find::find({
wanted=>sub {
- return unless /\.txt$/i; # Some platforms change the name's case
+ return unless / \. ( txt | htm l? ) $ /xi; # Some platforms change the
+ # name's case
my $full = lc(File::Spec->rel2abs($_));
- $potential_files{$full} = 1
- if ! grep { $full eq lc($_) } @ignored_files_full_names;
+ $potential_files{$full} = 1;
return;
}
}, File::Spec->curdir());
# The paths are stored with relative names, and with '/' as the
# delimiter; convert to absolute on this machine
my $full = lc(File::Spec->rel2abs(internal_file_to_platform($input)));
- $potential_files{lc $full} = 1
- if ! grep { lc($full) eq lc($_) } @ignored_files_full_names;
+ $potential_files{lc $full} = 1;
}
}
}
}
if (! $rebuild) {
- print "Files seem to be ok, not bothering to rebuild. Add '-w' option to force build\n";
+ print "$0: Files seem to be ok, not bothering to rebuild. Add '-w' option to force build\n";
exit(0);
}
-print "Must rebuild tables.\n" if $verbosity >= $VERBOSE;
+print "$0: Must rebuild tables.\n" if $verbosity >= $VERBOSE;
# Ready to do the major processing. First create the perl pseudo-property.
$perl = Property->new('perl', Type => $NON_STRING, Perl_Extension => 1);
print "Finishing processing Unicode properties\n" if $verbosity >= $PROGRESS;
finish_Unicode();
+# For the very specialized case of comparing two Unicode versions...
+if (DEBUG && $compare_versions) {
+ handle_compare_versions();
+}
+
print "Compiling Perl properties\n" if $verbosity >= $PROGRESS;
compile_perl();
}
print "\nAll done\n" if $verbosity >= $VERBOSE;
}
+
+if ($version_of_mk_invlist_bounds lt $v_version) {
+ Carp::my_carp("WARNING: \\b{} algorithms (regen/mk_invlist.pl) need"
+ . " to be checked and possibly updated to Unicode"
+ . " $string_version");
+}
+
exit(0);
# TRAILING CODE IS USED BY make_property_test_script()
$Tests++;
# A string eval is needed because of the 'no warnings'.
- # Assumes no parens in the regular expression
+ # Assumes no parentheses in the regular expression
my $result = eval "$no_warnings
my \$RegObj = qr($regex);
$string =~ \$RegObj ? 1 : 0";
my $nobreak_utf8 = my $nobreak = chr(utf8::unicode_to_native(0xD7));
utf8::upgrade($nobreak_utf8);
-use Config;
+my $are_ctype_locales_available;
my $utf8_locale;
chdir 't' if -d 't';
eval { require "./loc_tools.pl" };
-$utf8_locale = &find_utf8_ctype_locale if defined &find_utf8_ctype_locale;
+if (defined &locales_enabled) {
+ $are_ctype_locales_available = locales_enabled('LC_CTYPE');
+ if ($are_ctype_locales_available) {
+ $utf8_locale = &find_utf8_ctype_locale;
+ }
+}
+
+# Eval'd so can run on versions earlier than the property is available in
+my $WB_Extend_or_Format_re = eval 'qr/[\p{WB=Extend}\p{WB=Format}\p{WB=ZWJ}]/';
+if (! defined $WB_Extend_or_Format_re) {
+ $WB_Extend_or_Format_re = eval 'qr/[\p{WB=Extend}\p{WB=Format}]/';
+}
sub _test_break($$) {
- # Test qr/\X/ matches. The input is a line from auxiliary/GCBTest.txt
- # Each such line is a sequence of code points given by their hex numbers,
- # separated by the two characters defined just before this subroutine that
- # indicate that either there can or cannot be a break between the adjacent
- # code points. If there isn't a break, that means the sequence forms an
- # extended grapheme cluster, which means that \X should match the whole
- # thing. If there is a break, \X should stop there. This is all
- # converted by this routine into a match:
- # $string =~ /(\X)/,
- # Each \X should match the next cluster; and that is what is checked.
+ # Test various break property matches. The 2nd parameter gives the
+ # property name. The input is a line from auxiliary/*Test.txt for the
+ # given property. Each such line is a sequence of Unicode (not native)
+ # code points given by their hex numbers, separated by the two characters
+ # defined just before this subroutine that indicate that either there can
+ # or cannot be a break between the adjacent code points. All these are
+ # tested.
+ #
+ # For the gcb property extra tests are made. if there isn't a break, that
+ # means the sequence forms an extended grapheme cluster, which means that
+ # \X should match the whole thing. If there is a break, \X should stop
+ # there. This is all converted by this routine into a match: $string =~
+ # /(\X)/, Each \X should match the next cluster; and that is what is
+ # checked.
my $template = shift;
my $break_type = shift;
my $line = (caller 1)[2]; # Line number
+ my $comment = "";
+
+ if ($template =~ / ( .*? ) \s* \# (.*) /x) {
+ $template = $1;
+ $comment = $2;
+
+ # Replace leading spaces with a single one.
+ $comment =~ s/ ^ \s* / # /x;
+ }
# The line contains characters above the ASCII range, but in Latin1. It
# may or may not be in utf8, and if it is, it may or may not know it. So,
$template =~ s/$breakable_utf8/$breakable/g;
}
+ # Perl customizes wb. So change the official tests accordingly
+ if ($break_type eq 'wb' && $WB_Extend_or_Format_re) {
+
+ # Split into elements that alternate between code point and
+ # break/no-break
+ my @line = split / +/, $template;
+
+ # Look at each code point and its following one
+ for (my $i = 1; $i < @line - 1 - 1; $i+=2) {
+
+ # The customization only involves changing some breaks to
+ # non-breaks.
+ next if $line[$i+1] =~ /$nobreak/;
+
+ my $lhs = chr utf8::unicode_to_native(hex $line[$i]);
+ my $rhs = chr utf8::unicode_to_native(hex $line[$i+2]);
+
+ # And it only affects adjacent space characters.
+ next if $lhs !~ /\s/u;
+
+ # But, we want to make sure to test spaces followed by a Extend
+ # or Format.
+ next if $rhs !~ /\s|$WB_Extend_or_Format_re/;
+
+ # To test the customization, add some white-space before this to
+ # create a span. The $lhs white space may or may not be bound to
+ # that span, and also with the $rhs. If the $rhs is a binding
+ # character, the $lhs is bound to it and not to the span, unless
+ # $lhs is vertical space. In all other cases, the $lhs is bound
+ # to the span. If the $rhs is white space, it is bound to the
+ # $lhs
+ my $bound;
+ my $span;
+ if ($rhs =~ /$WB_Extend_or_Format_re/) {
+ if ($lhs =~ /\v/) {
+ $bound = $breakable;
+ $span = $nobreak;
+ }
+ else {
+ $bound = $nobreak;
+ $span = $breakable;
+ }
+ }
+ else {
+ $span = $nobreak;
+ $bound = $nobreak;
+ }
+
+ splice @line, $i, 0, ( '0020', $nobreak, '0020', $span);
+ $i += 4;
+ $line[$i+1] = $bound;
+ }
+ $template = join " ", @line;
+ }
+
# The input is just the break/no-break symbols and sequences of Unicode
# code points as hex digits separated by spaces for legibility. e.g.:
# ÷ 0020 × 0308 ÷ 0020 ÷
$display_upgrade = " (utf8-upgraded)";
}
- # The /l modifier has C after it to indicate the locale to try
- my @modifiers = qw(a aa d lC u i);
- push @modifiers, "l$utf8_locale" if defined $utf8_locale;
+ my @modifiers = qw(a aa d u i);
+ if ($are_ctype_locales_available) {
+ push @modifiers, "l$utf8_locale" if defined $utf8_locale;
+
+ # The /l modifier has C after it to indicate the locale to try
+ push @modifiers, "lC";
+ }
# Test for each of the regex modifiers.
for my $modifier (@modifiers) {
if ($modifier =~ / ^ l (.*) /x) {
my $locale = $1;
$display_locale = "(locale = $locale)";
- use Config;
- if (defined $Config{d_setlocale}) {
- eval { require POSIX; import POSIX 'locale_h'; };
- if (defined &POSIX::LC_CTYPE) {
- POSIX::setlocale(&POSIX::LC_CTYPE, $locale);
- }
- }
+ POSIX::setlocale(&POSIX::LC_CTYPE, $locale);
$modifier = 'l';
}
my $pattern = "(?$modifier:$break_pattern)";
# Actually do the test
+ my $matched_text;
my $matched = $string =~ qr/$pattern/;
- print "not " unless $matched;
+ if ($matched) {
+ $matched_text = "matched";
+ }
+ else {
+ $matched_text = "failed to match";
+ print "not ";
+
+ if (TODO_FAILING_BREAKS) {
+ $comment = " # $comment" unless $comment =~ / ^ \s* \# /x;
+ $comment =~ s/#/# TODO/;
+ }
+ }
+ print "ok ", ++$Tests, " - \"$display_string\" $matched_text /$pattern/$display_upgrade; line $line $display_locale$comment\n";
- # Fancy display of test results
- $matched = ($matched) ? "matched" : "failed to match";
- print "ok ", ++$Tests, " - \"$display_string\" $matched /$pattern/$display_upgrade; line $line $display_locale\n";
+ # Only print the comment on the first use of this line
+ $comment = "";
# Repeat with the first \B{} in the pattern. This makes sure the
# code in regexec.c:find_byclass() for \B gets executed
my $B_pattern = "$1$2";
$matched = $string =~ qr/$B_pattern/;
print "not " unless $matched;
- print "ok ", ++$Tests, " - \"$display_string\" $matched /$B_pattern/$display_upgrade; line $line $display_locale\n";
+ $matched_text = ($matched) ? "matched" : "failed to match";
+ print "ok ", ++$Tests, " - \"$display_string\" $matched_text /$B_pattern/$display_upgrade; line $line $display_locale";
+ print " # TODO" if TODO_FAILING_BREAKS && ! $matched;
+ print "\n";
}
}
}
print " correctly matched $should_display[$i]; line $line\n";
} else {
- $matches[$i] = join("", map { sprintf "\\x{%04X}", $_ }
+ $matches[$i] = join("", map { sprintf "\\x{%04X}", ord $_ }
split "", $matches[$i]);
- print "not ok $Tests - In \"$display_string\" =~ /(\\X)/g, \\X #",
+ print "not ok $Tests -";
+ print " # TODO" if TODO_FAILING_BREAKS;
+ print " In \"$display_string\" =~ /(\\X)/g, \\X #",
$i + 1,
" should have matched $should_display[$i]",
" but instead matched $matches[$i]",
if (@matches == @should_match) {
print "ok $Tests - Nothing was left over; line $line\n";
} else {
- print "not ok $Tests - There were ", scalar @should_match, " \\X matches expected, but got ", scalar @matches, " instead; line $line\n";
+ print "not ok $Tests - There were ", scalar @should_match, " \\X matches expected, but got ", scalar @matches, " instead; line $line";
+ print " # TODO" if TODO_FAILING_BREAKS;
+ print "\n";
}
}
_test_break(shift, 'gcb');
}
+sub Test_LB($) {
+ _test_break(shift, 'lb');
+}
+
sub Test_SB($) {
_test_break(shift, 'sb');
}
exit($Fails ? -1 : 0);
}
-Error('\p{Script=InGreek}'); # Bug #69018
-Test_GCB("1100 $nobreak 1161"); # Bug #70940
-Expect(0, 0x2028, '\p{Print}', ""); # Bug # 71722
-Expect(0, 0x2029, '\p{Print}', ""); # Bug # 71722
-Expect(1, 0xFF10, '\p{XDigit}', ""); # Bug # 71726
https://perl5.git.perl.org / perl5.git / blobdiff