This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
mktables: Add specifiable construction handler for Input_file class
[perl5.git] / lib / unicore / mktables
CommitLineData
d73e5302 1#!/usr/bin/perl -w
99870f4d
KW
2
3# !!!!!!!!!!!!!! IF YOU MODIFY THIS FILE !!!!!!!!!!!!!!!!!!!!!!!!!
4# Any files created or read by this program should be listed in 'mktables.lst'
5# Use -makelist to regenerate it.
6
9be22ca5
KW
7# There was an attempt when this was first rewritten to make it 5.8
8# compatible, but that has now been abandoned, and newer constructs are used
9# as convenient.
6c68572b 10
cdcef19a 11my $start_time;
98dc9551 12BEGIN { # Get the time the script started running; do it at compilation to
cdcef19a
KW
13 # get it as close as possible
14 $start_time= time;
15}
16
23e33b60 17require 5.010_001;
d73e5302 18use strict;
99870f4d 19use warnings;
cf25bb62 20use Carp;
bd9ebcfd 21use Config;
99870f4d
KW
22use File::Find;
23use File::Path;
d07a55ed 24use File::Spec;
99870f4d 25use Text::Tabs;
6b64c11c 26use re "/aa";
0dee21d6 27use feature 'state';
99870f4d
KW
28
29sub DEBUG () { 0 } # Set to 0 for production; 1 for development
bd9ebcfd 30my $debugging_build = $Config{"ccflags"} =~ /-DDEBUGGING/;
99870f4d 31
74cd47d0
KW
32sub NON_ASCII_PLATFORM { ord("A") != 65 }
33
99870f4d
KW
34##########################################################################
35#
36# mktables -- create the runtime Perl Unicode files (lib/unicore/.../*.pl),
37# from the Unicode database files (lib/unicore/.../*.txt), It also generates
232ed87f 38# a pod file and .t files, depending on option parameters.
99870f4d
KW
39#
40# The structure of this file is:
41# First these introductory comments; then
42# code needed for everywhere, such as debugging stuff; then
43# code to handle input parameters; then
44# data structures likely to be of external interest (some of which depend on
45# the input parameters, so follows them; then
46# more data structures and subroutine and package (class) definitions; then
47# the small actual loop to process the input files and finish up; then
48# a __DATA__ section, for the .t tests
49#
232ed87f
KW
50# This program works on all releases of Unicode so far. The outputs have been
51# scrutinized most intently for release 5.1. The others have been checked for
52# somewhat more than just sanity. It can handle all non-provisional Unicode
53# character properties in those releases.
99870f4d 54#
99870f4d
KW
55# This program is mostly about Unicode character (or code point) properties.
56# A property describes some attribute or quality of a code point, like if it
57# is lowercase or not, its name, what version of Unicode it was first defined
58# in, or what its uppercase equivalent is. Unicode deals with these disparate
59# possibilities by making all properties into mappings from each code point
60# into some corresponding value. In the case of it being lowercase or not,
61# the mapping is either to 'Y' or 'N' (or various synonyms thereof). Each
62# property maps each Unicode code point to a single value, called a "property
232ed87f
KW
63# value". (Some more recently defined properties, map a code point to a set
64# of values.)
99870f4d
KW
65#
66# When using a property in a regular expression, what is desired isn't the
67# mapping of the code point to its property's value, but the reverse (or the
68# mathematical "inverse relation"): starting with the property value, "Does a
69# code point map to it?" These are written in a "compound" form:
70# \p{property=value}, e.g., \p{category=punctuation}. This program generates
71# files containing the lists of code points that map to each such regular
72# expression property value, one file per list
73#
74# There is also a single form shortcut that Perl adds for many of the commonly
75# used properties. This happens for all binary properties, plus script,
76# general_category, and block properties.
77#
78# Thus the outputs of this program are files. There are map files, mostly in
79# the 'To' directory; and there are list files for use in regular expression
80# matching, all in subdirectories of the 'lib' directory, with each
81# subdirectory being named for the property that the lists in it are for.
82# Bookkeeping, test, and documentation files are also generated.
83
84my $matches_directory = 'lib'; # Where match (\p{}) files go.
85my $map_directory = 'To'; # Where map files go.
86
87# DATA STRUCTURES
88#
89# The major data structures of this program are Property, of course, but also
90# Table. There are two kinds of tables, very similar to each other.
91# "Match_Table" is the data structure giving the list of code points that have
92# a particular property value, mentioned above. There is also a "Map_Table"
93# data structure which gives the property's mapping from code point to value.
94# There are two structures because the match tables need to be combined in
95# various ways, such as constructing unions, intersections, complements, etc.,
96# and the map ones don't. And there would be problems, perhaps subtle, if
97# a map table were inadvertently operated on in some of those ways.
98# The use of separate classes with operations defined on one but not the other
99# prevents accidentally confusing the two.
100#
101# At the heart of each table's data structure is a "Range_List", which is just
102# an ordered list of "Ranges", plus ancillary information, and methods to
103# operate on them. A Range is a compact way to store property information.
104# Each range has a starting code point, an ending code point, and a value that
105# is meant to apply to all the code points between the two end points,
106# inclusive. For a map table, this value is the property value for those
107# code points. Two such ranges could be written like this:
108# 0x41 .. 0x5A, 'Upper',
109# 0x61 .. 0x7A, 'Lower'
110#
111# Each range also has a type used as a convenience to classify the values.
112# Most ranges in this program will be Type 0, or normal, but there are some
113# ranges that have a non-zero type. These are used only in map tables, and
114# are for mappings that don't fit into the normal scheme of things. Mappings
115# that require a hash entry to communicate with utf8.c are one example;
116# another example is mappings for charnames.pm to use which indicate a name
232ed87f 117# that is algorithmically determinable from its code point (and the reverse).
99870f4d
KW
118# These are used to significantly compact these tables, instead of listing
119# each one of the tens of thousands individually.
120#
121# In a match table, the value of a range is irrelevant (and hence the type as
122# well, which will always be 0), and arbitrarily set to the null string.
123# Using the example above, there would be two match tables for those two
124# entries, one named Upper would contain the 0x41..0x5A range, and the other
125# named Lower would contain 0x61..0x7A.
126#
127# Actually, there are two types of range lists, "Range_Map" is the one
128# associated with map tables, and "Range_List" with match tables.
232ed87f
KW
129# Again, this is so that methods can be defined on one and not the others so
130# as to prevent operating on them in incorrect ways.
99870f4d
KW
131#
132# Eventually, most tables are written out to files to be read by utf8_heavy.pl
133# in the perl core. All tables could in theory be written, but some are
134# suppressed because there is no current practical use for them. It is easy
135# to change which get written by changing various lists that are near the top
136# of the actual code in this file. The table data structures contain enough
137# ancillary information to allow them to be treated as separate entities for
138# writing, such as the path to each one's file. There is a heading in each
139# map table that gives the format of its entries, and what the map is for all
140# the code points missing from it. (This allows tables to be more compact.)
678f13d5 141#
99870f4d
KW
142# The Property data structure contains one or more tables. All properties
143# contain a map table (except the $perl property which is a
144# pseudo-property containing only match tables), and any properties that
145# are usable in regular expression matches also contain various matching
146# tables, one for each value the property can have. A binary property can
147# have two values, True and False (or Y and N, which are preferred by Unicode
148# terminology). Thus each of these properties will have a map table that
149# takes every code point and maps it to Y or N (but having ranges cuts the
150# number of entries in that table way down), and two match tables, one
151# which has a list of all the code points that map to Y, and one for all the
232ed87f 152# code points that map to N. (For each binary property, a third table is also
99870f4d 153# generated for the pseudo Perl property. It contains the identical code
232ed87f
KW
154# points as the Y table, but can be written in regular expressions, not in the
155# compound form, but in a "single" form like \p{IsUppercase}.) Many
156# properties are binary, but some properties have several possible values,
157# some have many, and properties like Name have a different value for every
158# named code point. Those will not, unless the controlling lists are changed,
159# have their match tables written out. But all the ones which can be used in
160# regular expression \p{} and \P{} constructs will. Prior to 5.14, generally
161# a property would have either its map table or its match tables written but
162# not both. Again, what gets written is controlled by lists which can easily
163# be changed. Starting in 5.14, advantage was taken of this, and all the map
164# tables needed to reconstruct the Unicode db are now written out, while
165# suppressing the Unicode .txt files that contain the data. Our tables are
166# much more compact than the .txt files, so a significant space savings was
167# achieved. Also, tables are not written out that are trivially derivable
168# from tables that do get written. So, there typically is no file containing
169# the code points not matched by a binary property (the table for \P{} versus
170# lowercase \p{}), since you just need to invert the True table to get the
171# False table.
172
173# Properties have a 'Type', like 'binary', or 'string', or 'enum' depending on
174# how many match tables there are and the content of the maps. This 'Type' is
c12f2655
KW
175# different than a range 'Type', so don't get confused by the two concepts
176# having the same name.
678f13d5 177#
99870f4d
KW
178# For information about the Unicode properties, see Unicode's UAX44 document:
179
180my $unicode_reference_url = 'http://www.unicode.org/reports/tr44/';
181
182# As stated earlier, this program will work on any release of Unicode so far.
183# Most obvious problems in earlier data have NOT been corrected except when
be864b6c 184# necessary to make Perl or this program work reasonably, and to keep out
232ed87f
KW
185# potential security issues. For example, no folding information was given in
186# early releases, so this program substitutes lower case instead, just so that
187# a regular expression with the /i option will do something that actually
188# gives the right results in many cases. There are also a couple other
189# corrections for version 1.1.5, commented at the point they are made. As an
190# example of corrections that weren't made (but could be) is this statement
191# from DerivedAge.txt: "The supplementary private use code points and the
192# non-character code points were assigned in version 2.0, but not specifically
193# listed in the UCD until versions 3.0 and 3.1 respectively." (To be precise
194# it was 3.0.1 not 3.0.0) More information on Unicode version glitches is
195# further down in these introductory comments.
99870f4d 196#
232ed87f
KW
197# This program works on all non-provisional properties as of the current
198# Unicode release, though the files for some are suppressed for various
199# reasons. You can change which are output by changing lists in this program.
678f13d5 200#
dc85bd38 201# The old version of mktables emphasized the term "Fuzzy" to mean Unicode's
99870f4d
KW
202# loose matchings rules (from Unicode TR18):
203#
204# The recommended names for UCD properties and property values are in
205# PropertyAliases.txt [Prop] and PropertyValueAliases.txt
206# [PropValue]. There are both abbreviated names and longer, more
207# descriptive names. It is strongly recommended that both names be
208# recognized, and that loose matching of property names be used,
209# whereby the case distinctions, whitespace, hyphens, and underbar
210# are ignored.
232ed87f 211#
99870f4d
KW
212# The program still allows Fuzzy to override its determination of if loose
213# matching should be used, but it isn't currently used, as it is no longer
214# needed; the calculations it makes are good enough.
678f13d5 215#
99870f4d
KW
216# SUMMARY OF HOW IT WORKS:
217#
218# Process arguments
219#
220# A list is constructed containing each input file that is to be processed
221#
222# Each file on the list is processed in a loop, using the associated handler
223# code for each:
224# The PropertyAliases.txt and PropValueAliases.txt files are processed
225# first. These files name the properties and property values.
226# Objects are created of all the property and property value names
227# that the rest of the input should expect, including all synonyms.
228# The other input files give mappings from properties to property
229# values. That is, they list code points and say what the mapping
230# is under the given property. Some files give the mappings for
231# just one property; and some for many. This program goes through
232ed87f
KW
232# each file and populates the properties and their map tables from
233# them. Some properties are listed in more than one file, and
234# Unicode has set up a precedence as to which has priority if there
235# is a conflict. Thus the order of processing matters, and this
236# program handles the conflict possibility by processing the
237# overriding input files last, so that if necessary they replace
238# earlier values.
99870f4d
KW
239# After this is all done, the program creates the property mappings not
240# furnished by Unicode, but derivable from what it does give.
241# The tables of code points that match each property value in each
242# property that is accessible by regular expressions are created.
243# The Perl-defined properties are created and populated. Many of these
244# require data determined from the earlier steps
245# Any Perl-defined synonyms are created, and name clashes between Perl
678f13d5 246# and Unicode are reconciled and warned about.
99870f4d
KW
247# All the properties are written to files
248# Any other files are written, and final warnings issued.
678f13d5 249#
99870f4d
KW
250# For clarity, a number of operators have been overloaded to work on tables:
251# ~ means invert (take all characters not in the set). The more
252# conventional '!' is not used because of the possibility of confusing
253# it with the actual boolean operation.
254# + means union
255# - means subtraction
256# & means intersection
257# The precedence of these is the order listed. Parentheses should be
258# copiously used. These are not a general scheme. The operations aren't
259# defined for a number of things, deliberately, to avoid getting into trouble.
260# Operations are done on references and affect the underlying structures, so
261# that the copy constructors for them have been overloaded to not return a new
262# clone, but the input object itself.
678f13d5 263#
99870f4d
KW
264# The bool operator is deliberately not overloaded to avoid confusion with
265# "should it mean if the object merely exists, or also is non-empty?".
99870f4d
KW
266#
267# WHY CERTAIN DESIGN DECISIONS WERE MADE
678f13d5
KW
268#
269# This program needs to be able to run under miniperl. Therefore, it uses a
270# minimum of other modules, and hence implements some things itself that could
271# be gotten from CPAN
272#
273# This program uses inputs published by the Unicode Consortium. These can
274# change incompatibly between releases without the Perl maintainers realizing
275# it. Therefore this program is now designed to try to flag these. It looks
276# at the directories where the inputs are, and flags any unrecognized files.
277# It keeps track of all the properties in the files it handles, and flags any
278# that it doesn't know how to handle. It also flags any input lines that
279# don't match the expected syntax, among other checks.
280#
281# It is also designed so if a new input file matches one of the known
282# templates, one hopefully just needs to add it to a list to have it
283# processed.
284#
285# As mentioned earlier, some properties are given in more than one file. In
286# particular, the files in the extracted directory are supposedly just
287# reformattings of the others. But they contain information not easily
9be22ca5
KW
288# derivable from the other files, including results for Unihan (which isn't
289# usually available to this program) and for unassigned code points. They
678f13d5
KW
290# also have historically had errors or been incomplete. In an attempt to
291# create the best possible data, this program thus processes them first to
292# glean information missing from the other files; then processes those other
293# files to override any errors in the extracted ones. Much of the design was
294# driven by this need to store things and then possibly override them.
295#
296# It tries to keep fatal errors to a minimum, to generate something usable for
297# testing purposes. It always looks for files that could be inputs, and will
298# warn about any that it doesn't know how to handle (the -q option suppresses
299# the warning).
99870f4d 300#
678f13d5
KW
301# Why is there more than one type of range?
302# This simplified things. There are some very specialized code points that
303# have to be handled specially for output, such as Hangul syllable names.
304# By creating a range type (done late in the development process), it
305# allowed this to be stored with the range, and overridden by other input.
306# Originally these were stored in another data structure, and it became a
307# mess trying to decide if a second file that was for the same property was
308# overriding the earlier one or not.
309#
310# Why are there two kinds of tables, match and map?
311# (And there is a base class shared by the two as well.) As stated above,
312# they actually are for different things. Development proceeded much more
313# smoothly when I (khw) realized the distinction. Map tables are used to
314# give the property value for every code point (actually every code point
315# that doesn't map to a default value). Match tables are used for regular
316# expression matches, and are essentially the inverse mapping. Separating
317# the two allows more specialized methods, and error checks so that one
318# can't just take the intersection of two map tables, for example, as that
319# is nonsensical.
99870f4d 320#
232ed87f
KW
321# What about 'fate' and 'status'. The concept of a table's fate was created
322# late when it became clear that something more was needed. The difference
323# between this and 'status' is unclean, and could be improved if someone
324# wanted to spend the effort.
325#
23e33b60
KW
326# DEBUGGING
327#
678f13d5
KW
328# This program is written so it will run under miniperl. Occasionally changes
329# will cause an error where the backtrace doesn't work well under miniperl.
330# To diagnose the problem, you can instead run it under regular perl, if you
331# have one compiled.
332#
333# There is a good trace facility. To enable it, first sub DEBUG must be set
334# to return true. Then a line like
335#
336# local $to_trace = 1 if main::DEBUG;
337#
232ed87f
KW
338# can be added to enable tracing in its lexical scope (plus dynamic) or until
339# you insert another line:
678f13d5
KW
340#
341# local $to_trace = 0 if main::DEBUG;
342#
232ed87f 343# To actually trace, use a line like "trace $a, @b, %c, ...;
678f13d5
KW
344#
345# Some of the more complex subroutines already have trace statements in them.
346# Permanent trace statements should be like:
347#
348# trace ... if main::DEBUG && $to_trace;
349#
350# If there is just one or a few files that you're debugging, you can easily
351# cause most everything else to be skipped. Change the line
352#
353# my $debug_skip = 0;
354#
355# to 1, and every file whose object is in @input_file_objects and doesn't have
232ed87f
KW
356# a, 'non_skip => 1,' in its constructor will be skipped. However, skipping
357# Jamo.txt or UnicodeData.txt will likely cause fatal errors.
678f13d5 358#
b4a0206c 359# To compare the output tables, it may be useful to specify the -annotate
97a8a595
KW
360# flag. (As of this writing, this can't be done on a clean workspace, due to
361# requirements in Text::Tabs used in this option; so first run mktables
362# without this option.) This option adds comment lines to each table, one for
363# each non-algorithmically named character giving, currently its code point,
364# name, and graphic representation if printable (and you have a font that
365# knows about it). This makes it easier to see what the particular code
366# points are in each output table. Non-named code points are annotated with a
367# description of their status, and contiguous ones with the same description
368# will be output as a range rather than individually. Algorithmically named
369# characters are also output as ranges, except when there are just a few
370# contiguous ones.
c4019d52 371#
99870f4d
KW
372# FUTURE ISSUES
373#
374# The program would break if Unicode were to change its names so that
375# interior white space, underscores, or dashes differences were significant
376# within property and property value names.
377#
378# It might be easier to use the xml versions of the UCD if this program ever
379# would need heavy revision, and the ability to handle old versions was not
380# required.
381#
382# There is the potential for name collisions, in that Perl has chosen names
383# that Unicode could decide it also likes. There have been such collisions in
384# the past, with mostly Perl deciding to adopt the Unicode definition of the
385# name. However in the 5.2 Unicode beta testing, there were a number of such
386# collisions, which were withdrawn before the final release, because of Perl's
387# and other's protests. These all involved new properties which began with
388# 'Is'. Based on the protests, Unicode is unlikely to try that again. Also,
389# many of the Perl-defined synonyms, like Any, Word, etc, are listed in a
390# Unicode document, so they are unlikely to be used by Unicode for another
391# purpose. However, they might try something beginning with 'In', or use any
392# of the other Perl-defined properties. This program will warn you of name
393# collisions, and refuse to generate tables with them, but manual intervention
394# will be required in this event. One scheme that could be implemented, if
395# necessary, would be to have this program generate another file, or add a
396# field to mktables.lst that gives the date of first definition of a property.
397# Each new release of Unicode would use that file as a basis for the next
398# iteration. And the Perl synonym addition code could sort based on the age
399# of the property, so older properties get priority, and newer ones that clash
400# would be refused; hence existing code would not be impacted, and some other
401# synonym would have to be used for the new property. This is ugly, and
402# manual intervention would certainly be easier to do in the short run; lets
403# hope it never comes to this.
678f13d5 404#
99870f4d
KW
405# A NOTE ON UNIHAN
406#
407# This program can generate tables from the Unihan database. But it doesn't
408# by default, letting the CPAN module Unicode::Unihan handle them. Prior to
409# version 5.2, this database was in a single file, Unihan.txt. In 5.2 the
410# database was split into 8 different files, all beginning with the letters
411# 'Unihan'. This program will read those file(s) if present, but it needs to
412# know which of the many properties in the file(s) should have tables created
413# for them. It will create tables for any properties listed in
414# PropertyAliases.txt and PropValueAliases.txt, plus any listed in the
415# @cjk_properties array and the @cjk_property_values array. Thus, if a
416# property you want is not in those files of the release you are building
417# against, you must add it to those two arrays. Starting in 4.0, the
418# Unicode_Radical_Stroke was listed in those files, so if the Unihan database
419# is present in the directory, a table will be generated for that property.
420# In 5.2, several more properties were added. For your convenience, the two
5f7264c7 421# arrays are initialized with all the 6.0 listed properties that are also in
99870f4d
KW
422# earlier releases. But these are commented out. You can just uncomment the
423# ones you want, or use them as a template for adding entries for other
424# properties.
425#
426# You may need to adjust the entries to suit your purposes. setup_unihan(),
427# and filter_unihan_line() are the functions where this is done. This program
428# already does some adjusting to make the lines look more like the rest of the
429# Unicode DB; You can see what that is in filter_unihan_line()
430#
431# There is a bug in the 3.2 data file in which some values for the
432# kPrimaryNumeric property have commas and an unexpected comment. A filter
9be22ca5
KW
433# could be added to correct these; or for a particular installation, the
434# Unihan.txt file could be edited to fix them.
99870f4d 435#
678f13d5
KW
436# HOW TO ADD A FILE TO BE PROCESSED
437#
438# A new file from Unicode needs to have an object constructed for it in
439# @input_file_objects, probably at the end or at the end of the extracted
440# ones. The program should warn you if its name will clash with others on
441# restrictive file systems, like DOS. If so, figure out a better name, and
442# add lines to the README.perl file giving that. If the file is a character
232ed87f 443# property, it should be in the format that Unicode has implicitly
678f13d5
KW
444# standardized for such files for the more recently introduced ones.
445# If so, the Input_file constructor for @input_file_objects can just be the
446# file name and release it first appeared in. If not, then it should be
447# possible to construct an each_line_handler() to massage the line into the
448# standardized form.
449#
450# For non-character properties, more code will be needed. You can look at
451# the existing entries for clues.
452#
453# UNICODE VERSIONS NOTES
454#
455# The Unicode UCD has had a number of errors in it over the versions. And
456# these remain, by policy, in the standard for that version. Therefore it is
457# risky to correct them, because code may be expecting the error. So this
458# program doesn't generally make changes, unless the error breaks the Perl
459# core. As an example, some versions of 2.1.x Jamo.txt have the wrong value
460# for U+1105, which causes real problems for the algorithms for Jamo
461# calculations, so it is changed here.
462#
463# But it isn't so clear cut as to what to do about concepts that are
464# introduced in a later release; should they extend back to earlier releases
465# where the concept just didn't exist? It was easier to do this than to not,
466# so that's what was done. For example, the default value for code points not
467# in the files for various properties was probably undefined until changed by
468# some version. No_Block for blocks is such an example. This program will
469# assign No_Block even in Unicode versions that didn't have it. This has the
470# benefit that code being written doesn't have to special case earlier
471# versions; and the detriment that it doesn't match the Standard precisely for
472# the affected versions.
473#
474# Here are some observations about some of the issues in early versions:
475#
232ed87f
KW
476# Prior to version 3.0, there were 3 character decompositions. These are not
477# handled by Unicode::Normalize, nor will it compile when presented a version
478# that has them. However, you can trivially get it to compile by simply
479# ignoring those decompositions, by changing the croak to a carp. At the time
9be22ca5
KW
480# of this writing, the line (in cpan/Unicode-Normalize/Normalize.pm or
481# cpan/Unicode-Normalize/mkheader) reads
232ed87f
KW
482#
483# croak("Weird Canonical Decomposition of U+$h");
484#
28807e1d 485# Simply comment it out. It will compile, but will not know about any three
9be22ca5 486# character decompositions.
232ed87f
KW
487
488# The number of code points in \p{alpha=True} halved in 2.1.9. It turns out
489# that the reason is that the CJK block starting at 4E00 was removed from
490# PropList, and was not put back in until 3.1.0. The Perl extension (the
491# single property name \p{alpha}) has the correct values. But the compound
492# form is simply not generated until 3.1, as it can be argued that prior to
493# this release, this was not an official property. The comments for
494# filter_old_style_proplist() give more details.
678f13d5
KW
495#
496# Unicode introduced the synonym Space for White_Space in 4.1. Perl has
497# always had a \p{Space}. In release 3.2 only, they are not synonymous. The
498# reason is that 3.2 introduced U+205F=medium math space, which was not
499# classed as white space, but Perl figured out that it should have been. 4.0
500# reclassified it correctly.
501#
502# Another change between 3.2 and 4.0 is the CCC property value ATBL. In 3.2
232ed87f
KW
503# this was erroneously a synonym for 202 (it should be 200). In 4.0, ATB
504# became 202, and ATBL was left with no code points, as all the ones that
505# mapped to 202 stayed mapped to 202. Thus if your program used the numeric
506# name for the class, it would not have been affected, but if it used the
507# mnemonic, it would have been.
678f13d5 508#
9be22ca5 509# \p{Script=Hrkt} (Katakana_Or_Hiragana) came in 4.0.1. Before that, code
678f13d5
KW
510# points which eventually came to have this script property value, instead
511# mapped to "Unknown". But in the next release all these code points were
512# moved to \p{sc=common} instead.
9be22ca5
KW
513
514# The tests furnished by Unicode for testing WordBreak and SentenceBreak
515# generate errors in 5.0 and earlier.
99870f4d
KW
516#
517# The default for missing code points for BidiClass is complicated. Starting
518# in 3.1.1, the derived file DBidiClass.txt handles this, but this program
519# tries to do the best it can for earlier releases. It is done in
520# process_PropertyAliases()
521#
232ed87f
KW
522# In version 2.1.2, the entry in UnicodeData.txt:
523# 0275;LATIN SMALL LETTER BARRED O;Ll;0;L;;;;;N;;;;019F;
524# should instead be
525# 0275;LATIN SMALL LETTER BARRED O;Ll;0;L;;;;;N;;;019F;;019F
526# Without this change, there are casing problems for this character.
527#
7803ad2d
KW
528# Search for $string_compare_versions to see how to compare changes to
529# properties between Unicode versions
530#
99870f4d
KW
531##############################################################################
532
533my $UNDEF = ':UNDEF:'; # String to print out for undefined values in tracing
534 # and errors
535my $MAX_LINE_WIDTH = 78;
536
537# Debugging aid to skip most files so as to not be distracted by them when
538# concentrating on the ones being debugged. Add
539# non_skip => 1,
540# to the constructor for those files you want processed when you set this.
541# Files with a first version number of 0 are special: they are always
c12f2655
KW
542# processed regardless of the state of this flag. Generally, Jamo.txt and
543# UnicodeData.txt must not be skipped if you want this program to not die
544# before normal completion.
99870f4d
KW
545my $debug_skip = 0;
546
e9c4b4f8
KW
547
548# Normally these are suppressed.
549my $write_Unicode_deprecated_tables = 0;
550
99870f4d
KW
551# Set to 1 to enable tracing.
552our $to_trace = 0;
553
554{ # Closure for trace: debugging aid
555 my $print_caller = 1; # ? Include calling subroutine name
556 my $main_with_colon = 'main::';
557 my $main_colon_length = length($main_with_colon);
558
559 sub trace {
560 return unless $to_trace; # Do nothing if global flag not set
561
562 my @input = @_;
563
564 local $DB::trace = 0;
565 $DB::trace = 0; # Quiet 'used only once' message
566
567 my $line_number;
568
569 # Loop looking up the stack to get the first non-trace caller
570 my $caller_line;
571 my $caller_name;
572 my $i = 0;
573 do {
574 $line_number = $caller_line;
575 (my $pkg, my $file, $caller_line, my $caller) = caller $i++;
576 $caller = $main_with_colon unless defined $caller;
577
578 $caller_name = $caller;
579
580 # get rid of pkg
581 $caller_name =~ s/.*:://;
582 if (substr($caller_name, 0, $main_colon_length)
583 eq $main_with_colon)
584 {
585 $caller_name = substr($caller_name, $main_colon_length);
586 }
587
588 } until ($caller_name ne 'trace');
589
590 # If the stack was empty, we were called from the top level
591 $caller_name = 'main' if ($caller_name eq ""
592 || $caller_name eq 'trace');
593
594 my $output = "";
9346f59a 595 #print STDERR __LINE__, ": ", join ", ", @input, "\n";
99870f4d 596 foreach my $string (@input) {
99870f4d
KW
597 if (ref $string eq 'ARRAY' || ref $string eq 'HASH') {
598 $output .= simple_dumper($string);
599 }
600 else {
601 $string = "$string" if ref $string;
602 $string = $UNDEF unless defined $string;
603 chomp $string;
604 $string = '""' if $string eq "";
605 $output .= " " if $output ne ""
606 && $string ne ""
607 && substr($output, -1, 1) ne " "
608 && substr($string, 0, 1) ne " ";
609 $output .= $string;
610 }
611 }
612
99f78760
KW
613 print STDERR sprintf "%4d: ", $line_number if defined $line_number;
614 print STDERR "$caller_name: " if $print_caller;
99870f4d
KW
615 print STDERR $output, "\n";
616 return;
617 }
618}
619
620# This is for a rarely used development feature that allows you to compare two
621# versions of the Unicode standard without having to deal with changes caused
9be22ca5
KW
622# by the code points introduced in the later version. You probably also want
623# to use the -annotate option when using this. Change the 0 to a string
624# containing a SINGLE dotted Unicode release number (e.g. "2.1"). Only code
625# points introduced in that release and earlier will be used; later ones are
626# thrown away. You use the version number of the earliest one you want to
c12f2655
KW
627# compare; then run this program on directory structures containing each
628# release, and compare the outputs. These outputs will therefore include only
629# the code points common to both releases, and you can see the changes caused
630# just by the underlying release semantic changes. For versions earlier than
631# 3.2, you must copy a version of DAge.txt into the directory.
632my $string_compare_versions = DEBUG && 0; # e.g., "2.1";
99870f4d
KW
633my $compare_versions = DEBUG
634 && $string_compare_versions
635 && pack "C*", split /\./, $string_compare_versions;
636
637sub uniques {
638 # Returns non-duplicated input values. From "Perl Best Practices:
639 # Encapsulated Cleverness". p. 455 in first edition.
640
641 my %seen;
0e407844
NC
642 # Arguably this breaks encapsulation, if the goal is to permit multiple
643 # distinct objects to stringify to the same value, and be interchangeable.
644 # However, for this program, no two objects stringify identically, and all
645 # lists passed to this function are either objects or strings. So this
646 # doesn't affect correctness, but it does give a couple of percent speedup.
647 no overloading;
99870f4d
KW
648 return grep { ! $seen{$_}++ } @_;
649}
650
651$0 = File::Spec->canonpath($0);
652
653my $make_test_script = 0; # ? Should we output a test script
6b5ab373 654my $make_norm_test_script = 0; # ? Should we output a normalization test script
99870f4d
KW
655my $write_unchanged_files = 0; # ? Should we update the output files even if
656 # we don't think they have changed
657my $use_directory = ""; # ? Should we chdir somewhere.
658my $pod_directory; # input directory to store the pod file.
659my $pod_file = 'perluniprops';
660my $t_path; # Path to the .t test file
661my $file_list = 'mktables.lst'; # File to store input and output file names.
662 # This is used to speed up the build, by not
663 # executing the main body of the program if
664 # nothing on the list has changed since the
665 # previous build
666my $make_list = 1; # ? Should we write $file_list. Set to always
667 # make a list so that when the pumpking is
668 # preparing a release, s/he won't have to do
669 # special things
670my $glob_list = 0; # ? Should we try to include unknown .txt files
671 # in the input.
bd9ebcfd
KW
672my $output_range_counts = $debugging_build; # ? Should we include the number
673 # of code points in ranges in
674 # the output
558712cf 675my $annotate = 0; # ? Should character names be in the output
9ef2b94f 676
99870f4d
KW
677# Verbosity levels; 0 is quiet
678my $NORMAL_VERBOSITY = 1;
679my $PROGRESS = 2;
680my $VERBOSE = 3;
681
682my $verbosity = $NORMAL_VERBOSITY;
683
0458fbc1
KW
684# Stored in mktables.lst so that if this program is called with different
685# options, will regenerate even if the files otherwise look like they're
686# up-to-date.
687my $command_line_arguments = join " ", @ARGV;
688
99870f4d
KW
689# Process arguments
690while (@ARGV) {
cf25bb62
JH
691 my $arg = shift @ARGV;
692 if ($arg eq '-v') {
99870f4d
KW
693 $verbosity = $VERBOSE;
694 }
695 elsif ($arg eq '-p') {
696 $verbosity = $PROGRESS;
697 $| = 1; # Flush buffers as we go.
698 }
699 elsif ($arg eq '-q') {
700 $verbosity = 0;
701 }
702 elsif ($arg eq '-w') {
703 $write_unchanged_files = 1; # update the files even if havent changed
704 }
705 elsif ($arg eq '-check') {
6ae7e459
YO
706 my $this = shift @ARGV;
707 my $ok = shift @ARGV;
708 if ($this ne $ok) {
709 print "Skipping as check params are not the same.\n";
710 exit(0);
711 }
00a8df5c 712 }
99870f4d
KW
713 elsif ($arg eq '-P' && defined ($pod_directory = shift)) {
714 -d $pod_directory or croak "Directory '$pod_directory' doesn't exist";
715 }
3df51b85
KW
716 elsif ($arg eq '-maketest' || ($arg eq '-T' && defined ($t_path = shift)))
717 {
99870f4d 718 $make_test_script = 1;
99870f4d 719 }
6b5ab373
KW
720 elsif ($arg eq '-makenormtest')
721 {
722 $make_norm_test_script = 1;
723 }
99870f4d
KW
724 elsif ($arg eq '-makelist') {
725 $make_list = 1;
726 }
727 elsif ($arg eq '-C' && defined ($use_directory = shift)) {
728 -d $use_directory or croak "Unknown directory '$use_directory'";
729 }
730 elsif ($arg eq '-L') {
731
732 # Existence not tested until have chdir'd
733 $file_list = shift;
734 }
735 elsif ($arg eq '-globlist') {
736 $glob_list = 1;
737 }
738 elsif ($arg eq '-c') {
739 $output_range_counts = ! $output_range_counts
740 }
b4a0206c 741 elsif ($arg eq '-annotate') {
558712cf 742 $annotate = 1;
bd9ebcfd
KW
743 $debugging_build = 1;
744 $output_range_counts = 1;
9ef2b94f 745 }
99870f4d
KW
746 else {
747 my $with_c = 'with';
748 $with_c .= 'out' if $output_range_counts; # Complements the state
749 croak <<END;
750usage: $0 [-c|-p|-q|-v|-w] [-C dir] [-L filelist] [ -P pod_dir ]
751 [ -T test_file_path ] [-globlist] [-makelist] [-maketest]
752 [-check A B ]
753 -c : Output comments $with_c number of code points in ranges
754 -q : Quiet Mode: Only output serious warnings.
755 -p : Set verbosity level to normal plus show progress.
756 -v : Set Verbosity level high: Show progress and non-serious
757 warnings
758 -w : Write files regardless
759 -C dir : Change to this directory before proceeding. All relative paths
760 except those specified by the -P and -T options will be done
761 with respect to this directory.
762 -P dir : Output $pod_file file to directory 'dir'.
3df51b85 763 -T path : Create a test script as 'path'; overrides -maketest
99870f4d
KW
764 -L filelist : Use alternate 'filelist' instead of standard one
765 -globlist : Take as input all non-Test *.txt files in current and sub
766 directories
3df51b85
KW
767 -maketest : Make test script 'TestProp.pl' in current (or -C directory),
768 overrides -T
99870f4d 769 -makelist : Rewrite the file list $file_list based on current setup
b4a0206c 770 -annotate : Output an annotation for each character in the table files;
97a8a595
KW
771 useful for debugging mktables, looking at diffs; but is slow
772 and memory intensive
99870f4d
KW
773 -check A B : Executes $0 only if A and B are the same
774END
775 }
776}
777
778# Stores the most-recently changed file. If none have changed, can skip the
779# build
aeab6150 780my $most_recent = (stat $0)[9]; # Do this before the chdir!
99870f4d
KW
781
782# Change directories now, because need to read 'version' early.
783if ($use_directory) {
3df51b85 784 if ($pod_directory && ! File::Spec->file_name_is_absolute($pod_directory)) {
99870f4d
KW
785 $pod_directory = File::Spec->rel2abs($pod_directory);
786 }
3df51b85 787 if ($t_path && ! File::Spec->file_name_is_absolute($t_path)) {
99870f4d 788 $t_path = File::Spec->rel2abs($t_path);
00a8df5c 789 }
99870f4d 790 chdir $use_directory or croak "Failed to chdir to '$use_directory':$!";
3df51b85 791 if ($pod_directory && File::Spec->file_name_is_absolute($pod_directory)) {
99870f4d 792 $pod_directory = File::Spec->abs2rel($pod_directory);
02b1aeec 793 }
3df51b85 794 if ($t_path && File::Spec->file_name_is_absolute($t_path)) {
99870f4d 795 $t_path = File::Spec->abs2rel($t_path);
02b1aeec 796 }
00a8df5c
YO
797}
798
99870f4d
KW
799# Get Unicode version into regular and v-string. This is done now because
800# various tables below get populated based on it. These tables are populated
801# here to be near the top of the file, and so easily seeable by those needing
802# to modify things.
803open my $VERSION, "<", "version"
804 or croak "$0: can't open required file 'version': $!\n";
805my $string_version = <$VERSION>;
806close $VERSION;
807chomp $string_version;
808my $v_version = pack "C*", split /\./, $string_version; # v string
809
810# The following are the complete names of properties with property values that
811# are known to not match any code points in some versions of Unicode, but that
812# may change in the future so they should be matchable, hence an empty file is
813# generated for them.
a9c9e371
KW
814my @tables_that_may_be_empty;
815push @tables_that_may_be_empty, 'Joining_Type=Left_Joining'
816 if $v_version lt v6.3.0;
99870f4d
KW
817push @tables_that_may_be_empty, 'Script=Common' if $v_version le v4.0.1;
818push @tables_that_may_be_empty, 'Title' if $v_version lt v2.0.0;
819push @tables_that_may_be_empty, 'Script=Katakana_Or_Hiragana'
820 if $v_version ge v4.1.0;
82aed44a
KW
821push @tables_that_may_be_empty, 'Script_Extensions=Katakana_Or_Hiragana'
822 if $v_version ge v6.0.0;
f583b44c
KW
823push @tables_that_may_be_empty, 'Grapheme_Cluster_Break=Prepend'
824 if $v_version ge v6.1.0;
1e958ea9
KW
825push @tables_that_may_be_empty, 'Canonical_Combining_Class=CCC133'
826 if $v_version ge v6.2.0;
99870f4d
KW
827
828# The lists below are hashes, so the key is the item in the list, and the
829# value is the reason why it is in the list. This makes generation of
830# documentation easier.
831
832my %why_suppressed; # No file generated for these.
833
834# Files aren't generated for empty extraneous properties. This is arguable.
835# Extraneous properties generally come about because a property is no longer
836# used in a newer version of Unicode. If we generated a file without code
837# points, programs that used to work on that property will still execute
838# without errors. It just won't ever match (or will always match, with \P{}).
839# This means that the logic is now likely wrong. I (khw) think its better to
840# find this out by getting an error message. Just move them to the table
841# above to change this behavior
842my %why_suppress_if_empty_warn_if_not = (
843
844 # It is the only property that has ever officially been removed from the
845 # Standard. The database never contained any code points for it.
846 'Special_Case_Condition' => 'Obsolete',
847
848 # Apparently never official, but there were code points in some versions of
849 # old-style PropList.txt
850 'Non_Break' => 'Obsolete',
851);
852
853# These would normally go in the warn table just above, but they were changed
854# a long time before this program was written, so warnings about them are
855# moot.
856if ($v_version gt v3.2.0) {
857 push @tables_that_may_be_empty,
858 'Canonical_Combining_Class=Attached_Below_Left'
859}
860
5f7264c7 861# These are listed in the Property aliases file in 6.0, but Unihan is ignored
99870f4d 862# unless explicitly added.
68ab5aec 863if ($v_version ge v5.2.0 && ! $write_Unicode_deprecated_tables) {
99870f4d 864 my $unihan = 'Unihan; remove from list if using Unihan';
ea25a9b2 865 foreach my $table (qw (
99870f4d
KW
866 kAccountingNumeric
867 kOtherNumeric
868 kPrimaryNumeric
869 kCompatibilityVariant
870 kIICore
871 kIRG_GSource
872 kIRG_HSource
873 kIRG_JSource
874 kIRG_KPSource
875 kIRG_MSource
876 kIRG_KSource
877 kIRG_TSource
878 kIRG_USource
879 kIRG_VSource
880 kRSUnicode
ea25a9b2 881 ))
99870f4d
KW
882 {
883 $why_suppress_if_empty_warn_if_not{$table} = $unihan;
884 }
ca12659b
NC
885}
886
9be22ca5
KW
887# Enum values for to_output_map() method in the Map_Table package. (0 is don't
888# output)
272501f6
KW
889my $EXTERNAL_MAP = 1;
890my $INTERNAL_MAP = 2;
ce712c88 891my $OUTPUT_ADJUSTED = 3;
272501f6 892
fcf1973c
KW
893# To override computed values for writing the map tables for these properties.
894# The default for enum map tables is to write them out, so that the Unicode
895# .txt files can be removed, but all the data to compute any property value
896# for any code point is available in a more compact form.
897my %global_to_output_map = (
898 # Needed by UCD.pm, but don't want to publicize that it exists, so won't
c12f2655
KW
899 # get stuck supporting it if things change. Since it is a STRING
900 # property, it normally would be listed in the pod, but INTERNAL_MAP
901 # suppresses that.
fcf1973c
KW
902 Unicode_1_Name => $INTERNAL_MAP,
903
904 Present_In => 0, # Suppress, as easily computed from Age
74cd47d0
KW
905 Block => (NON_ASCII_PLATFORM) ? 1 : 0, # Suppress, as Blocks.txt is
906 # retained, but needed for
907 # non-ASCII
53d34b6c
KW
908
909 # Suppress, as mapping can be found instead from the
910 # Perl_Decomposition_Mapping file
911 Decomposition_Type => 0,
fcf1973c
KW
912);
913
99870f4d 914# Properties that this program ignores.
230e0c16
KW
915my @unimplemented_properties;
916
917# With this release, it is automatically handled if the Unihan db is
918# downloaded
431c1f00 919push @unimplemented_properties, 'Unicode_Radical_Stroke' if $v_version lt v5.2.0;
d73e5302 920
99870f4d
KW
921# There are several types of obsolete properties defined by Unicode. These
922# must be hand-edited for every new Unicode release.
923my %why_deprecated; # Generates a deprecated warning message if used.
924my %why_stabilized; # Documentation only
925my %why_obsolete; # Documentation only
926
927{ # Closure
8364f9eb 928 my $simple = 'Perl uses the more complete version';
99870f4d
KW
929 my $unihan = 'Unihan properties are by default not enabled in the Perl core. Instead use CPAN: Unicode::Unihan';
930
931 my $other_properties = 'other properties';
932 my $contributory = "Used by Unicode internally for generating $other_properties and not intended to be used stand-alone";
5d294d41 933 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.";
99870f4d
KW
934
935 %why_deprecated = (
5f7264c7 936 'Grapheme_Link' => 'Deprecated by Unicode: Duplicates ccc=vr (Canonical_Combining_Class=Virama)',
99870f4d
KW
937 'Jamo_Short_Name' => $contributory,
938 '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',
939 'Other_Alphabetic' => $contributory,
940 'Other_Default_Ignorable_Code_Point' => $contributory,
941 'Other_Grapheme_Extend' => $contributory,
942 'Other_ID_Continue' => $contributory,
943 'Other_ID_Start' => $contributory,
944 'Other_Lowercase' => $contributory,
945 'Other_Math' => $contributory,
946 'Other_Uppercase' => $contributory,
e22aaf5c
KW
947 'Expands_On_NFC' => $why_no_expand,
948 'Expands_On_NFD' => $why_no_expand,
949 'Expands_On_NFKC' => $why_no_expand,
950 'Expands_On_NFKD' => $why_no_expand,
99870f4d
KW
951 );
952
953 %why_suppressed = (
5f7264c7 954 # There is a lib/unicore/Decomposition.pl (used by Normalize.pm) which
99870f4d
KW
955 # contains the same information, but without the algorithmically
956 # determinable Hangul syllables'. This file is not published, so it's
957 # existence is not noted in the comment.
12fee290 958 'Decomposition_Mapping' => 'Accessible via Unicode::Normalize or prop_invmap() or charprop() in Unicode::UCD::',
99870f4d 959
ac71d2a0 960 'Indic_Matra_Category' => "Withdrawn by Unicode while still provisional",
3111abc0 961
5f8d1a89
KW
962 # Don't suppress ISO_Comment, as otherwise special handling is needed
963 # to differentiate between it and gc=c, which can be written as 'isc',
964 # which is the same characters as ISO_Comment's short name.
99870f4d 965
12fee290 966 'Name' => "Accessible via \\N{...} or 'use charnames;' or charprop() or prop_invmap() in Unicode::UCD::",
e0b29447 967
12fee290
KW
968 'Simple_Case_Folding' => "$simple. Can access this through casefold(), charprop(), or prop_invmap() in Unicode::UCD",
969 'Simple_Lowercase_Mapping' => "$simple. Can access this through charinfo(), charprop(), or prop_invmap() in Unicode::UCD",
970 'Simple_Titlecase_Mapping' => "$simple. Can access this through charinfo(), charprop(), or prop_invmap() in Unicode::UCD",
971 'Simple_Uppercase_Mapping' => "$simple. Can access this through charinfo(), charprop(), or prop_invmap() in Unicode::UCD",
99870f4d 972
dac6f618 973 FC_NFKC_Closure => 'Deprecated by Unicode, and supplanted in usage by NFKC_Casefold; otherwise not useful',
99870f4d
KW
974 );
975
1704a0ea
KW
976 foreach my $property (
977
978 # The following are suppressed because they were made contributory
979 # or deprecated by Unicode before Perl ever thought about
980 # supporting them.
981 'Jamo_Short_Name',
982 'Grapheme_Link',
983 'Expands_On_NFC',
984 'Expands_On_NFD',
985 'Expands_On_NFKC',
986 'Expands_On_NFKD',
987
988 # The following are suppressed because they have been marked
989 # as deprecated for a sufficient amount of time
990 'Other_Alphabetic',
991 'Other_Default_Ignorable_Code_Point',
992 'Other_Grapheme_Extend',
993 'Other_ID_Continue',
994 'Other_ID_Start',
995 'Other_Lowercase',
996 'Other_Math',
997 'Other_Uppercase',
e22aaf5c 998 ) {
99870f4d
KW
999 $why_suppressed{$property} = $why_deprecated{$property};
1000 }
cf25bb62 1001
99870f4d
KW
1002 # Customize the message for all the 'Other_' properties
1003 foreach my $property (keys %why_deprecated) {
1004 next if (my $main_property = $property) !~ s/^Other_//;
1005 $why_deprecated{$property} =~ s/$other_properties/the $main_property property (which should be used instead)/;
1006 }
1007}
1008
e9c4b4f8
KW
1009if ($write_Unicode_deprecated_tables) {
1010 foreach my $property (keys %why_suppressed) {
1011 delete $why_suppressed{$property} if $property =~
1012 / ^ Other | Grapheme /x;
1013 }
1014}
1015
99870f4d
KW
1016if ($v_version ge 4.0.0) {
1017 $why_stabilized{'Hyphen'} = 'Use the Line_Break property instead; see www.unicode.org/reports/tr14';
5f7264c7
KW
1018 if ($v_version ge 6.0.0) {
1019 $why_deprecated{'Hyphen'} = 'Supplanted by Line_Break property values; see www.unicode.org/reports/tr14';
1020 }
99870f4d 1021}
5f7264c7 1022if ($v_version ge 5.2.0 && $v_version lt 6.0.0) {
99870f4d 1023 $why_obsolete{'ISO_Comment'} = 'Code points for it have been removed';
5f7264c7 1024 if ($v_version ge 6.0.0) {
63f74647 1025 $why_deprecated{'ISO_Comment'} = 'No longer needed for Unicode\'s internal chart generation; otherwise not useful, and code points for it have been removed';
5f7264c7 1026 }
99870f4d
KW
1027}
1028
1029# Probably obsolete forever
1030if ($v_version ge v4.1.0) {
82aed44a
KW
1031 $why_suppressed{'Script=Katakana_Or_Hiragana'} = 'Obsolete. All code points previously matched by this have been moved to "Script=Common".';
1032}
1033if ($v_version ge v6.0.0) {
caa75395 1034 $why_suppressed{'Script=Katakana_Or_Hiragana'} .= ' Consider instead using "Script_Extensions=Katakana" or "Script_Extensions=Hiragana" (or both)';
2b352efd 1035 $why_suppressed{'Script_Extensions=Katakana_Or_Hiragana'} = 'All code points that would be matched by this are matched by either "Script_Extensions=Katakana" or "Script_Extensions=Hiragana"';
99870f4d
KW
1036}
1037
1038# This program can create files for enumerated-like properties, such as
1039# 'Numeric_Type'. This file would be the same format as for a string
1040# property, with a mapping from code point to its value, so you could look up,
1041# for example, the script a code point is in. But no one so far wants this
1042# mapping, or they have found another way to get it since this is a new
1043# feature. So no file is generated except if it is in this list.
1044my @output_mapped_properties = split "\n", <<END;
1045END
1046
c12f2655
KW
1047# If you are using the Unihan database in a Unicode version before 5.2, you
1048# need to add the properties that you want to extract from it to this table.
1049# For your convenience, the properties in the 6.0 PropertyAliases.txt file are
1050# listed, commented out
99870f4d
KW
1051my @cjk_properties = split "\n", <<'END';
1052#cjkAccountingNumeric; kAccountingNumeric
1053#cjkOtherNumeric; kOtherNumeric
1054#cjkPrimaryNumeric; kPrimaryNumeric
1055#cjkCompatibilityVariant; kCompatibilityVariant
1056#cjkIICore ; kIICore
1057#cjkIRG_GSource; kIRG_GSource
1058#cjkIRG_HSource; kIRG_HSource
1059#cjkIRG_JSource; kIRG_JSource
1060#cjkIRG_KPSource; kIRG_KPSource
1061#cjkIRG_KSource; kIRG_KSource
1062#cjkIRG_TSource; kIRG_TSource
1063#cjkIRG_USource; kIRG_USource
1064#cjkIRG_VSource; kIRG_VSource
1065#cjkRSUnicode; kRSUnicode ; Unicode_Radical_Stroke; URS
1066END
1067
1068# Similarly for the property values. For your convenience, the lines in the
5f7264c7 1069# 6.0 PropertyAliases.txt file are listed. Just remove the first BUT NOT both
c12f2655 1070# '#' marks (for Unicode versions before 5.2)
99870f4d
KW
1071my @cjk_property_values = split "\n", <<'END';
1072## @missing: 0000..10FFFF; cjkAccountingNumeric; NaN
1073## @missing: 0000..10FFFF; cjkCompatibilityVariant; <code point>
1074## @missing: 0000..10FFFF; cjkIICore; <none>
1075## @missing: 0000..10FFFF; cjkIRG_GSource; <none>
1076## @missing: 0000..10FFFF; cjkIRG_HSource; <none>
1077## @missing: 0000..10FFFF; cjkIRG_JSource; <none>
1078## @missing: 0000..10FFFF; cjkIRG_KPSource; <none>
1079## @missing: 0000..10FFFF; cjkIRG_KSource; <none>
1080## @missing: 0000..10FFFF; cjkIRG_TSource; <none>
1081## @missing: 0000..10FFFF; cjkIRG_USource; <none>
1082## @missing: 0000..10FFFF; cjkIRG_VSource; <none>
1083## @missing: 0000..10FFFF; cjkOtherNumeric; NaN
1084## @missing: 0000..10FFFF; cjkPrimaryNumeric; NaN
1085## @missing: 0000..10FFFF; cjkRSUnicode; <none>
1086END
1087
1088# The input files don't list every code point. Those not listed are to be
1089# defaulted to some value. Below are hard-coded what those values are for
1090# non-binary properties as of 5.1. Starting in 5.0, there are
caa75395 1091# machine-parsable comment lines in the files that give the defaults; so this
99870f4d
KW
1092# list shouldn't have to be extended. The claim is that all missing entries
1093# for binary properties will default to 'N'. Unicode tried to change that in
1094# 5.2, but the beta period produced enough protest that they backed off.
1095#
1096# The defaults for the fields that appear in UnicodeData.txt in this hash must
1097# be in the form that it expects. The others may be synonyms.
1098my $CODE_POINT = '<code point>';
1099my %default_mapping = (
1100 Age => "Unassigned",
1101 # Bidi_Class => Complicated; set in code
1102 Bidi_Mirroring_Glyph => "",
1103 Block => 'No_Block',
1104 Canonical_Combining_Class => 0,
1105 Case_Folding => $CODE_POINT,
1106 Decomposition_Mapping => $CODE_POINT,
1107 Decomposition_Type => 'None',
1108 East_Asian_Width => "Neutral",
1109 FC_NFKC_Closure => $CODE_POINT,
ec2cd995 1110 General_Category => ($v_version le 6.3.0) ? 'Cn' : 'Unassigned',
99870f4d
KW
1111 Grapheme_Cluster_Break => 'Other',
1112 Hangul_Syllable_Type => 'NA',
1113 ISO_Comment => "",
1114 Jamo_Short_Name => "",
1115 Joining_Group => "No_Joining_Group",
1116 # Joining_Type => Complicated; set in code
1117 kIICore => 'N', # Is converted to binary
1118 #Line_Break => Complicated; set in code
1119 Lowercase_Mapping => $CODE_POINT,
1120 Name => "",
1121 Name_Alias => "",
1122 NFC_QC => 'Yes',
1123 NFD_QC => 'Yes',
1124 NFKC_QC => 'Yes',
1125 NFKD_QC => 'Yes',
1126 Numeric_Type => 'None',
1127 Numeric_Value => 'NaN',
1128 Script => ($v_version le 4.1.0) ? 'Common' : 'Unknown',
1129 Sentence_Break => 'Other',
1130 Simple_Case_Folding => $CODE_POINT,
1131 Simple_Lowercase_Mapping => $CODE_POINT,
1132 Simple_Titlecase_Mapping => $CODE_POINT,
1133 Simple_Uppercase_Mapping => $CODE_POINT,
1134 Titlecase_Mapping => $CODE_POINT,
1135 Unicode_1_Name => "",
1136 Unicode_Radical_Stroke => "",
1137 Uppercase_Mapping => $CODE_POINT,
1138 Word_Break => 'Other',
1139);
1140
232ed87f
KW
1141# Below are files that Unicode furnishes, but this program ignores, and why.
1142# NormalizationCorrections.txt requires some more explanation. It documents
1143# the cumulative fixes to erroneous normalizations in earlier Unicode
1144# versions. Its main purpose is so that someone running on an earlier version
1145# can use this file to override what got published in that earlier release.
1146# It would be easy for mktables to read and handle this file. But all the
1147# corrections in it should already be in the other files for the release it
1148# is. To get it to actually mean something useful, someone would have to be
1149# using an earlier Unicode release, and copy it to the files for that release
1150# and recomplile. So far there has been no demand to do that, so this hasn't
1151# been implemented.
99870f4d 1152my %ignored_files = (
73ba1144
KW
1153 'CJKRadicals.txt' => 'Maps the kRSUnicode property values to corresponding code points',
1154 'Index.txt' => 'Alphabetical index of Unicode characters',
1155 'NamedSqProv.txt' => 'Named sequences proposed for inclusion in a later version of the Unicode Standard; if you need them now, you can append this file to F<NamedSequences.txt> and recompile perl',
1156 'NamesList.txt' => 'Annotated list of characters',
524a8e5e 1157 'NamesList.html' => 'Describes the format and contents of F<NamesList.txt>',
73ba1144
KW
1158 'NormalizationCorrections.txt' => 'Documentation of corrections already incorporated into the Unicode data base',
1159 'Props.txt' => 'Only in very early releases; is a subset of F<PropList.txt> (which is used instead)',
1160 'ReadMe.txt' => 'Documentation',
1161 'StandardizedVariants.txt' => 'Certain glyph variations for character display are standardized. This lists the non-Unihan ones; the Unihan ones are also not used by Perl, and are in a separate Unicode data base L<http://www.unicode.org/ivd>',
524a8e5e 1162 'StandardizedVariants.html' => 'Provides a visual display of the standard variant sequences derived from F<StandardizedVariants.txt>.',
73ba1144 1163 'EmojiSources.txt' => 'Maps certain Unicode code points to their legacy Japanese cell-phone values',
8ee2793f 1164 'USourceData.txt' => 'Documentation of status and cross reference of proposals for encoding by Unicode of Unihan characters',
524a8e5e 1165 'USourceGlyphs.pdf' => 'Pictures of the characters in F<USourceData.txt>',
73ba1144
KW
1166 'auxiliary/WordBreakTest.html' => 'Documentation of validation tests',
1167 'auxiliary/SentenceBreakTest.html' => 'Documentation of validation tests',
1168 'auxiliary/GraphemeBreakTest.html' => 'Documentation of validation tests',
1169 'auxiliary/LineBreakTest.html' => 'Documentation of validation tests',
99870f4d
KW
1170);
1171
1fec9f60
KW
1172my %skipped_files; # List of files that we skip
1173
678f13d5 1174### End of externally interesting definitions, except for @input_file_objects
99870f4d
KW
1175
1176my $HEADER=<<"EOF";
1177# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
3df51b85
KW
1178# This file is machine-generated by $0 from the Unicode
1179# database, Version $string_version. Any changes made here will be lost!
cf25bb62
JH
1180EOF
1181
126c3d4e 1182my $INTERNAL_ONLY_HEADER = <<"EOF";
99870f4d
KW
1183
1184# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
fac53429
KW
1185# This file is for internal use by core Perl only. The format and even the
1186# name or existence of this file are subject to change without notice. Don't
d9ae3878
KW
1187# use it directly. Use Unicode::UCD to access the Unicode character data
1188# base.
99870f4d
KW
1189EOF
1190
1191my $DEVELOPMENT_ONLY=<<"EOF";
1192# !!!!!!! DEVELOPMENT USE ONLY !!!!!!!
1193# This file contains information artificially constrained to code points
1194# present in Unicode release $string_compare_versions.
1195# IT CANNOT BE RELIED ON. It is for use during development only and should
23e33b60 1196# not be used for production.
b6922eda
KW
1197
1198EOF
1199
346a20cf
KW
1200my $MAX_UNICODE_CODEPOINT_STRING = ($v_version ge v2.0.0)
1201 ? "10FFFF"
1202 : "FFFF";
6189eadc
KW
1203my $MAX_UNICODE_CODEPOINT = hex $MAX_UNICODE_CODEPOINT_STRING;
1204my $MAX_UNICODE_CODEPOINTS = $MAX_UNICODE_CODEPOINT + 1;
99870f4d 1205
2d88a86a
KW
1206# We work with above-Unicode code points, up to UV_MAX. But when you get
1207# that high, above IV_MAX, some operations don't work, and you can easily get
1208# overflow. Therefore for internal use, we use a much smaller number,
1209# translating it to UV_MAX only for output. The exact number is immaterial
1210# (all Unicode code points are treated exactly the same), but the algorithm
1211# requires it to be at least 2 * $MAX_UNICODE_CODEPOINTS + 1;
1212my $MAX_WORKING_CODEPOINTS= $MAX_UNICODE_CODEPOINT * 8;
1213my $MAX_WORKING_CODEPOINT = $MAX_WORKING_CODEPOINTS - 1;
1214my $MAX_WORKING_CODEPOINT_STRING = sprintf("%X", $MAX_WORKING_CODEPOINT);
1215
1216my $MAX_PLATFORM_CODEPOINT = ~0;
1217
99870f4d
KW
1218# Matches legal code point. 4-6 hex numbers, If there are 6, the first
1219# two must be 10; if there are 5, the first must not be a 0. Written this way
92199589
KW
1220# to decrease backtracking. The first regex allows the code point to be at
1221# the end of a word, but to work properly, the word shouldn't end with a valid
1222# hex character. The second one won't match a code point at the end of a
1223# word, and doesn't have the run-on issue
8c32d378
KW
1224my $run_on_code_point_re =
1225 qr/ (?: 10[0-9A-F]{4} | [1-9A-F][0-9A-F]{4} | [0-9A-F]{4} ) \b/x;
1226my $code_point_re = qr/\b$run_on_code_point_re/;
99870f4d
KW
1227
1228# This matches the beginning of the line in the Unicode db files that give the
1229# defaults for code points not listed (i.e., missing) in the file. The code
1230# depends on this ending with a semi-colon, so it can assume it is a valid
1231# field when the line is split() by semi-colons
346a20cf 1232my $missing_defaults_prefix = qr/^#\s+\@missing:\s+0000\.\.10FFFF\s*;/;
99870f4d
KW
1233
1234# Property types. Unicode has more types, but these are sufficient for our
1235# purposes.
1236my $UNKNOWN = -1; # initialized to illegal value
1237my $NON_STRING = 1; # Either binary or enum
1238my $BINARY = 2;
06f26c45
KW
1239my $FORCED_BINARY = 3; # Not a binary property, but, besides its normal
1240 # tables, additional true and false tables are
1241 # generated so that false is anything matching the
1242 # default value, and true is everything else.
1243my $ENUM = 4; # Include catalog
1244my $STRING = 5; # Anything else: string or misc
99870f4d
KW
1245
1246# Some input files have lines that give default values for code points not
1247# contained in the file. Sometimes these should be ignored.
1248my $NO_DEFAULTS = 0; # Must evaluate to false
1249my $NOT_IGNORED = 1;
1250my $IGNORED = 2;
1251
1252# Range types. Each range has a type. Most ranges are type 0, for normal,
1253# and will appear in the main body of the tables in the output files, but
1254# there are other types of ranges as well, listed below, that are specially
1255# handled. There are pseudo-types as well that will never be stored as a
1256# type, but will affect the calculation of the type.
1257
1258# 0 is for normal, non-specials
1259my $MULTI_CP = 1; # Sequence of more than code point
1260my $HANGUL_SYLLABLE = 2;
1261my $CP_IN_NAME = 3; # The NAME contains the code point appended to it.
1262my $NULL = 4; # The map is to the null string; utf8.c can't
1263 # handle these, nor is there an accepted syntax
1264 # for them in \p{} constructs
f86864ac 1265my $COMPUTE_NO_MULTI_CP = 5; # Pseudo-type; means that ranges that would
99870f4d
KW
1266 # otherwise be $MULTI_CP type are instead type 0
1267
1268# process_generic_property_file() can accept certain overrides in its input.
1269# Each of these must begin AND end with $CMD_DELIM.
1270my $CMD_DELIM = "\a";
1271my $REPLACE_CMD = 'replace'; # Override the Replace
1272my $MAP_TYPE_CMD = 'map_type'; # Override the Type
1273
1274my $NO = 0;
1275my $YES = 1;
1276
1277# Values for the Replace argument to add_range.
1278# $NO # Don't replace; add only the code points not
1279 # already present.
1280my $IF_NOT_EQUIVALENT = 1; # Replace only under certain conditions; details in
1281 # the comments at the subroutine definition.
1282my $UNCONDITIONALLY = 2; # Replace without conditions.
9470941f 1283my $MULTIPLE_BEFORE = 4; # Don't replace, but add a duplicate record if
99870f4d 1284 # already there
7f4b1e25
KW
1285my $MULTIPLE_AFTER = 5; # Don't replace, but add a duplicate record if
1286 # already there
1287my $CROAK = 6; # Die with an error if is already there
99870f4d
KW
1288
1289# Flags to give property statuses. The phrases are to remind maintainers that
1290# if the flag is changed, the indefinite article referring to it in the
1291# documentation may need to be as well.
1292my $NORMAL = "";
99870f4d
KW
1293my $DEPRECATED = 'D';
1294my $a_bold_deprecated = "a 'B<$DEPRECATED>'";
1295my $A_bold_deprecated = "A 'B<$DEPRECATED>'";
1296my $DISCOURAGED = 'X';
1297my $a_bold_discouraged = "an 'B<$DISCOURAGED>'";
1298my $A_bold_discouraged = "An 'B<$DISCOURAGED>'";
1299my $STRICTER = 'T';
1300my $a_bold_stricter = "a 'B<$STRICTER>'";
1301my $A_bold_stricter = "A 'B<$STRICTER>'";
1302my $STABILIZED = 'S';
1303my $a_bold_stabilized = "an 'B<$STABILIZED>'";
1304my $A_bold_stabilized = "An 'B<$STABILIZED>'";
1305my $OBSOLETE = 'O';
1306my $a_bold_obsolete = "an 'B<$OBSOLETE>'";
1307my $A_bold_obsolete = "An 'B<$OBSOLETE>'";
1308
5c6d9947
KW
1309# Aliases can also have an extra status:
1310my $INTERNAL_ALIAS = 'P';
1311
99870f4d
KW
1312my %status_past_participles = (
1313 $DISCOURAGED => 'discouraged',
99870f4d
KW
1314 $STABILIZED => 'stabilized',
1315 $OBSOLETE => 'obsolete',
37e2e78e 1316 $DEPRECATED => 'deprecated',
5c6d9947 1317 $INTERNAL_ALIAS => 'reserved for Perl core internal use only',
99870f4d
KW
1318);
1319
395dfc19
KW
1320# Table fates. These are somewhat ordered, so that fates < $MAP_PROXIED should be
1321# externally documented.
301ba948 1322my $ORDINARY = 0; # The normal fate.
395dfc19
KW
1323my $MAP_PROXIED = 1; # The map table for the property isn't written out,
1324 # but there is a file written that can be used to
1325 # reconstruct this table
3cdaf629 1326my $INTERNAL_ONLY = 2; # The file for this table is written out, but it is
301ba948 1327 # for Perl's internal use only
277b7b16
KW
1328my $LEGACY_ONLY = 3; # Like $INTERNAL_ONLY, but not actually used by Perl.
1329 # Is for backwards compatibility for applications that
1330 # read the file directly, so it's format is
1331 # unchangeable.
1332my $SUPPRESSED = 4; # The file for this table is not written out, and as a
3cdaf629
KW
1333 # result, we don't bother to do many computations on
1334 # it.
277b7b16 1335my $PLACEHOLDER = 5; # Like $SUPPRESSED, but we go through all the
3cdaf629
KW
1336 # computations anyway, as the values are needed for
1337 # things to work. This happens when we have Perl
1338 # extensions that depend on Unicode tables that
1339 # wouldn't normally be in a given Unicode version.
301ba948 1340
f5817e0a
KW
1341# The format of the values of the tables:
1342my $EMPTY_FORMAT = "";
99870f4d
KW
1343my $BINARY_FORMAT = 'b';
1344my $DECIMAL_FORMAT = 'd';
1345my $FLOAT_FORMAT = 'f';
1346my $INTEGER_FORMAT = 'i';
1347my $HEX_FORMAT = 'x';
1348my $RATIONAL_FORMAT = 'r';
1349my $STRING_FORMAT = 's';
d11155ec 1350my $ADJUST_FORMAT = 'a';
24303724 1351my $HEX_ADJUST_FORMAT = 'ax';
a14f3cb1 1352my $DECOMP_STRING_FORMAT = 'c';
c3ff2976 1353my $STRING_WHITE_SPACE_LIST = 'sw';
99870f4d
KW
1354
1355my %map_table_formats = (
1356 $BINARY_FORMAT => 'binary',
1357 $DECIMAL_FORMAT => 'single decimal digit',
1358 $FLOAT_FORMAT => 'floating point number',
1359 $INTEGER_FORMAT => 'integer',
add63c13 1360 $HEX_FORMAT => 'non-negative hex whole number; a code point',
99870f4d 1361 $RATIONAL_FORMAT => 'rational: an integer or a fraction',
1a9d544b 1362 $STRING_FORMAT => 'string',
d11155ec 1363 $ADJUST_FORMAT => 'some entries need adjustment',
24303724 1364 $HEX_ADJUST_FORMAT => 'mapped value in hex; some entries need adjustment',
92f9d56c 1365 $DECOMP_STRING_FORMAT => 'Perl\'s internal (Normalize.pm) decomposition mapping',
c3ff2976 1366 $STRING_WHITE_SPACE_LIST => 'string, but some elements are interpreted as a list; white space occurs only as list item separators'
99870f4d
KW
1367);
1368
1369# Unicode didn't put such derived files in a separate directory at first.
1370my $EXTRACTED_DIR = (-d 'extracted') ? 'extracted' : "";
1371my $EXTRACTED = ($EXTRACTED_DIR) ? "$EXTRACTED_DIR/" : "";
1372my $AUXILIARY = 'auxiliary';
1373
3854b4b8
KW
1374# Hashes and arrays that will eventually go into Heavy.pl for the use of
1375# utf8_heavy.pl and into UCD.pl for the use of UCD.pm
99870f4d
KW
1376my %loose_to_file_of; # loosely maps table names to their respective
1377 # files
1378my %stricter_to_file_of; # same; but for stricter mapping.
315bfd4e 1379my %loose_property_to_file_of; # Maps a loose property name to its map file
e1dc048d 1380my %strict_property_to_file_of; # Same, but strict
3854b4b8
KW
1381my @inline_definitions = "V0"; # Each element gives a definition of a unique
1382 # inversion list. When a definition is inlined,
1383 # its value in the hash it's in (one of the two
1384 # defined just above) will include an index into
1385 # this array. The 0th element is initialized to
9be22ca5 1386 # the definition for a zero length inversion list
89cf10cc
KW
1387my %file_to_swash_name; # Maps the file name to its corresponding key name
1388 # in the hash %utf8::SwashInfo
99870f4d
KW
1389my %nv_floating_to_rational; # maps numeric values floating point numbers to
1390 # their rational equivalent
c12f2655
KW
1391my %loose_property_name_of; # Loosely maps (non_string) property names to
1392 # standard form
e1dc048d
KW
1393my %strict_property_name_of; # Strictly maps (non_string) property names to
1394 # standard form
86a52d1e 1395my %string_property_loose_to_name; # Same, for string properties.
c15fda25
KW
1396my %loose_defaults; # keys are of form "prop=value", where 'prop' is
1397 # the property name in standard loose form, and
1398 # 'value' is the default value for that property,
1399 # also in standard loose form.
9e4a1e86
KW
1400my %loose_to_standard_value; # loosely maps table names to the canonical
1401 # alias for them
2df7880f
KW
1402my %ambiguous_names; # keys are alias names (in standard form) that
1403 # have more than one possible meaning.
d963b40d
KW
1404my %combination_property; # keys are alias names (in standard form) that
1405 # have both a map table, and a binary one that
1406 # yields true for all non-null maps.
5d1df013
KW
1407my %prop_aliases; # Keys are standard property name; values are each
1408 # one's aliases
1e863613
KW
1409my %prop_value_aliases; # Keys of top level are standard property name;
1410 # values are keys to another hash, Each one is
1411 # one of the property's values, in standard form.
1412 # The values are that prop-val's aliases.
2df7880f 1413my %ucd_pod; # Holds entries that will go into the UCD section of the pod
99870f4d 1414
d867ccfb
KW
1415# Most properties are immune to caseless matching, otherwise you would get
1416# nonsensical results, as properties are a function of a code point, not
1417# everything that is caselessly equivalent to that code point. For example,
1418# Changes_When_Case_Folded('s') should be false, whereas caselessly it would
1419# be true because 's' and 'S' are equivalent caselessly. However,
1420# traditionally, [:upper:] and [:lower:] are equivalent caselessly, so we
1421# extend that concept to those very few properties that are like this. Each
1422# such property will match the full range caselessly. They are hard-coded in
1423# the program; it's not worth trying to make it general as it's extremely
1424# unlikely that they will ever change.
1425my %caseless_equivalent_to;
1426
99870f4d
KW
1427# These constants names and values were taken from the Unicode standard,
1428# version 5.1, section 3.12. They are used in conjunction with Hangul
6e5a209b
KW
1429# syllables. The '_string' versions are so generated tables can retain the
1430# hex format, which is the more familiar value
1431my $SBase_string = "0xAC00";
1432my $SBase = CORE::hex $SBase_string;
1433my $LBase_string = "0x1100";
1434my $LBase = CORE::hex $LBase_string;
1435my $VBase_string = "0x1161";
1436my $VBase = CORE::hex $VBase_string;
1437my $TBase_string = "0x11A7";
1438my $TBase = CORE::hex $TBase_string;
99870f4d
KW
1439my $SCount = 11172;
1440my $LCount = 19;
1441my $VCount = 21;
1442my $TCount = 28;
1443my $NCount = $VCount * $TCount;
1444
1445# For Hangul syllables; These store the numbers from Jamo.txt in conjunction
1446# with the above published constants.
1447my %Jamo;
1448my %Jamo_L; # Leading consonants
1449my %Jamo_V; # Vowels
1450my %Jamo_T; # Trailing consonants
1451
bb1dd3da
KW
1452# For code points whose name contains its ordinal as a '-ABCD' suffix.
1453# The key is the base name of the code point, and the value is an
1454# array giving all the ranges that use this base name. Each range
1455# is actually a hash giving the 'low' and 'high' values of it.
1456my %names_ending_in_code_point;
1457my %loose_names_ending_in_code_point; # Same as above, but has blanks, dashes
1458 # removed from the names
1459# Inverse mapping. The list of ranges that have these kinds of
1460# names. Each element contains the low, high, and base names in an
1461# anonymous hash.
1462my @code_points_ending_in_code_point;
1463
6b5ab373
KW
1464# To hold Unicode's normalization test suite
1465my @normalization_tests;
1466
bb1dd3da
KW
1467# Boolean: does this Unicode version have the hangul syllables, and are we
1468# writing out a table for them?
1469my $has_hangul_syllables = 0;
1470
1471# Does this Unicode version have code points whose names end in their
1472# respective code points, and are we writing out a table for them? 0 for no;
1473# otherwise points to first property that a table is needed for them, so that
1474# if multiple tables are needed, we don't create duplicates
1475my $needing_code_points_ending_in_code_point = 0;
1476
37e2e78e 1477my @backslash_X_tests; # List of tests read in for testing \X
06ae2722 1478my @SB_tests; # List of tests read in for testing \b{sb}
ae3bb8ea 1479my @WB_tests; # List of tests read in for testing \b{wb}
99870f4d
KW
1480my @unhandled_properties; # Will contain a list of properties found in
1481 # the input that we didn't process.
f86864ac 1482my @match_properties; # Properties that have match tables, to be
99870f4d
KW
1483 # listed in the pod
1484my @map_properties; # Properties that get map files written
1485my @named_sequences; # NamedSequences.txt contents.
1486my %potential_files; # Generated list of all .txt files in the directory
1487 # structure so we can warn if something is being
1488 # ignored.
1489my @files_actually_output; # List of files we generated.
1490my @more_Names; # Some code point names are compound; this is used
1491 # to store the extra components of them.
1492my $MIN_FRACTION_LENGTH = 3; # How many digits of a floating point number at
1493 # the minimum before we consider it equivalent to a
1494 # candidate rational
1495my $MAX_FLOATING_SLOP = 10 ** - $MIN_FRACTION_LENGTH; # And in floating terms
1496
1497# These store references to certain commonly used property objects
3c88a801 1498my $ccc;
99870f4d
KW
1499my $gc;
1500my $perl;
1501my $block;
3e20195b
KW
1502my $perl_charname;
1503my $print;
ac7dbdb6 1504my $All;
bc0c431d 1505my $Assigned; # All assigned characters in this Unicode release
359523e2 1506my $script;
99870f4d
KW
1507
1508# Are there conflicting names because of beginning with 'In_', or 'Is_'
1509my $has_In_conflicts = 0;
1510my $has_Is_conflicts = 0;
1511
1512sub internal_file_to_platform ($) {
1513 # Convert our file paths which have '/' separators to those of the
1514 # platform.
1515
1516 my $file = shift;
1517 return undef unless defined $file;
1518
1519 return File::Spec->join(split '/', $file);
d07a55ed 1520}
5beb625e 1521
99870f4d
KW
1522sub file_exists ($) { # platform independent '-e'. This program internally
1523 # uses slash as a path separator.
1524 my $file = shift;
1525 return 0 if ! defined $file;
1526 return -e internal_file_to_platform($file);
1527}
5beb625e 1528
99870f4d 1529sub objaddr($) {
23e33b60
KW
1530 # Returns the address of the blessed input object.
1531 # It doesn't check for blessedness because that would do a string eval
1532 # every call, and the program is structured so that this is never called
1533 # for a non-blessed object.
99870f4d 1534
23e33b60 1535 no overloading; # If overloaded, numifying below won't work.
99870f4d
KW
1536
1537 # Numifying a ref gives its address.
051df77b 1538 return pack 'J', $_[0];
99870f4d
KW
1539}
1540
558712cf 1541# These are used only if $annotate is true.
c4019d52
KW
1542# The entire range of Unicode characters is examined to populate these
1543# after all the input has been processed. But most can be skipped, as they
1544# have the same descriptive phrases, such as being unassigned
1545my @viacode; # Contains the 1 million character names
1546my @printable; # boolean: And are those characters printable?
1547my @annotate_char_type; # Contains a type of those characters, specifically
1548 # for the purposes of annotation.
1549my $annotate_ranges; # A map of ranges of code points that have the same
98dc9551 1550 # name for the purposes of annotation. They map to the
c4019d52
KW
1551 # upper edge of the range, so that the end point can
1552 # be immediately found. This is used to skip ahead to
1553 # the end of a range, and avoid processing each
1554 # individual code point in it.
1555my $unassigned_sans_noncharacters; # A Range_List of the unassigned
1556 # characters, but excluding those which are
1557 # also noncharacter code points
1558
1559# The annotation types are an extension of the regular range types, though
1560# some of the latter are folded into one. Make the new types negative to
1561# avoid conflicting with the regular types
1562my $SURROGATE_TYPE = -1;
1563my $UNASSIGNED_TYPE = -2;
1564my $PRIVATE_USE_TYPE = -3;
1565my $NONCHARACTER_TYPE = -4;
1566my $CONTROL_TYPE = -5;
2d88a86a
KW
1567my $ABOVE_UNICODE_TYPE = -6;
1568my $UNKNOWN_TYPE = -7; # Used only if there is a bug in this program
c4019d52
KW
1569
1570sub populate_char_info ($) {
558712cf 1571 # Used only with the $annotate option. Populates the arrays with the
c4019d52
KW
1572 # input code point's info that are needed for outputting more detailed
1573 # comments. If calling context wants a return, it is the end point of
1574 # any contiguous range of characters that share essentially the same info
1575
1576 my $i = shift;
1577 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
1578
1579 $viacode[$i] = $perl_charname->value_of($i) || "";
1580
1581 # A character is generally printable if Unicode says it is,
1582 # but below we make sure that most Unicode general category 'C' types
1583 # aren't.
1584 $printable[$i] = $print->contains($i);
1585
1586 $annotate_char_type[$i] = $perl_charname->type_of($i) || 0;
1587
1588 # Only these two regular types are treated specially for annotations
1589 # purposes
1590 $annotate_char_type[$i] = 0 if $annotate_char_type[$i] != $CP_IN_NAME
1591 && $annotate_char_type[$i] != $HANGUL_SYLLABLE;
1592
1593 # Give a generic name to all code points that don't have a real name.
1594 # We output ranges, if applicable, for these. Also calculate the end
1595 # point of the range.
1596 my $end;
1597 if (! $viacode[$i]) {
1d025d66 1598 my $nonchar;
2d88a86a
KW
1599 if ($i > $MAX_UNICODE_CODEPOINT) {
1600 $viacode[$i] = 'Above-Unicode';
1601 $annotate_char_type[$i] = $ABOVE_UNICODE_TYPE;
1602 $printable[$i] = 0;
1603 $end = $MAX_WORKING_CODEPOINT;
1604 }
1605 elsif ($gc-> table('Private_use')->contains($i)) {
c4019d52
KW
1606 $viacode[$i] = 'Private Use';
1607 $annotate_char_type[$i] = $PRIVATE_USE_TYPE;
1608 $printable[$i] = 0;
1609 $end = $gc->table('Private_Use')->containing_range($i)->end;
1610 }
1d025d66
KW
1611 elsif ((defined ($nonchar =
1612 Property::property_ref('Noncharacter_Code_Point'))
1613 && $nonchar->table('Y')->contains($i)))
c4019d52
KW
1614 {
1615 $viacode[$i] = 'Noncharacter';
1616 $annotate_char_type[$i] = $NONCHARACTER_TYPE;
1617 $printable[$i] = 0;
1618 $end = property_ref('Noncharacter_Code_Point')->table('Y')->
1619 containing_range($i)->end;
1620 }
1621 elsif ($gc-> table('Control')->contains($i)) {
c71dea7f 1622 $viacode[$i] = property_ref('Name_Alias')->value_of($i) || 'Control';
c4019d52
KW
1623 $annotate_char_type[$i] = $CONTROL_TYPE;
1624 $printable[$i] = 0;
c4019d52
KW
1625 }
1626 elsif ($gc-> table('Unassigned')->contains($i)) {
c4019d52
KW
1627 $annotate_char_type[$i] = $UNASSIGNED_TYPE;
1628 $printable[$i] = 0;
1d025d66
KW
1629 if ($v_version lt v2.0.0) { # No blocks in earliest releases
1630 $viacode[$i] = 'Unassigned';
1631 $end = $gc-> table('Unassigned')->containing_range($i)->end;
1632 }
1633 else {
1634 $viacode[$i] = 'Unassigned, block=' . $block-> value_of($i);
c4019d52 1635
bf06c733
KW
1636 # Because we name the unassigned by the blocks they are in, it
1637 # can't go past the end of that block, and it also can't go
1638 # past the unassigned range it is in. The special table makes
1639 # sure that the non-characters, which are unassigned, are
1640 # separated out.
1641 $end = min($block->containing_range($i)->end,
1642 $unassigned_sans_noncharacters->
1643 containing_range($i)->end);
1d025d66
KW
1644 }
1645 }
35e2b416 1646 elsif ($perl->table('_Perl_Surrogate')->contains($i)) {
1d025d66
KW
1647 $viacode[$i] = 'Surrogate';
1648 $annotate_char_type[$i] = $SURROGATE_TYPE;
1649 $printable[$i] = 0;
1650 $end = $gc->table('Surrogate')->containing_range($i)->end;
13ca76ff
KW
1651 }
1652 else {
1653 Carp::my_carp_bug("Can't figure out how to annotate "
1654 . sprintf("U+%04X", $i)
1655 . ". Proceeding anyway.");
c4019d52
KW
1656 $viacode[$i] = 'UNKNOWN';
1657 $annotate_char_type[$i] = $UNKNOWN_TYPE;
1658 $printable[$i] = 0;
1659 }
1660 }
1661
1662 # Here, has a name, but if it's one in which the code point number is
1663 # appended to the name, do that.
1664 elsif ($annotate_char_type[$i] == $CP_IN_NAME) {
1665 $viacode[$i] .= sprintf("-%04X", $i);
1666 $end = $perl_charname->containing_range($i)->end;
1667 }
1668
1669 # And here, has a name, but if it's a hangul syllable one, replace it with
1670 # the correct name from the Unicode algorithm
1671 elsif ($annotate_char_type[$i] == $HANGUL_SYLLABLE) {
1672 use integer;
1673 my $SIndex = $i - $SBase;
1674 my $L = $LBase + $SIndex / $NCount;
1675 my $V = $VBase + ($SIndex % $NCount) / $TCount;
1676 my $T = $TBase + $SIndex % $TCount;
1677 $viacode[$i] = "HANGUL SYLLABLE $Jamo{$L}$Jamo{$V}";
1678 $viacode[$i] .= $Jamo{$T} if $T != $TBase;
1679 $end = $perl_charname->containing_range($i)->end;
1680 }
1681
1682 return if ! defined wantarray;
1683 return $i if ! defined $end; # If not a range, return the input
1684
1685 # Save this whole range so can find the end point quickly
1686 $annotate_ranges->add_map($i, $end, $end);
1687
1688 return $end;
1689}
1690
23e33b60
KW
1691# Commented code below should work on Perl 5.8.
1692## This 'require' doesn't necessarily work in miniperl, and even if it does,
1693## the native perl version of it (which is what would operate under miniperl)
1694## is extremely slow, as it does a string eval every call.
7e017d6d 1695#my $has_fast_scalar_util = $^X !~ /miniperl/
23e33b60
KW
1696# && defined eval "require Scalar::Util";
1697#
1698#sub objaddr($) {
1699# # Returns the address of the blessed input object. Uses the XS version if
1700# # available. It doesn't check for blessedness because that would do a
1701# # string eval every call, and the program is structured so that this is
1702# # never called for a non-blessed object.
1703#
1704# return Scalar::Util::refaddr($_[0]) if $has_fast_scalar_util;
1705#
1706# # Check at least that is a ref.
1707# my $pkg = ref($_[0]) or return undef;
1708#
1709# # Change to a fake package to defeat any overloaded stringify
1710# bless $_[0], 'main::Fake';
1711#
1712# # Numifying a ref gives its address.
051df77b 1713# my $addr = pack 'J', $_[0];
23e33b60
KW
1714#
1715# # Return to original class
1716# bless $_[0], $pkg;
1717# return $addr;
1718#}
1719
99870f4d
KW
1720sub max ($$) {
1721 my $a = shift;
1722 my $b = shift;
1723 return $a if $a >= $b;
1724 return $b;
1725}
1726
1727sub min ($$) {
1728 my $a = shift;
1729 my $b = shift;
1730 return $a if $a <= $b;
1731 return $b;
1732}
1733
1734sub clarify_number ($) {
1735 # This returns the input number with underscores inserted every 3 digits
1736 # in large (5 digits or more) numbers. Input must be entirely digits, not
1737 # checked.
1738
1739 my $number = shift;
1740 my $pos = length($number) - 3;
1741 return $number if $pos <= 1;
1742 while ($pos > 0) {
1743 substr($number, $pos, 0) = '_';
1744 $pos -= 3;
5beb625e 1745 }
99870f4d 1746 return $number;
99598c8c
JH
1747}
1748
731cb813
KW
1749sub clarify_code_point_count ($) {
1750 # This is like clarify_number(), but the input is assumed to be a count of
1751 # code points, rather than a generic number.
1752
2d88a86a
KW
1753 my $append = "";
1754
1755 my $number = shift;
1756 if ($number > $MAX_UNICODE_CODEPOINTS) {
1757 $number -= ($MAX_WORKING_CODEPOINTS - $MAX_UNICODE_CODEPOINTS);
1758 return "All above-Unicode code points" if $number == 0;
1759 $append = " + all above-Unicode code points";
1760 }
1761 return clarify_number($number) . $append;
731cb813 1762}
12ac2576 1763
99870f4d 1764package Carp;
7ebf06b3 1765
99870f4d
KW
1766# These routines give a uniform treatment of messages in this program. They
1767# are placed in the Carp package to cause the stack trace to not include them,
1768# although an alternative would be to use another package and set @CARP_NOT
1769# for it.
12ac2576 1770
99870f4d 1771our $Verbose = 1 if main::DEBUG; # Useful info when debugging
12ac2576 1772
99f78760
KW
1773# This is a work-around suggested by Nicholas Clark to fix a problem with Carp
1774# and overload trying to load Scalar:Util under miniperl. See
1775# http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2009-11/msg01057.html
1776undef $overload::VERSION;
1777
99870f4d
KW
1778sub my_carp {
1779 my $message = shift || "";
1780 my $nofold = shift || 0;
7ebf06b3 1781
99870f4d
KW
1782 if ($message) {
1783 $message = main::join_lines($message);
1784 $message =~ s/^$0: *//; # Remove initial program name
1785 $message =~ s/[.;,]+$//; # Remove certain ending punctuation
1786 $message = "\n$0: $message;";
12ac2576 1787
99870f4d
KW
1788 # Fold the message with program name, semi-colon end punctuation
1789 # (which looks good with the message that carp appends to it), and a
1790 # hanging indent for continuation lines.
1791 $message = main::simple_fold($message, "", 4) unless $nofold;
1792 $message =~ s/\n$//; # Remove the trailing nl so what carp
1793 # appends is to the same line
1794 }
12ac2576 1795
99870f4d 1796 return $message if defined wantarray; # If a caller just wants the msg
12ac2576 1797
99870f4d
KW
1798 carp $message;
1799 return;
1800}
7ebf06b3 1801
99870f4d
KW
1802sub my_carp_bug {
1803 # This is called when it is clear that the problem is caused by a bug in
1804 # this program.
7ebf06b3 1805
99870f4d
KW
1806 my $message = shift;
1807 $message =~ s/^$0: *//;
1808 $message = my_carp("Bug in $0. Please report it by running perlbug or if that is unavailable, by sending email to perbug\@perl.org:\n$message");
1809 carp $message;
1810 return;
1811}
7ebf06b3 1812
99870f4d
KW
1813sub carp_too_few_args {
1814 if (@_ != 2) {
1815 my_carp_bug("Wrong number of arguments: to 'carp_too_few_arguments'. No action taken.");
1816 return;
12ac2576 1817 }
7ebf06b3 1818
99870f4d
KW
1819 my $args_ref = shift;
1820 my $count = shift;
7ebf06b3 1821
99870f4d
KW
1822 my_carp_bug("Need at least $count arguments to "
1823 . (caller 1)[3]
1824 . ". Instead got: '"
1825 . join ', ', @$args_ref
1826 . "'. No action taken.");
1827 return;
12ac2576
JP
1828}
1829
99870f4d
KW
1830sub carp_extra_args {
1831 my $args_ref = shift;
1832 my_carp_bug("Too many arguments to 'carp_extra_args': (" . join(', ', @_) . "); Extras ignored.") if @_;
12ac2576 1833
99870f4d
KW
1834 unless (ref $args_ref) {
1835 my_carp_bug("Argument to 'carp_extra_args' ($args_ref) must be a ref. Not checking arguments.");
1836 return;
1837 }
1838 my ($package, $file, $line) = caller;
1839 my $subroutine = (caller 1)[3];
cf25bb62 1840
99870f4d
KW
1841 my $list;
1842 if (ref $args_ref eq 'HASH') {
1843 foreach my $key (keys %$args_ref) {
1844 $args_ref->{$key} = $UNDEF unless defined $args_ref->{$key};
cf25bb62 1845 }
99870f4d 1846 $list = join ', ', each %{$args_ref};
cf25bb62 1847 }
99870f4d
KW
1848 elsif (ref $args_ref eq 'ARRAY') {
1849 foreach my $arg (@$args_ref) {
1850 $arg = $UNDEF unless defined $arg;
1851 }
1852 $list = join ', ', @$args_ref;
1853 }
1854 else {
1855 my_carp_bug("Can't cope with ref "
1856 . ref($args_ref)
1857 . " . argument to 'carp_extra_args'. Not checking arguments.");
1858 return;
1859 }
1860
1861 my_carp_bug("Unrecognized parameters in options: '$list' to $subroutine. Skipped.");
1862 return;
d73e5302
JH
1863}
1864
99870f4d
KW
1865package main;
1866
1867{ # Closure
1868
1869 # This program uses the inside-out method for objects, as recommended in
1b6b3fa9
KW
1870 # "Perl Best Practices". (This is the best solution still, since this has
1871 # to run under miniperl.) This closure aids in generating those. There
99870f4d
KW
1872 # are two routines. setup_package() is called once per package to set
1873 # things up, and then set_access() is called for each hash representing a
1874 # field in the object. These routines arrange for the object to be
1875 # properly destroyed when no longer used, and for standard accessor
1876 # functions to be generated. If you need more complex accessors, just
1877 # write your own and leave those accesses out of the call to set_access().
1878 # More details below.
1879
1880 my %constructor_fields; # fields that are to be used in constructors; see
1881 # below
1882
1883 # The values of this hash will be the package names as keys to other
1884 # hashes containing the name of each field in the package as keys, and
1885 # references to their respective hashes as values.
1886 my %package_fields;
1887
1888 sub setup_package {
1889 # Sets up the package, creating standard DESTROY and dump methods
1890 # (unless already defined). The dump method is used in debugging by
1891 # simple_dumper().
1892 # The optional parameters are:
1893 # a) a reference to a hash, that gets populated by later
1894 # set_access() calls with one of the accesses being
1895 # 'constructor'. The caller can then refer to this, but it is
1896 # not otherwise used by these two routines.
1897 # b) a reference to a callback routine to call during destruction
1898 # of the object, before any fields are actually destroyed
1899
1900 my %args = @_;
1901 my $constructor_ref = delete $args{'Constructor_Fields'};
1902 my $destroy_callback = delete $args{'Destroy_Callback'};
1903 Carp::carp_extra_args(\@_) if main::DEBUG && %args;
1904
1905 my %fields;
1906 my $package = (caller)[0];
1907
1908 $package_fields{$package} = \%fields;
1909 $constructor_fields{$package} = $constructor_ref;
1910
1911 unless ($package->can('DESTROY')) {
1912 my $destroy_name = "${package}::DESTROY";
1913 no strict "refs";
1914
1915 # Use typeglob to give the anonymous subroutine the name we want
1916 *$destroy_name = sub {
1917 my $self = shift;
ffe43484 1918 my $addr = do { no overloading; pack 'J', $self; };
99870f4d
KW
1919
1920 $self->$destroy_callback if $destroy_callback;
1921 foreach my $field (keys %{$package_fields{$package}}) {
1922 #print STDERR __LINE__, ": Destroying ", ref $self, " ", sprintf("%04X", $addr), ": ", $field, "\n";
1923 delete $package_fields{$package}{$field}{$addr};
1924 }
1925 return;
1926 }
1927 }
1928
1929 unless ($package->can('dump')) {
1930 my $dump_name = "${package}::dump";
1931 no strict "refs";
1932 *$dump_name = sub {
1933 my $self = shift;
1934 return dump_inside_out($self, $package_fields{$package}, @_);
1935 }
1936 }
1937 return;
1938 }
1939
1940 sub set_access {
1941 # Arrange for the input field to be garbage collected when no longer
1942 # needed. Also, creates standard accessor functions for the field
1943 # based on the optional parameters-- none if none of these parameters:
1944 # 'addable' creates an 'add_NAME()' accessor function.
1945 # 'readable' or 'readable_array' creates a 'NAME()' accessor
1946 # function.
1947 # 'settable' creates a 'set_NAME()' accessor function.
1948 # 'constructor' doesn't create an accessor function, but adds the
1949 # field to the hash that was previously passed to
1950 # setup_package();
1951 # Any of the accesses can be abbreviated down, so that 'a', 'ad',
1952 # 'add' etc. all mean 'addable'.
1953 # The read accessor function will work on both array and scalar
1954 # values. If another accessor in the parameter list is 'a', the read
1955 # access assumes an array. You can also force it to be array access
1956 # by specifying 'readable_array' instead of 'readable'
1957 #
1958 # A sort-of 'protected' access can be set-up by preceding the addable,
1959 # readable or settable with some initial portion of 'protected_' (but,
1960 # the underscore is required), like 'p_a', 'pro_set', etc. The
1961 # "protection" is only by convention. All that happens is that the
1962 # accessor functions' names begin with an underscore. So instead of
1963 # calling set_foo, the call is _set_foo. (Real protection could be
c1739a4a 1964 # accomplished by having a new subroutine, end_package, called at the
99870f4d
KW
1965 # end of each package, and then storing the __LINE__ ranges and
1966 # checking them on every accessor. But that is way overkill.)
1967
1968 # We create anonymous subroutines as the accessors and then use
1969 # typeglobs to assign them to the proper package and name
1970
1971 my $name = shift; # Name of the field
1972 my $field = shift; # Reference to the inside-out hash containing the
1973 # field
1974
1975 my $package = (caller)[0];
1976
1977 if (! exists $package_fields{$package}) {
1978 croak "$0: Must call 'setup_package' before 'set_access'";
1979 }
d73e5302 1980
99870f4d
KW
1981 # Stash the field so DESTROY can get it.
1982 $package_fields{$package}{$name} = $field;
cf25bb62 1983
99870f4d
KW
1984 # Remaining arguments are the accessors. For each...
1985 foreach my $access (@_) {
1986 my $access = lc $access;
cf25bb62 1987
99870f4d 1988 my $protected = "";
cf25bb62 1989
99870f4d
KW
1990 # Match the input as far as it goes.
1991 if ($access =~ /^(p[^_]*)_/) {
1992 $protected = $1;
1993 if (substr('protected_', 0, length $protected)
1994 eq $protected)
1995 {
1996
1997 # Add 1 for the underscore not included in $protected
1998 $access = substr($access, length($protected) + 1);
1999 $protected = '_';
2000 }
2001 else {
2002 $protected = "";
2003 }
2004 }
2005
2006 if (substr('addable', 0, length $access) eq $access) {
2007 my $subname = "${package}::${protected}add_$name";
2008 no strict "refs";
2009
2010 # add_ accessor. Don't add if already there, which we
2011 # determine using 'eq' for scalars and '==' otherwise.
2012 *$subname = sub {
2013 use strict "refs";
2014 return Carp::carp_too_few_args(\@_, 2) if main::DEBUG && @_ < 2;
2015 my $self = shift;
2016 my $value = shift;
ffe43484 2017 my $addr = do { no overloading; pack 'J', $self; };
99870f4d
KW
2018 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2019 if (ref $value) {
f998e60c 2020 return if grep { $value == $_ } @{$field->{$addr}};
99870f4d
KW
2021 }
2022 else {
f998e60c 2023 return if grep { $value eq $_ } @{$field->{$addr}};
99870f4d 2024 }
f998e60c 2025 push @{$field->{$addr}}, $value;
99870f4d
KW
2026 return;
2027 }
2028 }
2029 elsif (substr('constructor', 0, length $access) eq $access) {
2030 if ($protected) {
2031 Carp::my_carp_bug("Can't set-up 'protected' constructors")
2032 }
2033 else {
2034 $constructor_fields{$package}{$name} = $field;
2035 }
2036 }
2037 elsif (substr('readable_array', 0, length $access) eq $access) {
2038
2039 # Here has read access. If one of the other parameters for
2040 # access is array, or this one specifies array (by being more
2041 # than just 'readable_'), then create a subroutine that
2042 # assumes the data is an array. Otherwise just a scalar
2043 my $subname = "${package}::${protected}$name";
2044 if (grep { /^a/i } @_
2045 or length($access) > length('readable_'))
2046 {
2047 no strict "refs";
2048 *$subname = sub {
2049 use strict "refs";
23e33b60 2050 Carp::carp_extra_args(\@_) if main::DEBUG && @_ > 1;
ffe43484 2051 my $addr = do { no overloading; pack 'J', $_[0]; };
99870f4d
KW
2052 if (ref $field->{$addr} ne 'ARRAY') {
2053 my $type = ref $field->{$addr};
2054 $type = 'scalar' unless $type;
2055 Carp::my_carp_bug("Trying to read $name as an array when it is a $type. Big problems.");
2056 return;
2057 }
2058 return scalar @{$field->{$addr}} unless wantarray;
2059
2060 # Make a copy; had problems with caller modifying the
2061 # original otherwise
2062 my @return = @{$field->{$addr}};
2063 return @return;
2064 }
2065 }
2066 else {
2067
2068 # Here not an array value, a simpler function.
2069 no strict "refs";
2070 *$subname = sub {
2071 use strict "refs";
23e33b60 2072 Carp::carp_extra_args(\@_) if main::DEBUG && @_ > 1;
f998e60c 2073 no overloading;
051df77b 2074 return $field->{pack 'J', $_[0]};
99870f4d
KW
2075 }
2076 }
2077 }
2078 elsif (substr('settable', 0, length $access) eq $access) {
2079 my $subname = "${package}::${protected}set_$name";
2080 no strict "refs";
2081 *$subname = sub {
2082 use strict "refs";
23e33b60
KW
2083 if (main::DEBUG) {
2084 return Carp::carp_too_few_args(\@_, 2) if @_ < 2;
2085 Carp::carp_extra_args(\@_) if @_ > 2;
2086 }
2087 # $self is $_[0]; $value is $_[1]
f998e60c 2088 no overloading;
051df77b 2089 $field->{pack 'J', $_[0]} = $_[1];
99870f4d
KW
2090 return;
2091 }
2092 }
2093 else {
2094 Carp::my_carp_bug("Unknown accessor type $access. No accessor set.");
2095 }
cf25bb62 2096 }
99870f4d 2097 return;
cf25bb62 2098 }
99870f4d
KW
2099}
2100
2101package Input_file;
2102
2103# All input files use this object, which stores various attributes about them,
2104# and provides for convenient, uniform handling. The run method wraps the
2105# processing. It handles all the bookkeeping of opening, reading, and closing
2106# the file, returning only significant input lines.
2107#
2108# Each object gets a handler which processes the body of the file, and is
74cd47d0
KW
2109# called by run(). All character property files must use the generic,
2110# default handler, which has code scrubbed to handle things you might not
2111# expect, including automatic EBCDIC handling. For files that don't deal with
2112# mapping code points to a property value, such as test files,
2113# PropertyAliases, PropValueAliases, and named sequences, you can override the
2114# handler to be a custom one. Such a handler should basically be a
2115# while(next_line()) {...} loop.
99870f4d
KW
2116#
2117# You can also set up handlers to
40045c2d 2118# 0) call during object construction time, after everything else is done
537124e4 2119# 1) call before the first line is read, for pre processing
83b68635
KW
2120# 2) call to adjust each line of the input before the main handler gets
2121# them. This can be automatically generated, if appropriately simple
2122# enough, by specifiying a Properties parameter in the constructor.
99870f4d 2123# 3) call upon EOF before the main handler exits its loop
537124e4 2124# 4) call at the end, for post processing
99870f4d
KW
2125#
2126# $_ is used to store the input line, and is to be filtered by the
2127# each_line_handler()s. So, if the format of the line is not in the desired
2128# format for the main handler, these are used to do that adjusting. They can
2129# be stacked (by enclosing them in an [ anonymous array ] in the constructor,
3848e5b7
KW
2130# so the $_ output of one is used as the input to the next. The eof handler
2131# is also stackable, but none of the others are, but could easily be changed
2132# to be so.
99870f4d
KW
2133#
2134# Most of the handlers can call insert_lines() or insert_adjusted_lines()
2135# which insert the parameters as lines to be processed before the next input
3848e5b7 2136# file line is read. This allows the EOF handler(s) to flush buffers, for
99870f4d
KW
2137# example. The difference between the two routines is that the lines inserted
2138# by insert_lines() are subjected to the each_line_handler()s. (So if you
9be22ca5
KW
2139# called it from such a handler, you would get infinite recursion without some
2140# mechanism to prevent that.) Lines inserted by insert_adjusted_lines() go
2141# directly to the main handler without any adjustments. If the
2142# post-processing handler calls any of these, there will be no effect. Some
2143# error checking for these conditions could be added, but it hasn't been done.
99870f4d
KW
2144#
2145# carp_bad_line() should be called to warn of bad input lines, which clears $_
2146# to prevent further processing of the line. This routine will output the
2147# message as a warning once, and then keep a count of the lines that have the
2148# same message, and output that count at the end of the file's processing.
2149# This keeps the number of messages down to a manageable amount.
2150#
2151# get_missings() should be called to retrieve any @missing input lines.
2152# Messages will be raised if this isn't done if the options aren't to ignore
2153# missings.
2154
2155sub trace { return main::trace(@_); }
2156
99870f4d
KW
2157{ # Closure
2158 # Keep track of fields that are to be put into the constructor.
2159 my %constructor_fields;
2160
2161 main::setup_package(Constructor_Fields => \%constructor_fields);
2162
2163 my %file; # Input file name, required
2164 main::set_access('file', \%file, qw{ c r });
2165
2166 my %first_released; # Unicode version file was first released in, required
2167 main::set_access('first_released', \%first_released, qw{ c r });
2168
2169 my %handler; # Subroutine to process the input file, defaults to
2170 # 'process_generic_property_file'
2171 main::set_access('handler', \%handler, qw{ c });
2172
2173 my %property;
2174 # name of property this file is for. defaults to none, meaning not
2175 # applicable, or is otherwise determinable, for example, from each line.
696609bf 2176 main::set_access('property', \%property, qw{ c r });
99870f4d
KW
2177
2178 my %optional;
2179 # If this is true, the file is optional. If not present, no warning is
2180 # output. If it is present, the string given by this parameter is
2181 # evaluated, and if false the file is not processed.
2182 main::set_access('optional', \%optional, 'c', 'r');
2183
2184 my %non_skip;
2185 # This is used for debugging, to skip processing of all but a few input
2186 # files. Add 'non_skip => 1' to the constructor for those files you want
2187 # processed when you set the $debug_skip global.
2188 main::set_access('non_skip', \%non_skip, 'c');
2189
37e2e78e 2190 my %skip;
0dee21d6
KW
2191 # This is used to skip processing of this input file (semi-) permanently.
2192 # The value should be the reason the file is being skipped. It is used
2193 # for files that we aren't planning to process anytime soon, but want to
2194 # allow to be in the directory and be checked for their names not
2195 # conflicting with any other files on a DOS 8.3 name filesystem, but to
2196 # not otherwise be processed, and to not raise a warning about not being
2197 # handled. In the constructor call, any value that evaluates to a numeric
2198 # 0 or undef means don't skip. Any other value is a string giving the
2199 # reason it is being skippped, and this will appear in generated pod.
2200 # However, an empty string reason will suppress the pod entry.
2201 # Internally, calls that evaluate to numeric 0 are changed into undef to
2202 # distinguish them from an empty string call.
2203 main::set_access('skip', \%skip, 'c', 'r');
37e2e78e 2204
99870f4d
KW
2205 my %each_line_handler;
2206 # list of subroutines to look at and filter each non-comment line in the
2207 # file. defaults to none. The subroutines are called in order, each is
2208 # to adjust $_ for the next one, and the final one adjusts it for
2209 # 'handler'
2210 main::set_access('each_line_handler', \%each_line_handler, 'c');
2211
83b68635
KW
2212 my %properties; # Optional ordered list of the properties that occur in each
2213 # meaningful line of the input file. If present, an appropriate
2214 # each_line_handler() is automatically generated and pushed onto the stack
2215 # of such handlers. This is useful when a file contains multiple
2216 # proerties per line, but no other special considerations are necessary.
2217 # The special value "<ignored>" means to discard the corresponding input
2218 # field.
2219 # Any @missing lines in the file should also match this syntax; no such
2220 # files exist as of 6.3. But if it happens in a future release, the code
2221 # could be expanded to properly parse them.
2222 main::set_access('properties', \%properties, qw{ c r });
2223
99870f4d
KW
2224 my %has_missings_defaults;
2225 # ? Are there lines in the file giving default values for code points
2226 # missing from it?. Defaults to NO_DEFAULTS. Otherwise NOT_IGNORED is
2227 # the norm, but IGNORED means it has such lines, but the handler doesn't
2228 # use them. Having these three states allows us to catch changes to the
83b68635
KW
2229 # UCD that this program should track. XXX This could be expanded to
2230 # specify the syntax for such lines, like %properties above.
99870f4d
KW
2231 main::set_access('has_missings_defaults',
2232 \%has_missings_defaults, qw{ c r });
2233
40045c2d
KW
2234 my %construction_time_handler;
2235 # Subroutine to call at the end of the new method. If undef, no such
2236 # handler is called.
2237 main::set_access('construction_time_handler',
2238 \%construction_time_handler, qw{ c });
2239
99870f4d
KW
2240 my %pre_handler;
2241 # Subroutine to call before doing anything else in the file. If undef, no
2242 # such handler is called.
2243 main::set_access('pre_handler', \%pre_handler, qw{ c });
2244
2245 my %eof_handler;
3848e5b7 2246 # Subroutines to call upon getting an EOF on the input file, but before
99870f4d
KW
2247 # that is returned to the main handler. This is to allow buffers to be
2248 # flushed. The handler is expected to call insert_lines() or
2249 # insert_adjusted() with the buffered material
3848e5b7 2250 main::set_access('eof_handler', \%eof_handler, qw{ c });
99870f4d
KW
2251
2252 my %post_handler;
2253 # Subroutine to call after all the lines of the file are read in and
9be22ca5
KW
2254 # processed. If undef, no such handler is called. Note that this cannot
2255 # add lines to be processed; instead use eof_handler
99870f4d
KW
2256 main::set_access('post_handler', \%post_handler, qw{ c });
2257
2258 my %progress_message;
2259 # Message to print to display progress in lieu of the standard one
2260 main::set_access('progress_message', \%progress_message, qw{ c });
2261
2262 my %handle;
2263 # cache open file handle, internal. Is undef if file hasn't been
2264 # processed at all, empty if has;
2265 main::set_access('handle', \%handle);
2266
2267 my %added_lines;
2268 # cache of lines added virtually to the file, internal
2269 main::set_access('added_lines', \%added_lines);
2270
74cd47d0
KW
2271 my %remapped_lines;
2272 # cache of lines added virtually to the file, internal
2273 main::set_access('remapped_lines', \%remapped_lines);
2274
99870f4d
KW
2275 my %errors;
2276 # cache of errors found, internal
2277 main::set_access('errors', \%errors);
2278
2279 my %missings;
2280 # storage of '@missing' defaults lines
2281 main::set_access('missings', \%missings);
2282
0dee21d6
KW
2283 my %required_even_in_debug_skip;
2284 # debug_skip is used to speed up compilation during debugging by skipping
2285 # processing files that are not needed for the task at hand. However,
2286 # some files pretty much can never be skipped, and this is used to specify
2287 # that this is one of them. In order to skip this file, the call to the
2288 # constructor must be edited to comment out this parameter.
2289 main::set_access('required_even_in_debug_skip',
2290 \%required_even_in_debug_skip, 'c');
2291
d8062573
KW
2292 my %withdrawn;
2293 # Some files get removed from the Unicode DB. This is a version object
2294 # giving the first release without this file.
2295 main::set_access('withdrawn', \%withdrawn, 'c');
2296
0dee21d6
KW
2297 my %in_this_release;
2298 # Calculated value from %first_released and %withdrawn. Are we compiling
2299 # a Unicode release which includes this file?
2300 main::set_access('in_this_release', \%in_this_release);
2301
74cd47d0
KW
2302 sub _next_line;
2303 sub _next_line_with_remapped_range;
2304
99870f4d
KW
2305 sub new {
2306 my $class = shift;
2307
2308 my $self = bless \do{ my $anonymous_scalar }, $class;
ffe43484 2309 my $addr = do { no overloading; pack 'J', $self; };
99870f4d
KW
2310
2311 # Set defaults
2312 $handler{$addr} = \&main::process_generic_property_file;
2313 $non_skip{$addr} = 0;
0dee21d6 2314 $skip{$addr} = undef;
99870f4d
KW
2315 $has_missings_defaults{$addr} = $NO_DEFAULTS;
2316 $handle{$addr} = undef;
2317 $added_lines{$addr} = [ ];
74cd47d0 2318 $remapped_lines{$addr} = [ ];
99870f4d 2319 $each_line_handler{$addr} = [ ];
3848e5b7 2320 $eof_handler{$addr} = [ ];
99870f4d
KW
2321 $errors{$addr} = { };
2322 $missings{$addr} = [ ];
2323
2324 # Two positional parameters.
99f78760 2325 return Carp::carp_too_few_args(\@_, 2) if main::DEBUG && @_ < 2;
99870f4d
KW
2326 $file{$addr} = main::internal_file_to_platform(shift);
2327 $first_released{$addr} = shift;
2328
2329 # The rest of the arguments are key => value pairs
2330 # %constructor_fields has been set up earlier to list all possible
2331 # ones. Either set or push, depending on how the default has been set
2332 # up just above.
2333 my %args = @_;
2334 foreach my $key (keys %args) {
2335 my $argument = $args{$key};
2336
2337 # Note that the fields are the lower case of the constructor keys
2338 my $hash = $constructor_fields{lc $key};
2339 if (! defined $hash) {
2340 Carp::my_carp_bug("Unrecognized parameters '$key => $argument' to new() for $self. Skipped");
2341 next;
2342 }
2343 if (ref $hash->{$addr} eq 'ARRAY') {
2344 if (ref $argument eq 'ARRAY') {
2345 foreach my $argument (@{$argument}) {
2346 next if ! defined $argument;
2347 push @{$hash->{$addr}}, $argument;
2348 }
2349 }
2350 else {
2351 push @{$hash->{$addr}}, $argument if defined $argument;
2352 }
2353 }
2354 else {
2355 $hash->{$addr} = $argument;
2356 }
2357 delete $args{$key};
2358 };
2359
0dee21d6
KW
2360 $non_skip{$addr} = 1 if $required_even_in_debug_skip{$addr};
2361
2362 # Convert 0 (meaning don't skip) to undef
2363 undef $skip{$addr} unless $skip{$addr};
2364
2365 my $progress;
2366
2367 if ($first_released{$addr} le $v_version) {
2368 $progress = $file{$addr};
99870f4d
KW
2369 }
2370
0dee21d6
KW
2371 my $file = $file{$addr};
2372 $progress_message{$addr} = "Processing $progress"
2373 unless $progress_message{$addr};
2374
d8062573
KW
2375 # A file should be there if it is within the window of versions for
2376 # which Unicode supplies it
2377 if ($withdrawn{$addr} && $withdrawn{$addr} le $v_version) {
2378 $in_this_release{$addr} = 0;
2379 $skip{$addr} = "";
2380 }
2381 else {
0dee21d6
KW
2382 $in_this_release{$addr} = $first_released{$addr} le $v_version;
2383
2384 # Check that the file for this object exists
2385 if (! main::file_exists($file))
2386 {
2387 # Here there is nothing available for this release. This is
2388 # fine if we aren't expecting anything in this release.
2389 if (! $in_this_release{$addr}) {
2390 $skip{$addr} = ""; # Don't remark since we expected
2391 # nothing and got nothing
2392 }
2393 elsif ($optional{$addr}) {
2394
2395 # Here the file is optional in this release.
2396 $skip{$addr} = "";
2397 }
2398 elsif ( $in_this_release{$addr}
2399 && ! defined $skip{$addr}
2400 && defined $file)
2401 { # Doesn't exist but should.
2402 $skip{$addr} = "'$file' not found. Possibly Big problems";
2403 Carp::my_carp($skip{$addr});
2404 }
2405 }
2406 elsif ($debug_skip && ! defined $skip{$addr} && ! $non_skip{$addr})
2407 {
2408
2409 # The file exists; if not skipped for another reason, and we are
2410 # skipping most everything during debugging builds, use that as
2411 # the skip reason.
2412 $skip{$addr} = '$debug_skip is on'
2413 }
d8062573 2414 }
0dee21d6
KW
2415
2416 if ( ! $debug_skip
2417 && $non_skip{$addr}
2418 && ! $required_even_in_debug_skip{$addr}
2419 && $verbosity)
2420 {
2421 print "Warning: " . __PACKAGE__ . " constructor for $file has useless 'non_skip' in it\n";
a3a8c5f0 2422 }
99870f4d 2423
0dee21d6
KW
2424 # Here, we have figured out if we will be skipping this file or not.
2425 if (defined $skip{$addr}) {
2426 }
2427 elsif ($property{$addr}) {
2428
2429 # If the file has a property defined in the constructor for it, it
2430 # means that the property is not listed in the file's entries. So
2431 # add a handler (to the list of line handlers) to insert the
2432 # property name into the lines, to provide a uniform interface to
2433 # the final processing subroutine.
2434 push @{$each_line_handler{$addr}}, \&_insert_property_into_line;
09ca89ce 2435 }
83b68635
KW
2436 elsif ($properties{$addr}) {
2437
9be22ca5
KW
2438 # Similarly, there may be more than one property represented on
2439 # each line, with no clue but the constructor input what those
2440 # might be. Add a handler for each line in the input so that it
2441 # creates a separate input line for each property in those input
2442 # lines, thus making them suitable to handle generically.
83b68635
KW
2443
2444 push @{$each_line_handler{$addr}},
2445 sub {
2446 my $file = shift;
2447 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2448
2449 my @fields = split /\s*;\s*/, $_, -1;
2450
2451 if (@fields - 1 > @{$properties{$addr}}) {
2452 $file->carp_bad_line('Extra fields');
2453 $_ = "";
2454 return;
2455 }
2456 my $range = shift @fields; # 0th element is always the
2457 # range
2458
2459 # The next fields in the input line correspond
2460 # respectively to the stored properties.
2461 for my $i (0 .. @{$properties{$addr}} - 1) {
2462 my $property_name = $properties{$addr}[$i];
2463 next if $property_name eq '<ignored>';
2464 $file->insert_adjusted_lines(
2465 "$range; $property_name; $fields[$i]");
2466 }
2467 $_ = "";
2468
2469 return;
2470 };
2471 }
37e2e78e 2472
9be22ca5 2473 { # On non-ascii platforms, we use a special pre-handler
74cd47d0
KW
2474 no strict;
2475 no warnings 'once';
2476 *next_line = (main::NON_ASCII_PLATFORM)
2477 ? *_next_line_with_remapped_range
2478 : *_next_line;
2479 }
2480
40045c2d
KW
2481 &{$construction_time_handler{$addr}}($self)
2482 if $construction_time_handler{$addr};
2483
99870f4d 2484 return $self;
d73e5302
JH
2485 }
2486
cf25bb62 2487
99870f4d
KW
2488 use overload
2489 fallback => 0,
2490 qw("") => "_operator_stringify",
2491 "." => \&main::_operator_dot,
1285127e 2492 ".=" => \&main::_operator_dot_equal,
99870f4d 2493 ;
cf25bb62 2494
99870f4d
KW
2495 sub _operator_stringify {
2496 my $self = shift;
cf25bb62 2497
99870f4d 2498 return __PACKAGE__ . " object for " . $self->file;
d73e5302 2499 }
d73e5302 2500
99870f4d
KW
2501 sub run {
2502 # Process the input object $self. This opens and closes the file and
2503 # calls all the handlers for it. Currently, this can only be called
3848e5b7 2504 # once per file, as it destroy's the EOF handlers
d73e5302 2505
0dee21d6
KW
2506 # flag to make sure extracted files are processed early
2507 state $seen_non_extracted_non_age = 0;
2508
99870f4d
KW
2509 my $self = shift;
2510 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
b6922eda 2511
ffe43484 2512 my $addr = do { no overloading; pack 'J', $self; };
b6922eda 2513
99870f4d 2514 my $file = $file{$addr};
d73e5302 2515
0dee21d6
KW
2516 if (! $file) {
2517 $handle{$addr} = 'pretend_is_open';
99870f4d
KW
2518 }
2519 else {
99870f4d 2520 if ($seen_non_extracted_non_age) {
9be22ca5
KW
2521 if ($file =~ /$EXTRACTED/i) # Some platforms may change the
2522 # case of the file's name
2523 {
1675ea0d 2524 Carp::my_carp_bug(main::join_lines(<<END
99f78760 2525$file should be processed just after the 'Prop...Alias' files, and before
99870f4d
KW
2526anything not in the $EXTRACTED_DIR directory. Proceeding, but the results may
2527have subtle problems
2528END
2529 ));
2530 }
2531 }
2532 elsif ($EXTRACTED_DIR
0dee21d6
KW
2533
2534 # We only do this check for generic property files
2535 && $handler{$addr} == \&main::process_generic_property_file
2536
517956bf
CB
2537 && $file !~ /$EXTRACTED/i
2538 && lc($file) ne 'dage.txt')
99870f4d
KW
2539 {
2540 # We don't set this (by the 'if' above) if we have no
2541 # extracted directory, so if running on an early version,
2542 # this test won't work. Not worth worrying about.
2543 $seen_non_extracted_non_age = 1;
2544 }
2545
9be22ca5 2546 # Mark the file as having being processed, and warn if it
99870f4d
KW
2547 # isn't a file we are expecting. As we process the files,
2548 # they are deleted from the hash, so any that remain at the
2549 # end of the program are files that we didn't process.
517956bf 2550 my $fkey = File::Spec->rel2abs($file);
0dee21d6 2551 my $exists = delete $potential_files{lc($fkey)};
faf3cf6b 2552
0dee21d6
KW
2553 Carp::my_carp("Was not expecting '$file'.")
2554 if $exists && ! $in_this_release{$addr};
2555
2556 # We may be skipping this file ...
2557 if (defined $skip{$addr}) {
2558
2559 # If the file isn't supposed to be in this release, there is
2560 # nothing to do
2561 if ($in_this_release{$addr}) {
2562
2563 # But otherwise, we may print a message
2564 if ($debug_skip) {
2565 print STDERR "Skipping input file '$file'",
2566 " because '$skip{$addr}'\n";
2567 }
2568
2569 # And add it to the list of skipped files, which is later
2570 # used to make the pod
2571 $skipped_files{$file} = $skip{$addr};
2572 }
99870f4d 2573
37e2e78e
KW
2574 return;
2575 }
2576
9be22ca5
KW
2577 # Here, we are going to process the file. Open it, converting the
2578 # slashes used in this program into the proper form for the OS
99870f4d
KW
2579 my $file_handle;
2580 if (not open $file_handle, "<", $file) {
2581 Carp::my_carp("Can't open $file. Skipping: $!");
d3664eb9 2582 return;
99870f4d
KW
2583 }
2584 $handle{$addr} = $file_handle; # Cache the open file handle
9e65c3f4 2585
0dee21d6
KW
2586 # If possible, make sure that the file is the correct version.
2587 # (This data isn't available on early Unicode releases or in
2588 # UnicodeData.txt.) We don't do this check if we are using a
2589 # substitute file instead of the official one (though the code
2590 # could be extended to do so).
2591 if ($in_this_release{$addr}
2592 && lc($file) ne 'unicodedata.txt')
2593 {
96f226dc 2594 if ($file !~ /^Unihan/i) {
0dee21d6
KW
2595
2596 # The non-Unihan files started getting version numbers in
2597 # 3.2, but some files in 4.0 are unchanged from 3.2, and
2598 # marked as 3.2. 4.0.1 is the first version where there
2599 # are no files marked as being from less than 4.0, though
2600 # some are marked as 4.0. In versions after that, the
2601 # numbers are correct.
2602 if ($v_version ge v4.0.1) {
2603 $_ = <$file_handle>; # The version number is in the
2604 # very first line
2605 if ($_ !~ / - $string_version \. /x) {
2606 chomp;
2607 $_ =~ s/^#\s*//;
2608
2609 # 4.0.1 had some valid files that weren't updated.
2610 if (! ($v_version eq v4.0.1 && $_ =~ /4\.0\.0/)) {
2611 die Carp::my_carp("File '$file' is version "
2612 . "'$_'. It should be "
2613 . "version $string_version");
2614 }
2615 }
cafe9cf0 2616 }
96f226dc 2617 }
0dee21d6
KW
2618 elsif ($v_version ge v6.0.0) { # Unihan
2619
2620 # Unihan files didn't get accurate version numbers until
2621 # 6.0. The version is somewhere in the first comment
2622 # block
96f226dc
KW
2623 while (<$file_handle>) {
2624 if ($_ !~ /^#/) {
0dee21d6
KW
2625 Carp::my_carp_bug("Could not find the expected "
2626 . "version info in file '$file'");
96f226dc
KW
2627 last;
2628 }
2629 chomp;
2630 $_ =~ s/^#\s*//;
2631 next if $_ !~ / version: /x;
2632 last if $_ =~ /$string_version/;
0dee21d6
KW
2633 die Carp::my_carp("File '$file' is version "
2634 . "'$_'. It should be "
2635 . "version $string_version");
96f226dc
KW
2636 }
2637 }
9e65c3f4 2638 }
99870f4d
KW
2639 }
2640
0dee21d6 2641 print "$progress_message{$addr}\n" if $verbosity >= $PROGRESS;
99870f4d
KW
2642
2643 # Call any special handler for before the file.
2644 &{$pre_handler{$addr}}($self) if $pre_handler{$addr};
2645
2646 # Then the main handler
2647 &{$handler{$addr}}($self);
2648
2649 # Then any special post-file handler.
2650 &{$post_handler{$addr}}($self) if $post_handler{$addr};
2651
2652 # If any errors have been accumulated, output the counts (as the first
2653 # error message in each class was output when it was encountered).
2654 if ($errors{$addr}) {
2655 my $total = 0;
2656 my $types = 0;
2657 foreach my $error (keys %{$errors{$addr}}) {
2658 $total += $errors{$addr}->{$error};
2659 delete $errors{$addr}->{$error};
2660 $types++;
2661 }
2662 if ($total > 1) {
2663 my $message
2664 = "A total of $total lines had errors in $file. ";
2665
2666 $message .= ($types == 1)
2667 ? '(Only the first one was displayed.)'
2668 : '(Only the first of each type was displayed.)';
2669 Carp::my_carp($message);
2670 }
2671 }
2672
2673 if (@{$missings{$addr}}) {
2674 Carp::my_carp_bug("Handler for $file didn't look at all the \@missing lines. Generated tables likely are wrong");
2675 }
2676
2677 # If a real file handle, close it.
2678 close $handle{$addr} or Carp::my_carp("Can't close $file: $!") if
2679 ref $handle{$addr};
2680 $handle{$addr} = ""; # Uses empty to indicate that has already seen
2681 # the file, as opposed to undef
2682 return;
2683 }
2684
74cd47d0 2685 sub _next_line {
99870f4d
KW
2686 # Sets $_ to be the next logical input line, if any. Returns non-zero
2687 # if such a line exists. 'logical' means that any lines that have
2688 # been added via insert_lines() will be returned in $_ before the file
2689 # is read again.
2690
2691 my $self = shift;
2692 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2693
ffe43484 2694 my $addr = do { no overloading; pack 'J', $self; };
99870f4d
KW
2695
2696 # Here the file is open (or if the handle is not a ref, is an open
2697 # 'virtual' file). Get the next line; any inserted lines get priority
2698 # over the file itself.
2699 my $adjusted;
2700
2701 LINE:
2702 while (1) { # Loop until find non-comment, non-empty line
2703 #local $to_trace = 1 if main::DEBUG;
2704 my $inserted_ref = shift @{$added_lines{$addr}};
2705 if (defined $inserted_ref) {
2706 ($adjusted, $_) = @{$inserted_ref};
2707 trace $adjusted, $_ if main::DEBUG && $to_trace;
2708 return 1 if $adjusted;
2709 }
2710 else {
2711 last if ! ref $handle{$addr}; # Don't read unless is real file
2712 last if ! defined ($_ = readline $handle{$addr});
2713 }
2714 chomp;
2715 trace $_ if main::DEBUG && $to_trace;
2716
2717 # See if this line is the comment line that defines what property
2718 # value that code points that are not listed in the file should
2719 # have. The format or existence of these lines is not guaranteed
2720 # by Unicode since they are comments, but the documentation says
2721 # that this was added for machine-readability, so probably won't
2722 # change. This works starting in Unicode Version 5.0. They look
2723 # like:
2724 #
2725 # @missing: 0000..10FFFF; Not_Reordered
2726 # @missing: 0000..10FFFF; Decomposition_Mapping; <code point>
2727 # @missing: 0000..10FFFF; ; NaN
2728 #
2729 # Save the line for a later get_missings() call.
2730 if (/$missing_defaults_prefix/) {
2731 if ($has_missings_defaults{$addr} == $NO_DEFAULTS) {
2732 $self->carp_bad_line("Unexpected \@missing line. Assuming no missing entries");
2733 }
2734 elsif ($has_missings_defaults{$addr} == $NOT_IGNORED) {
2735 my @defaults = split /\s* ; \s*/x, $_;
2736
2737 # The first field is the @missing, which ends in a
2738 # semi-colon, so can safely shift.
2739 shift @defaults;
2740
2741 # Some of these lines may have empty field placeholders
2742 # which get in the way. An example is:
2743 # @missing: 0000..10FFFF; ; NaN
2744 # Remove them. Process starting from the top so the
2745 # splice doesn't affect things still to be looked at.
2746 for (my $i = @defaults - 1; $i >= 0; $i--) {
2747 next if $defaults[$i] ne "";
2748 splice @defaults, $i, 1;
2749 }
2750
2751 # What's left should be just the property (maybe) and the
2752 # default. Having only one element means it doesn't have
2753 # the property.
2754 my $default;
2755 my $property;
2756 if (@defaults >= 1) {
2757 if (@defaults == 1) {
2758 $default = $defaults[0];
2759 }
2760 else {
2761 $property = $defaults[0];
2762 $default = $defaults[1];
2763 }
2764 }
2765
2766 if (@defaults < 1
2767 || @defaults > 2
2768 || ($default =~ /^</
2769 && $default !~ /^<code *point>$/i
09f8d0ac
KW
2770 && $default !~ /^<none>$/i
2771 && $default !~ /^<script>$/i))
99870f4d
KW
2772 {
2773 $self->carp_bad_line("Unrecognized \@missing line: $_. Assuming no missing entries");
2774 }
2775 else {
2776
2777 # If the property is missing from the line, it should
2778 # be the one for the whole file
2779 $property = $property{$addr} if ! defined $property;
2780
2781 # Change <none> to the null string, which is what it
2782 # really means. If the default is the code point
2783 # itself, set it to <code point>, which is what
2784 # Unicode uses (but sometimes they've forgotten the
2785 # space)
2786 if ($default =~ /^<none>$/i) {
2787 $default = "";
2788 }
2789 elsif ($default =~ /^<code *point>$/i) {
2790 $default = $CODE_POINT;
2791 }
09f8d0ac
KW
2792 elsif ($default =~ /^<script>$/i) {
2793
2794 # Special case this one. Currently is from
2795 # ScriptExtensions.txt, and means for all unlisted
2796 # code points, use their Script property values.
2797 # For the code points not listed in that file, the
2798 # default value is 'Unknown'.
2799 $default = "Unknown";
2800 }
99870f4d
KW
2801
2802 # Store them as a sub-arrays with both components.
2803 push @{$missings{$addr}}, [ $default, $property ];
2804 }
2805 }
2806
2807 # There is nothing for the caller to process on this comment
2808 # line.
2809 next;
2810 }
2811
2812 # Remove comments and trailing space, and skip this line if the
2813 # result is empty
2814 s/#.*//;
2815 s/\s+$//;
2816 next if /^$/;
2817
2818 # Call any handlers for this line, and skip further processing of
2819 # the line if the handler sets the line to null.
2820 foreach my $sub_ref (@{$each_line_handler{$addr}}) {
2821 &{$sub_ref}($self);
2822 next LINE if /^$/;
2823 }
2824
2825 # Here the line is ok. return success.
2826 return 1;
2827 } # End of looping through lines.
2828
3848e5b7 2829 # If there are EOF handlers, call each (only once) and if it generates
99870f4d 2830 # more lines to process go back in the loop to handle them.
3848e5b7
KW
2831 while ($eof_handler{$addr}->@*) {
2832 &{$eof_handler{$addr}[0]}($self);
2833 shift $eof_handler{$addr}->@*; # Currently only get one shot at it.
99870f4d
KW
2834 goto LINE if $added_lines{$addr};
2835 }
2836
2837 # Return failure -- no more lines.
2838 return 0;
2839
2840 }
2841
74cd47d0
KW
2842 sub _next_line_with_remapped_range {
2843 my $self = shift;
2844 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2845
2846 # like _next_line(), but for use on non-ASCII platforms. It sets $_
2847 # to be the next logical input line, if any. Returns non-zero if such
2848 # a line exists. 'logical' means that any lines that have been added
2849 # via insert_lines() will be returned in $_ before the file is read
2850 # again.
2851 #
2852 # The difference from _next_line() is that this remaps the Unicode
2853 # code points in the input to those of the native platform. Each
2854 # input line contains a single code point, or a single contiguous
2855 # range of them This routine splits each range into its individual
2856 # code points and caches them. It returns the cached values,
2857 # translated into their native equivalents, one at a time, for each
2858 # call, before reading the next line. Since native values can only be
2859 # a single byte wide, no translation is needed for code points above
2860 # 0xFF, and ranges that are entirely above that number are not split.
2861 # If an input line contains the range 254-1000, it would be split into
2862 # three elements: 254, 255, and 256-1000. (The downstream table
2863 # insertion code will sort and coalesce the individual code points
2864 # into appropriate ranges.)
2865
2866 my $addr = do { no overloading; pack 'J', $self; };
2867
2868 while (1) {
2869
2870 # Look in cache before reading the next line. Return any cached
2871 # value, translated
2872 my $inserted = shift @{$remapped_lines{$addr}};
2873 if (defined $inserted) {
2874 trace $inserted if main::DEBUG && $to_trace;
2875 $_ = $inserted =~ s/^ ( \d+ ) /sprintf("%04X", utf8::unicode_to_native($1))/xer;
2876 trace $_ if main::DEBUG && $to_trace;
2877 return 1;
2878 }
2879
2880 # Get the next line.
2881 return 0 unless _next_line($self);
2882
2883 # If there is a special handler for it, return the line,
2884 # untranslated. This should happen only for files that are
2885 # special, not being code-point related, such as property names.
2886 return 1 if $handler{$addr}
2887 != \&main::process_generic_property_file;
2888
2889 my ($range, $property_name, $map, @remainder)
2890 = split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields
2891
2892 if (@remainder
2893 || ! defined $property_name
2894 || $range !~ /^ ($code_point_re) (?:\.\. ($code_point_re) )? $/x)
2895 {
2896 Carp::my_carp_bug("Unrecognized input line '$_'. Ignored");
2897 }
2898
2899 my $low = hex $1;
2900 my $high = (defined $2) ? hex $2 : $low;
2901
2902 # If the input maps the range to another code point, remap the
2903 # target if it is between 0 and 255.
2904 my $tail;
2905 if (defined $map) {
2906 $map =~ s/\b 00 ( [0-9A-F]{2} ) \b/sprintf("%04X", utf8::unicode_to_native(hex $1))/gxe;
2907 $tail = "$property_name; $map";
2908 $_ = "$range; $tail";
2909 }
2910 else {
2911 $tail = $property_name;
2912 }
2913
2914 # If entire range is above 255, just return it, unchanged (except
2915 # any mapped-to code point, already changed above)
2916 return 1 if $low > 255;
2917
2918 # Cache an entry for every code point < 255. For those in the
2919 # range above 255, return a dummy entry for just that portion of
2920 # the range. Note that this will be out-of-order, but that is not
2921 # a problem.
2922 foreach my $code_point ($low .. $high) {
2923 if ($code_point > 255) {
2924 $_ = sprintf "%04X..%04X; $tail", $code_point, $high;
2925 return 1;
2926 }
2927 push @{$remapped_lines{$addr}}, "$code_point; $tail";
2928 }
2929 } # End of looping through lines.
2930
2931 # NOTREACHED
2932 }
2933
99870f4d
KW
2934# Not currently used, not fully tested.
2935# sub peek {
2936# # Non-destructive look-ahead one non-adjusted, non-comment, non-blank
2937# # record. Not callable from an each_line_handler(), nor does it call
2938# # an each_line_handler() on the line.
2939#
2940# my $self = shift;
ffe43484 2941# my $addr = do { no overloading; pack 'J', $self; };
99870f4d
KW
2942#
2943# foreach my $inserted_ref (@{$added_lines{$addr}}) {
2944# my ($adjusted, $line) = @{$inserted_ref};
2945# next if $adjusted;
2946#
2947# # Remove comments and trailing space, and return a non-empty
2948# # resulting line
2949# $line =~ s/#.*//;
2950# $line =~ s/\s+$//;
2951# return $line if $line ne "";
2952# }
2953#
2954# return if ! ref $handle{$addr}; # Don't read unless is real file
2955# while (1) { # Loop until find non-comment, non-empty line
2956# local $to_trace = 1 if main::DEBUG;
2957# trace $_ if main::DEBUG && $to_trace;
2958# return if ! defined (my $line = readline $handle{$addr});
2959# chomp $line;
2960# push @{$added_lines{$addr}}, [ 0, $line ];
2961#
2962# $line =~ s/#.*//;
2963# $line =~ s/\s+$//;
2964# return $line if $line ne "";
2965# }
2966#
2967# return;
2968# }
2969
2970
2971 sub insert_lines {
2972 # Lines can be inserted so that it looks like they were in the input
2973 # file at the place it was when this routine is called. See also
2974 # insert_adjusted_lines(). Lines inserted via this routine go through
2975 # any each_line_handler()
2976
2977 my $self = shift;
2978
2979 # Each inserted line is an array, with the first element being 0 to
2980 # indicate that this line hasn't been adjusted, and needs to be
2981 # processed.
f998e60c 2982 no overloading;
051df77b 2983 push @{$added_lines{pack 'J', $self}}, map { [ 0, $_ ] } @_;
99870f4d
KW
2984 return;
2985 }
2986
2987 sub insert_adjusted_lines {
2988 # Lines can be inserted so that it looks like they were in the input
2989 # file at the place it was when this routine is called. See also
2990 # insert_lines(). Lines inserted via this routine are already fully
2991 # adjusted, ready to be processed; each_line_handler()s handlers will
2992 # not be called. This means this is not a completely general
2993 # facility, as only the last each_line_handler on the stack should
2994 # call this. It could be made more general, by passing to each of the
2995 # line_handlers their position on the stack, which they would pass on
2996 # to this routine, and that would replace the boolean first element in
2997 # the anonymous array pushed here, so that the next_line routine could
2998 # use that to call only those handlers whose index is after it on the
2999 # stack. But this is overkill for what is needed now.
3000
3001 my $self = shift;
3002 trace $_[0] if main::DEBUG && $to_trace;
3003
3004 # Each inserted line is an array, with the first element being 1 to
3005 # indicate that this line has been adjusted
f998e60c 3006 no overloading;
051df77b 3007 push @{$added_lines{pack 'J', $self}}, map { [ 1, $_ ] } @_;
99870f4d
KW
3008 return;
3009 }
3010
3011 sub get_missings {
3012 # Returns the stored up @missings lines' values, and clears the list.
3013 # The values are in an array, consisting of the default in the first
3014 # element, and the property in the 2nd. However, since these lines
3015 # can be stacked up, the return is an array of all these arrays.
3016
3017 my $self = shift;
3018 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3019
ffe43484 3020 my $addr = do { no overloading; pack 'J', $self; };
99870f4d
KW
3021
3022 # If not accepting a list return, just return the first one.
3023 return shift @{$missings{$addr}} unless wantarray;
3024
3025 my @return = @{$missings{$addr}};
3026 undef @{$missings{$addr}};
3027 return @return;
3028 }
3029
3030 sub _insert_property_into_line {
3031 # Add a property field to $_, if this file requires it.
3032
f998e60c 3033 my $self = shift;
ffe43484 3034 my $addr = do { no overloading; pack 'J', $self; };
f998e60c 3035 my $property = $property{$addr};
99870f4d
KW
3036 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3037
3038 $_ =~ s/(;|$)/; $property$1/;
3039 return;
3040 }
3041
3042 sub carp_bad_line {
3043 # Output consistent error messages, using either a generic one, or the
3044 # one given by the optional parameter. To avoid gazillions of the
3045 # same message in case the syntax of a file is way off, this routine
3046 # only outputs the first instance of each message, incrementing a
3047 # count so the totals can be output at the end of the file.
3048
3049 my $self = shift;
3050 my $message = shift;
3051 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3052
ffe43484 3053 my $addr = do { no overloading; pack 'J', $self; };
99870f4d
KW
3054
3055 $message = 'Unexpected line' unless $message;
3056
3057 # No trailing punctuation so as to fit with our addenda.
3058 $message =~ s/[.:;,]$//;
3059
3060 # If haven't seen this exact message before, output it now. Otherwise
3061 # increment the count of how many times it has occurred
3062 unless ($errors{$addr}->{$message}) {
3063 Carp::my_carp("$message in '$_' in "
f998e60c 3064 . $file{$addr}
99870f4d
KW
3065 . " at line $.. Skipping this line;");
3066 $errors{$addr}->{$message} = 1;
3067 }
3068 else {
3069 $errors{$addr}->{$message}++;
3070 }
3071
3072 # Clear the line to prevent any further (meaningful) processing of it.
3073 $_ = "";
3074
3075 return;
3076 }
3077} # End closure
3078
3079package Multi_Default;
3080
3081# Certain properties in early versions of Unicode had more than one possible
3082# default for code points missing from the files. In these cases, one
3083# default applies to everything left over after all the others are applied,
3084# and for each of the others, there is a description of which class of code
3085# points applies to it. This object helps implement this by storing the
3086# defaults, and for all but that final default, an eval string that generates
3087# the class that it applies to.
3088
3089
3090{ # Closure
3091
3092 main::setup_package();
3093
3094 my %class_defaults;
3095 # The defaults structure for the classes
3096 main::set_access('class_defaults', \%class_defaults);
3097
3098 my %other_default;
3099 # The default that applies to everything left over.
3100 main::set_access('other_default', \%other_default, 'r');
3101
3102
3103 sub new {
3104 # The constructor is called with default => eval pairs, terminated by
3105 # the left-over default. e.g.
3106 # Multi_Default->new(
3107 # 'T' => '$gc->table("Mn") + $gc->table("Cf") - 0x200C
3108 # - 0x200D',
3109 # 'R' => 'some other expression that evaluates to code points',
3110 # .
3111 # .
3112 # .
3113 # 'U'));
3114
3115 my $class = shift;
3116
3117 my $self = bless \do{my $anonymous_scalar}, $class;
ffe43484 3118 my $addr = do { no overloading; pack 'J', $self; };
99870f4d
KW
3119
3120 while (@_ > 1) {
3121 my $default = shift;
3122 my $eval = shift;
3123 $class_defaults{$addr}->{$default} = $eval;
3124 }
3125
3126 $other_default{$addr} = shift;
3127
3128 return $self;
3129 }
3130
3131 sub get_next_defaults {
3132 # Iterates and returns the next class of defaults.
3133 my $self = shift;
3134 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3135
ffe43484 3136 my $addr = do { no overloading; pack 'J', $self; };
99870f4d
KW
3137
3138 return each %{$class_defaults{$addr}};
3139 }
3140}
3141
3142package Alias;
3143
3144# An alias is one of the names that a table goes by. This class defines them
3145# including some attributes. Everything is currently setup in the
3146# constructor.
3147
3148
3149{ # Closure
3150
3151 main::setup_package();
3152
3153 my %name;
3154 main::set_access('name', \%name, 'r');
3155
3156 my %loose_match;
c12f2655 3157 # Should this name match loosely or not.
99870f4d
KW
3158 main::set_access('loose_match', \%loose_match, 'r');
3159
33e96e72
KW
3160 my %make_re_pod_entry;
3161 # Some aliases should not get their own entries in the re section of the
3162 # pod, because they are covered by a wild-card, and some we want to
3163 # discourage use of. Binary
f82fe4ba 3164 main::set_access('make_re_pod_entry', \%make_re_pod_entry, 'r', 's');
99870f4d 3165
fd1e3e84
KW
3166 my %ucd;
3167 # Is this documented to be accessible via Unicode::UCD
3168 main::set_access('ucd', \%ucd, 'r', 's');
3169
99870f4d
KW
3170 my %status;
3171 # Aliases have a status, like deprecated, or even suppressed (which means
3172 # they don't appear in documentation). Enum
3173 main::set_access('status', \%status, 'r');
3174
0eac1e20 3175 my %ok_as_filename;
99870f4d
KW
3176 # Similarly, some aliases should not be considered as usable ones for
3177 # external use, such as file names, or we don't want documentation to
3178 # recommend them. Boolean
0eac1e20 3179 main::set_access('ok_as_filename', \%ok_as_filename, 'r');
99870f4d
KW
3180
3181 sub new {
3182 my $class = shift;
3183
3184 my $self = bless \do { my $anonymous_scalar }, $class;
ffe43484 3185 my $addr = do { no overloading; pack 'J', $self; };
99870f4d
KW
3186
3187 $name{$addr} = shift;
3188 $loose_match{$addr} = shift;
33e96e72 3189 $make_re_pod_entry{$addr} = shift;
0eac1e20 3190 $ok_as_filename{$addr} = shift;
99870f4d 3191 $status{$addr} = shift;
fd1e3e84 3192 $ucd{$addr} = shift;
99870f4d
KW
3193
3194 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3195
3196 # Null names are never ok externally
0eac1e20 3197 $ok_as_filename{$addr} = 0 if $name{$addr} eq "";
99870f4d
KW
3198
3199 return $self;
3200 }
3201}
3202
3203package Range;
3204
3205# A range is the basic unit for storing code points, and is described in the
3206# comments at the beginning of the program. Each range has a starting code
3207# point; an ending code point (not less than the starting one); a value
3208# that applies to every code point in between the two end-points, inclusive;
3209# and an enum type that applies to the value. The type is for the user's
3210# convenience, and has no meaning here, except that a non-zero type is
3211# considered to not obey the normal Unicode rules for having standard forms.
3212#
3213# The same structure is used for both map and match tables, even though in the
3214# latter, the value (and hence type) is irrelevant and could be used as a
3215# comment. In map tables, the value is what all the code points in the range
3216# map to. Type 0 values have the standardized version of the value stored as
3217# well, so as to not have to recalculate it a lot.
3218
3219sub trace { return main::trace(@_); }
3220
3221{ # Closure
3222
3223 main::setup_package();
3224
3225 my %start;
3226 main::set_access('start', \%start, 'r', 's');
3227
3228 my %end;
3229 main::set_access('end', \%end, 'r', 's');
3230
3231 my %value;
3232 main::set_access('value', \%value, 'r');
3233
3234 my %type;
3235 main::set_access('type', \%type, 'r');
3236
3237 my %standard_form;
3238 # The value in internal standard form. Defined only if the type is 0.
3239 main::set_access('standard_form', \%standard_form);
3240
3241 # Note that if these fields change, the dump() method should as well
3242
3243 sub new {
3244 return Carp::carp_too_few_args(\@_, 3) if main::DEBUG && @_ < 3;
3245 my $class = shift;
3246
3247 my $self = bless \do { my $anonymous_scalar }, $class;
ffe43484 3248 my $addr = do { no overloading; pack 'J', $self; };
99870f4d
KW
3249
3250 $start{$addr} = shift;
3251 $end{$addr} = shift;
3252
3253 my %args = @_;
3254
3255 my $value = delete $args{'Value'}; # Can be 0
3256 $value = "" unless defined $value;
3257 $value{$addr} = $value;
3258
3259 $type{$addr} = delete $args{'Type'} || 0;
3260
3261 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
3262
99870f4d
KW
3263 return $self;
3264 }
3265
3266 use overload
3267 fallback => 0,
3268 qw("") => "_operator_stringify",
3269 "." => \&main::_operator_dot,
1285127e 3270 ".=" => \&main::_operator_dot_equal,
99870f4d
KW
3271 ;
3272
3273 sub _operator_stringify {
3274 my $self = shift;
ffe43484 3275 my $addr = do { no overloading; pack 'J', $self; };
99870f4d
KW
3276
3277 # Output it like '0041..0065 (value)'
3278 my $return = sprintf("%04X", $start{$addr})
3279 . '..'
3280 . sprintf("%04X", $end{$addr});
3281 my $value = $value{$addr};
3282 my $type = $type{$addr};
3283 $return .= ' (';
3284 $return .= "$value";
3285 $return .= ", Type=$type" if $type != 0;
3286 $return .= ')';
3287
3288 return $return;
3289 }
3290
3291 sub standard_form {
c292d35a
NC
3292 # Calculate the standard form only if needed, and cache the result.
3293 # The standard form is the value itself if the type is special.
3294 # This represents a considerable CPU and memory saving - at the time
3295 # of writing there are 368676 non-special objects, but the standard
3296 # form is only requested for 22047 of them - ie about 6%.
99870f4d
KW
3297
3298 my $self = shift;
3299 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3300
ffe43484 3301 my $addr = do { no overloading; pack 'J', $self; };
99870f4d
KW
3302
3303 return $standard_form{$addr} if defined $standard_form{$addr};
c292d35a
NC
3304
3305 my $value = $value{$addr};
3306 return $value if $type{$addr};
3307 return $standard_form{$addr} = main::standardize($value);
99870f4d
KW
3308 }
3309
3310 sub dump {
3311 # Human, not machine readable. For machine readable, comment out this
3312 # entire routine and let the standard one take effect.
3313 my $self = shift;
3314 my $indent = shift;
3315 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3316
ffe43484 3317 my $addr = do { no overloading; pack 'J', $self; };
99870f4d
KW
3318
3319 my $return = $indent
3320 . sprintf("%04X", $start{$addr})
3321 . '..'
3322 . sprintf("%04X", $end{$addr})
3323 . " '$value{$addr}';";
3324 if (! defined $standard_form{$addr}) {
3325 $return .= "(type=$type{$addr})";
3326 }
3327 elsif ($standard_form{$addr} ne $value{$addr}) {
3328 $return .= "(standard '$standard_form{$addr}')";
3329 }
3330 return $return;
3331 }
3332} # End closure
3333
3334package _Range_List_Base;
3335
3336# Base class for range lists. A range list is simply an ordered list of
3337# ranges, so that the ranges with the lowest starting numbers are first in it.
3338#
3339# When a new range is added that is adjacent to an existing range that has the
3340# same value and type, it merges with it to form a larger range.
3341#
3342# Ranges generally do not overlap, except that there can be multiple entries
3343# of single code point ranges. This is because of NameAliases.txt.
3344#
3345# In this program, there is a standard value such that if two different
3346# values, have the same standard value, they are considered equivalent. This
3347# value was chosen so that it gives correct results on Unicode data
3348
3349# There are a number of methods to manipulate range lists, and some operators
3350# are overloaded to handle them.
3351
99870f4d
KW
3352sub trace { return main::trace(@_); }
3353
3354{ # Closure
3355
3356 our $addr;
3357
5b348b71
KW
3358 # Max is initialized to a negative value that isn't adjacent to 0, for
3359 # simpler tests
3360 my $max_init = -2;
3361
99870f4d
KW
3362 main::setup_package();
3363
3364 my %ranges;
3365 # The list of ranges
3366 main::set_access('ranges', \%ranges, 'readable_array');
3367
3368 my %max;
3369 # The highest code point in the list. This was originally a method, but
3370 # actual measurements said it was used a lot.
3371 main::set_access('max', \%max, 'r');
3372
3373 my %each_range_iterator;
3374 # Iterator position for each_range()
3375 main::set_access('each_range_iterator', \%each_range_iterator);
3376
3377 my %owner_name_of;
3378 # Name of parent this is attached to, if any. Solely for better error
3379 # messages.
3380 main::set_access('owner_name_of', \%owner_name_of, 'p_r');
3381
3382 my %_search_ranges_cache;
3383 # A cache of the previous result from _search_ranges(), for better
3384 # performance
3385 main::set_access('_search_ranges_cache', \%_search_ranges_cache);
3386
3387 sub new {
3388 my $class = shift;
3389 my %args = @_;
3390
3391 # Optional initialization data for the range list.
3392 my $initialize = delete $args{'Initialize'};
3393
3394 my $self;
3395
3396 # Use _union() to initialize. _union() returns an object of this
3397 # class, which means that it will call this constructor recursively.
3398 # But it won't have this $initialize parameter so that it won't
3399 # infinitely loop on this.
3400 return _union($class, $initialize, %args) if defined $initialize;
3401
3402 $self = bless \do { my $anonymous_scalar }, $class;
ffe43484 3403 my $addr = do { no overloading; pack 'J', $self; };
99870f4d
KW
3404
3405 # Optional parent object, only for debug info.
3406 $owner_name_of{$addr} = delete $args{'Owner'};
3407 $owner_name_of{$addr} = "" if ! defined $owner_name_of{$addr};
3408
3409 # Stringify, in case it is an object.
3410 $owner_name_of{$addr} = "$owner_name_of{$addr}";
3411
3412 # This is used only for error messages, and so a colon is added
3413 $owner_name_of{$addr} .= ": " if $owner_name_of{$addr} ne "";
3414
3415 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
3416
5b348b71 3417 $max{$addr} = $max_init;
99870f4d
KW
3418
3419 $_search_ranges_cache{$addr} = 0;
3420 $ranges{$addr} = [];
3421
3422 return $self;
3423 }
3424
3425 use overload
3426 fallback => 0,
3427 qw("") => "_operator_stringify",
3428 "." => \&main::_operator_dot,
1285127e 3429 ".=" => \&main::_operator_dot_equal,
99870f4d
KW
3430 ;
3431
3432 sub _operator_stringify {
3433 my $self = shift;
ffe43484 3434 my $addr = do { no overloading; pack 'J', $self; };
99870f4d
KW
3435
3436 return "Range_List attached to '$owner_name_of{$addr}'"
3437 if $owner_name_of{$addr};
3438 return "anonymous Range_List " . \$self;
3439 }
3440
3441 sub _union {
3442 # Returns the union of the input code points. It can be called as
3443 # either a constructor or a method. If called as a method, the result
3444 # will be a new() instance of the calling object, containing the union
3445 # of that object with the other parameter's code points; if called as
d59563d0 3446 # a constructor, the first parameter gives the class that the new object
99870f4d
KW
3447 # should be, and the second parameter gives the code points to go into
3448 # it.
3449 # In either case, there are two parameters looked at by this routine;
3450 # any additional parameters are passed to the new() constructor.
3451 #
3452 # The code points can come in the form of some object that contains
3453 # ranges, and has a conventionally named method to access them; or
3454 # they can be an array of individual code points (as integers); or
3455 # just a single code point.
3456 #
3457 # If they are ranges, this routine doesn't make any effort to preserve
3198cc57
KW
3458 # the range values and types of one input over the other. Therefore
3459 # this base class should not allow _union to be called from other than
99870f4d
KW
3460 # initialization code, so as to prevent two tables from being added
3461 # together where the range values matter. The general form of this
3462 # routine therefore belongs in a derived class, but it was moved here
3463 # to avoid duplication of code. The failure to overload this in this
3464 # class keeps it safe.
3198cc57
KW
3465 #
3466 # It does make the effort during initialization to accept tables with
3467 # multiple values for the same code point, and to preserve the order
3468 # of these. If there is only one input range or range set, it doesn't
3469 # sort (as it should already be sorted to the desired order), and will
3470 # accept multiple values per code point. Otherwise it will merge
3471 # multiple values into a single one.
99870f4d
KW
3472
3473 my $self;
3474 my @args; # Arguments to pass to the constructor
3475
3476 my $class = shift;
3477
3478 # If a method call, will start the union with the object itself, and
3479 # the class of the new object will be the same as self.
3480 if (ref $class) {
3481 $self = $class;
3482 $class = ref $self;
3483 push @args, $self;
3484 }
3485
3486 # Add the other required parameter.
3487 push @args, shift;
3488 # Rest of parameters are passed on to the constructor
3489
3490 # Accumulate all records from both lists.
3491 my @records;
3198cc57 3492 my $input_count = 0;
99870f4d
KW
3493 for my $arg (@args) {
3494 #local $to_trace = 0 if main::DEBUG;
3495 trace "argument = $arg" if main::DEBUG && $to_trace;
3496 if (! defined $arg) {
3497 my $message = "";
3498 if (defined $self) {
f998e60c 3499 no overloading;
051df77b 3500 $message .= $owner_name_of{pack 'J', $self};
99870f4d 3501 }
ada6088e 3502 Carp::my_carp_bug($message . "Undefined argument to _union. No union done.");
99870f4d
KW
3503 return;
3504 }
3198cc57 3505
99870f4d
KW
3506 $arg = [ $arg ] if ! ref $arg;
3507 my $type = ref $arg;
3508 if ($type eq 'ARRAY') {
3509 foreach my $element (@$arg) {
3510 push @records, Range->new($element, $element);
3198cc57 3511 $input_count++;
99870f4d
KW
3512 }
3513 }
3514 elsif ($arg->isa('Range')) {
3515 push @records, $arg;
3198cc57 3516 $input_count++;
99870f4d
KW
3517 }
3518 elsif ($arg->can('ranges')) {
3519 push @records, $arg->ranges;
3198cc57 3520 $input_count++;
99870f4d
KW
3521 }
3522 else {
3523 my $message = "";
3524 if (defined $self) {
f998e60c 3525 no overloading;
051df77b 3526 $message .= $owner_name_of{pack 'J', $self};
99870f4d
KW
3527 }
3528 Carp::my_carp_bug($message . "Cannot take the union of a $type. No union done.");
3529 return;
3530 }
3531 }
3532
3533 # Sort with the range containing the lowest ordinal first, but if
3534 # two ranges start at the same code point, sort with the bigger range
3535 # of the two first, because it takes fewer cycles.
3198cc57
KW
3536 if ($input_count > 1) {
3537 @records = sort { ($a->start <=> $b->start)
99870f4d
KW
3538 or
3539 # if b is shorter than a, b->end will be
3540 # less than a->end, and we want to select
3541 # a, so want to return -1
3542 ($b->end <=> $a->end)
3543 } @records;
3198cc57 3544 }
99870f4d
KW
3545
3546 my $new = $class->new(@_);
3547
3548 # Fold in records so long as they add new information.
3549 for my $set (@records) {
3550 my $start = $set->start;
3551 my $end = $set->end;
d59563d0 3552 my $value = $set->value;
3198cc57 3553 my $type = $set->type;
99870f4d 3554 if ($start > $new->max) {
3198cc57 3555 $new->_add_delete('+', $start, $end, $value, Type => $type);
99870f4d
KW
3556 }
3557 elsif ($end > $new->max) {
3198cc57
KW
3558 $new->_add_delete('+', $new->max +1, $end, $value,
3559 Type => $type);
3560 }
3561 elsif ($input_count == 1) {
3562 # Here, overlaps existing range, but is from a single input,
3563 # so preserve the multiple values from that input.
3564 $new->_add_delete('+', $start, $end, $value, Type => $type,
3565 Replace => $MULTIPLE_AFTER);
99870f4d
KW
3566 }
3567 }
3568
3569 return $new;
3570 }
3571
3572 sub range_count { # Return the number of ranges in the range list
3573 my $self = shift;
3574 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3575
f998e60c 3576 no overloading;
051df77b 3577 return scalar @{$ranges{pack 'J', $self}};
99870f4d
KW
3578 }
3579
3580 sub min {
3581 # Returns the minimum code point currently in the range list, or if
3582 # the range list is empty, 2 beyond the max possible. This is a
3583 # method because used so rarely, that not worth saving between calls,
3584 # and having to worry about changing it as ranges are added and
3585 # deleted.
3586
3587 my $self = shift;
3588 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3589
ffe43484 3590 my $addr = do { no overloading; pack 'J', $self; };
99870f4d
KW
3591
3592 # If the range list is empty, return a large value that isn't adjacent
3593 # to any that could be in the range list, for simpler tests
2d88a86a 3594 return $MAX_WORKING_CODEPOINT + 2 unless scalar @{$ranges{$addr}};
99870f4d
KW
3595 return $ranges{$addr}->[0]->start;
3596 }
3597
3598 sub contains {
3599 # Boolean: Is argument in the range list? If so returns $i such that:
3600 # range[$i]->end < $codepoint <= range[$i+1]->end
3601 # which is one beyond what you want; this is so that the 0th range
3602 # doesn't return false
3603 my $self = shift;
3604 my $codepoint = shift;
3605 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3606
99870f4d
KW
3607 my $i = $self->_search_ranges($codepoint);
3608 return 0 unless defined $i;
3609
3610 # The search returns $i, such that
3611 # range[$i-1]->end < $codepoint <= range[$i]->end
3612 # So is in the table if and only iff it is at least the start position
3613 # of range $i.
f998e60c 3614 no overloading;
051df77b 3615 return 0 if $ranges{pack 'J', $self}->[$i]->start > $codepoint;
99870f4d
KW
3616 return $i + 1;
3617 }
3618
2f7a8815
KW
3619 sub containing_range {
3620 # Returns the range object that contains the code point, undef if none
3621
3622 my $self = shift;
3623 my $codepoint = shift;
3624 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3625
3626 my $i = $self->contains($codepoint);
3627 return unless $i;
3628
3629 # contains() returns 1 beyond where we should look
3630 no overloading;
3631 return $ranges{pack 'J', $self}->[$i-1];
3632 }
3633
99870f4d
KW
3634 sub value_of {
3635 # Returns the value associated with the code point, undef if none
3636
3637 my $self = shift;
3638 my $codepoint = shift;
3639 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3640
d69c231b
KW
3641 my $range = $self->containing_range($codepoint);
3642 return unless defined $range;
99870f4d 3643
d69c231b 3644 return $range->value;
99870f4d
KW
3645 }
3646
0a9dbafc
KW
3647 sub type_of {
3648 # Returns the type of the range containing the code point, undef if
3649 # the code point is not in the table
3650
3651 my $self = shift;
3652 my $codepoint = shift;
3653 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3654
3655 my $range = $self->containing_range($codepoint);
3656 return unless defined $range;
3657
3658 return $range->type;
3659 }
3660
99870f4d
KW
3661 sub _search_ranges {
3662 # Find the range in the list which contains a code point, or where it
3663 # should go if were to add it. That is, it returns $i, such that:
3664 # range[$i-1]->end < $codepoint <= range[$i]->end
3665 # Returns undef if no such $i is possible (e.g. at end of table), or
3666 # if there is an error.
3667
3668 my $self = shift;
3669 my $code_point = shift;
3670 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3671
ffe43484 3672 my $addr = do { no overloading; pack 'J', $self; };
99870f4d
KW
3673
3674 return if $code_point > $max{$addr};
3675 my $r = $ranges{$addr}; # The current list of ranges
3676 my $range_list_size = scalar @$r;
3677 my $i;
3678
3679 use integer; # want integer division
3680
3681 # Use the cached result as the starting guess for this one, because,
3682 # an experiment on 5.1 showed that 90% of the time the cache was the
3683 # same as the result on the next call (and 7% it was one less).
3684 $i = $_search_ranges_cache{$addr};
3685 $i = 0 if $i >= $range_list_size; # Reset if no longer valid (prob.
3686 # from an intervening deletion
3687 #local $to_trace = 1 if main::DEBUG;
3688 trace "previous \$i is still valid: $i" if main::DEBUG && $to_trace && $code_point <= $r->[$i]->end && ($i == 0 || $r->[$i-1]->end < $code_point);
3689 return $i if $code_point <= $r->[$i]->end
3690 && ($i == 0 || $r->[$i-1]->end < $code_point);
3691
3692 # Here the cache doesn't yield the correct $i. Try adding 1.
3693 if ($i < $range_list_size - 1
3694 && $r->[$i]->end < $code_point &&
3695 $code_point <= $r->[$i+1]->end)
3696 {
3697 $i++;
3698 trace "next \$i is correct: $i" if main::DEBUG && $to_trace;
3699 $_search_ranges_cache{$addr} = $i;
3700 return $i;
3701 }
3702
3703 # Here, adding 1 also didn't work. We do a binary search to
3704 # find the correct position, starting with current $i
3705 my $lower = 0;
3706 my $upper = $range_list_size - 1;
3707 while (1) {
3708 trace "top of loop i=$i:", sprintf("%04X"