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 = v11.0.0;
+
##########################################################################
#
# mktables -- create the runtime Perl Unicode files (lib/unicore/.../*.pl),
# each one of the tens of thousands individually.
#
# In a match table, the value of a range is irrelevant (and hence the type as
-# well, which will always be 0), and arbitrarily set to the null string.
+# well, which will always be 0), and arbitrarily set to the empty string.
# Using the example above, there would be two match tables for those two
# entries, one named Upper would contain the 0x41..0x5A range, and the other
# named Lower would contain 0x61..0x7A.
#
# 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");
#
# by the code points introduced in the later version. You probably also want
# 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
-# structrue. Then, switching to a unicore with the ending release, change the
-# 0 in the $string_compare_versions definition just below to a string
+# structure. Then, switching to a unicore with the ending release, change the
+# "" 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
# common to both releases, and you can see the changes caused just by the
# underlying release semantic changes. For versions earlier than 3.2, you
# must copy a version of DAge.txt into the directory.
-my $string_compare_versions = DEBUG && 0; # e.g., "2.1";
+my $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;
'Canonical_Combining_Class=Attached_Below_Left'
}
+# Obsoleted
+if ($v_version ge v11.0.0) {
+ push @tables_that_may_be_empty, qw(
+ Grapheme_Cluster_Break=E_Base
+ Grapheme_Cluster_Break=E_Base_GAZ
+ Grapheme_Cluster_Break=E_Modifier
+ Grapheme_Cluster_Break=Glue_After_Zwj
+ Word_Break=E_Base
+ Word_Break=E_Base_GAZ
+ Word_Break=E_Modifier
+ Word_Break=Glue_After_Zwj);
+}
+
# Enum values for to_output_map() method in the Map_Table package. (0 is don't
# output)
my $EXTERNAL_MAP = 1;
my $why_no_expand = "Deprecated by Unicode. These are characters that expand to more than one character in the specified normalization form, but whether they actually take up more bytes or not depends on the encoding being used. For example, a UTF-8 encoded character may expand to a different number of bytes than a UTF-32 encoded character.";
%why_deprecated = (
- 'Grapheme_Link' => 'Deprecated by Unicode: Duplicates ccc=vr (Canonical_Combining_Class=Virama)',
+ 'Grapheme_Link' => 'Duplicates ccc=vr (Canonical_Combining_Class=Virama)',
'Jamo_Short_Name' => $contributory,
- 'Line_Break=Surrogate' => 'Deprecated by Unicode because surrogates should never appear in well-formed text, and therefore shouldn\'t be the basis for line breaking',
+ 'Line_Break=Surrogate' => 'Surrogates should never appear in well-formed text, and therefore shouldn\'t be the basis for line breaking',
'Other_Alphabetic' => $contributory,
'Other_Default_Ignorable_Code_Point' => $contributory,
'Other_Grapheme_Extend' => $contributory,
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 above-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
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 $MIN_FRACTION_LENGTH = 3; # How many digits of a floating point number at
- # the minimum before we consider it equivalent to a
- # candidate rational
-my $MAX_FLOATING_SLOP = 10 ** - $MIN_FRACTION_LENGTH; # And in floating terms
+my $E_FLOAT_PRECISION = 2; # The minimum number of digits after the decimal
+ # point of a normalized floating point number
+ # needed to match before we consider it equivalent
+ # to a candidate rational
# These store references to certain commonly used property objects
my $age;
my $DI; # Default_Ignorable_Code_Point property
my $NChar; # Noncharacter_Code_Point property
my $script;
+my $scx; # Script_Extensions property
# Are there conflicting names because of beginning with 'In_', or 'Is_'
my $has_In_conflicts = 0;
$viacode[$i] = $perl_charname->value_of($i) || "";
$age[$i] = (defined $age)
- ? (($age->value_of($i) =~ / ^ \d \. \d $ /x)
+ ? (($age->value_of($i) =~ / ^ \d+ \. \d+ $ /x)
? $age->value_of($i)
: "")
: "";
# 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.
#
# 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
# 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;
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 /^$/;
main::set_access('end', \%end, 'r', 's');
my %value;
- main::set_access('value', \%value, 'r');
+ main::set_access('value', \%value, 'r', 's');
my %type;
main::set_access('type', \%type, 'r');
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;
}
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
# Accessors for the underlying list that should fail if locked.
for my $sub (qw(
add_duplicate
+ replace_map
))
{
no strict "refs";
# version. But manual intervention to decide what the actual behavior
# should be may be required should this happen. The introductory comments
# have more to say about this.
+#
+# 4) Definition. This is a string for human consumption that specifies the
+# code points that this table matches. This is used only for the generated
+# pod file. It may be specified explicitly, or automatically computed.
+# Only the first portion of complicated definitions is computed and
+# displayed.
sub standardize { return main::standardize($_[0]); }
sub trace { return main::trace(@_); }
# none.
main::set_access('complement', \%complement, 'r');
+ my %definition;
+ # Human readable string of the first few ranges of code points matched by
+ # this table
+ main::set_access('definition', \%definition, 'r', 's');
+
sub new {
my $class = shift;
my $initialize = delete $args{'Initialize'};
my $matches_all = delete $args{'Matches_All'} || 0;
my $format = delete $args{'Format'};
+ my $definition = delete $args{'Definition'} // "";
# Rest of parameters passed on.
my $range_list = Range_List->new(Initialize => $initialize,
$leader{$addr} = $self;
$parent{$addr} = $self;
$complement{$addr} = 0;
+ $definition{$addr} = $definition;
if (defined $format && $format ne $EMPTY_FORMAT) {
Carp::my_carp_bug("'Format' must be '$EMPTY_FORMAT' in a match table instead of '$format'. Using '$EMPTY_FORMAT'");
# 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 {
# disambiguate with).
if (defined $conflicting_object) {
foreach my $alias ($self->aliases) {
- if ($alias->name eq $conflicting_name) {
+ if (standardize($alias->name) eq standardize($conflicting_name)) {
# Here, there is an exact match. This results in
# ambiguous comments, so disambiguate by changing the
# add_alias()
# instead for same
# property
- && ! $other->perl_extension)
+ && ! $other->perl_extension
+
+ # We allow the sc and scx properties to be marked as
+ # related. They are in fact related, and this allows
+ # the pod to show that better. This test isn't valid
+ # if this is an early Unicode release without the scx
+ # property (having that also implies the sc property
+ # exists, so don't have to test for no 'sc')
+ && ( ! defined $scx
+ && ! ( ( $self->property == $script
+ || $self->property == $scx)
+ && ( $self->property == $script
+ || $self->property == $scx))))
{
Carp::my_carp_bug("set_equivalent_to should have 'Related => 0 for equivalencing two Unicode properties. Assuming $self is not related to $other");
$related = 0;
}
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;
}
return;
}
+ sub calculate_table_definition
+ {
+ # Returns a human-readable string showing some or all of the code
+ # points matched by this table. The string will include a
+ # bracketed-character class for all characters matched in the 00-FF
+ # range, and the first few ranges matched beyond that.
+ my $max_ranges = 6;
+
+ my $self = shift;
+ my $definition = $self->definition || "";
+
+ # Skip this if already have a definition.
+ return $definition if $definition;
+
+ my $lows_string = ""; # The string representation of the 0-FF
+ # characters
+ my $string_range = ""; # The string rep. of the above FF ranges
+ my $range_count = 0; # How many ranges in $string_rage
+
+ my @lows_invlist; # The inversion list of the 0-FF code points
+ my $first_non_control = ord(" "); # Everything below this is a
+ # control, on ASCII or EBCDIC
+ my $max_table_code_point = $self->max;
+
+ # On ASCII platforms, the range 80-FF contains no printables.
+ my $highest_printable = ((main::NON_ASCII_PLATFORM) ? 255 : 126);
+
+
+ # Look through the first few ranges matched by this table.
+ $self->reset_each_range; # Defensive programming
+ while (defined (my $range = $self->each_range())) {
+ my $start = $range->start;
+ my $end = $range->end;
+
+ # Accumulate an inversion list of the 00-FF code points
+ if ($start < 256 && ($start > 0 || $end < 256)) {
+ push @lows_invlist, $start;
+ push @lows_invlist, 1 + (($end < 256) ? $end : 255);
+
+ # Get next range if there are more ranges below 256
+ next if $end < 256 && $end < $max_table_code_point;
+
+ # If the range straddles the 255/256 boundary, we split it
+ # there. We already added above the low portion to the
+ # inversion list
+ $start = 256 if $end > 256;
+ }
+
+ # Here, @lows_invlist contains the code points below 256, and
+ # there is no other range, or the current one starts at or above
+ # 256. Generate the [char class] for the 0-255 ones.
+ while (@lows_invlist) {
+
+ # If this range (necessarily the first one, by the way) starts
+ # at 0 ...
+ if ($lows_invlist[0] == 0) {
+
+ # If it ends within the block of controls, that means that
+ # some controls are in it and some aren't. Since Unicode
+ # properties pretty much only know about a few of the
+ # controls, like \n, \t, this means that its one of them
+ # that isn't in the range. Complement the inversion list
+ # which will likely cause these to be output using their
+ # mnemonics, hence being clearer.
+ if ($lows_invlist[1] < $first_non_control) {
+ $lows_string .= '^';
+ shift @lows_invlist;
+ push @lows_invlist, 256;
+ }
+ elsif ($lows_invlist[1] <= $highest_printable) {
+
+ # Here, it extends into the printables block. Split
+ # into two ranges so that the controls are separate.
+ $lows_string .= sprintf "\\x00-\\x%02x",
+ $first_non_control - 1;
+ $lows_invlist[0] = $first_non_control;
+ }
+ }
+
+ # If the range completely contains the printables, don't
+ # individually spell out the printables.
+ if ( $lows_invlist[0] <= $first_non_control
+ && $lows_invlist[1] > $highest_printable)
+ {
+ $lows_string .= sprintf "\\x%02x-\\x%02x",
+ $lows_invlist[0], $lows_invlist[1] - 1;
+ shift @lows_invlist;
+ shift @lows_invlist;
+ next;
+ }
+
+ # Here, the range may include some but not all printables.
+ # Look at each one individually
+ foreach my $ord (shift @lows_invlist .. shift(@lows_invlist) - 1) {
+ my $char = chr $ord;
+
+ # If there is already something in the list, an
+ # alphanumeric char could be the next in sequence. If so,
+ # we start or extend a range. That is, we could have so
+ # far something like 'a-c', and the next char is a 'd', so
+ # we change it to 'a-d'. We use native_to_unicode()
+ # because a-z on EBCDIC means 26 chars, and excludes the
+ # gap ones.
+ if ($lows_string ne "" && $char =~ /[[:alnum:]]/) {
+ my $prev = substr($lows_string, -1);
+ if ( $prev !~ /[[:alnum:]]/
+ || utf8::native_to_unicode(ord $prev) + 1
+ != utf8::native_to_unicode(ord $char))
+ {
+ # Not extending the range
+ $lows_string .= $char;
+ }
+ elsif ( length $lows_string > 1
+ && substr($lows_string, -2, 1) eq '-')
+ {
+ # We had a sequence like '-c' and the current
+ # character is 'd'. Extend the range.
+ substr($lows_string, -1, 1) = $char;
+ }
+ else {
+ # We had something like 'd' and this is 'e'.
+ # Start a range.
+ $lows_string .= "-$char";
+ }
+ }
+ elsif ($char =~ /[[:graph:]]/) {
+
+ # We output a graphic char as-is, preceded by a
+ # backslash if it is a metacharacter
+ $lows_string .= '\\'
+ if $char =~ /[\\\^\$\@\%\|()\[\]\{\}\-\/"']/;
+ $lows_string .= $char;
+ } # Otherwise use mnemonic for any that have them
+ elsif ($char =~ /[\a]/) {
+ $lows_string .= '\a';
+ }
+ elsif ($char =~ /[\b]/) {
+ $lows_string .= '\b';
+ }
+ elsif ($char eq "\e") {
+ $lows_string .= '\e';
+ }
+ elsif ($char eq "\f") {
+ $lows_string .= '\f';
+ }
+ elsif ($char eq "\cK") {
+ $lows_string .= '\cK';
+ }
+ elsif ($char eq "\n") {
+ $lows_string .= '\n';
+ }
+ elsif ($char eq "\r") {
+ $lows_string .= '\r';
+ }
+ elsif ($char eq "\t") {
+ $lows_string .= '\t';
+ }
+ else {
+
+ # Here is a non-graphic without a mnemonic. We use \x
+ # notation. But if the ordinal of this is one above
+ # the previous, create or extend the range
+ my $hex_representation = sprintf("%02x", ord $char);
+ if ( length $lows_string >= 4
+ && substr($lows_string, -4, 2) eq '\\x'
+ && hex(substr($lows_string, -2)) + 1 == ord $char)
+ {
+ if ( length $lows_string >= 5
+ && substr($lows_string, -5, 1) eq '-'
+ && ( length $lows_string == 5
+ || substr($lows_string, -6, 1) ne '\\'))
+ {
+ substr($lows_string, -2) = $hex_representation;
+ }
+ else {
+ $lows_string .= '-\\x' . $hex_representation;
+ }
+ }
+ else {
+ $lows_string .= '\\x' . $hex_representation;
+ }
+ }
+ }
+ }
+
+ # Done with assembling the string of all lows. If there are only
+ # lows in the property, are completely done.
+ if ($max_table_code_point < 256) {
+ $self->reset_each_range;
+ last;
+ }
+
+ # Otherwise, quit if reached max number of non-lows ranges. If
+ # there are lows, count them as one unit towards the maximum.
+ $range_count++;
+ if ($range_count > (($lows_string eq "") ? $max_ranges : $max_ranges - 1)) {
+ $string_range .= " ...";
+ $self->reset_each_range;
+ last;
+ }
+
+ # Otherwise add this range.
+ $string_range .= ", " if $string_range ne "";
+ if ($start == $end) {
+ $string_range .= sprintf("U+%04X", $start);
+ }
+ elsif ($end >= $MAX_WORKING_CODEPOINT) {
+ $string_range .= sprintf("U+%04X..infinity", $start);
+ }
+ else {
+ $string_range .= sprintf("U+%04X..%04X",
+ $start, $end);
+ }
+ }
+
+ # Done with all the ranges we're going to look at. Assemble the
+ # definition from the lows + non-lows.
+
+ if ($lows_string ne "" || $string_range ne "") {
+ if ($lows_string ne "") {
+ $definition .= "[$lows_string]";
+ $definition .= ", " if $string_range;
+ }
+ $definition .= $string_range;
+ }
+
+ return $definition;
+ }
+
sub write {
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
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},
containing_range
count
default_map
+ definition
delete_range
description
each_range
range_count
ranges
range_size_1
+ replace_map
reset_each_range
set_comment
set_default_map
);
}
-
# Add any explicit cjk values
$file->insert_lines(@cjk_property_values);
. $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'
my $rational = shift;
my $float = eval $rational;
+ $float = sprintf "%.*e", $E_FLOAT_PRECISION, $float;
+
+ # Strip off any leading zeros beyond 2 digits to make it C99 compliant.
+ # (Windows has 3 digit exponents, contrary to C99)
+ $float =~ s/ ( .* e [-+] ) 0* ( \d{2,}? ) /$1$2/x;
+
+ if ( defined $nv_floating_to_rational{$float}
+ && $nv_floating_to_rational{$float} ne $rational)
+ {
+ die Carp::my_carp_bug("Both '$rational' and"
+ . " '$nv_floating_to_rational{$float}' evaluate to"
+ . " the same floating point number."
+ . " \$E_FLOAT_PRECISION must be increased");
+ }
$nv_floating_to_rational{$float} = $rational;
return;
}
# The Script_Extensions property starts out with a clone of the Script
# property.
- my $scx = property_ref("Script_Extensions");
- $scx = Property->new("scx", Full_Name => "Script_Extensions")
- if ! defined $scx;
+ $scx = property_ref("Script_Extensions");
+ return unless defined $scx;
+
$scx->_set_format($STRING_WHITE_SPACE_LIST);
$scx->initialize($script);
$scx->set_default_map($script->default_map);
return;
}
+sub setup_emojidata {
+ my $prop_ref = Property->new('XPG',
+ Full_Name => 'Extended_Pictographic',
+ );
+ $prop_ref->set_fate($PLACEHOLDER,
+ "Not part of the Unicode Character Database");
+}
+
+sub filter_emojidata_line {
+ # We only are interested in this single property from this non-UCD data
+ # file, and we turn it into a Perl property, so that it isn't accessible
+ # to the users
+
+ $_ = "" unless /\bExtended_Pictographic\b/;
+
+ return;
+}
+
sub generate_hst {
# Populates the Hangul Syllable Type property from first principles
my ($range, $script, @remainder)
= split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields
- my @words = split "_", $script;
+ my @words = split /[_-]/, $script;
for my $word (@words) {
$word =
ucfirst(lc($word)) if $word ne 'CJK';
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,
# data is retained in the map table for reference, but the spurious match
# tables are deleted.
- my $scx = property_ref("Script_Extensions");
if (defined $scx) {
foreach my $table ($scx->tables) {
next unless $table->name =~ /\s/; # All the new and only the new
}
$scx->delete_match_table($table);
}
+
+ # Mark the scx table as the parent of the corresponding sc table for
+ # those which are identical. This causes the pod for the script table
+ # to refer to the corresponding scx one.
+ #
+ # This has to be in a separate loop from above, so as to wait until
+ # the tables are stabilized before checking for equivalency.
+ if (defined $pod_directory) {
+ foreach my $table ($scx->tables) {
+ my $plain_sc_equiv = $script->table($table->name);
+ if ($table->matches_identically_to($plain_sc_equiv)) {
+ $plain_sc_equiv->set_equivalent_to($table, Related => 1);
+ }
+ }
+ }
}
return;
# 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 $table->name le $string_compare_versions;
+ next if version->parse($table->name)
+ le version->parse($string_compare_versions);
$delta += $table;
}
if ($delta->is_empty) {
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 $Any = $perl->add_match_table('Any',
- Description => "All Unicode code points: [\\x{0000}-\\x{$MAX_UNICODE_CODEPOINT_STRING}]",
- );
+ Description => "All Unicode code points");
$Any->add_range(0, $MAX_UNICODE_CODEPOINT);
$Any->add_alias('Unicode');
calculate_Assigned();
- # Our internal-only property should be treated as more than just a
- # synonym; grandfather it in to the pod.
- $perl->add_match_table('_CombAbove', Re_Pod_Entry => 1,
- Fate => $INTERNAL_ONLY, Status => $DISCOURAGED)
- ->set_equivalent_to(property_ref('ccc')->table('Above'),
- Related => 1);
-
- my $ASCII = $perl->add_match_table('ASCII', Description => '[[:ASCII:]]');
+ my $ASCII = $perl->add_match_table('ASCII');
if (defined $block) { # This is equivalent to the block if have it.
my $Unicode_ASCII = $block->table('Basic_Latin');
if (defined $Unicode_ASCII && ! $Unicode_ASCII->is_empty) {
$Lower += $temp & $Assigned;
}
my $Posix_Lower = $perl->add_match_table("PosixLower",
- Description => "[a-z]",
Initialize => $Lower & $ASCII,
);
$Upper->add_range(0x24B6, 0x24CF); # Circled Latin upper case letters
}
my $Posix_Upper = $perl->add_match_table("PosixUpper",
- Description => "[A-Z]",
Initialize => $Upper & $ASCII,
);
$Lower->set_caseless_equivalent($cased);
}
- # Similarly, set up our own Case_Ignorable property if this Unicode
- # version doesn't have it. From Unicode 5.1: Definition D121: A character
- # C is defined to be case-ignorable if C has the value MidLetter or the
- # value MidNumLet for the Word_Break property or its General_Category is
- # one of Nonspacing_Mark (Mn), Enclosing_Mark (Me), Format (Cf),
- # Modifier_Letter (Lm), or Modifier_Symbol (Sk).
-
- # Perl has long had an internal-only alias for this property; grandfather
- # it in to the pod, but discourage its use.
- my $perl_case_ignorable = $perl->add_match_table('_Case_Ignorable',
- Re_Pod_Entry => 1,
- Fate => $INTERNAL_ONLY,
- Status => $DISCOURAGED);
- my $case_ignorable = property_ref('Case_Ignorable');
- if (defined $case_ignorable && ! $case_ignorable->is_empty) {
- $perl_case_ignorable->set_equivalent_to($case_ignorable->table('Y'),
- Related => 1);
- }
- else {
-
- $perl_case_ignorable->initialize($gc->table('Mn') + $gc->table('Lm'));
-
- # The following three properties are not in early releases
- $perl_case_ignorable += $gc->table('Me') if defined $gc->table('Me');
- $perl_case_ignorable += $gc->table('Cf') if defined $gc->table('Cf');
- $perl_case_ignorable += $gc->table('Sk') if defined $gc->table('Sk');
-
- # For versions 4.1 - 5.0, there is no MidNumLet property, and
- # correspondingly the case-ignorable definition lacks that one. For
- # 4.0, it appears that it was meant to be the same definition, but was
- # inadvertently omitted from the standard's text, so add it if the
- # property actually is there
- my $wb = property_ref('Word_Break');
- if (defined $wb) {
- my $midlet = $wb->table('MidLetter');
- $perl_case_ignorable += $midlet if defined $midlet;
- my $midnumlet = $wb->table('MidNumLet');
- $perl_case_ignorable += $midnumlet if defined $midnumlet;
- }
- else {
-
- # In earlier versions of the standard, instead of the above two
- # properties , just the following characters were used:
- $perl_case_ignorable +=
- ord("'")
- + utf8::unicode_to_native(0xAD) # SOFT HYPHEN (SHY)
- + 0x2019; # RIGHT SINGLE QUOTATION MARK
- }
- }
-
# The remaining perl defined tables are mostly based on Unicode TR 18,
# "Annex C: Compatibility Properties". All of these have two versions,
# one whose name generally begins with Posix that is posix-compliant, and
$Alpha->add_alias('Alphabetic');
}
my $Posix_Alpha = $perl->add_match_table("PosixAlpha",
- Description => "[A-Za-z]",
Initialize => $Alpha & $ASCII,
);
$Posix_Upper->set_caseless_equivalent($Posix_Alpha);
Initialize => $Alpha + $gc->table('Decimal_Number'),
);
$perl->add_match_table("PosixAlnum",
- Description => "[A-Za-z0-9]",
Initialize => $Alnum & $ASCII,
);
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
# This is a Perl extension, so the name doesn't begin with Posix.
my $PerlWord = $perl->add_match_table('PosixWord',
- Description => '\w, restricted to ASCII = [A-Za-z0-9_]',
+ Description => '\w, restricted to ASCII',
Initialize => $Word & $ASCII,
);
$PerlWord->add_alias('PerlWord');
);
$Blank->add_alias('HorizSpace'); # Another name for it.
$perl->add_match_table("PosixBlank",
- Description => "\\t and ' '",
Initialize => $Blank & $ASCII,
);
$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)",
Initialize => $Space & $ASCII,
);
$Posix_space->add_alias('PerlSpace'); # A pre-existing synonym
Description => 'Control characters');
$Cntrl->set_equivalent_to($gc->table('Cc'), Related => 1);
$perl->add_match_table("PosixCntrl",
- Description => "ASCII control characters: NUL, SOH, STX, ETX, EOT, ENQ, ACK, BEL, BS, HT, LF, VT, FF, CR, SO, SI, DLE, DC1, DC2, DC3, DC4, NAK, SYN, ETB, CAN, EOM, SUB, ESC, FS, GS, RS, US, and DEL",
+ Description => "ASCII control characters",
+ Definition => "ACK, BEL, BS, CAN, CR, DC1, DC2,"
+ . " DC3, DC4, DEL, DLE, ENQ, EOM,"
+ . " EOT, ESC, ETB, ETX, FF, FS, GS,"
+ . " HT, LF, NAK, NUL, RS, SI, SO,"
+ . " SOH, STX, SUB, SYN, US, VT",
Initialize => $Cntrl & $ASCII,
);
Initialize => ~ ($Space + $controls),
);
$perl->add_match_table("PosixGraph",
- Description =>
- '[-!"#$%&\'()*+,./:;<=>?@[\\\]^_`{|}~0-9A-Za-z]',
Initialize => $Graph & $ASCII,
);
Initialize => $Blank + $Graph - $gc->table('Control'),
);
$perl->add_match_table("PosixPrint",
- Description =>
- '[- 0-9A-Za-z!"#$%&\'()*+,./:;<=>?@[\\\]^_`{|}~]',
Initialize => $print & $ASCII,
);
Perl_Extension => 1
);
$perl->add_match_table('PosixPunct', Perl_Extension => 1,
- Description => '[-!"#$%&\'()*+,./:;<=>?@[\\\]^_`{|}~]',
Initialize => $ASCII & $XPosixPunct,
);
Description => '[0-9] + all other decimal digits');
$Digit->set_equivalent_to($gc->table('Decimal_Number'), Related => 1);
my $PosixDigit = $perl->add_match_table("PosixDigit",
- Description => '[0-9]',
Initialize => $Digit & $ASCII,
);
ord('A') .. ord('F'),
ord('a') .. ord('f'),
0xFF10..0xFF19, 0xFF21..0xFF26, 0xFF41..0xFF46]);
- $Xdigit->add_description('[0-9A-Fa-f] and corresponding fullwidth versions, like U+FF10: FULLWIDTH DIGIT ZERO');
}
# AHex was not present in early releases
$PosixXDigit->add_alias('AHex');
$PosixXDigit->add_alias('Ascii_Hex_Digit');
}
- $PosixXDigit->add_description('[0-9A-Fa-f]');
my $any_folds = $perl->add_match_table("_Perl_Any_Folds",
Description => "Code points that particpate in some fold",
Note => 'Union of all non-canonical decompositions',
);
- # _CanonDCIJ is equivalent to Soft_Dotted, but if on a release earlier
- # than SD appeared, construct it ourselves, based on the first release SD
- # was in. A pod entry is grandfathered in for it
- my $CanonDCIJ = $perl->add_match_table('_CanonDCIJ', Re_Pod_Entry => 1,
- Perl_Extension => 1,
- Fate => $INTERNAL_ONLY,
- Status => $DISCOURAGED);
- my $soft_dotted = property_ref('Soft_Dotted');
- if (defined $soft_dotted && ! $soft_dotted->is_empty) {
- $CanonDCIJ->set_equivalent_to($soft_dotted->table('Y'), Related => 1);
- }
- else {
-
- # This list came from 3.2 Soft_Dotted; all of these code points are in
- # all releases
- $CanonDCIJ->initialize([ ord('i'),
- ord('j'),
- 0x012F,
- 0x0268,
- 0x0456,
- 0x0458,
- 0x1E2D,
- 0x1ECB,
- ]);
- $CanonDCIJ = $CanonDCIJ & $Assigned;
- }
-
# For backward compatibility, Perl has its own definition for IDStart.
# It is regular XID_Start plus the underscore, but all characters must be
# Word characters as well
+ ord("(")
+ ord(")")
+ ord("-")
- + utf8::unicode_to_native(0xA0) # NBSP
);
my @composition = ('Name', 'Unicode_1_Name', '_Perl_Name_Alias');
. $current_age->name
. ' or earlier',
);
+ foreach my $alias ($current_age->aliases) {
+ $current_in->add_alias($alias->name);
+ }
$previous_in = $current_in;
# Add clarifying material for the corresponding age file. This is
}
# 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.)
+ # adjacent spaces into separate words. Unicode 11.0 moved in that
+ # direction, but left TAB, FIGURE SPACE (U+2007), and (ironically) NO
+ # BREAK SPACE as breaking, so we retained the original Perl customization.
+ # To do this, in the Perl copy of WB, simply replace the mappings of
+ # horizontal space characters that otherwise would map to the default or
+ # the 11.0 'WSegSpace' to instead map to our tailoring.
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;
+ my $value = $perl_wb->value_of($i);
+
+ next unless $value eq $default || $value eq 'WSegSpace';
$perl_wb->add_map($i, $i, 'Perl_Tailored_HSpace',
Replace => $UNCONDITIONALLY);
}
}
+ # Also starting in Unicode 11.0, rules for some of the boundary types are
+ # based on a non-UCD property (which we have read in if it exists).
+ # Recall that these boundary properties partition the code points into
+ # equivalence classes (represented as enums).
+ #
+ # The loop below goes through each code point that matches the non-UCD
+ # property, and for each current equivalence class containing such a code
+ # point, splits it so that those that are in both are now in a newly
+ # created equivalence class whose name is a combination of the property
+ # and the old class name, leaving unchanged everything that doesn't match
+ # the non-UCD property.
+ my $pictographic_emoji = property_ref('XPG');
+ if (defined $pictographic_emoji) {
+ foreach my $base_property (property_ref('GCB'),
+ property_ref('WB'))
+ {
+ my $property = property_ref('_Perl_' . $base_property->name);
+ foreach my $range ($pictographic_emoji->table('Y')->ranges) {
+ foreach my $i ($range->start .. $range->end) {
+ my $current = $property->value_of($i);
+ $current = $property->table($current)->short_name;
+ $property->add_map($i, $i, 'XPG_' . $current,
+ 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.
}
}
+ # This property is a modification of the scx property
+ my $perl_scx = Property->new('_Perl_SCX',
+ Fate => $INTERNAL_ONLY,
+ Perl_Extension => 1,
+ Directory => $map_directory,
+ Type => $ENUM);
+ my $source;
+
+ # Use scx if available; otherwise sc; if neither is there (a very old
+ # Unicode version, just say that everything is 'Common'
+ if (defined $scx) {
+ $source = $scx;
+ $perl_scx->set_default_map('Unknown');
+ }
+ elsif (defined $script) {
+ $source = $script;
+
+ # Early versions of 'sc', had everything be 'Common'
+ if (defined $script->table('Unknown')) {
+ $perl_scx->set_default_map('Unknown');
+ }
+ else {
+ $perl_scx->set_default_map('Common');
+ }
+ } else {
+ $perl_scx->add_match_table('Common');
+ $perl_scx->add_map(0, $MAX_UNICODE_CODEPOINT, 'Common');
+
+ $perl_scx->add_match_table('Unknown');
+ $perl_scx->set_default_map('Unknown');
+ }
+
+ $perl_scx->_set_format($STRING_WHITE_SPACE_LIST);
+ $perl_scx->set_pre_declared_maps(0); # PropValueAliases doesn't list these
+
+ if (defined $source) {
+ $perl_scx->initialize($source);
+
+ # UTS 39 says that the scx property should be modified for these
+ # countries where certain mixed scripts are commonly used.
+ for my $range ($perl_scx->ranges) {
+ my $value = $range->value;
+ my $changed = $value =~ s/ ( \b Han i? \b ) /$1 Hanb Jpan Kore/xi;
+ $changed |= $value =~ s/ ( \b Hira (gana)? \b ) /$1 Jpan/xi;
+ $changed |= $value =~ s/ ( \b Kata (kana)? \b ) /$1 Jpan/xi;
+ $changed |= $value =~ s{ ( \b Katakana_or_Hiragana \b ) }
+ {$1 Katakana Hiragana Jpan}xi;
+ $changed |= $value =~ s/ ( \b Hang (ul)? \b ) /$1 Kore/xi;
+ $changed |= $value =~ s/ ( \b Bopo (mofo)? \b ) /$1 Hanb/xi;
+
+ if ($changed) {
+ $value = join " ", uniques split " ", $value;
+ $range->set_value($value)
+ }
+ }
+
+ foreach my $table ($source->tables) {
+ my $scx_table = $perl_scx->add_match_table($table->name,
+ Full_Name => $table->full_name);
+ foreach my $alias ($table->aliases) {
+ $scx_table->add_alias($alias->name);
+ }
+ }
+ }
+
# Here done with all the basic stuff. Ready to populate the information
# about each character if annotating them.
if ($annotate) {
# 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
+ 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;
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.
$unicode_count = $count;
$non_unicode_string = "";
}
+
my $string_count = clarify_number($unicode_count) . $non_unicode_string;
+
+ my $definition = $input_table->calculate_table_definition;
+ if ($definition) {
+
+ # Save the definition for later use.
+ $input_table->set_definition($definition);
+
+ $definition = ": $definition";
+ }
+
my $status = $input_table->status;
my $status_info = $input_table->status_info;
my $caseless_equivalent = $input_table->caseless_equivalent;
if ($table_property != $perl && $table->perl_extension) {
push @info, '(Perl extension)';
}
- push @info, "($string_count)";
+ my $definition = $table->definition // "";
+ $definition = "" if $entry_for_first_alias;
+ $definition = ": $definition" if $definition;
+ push @info, "($string_count$definition)";
# Now, we have both the entry and info so add them to the
# list of all the properties.
: $table->parent->property;
my $perl_extension = $table->perl_extension;
+ my $is_perl_extension_match_table_but_not_dollar_perl
+ = $property != $perl
+ && $perl_extension
+ && $property != $table;
# Get the more official name for for perl extensions that aren't
# stand-alone properties
- if ($perl_extension && $property != $table) {
- if ($property == $perl ||$property->type == $BINARY) {
- $meaning = $table->complete_name;
+ if ($is_perl_extension_match_table_but_not_dollar_perl) {
+ if ($property->type == $BINARY) {
+ $meaning = $property->full_name;
}
else {
- $meaning = $property->full_name . "=$full_name";
+ $meaning = $table->parent->complete_name;
}
}
# There are three types of info column. One for the short name, one for
# the full name, and one for everything else. They mostly are the same,
# so initialize in the same loop.
+
foreach my $info_ref (\$full_info, \$short_info, \$other_info) {
- if ($perl_extension && $property != $table) {
+ if ($info_ref != \$full_info) {
+
+ # The non-full name columns include the full name
+ $$info_ref .= $full_name;
+ }
+
+
+ if ($is_perl_extension_match_table_but_not_dollar_perl) {
# Add the synonymous name for the non-full name entries; and to
# the full-name entry if it adds extra information
- if ($info_ref == \$other_info
- || ($info_ref == \$short_info
- && $standard_short_name ne $standard_full_name)
- || standardize($meaning) ne $standard_full_name
- ) {
- $$info_ref .= "$meaning.";
+ if ( standardize($meaning) ne $standard_full_name
+ || $info_ref == \$other_info
+ || $info_ref == \$short_info)
+ {
+ my $parenthesized = $info_ref != \$full_info;
+ $$info_ref .= " " if $$info_ref && $parenthesized;
+ $$info_ref .= "(=" if $parenthesized;
+ $$info_ref .= "$meaning";
+ $$info_ref .= ")" if $parenthesized;
+ $$info_ref .= ".";
}
}
- elsif ($info_ref != \$full_info) {
-
- # Otherwise, the non-full name columns include the full name
- $$info_ref .= $full_name;
- }
# And the full-name entry includes the short name, if shorter
if ($info_ref == \$full_info
}
}
+ my $definition;
+ my $definition_table;
+ my $type = $table->property->type;
+ if ($type == $BINARY || $type == $FORCED_BINARY) {
+ $definition_table = $table->property->table('Y');
+ }
+ elsif ($table->isa('Match_Table')) {
+ $definition_table = $table;
+ }
+
+ $definition = $definition_table->calculate_table_definition
+ if defined $definition_table
+ && $definition_table != 0;
+
# Add any extra annotations to the full name entry
foreach my $more_info ($table->description,
+ $definition,
$table->note,
$table->status_info)
{
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;
return -1
}
- # Determine if the two operands are numeric property values or not.
- # A numeric property will look like xyz: 3. But the number
- # can begin with an optional minus sign, and may have a
- # fraction or rational component, like xyz: 3/2. If either
- # isn't numeric, use alphabetic sort.
- my ($a_initial, $a_number) =
- ($a =~ /^ ( [^:=]+ [:=] \s* ) (-? \d+ (?: [.\/] \d+)? )/ix);
- return $a cmp $b unless defined $a_number;
- my ($b_initial, $b_number) =
- ($b =~ /^ ( [^:=]+ [:=] \s* ) (-? \d+ (?: [.\/] \d+)? )/ix);
- return $a cmp $b unless defined $b_number;
-
- # Here they are both numeric, but use alphabetic sort if the
- # initial parts don't match
- return $a cmp $b if $a_initial ne $b_initial;
+ # Determine if the two operands are compound or not, and if so if are
+ # "numeric" property values or not, like \p{Age: 3.0}. But there are also
+ # things like \p{Canonical_Combining_Class: CCC133} and \p{Age: V10_0},
+ # all of which this considers numeric, and for sorting, looks just at the
+ # numeric parts. It can also be a rational like \p{Numeric Value=-1/2}.
+ my $split_re = qr/
+ ^ ( [^:=]+ ) # $1 is undef if not a compound form, otherwise is the
+ # property name
+ [:=] \s* # The syntax for the compound form
+ (?: # followed by ...
+ ( # $2 gets defined if what follows is a "numeric"
+ # expression, which is ...
+ ( -? \d+ (?: [.\/] \d+)? # An integer, float, or rational
+ # number, optionally signed
+ | [[:alpha:]]{2,} \d+ $ ) # or something like CCC131. Either
+ # of these go into $3
+ | ( V \d+ _ \d+ ) # or a Unicode's Age property version
+ # number, into $4
+ )
+ | .* $ # If not "numeric", accept anything so that $1 gets
+ # defined if it is any compound form
+ ) /ix;
+ my ($a_initial, $a_numeric, $a_number, $a_version) = ($a =~ $split_re);
+ my ($b_initial, $b_numeric, $b_number, $b_version) = ($b =~ $split_re);
+
+ # Sort alphabeticlly on the whole property name if either operand isn't
+ # compound, or they differ.
+ return $a cmp $b if ! defined $a_initial
+ || ! defined $b_initial
+ || $a_initial ne $b_initial;
+
+ if (! defined $a_numeric) {
+
+ # If neither is numeric, use alpha sort
+ return $a cmp $b if ! defined $b_numeric;
+ return 1; # Sort numeric ahead of alpha
+ }
+
+ # Here $a is numeric
+ return -1 if ! defined $b_numeric; # Numeric sorts before alpha
+
+ # Here they are both numeric in the same property.
+ # Convert version numbers into regular numbers
+ if (defined $a_version) {
+ ($a_number = $a_version) =~ s/^V//i;
+ $a_number =~ s/_/./;
+ }
+ else { # Otherwise get rid of the, e.g., CCC in CCC9 */
+ $a_number =~ s/ ^ [[:alpha:]]+ //x;
+ }
+ if (defined $b_version) {
+ ($b_number = $b_version) =~ s/^V//i;
+ $b_number =~ s/_/./;
+ }
+ else {
+ $b_number =~ s/ ^ [[:alpha:]]+ //x;
+ }
# Convert rationals to floating for the comparison.
$a_number = eval $a_number if $a_number =~ qr{/};
$b_number = eval $b_number if $b_number =~ qr{/};
- return $a_number <=> $b_number;
+ return $a_number <=> $b_number || $a cmp $b;
}
sub make_pod () {
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.
$ucd_pod = format_pod_line($indent_info_column, 'NAME', ' INFO')
. "\n"
. $ucd_pod;
+ my $space_hex = sprintf("%02x", ord " ");
local $" = "";
# Everything is ready to assemble.
though not all are enabled by default. The omitted ones are the Unihan
properties (accessible via the CPAN module L<Unicode::Unihan>) and certain
deprecated or Unicode-internal properties. (An installation may choose to
-recompile Perl's tables to change this. See L<Unicode character
+recompile Perl's tables to change this. See L</Unicode character
properties that are NOT accepted by Perl>.)
For most purposes, access to Unicode properties from the Perl core is through
B<Compound forms> consist of two components, separated by an equals sign or a
colon. The first component is the property name, and the second component is
the particular value of the property to match against, for example,
-C<\\p{Script: Greek}> and C<\\p{Script=Greek}> both mean to match characters
-whose Script property value is Greek.
+C<\\p{Script_Extensions: Greek}> and C<\\p{Script_Extensions=Greek}> both mean
+to match characters whose Script_Extensions property value is Greek.
+(C<Script_Extensions> is an improved version of the C<Script> property.)
B<Single forms>, like C<\\p{Greek}>, are mostly Perl-defined shortcuts for
their equivalent compound forms. The table shows these equivalences. (In our
-example, C<\\p{Greek}> is a just a shortcut for C<\\p{Script=Greek}>.)
-There are also a few Perl-defined single forms that are not shortcuts for a
-compound form. One such is C<\\p{Word}>. These are also listed in the table.
+example, C<\\p{Greek}> is a just a shortcut for
+C<\\p{Script_Extensions=Greek}>). There are also a few Perl-defined single
+forms that are not shortcuts for a compound form. One such is C<\\p{Word}>.
+These are also listed in the table.
In parsing these constructs, Perl always ignores Upper/lower case differences
everywhere within the {braces}. Thus C<\\p{Greek}> means the same thing as
are noted as such.
Numbers in (parentheses) indicate the total number of Unicode code points
-matched by the property. For emphasis, those properties that match no code
-points at all are listed as well in a separate section following the table.
+matched by the property. For the entries that give the longest, most
+descriptive version of the property, the count is followed by a list of some
+of the code points matched by it. The list includes all the matched
+characters in the 0-255 range, enclosed in the familiar [brackets] the same as
+a regular expression bracketed character class. Following that, the next few
+higher matching ranges are also given. To avoid visual ambiguity, the SPACE
+character is represented as C<\\x$space_hex>.
+
+For emphasis, those properties that match no code points at all are listed as
+well in a separate section following the table.
Most properties match the same code points regardless of whether C<"/i">
case-insensitive matching is specified or not. But a few properties are
=over 4
-=item *
+=item Z<>B<*> is a wild-card
-B<*> is a wild-card
-
-=item *
-
-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 *
+=item B<$DEPRECATED> means this is deprecated.
-B<$OBSOLETE> means this is obsolete.
+=item B<$OBSOLETE> means this is obsolete.
-=item *
+=item B<$STABILIZED> means this is stabilized.
-B<$STABILIZED> means this is stabilized.
+=item B<$STRICTER> means tighter (stricter) name matching applies.
-=item *
-
-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
name is the property's full name, unless that would simply repeat the first
column, in which case the second column indicates the property's short name
(if different). The annotations are given only in the entry for the full
-name. If a property is obsolete, etc, the entry will be flagged with the same
+name. The annotations for binary properties include a list of the first few
+ranges that the property matches. To avoid any ambiguity, the SPACE character
+is represented as C<\\x$space_hex>.
+
+If a property is obsolete, etc, the entry will be flagged with the same
characters used in the table in the L<section above|/Properties accessible
through \\p{} and \\P{}>, like B<$DEPRECATED> or B<$STABILIZED>.
$nv_floating_to_rational
);
-# If a floating point number doesn't have enough digits in it to get this
-# close to a fraction, it isn't considered to be that fraction even if all the
-# digits it does have match.
-\$utf8::max_floating_slop = $MAX_FLOATING_SLOP;
+# If a %e floating point number doesn't have this number of digits in it after
+# the decimal point to get this close to a fraction, it isn't considered to be
+# that fraction even if all the digits it does have match.
+\$utf8::e_precision = $E_FLOAT_PRECISION;
# Deprecated tables to generate a warning for. The key is the file containing
# the table, so as to avoid duplication, as many property names can map to the
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
- # 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
- # in buckets, so that it is quite likely that if two
- # tables are in the same bucket they will be identical, so
- # don't have to compare tables frequently. The tables
- # have to have the same status to share a file, so add
- # this to the bucket hash. (The reason for this latter is
- # that Heavy.pl associates a status with a file.)
- # We don't check tables that are inverses of others, as it
- # would lead to some coding complications, and checking
- # all the regular ones should find everything.
+ # See if the table matches identical code points with
+ # something that has already been processed and is ready
+ # for 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 in buckets, so that it is
+ # quite likely that if two tables are in the same bucket
+ # they will be identical, so don't have to compare tables
+ # frequently. The tables have to have the same status to
+ # share a file, so add this to the bucket hash. (The
+ # reason for this latter is that Heavy.pl associates a
+ # status with a file.) We don't check tables that are
+ # inverses of others, as it would lead to some coding
+ # complications, and checking all the regular ones should
+ # find everything.
if ($table->complement == 0) {
my $hash = $table->hash . ';' . $table->status;
foreach my $comparison
(@{$match_tables_to_write{$hash}})
{
- if ($table->matches_identically_to($comparison)) {
+ # If the table doesn't point back to this one, we
+ # see if it matches identically
+ if ( $comparison->leader != $table
+ && $table->matches_identically_to($comparison))
+ {
$table->set_equivalent_to($comparison,
Related => 0);
next TABLE;
# 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;
$t_path = 'TestProp.pl' unless defined $t_path; # the traditional name
- # Keep going down an order of magnitude
- # until find that adding this quantity to
- # 1 remains 1; but put an upper limit on
- # this so in case this algorithm doesn't
- # work properly on some platform, that we
- # won't loop forever.
- my $digits = 0;
- my $min_floating_slop = 1;
- while (1+ $min_floating_slop != 1
- && $digits++ < 50)
- {
- my $next = $min_floating_slop / 10;
- last if $next == 0; # If underflows,
- # use previous one
- $min_floating_slop = $next;
+ # Create a list of what the %f representation is for each rational number.
+ # This will be used below.
+ my @valid_base_floats = '0.0';
+ foreach my $e_representation (keys %nv_floating_to_rational) {
+ push @valid_base_floats,
+ eval $nv_floating_to_rational{$e_representation};
}
# It doesn't matter whether the elements of this array contain single lines
# 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('*'))
+ {
+ # Non-binary properties should not match \p{}; Test all for that.
+ if ($property->type != $BINARY && $property->type != $FORCED_BINARY) {
+ my @property_aliases = grep { $_->status ne $INTERNAL_ALIAS }
+ $property->aliases;
+ foreach my $property_alias ($property->aliases) {
+ my $name = standardize($property_alias->name);
+
+ # But some names are ambiguous, meaning a binary property with
+ # the same name when used in \p{}, and a different
+ # (non-binary) property in other contexts.
+ next if grep { $name eq $_ } keys %ambiguous_names;
+
+ push @output, <<"EOF_CODE";
+Error('\\p{$name}');
+Error('\\P{$name}');
+EOF_CODE
+ }
+ }
+ 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;
# already guaranteed to be in error
my $already_error = ! $table->file_path;
+ # A table that begins with these could actually be a
+ # user-defined property, so won't be compile time errors, as
+ # the definitions of those can be deferred until runtime
+ next if $already_error && $table_name =~ / ^ I[ns] /x;
+
# Generate error cases for this alias.
push @output, generate_error($property_name,
$table_name,
$warning,
);
- # If the name is a rational number, add tests for the
- # floating point equivalent.
- if ($table_name =~ qr{/}) {
+ if ($property->name eq 'nv') {
+ if ($table_name !~ qr{/}) {
+ push @output, generate_tests($property_name,
+ sprintf("%.15e", $table_name),
+ $valid,
+ $invalid,
+ $warning,
+ );
+ }
+ else {
+ # If the name is a rational number, add tests for a
+ # non-reduced form, and for a floating point equivalent.
+
+ # 60 is a number divisible by a bunch of things
+ my ($numerator, $denominator) = $table_name
+ =~ m! (.+) / (.+) !x;
+ $numerator *= 60;
+ $denominator *= 60;
+ push @output, generate_tests($property_name,
+ "$numerator/$denominator",
+ $valid,
+ $invalid,
+ $warning,
+ );
- # Calculate the float, and find just the fraction.
+ # Calculate the float, and the %e representation
my $float = eval $table_name;
- my ($whole, $fraction)
- = $float =~ / (.*) \. (.*) /x;
-
- # Starting with one digit after the decimal point,
- # create a test for each possible precision (number of
- # digits past the decimal point) until well beyond the
- # native number found on this machine. (If we started
- # with 0 digits, it would be an integer, which could
- # well match an unrelated table)
- PLACE:
- for my $i (1 .. $min_floating_slop + 3) {
- my $table_name = sprintf("%.*f", $i, $float);
- if ($i < $MIN_FRACTION_LENGTH) {
-
- # If the test case has fewer digits than the
- # minimum acceptable precision, it shouldn't
- # succeed, so we expect an error for it.
- # E.g., 2/3 = .7 at one decimal point, and we
- # shouldn't say it matches .7. We should make
- # it be .667 at least before agreeing that the
- # intent was to match 2/3. But at the
- # less-than- acceptable level of precision, it
- # might actually match an unrelated number.
- # So don't generate a test case if this
- # 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)
+ my $e_representation = sprintf("%.*e",
+ $E_FLOAT_PRECISION, $float);
+ # Parse that
+ my ($non_zeros, $zeros, $exponent_sign, $exponent)
+ = $e_representation
+ =~ / -? [1-9] \. (\d*?) (0*) e ([+-]) (\d+) /x;
+ my $min_e_precision;
+ my $min_f_precision;
+
+ if ($exponent_sign eq '+' && $exponent != 0) {
+ Carp::my_carp_bug("Not yet equipped to handle"
+ . " positive exponents");
+ return;
+ }
+ else {
+ # We're trying to find the minimum precision that
+ # is needed to indicate this particular rational
+ # for the given $E_FLOAT_PRECISION. For %e, any
+ # trailing zeros, like 1.500e-02 aren't needed, so
+ # the correct value is how many non-trailing zeros
+ # there are after the decimal point.
+ $min_e_precision = length $non_zeros;
+
+ # For %f, like .01500, we want at least
+ # $E_FLOAT_PRECISION digits, but any trailing
+ # zeros aren't needed, so we can subtract the
+ # length of those. But we also need to include
+ # the zeros after the decimal point, but before
+ # the first significant digit.
+ $min_f_precision = $E_FLOAT_PRECISION
+ + $exponent
+ - length $zeros;
+ }
+
+ # Make tests for each possible precision from 1 to
+ # just past the worst case.
+ my $upper_limit = ($min_e_precision > $min_f_precision)
+ ? $min_e_precision
+ : $min_f_precision;
+
+ for my $i (1 .. $upper_limit + 1) {
+ for my $format ("e", "f") {
+ my $this_table
+ = sprintf("%.*$format", $i, $float);
+
+ # If we don't have enough precision digits,
+ # make a fail test; otherwise a pass test.
+ my $pass = ($format eq "e")
+ ? $i >= $min_e_precision
+ : $i >= $min_f_precision;
+ if ($pass) {
+ push @output, generate_tests($property_name,
+ $this_table,
+ $valid,
+ $invalid,
+ $warning,
+ );
+ }
+ elsif ( $format eq "e"
+
+ # Here we would fail, but in the %f
+ # case, the representation at this
+ # precision could actually be a
+ # valid one for some other rational
+ || ! grep { $_ eq $this_table }
+ @valid_base_floats)
{
- next PLACE
- if abs($table_name - $existing)
- < $MAX_FLOATING_SLOP;
+ push @output,
+ generate_error($property_name,
+ $this_table,
+ 1 # 1 => already an
+ # error
+ );
}
- push @output, generate_error($property_name,
- $table_name,
- 1 # 1 => already an error
- );
- }
- else {
-
- # Here the number of digits exceeds the
- # minimum we think is needed. So generate a
- # success test case for it.
- push @output, generate_tests($property_name,
- $table_name,
- $valid,
- $invalid,
- $warning,
- );
}
}
}
+ }
}
}
$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_LB('$_');\n"} @LB_tests),
- (map {"Test_SB('$_');\n"} @SB_tests),
- (map {"Test_WB('$_');\n"} @WB_tests),
- "Finished();\n"
+ @output_chunked,
+ "Finished();\n",
]);
return;
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,
# 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 recomplile. So far there has been
+ # 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 => 'Provides a visual display of the standard '
+ 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
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' ],
+ Early => [ "WBsubst.txt", '_Perl_WB', 'ALetter' ],
Property => 'Word_Break',
Has_Missings_Defaults => $NOT_IGNORED,
),
),
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/LBTest.txt", v5.1.0,
Handler => \&process_LB_test,
+ retain_trailing_comments => 1,
),
Input_file->new("$AUXILIARY/LineBreakTest.html", v5.1.0,
Skip => $Validation_Documentation,
Skip => 'Maps certain Unicode code points to their '
. 'legacy Japanese cell-phone values',
),
+ # This file is actually not usable as-is until 6.1.0, because the property
+ # is provisional, so its name is missing from PropertyAliases.txt until
+ # that release, so that further work would have to be done to get it to
+ # work properly
Input_file->new('ScriptExtensions.txt', v6.0.0,
Property => 'Script_Extensions',
+ Early => [ sub {} ], # Doesn't do anything but ensures
+ # that this isn't skipped for early
+ # versions
Pre_Handler => \&setup_script_extensions,
Each_Line_Handler => \&filter_script_extensions_line,
Has_Missings_Defaults => (($v_version le v6.0.0)
: $IGNORED),
),
# These two Indic files are actually not usable as-is until 6.1.0,
- # because their property values are missing from PropValueAliases.txt
- # until that release, so that further work would have to be done to get
- # them to work properly, which isn't worth it because of them being
- # provisional.
+ # because they are provisional, so their property values are missing from
+ # PropValueAliases.txt until that release, so that further work would have
+ # to be done to get them to work properly.
Input_file->new('IndicMatraCategory.txt', v6.0.0,
Withdrawn => v8.0.0,
Property => 'Indic_Matra_Category',
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',
+ ),
+ Input_file->new('EquivalentUnifiedIdeograph.txt', v11.0.0,
+ Property => 'Equivalent_Unified_Ideograph',
+ Has_Missings_Defaults => $NOT_IGNORED,
+ ),
+ Input_file->new('EmojiData.txt', v11.0.0,
+ # Is in UAX #51 and not the UCD, so must be updated
+ # separately, and the first line edited to indicate the
+ # UCD release we're pretending it to be in. The UTC says
+ # this is a transitional state.
+ Pre_Handler => \&setup_emojidata,
+ Has_Missings_Defaults => $NOT_IGNORED,
+ Each_Line_Handler => \&filter_emojidata_line,
+ ),
);
# End of all the preliminaries.
print "Updating '$file_list'\n" if $verbosity >= $PROGRESS;
foreach my $file (@input_files, @files_actually_output) {
- my (undef, $directories, $file) = File::Spec->splitpath($file);
- my @directories = File::Spec->splitdir($directories);
- $file = join '/', @directories, $file;
+ my (undef, $directories, $basefile) = File::Spec->splitpath($file);
+ my @directories = grep length, File::Spec->splitdir($directories);
+ $file = join '/', @directories, $basefile;
}
my $ofh;
}
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. Failing tests will be marked TODO");
+}
+
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";
}
# 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}]/';
+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 various break property matches. The 2nd parameter gives the
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,
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 ";
- # 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";
+ 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";
+
+ # 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;
- $matched = ($matched) ? "matched" : "failed to match";
- 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";
}
}
} else {
$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";
}
}
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
-
-# Make sure this gets tested; it was not part of the official test suite at
-# the time this was addded. 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");
https://perl5.git.perl.org / perl5.git / blobdiff