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