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