# Needs 'no overloading' to run faster on miniperl. Code commented out at the
# subroutine objaddr can be used instead to work as far back (untested) as
-# 5.8: needs pack "U".
+# 5.8: needs pack "U". But almost all occurrences of objaddr have been
+# removed in favor of using 'no overloading'. You also would have to go
+# through and replace occurrences like:
+# my $addr = do { no overloading; pack 'J', $self; }
+# with
+# my $addr = main::objaddr $self;
+# (or reverse commit 9b01bafde4b022706c3d6f947a0963f821b2e50b
+# that instituted the change to main::objaddr, and subsequent commits that
+# changed 0+$self to pack 'J', $self.)
+
+my $start_time;
+BEGIN { # Get the time the script started running; do it at compiliation to
+ # get it as close as possible
+ $start_time= time;
+}
+
+
require 5.010_001;
use strict;
use warnings;
# have been checked for somewhat more than just sanity. It can handle all
# existing Unicode character properties in those releases.
#
-# This program needs to be able to run under miniperl. Therefore, it uses a
-# minimum of other modules, and hence implements some things itself that could
-# be gotten from CPAN
-#
-# This program uses inputs published by the Unicode Consortium. These can
-# change incompatibly between releases without the Perl maintainers realizing
-# it. Therefore this program is now designed to try to flag these. It looks
-# at the directories where the inputs are, and flags any unrecognized files.
-# It keeps track of all the properties in the files it handles, and flags any
-# that it doesn't know how to handle. It also flags any input lines that
-# don't match the expected syntax, among other checks.
-# It is also designed so if a new input file matches one of the known
-# templates, one hopefully just needs to add it to a list to have it
-# processed.
-#
-# It tries to keep fatal errors to a minimum, to generate something usable for
-# testing purposes. It always looks for files that could be inputs, and will
-# warn about any that it doesn't know how to handle (the -q option suppresses
-# the warning).
-#
# This program is mostly about Unicode character (or code point) properties.
# A property describes some attribute or quality of a code point, like if it
# is lowercase or not, its name, what version of Unicode it was first defined
# writing, such as the path to each one's file. There is a heading in each
# map table that gives the format of its entries, and what the map is for all
# the code points missing from it. (This allows tables to be more compact.)
-
+#
# The Property data structure contains one or more tables. All properties
# contain a map table (except the $perl property which is a
# pseudo-property containing only match tables), and any properties that
# constructs will. Generally a property will have either its map table or its
# match tables written but not both. Again, what gets written is controlled
# by lists which can easily be changed.
-
+#
# For information about the Unicode properties, see Unicode's UAX44 document:
my $unicode_reference_url = 'http://www.unicode.org/reports/tr44/';
# introductory comments.
#
# This program works on all properties as of 5.2, though the files for some
-# are suppressed from apparent lack of demand for. You can change which are
-# output by changing lists in this program.
-
+# are suppressed from apparent lack of demand for them. You can change which
+# are output by changing lists in this program.
+#
# The old version of mktables emphasized the term "Fuzzy" to mean Unocde's
# loose matchings rules (from Unicode TR18):
#
# The program still allows Fuzzy to override its determination of if loose
# matching should be used, but it isn't currently used, as it is no longer
# needed; the calculations it makes are good enough.
-
+#
# SUMMARY OF HOW IT WORKS:
#
# Process arguments
# The Perl-defined properties are created and populated. Many of these
# require data determined from the earlier steps
# Any Perl-defined synonyms are created, and name clashes between Perl
-# and Unicode are reconciled.
+# and Unicode are reconciled and warned about.
# All the properties are written to files
# Any other files are written, and final warnings issued.
-
-# As mentioned above, some properties are given in more than one file. In
-# particular, the files in the extracted directory are supposedly just
-# reformattings of the others. But they contain information not easily
-# derivable from the other files, including results for Unihan, which this
-# program doesn't ordinarily look at, and for unassigned code points. They
-# also have historically had errors or been incomplete. In an attempt to
-# create the best possible data, this program thus processes them first to
-# glean information missing from the other files; then processes those other
-# files to override any errors in the extracted ones.
-
+#
# For clarity, a number of operators have been overloaded to work on tables:
# ~ means invert (take all characters not in the set). The more
# conventional '!' is not used because of the possibility of confusing
# Operations are done on references and affect the underlying structures, so
# that the copy constructors for them have been overloaded to not return a new
# clone, but the input object itself.
-
+#
# The bool operator is deliberately not overloaded to avoid confusion with
# "should it mean if the object merely exists, or also is non-empty?".
-
#
# WHY CERTAIN DESIGN DECISIONS WERE MADE
-
-# XXX These comments need more work.
+#
+# This program needs to be able to run under miniperl. Therefore, it uses a
+# minimum of other modules, and hence implements some things itself that could
+# be gotten from CPAN
+#
+# This program uses inputs published by the Unicode Consortium. These can
+# change incompatibly between releases without the Perl maintainers realizing
+# it. Therefore this program is now designed to try to flag these. It looks
+# at the directories where the inputs are, and flags any unrecognized files.
+# It keeps track of all the properties in the files it handles, and flags any
+# that it doesn't know how to handle. It also flags any input lines that
+# don't match the expected syntax, among other checks.
+#
+# It is also designed so if a new input file matches one of the known
+# templates, one hopefully just needs to add it to a list to have it
+# processed.
+#
+# As mentioned earlier, some properties are given in more than one file. In
+# particular, the files in the extracted directory are supposedly just
+# reformattings of the others. But they contain information not easily
+# derivable from the other files, including results for Unihan, which this
+# program doesn't ordinarily look at, and for unassigned code points. They
+# also have historically had errors or been incomplete. In an attempt to
+# create the best possible data, this program thus processes them first to
+# glean information missing from the other files; then processes those other
+# files to override any errors in the extracted ones. Much of the design was
+# driven by this need to store things and then possibly override them.
+#
+# It tries to keep fatal errors to a minimum, to generate something usable for
+# testing purposes. It always looks for files that could be inputs, and will
+# warn about any that it doesn't know how to handle (the -q option suppresses
+# the warning).
#
# Why have files written out for binary 'N' matches?
# For binary properties, if you know the mapping for either Y or N; the
-# other is trivial to construct, so could be done at Perl run-time instead
-# of having a file for it. That is, if someone types in \p{foo: N}, Perl
-# could translate that to \P{foo: Y} and not need a file. The problem is
-# communicating to Perl that a given property is binary. Perl can't figure
-# it out from looking at the N (or No), as some non-binary properties have
-# these as property values.
-# Why
-# There are several types of properties, based on what form their values can
-# take on. These are described in more detail below in the DATA STRUCTURES
-# section of these comments, but for now, you should know that there are
-# string properties, whose values are strings of one or more code points (such
-# as the Uppercase_mapping property); every other property maps to some other
-# form, like true or false, or a number, or a name, etc. The reason there are
-# two directories for map files is because of the way utf8.c works. It
-# expects that any files there are string properties, that is that the
-# mappings are each to one code point, with mappings in multiple code points
-# handled specially in an extra hash data structure. Digit.pl is a table that
-# is written there for historical reasons, even though it doesn't fit that
-# mold. Thus it can't currently be looked at by the Perl core.
+# other is trivial to construct, so could be done at Perl run-time by just
+# complementing the result, instead of having a file for it. That is, if
+# someone types in \p{foo: N}, Perl could translate that to \P{foo: Y} and
+# not need a file. The problem is communicating to Perl that a given
+# property is binary. Perl can't figure it out from looking at the N (or
+# No), as some non-binary properties have these as property values. So
+# rather than inventing a way to communicate this info back to the core,
+# which would have required changes there as well, it was simpler just to
+# add the extra tables.
+#
+# Why is there more than one type of range?
+# This simplified things. There are some very specialized code points that
+# have to be handled specially for output, such as Hangul syllable names.
+# By creating a range type (done late in the development process), it
+# allowed this to be stored with the range, and overridden by other input.
+# Originally these were stored in another data structure, and it became a
+# mess trying to decide if a second file that was for the same property was
+# overriding the earlier one or not.
+#
+# Why are there two kinds of tables, match and map?
+# (And there is a base class shared by the two as well.) As stated above,
+# they actually are for different things. Development proceeded much more
+# smoothly when I (khw) realized the distinction. Map tables are used to
+# give the property value for every code point (actually every code point
+# that doesn't map to a default value). Match tables are used for regular
+# expression matches, and are essentially the inverse mapping. Separating
+# the two allows more specialized methods, and error checks so that one
+# can't just take the intersection of two map tables, for example, as that
+# is nonsensical.
#
# There are no match tables generated for matches of the null string. These
-# would like like \p{JSN=}. Perhaps something like them could be added if
-# necessary. The JSN does have a real code point U+110B that maps to the null
-# string, but it is a contributory property, and therefore not output by
-# default.
+# would look like qr/\p{JSN=}/ currently without modifying the regex code.
+# Perhaps something like them could be added if necessary. The JSN does have
+# a real code point U+110B that maps to the null string, but it is a
+# contributory property, and therefore not output by default. And it's easily
+# handled so far by making the null string the default where it is a
+# possibility.
#
# DEBUGGING
#
-# XXX Add more stuff here. use perl instead of miniperl to find problems with
-# Scalar::Util
-
+# This program is written so it will run under miniperl. Occasionally changes
+# will cause an error where the backtrace doesn't work well under miniperl.
+# To diagnose the problem, you can instead run it under regular perl, if you
+# have one compiled.
+#
+# There is a good trace facility. To enable it, first sub DEBUG must be set
+# to return true. Then a line like
+#
+# local $to_trace = 1 if main::DEBUG;
+#
+# can be added to enable tracing in its lexical scope or until you insert
+# another line:
+#
+# local $to_trace = 0 if main::DEBUG;
+#
+# then use a line like "trace $a, @b, %c, ...;
+#
+# Some of the more complex subroutines already have trace statements in them.
+# Permanent trace statements should be like:
+#
+# trace ... if main::DEBUG && $to_trace;
+#
+# 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
+#
+# my $debug_skip = 0;
+#
+# to 1, and every file whose object is in @input_file_objects and doesn't have
+# a, 'non_skip => 1,' in its constructor will be skipped.
+#
# FUTURE ISSUES
#
# The program would break if Unicode were to change its names so that
# synonym would have to be used for the new property. This is ugly, and
# manual intervention would certainly be easier to do in the short run; lets
# hope it never comes to this.
-
+#
# A NOTE ON UNIHAN
#
# This program can generate tables from the Unihan database. But it doesn't
# kPrimaryNumeric property have commas and an unexpected comment. A filter
# could be added for these; or for a particular installation, the Unihan.txt
# file could be edited to fix them.
-# have to be
#
-# HOW TO ADD A FILE
-
-# Unicode Versions Notes
-
-# alpha's numbers halve in 2.1.9, answer cjk block at 4E00 were removed from PropList; not changed, could add gc Letter, put back in in 3.1.0
-# Some versions of 2.1.x Jamo.txt have the wrong value for 1105, which causes
-# real problems for the algorithms for Jamo calculations, so it is changed
-# here.
-# White space vs Space. in 3.2 perl has +205F=medium math space, fixed in 4.0, and ok in 3.1.1 because not there in unicode. synonym introduced in 4.1
-# ATBL = 202. 202 changed to ATB, and all code points stayed there. So if you were useing ATBL you were out of luck.
-# Hrkt Katakana_Or_Hiragana came in 4.01, before was Unknown.
+# HOW TO ADD A FILE TO BE PROCESSED
+#
+# A new file from Unicode needs to have an object constructed for it in
+# @input_file_objects, probably at the end or at the end of the extracted
+# ones. The program should warn you if its name will clash with others on
+# restrictive file systems, like DOS. If so, figure out a better name, and
+# add lines to the README.perl file giving that. If the file is a character
+# property, it should be in the format that Unicode has by default
+# standardized for such files for the more recently introduced ones.
+# If so, the Input_file constructor for @input_file_objects can just be the
+# file name and release it first appeared in. If not, then it should be
+# possible to construct an each_line_handler() to massage the line into the
+# standardized form.
+#
+# For non-character properties, more code will be needed. You can look at
+# the existing entries for clues.
+#
+# UNICODE VERSIONS NOTES
+#
+# The Unicode UCD has had a number of errors in it over the versions. And
+# these remain, by policy, in the standard for that version. Therefore it is
+# risky to correct them, because code may be expecting the error. So this
+# program doesn't generally make changes, unless the error breaks the Perl
+# core. As an example, some versions of 2.1.x Jamo.txt have the wrong value
+# for U+1105, which causes real problems for the algorithms for Jamo
+# calculations, so it is changed here.
+#
+# But it isn't so clear cut as to what to do about concepts that are
+# introduced in a later release; should they extend back to earlier releases
+# where the concept just didn't exist? It was easier to do this than to not,
+# so that's what was done. For example, the default value for code points not
+# in the files for various properties was probably undefined until changed by
+# some version. No_Block for blocks is such an example. This program will
+# assign No_Block even in Unicode versions that didn't have it. This has the
+# benefit that code being written doesn't have to special case earlier
+# versions; and the detriment that it doesn't match the Standard precisely for
+# the affected versions.
+#
+# Here are some observations about some of the issues in early versions:
+#
+# The number of code points in \p{alpha} halve in 2.1.9. It turns out that
+# the reason is that the CJK block starting at 4E00 was removed from PropList,
+# and was not put back in until 3.1.0
+#
+# Unicode introduced the synonym Space for White_Space in 4.1. Perl has
+# always had a \p{Space}. In release 3.2 only, they are not synonymous. The
+# reason is that 3.2 introduced U+205F=medium math space, which was not
+# classed as white space, but Perl figured out that it should have been. 4.0
+# reclassified it correctly.
+#
+# Another change between 3.2 and 4.0 is the CCC property value ATBL. In 3.2
+# this was erroneously a synonym for 202. In 4.0, ATB became 202, and ATBL
+# was left with no code points, as all the ones that mapped to 202 stayed
+# mapped to 202. Thus if your program used the numeric name for the class,
+# it would not have been affected, but if it used the mnemonic, it would have
+# been.
+#
+# \p{Script=Hrkt} (Katakana_Or_Hiragana) came in 4.0.1. Before that code
+# points which eventually came to have this script property value, instead
+# mapped to "Unknown". But in the next release all these code points were
+# moved to \p{sc=common} instead.
#
# The default for missing code points for BidiClass is complicated. Starting
# in 3.1.1, the derived file DBidiClass.txt handles this, but this program
# Encapsulated Cleverness". p. 455 in first edition.
my %seen;
+ # Arguably this breaks encapsulation, if the goal is to permit multiple
+ # distinct objects to stringify to the same value, and be interchangeable.
+ # However, for this program, no two objects stringify identically, and all
+ # lists passed to this function are either objects or strings. So this
+ # doesn't affect correctness, but it does give a couple of percent speedup.
+ no overloading;
return grep { ! $seen{$_}++ } @_;
}
# in the input.
my $output_range_counts = 1; # ? Should we include the number of code points
# in ranges in the output
+my $output_names = 0; # ? Should character names be in the output
+my @viacode; # Contains the 1 million character names, if
+ # $output_names is true
+
# Verbosity levels; 0 is quiet
my $NORMAL_VERBOSITY = 1;
my $PROGRESS = 2;
elsif ($arg eq '-c') {
$output_range_counts = ! $output_range_counts
}
+ elsif ($arg eq '-output_names') {
+ $output_names = 1;
+ }
else {
my $with_c = 'with';
$with_c .= 'out' if $output_range_counts; # Complements the state
-maketest : Make test script 'TestProp.pl' in current (or -C directory),
overrides -T
-makelist : Rewrite the file list $file_list based on current setup
+ -output_names : Output each character's name in the table files; useful for
+ doing what-ifs, looking at diffs; is slow, memory intensive,
+ resulting tables are usable but very large.
-check A B : Executes $0 only if A and B are the same
END
}
# Stores the most-recently changed file. If none have changed, can skip the
# build
-my $youngest = -M $0; # Do this before the chdir!
+my $youngest = (stat $0)[9]; # Do this before the chdir!
# Change directories now, because need to read 'version' early.
if ($use_directory) {
# unless explicitly added.
if ($v_version ge v5.2.0) {
my $unihan = 'Unihan; remove from list if using Unihan';
- foreach my $table qw (
+ foreach my $table (qw (
kAccountingNumeric
kOtherNumeric
kPrimaryNumeric
kIRG_USource
kIRG_VSource
kRSUnicode
- )
+ ))
{
$why_suppress_if_empty_warn_if_not{$table} = $unihan;
}
'StandardizedVariants.txt' => 'Only for glyph changes, not a Unicode character property. Does not fit into current scheme where one code point is mapped',
);
-################ End of externally interesting definitions ###############
+### End of externally interesting definitions, except for @input_file_objects
my $HEADER=<<"EOF";
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
$INTEGER_FORMAT => 'integer',
$HEX_FORMAT => 'positive hex whole number; a code point',
$RATIONAL_FORMAT => 'rational: an integer or a fraction',
- $STRING_FORMAT => 'arbitrary string',
+ $STRING_FORMAT => 'string',
);
# Unicode didn't put such derived files in a separate directory at first.
# These constants names and values were taken from the Unicode standard,
# version 5.1, section 3.12. They are used in conjunction with Hangul
-# syllables
-my $SBase = 0xAC00;
-my $LBase = 0x1100;
-my $VBase = 0x1161;
-my $TBase = 0x11A7;
+# syllables. The '_string' versions are so generated tables can retain the
+# hex format, which is the more familiar value
+my $SBase_string = "0xAC00";
+my $SBase = CORE::hex $SBase_string;
+my $LBase_string = "0x1100";
+my $LBase = CORE::hex $LBase_string;
+my $VBase_string = "0x1161";
+my $VBase = CORE::hex $VBase_string;
+my $TBase_string = "0x11A7";
+my $TBase = CORE::hex $TBase_string;
my $SCount = 11172;
my $LCount = 19;
my $VCount = 21;
my $gc;
my $perl;
my $block;
+my $perl_charname;
+my $print;
# Are there conflicting names because of beginning with 'In_', or 'Is_'
my $has_In_conflicts = 0;
no overloading; # If overloaded, numifying below won't work.
# Numifying a ref gives its address.
- return 0 + $_[0];
+ return pack 'J', $_[0];
}
# Commented code below should work on Perl 5.8.
# bless $_[0], 'main::Fake';
#
# # Numifying a ref gives its address.
-# my $addr = 0 + $_[0];
+# my $addr = pack 'J', $_[0];
#
# # Return to original class
# bless $_[0], $pkg;
# Use typeglob to give the anonymous subroutine the name we want
*$destroy_name = sub {
my $self = shift;
- my $addr = main::objaddr($self);
+ my $addr = do { no overloading; pack 'J', $self; };
$self->$destroy_callback if $destroy_callback;
foreach my $field (keys %{$package_fields{$package}}) {
# "protection" is only by convention. All that happens is that the
# accessor functions' names begin with an underscore. So instead of
# calling set_foo, the call is _set_foo. (Real protection could be
- # accomplished by having a new subroutine, end_package called at the
+ # accomplished by having a new subroutine, end_package, called at the
# end of each package, and then storing the __LINE__ ranges and
# checking them on every accessor. But that is way overkill.)
return Carp::carp_too_few_args(\@_, 2) if main::DEBUG && @_ < 2;
my $self = shift;
my $value = shift;
+ my $addr = do { no overloading; pack 'J', $self; };
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
if (ref $value) {
- return if grep { $value == $_ }
- @{$field->{main::objaddr $self}};
+ return if grep { $value == $_ } @{$field->{$addr}};
}
else {
- return if grep { $value eq $_ }
- @{$field->{main::objaddr $self}};
+ return if grep { $value eq $_ } @{$field->{$addr}};
}
- push @{$field->{main::objaddr $self}}, $value;
+ push @{$field->{$addr}}, $value;
return;
}
}
*$subname = sub {
use strict "refs";
Carp::carp_extra_args(\@_) if main::DEBUG && @_ > 1;
- my $addr = main::objaddr $_[0];
+ my $addr = do { no overloading; pack 'J', $_[0]; };
if (ref $field->{$addr} ne 'ARRAY') {
my $type = ref $field->{$addr};
$type = 'scalar' unless $type;
*$subname = sub {
use strict "refs";
Carp::carp_extra_args(\@_) if main::DEBUG && @_ > 1;
- return $field->{main::objaddr $_[0]};
+ no overloading;
+ return $field->{pack 'J', $_[0]};
}
}
}
Carp::carp_extra_args(\@_) if @_ > 2;
}
# $self is $_[0]; $value is $_[1]
- $field->{main::objaddr $_[0]} = $_[1];
+ no overloading;
+ $field->{pack 'J', $_[0]} = $_[1];
return;
}
}
my $class = shift;
my $self = bless \do{ my $anonymous_scalar }, $class;
- my $addr = main::objaddr($self);
+ my $addr = do { no overloading; pack 'J', $self; };
# Set defaults
$handler{$addr} = \&main::process_generic_property_file;
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
my $file = $file{$addr};
my $fkey = File::Spec->rel2abs($file);
my $expecting = delete $potential_files{$fkey};
$expecting = delete $potential_files{lc($fkey)} unless defined $expecting;
- Carp::my_carp("Was not expecting '$file'.") if
- ! $expecting
+ Carp::my_carp("Was not expecting '$file'.") if
+ ! $expecting
&& ! defined $handle{$addr};
# Having deleted from expected files, we can quit if not to do
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
# Here the file is open (or if the handle is not a ref, is an open
# 'virtual' file). Get the next line; any inserted lines get priority
# # an each_line_handler() on the line.
#
# my $self = shift;
-# my $addr = main::objaddr $self;
+# my $addr = do { no overloading; pack 'J', $self; };
#
# foreach my $inserted_ref (@{$added_lines{$addr}}) {
# my ($adjusted, $line) = @{$inserted_ref};
# Each inserted line is an array, with the first element being 0 to
# indicate that this line hasn't been adjusted, and needs to be
# processed.
- push @{$added_lines{main::objaddr $self}}, map { [ 0, $_ ] } @_;
+ no overloading;
+ push @{$added_lines{pack 'J', $self}}, map { [ 0, $_ ] } @_;
return;
}
# Each inserted line is an array, with the first element being 1 to
# indicate that this line has been adjusted
- push @{$added_lines{main::objaddr $self}}, map { [ 1, $_ ] } @_;
+ no overloading;
+ push @{$added_lines{pack 'J', $self}}, map { [ 1, $_ ] } @_;
return;
}
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
# If not accepting a list return, just return the first one.
return shift @{$missings{$addr}} unless wantarray;
sub _insert_property_into_line {
# Add a property field to $_, if this file requires it.
- my $property = $property{main::objaddr shift};
+ my $self = shift;
+ my $addr = do { no overloading; pack 'J', $self; };
+ my $property = $property{$addr};
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
$_ =~ s/(;|$)/; $property$1/;
my $message = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
$message = 'Unexpected line' unless $message;
# increment the count of how many times it has occurred
unless ($errors{$addr}->{$message}) {
Carp::my_carp("$message in '$_' in "
- . $file{main::objaddr $self}
+ . $file{$addr}
. " at line $.. Skipping this line;");
$errors{$addr}->{$message} = 1;
}
my $class = shift;
my $self = bless \do{my $anonymous_scalar}, $class;
- my $addr = main::objaddr($self);
+ my $addr = do { no overloading; pack 'J', $self; };
while (@_ > 1) {
my $default = shift;
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
return each %{$class_defaults{$addr}};
}
my $class = shift;
my $self = bless \do { my $anonymous_scalar }, $class;
- my $addr = main::objaddr($self);
+ my $addr = do { no overloading; pack 'J', $self; };
$name{$addr} = shift;
$loose_match{$addr} = shift;
my $class = shift;
my $self = bless \do { my $anonymous_scalar }, $class;
- my $addr = main::objaddr($self);
+ my $addr = do { no overloading; pack 'J', $self; };
$start{$addr} = shift;
$end{$addr} = shift;
sub _operator_stringify {
my $self = shift;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
# Output it like '0041..0065 (value)'
my $return = sprintf("%04X", $start{$addr})
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
return $standard_form{$addr} if defined $standard_form{$addr};
return $value{$addr};
my $indent = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
my $return = $indent
. sprintf("%04X", $start{$addr})
# There are a number of methods to manipulate range lists, and some operators
# are overloaded to handle them.
-# Because of the slowness of pure Perl objaddr() on miniperl, and measurements
-# showing this package was using a lot of real time calculating that, the code
-# was changed to only calculate it once per call stack. This is done by
-# consistently using the package variable $addr in routines, and only calling
-# objaddr() if it isn't defined, and setting that to be local, so that callees
-# will have it already. It would be a good thing to change this. XXX
-
sub trace { return main::trace(@_); }
{ # Closure
return _union($class, $initialize, %args) if defined $initialize;
$self = bless \do { my $anonymous_scalar }, $class;
- local $addr = main::objaddr($self);
+ my $addr = do { no overloading; pack 'J', $self; };
# Optional parent object, only for debug info.
$owner_name_of{$addr} = delete $args{'Owner'};
sub _operator_stringify {
my $self = shift;
- local $addr = main::objaddr($self) if !defined $addr;
+ my $addr = do { no overloading; pack 'J', $self; };
return "Range_List attached to '$owner_name_of{$addr}'"
if $owner_name_of{$addr};
if (! defined $arg) {
my $message = "";
if (defined $self) {
- $message .= $owner_name_of{main::objaddr $self};
+ no overloading;
+ $message .= $owner_name_of{pack 'J', $self};
}
Carp::my_carp_bug($message .= "Undefined argument to _union. No union done.");
return;
else {
my $message = "";
if (defined $self) {
- $message .= $owner_name_of{main::objaddr $self};
+ no overloading;
+ $message .= $owner_name_of{pack 'J', $self};
}
Carp::my_carp_bug($message . "Cannot take the union of a $type. No union done.");
return;
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- local $addr = main::objaddr($self) if ! defined $addr;
-
- return scalar @{$ranges{$addr}};
+ no overloading;
+ return scalar @{$ranges{pack 'J', $self}};
}
sub min {
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- local $addr = main::objaddr($self) if ! defined $addr;
+ my $addr = do { no overloading; pack 'J', $self; };
# If the range list is empty, return a large value that isn't adjacent
# to any that could be in the range list, for simpler tests
my $codepoint = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- local $addr = main::objaddr $self if ! defined $addr;
-
my $i = $self->_search_ranges($codepoint);
return 0 unless defined $i;
# range[$i-1]->end < $codepoint <= range[$i]->end
# So is in the table if and only iff it is at least the start position
# of range $i.
- return 0 if $ranges{$addr}->[$i]->start > $codepoint;
+ no overloading;
+ return 0 if $ranges{pack 'J', $self}->[$i]->start > $codepoint;
return $i + 1;
}
- sub value_of {
- # Returns the value associated with the code point, undef if none
+ sub containing_range {
+ # Returns the range object that contains the code point, undef if none
my $self = shift;
my $codepoint = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- local $addr = main::objaddr $self if ! defined $addr;
-
my $i = $self->contains($codepoint);
return unless $i;
# contains() returns 1 beyond where we should look
- return $ranges{$addr}->[$i-1]->value;
+ no overloading;
+ return $ranges{pack 'J', $self}->[$i-1];
+ }
+
+ sub value_of {
+ # Returns the value associated with the code point, undef if none
+
+ my $self = shift;
+ my $codepoint = shift;
+ Carp::carp_extra_args(\@_) if main::DEBUG && @_;
+
+ my $range = $self->containing_range($codepoint);
+ return unless defined $range;
+
+ return $range->value;
+ }
+
+ sub type_of {
+ # Returns the type of the range containing the code point, undef if
+ # the code point is not in the table
+
+ my $self = shift;
+ my $codepoint = shift;
+ Carp::carp_extra_args(\@_) if main::DEBUG && @_;
+
+ my $range = $self->containing_range($codepoint);
+ return unless defined $range;
+
+ return $range->type;
}
sub _search_ranges {
my $code_point = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- local $addr = main::objaddr $self if ! defined $addr;
+ my $addr = do { no overloading; pack 'J', $self; };
return if $code_point > $max{$addr};
my $r = $ranges{$addr}; # The current list of ranges
#
# The range list is kept sorted so that the range with the lowest
# starting position is first in the list, and generally, adjacent
- # ranges with the same values are merged into single larger one (see
+ # ranges with the same values are merged into a single larger one (see
# exceptions below).
#
- # There are more parameters, all are key => value pairs:
+ # There are more parameters; all are key => value pairs:
# Type gives the type of the value. It is only valid for '+'.
# All ranges have types; if this parameter is omitted, 0 is
# assumed. Ranges with type 0 are assumed to obey the
# => $IF_NOT_EQUIVALENT means to replace the existing values
# with this one if they are not equivalent.
# Ranges are equivalent if their types are the
- # same, and they are the same string, or if
+ # same, and they are the same string; or if
# both are type 0 ranges, if their Unicode
# standard forms are identical. In this last
# case, the routine chooses the more "modern"
# multiple times.
# => anything else is the same as => $IF_NOT_EQUIVALENT
#
- # "same value" means identical for type-0 ranges, and it means having
- # the same standard forms for non-type-0 ranges.
+ # "same value" means identical for non-type-0 ranges, and it means
+ # having the same standard forms for type-0 ranges.
return Carp::carp_too_few_args(\@_, 5) if main::DEBUG && @_ < 5;
Carp::carp_extra_args(\%args) if main::DEBUG && %args;
- local $addr = main::objaddr($self) if ! defined $addr;
+ my $addr = do { no overloading; pack 'J', $self; };
if ($operation ne '+' && $operation ne '-') {
Carp::my_carp_bug("$owner_name_of{$addr}First parameter to _add_delete must be '+' or '-'. No action taken.");
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- local $addr = main::objaddr $self if ! defined $addr;
-
- undef $each_range_iterator{$addr};
+ no overloading;
+ undef $each_range_iterator{pack 'J', $self};
return;
}
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- local $addr = main::objaddr($self) if ! defined $addr;
+ my $addr = do { no overloading; pack 'J', $self; };
return if $self->is_empty;
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- local $addr = main::objaddr($self) if ! defined $addr;
+ my $addr = do { no overloading; pack 'J', $self; };
my $count = 0;
foreach my $range (@{$ranges{$addr}}) {
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- local $addr = main::objaddr($self) if ! defined $addr;
- return scalar @{$ranges{$addr}} == 0;
+ no overloading;
+ return scalar @{$ranges{pack 'J', $self}} == 0;
}
sub hash {
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- local $addr = main::objaddr($self) if ! defined $addr;
+ my $addr = do { no overloading; pack 'J', $self; };
# These are quickly computable. Return looks like 'min..max;count'
return $self->min . "..$max{$addr};" . scalar @{$ranges{$addr}};
return $self->_add_delete('+', $start, $end, "");
}
- my $non_ASCII = (ord('A') != 65); # Assumes test on same platform
-
sub is_code_point_usable {
# This used only for making the test script. See if the input
# proposed trial code point is one that Perl will handle. If second
return 0 if $code < 0; # Never use a negative
- # For non-ASCII, we shun the characters that don't have Perl encoding-
- # independent symbols for them. 'A' is such a symbol, so is "\n".
- return $try_hard if $non_ASCII
- && $code <= 0xFF
- && ($code >= 0x7F
- || ($code >= 0x0E && $code <= 0x1F)
- || ($code >= 0x01 && $code <= 0x06)
- || $code == 0x0B);
-
# shun null. I'm (khw) not sure why this was done, but NULL would be
# the character very frequently used.
return $try_hard if $code == 0x0000;
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr($self);
+ my $addr = do { no overloading; pack 'J', $self; };
# On first pass, don't choose less desirable code points; if no good
# one is found, repeat, allowing a less desirable one to be selected.
# standard.
main::set_access('perl_extension', \%perl_extension, 'r');
+ my %output_range_counts;
+ # A boolean set iff this table is to have comments written in the
+ # output file that contain the number of code points in the range.
+ # The constructor can override the global flag of the same name.
+ main::set_access('output_range_counts', \%output_range_counts, 'r');
+
sub new {
# All arguments are key => value pairs, which you can see below, most
# of which match fields documented above. Otherwise: Pod_Entry,
my $class = shift;
my $self = bless \do { my $anonymous_scalar }, $class;
- my $addr = main::objaddr($self);
+ my $addr = do { no overloading; pack 'J', $self; };
my %args = @_;
my $complete_name = $complete_name{$addr}
= delete $args{'Complete_Name'};
$internal_only{$addr} = delete $args{'Internal_Only_Warning'} || 0;
+ $output_range_counts{$addr} = delete $args{'Output_Range_Counts'};
$property{$addr} = delete $args{'_Property'};
$range_list{$addr} = delete $args{'_Range_List'};
$status{$addr} = delete $args{'Status'} || $NORMAL;
$status_info{$addr} = delete $args{'_Status_Info'} || "";
$range_size_1{$addr} = delete $args{'Range_Size_1'} || 0;
+ $range_size_1{$addr} = 1 if $output_names; # Make sure 1 name per line
my $description = delete $args{'Description'};
my $externally_ok = delete $args{'Externally_Ok'};
# Can't use || above because conceivably the name could be 0, and
# can't use // operator in case this program gets used in Perl 5.8
$full_name{$addr} = $name{$addr} if ! defined $full_name{$addr};
+ $output_range_counts{$addr} = $output_range_counts if
+ ! defined $output_range_counts{$addr};
$aliases{$addr} = [ ];
$comment{$addr} = [ ];
# lists of properties or tables that have particular statuses; if
# not, is normal. The lists are prioritized so the most serious
# ones are checked first
- if (exists $why_suppressed{$complete_name}) {
+ if (exists $why_suppressed{$complete_name}
+ # Don't suppress if overriden
+ && ! grep { $_ eq $complete_name{$addr} }
+ @output_mapped_properties)
+ {
$status{$addr} = $SUPPRESSED;
}
elsif (exists $why_deprecated{$complete_name}) {
# Here are the methods that are required to be defined by any derived
# class
- for my $sub qw(
+ for my $sub (qw(
append_to_body
pre_body
- )
+ ))
# append_to_body and pre_body are called in the write() method
# to add stuff after the main body of the table, but before
# its close; and to prepend stuff before the beginning of the
sub ranges {
# Returns the array of ranges associated with this table.
- return $range_list{main::objaddr shift}->ranges;
+ no overloading;
+ return $range_list{pack 'J', shift}->ranges;
}
sub add_alias {
# release
$name = ucfirst($name) unless $name =~ /^k[A-Z]/;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
# Figure out if should be loosely matched if not already specified.
if (! defined $loose_match) {
# This name may be shorter than any existing ones, so clear the cache
# of the shortest, so will have to be recalculated.
- undef $short_name{main::objaddr $self};
+ no overloading;
+ undef $short_name{pack 'J', $self};
return;
}
my $nominal_length_ptr = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
# For efficiency, don't recalculate, but this means that adding new
# aliases could change what the shortest is, so the code that does
chomp $description;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- push @{$description{main::objaddr $self}}, $description;
+ no overloading;
+ push @{$description{pack 'J', $self}}, $description;
return;
}
chomp $note;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- push @{$note{main::objaddr $self}}, $note;
+ no overloading;
+ push @{$note{pack 'J', $self}}, $note;
return;
}
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
chomp $comment;
- push @{$comment{main::objaddr $self}}, $comment;
+
+ no overloading;
+ push @{$comment{pack 'J', $self}}, $comment;
return;
}
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my @list = @{$comment{main::objaddr $self}};
+ my $addr = do { no overloading; pack 'J', $self; };
+ my @list = @{$comment{$addr}};
return @list if wantarray;
my $return = "";
foreach my $sentence (@list) {
# initialization for range lists.
my $self = shift;
+ my $addr = do { no overloading; pack 'J', $self; };
my $initialization = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
# Replace the current range list with a new one of the same exact
# type.
- my $class = ref $range_list{main::objaddr $self};
- $range_list{main::objaddr $self} = $class->new(Owner => $self,
+ my $class = ref $range_list{$addr};
+ $range_list{$addr} = $class->new(Owner => $self,
Initialize => $initialization);
return;
my $return = "";
$return .= $DEVELOPMENT_ONLY if $compare_versions;
$return .= $HEADER;
- $return .= $INTERNAL_ONLY if $internal_only{main::objaddr $self};
+ no overloading;
+ $return .= $INTERNAL_ONLY if $internal_only{pack 'J', $self};
return $return;
}
# the range
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr($self);
+ my $addr = do { no overloading; pack 'J', $self; };
# Start with the header
my @OUT = $self->header;
# If has or wants a single point range output
if ($start == $end || $range_size_1) {
- for my $i ($start .. $end) {
- push @OUT, sprintf "%04X\t\t%s\n", $i, $value;
+ if (ref $range_size_1 eq 'CODE') {
+ for my $i ($start .. $end) {
+ push @OUT, &$range_size_1($i, $value);
+ }
+ }
+ else {
+ for my $i ($start .. $end) {
+ push @OUT, sprintf "%04X\t\t%s\n", $i, $value;
+ if ($output_names) {
+ if (! defined $viacode[$i]) {
+ $viacode[$i] =
+ Property::property_ref('Perl_Charnames')
+ ->value_of($i)
+ || "";
+ }
+ $OUT[-1] =~ s/\n/\t# $viacode[$i]\n/;
+ }
+ }
}
}
else {
# Add a comment with the size of the range, if requested.
# Expand Tabs to make sure they all start in the same
# column, and then unexpand to use mostly tabs.
- if (! $output_range_counts) {
+ if (! $output_range_counts{$addr}) {
$OUT[-1] .= "\n";
}
else {
my $info = shift; # Any message associated with it.
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr($self);
+ my $addr = do { no overloading; pack 'J', $self; };
$status{$addr} = $status;
$status_info{$addr} = $info;
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
$locked{$addr} = "";
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
return 0 if ! $locked{$addr};
Carp::my_carp_bug("Can't modify a locked table. Stack trace of locking:\n$locked{$addr}\n\n");
my $self = shift;
# Rest of parameters passed on
- @{$file_path{main::objaddr $self}} = @_;
+ no overloading;
+ @{$file_path{pack 'J', $self}} = @_;
return
}
# Accessors for the range list stored in this table. First for
# unconditional
- for my $sub qw(
+ for my $sub (qw(
+ containing_range
contains
count
each_range
min
range_count
reset_each_range
+ type_of
value_of
- )
+ ))
{
no strict "refs";
*$sub = sub {
use strict "refs";
my $self = shift;
- return $range_list{main::objaddr $self}->$sub(@_);
+ no overloading;
+ return $range_list{pack 'J', $self}->$sub(@_);
}
}
# Then for ones that should fail if locked
- for my $sub qw(
+ for my $sub (qw(
delete_range
- )
+ ))
{
no strict "refs";
*$sub = sub {
my $self = shift;
return if $self->carp_if_locked;
- return $range_list{main::objaddr $self}->$sub(@_);
+ no overloading;
+ return $range_list{pack 'J', $self}->$sub(@_);
}
}
_Range_List => $range_list,
%args);
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
$anomalous_entries{$addr} = [];
$core_access{$addr} = $core_access;
# Can't change the table if locked.
return if $self->carp_if_locked;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
$has_specials{$addr} = 1 if $type;
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
return "" unless @{$anomalous_entries{$addr}};
return join("\n", @{$anomalous_entries{$addr}}) . "\n";
return;
}
- my $addr = main::objaddr $self;
- my $other_addr = main::objaddr $other;
+ my $addr = do { no overloading; pack 'J', $self; };
+ my $other_addr = do { no overloading; pack 'J', $other; };
local $to_trace = 0 if main::DEBUG;
my $map = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr $self;
+ 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 $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
# If overridden, use that
return $to_output_map{$addr} if defined $to_output_map{$addr};
# No sense generating a comment if aren't going to write it out.
return if ! $self->to_output_map;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
my $property = $self->property;
range, in hex; STOP is the ending point, or if omitted, the range has just one
code point; MAPPING is what each code point between START and STOP maps to.
END
- if ($output_range_counts) {
+ if ($self->output_range_counts) {
$comment .= <<END;
Numbers in comments in [brackets] indicate how many code points are in the
range (omitted when the range is a single code point or if the mapping is to
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
my $name = $self->property->swash_name;
# multiple code points. These do not appear in the main body, but are defined
# in the hash below.
-# The key: UTF-8 _bytes_, the value: UTF-8 (speed hack)
+# Each key is the string of N bytes that together make up the UTF-8 encoding
+# for the code point. (i.e. the same as looking at the code point's UTF-8
+# under "use bytes"). Each value is the UTF-8 of the translation, for speed.
%utf8::ToSpec$name = (
END
$pre_body .= join("\n", @multi_code_point_maps) . "\n);\n";
# These constants names and values were taken from the Unicode standard,
# version 5.1, section 3.12. They are used in conjunction with Hangul
# syllables
- my \$SBase = 0xAC00;
- my \$LBase = 0x1100;
- my \$VBase = 0x1161;
- my \$TBase = 0x11A7;
- my \$SCount = 11172;
- my \$LCount = 19;
- my \$VCount = 21;
- my \$TCount = 28;
+ my \$SBase = $SBase_string;
+ my \$LBase = $LBase_string;
+ my \$VBase = $VBase_string;
+ my \$TBase = $TBase_string;
+ my \$SCount = $SCount;
+ my \$LCount = $LCount;
+ my \$VCount = $VCount;
+ my \$TCount = $TCount;
my \$NCount = \$VCount * \$TCount;
END
} # End of has Jamos
my $L = $LBase + $SIndex / $NCount;
my $V = $VBase + ($SIndex % $NCount) / $TCount;
my $T = $TBase + $SIndex % $TCount;
- $name = "$HANGUL_SYLLABLE $Jamo{$L}$Jamo{$V}";
+ $name = "$HANGUL_SYLLABLE$Jamo{$L}$Jamo{$V}";
$name .= $Jamo{$T} if $T != $TBase;
return $name;
}
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
return $self->SUPER::write(
($self->property == $block)
}
# Accessors for the underlying list that should fail if locked.
- for my $sub qw(
+ for my $sub (qw(
add_duplicate
- )
+ ))
{
no strict "refs";
*$sub = sub {
# 'table' (If you change the '=' must also change the ':' in lots of
# places in this program that assume an equal sign)
$complete = $property->full_name . "=$complete" if $property != $perl;
-
my $self = $class->SUPER::new(%args,
Name => $name,
_Property => $property,
_Range_List => $range_list,
);
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
$conflicting{$addr} = [ ];
$equivalents{$addr} = [ ];
return if $self->carp_if_locked;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
if (ref $other) {
# be an optional parameter.
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
# Check if the conflicting name is exactly the same as any existing
# alias in this table (as long as there is a real object there to
}
# Two tables are equivalent if they have the same leader.
- return $leader{main::objaddr $self}
- == $leader{main::objaddr $other};
+ no overloading;
+ return $leader{pack 'J', $self} == $leader{pack 'J', $other};
return;
}
my $are_equivalent = $self->is_equivalent_to($other);
return if ! defined $are_equivalent || $are_equivalent;
- my $current_leader = ($related)
- ? $parent{main::objaddr $self}
- : $leader{main::objaddr $self};
+ my $addr = do { no overloading; pack 'J', $self; };
+ my $current_leader = ($related) ? $parent{$addr} : $leader{$addr};
if ($related &&
! $other->perl_extension
$related = 0;
}
- my $leader = main::objaddr $current_leader;
- my $other_addr = main::objaddr $other;
+ my $leader = do { no overloading; pack 'J', $current_leader; };
+ my $other_addr = do { no overloading; pack 'J', $other; };
# Any tables that are equivalent to or children of this table must now
# instead be equivalent to or (children) to the new leader (parent),
next if $table == $other;
trace "setting $other to be the leader of $table, status=$status" if main::DEBUG && $to_trace;
- my $table_addr = main::objaddr $table;
+ my $table_addr = do { no overloading; pack 'J', $table; };
$leader{$table_addr} = $other;
$matches_all{$table_addr} = $matches_all;
$self->_set_range_list($other->_range_list);
# an equivalent group
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr $leader;
+ my $addr = do { no overloading; pack 'J', $leader; };
if ($leader{$addr} != $leader) {
Carp::my_carp_bug(<<END
&& $parent == $property->table('N')
&& defined (my $yes = $property->table('Y')))
{
- my $yes_addr = main::objaddr $yes;
+ my $yes_addr = do { no overloading; pack 'J', $yes; };
@yes_perl_synonyms
= grep { $_->property == $perl }
main::uniques($yes,
my @conflicting; # Will hold the table conflicts.
# Look at the parent, any yes synonyms, and all the children
+ my $parent_addr = do { no overloading; pack 'J', $parent; };
for my $table ($parent,
@yes_perl_synonyms,
- @{$children{main::objaddr $parent}})
+ @{$children{$parent_addr}})
{
- my $table_addr = main::objaddr $table;
+ my $table_addr = do { no overloading; pack 'J', $table; };
my $table_property = $table->property;
# Tables are separated by a blank line to create a grouping.
START\\tSTOP\\twhere START is the starting code point of the range, in hex;
STOP is the ending point, or if omitted, the range has just one code point.
END
- if ($output_range_counts) {
+ if ($leader->output_range_counts) {
$comment .= <<END;
Numbers in comments in [brackets] indicate how many code points are in the
range.
}
# Accessors for the underlying list
- for my $sub qw(
+ for my $sub (qw(
get_valid_code_point
get_invalid_code_point
- )
+ ))
{
no strict "refs";
*$sub = sub {
my %args = @_;
$self = bless \do { my $anonymous_scalar }, $class;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
$directory{$addr} = delete $args{'Directory'};
$file{$addr} = delete $args{'File'};
return $self;
}
else {
- $map{main::objaddr $self}->delete_range($other, $other);
+ no overloading;
+ $map{pack 'J', $self}->delete_range($other, $other);
}
return $self;
}
my $name = shift;
my %args = @_;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
my $table = $table_ref{$addr}{$name};
my $standard_name = main::standardize($name);
my $name = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
return $table_ref{$addr}{$name} if defined $table_ref{$addr}{$name};
# Return a list of pointers to all the match tables attached to this
# property
- return main::uniques(values %{$table_ref{main::objaddr shift}});
+ no overloading;
+ return main::uniques(values %{$table_ref{pack 'J', shift}});
}
sub directory {
# priority; 'undef' is returned if the type isn't defined;
# or $map_directory for everything else.
- my $addr = main::objaddr shift;
+ my $addr = do { no overloading; pack 'J', shift; };
return $directory{$addr} if defined $directory{$addr};
return undef if $type{$addr} == $UNKNOWN;
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
return $file{$addr} if defined $file{$addr};
return $map{$addr}->external_name;
# The whole point of this pseudo property is match tables.
return 1 if $self == $perl;
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
# Don't generate tables of code points that match the property values
# of a string property. Such a list would most likely have many
return;
}
- return $map{main::objaddr $self}->
- map_add_or_replace_non_nulls($map{main::objaddr $other});
+ no overloading;
+ return $map{pack 'J', $self}->map_add_or_replace_non_nulls($map{pack 'J', $other});
}
sub set_type {
return;
}
- $type{main::objaddr $self} = $type;
+ { no overloading; $type{pack 'J', $self} = $type; }
return if $type != $BINARY;
my $yes = $self->table('Y');
my $map = shift; # What the range maps to.
# Rest of parameters passed on.
- my $addr = main::objaddr $self;
+ my $addr = do { no overloading; pack 'J', $self; };
# If haven't the type of the property, gather information to figure it
# out.
my $self = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr($self);
+ my $addr = do { no overloading; pack 'J', $self; };
my $type = $type{$addr};
# Most of the accessors for a property actually apply to its map table.
# Setup up accessor functions for those, referring to %map
- for my $sub qw(
+ for my $sub (qw(
add_alias
add_anomalous_entry
add_comment
aliases
comment
complete_name
+ containing_range
core_access
count
default_map
status
status_info
to_output_map
+ type_of
value_of
write
- )
+ ))
# 'property' above is for symmetry, so that one can take
# the property of a property and get itself, and so don't
# have to distinguish between properties and tables in
*$sub = sub {
use strict "refs";
my $self = shift;
- return $map{main::objaddr $self}->$sub(@_);
+ no overloading;
+ return $map{pack 'J', $self}->$sub(@_);
}
}
push @files_actually_output, $file;
- my $text;
- if (@$lines_ref) {
- $text = join "", @$lines_ref;
- }
- else {
- $text = "";
+ unless (@$lines_ref) {
Carp::my_carp("Output file '$file' is empty; writing it anyway;");
}
Carp::my_carp("can't open $file for output. Skipping this file: $!");
return;
}
+
+ print $OUT @$lines_ref or die Carp::my_carp("write to '$file' failed: $!");
+ close $OUT or die Carp::my_carp("close '$file' failed: $!");
+
print "$file written.\n" if $verbosity >= $VERBOSE;
- print $OUT $text;
- close $OUT;
return;
}
else {
# Keep track of cycles in the input, and refuse to infinitely loop
- if (defined $already_output{main::objaddr $item}) {
+ my $addr = do { no overloading; pack 'J', $item; };
+ if (defined $already_output{$addr}) {
return "${indent}ALREADY OUTPUT: $item\n";
}
- $already_output{main::objaddr $item} = $item;
+ $already_output{$addr} = $item;
if (ref $item eq 'ARRAY') {
my $using_brackets;
my $fields_ref = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
- my $addr = main::objaddr $object;
+ my $addr = do { no overloading; pack 'J', $object; };
my %hash;
foreach my $key (keys %$fields_ref) {
}
else {
my $ref = ref $$which;
- my $addr = main::objaddr $$which;
+ my $addr = do { no overloading; pack 'J', $$which; };
$$which = "$ref ($addr)";
}
}
return 0 unless defined $other;
return 0 unless ref $other;
- return main::objaddr $self == main::objaddr $other;
+ no overloading;
+ return $self == $other;
}
sub _operator_not_equal {
;
# The defaults apply only to unassigned characters
- $default_R .= '$gc->table("Cn") & $default;';
+ $default_R .= '$gc->table("Unassigned") & $default;';
if ($v_version lt v3.0.0) {
$default = Multi_Default->new(R => $default_R, 'L');
if ($v_version ge 3.1.0) {
$default_AL .= '$default->delete_range(0xFDD0, 0xFDEF);';
}
- $default_AL .= '$gc->table("Cn") & $default';
+ $default_AL .= '$gc->table("Unassigned") & $default';
$default = Multi_Default->new(AL => $default_AL,
R => $default_R,
'L');
return @return;
}
+sub output_perl_charnames_line ($$) {
+
+ # Output the entries in Perl_charnames specially, using 5 digits instead
+ # of four. This makes the entries a constant length, and simplifies
+ # charnames.pm which this table is for. Unicode can have 6 digit
+ # ordinals, but they are all private use or noncharacters which do not
+ # have names, so won't be in this table.
+
+ return sprintf "%05X\t%s\n", $_[0], $_[1];
+}
+
{ # Closure
# This is used to store the range list of all the code points usable when
# the little used $compare_versions feature is enabled.
$file->carp_bad_line("Unexpected property '$property_name'. Skipped");
next LINE;
}
- $property_addr = main::objaddr($property_object);
+ { no overloading; $property_addr = pack 'J', $property_object; }
# Defer changing names until have a line that is acceptable
# (the 'next' statement above means is unacceptable)
if $file->has_missings_defaults;
foreach my $default_ref (@missings_list) {
my $default = $default_ref->[0];
- my $addr = objaddr property_ref($default_ref->[1]);
+ my $addr = do { no overloading; pack 'J', property_ref($default_ref->[1]); };
# For string properties, the default is just what the
# file says, but non-string properties should already
else {
$default_map = $missings;
}
-
+
# And store it with the property for outside use.
$property_object->set_default_map($default_map);
}
}
}
-# XXX Unused until revise charnames;
-#sub check_and_handle_compound_name {
-# This looks at Name properties for parenthesized components and splits
-# them off. Thus it finds FF as an equivalent to Form Feed.
-# my $code_point = shift;
-# my $name = shift;
-# if ($name =~ /^ ( .*? ) ( \s* ) \( ( [^)]* ) \) (.*) $/x) {
-# #local $to_trace = 1 if main::DEBUG;
-# trace $1, $2, $3, $4 if main::DEBUG && $to_trace;
-# push @more_Names, "$code_point; $1";
-# push @more_Names, "$code_point; $3";
-# Carp::my_carp_bug("Expecting blank space before left parenthesis in '$_'. Proceeding and assuming it was there;") if $2 ne " ";
-# Carp::my_carp_bug("Not expecting anything after the right parenthesis in '$_'. Proceeding and ignoring that;") if $4 ne "";
-# }
-# return;
-#}
-
{ # Closure for UnicodeData.txt handling
# This file was the first one in the UCD; its design leads to some
# 0041;LATIN CAPITAL LETTER A;Lu;0;L;;;;;N;;;;0061;
# The fields in order are:
my $i = 0; # The code point is in field 0, and is shifted off.
- my $NAME = $i++; # character name (e.g. "LATIN CAPITAL LETTER A")
+ my $CHARNAME = $i++; # character name (e.g. "LATIN CAPITAL LETTER A")
my $CATEGORY = $i++; # category (e.g. "Lu")
my $CCC = $i++; # Canonical combining class (e.g. "230")
my $BIDI = $i++; # directional class (e.g. "L")
# This routine in addition outputs these extra fields:
my $DECOMP_TYPE = $i++; # Decomposition type
- my $DECOMP_MAP = $i++; # Must be last; another decomposition mapping
+
+ # These fields are modifications of ones above, and are usually
+ # suppressed; they must come last, as for speed, the loop upper bound is
+ # normally set to ignore them
+ my $NAME = $i++; # This is the strict name field, not the one that
+ # charnames uses.
+ my $DECOMP_MAP = $i++; # Strict decomposition mapping; not the one used
+ # by Unicode::Normalize
my $last_field = $i - 1;
# All these are read into an array for each line, with the indices defined
$field_names[$BIDI] = 'Bidi_Class';
$field_names[$CATEGORY] = 'General_Category';
$field_names[$CCC] = 'Canonical_Combining_Class';
+ $field_names[$CHARNAME] = 'Perl_Charnames';
$field_names[$COMMENT] = 'ISO_Comment';
$field_names[$DECOMP_MAP] = 'Decomposition_Mapping';
$field_names[$DECOMP_TYPE] = 'Decomposition_Type';
- $field_names[$LOWER] = 'Simple_Lowercase_Mapping';
+ $field_names[$LOWER] = 'Lowercase_Mapping';
$field_names[$MIRRORED] = 'Bidi_Mirrored';
$field_names[$NAME] = 'Name';
$field_names[$NUMERIC] = 'Numeric_Value';
$field_names[$NUMERIC_TYPE_OTHER_DIGIT] = 'Numeric_Type';
$field_names[$PERL_DECIMAL_DIGIT] = 'Perl_Decimal_Digit';
$field_names[$PERL_DECOMPOSITION] = 'Perl_Decomposition_Mapping';
- $field_names[$TITLE] = 'Simple_Titlecase_Mapping';
+ $field_names[$TITLE] = 'Titlecase_Mapping';
$field_names[$UNICODE_1_NAME] = 'Unicode_1_Name';
- $field_names[$UPPER] = 'Simple_Uppercase_Mapping';
-
- # Some of these need a little more explanation. The $PERL_DECIMAL_DIGIT
- # field does not lead to an official Unicode property, but is used in
- # calculating the Numeric_Type. Perl however, creates a file from this
- # field, so a Perl property is created from it. Similarly, the Other
- # Digit field is used only for calculating the Numeric_Type, and so it can
- # be safely re-used as the place to store the value for Numeric_Type;
- # hence it is referred to as $NUMERIC_TYPE_OTHER_DIGIT. The input field
- # named $PERL_DECOMPOSITION is a combination of both the decomposition
- # mapping and its type. Perl creates a file containing exactly this
- # field, so it is used for that. The two properties are separated into
- # two extra output fields, $DECOMP_MAP and $DECOMP_TYPE.
+ $field_names[$UPPER] = 'Uppercase_Mapping';
+
+ # Some of these need a little more explanation:
+ # The $PERL_DECIMAL_DIGIT field does not lead to an official Unicode
+ # property, but is used in calculating the Numeric_Type. Perl however,
+ # creates a file from this field, so a Perl property is created from it.
+ # Similarly, the Other_Digit field is used only for calculating the
+ # Numeric_Type, and so it can be safely re-used as the place to store
+ # the value for Numeric_Type; hence it is referred to as
+ # $NUMERIC_TYPE_OTHER_DIGIT.
+ # The input field named $PERL_DECOMPOSITION is a combination of both the
+ # decomposition mapping and its type. Perl creates a file containing
+ # exactly this field, so it is used for that. The two properties are
+ # separated into two extra output fields, $DECOMP_MAP and $DECOMP_TYPE.
+ # $DECOMP_MAP is usually suppressed (unless the lists are changed to
+ # output it), as Perl doesn't use it directly.
+ # The input field named here $CHARNAME is used to construct the
+ # Perl_Charnames property, which is a combination of the Name property
+ # (which the input field contains), and the Unicode_1_Name property, and
+ # others from other files. Since, the strict Name property is not used
+ # by Perl, this field is used for the table that Perl does use. The
+ # strict Name property table is usually suppressed (unless the lists are
+ # changed to output it), so it is accumulated in a separate field,
+ # $NAME, which to save time is discarded unless the table is actually to
+ # be output
# This file is processed like most in this program. Control is passed to
# process_generic_property_file() which calls filter_UnicodeData_line()
my $file = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
+ # Create a new property specially located that is a combination of the
+ # 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_charname = Property->new('Perl_Charnames',
+ Core_Access => '\N{...} and "use charnames"',
+ Default_Map => "",
+ Directory => File::Spec->curdir(),
+ File => 'Name',
+ Internal_Only_Warning => 1,
+ Perl_Extension => 1,
+ Range_Size_1 => \&output_perl_charnames_line,
+ Type => $STRING,
+ );
+
my $Perl_decomp = Property->new('Perl_Decomposition_Mapping',
Directory => File::Spec->curdir(),
File => 'Decomposition',
Perl_Extension => 1,
Default_Map => $CODE_POINT,
+ # normalize.pm can't cope with these
+ Output_Range_Counts => 0,
+
# This is a specially formatted table
# explicitly for normalize.pm, which
# is expecting a particular format,
END
));
- # This property is not used for generating anything else, and is
- # usually not output. By making it last in the list, we can just
+ # These properties are not used for generating anything else, and are
+ # usually not output. By making them last in the list, we can just
# change the high end of the loop downwards to avoid the work of
- # generating a table that is just going to get thrown away.
- if (! property_ref('Decomposition_Mapping')->to_output_map) {
- $last_field--;
+ # generating a table(s) that is/are just going to get thrown away.
+ if (! property_ref('Decomposition_Mapping')->to_output_map
+ && ! property_ref('Name')->to_output_map)
+ {
+ $last_field = min($NAME, $DECOMP_MAP) - 1;
+ } elsif (property_ref('Decomposition_Mapping')->to_output_map) {
+ $last_field = $DECOMP_MAP;
+ } elsif (property_ref('Name')->to_output_map) {
+ $last_field = $NAME;
}
return;
}
# Certain fields just haven't been empty so far in any Unicode
# version, so don't look at those, namely $MIRRORED, $BIDI, $CCC,
# $CATEGORY. This leaves just the two fields, and so we hard-code in
- # the defaults; which are verly unlikely to ever change.
+ # the defaults; which are very unlikely to ever change.
$fields[$UPPER] = $CODE_POINT if $fields[$UPPER] eq "";
$fields[$LOWER] = $CODE_POINT if $fields[$LOWER] eq "";
# D7A3;<Hangul Syllable, Last>;Lo;0;L;;;;;N;;;;;
# that define ranges. These should be processed after the fields are
# adjusted above, as they may override some of them; but mostly what
- # is left is to possibly adjust the $NAME field. The names of all the
+ # is left is to possibly adjust the $CHARNAME field. The names of all the
# paired lines start with a '<', but this is also true of '<control>,
# which isn't one of these special ones.
- if ($fields[$NAME] eq '<control>') {
+ if ($fields[$CHARNAME] eq '<control>') {
# Some code points in this file have the pseudo-name
# '<control>', but the official name for such ones is the null
- # string.
+ # string. For charnames.pm, we use the Unicode version 1 name
$fields[$NAME] = "";
+ $fields[$CHARNAME] = $fields[$UNICODE_1_NAME];
# We had better not be in between range lines.
if ($in_range) {
- $file->carp_bad_line("Expecting a closing range line, not a $fields[$NAME]'. Trying anyway");
+ $file->carp_bad_line("Expecting a closing range line, not a $fields[$CHARNAME]'. Trying anyway");
$in_range = 0;
}
}
- elsif (substr($fields[$NAME], 0, 1) ne '<') {
+ elsif (substr($fields[$CHARNAME], 0, 1) ne '<') {
# Here is a non-range line. We had better not be in between range
# lines.
if ($in_range) {
- $file->carp_bad_line("Expecting a closing range line, not a $fields[$NAME]'. Trying anyway");
+ $file->carp_bad_line("Expecting a closing range line, not a $fields[$CHARNAME]'. Trying anyway");
$in_range = 0;
}
- # XXX until charnames catches up.
-# if ($fields[$NAME] =~ s/- $cp $//x) {
-#
-# # These are code points whose names end in their code points,
-# # which means the names are algorithmically derivable from the
-# # code points. To shorten the output Name file, the algorithm
-# # for deriving these is placed in the file instead of each
-# # code point, so they have map type $CP_IN_NAME
-# $fields[$NAME] = $CMD_DELIM
-# . $MAP_TYPE_CMD
-# . '='
-# . $CP_IN_NAME
-# . $CMD_DELIM
-# . $fields[$NAME];
-# }
-
- # Some official names are really two alternate names with one in
- # parentheses. What we do here is use the full official one for
- # the standard property (stored just above), but for the charnames
- # table, we add two more entries, one for each of the alternate
- # ones.
- # elsif name ne ""
- #check_and_handle_compound_name($cp, $fields[$NAME]);
- #check_and_handle_compound_name($cp, $unicode_1_name);
- # XXX until charnames catches up.
- }
- elsif ($fields[$NAME] =~ /^<(.+), First>$/) {
- $fields[$NAME] = $1;
+ if ($fields[$CHARNAME] =~ s/- $cp $//x) {
+
+ # These are code points whose names end in their code points,
+ # which means the names are algorithmically derivable from the
+ # code points. To shorten the output Name file, the algorithm
+ # for deriving these is placed in the file instead of each
+ # code point, so they have map type $CP_IN_NAME
+ $fields[$CHARNAME] = $CMD_DELIM
+ . $MAP_TYPE_CMD
+ . '='
+ . $CP_IN_NAME
+ . $CMD_DELIM
+ . $fields[$CHARNAME];
+ }
+ $fields[$NAME] = $fields[$CHARNAME];
+ }
+ elsif ($fields[$CHARNAME] =~ /^<(.+), First>$/) {
+ $fields[$CHARNAME] = $fields[$NAME] = $1;
# Here we are at the beginning of a range pair.
if ($in_range) {
- $file->carp_bad_line("Expecting a closing range line, not a beginning one, $fields[$NAME]'. Trying anyway");
+ $file->carp_bad_line("Expecting a closing range line, not a beginning one, $fields[$CHARNAME]'. Trying anyway");
}
$in_range = 1;
$force_output = 1;
}
- elsif ($fields[$NAME] !~ s/^<(.+), Last>$/$1/) {
- $file->carp_bad_line("Unexpected name starting with '<' $fields[$NAME]. Ignoring this line.");
+ elsif ($fields[$CHARNAME] !~ s/^<(.+), Last>$/$1/) {
+ $file->carp_bad_line("Unexpected name starting with '<' $fields[$CHARNAME]. Ignoring this line.");
$_ = "";
return;
}
else { # Here, we are at the last line of a range pair.
if (! $in_range) {
- $file->carp_bad_line("Unexpected end of range $fields[$NAME] when not in one. Ignoring this line.");
+ $file->carp_bad_line("Unexpected end of range $fields[$CHARNAME] when not in one. Ignoring this line.");
$_ = "";
return;
}
$in_range = 0;
+ $fields[$NAME] = $fields[$CHARNAME];
+
# Check that the input is valid: that the closing of the range is
# the same as the beginning.
foreach my $i (0 .. $last_field) {
}
# The processing differs depending on the type of range,
- # determined by its $NAME
- if ($fields[$NAME] =~ /^Hangul Syllable/) {
+ # determined by its $CHARNAME
+ if ($fields[$CHARNAME] =~ /^Hangul Syllable/) {
# Check that the data looks right.
if ($decimal_previous_cp != $SBase) {
# This range is stored in our internal structure with its
# own map type, different from all others.
- $previous_fields[$NAME] = $CMD_DELIM
+ $previous_fields[$CHARNAME] = $previous_fields[$NAME]
+ = $CMD_DELIM
. $MAP_TYPE_CMD
. '='
. $HANGUL_SYLLABLE
. $CMD_DELIM
- . $fields[$NAME];
+ . $fields[$CHARNAME];
}
- elsif ($fields[$NAME] =~ /^CJK/) {
+ elsif ($fields[$CHARNAME] =~ /^CJK/) {
# The name for these contains the code point itself, and all
# are defined to have the same base name, regardless of what
# is in the file. They are stored in our internal structure
# with a map type of $CP_IN_NAME
- $previous_fields[$NAME] = $CMD_DELIM
+ $previous_fields[$CHARNAME] = $previous_fields[$NAME]
+ = $CMD_DELIM
. $MAP_TYPE_CMD
. '='
. $CP_IN_NAME
# null, as there are no names for the private use and
# surrogate code points.
- $previous_fields[$NAME] = "";
+ $previous_fields[$CHARNAME] = $previous_fields[$NAME] = "";
}
else {
- $file->carp_bad_line("Unexpected code point range $fields[$NAME] because category is $fields[$CATEGORY]. Attempting to process it.");
+ $file->carp_bad_line("Unexpected code point range $fields[$CHARNAME] because category is $fields[$CATEGORY]. Attempting to process it.");
}
# The first line of the range caused everything else to be output,
# code in this subroutine that does the same thing, but doesn't
# know about these ranges.
$_ = "";
+
return;
}
while ($file->next_line) {
push @backslash_X_tests, $_;
}
-
+
return;
}
#
# This just adds the sequence to an array for later handling
- return; # XXX Until charnames catches up
my $file = shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
"Doesn't look like 'KHMER VOWEL SIGN OM;17BB 17C6'");
next;
}
- push @named_sequences, "$sequence\t\t$name";
+
+ # Note single \t in keeping with special output format of
+ # Perl_charnames. But it turns out that the code points don't have to
+ # be 5 digits long, like the rest, based on the internal workings of
+ # charnames.pm. This could be easily changed for consistency.
+ push @named_sequences, "$sequence\t$name";
}
return;
}
sub setup_special_casing {
# SpecialCasing.txt contains the non-simple case change mappings. The
- # simple ones are in UnicodeData.txt, and should already have been read
- # in.
- # This routine initializes the full mappings to the simple, then as each
- # line is processed, it overrides the simple ones.
+ # simple ones are in UnicodeData.txt, which should already have been read
+ # in to the full property data structures, so as to initialize these with
+ # the simple ones. Then the SpecialCasing.txt entries overwrite the ones
+ # which have different full mappings.
+
+ # This routine sees if the simple mappings are to be output, and if so,
+ # copies what has already been put into the full mapping tables, while
+ # they still contain only the simple mappings.
+
+ # The reason it is done this way is that the simple mappings are probably
+ # not going to be output, so it saves work to initialize the full tables
+ # with the simple mappings, and then overwrite those relatively few
+ # entries in them that have different full mappings, and thus skip the
+ # simple mapping tables altogether.
my $file= shift;
Carp::carp_extra_args(\@_) if main::DEBUG && @_;
# For each of the case change mappings...
foreach my $case ('lc', 'tc', 'uc') {
+ my $full = property_ref($case);
+ unless (defined $full && ! $full->is_empty) {
+ Carp::my_carp_bug("Need to process UnicodeData before SpecialCasing. Only special casing will be generated.");
+ }
# The simple version's name in each mapping merely has an 's' in front
# of the full one's
my $simple = property_ref('s' . $case);
- unless (defined $simple && ! $simple->is_empty) {
- Carp::my_carp_bug("Need to process UnicodeData before SpecialCasing. Only special casing will be generated.");
- }
-
- # Initialize the full case mappings with the simple ones.
- property_ref($case)->initialize($simple);
+ $simple->initialize($full) if $simple->to_output_map();
}
return;
my $Pc = $gc->table('Connector_Punctuation'); # 'Pc' Not in release 1
$Word += $Pc if defined $Pc;
- # There is no [[:Word:]], so the name doesn't begin with Posix.
+ # This is a Perl extension, so the name doesn't begin with Posix.
$perl->add_match_table('PerlWord',
Description => '\w, restricted to ASCII = [A-Za-z0-9_]',
Initialize => $Word & $ASCII,
Initialize => $Blank + $VertSpace,
);
$perl->add_match_table("PosixSpace",
- Description => "\\t \\n, \\x0B, \\f, \\r, and ' '",
+ Description => "\\t, \\n, \\cK, \\f, \\r, and ' '. (\\cK is vertical tab)",
Initialize => $Space & $ASCII,
);
Description => 'Control characters');
$Cntrl->set_equivalent_to($gc->table('Cc'), Related => 1);
$perl->add_match_table("PosixCntrl",
- Description => '[\x00-\x1F]',
+ 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",
Initialize => $Cntrl & $ASCII,
);
Initialize => ~ ($Space + $controls),
);
$perl->add_match_table("PosixGraph",
- Description => '[\x21-\x7E]',
+ Description =>
+ '[-!"#$%&\'()*+,./:;<>?@[\\\]^_`{|}~0-9A-Za-z]',
Initialize => $Graph & $ASCII,
);
- my $Print = $perl->add_match_table('Print',
+ $print = $perl->add_match_table('Print',
Description => 'Characters that are graphical plus space characters (but no controls)',
Initialize => $Blank + $Graph - $gc->table('Control'),
);
$perl->add_match_table("PosixPrint",
- Description => '[\x20-\x7E]',
- Initialize => $Print & $ASCII,
+ Description =>
+ '[- 0-9A-Za-z!"#$%&\'()*+,./:;<>?@[\\\]^_`{|}~]',
+ Initialize => $print & $ASCII,
);
my $Punct = $perl->add_match_table('Punct');
# \p{punct} doesn't include the symbols, which posix does
$perl->add_match_table('PosixPunct',
- Description => 'Graphical characters that aren\'t Word characters = [\x21-\x2F\x3A-\x40\x5B-\x60\x7B-\x7E]',
+ Description => '[-!"#$%&\'()*+,./:;<>?@[\\\]^_`{|}~]',
Initialize => $ASCII & ($gc->table('Punctuation')
+ $gc->table('Symbol')),
);
Initialize => $Digit & $ASCII,
);
- # AHex was not present in early releases
- # XXX TUS recommends Hex_Digit, not ASCII_Hex_Digit.
- my $Xdigit = $perl->add_match_table('XDigit',
- Description => '[0-9A-Fa-f]');
- my $AHex = property_ref('ASCII_Hex_Digit');
- if (defined $AHex && ! $AHex->is_empty) {
- $Xdigit->set_equivalent_to($AHex->table('Y'), Related => 1);
+ # Hex_Digit was not present in first release
+ my $Xdigit = $perl->add_match_table('XDigit');
+ my $Hex = property_ref('Hex_Digit');
+ if (defined $Hex && ! $Hex->is_empty) {
+ $Xdigit->set_equivalent_to($Hex->table('Y'), Related => 1);
}
else {
- # (Have to use hex because could be running on a non-ASCII machine,
- # and we want the Unicode (ASCII) values)
- $Xdigit->initialize([ 0x30..0x39, 0x41..0x46, 0x61..0x66 ]);
+ # (Have to use hex instead of e.g. '0', because could be running on an
+ # non-ASCII machine, and we want the Unicode (ASCII) values)
+ $Xdigit->initialize([ 0x30..0x39, 0x41..0x46, 0x61..0x66,
+ 0xFF10..0xFF19, 0xFF21..0xFF26, 0xFF41..0xFF46]);
+ $Xdigit->add_description('[0-9A-Fa-f] and corresponding fullwidth versions, like U+FF10: FULLWIDTH DIGIT ZERO');
}
my $dt = property_ref('Decomposition_Type');
my $gcb = property_ref('Grapheme_Cluster_Break');
- # The 'extended' grapheme cluster came in 5.1. The non-extended
+ # The 'extended' grapheme cluster came in 5.1. The non-extended
# definition differs too much from the traditional Perl one to use.
if (defined $gcb && defined $gcb->table('SpacingMark')) {
$lv_lvt_v->add_comment('For use in \X; matches: HST=LV | HST=LVT | HST=V');
}
- # Create a new property specially located that is a combination of the
- # various Name properties: Name, Unicode_1_Name, Named Sequences, and
- # Name_Alias properties. (The final duplicates elements of the first.) A
- # comment for it is constructed based on the actual properties present and
- # used
- my $perl_charname = Property->new('Perl_Charnames',
- Core_Access => '\N{...} and charnames.pm',
- Default_Map => "",
- Directory => File::Spec->curdir(),
- File => 'Name',
- Internal_Only_Warning => 1,
- Perl_Extension => 1,
- Range_Size_1 => 1,
- Type => $STRING,
- Initialize => property_ref('Unicode_1_Name'),
- );
- # Name overrides Unicode_1_Name
- $perl_charname->property_add_or_replace_non_nulls(property_ref('Name'));
+ # Was previously constructed to contain both Name and Unicode_1_Name
my @composition = ('Name', 'Unicode_1_Name');
if (@named_sequences) {
$comment .= ", and $composition[-1]";
}
- # Wait for charnames to catch up
-# foreach my $entry (@more_Names,
-# split "\n", <<"END"
-#000A; LF
-#000C; FF
-#000D; CR
-#0085; NEL
-#200C; ZWNJ
-#200D; ZWJ
-#FEFF; BOM
-#FEFF; BYTE ORDER MARK
-#END
-# ) {
-# #local $to_trace = 1 if main::DEBUG;
-# trace $entry if main::DEBUG && $to_trace;
-# my ($code_point, $name) = split /\s*;\s*/, $entry;
-# $code_point = hex $code_point;
-# trace $code_point, $name if main::DEBUG && $to_trace;
-# $perl_charname->add_duplicate($code_point, $name);
-# }
-# #$perl_charname->add_comment("This file is for charnames.pm. It is the union of the $comment properties, plus certain commonly used but unofficial names, such as 'FF' and 'ZWNJ'. Unicode_1_Name entries are used only for otherwise nameless code points.$alias_sentence");
$perl_charname->add_comment(join_lines( <<END
This file is for charnames.pm. It is the union of the $comment properties.
Unicode_1_Name entries are used only for otherwise nameless code
The Name property is accessible through the \\N{} interpolation in
double-quoted strings and regular expressions, but both usages require a C<use
-charnames;> to be specified, which also contains related functions viacode()
-and vianame().
+charnames;> to be specified, which also contains related functions viacode(),
+vianame(), and string_vianame().
=head1 Unicode regular expression properties that are NOT accepted by Perl
For example, the uc() function implements the Uppercase_Mapping property and
uses the F<Upper.pl> file found in this directory.
-The available files with their properties (short names in parentheses),
-and any flags or comments about them, are:
+The available files in the current installation, with their properties (short
+names in parentheses), and any flags or comments about them, are:
@map_tables_actually_output
. $spaces_after;
}
-sub generate_tests($$$$$$) {
+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.
- my $file_handle = shift; # Where to output the tests
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
# The whole 'property=value'
my $name = "$lhs$separator$rhs";
+ my @output;
# Create a complete set of tests, with complements.
if (defined $valid_code) {
- printf $file_handle
- qq/Expect(1, $valid_code, '\\p{$name}', $warning);\n/;
- printf $file_handle
- qq/Expect(0, $valid_code, '\\p{^$name}', $warning);\n/;
- printf $file_handle
- qq/Expect(0, $valid_code, '\\P{$name}', $warning);\n/;
- printf $file_handle
- qq/Expect(1, $valid_code, '\\P{^$name}', $warning);\n/;
+ push @output, <<"EOC"
+Expect(1, $valid_code, '\\p{$name}', $warning);
+Expect(0, $valid_code, '\\p{^$name}', $warning);
+Expect(0, $valid_code, '\\P{$name}', $warning);
+Expect(1, $valid_code, '\\P{^$name}', $warning);
+EOC
}
if (defined $invalid_code) {
- printf $file_handle
- qq/Expect(0, $invalid_code, '\\p{$name}', $warning);\n/;
- printf $file_handle
- qq/Expect(1, $invalid_code, '\\p{^$name}', $warning);\n/;
- printf $file_handle
- qq/Expect(1, $invalid_code, '\\P{$name}', $warning);\n/;
- printf $file_handle
- qq/Expect(0, $invalid_code, '\\P{^$name}', $warning);\n/;
- }
- return;
+ push @output, <<"EOC"
+Expect(0, $invalid_code, '\\p{$name}', $warning);
+Expect(1, $invalid_code, '\\p{^$name}', $warning);
+Expect(1, $invalid_code, '\\P{$name}', $warning);
+Expect(0, $invalid_code, '\\P{^$name}', $warning);
+EOC
+ }
+ return @output;
}
-sub generate_error($$$$) {
+sub generate_error($$$) {
# This used only for making the test script. It generates test cases that
# are expected to not only not match, but to be syntax or similar errors
- my $file_handle = shift; # Where to output to.
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 $property = $lhs . $separator . $rhs;
- print $file_handle qq/Error('\\p{$property}');\n/;
- print $file_handle qq/Error('\\P{$property}');\n/;
- return;
+ return <<"EOC";
+Error('\\p{$property}');
+Error('\\P{$property}');
+EOC
}
# These are used only for making the test script
$t_path = 'TestProp.pl' unless defined $t_path; # the traditional name
- force_unlink ($t_path);
- push @files_actually_output, $t_path;
- my $OUT;
- if (not open $OUT, "> $t_path") {
- Carp::my_carp("Can't open $t_path. Skipping: $!");
- return;
- }
-
# Keep going down an order of magnitude
# until find that adding this quantity to
# 1 remains 1; but put an upper limit on
# use previous one
$min_floating_slop = $next;
}
- print $OUT $HEADER, <DATA>;
+
+ # 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;
foreach my $property (property_ref('*')) {
foreach my $table ($property->tables) {
my $already_error = ! $table->file_path;
# Generate error cases for this alias.
- generate_error($OUT,
- $property_name,
- $table_name,
- $already_error);
+ push @output, generate_error($property_name,
+ $table_name,
+ $already_error);
# If the table is guaranteed to always generate an error,
# quit now without generating success cases.
# Don't output duplicate test cases.
if (! exists $test_generated{$test_name}) {
$test_generated{$test_name} = 1;
- generate_tests($OUT,
- $property_name,
- $standard,
- $valid,
- $invalid,
- $warning,
- );
+ push @output, generate_tests($property_name,
+ $standard,
+ $valid,
+ $invalid,
+ $warning,
+ );
}
$random = randomize_loose_name($table_name)
}
my $test_name = "$property_name=$random";
if (! exists $test_generated{$test_name}) {
$test_generated{$test_name} = 1;
- generate_tests($OUT,
- $property_name,
- $random,
- $valid,
- $invalid,
- $warning,
- );
+ push @output, generate_tests($property_name,
+ $random,
+ $valid,
+ $invalid,
+ $warning,
+ );
# If the name is a rational number, add tests for the
# floating point equivalent.
if abs($table_name - $existing)
< $MAX_FLOATING_SLOP;
}
- generate_error($OUT,
- $property_name,
- $table_name,
- 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.
- generate_tests($OUT,
- $property_name,
- $table_name,
- $valid,
- $invalid,
- $warning,
- );
+ push @output, generate_tests($property_name,
+ $table_name,
+ $valid,
+ $invalid,
+ $warning,
+ );
}
}
}
}
}
- foreach my $test (@backslash_X_tests) {
- print $OUT "Test_X('$test');\n";
- }
-
- print $OUT "Finished();\n";
- close $OUT;
+ &write($t_path, [<DATA>,
+ @output,
+ (map {"Test_X('$_');\n"} @backslash_X_tests),
+ "Finished();\n"]);
return;
}
}, File::Spec->curdir());
my @mktables_list_output_files;
+my $old_start_time = 0;
-if ($write_unchanged_files) {
+if (! -e $file_list) {
+ print "'$file_list' doesn't exist, so forcing rebuild.\n" if $verbosity >= $VERBOSE;
+ $write_unchanged_files = 1;
+} elsif ($write_unchanged_files) {
print "Not checking file list '$file_list'.\n" if $verbosity >= $VERBOSE;
}
else {
print "Reading file list '$file_list'\n" if $verbosity >= $VERBOSE;
my $file_handle;
if (! open $file_handle, "<", $file_list) {
- Carp::my_carp("Failed to open '$file_list' (this is expected to be missing the first time); turning on -globlist option instead: $!");
+ Carp::my_carp("Failed to open '$file_list'; turning on -globlist option instead: $!");
$glob_list = 1;
}
else {
for my $list ( \@input, \@mktables_list_output_files ) {
while (<$file_handle>) {
s/^ \s+ | \s+ $//xg;
+ if (/^ \s* \# .* Autogenerated\ starting\ on\ (\d+)/x) {
+ $old_start_time = $1;
+ }
next if /^ \s* (?: \# .* )? $/x;
last if /^ =+ $/x;
my ( $file ) = split /\t/;
# We set $youngest to be the most recently changed input file, including this
# program itself (done much earlier in this file)
foreach my $in (@input_files) {
- my $age = -M $in;
- next unless defined $age; # Keep going even if missing a file
- $youngest = $age if $age < $youngest;
+ next unless -e $in; # Keep going even if missing a file
+ my $mod_time = (stat $in)[9];
+ $youngest = $mod_time if $mod_time > $youngest;
# See that the input files have distinct names, to warn someone if they
# are adding a new one
}
}
-my $ok = ! $write_unchanged_files
- && scalar @mktables_list_output_files; # If none known, rebuild
+my $rebuild = $write_unchanged_files # Rebuild: if unconditional rebuild
+ || ! scalar @mktables_list_output_files # or if no outputs known
+ || $old_start_time < $youngest; # or out-of-date
# Now we check to see if any output files are older than youngest, if
# they are, we need to continue on, otherwise we can presumably bail.
-if ($ok) {
+if (! $rebuild) {
foreach my $out (@mktables_list_output_files) {
if ( ! file_exists($out)) {
print "'$out' is missing.\n" if $verbosity >= $VERBOSE;
- $ok = 0;
+ $rebuild = 1;
last;
}
#local $to_trace = 1 if main::DEBUG;
- trace $youngest, -M $out if main::DEBUG && $to_trace;
- if ( -M $out > $youngest ) {
- #trace "$out: age: ", -M $out, ", youngest: $youngest\n" if main::DEBUG && $to_trace;
+ trace $youngest, (stat $out)[9] if main::DEBUG && $to_trace;
+ if ( (stat $out)[9] <= $youngest ) {
+ #trace "$out: most recent mod time: ", (stat $out)[9], ", youngest: $youngest\n" if main::DEBUG && $to_trace;
print "'$out' is too old.\n" if $verbosity >= $VERBOSE;
- $ok = 0;
+ $rebuild = 1;
last;
}
}
}
-if ($ok) {
- print "Files seem to be ok, not bothering to rebuild.\n";
+if (! $rebuild) {
+ print "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;
return
}
else {
+ my $localtime = localtime $start_time;
print $ofh <<"END";
#
# $file_list -- File list for $0.
#
-# Autogenerated on @{[scalar localtime]}
+# Autogenerated starting on $start_time ($localtime)
#
# - First section is input files
# ($0 itself is not listed but is automatically considered an input)
use strict;
use warnings;
+# If run outside the normal test suite on an ASCII platform, you can
+# just create a latin1_to_native() function that just returns its
+# inputs, because that's the only function used from test.pl
+require "test.pl";
+
# Test qr/\X/ and the \p{} regular expression constructs. This file is
# constructed by mktables from the tables it generates, so if mktables is
# buggy, this won't necessarily catch those bugs. Tests are generated for all
my $Tests = 0;
my $Fails = 0;
-my $non_ASCII = (ord('A') != 65);
-
-# The 256 8-bit characters in ASCII ordinal order, with the ones that don't
-# have Perl names replaced by -1
-my @ascii_ordered_chars = (
- "\0",
- (-1) x 6,
- "\a", "\b", "\t", "\n",
- -1, # No Vt
- "\f", "\r",
- (-1) x 18,
- " ", "!", "\"", "#", '$', "%", "&", "'",
- "(", ")", "*", "+", ",", "-", ".", "/",
- "0", "1", "2", "3", "4", "5", "6", "7", "8", "9",
- ":", ";", "<", "=", ">", "?", "@",
- "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M",
- "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z",
- "[", "\\", "]", "^", "_", "`",
- "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m",
- "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z",
- "{", "|", "}", "~",
- (-1) x 129
-);
-
-sub ASCII_ord_to_native ($) {
- # Converts input ordinal number to the native one, if can be done easily.
- # Returns -1 otherwise.
-
- my $ord = shift;
-
- return $ord if $ord > 255 || ! $non_ASCII;
- my $result = $ascii_ordered_chars[$ord];
- return $result if $result eq '-1';
- return ord($result);
-}
-
sub Expect($$$$) {
my $expected = shift;
my $ord = shift;
my $warning_type = shift; # Type of warning message, like 'deprecated'
# or empty if none
my $line = (caller)[2];
-
- # Convert the non-ASCII code points expressible as characters to their
- # ASCII equivalents, and skip the others.
- $ord = ASCII_ord_to_native($ord);
- if ($ord < 0) {
- $Tests++;
- print "ok $Tests - "
- . sprintf("\"\\x{%04X}\"", $ord)
- . " =~ $regex # Skipped: non-ASCII\n";
- return;
- }
+ $ord = ord(latin1_to_native(chr($ord)));
# Convert the code point to hex form
my $string = sprintf "\"\\x{%04X}\"", $ord;
my $this_string = "";
my $this_display = "";
foreach my $code_point (@code_points) {
- my $ord = ASCII_ord_to_native(hex $code_point);
- if ($ord < 0) {
- $Tests++;
- print "ok $Tests - String containing $code_point =~ /(\\X)/g # Skipped: non-ASCII\n";
- return;
- }
- $this_string .= chr $ord;
+ $this_string .= latin1_to_native(chr(hex $code_point));
$this_display .= "\\x{$code_point}";
}
# If a string can be represented in both non-ut8 and utf8, test both cases
UPGRADE:
for my $to_upgrade (0 .. 1) {
-
+
if ($to_upgrade) {
# If already in utf8, would just be a repeat
Test_X("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