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.
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". But almost all occurrences of objaddr have been
10 # removed in favor of using 'no overloading'. You also would have to go
11 # through and replace occurrences like:
12 # my $addr = do { no overloading; pack 'J', $self; }
14 # my $addr = main::objaddr $self;
15 # (or reverse commit 9b01bafde4b022706c3d6f947a0963f821b2e50b
16 # that instituted the change to main::objaddr, and subsequent commits that
17 # changed 0+$self to pack 'J', $self.)
20 BEGIN { # Get the time the script started running; do it at compiliation to
21 # get it as close as possible
35 sub DEBUG () { 0 } # Set to 0 for production; 1 for development
37 ##########################################################################
39 # mktables -- create the runtime Perl Unicode files (lib/unicore/.../*.pl),
40 # from the Unicode database files (lib/unicore/.../*.txt), It also generates
41 # a pod file and a .t file
43 # The structure of this file is:
44 # First these introductory comments; then
45 # code needed for everywhere, such as debugging stuff; then
46 # code to handle input parameters; then
47 # data structures likely to be of external interest (some of which depend on
48 # the input parameters, so follows them; then
49 # more data structures and subroutine and package (class) definitions; then
50 # the small actual loop to process the input files and finish up; then
51 # a __DATA__ section, for the .t tests
53 # This program works on all releases of Unicode through at least 5.2. The
54 # outputs have been scrutinized most intently for release 5.1. The others
55 # have been checked for somewhat more than just sanity. It can handle all
56 # existing Unicode character properties in those releases.
58 # This program is mostly about Unicode character (or code point) properties.
59 # A property describes some attribute or quality of a code point, like if it
60 # is lowercase or not, its name, what version of Unicode it was first defined
61 # in, or what its uppercase equivalent is. Unicode deals with these disparate
62 # possibilities by making all properties into mappings from each code point
63 # into some corresponding value. In the case of it being lowercase or not,
64 # the mapping is either to 'Y' or 'N' (or various synonyms thereof). Each
65 # property maps each Unicode code point to a single value, called a "property
66 # value". (Hence each Unicode property is a true mathematical function with
67 # exactly one value per code point.)
69 # When using a property in a regular expression, what is desired isn't the
70 # mapping of the code point to its property's value, but the reverse (or the
71 # mathematical "inverse relation"): starting with the property value, "Does a
72 # code point map to it?" These are written in a "compound" form:
73 # \p{property=value}, e.g., \p{category=punctuation}. This program generates
74 # files containing the lists of code points that map to each such regular
75 # expression property value, one file per list
77 # There is also a single form shortcut that Perl adds for many of the commonly
78 # used properties. This happens for all binary properties, plus script,
79 # general_category, and block properties.
81 # Thus the outputs of this program are files. There are map files, mostly in
82 # the 'To' directory; and there are list files for use in regular expression
83 # matching, all in subdirectories of the 'lib' directory, with each
84 # subdirectory being named for the property that the lists in it are for.
85 # Bookkeeping, test, and documentation files are also generated.
87 my $matches_directory = 'lib'; # Where match (\p{}) files go.
88 my $map_directory = 'To'; # Where map files go.
92 # The major data structures of this program are Property, of course, but also
93 # Table. There are two kinds of tables, very similar to each other.
94 # "Match_Table" is the data structure giving the list of code points that have
95 # a particular property value, mentioned above. There is also a "Map_Table"
96 # data structure which gives the property's mapping from code point to value.
97 # There are two structures because the match tables need to be combined in
98 # various ways, such as constructing unions, intersections, complements, etc.,
99 # and the map ones don't. And there would be problems, perhaps subtle, if
100 # a map table were inadvertently operated on in some of those ways.
101 # The use of separate classes with operations defined on one but not the other
102 # prevents accidentally confusing the two.
104 # At the heart of each table's data structure is a "Range_List", which is just
105 # an ordered list of "Ranges", plus ancillary information, and methods to
106 # operate on them. A Range is a compact way to store property information.
107 # Each range has a starting code point, an ending code point, and a value that
108 # is meant to apply to all the code points between the two end points,
109 # inclusive. For a map table, this value is the property value for those
110 # code points. Two such ranges could be written like this:
111 # 0x41 .. 0x5A, 'Upper',
112 # 0x61 .. 0x7A, 'Lower'
114 # Each range also has a type used as a convenience to classify the values.
115 # Most ranges in this program will be Type 0, or normal, but there are some
116 # ranges that have a non-zero type. These are used only in map tables, and
117 # are for mappings that don't fit into the normal scheme of things. Mappings
118 # that require a hash entry to communicate with utf8.c are one example;
119 # another example is mappings for charnames.pm to use which indicate a name
120 # that is algorithmically determinable from its code point (and vice-versa).
121 # These are used to significantly compact these tables, instead of listing
122 # each one of the tens of thousands individually.
124 # In a match table, the value of a range is irrelevant (and hence the type as
125 # well, which will always be 0), and arbitrarily set to the null string.
126 # Using the example above, there would be two match tables for those two
127 # entries, one named Upper would contain the 0x41..0x5A range, and the other
128 # named Lower would contain 0x61..0x7A.
130 # Actually, there are two types of range lists, "Range_Map" is the one
131 # associated with map tables, and "Range_List" with match tables.
132 # Again, this is so that methods can be defined on one and not the other so as
133 # to prevent operating on them in incorrect ways.
135 # Eventually, most tables are written out to files to be read by utf8_heavy.pl
136 # in the perl core. All tables could in theory be written, but some are
137 # suppressed because there is no current practical use for them. It is easy
138 # to change which get written by changing various lists that are near the top
139 # of the actual code in this file. The table data structures contain enough
140 # ancillary information to allow them to be treated as separate entities for
141 # writing, such as the path to each one's file. There is a heading in each
142 # map table that gives the format of its entries, and what the map is for all
143 # the code points missing from it. (This allows tables to be more compact.)
145 # The Property data structure contains one or more tables. All properties
146 # contain a map table (except the $perl property which is a
147 # pseudo-property containing only match tables), and any properties that
148 # are usable in regular expression matches also contain various matching
149 # tables, one for each value the property can have. A binary property can
150 # have two values, True and False (or Y and N, which are preferred by Unicode
151 # terminology). Thus each of these properties will have a map table that
152 # takes every code point and maps it to Y or N (but having ranges cuts the
153 # number of entries in that table way down), and two match tables, one
154 # which has a list of all the code points that map to Y, and one for all the
155 # code points that map to N. (For each of these, a third table is also
156 # generated for the pseudo Perl property. It contains the identical code
157 # points as the Y table, but can be written, not in the compound form, but in
158 # a "single" form like \p{IsUppercase}.) Many properties are binary, but some
159 # properties have several possible values, some have many, and properties like
160 # Name have a different value for every named code point. Those will not,
161 # unless the controlling lists are changed, have their match tables written
162 # out. But all the ones which can be used in regular expression \p{} and \P{}
163 # constructs will. Generally a property will have either its map table or its
164 # match tables written but not both. Again, what gets written is controlled
165 # by lists which can easily be changed.
167 # For information about the Unicode properties, see Unicode's UAX44 document:
169 my $unicode_reference_url = 'http://www.unicode.org/reports/tr44/';
171 # As stated earlier, this program will work on any release of Unicode so far.
172 # Most obvious problems in earlier data have NOT been corrected except when
173 # necessary to make Perl or this program work reasonably. For example, no
174 # folding information was given in early releases, so this program uses the
175 # substitute of lower case, just so that a regular expression with the /i
176 # option will do something that actually gives the right results in many
177 # cases. There are also a couple other corrections for version 1.1.5,
178 # commented at the point they are made. As an example of corrections that
179 # weren't made (but could be) is this statement from DerivedAge.txt: "The
180 # supplementary private use code points and the non-character code points were
181 # assigned in version 2.0, but not specifically listed in the UCD until
182 # versions 3.0 and 3.1 respectively." (To be precise it was 3.0.1 not 3.0.0)
183 # More information on Unicode version glitches is further down in these
184 # introductory comments.
186 # This program works on all properties as of 5.2, though the files for some
187 # are suppressed from apparent lack of demand for them. You can change which
188 # are output by changing lists in this program.
190 # The old version of mktables emphasized the term "Fuzzy" to mean Unocde's
191 # loose matchings rules (from Unicode TR18):
193 # The recommended names for UCD properties and property values are in
194 # PropertyAliases.txt [Prop] and PropertyValueAliases.txt
195 # [PropValue]. There are both abbreviated names and longer, more
196 # descriptive names. It is strongly recommended that both names be
197 # recognized, and that loose matching of property names be used,
198 # whereby the case distinctions, whitespace, hyphens, and underbar
200 # The program still allows Fuzzy to override its determination of if loose
201 # matching should be used, but it isn't currently used, as it is no longer
202 # needed; the calculations it makes are good enough.
204 # SUMMARY OF HOW IT WORKS:
208 # A list is constructed containing each input file that is to be processed
210 # Each file on the list is processed in a loop, using the associated handler
212 # The PropertyAliases.txt and PropValueAliases.txt files are processed
213 # first. These files name the properties and property values.
214 # Objects are created of all the property and property value names
215 # that the rest of the input should expect, including all synonyms.
216 # The other input files give mappings from properties to property
217 # values. That is, they list code points and say what the mapping
218 # is under the given property. Some files give the mappings for
219 # just one property; and some for many. This program goes through
220 # each file and populates the properties from them. Some properties
221 # are listed in more than one file, and Unicode has set up a
222 # precedence as to which has priority if there is a conflict. Thus
223 # the order of processing matters, and this program handles the
224 # conflict possibility by processing the overriding input files
225 # last, so that if necessary they replace earlier values.
226 # After this is all done, the program creates the property mappings not
227 # furnished by Unicode, but derivable from what it does give.
228 # The tables of code points that match each property value in each
229 # property that is accessible by regular expressions are created.
230 # The Perl-defined properties are created and populated. Many of these
231 # require data determined from the earlier steps
232 # Any Perl-defined synonyms are created, and name clashes between Perl
233 # and Unicode are reconciled and warned about.
234 # All the properties are written to files
235 # Any other files are written, and final warnings issued.
237 # For clarity, a number of operators have been overloaded to work on tables:
238 # ~ means invert (take all characters not in the set). The more
239 # conventional '!' is not used because of the possibility of confusing
240 # it with the actual boolean operation.
242 # - means subtraction
243 # & means intersection
244 # The precedence of these is the order listed. Parentheses should be
245 # copiously used. These are not a general scheme. The operations aren't
246 # defined for a number of things, deliberately, to avoid getting into trouble.
247 # Operations are done on references and affect the underlying structures, so
248 # that the copy constructors for them have been overloaded to not return a new
249 # clone, but the input object itself.
251 # The bool operator is deliberately not overloaded to avoid confusion with
252 # "should it mean if the object merely exists, or also is non-empty?".
254 # WHY CERTAIN DESIGN DECISIONS WERE MADE
256 # This program needs to be able to run under miniperl. Therefore, it uses a
257 # minimum of other modules, and hence implements some things itself that could
258 # be gotten from CPAN
260 # This program uses inputs published by the Unicode Consortium. These can
261 # change incompatibly between releases without the Perl maintainers realizing
262 # it. Therefore this program is now designed to try to flag these. It looks
263 # at the directories where the inputs are, and flags any unrecognized files.
264 # It keeps track of all the properties in the files it handles, and flags any
265 # that it doesn't know how to handle. It also flags any input lines that
266 # don't match the expected syntax, among other checks.
268 # It is also designed so if a new input file matches one of the known
269 # templates, one hopefully just needs to add it to a list to have it
272 # As mentioned earlier, some properties are given in more than one file. In
273 # particular, the files in the extracted directory are supposedly just
274 # reformattings of the others. But they contain information not easily
275 # derivable from the other files, including results for Unihan, which this
276 # program doesn't ordinarily look at, and for unassigned code points. They
277 # also have historically had errors or been incomplete. In an attempt to
278 # create the best possible data, this program thus processes them first to
279 # glean information missing from the other files; then processes those other
280 # files to override any errors in the extracted ones. Much of the design was
281 # driven by this need to store things and then possibly override them.
283 # It tries to keep fatal errors to a minimum, to generate something usable for
284 # testing purposes. It always looks for files that could be inputs, and will
285 # warn about any that it doesn't know how to handle (the -q option suppresses
288 # Why have files written out for binary 'N' matches?
289 # For binary properties, if you know the mapping for either Y or N; the
290 # other is trivial to construct, so could be done at Perl run-time by just
291 # complementing the result, instead of having a file for it. That is, if
292 # someone types in \p{foo: N}, Perl could translate that to \P{foo: Y} and
293 # not need a file. The problem is communicating to Perl that a given
294 # property is binary. Perl can't figure it out from looking at the N (or
295 # No), as some non-binary properties have these as property values. So
296 # rather than inventing a way to communicate this info back to the core,
297 # which would have required changes there as well, it was simpler just to
298 # add the extra tables.
300 # Why is there more than one type of range?
301 # This simplified things. There are some very specialized code points that
302 # have to be handled specially for output, such as Hangul syllable names.
303 # By creating a range type (done late in the development process), it
304 # allowed this to be stored with the range, and overridden by other input.
305 # Originally these were stored in another data structure, and it became a
306 # mess trying to decide if a second file that was for the same property was
307 # overriding the earlier one or not.
309 # Why are there two kinds of tables, match and map?
310 # (And there is a base class shared by the two as well.) As stated above,
311 # they actually are for different things. Development proceeded much more
312 # smoothly when I (khw) realized the distinction. Map tables are used to
313 # give the property value for every code point (actually every code point
314 # that doesn't map to a default value). Match tables are used for regular
315 # expression matches, and are essentially the inverse mapping. Separating
316 # the two allows more specialized methods, and error checks so that one
317 # can't just take the intersection of two map tables, for example, as that
320 # There are no match tables generated for matches of the null string. These
321 # would look like qr/\p{JSN=}/ currently without modifying the regex code.
322 # Perhaps something like them could be added if necessary. The JSN does have
323 # a real code point U+110B that maps to the null string, but it is a
324 # contributory property, and therefore not output by default. And it's easily
325 # handled so far by making the null string the default where it is a
330 # This program is written so it will run under miniperl. Occasionally changes
331 # will cause an error where the backtrace doesn't work well under miniperl.
332 # To diagnose the problem, you can instead run it under regular perl, if you
335 # There is a good trace facility. To enable it, first sub DEBUG must be set
336 # to return true. Then a line like
338 # local $to_trace = 1 if main::DEBUG;
340 # can be added to enable tracing in its lexical scope or until you insert
343 # local $to_trace = 0 if main::DEBUG;
345 # then use a line like "trace $a, @b, %c, ...;
347 # Some of the more complex subroutines already have trace statements in them.
348 # Permanent trace statements should be like:
350 # trace ... if main::DEBUG && $to_trace;
352 # If there is just one or a few files that you're debugging, you can easily
353 # cause most everything else to be skipped. Change the line
355 # my $debug_skip = 0;
357 # to 1, and every file whose object is in @input_file_objects and doesn't have
358 # a, 'non_skip => 1,' in its constructor will be skipped.
360 # To compare the output tables, it may be useful to specify the -annotate
361 # flag. This causes the tables to expand so there is one entry for each
362 # non-algorithmically named code point giving, currently its name, and its
363 # graphic representation if printable (and you have a font that knows about
364 # it). This makes it easier to see what the particular code points are in
365 # each output table. The tables are usable, but because they don't have
366 # ranges (for the most part), a Perl using them will run slower. Non-named
367 # code points are annotated with a description of their status, and contiguous
368 # ones with the same description will be output as a range rather than
369 # individually. Algorithmically named characters are also output as ranges,
370 # except when there are just a few contiguous ones.
374 # The program would break if Unicode were to change its names so that
375 # interior white space, underscores, or dashes differences were significant
376 # within property and property value names.
378 # It might be easier to use the xml versions of the UCD if this program ever
379 # would need heavy revision, and the ability to handle old versions was not
382 # There is the potential for name collisions, in that Perl has chosen names
383 # that Unicode could decide it also likes. There have been such collisions in
384 # the past, with mostly Perl deciding to adopt the Unicode definition of the
385 # name. However in the 5.2 Unicode beta testing, there were a number of such
386 # collisions, which were withdrawn before the final release, because of Perl's
387 # and other's protests. These all involved new properties which began with
388 # 'Is'. Based on the protests, Unicode is unlikely to try that again. Also,
389 # many of the Perl-defined synonyms, like Any, Word, etc, are listed in a
390 # Unicode document, so they are unlikely to be used by Unicode for another
391 # purpose. However, they might try something beginning with 'In', or use any
392 # of the other Perl-defined properties. This program will warn you of name
393 # collisions, and refuse to generate tables with them, but manual intervention
394 # will be required in this event. One scheme that could be implemented, if
395 # necessary, would be to have this program generate another file, or add a
396 # field to mktables.lst that gives the date of first definition of a property.
397 # Each new release of Unicode would use that file as a basis for the next
398 # iteration. And the Perl synonym addition code could sort based on the age
399 # of the property, so older properties get priority, and newer ones that clash
400 # would be refused; hence existing code would not be impacted, and some other
401 # synonym would have to be used for the new property. This is ugly, and
402 # manual intervention would certainly be easier to do in the short run; lets
403 # hope it never comes to this.
407 # This program can generate tables from the Unihan database. But it doesn't
408 # by default, letting the CPAN module Unicode::Unihan handle them. Prior to
409 # version 5.2, this database was in a single file, Unihan.txt. In 5.2 the
410 # database was split into 8 different files, all beginning with the letters
411 # 'Unihan'. This program will read those file(s) if present, but it needs to
412 # know which of the many properties in the file(s) should have tables created
413 # for them. It will create tables for any properties listed in
414 # PropertyAliases.txt and PropValueAliases.txt, plus any listed in the
415 # @cjk_properties array and the @cjk_property_values array. Thus, if a
416 # property you want is not in those files of the release you are building
417 # against, you must add it to those two arrays. Starting in 4.0, the
418 # Unicode_Radical_Stroke was listed in those files, so if the Unihan database
419 # is present in the directory, a table will be generated for that property.
420 # In 5.2, several more properties were added. For your convenience, the two
421 # arrays are initialized with all the 5.2 listed properties that are also in
422 # earlier releases. But these are commented out. You can just uncomment the
423 # ones you want, or use them as a template for adding entries for other
426 # You may need to adjust the entries to suit your purposes. setup_unihan(),
427 # and filter_unihan_line() are the functions where this is done. This program
428 # already does some adjusting to make the lines look more like the rest of the
429 # Unicode DB; You can see what that is in filter_unihan_line()
431 # There is a bug in the 3.2 data file in which some values for the
432 # kPrimaryNumeric property have commas and an unexpected comment. A filter
433 # could be added for these; or for a particular installation, the Unihan.txt
434 # file could be edited to fix them.
436 # HOW TO ADD A FILE TO BE PROCESSED
438 # A new file from Unicode needs to have an object constructed for it in
439 # @input_file_objects, probably at the end or at the end of the extracted
440 # ones. The program should warn you if its name will clash with others on
441 # restrictive file systems, like DOS. If so, figure out a better name, and
442 # add lines to the README.perl file giving that. If the file is a character
443 # property, it should be in the format that Unicode has by default
444 # standardized for such files for the more recently introduced ones.
445 # If so, the Input_file constructor for @input_file_objects can just be the
446 # file name and release it first appeared in. If not, then it should be
447 # possible to construct an each_line_handler() to massage the line into the
450 # For non-character properties, more code will be needed. You can look at
451 # the existing entries for clues.
453 # UNICODE VERSIONS NOTES
455 # The Unicode UCD has had a number of errors in it over the versions. And
456 # these remain, by policy, in the standard for that version. Therefore it is
457 # risky to correct them, because code may be expecting the error. So this
458 # program doesn't generally make changes, unless the error breaks the Perl
459 # core. As an example, some versions of 2.1.x Jamo.txt have the wrong value
460 # for U+1105, which causes real problems for the algorithms for Jamo
461 # calculations, so it is changed here.
463 # But it isn't so clear cut as to what to do about concepts that are
464 # introduced in a later release; should they extend back to earlier releases
465 # where the concept just didn't exist? It was easier to do this than to not,
466 # so that's what was done. For example, the default value for code points not
467 # in the files for various properties was probably undefined until changed by
468 # some version. No_Block for blocks is such an example. This program will
469 # assign No_Block even in Unicode versions that didn't have it. This has the
470 # benefit that code being written doesn't have to special case earlier
471 # versions; and the detriment that it doesn't match the Standard precisely for
472 # the affected versions.
474 # Here are some observations about some of the issues in early versions:
476 # The number of code points in \p{alpha} halve in 2.1.9. It turns out that
477 # the reason is that the CJK block starting at 4E00 was removed from PropList,
478 # and was not put back in until 3.1.0
480 # Unicode introduced the synonym Space for White_Space in 4.1. Perl has
481 # always had a \p{Space}. In release 3.2 only, they are not synonymous. The
482 # reason is that 3.2 introduced U+205F=medium math space, which was not
483 # classed as white space, but Perl figured out that it should have been. 4.0
484 # reclassified it correctly.
486 # Another change between 3.2 and 4.0 is the CCC property value ATBL. In 3.2
487 # this was erroneously a synonym for 202. In 4.0, ATB became 202, and ATBL
488 # was left with no code points, as all the ones that mapped to 202 stayed
489 # mapped to 202. Thus if your program used the numeric name for the class,
490 # it would not have been affected, but if it used the mnemonic, it would have
493 # \p{Script=Hrkt} (Katakana_Or_Hiragana) came in 4.0.1. Before that code
494 # points which eventually came to have this script property value, instead
495 # mapped to "Unknown". But in the next release all these code points were
496 # moved to \p{sc=common} instead.
498 # The default for missing code points for BidiClass is complicated. Starting
499 # in 3.1.1, the derived file DBidiClass.txt handles this, but this program
500 # tries to do the best it can for earlier releases. It is done in
501 # process_PropertyAliases()
503 ##############################################################################
505 my $UNDEF = ':UNDEF:'; # String to print out for undefined values in tracing
507 my $MAX_LINE_WIDTH = 78;
509 # Debugging aid to skip most files so as to not be distracted by them when
510 # concentrating on the ones being debugged. Add
512 # to the constructor for those files you want processed when you set this.
513 # Files with a first version number of 0 are special: they are always
514 # processed regardless of the state of this flag.
517 # Set to 1 to enable tracing.
520 { # Closure for trace: debugging aid
521 my $print_caller = 1; # ? Include calling subroutine name
522 my $main_with_colon = 'main::';
523 my $main_colon_length = length($main_with_colon);
526 return unless $to_trace; # Do nothing if global flag not set
530 local $DB::trace = 0;
531 $DB::trace = 0; # Quiet 'used only once' message
535 # Loop looking up the stack to get the first non-trace caller
540 $line_number = $caller_line;
541 (my $pkg, my $file, $caller_line, my $caller) = caller $i++;
542 $caller = $main_with_colon unless defined $caller;
544 $caller_name = $caller;
547 $caller_name =~ s/.*:://;
548 if (substr($caller_name, 0, $main_colon_length)
551 $caller_name = substr($caller_name, $main_colon_length);
554 } until ($caller_name ne 'trace');
556 # If the stack was empty, we were called from the top level
557 $caller_name = 'main' if ($caller_name eq ""
558 || $caller_name eq 'trace');
561 foreach my $string (@input) {
562 #print STDERR __LINE__, ": ", join ", ", @input, "\n";
563 if (ref $string eq 'ARRAY' || ref $string eq 'HASH') {
564 $output .= simple_dumper($string);
567 $string = "$string" if ref $string;
568 $string = $UNDEF unless defined $string;
570 $string = '""' if $string eq "";
571 $output .= " " if $output ne ""
573 && substr($output, -1, 1) ne " "
574 && substr($string, 0, 1) ne " ";
579 print STDERR sprintf "%4d: ", $line_number if defined $line_number;
580 print STDERR "$caller_name: " if $print_caller;
581 print STDERR $output, "\n";
586 # This is for a rarely used development feature that allows you to compare two
587 # versions of the Unicode standard without having to deal with changes caused
588 # by the code points introduced in the later verson. Change the 0 to a SINGLE
589 # dotted Unicode release number (e.g. 2.1). Only code points introduced in
590 # that release and earlier will be used; later ones are thrown away. You use
591 # the version number of the earliest one you want to compare; then run this
592 # program on directory structures containing each release, and compare the
593 # outputs. These outputs will therefore include only the code points common
594 # to both releases, and you can see the changes caused just by the underlying
595 # release semantic changes. For versions earlier than 3.2, you must copy a
596 # version of DAge.txt into the directory.
597 my $string_compare_versions = DEBUG && 0; # e.g., v2.1;
598 my $compare_versions = DEBUG
599 && $string_compare_versions
600 && pack "C*", split /\./, $string_compare_versions;
603 # Returns non-duplicated input values. From "Perl Best Practices:
604 # Encapsulated Cleverness". p. 455 in first edition.
607 # Arguably this breaks encapsulation, if the goal is to permit multiple
608 # distinct objects to stringify to the same value, and be interchangeable.
609 # However, for this program, no two objects stringify identically, and all
610 # lists passed to this function are either objects or strings. So this
611 # doesn't affect correctness, but it does give a couple of percent speedup.
613 return grep { ! $seen{$_}++ } @_;
616 $0 = File::Spec->canonpath($0);
618 my $make_test_script = 0; # ? Should we output a test script
619 my $write_unchanged_files = 0; # ? Should we update the output files even if
620 # we don't think they have changed
621 my $use_directory = ""; # ? Should we chdir somewhere.
622 my $pod_directory; # input directory to store the pod file.
623 my $pod_file = 'perluniprops';
624 my $t_path; # Path to the .t test file
625 my $file_list = 'mktables.lst'; # File to store input and output file names.
626 # This is used to speed up the build, by not
627 # executing the main body of the program if
628 # nothing on the list has changed since the
630 my $make_list = 1; # ? Should we write $file_list. Set to always
631 # make a list so that when the pumpking is
632 # preparing a release, s/he won't have to do
634 my $glob_list = 0; # ? Should we try to include unknown .txt files
636 my $output_range_counts = 1; # ? Should we include the number of code points
637 # in ranges in the output
638 my $annotate = 0; # ? Should character names be in the output
640 # Verbosity levels; 0 is quiet
641 my $NORMAL_VERBOSITY = 1;
645 my $verbosity = $NORMAL_VERBOSITY;
649 my $arg = shift @ARGV;
651 $verbosity = $VERBOSE;
653 elsif ($arg eq '-p') {
654 $verbosity = $PROGRESS;
655 $| = 1; # Flush buffers as we go.
657 elsif ($arg eq '-q') {
660 elsif ($arg eq '-w') {
661 $write_unchanged_files = 1; # update the files even if havent changed
663 elsif ($arg eq '-check') {
664 my $this = shift @ARGV;
665 my $ok = shift @ARGV;
667 print "Skipping as check params are not the same.\n";
671 elsif ($arg eq '-P' && defined ($pod_directory = shift)) {
672 -d $pod_directory or croak "Directory '$pod_directory' doesn't exist";
674 elsif ($arg eq '-maketest' || ($arg eq '-T' && defined ($t_path = shift)))
676 $make_test_script = 1;
678 elsif ($arg eq '-makelist') {
681 elsif ($arg eq '-C' && defined ($use_directory = shift)) {
682 -d $use_directory or croak "Unknown directory '$use_directory'";
684 elsif ($arg eq '-L') {
686 # Existence not tested until have chdir'd
689 elsif ($arg eq '-globlist') {
692 elsif ($arg eq '-c') {
693 $output_range_counts = ! $output_range_counts
695 elsif ($arg eq '-annotate') {
700 $with_c .= 'out' if $output_range_counts; # Complements the state
702 usage: $0 [-c|-p|-q|-v|-w] [-C dir] [-L filelist] [ -P pod_dir ]
703 [ -T test_file_path ] [-globlist] [-makelist] [-maketest]
705 -c : Output comments $with_c number of code points in ranges
706 -q : Quiet Mode: Only output serious warnings.
707 -p : Set verbosity level to normal plus show progress.
708 -v : Set Verbosity level high: Show progress and non-serious
710 -w : Write files regardless
711 -C dir : Change to this directory before proceeding. All relative paths
712 except those specified by the -P and -T options will be done
713 with respect to this directory.
714 -P dir : Output $pod_file file to directory 'dir'.
715 -T path : Create a test script as 'path'; overrides -maketest
716 -L filelist : Use alternate 'filelist' instead of standard one
717 -globlist : Take as input all non-Test *.txt files in current and sub
719 -maketest : Make test script 'TestProp.pl' in current (or -C directory),
721 -makelist : Rewrite the file list $file_list based on current setup
722 -annotate : Output an annotation for each character in the table files;
723 useful for debugging mktables, looking at diffs; but is slow,
724 memory intensive; resulting tables are usable but slow and
726 -check A B : Executes $0 only if A and B are the same
731 # Stores the most-recently changed file. If none have changed, can skip the
733 my $most_recent = (stat $0)[9]; # Do this before the chdir!
735 # Change directories now, because need to read 'version' early.
736 if ($use_directory) {
737 if ($pod_directory && ! File::Spec->file_name_is_absolute($pod_directory)) {
738 $pod_directory = File::Spec->rel2abs($pod_directory);
740 if ($t_path && ! File::Spec->file_name_is_absolute($t_path)) {
741 $t_path = File::Spec->rel2abs($t_path);
743 chdir $use_directory or croak "Failed to chdir to '$use_directory':$!";
744 if ($pod_directory && File::Spec->file_name_is_absolute($pod_directory)) {
745 $pod_directory = File::Spec->abs2rel($pod_directory);
747 if ($t_path && File::Spec->file_name_is_absolute($t_path)) {
748 $t_path = File::Spec->abs2rel($t_path);
752 # Get Unicode version into regular and v-string. This is done now because
753 # various tables below get populated based on it. These tables are populated
754 # here to be near the top of the file, and so easily seeable by those needing
756 open my $VERSION, "<", "version"
757 or croak "$0: can't open required file 'version': $!\n";
758 my $string_version = <$VERSION>;
760 chomp $string_version;
761 my $v_version = pack "C*", split /\./, $string_version; # v string
763 # The following are the complete names of properties with property values that
764 # are known to not match any code points in some versions of Unicode, but that
765 # may change in the future so they should be matchable, hence an empty file is
766 # generated for them.
767 my @tables_that_may_be_empty = (
768 'Joining_Type=Left_Joining',
770 push @tables_that_may_be_empty, 'Script=Common' if $v_version le v4.0.1;
771 push @tables_that_may_be_empty, 'Title' if $v_version lt v2.0.0;
772 push @tables_that_may_be_empty, 'Script=Katakana_Or_Hiragana'
773 if $v_version ge v4.1.0;
775 # The lists below are hashes, so the key is the item in the list, and the
776 # value is the reason why it is in the list. This makes generation of
777 # documentation easier.
779 my %why_suppressed; # No file generated for these.
781 # Files aren't generated for empty extraneous properties. This is arguable.
782 # Extraneous properties generally come about because a property is no longer
783 # used in a newer version of Unicode. If we generated a file without code
784 # points, programs that used to work on that property will still execute
785 # without errors. It just won't ever match (or will always match, with \P{}).
786 # This means that the logic is now likely wrong. I (khw) think its better to
787 # find this out by getting an error message. Just move them to the table
788 # above to change this behavior
789 my %why_suppress_if_empty_warn_if_not = (
791 # It is the only property that has ever officially been removed from the
792 # Standard. The database never contained any code points for it.
793 'Special_Case_Condition' => 'Obsolete',
795 # Apparently never official, but there were code points in some versions of
796 # old-style PropList.txt
797 'Non_Break' => 'Obsolete',
800 # These would normally go in the warn table just above, but they were changed
801 # a long time before this program was written, so warnings about them are
803 if ($v_version gt v3.2.0) {
804 push @tables_that_may_be_empty,
805 'Canonical_Combining_Class=Attached_Below_Left'
808 # These are listed in the Property aliases file in 5.2, but Unihan is ignored
809 # unless explicitly added.
810 if ($v_version ge v5.2.0) {
811 my $unihan = 'Unihan; remove from list if using Unihan';
812 foreach my $table (qw (
816 kCompatibilityVariant
830 $why_suppress_if_empty_warn_if_not{$table} = $unihan;
834 # Properties that this program ignores.
835 my @unimplemented_properties = (
836 'Unicode_Radical_Stroke' # Remove if changing to handle this one.
839 # There are several types of obsolete properties defined by Unicode. These
840 # must be hand-edited for every new Unicode release.
841 my %why_deprecated; # Generates a deprecated warning message if used.
842 my %why_stabilized; # Documentation only
843 my %why_obsolete; # Documentation only
846 my $simple = 'Perl uses the more complete version of this property';
847 my $unihan = 'Unihan properties are by default not enabled in the Perl core. Instead use CPAN: Unicode::Unihan';
849 my $other_properties = 'other properties';
850 my $contributory = "Used by Unicode internally for generating $other_properties and not intended to be used stand-alone";
851 my $why_no_expand = "Easily computed, and yet doesn't cover the common encoding forms (UTF-16/8)",
854 'Grapheme_Link' => 'Deprecated by Unicode. Use ccc=vr (Canonical_Combining_Class=Virama) instead',
855 'Jamo_Short_Name' => $contributory,
856 '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',
857 'Other_Alphabetic' => $contributory,
858 'Other_Default_Ignorable_Code_Point' => $contributory,
859 'Other_Grapheme_Extend' => $contributory,
860 'Other_ID_Continue' => $contributory,
861 'Other_ID_Start' => $contributory,
862 'Other_Lowercase' => $contributory,
863 'Other_Math' => $contributory,
864 'Other_Uppercase' => $contributory,
868 # There is a lib/unicore/Decomposition.pl (used by normalize.pm) which
869 # contains the same information, but without the algorithmically
870 # determinable Hangul syllables'. This file is not published, so it's
871 # existence is not noted in the comment.
872 'Decomposition_Mapping' => 'Accessible via Unicode::Normalize',
874 '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',
875 '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",
877 'Simple_Case_Folding' => "$simple. Can access this through Unicode::UCD::casefold",
878 'Simple_Lowercase_Mapping' => "$simple. Can access this through Unicode::UCD::charinfo",
879 'Simple_Titlecase_Mapping' => "$simple. Can access this through Unicode::UCD::charinfo",
880 'Simple_Uppercase_Mapping' => "$simple. Can access this through Unicode::UCD::charinfo",
882 'Name' => "Accessible via 'use charnames;'",
883 'Name_Alias' => "Accessible via 'use charnames;'",
885 # These are sort of jumping the gun; deprecation is proposed for
886 # Unicode version 6.0, but they have never been exposed by Perl, and
887 # likely are soon to be deprecated, so best not to expose them.
888 FC_NFKC_Closure => 'Use NFKC_Casefold instead',
889 Expands_On_NFC => $why_no_expand,
890 Expands_On_NFD => $why_no_expand,
891 Expands_On_NFKC => $why_no_expand,
892 Expands_On_NFKD => $why_no_expand,
895 # The following are suppressed because they were made contributory or
896 # deprecated by Unicode before Perl ever thought about supporting them.
897 foreach my $property ('Jamo_Short_Name', 'Grapheme_Link') {
898 $why_suppressed{$property} = $why_deprecated{$property};
901 # Customize the message for all the 'Other_' properties
902 foreach my $property (keys %why_deprecated) {
903 next if (my $main_property = $property) !~ s/^Other_//;
904 $why_deprecated{$property} =~ s/$other_properties/the $main_property property (which should be used instead)/;
908 if ($v_version ge 4.0.0) {
909 $why_stabilized{'Hyphen'} = 'Use the Line_Break property instead; see www.unicode.org/reports/tr14';
911 if ($v_version ge 5.2.0) {
912 $why_obsolete{'ISO_Comment'} = 'Code points for it have been removed';
915 # Probably obsolete forever
916 if ($v_version ge v4.1.0) {
917 $why_suppressed{'Script=Katakana_Or_Hiragana'} = 'Obsolete. All code points previously matched by this have been moved to "Script=Common"';
920 # This program can create files for enumerated-like properties, such as
921 # 'Numeric_Type'. This file would be the same format as for a string
922 # property, with a mapping from code point to its value, so you could look up,
923 # for example, the script a code point is in. But no one so far wants this
924 # mapping, or they have found another way to get it since this is a new
925 # feature. So no file is generated except if it is in this list.
926 my @output_mapped_properties = split "\n", <<END;
929 # If you are using the Unihan database, you need to add the properties that
930 # you want to extract from it to this table. For your convenience, the
931 # properties in the 5.2 PropertyAliases.txt file are listed, commented out
932 my @cjk_properties = split "\n", <<'END';
933 #cjkAccountingNumeric; kAccountingNumeric
934 #cjkOtherNumeric; kOtherNumeric
935 #cjkPrimaryNumeric; kPrimaryNumeric
936 #cjkCompatibilityVariant; kCompatibilityVariant
938 #cjkIRG_GSource; kIRG_GSource
939 #cjkIRG_HSource; kIRG_HSource
940 #cjkIRG_JSource; kIRG_JSource
941 #cjkIRG_KPSource; kIRG_KPSource
942 #cjkIRG_KSource; kIRG_KSource
943 #cjkIRG_TSource; kIRG_TSource
944 #cjkIRG_USource; kIRG_USource
945 #cjkIRG_VSource; kIRG_VSource
946 #cjkRSUnicode; kRSUnicode ; Unicode_Radical_Stroke; URS
949 # Similarly for the property values. For your convenience, the lines in the
950 # 5.2 PropertyAliases.txt file are listed. Just remove the first BUT NOT both
952 my @cjk_property_values = split "\n", <<'END';
953 ## @missing: 0000..10FFFF; cjkAccountingNumeric; NaN
954 ## @missing: 0000..10FFFF; cjkCompatibilityVariant; <code point>
955 ## @missing: 0000..10FFFF; cjkIICore; <none>
956 ## @missing: 0000..10FFFF; cjkIRG_GSource; <none>
957 ## @missing: 0000..10FFFF; cjkIRG_HSource; <none>
958 ## @missing: 0000..10FFFF; cjkIRG_JSource; <none>
959 ## @missing: 0000..10FFFF; cjkIRG_KPSource; <none>
960 ## @missing: 0000..10FFFF; cjkIRG_KSource; <none>
961 ## @missing: 0000..10FFFF; cjkIRG_TSource; <none>
962 ## @missing: 0000..10FFFF; cjkIRG_USource; <none>
963 ## @missing: 0000..10FFFF; cjkIRG_VSource; <none>
964 ## @missing: 0000..10FFFF; cjkOtherNumeric; NaN
965 ## @missing: 0000..10FFFF; cjkPrimaryNumeric; NaN
966 ## @missing: 0000..10FFFF; cjkRSUnicode; <none>
969 # The input files don't list every code point. Those not listed are to be
970 # defaulted to some value. Below are hard-coded what those values are for
971 # non-binary properties as of 5.1. Starting in 5.0, there are
972 # machine-parsable comment lines in the files the give the defaults; so this
973 # list shouldn't have to be extended. The claim is that all missing entries
974 # for binary properties will default to 'N'. Unicode tried to change that in
975 # 5.2, but the beta period produced enough protest that they backed off.
977 # The defaults for the fields that appear in UnicodeData.txt in this hash must
978 # be in the form that it expects. The others may be synonyms.
979 my $CODE_POINT = '<code point>';
980 my %default_mapping = (
982 # Bidi_Class => Complicated; set in code
983 Bidi_Mirroring_Glyph => "",
985 Canonical_Combining_Class => 0,
986 Case_Folding => $CODE_POINT,
987 Decomposition_Mapping => $CODE_POINT,
988 Decomposition_Type => 'None',
989 East_Asian_Width => "Neutral",
990 FC_NFKC_Closure => $CODE_POINT,
991 General_Category => 'Cn',
992 Grapheme_Cluster_Break => 'Other',
993 Hangul_Syllable_Type => 'NA',
995 Jamo_Short_Name => "",
996 Joining_Group => "No_Joining_Group",
997 # Joining_Type => Complicated; set in code
998 kIICore => 'N', # Is converted to binary
999 #Line_Break => Complicated; set in code
1000 Lowercase_Mapping => $CODE_POINT,
1007 Numeric_Type => 'None',
1008 Numeric_Value => 'NaN',
1009 Script => ($v_version le 4.1.0) ? 'Common' : 'Unknown',
1010 Sentence_Break => 'Other',
1011 Simple_Case_Folding => $CODE_POINT,
1012 Simple_Lowercase_Mapping => $CODE_POINT,
1013 Simple_Titlecase_Mapping => $CODE_POINT,
1014 Simple_Uppercase_Mapping => $CODE_POINT,
1015 Titlecase_Mapping => $CODE_POINT,
1016 Unicode_1_Name => "",
1017 Unicode_Radical_Stroke => "",
1018 Uppercase_Mapping => $CODE_POINT,
1019 Word_Break => 'Other',
1022 # Below are files that Unicode furnishes, but this program ignores, and why
1023 my %ignored_files = (
1024 'CJKRadicals.txt' => 'Unihan data',
1025 'Index.txt' => 'An index, not actual data',
1026 'NamedSqProv.txt' => 'Not officially part of the Unicode standard; Append it to NamedSequences.txt if you want to process the contents.',
1027 'NamesList.txt' => 'Just adds commentary',
1028 'NormalizationCorrections.txt' => 'Data is already in other files.',
1029 'Props.txt' => 'Adds nothing to PropList.txt; only in very early releases',
1030 'ReadMe.txt' => 'Just comments',
1031 'README.TXT' => 'Just comments',
1032 'StandardizedVariants.txt' => 'Only for glyph changes, not a Unicode character property. Does not fit into current scheme where one code point is mapped',
1035 ### End of externally interesting definitions, except for @input_file_objects
1038 # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
1039 # This file is machine-generated by $0 from the Unicode
1040 # database, Version $string_version. Any changes made here will be lost!
1043 my $INTERNAL_ONLY=<<"EOF";
1045 # !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
1046 # This file is for internal use by the Perl program only. The format and even
1047 # the name or existence of this file are subject to change without notice.
1048 # Don't use it directly.
1051 my $DEVELOPMENT_ONLY=<<"EOF";
1052 # !!!!!!! DEVELOPMENT USE ONLY !!!!!!!
1053 # This file contains information artificially constrained to code points
1054 # present in Unicode release $string_compare_versions.
1055 # IT CANNOT BE RELIED ON. It is for use during development only and should
1056 # not be used for production.
1060 my $LAST_UNICODE_CODEPOINT_STRING = "10FFFF";
1061 my $LAST_UNICODE_CODEPOINT = hex $LAST_UNICODE_CODEPOINT_STRING;
1062 my $MAX_UNICODE_CODEPOINTS = $LAST_UNICODE_CODEPOINT + 1;
1064 # Matches legal code point. 4-6 hex numbers, If there are 6, the first
1065 # two must be 10; if there are 5, the first must not be a 0. Written this way
1066 # to decrease backtracking
1068 qr/ \b (?: 10[0-9A-F]{4} | [1-9A-F][0-9A-F]{4} | [0-9A-F]{4} ) \b/x;
1070 # This matches the beginning of the line in the Unicode db files that give the
1071 # defaults for code points not listed (i.e., missing) in the file. The code
1072 # depends on this ending with a semi-colon, so it can assume it is a valid
1073 # field when the line is split() by semi-colons
1074 my $missing_defaults_prefix =
1075 qr/^#\s+\@missing:\s+0000\.\.$LAST_UNICODE_CODEPOINT_STRING\s*;/;
1077 # Property types. Unicode has more types, but these are sufficient for our
1079 my $UNKNOWN = -1; # initialized to illegal value
1080 my $NON_STRING = 1; # Either binary or enum
1082 my $ENUM = 3; # Include catalog
1083 my $STRING = 4; # Anything else: string or misc
1085 # Some input files have lines that give default values for code points not
1086 # contained in the file. Sometimes these should be ignored.
1087 my $NO_DEFAULTS = 0; # Must evaluate to false
1088 my $NOT_IGNORED = 1;
1091 # Range types. Each range has a type. Most ranges are type 0, for normal,
1092 # and will appear in the main body of the tables in the output files, but
1093 # there are other types of ranges as well, listed below, that are specially
1094 # handled. There are pseudo-types as well that will never be stored as a
1095 # type, but will affect the calculation of the type.
1097 # 0 is for normal, non-specials
1098 my $MULTI_CP = 1; # Sequence of more than code point
1099 my $HANGUL_SYLLABLE = 2;
1100 my $CP_IN_NAME = 3; # The NAME contains the code point appended to it.
1101 my $NULL = 4; # The map is to the null string; utf8.c can't
1102 # handle these, nor is there an accepted syntax
1103 # for them in \p{} constructs
1104 my $COMPUTE_NO_MULTI_CP = 5; # Pseudo-type; means that ranges that would
1105 # otherwise be $MULTI_CP type are instead type 0
1107 # process_generic_property_file() can accept certain overrides in its input.
1108 # Each of these must begin AND end with $CMD_DELIM.
1109 my $CMD_DELIM = "\a";
1110 my $REPLACE_CMD = 'replace'; # Override the Replace
1111 my $MAP_TYPE_CMD = 'map_type'; # Override the Type
1116 # Values for the Replace argument to add_range.
1117 # $NO # Don't replace; add only the code points not
1119 my $IF_NOT_EQUIVALENT = 1; # Replace only under certain conditions; details in
1120 # the comments at the subroutine definition.
1121 my $UNCONDITIONALLY = 2; # Replace without conditions.
1122 my $MULTIPLE = 4; # Don't replace, but add a duplicate record if
1125 # Flags to give property statuses. The phrases are to remind maintainers that
1126 # if the flag is changed, the indefinite article referring to it in the
1127 # documentation may need to be as well.
1129 my $SUPPRESSED = 'z'; # The character should never actually be seen, since
1131 my $PLACEHOLDER = 'P'; # Implies no pod entry generated
1132 my $DEPRECATED = 'D';
1133 my $a_bold_deprecated = "a 'B<$DEPRECATED>'";
1134 my $A_bold_deprecated = "A 'B<$DEPRECATED>'";
1135 my $DISCOURAGED = 'X';
1136 my $a_bold_discouraged = "an 'B<$DISCOURAGED>'";
1137 my $A_bold_discouraged = "An 'B<$DISCOURAGED>'";
1139 my $a_bold_stricter = "a 'B<$STRICTER>'";
1140 my $A_bold_stricter = "A 'B<$STRICTER>'";
1141 my $STABILIZED = 'S';
1142 my $a_bold_stabilized = "an 'B<$STABILIZED>'";
1143 my $A_bold_stabilized = "An 'B<$STABILIZED>'";
1145 my $a_bold_obsolete = "an 'B<$OBSOLETE>'";
1146 my $A_bold_obsolete = "An 'B<$OBSOLETE>'";
1148 my %status_past_participles = (
1149 $DISCOURAGED => 'discouraged',
1150 $SUPPRESSED => 'should never be generated',
1151 $STABILIZED => 'stabilized',
1152 $OBSOLETE => 'obsolete',
1153 $DEPRECATED => 'deprecated',
1156 # The format of the values of the tables:
1157 my $EMPTY_FORMAT = "";
1158 my $BINARY_FORMAT = 'b';
1159 my $DECIMAL_FORMAT = 'd';
1160 my $FLOAT_FORMAT = 'f';
1161 my $INTEGER_FORMAT = 'i';
1162 my $HEX_FORMAT = 'x';
1163 my $RATIONAL_FORMAT = 'r';
1164 my $STRING_FORMAT = 's';
1165 my $DECOMP_STRING_FORMAT = 'c';
1167 my %map_table_formats = (
1168 $BINARY_FORMAT => 'binary',
1169 $DECIMAL_FORMAT => 'single decimal digit',
1170 $FLOAT_FORMAT => 'floating point number',
1171 $INTEGER_FORMAT => 'integer',
1172 $HEX_FORMAT => 'positive hex whole number; a code point',
1173 $RATIONAL_FORMAT => 'rational: an integer or a fraction',
1174 $STRING_FORMAT => 'string',
1175 $DECOMP_STRING_FORMAT => 'Perl\'s internal (Normalize.pm) decomposition mapping',
1178 # Unicode didn't put such derived files in a separate directory at first.
1179 my $EXTRACTED_DIR = (-d 'extracted') ? 'extracted' : "";
1180 my $EXTRACTED = ($EXTRACTED_DIR) ? "$EXTRACTED_DIR/" : "";
1181 my $AUXILIARY = 'auxiliary';
1183 # Hashes that will eventually go into Heavy.pl for the use of utf8_heavy.pl
1184 my %loose_to_file_of; # loosely maps table names to their respective
1186 my %stricter_to_file_of; # same; but for stricter mapping.
1187 my %nv_floating_to_rational; # maps numeric values floating point numbers to
1188 # their rational equivalent
1189 my %loose_property_name_of; # Loosely maps property names to standard form
1191 # These constants names and values were taken from the Unicode standard,
1192 # version 5.1, section 3.12. They are used in conjunction with Hangul
1193 # syllables. The '_string' versions are so generated tables can retain the
1194 # hex format, which is the more familiar value
1195 my $SBase_string = "0xAC00";
1196 my $SBase = CORE::hex $SBase_string;
1197 my $LBase_string = "0x1100";
1198 my $LBase = CORE::hex $LBase_string;
1199 my $VBase_string = "0x1161";
1200 my $VBase = CORE::hex $VBase_string;
1201 my $TBase_string = "0x11A7";
1202 my $TBase = CORE::hex $TBase_string;
1207 my $NCount = $VCount * $TCount;
1209 # For Hangul syllables; These store the numbers from Jamo.txt in conjunction
1210 # with the above published constants.
1212 my %Jamo_L; # Leading consonants
1213 my %Jamo_V; # Vowels
1214 my %Jamo_T; # Trailing consonants
1216 my @backslash_X_tests; # List of tests read in for testing \X
1217 my @unhandled_properties; # Will contain a list of properties found in
1218 # the input that we didn't process.
1219 my @match_properties; # Properties that have match tables, to be
1221 my @map_properties; # Properties that get map files written
1222 my @named_sequences; # NamedSequences.txt contents.
1223 my %potential_files; # Generated list of all .txt files in the directory
1224 # structure so we can warn if something is being
1226 my @files_actually_output; # List of files we generated.
1227 my @more_Names; # Some code point names are compound; this is used
1228 # to store the extra components of them.
1229 my $MIN_FRACTION_LENGTH = 3; # How many digits of a floating point number at
1230 # the minimum before we consider it equivalent to a
1231 # candidate rational
1232 my $MAX_FLOATING_SLOP = 10 ** - $MIN_FRACTION_LENGTH; # And in floating terms
1234 # These store references to certain commonly used property objects
1241 # Are there conflicting names because of beginning with 'In_', or 'Is_'
1242 my $has_In_conflicts = 0;
1243 my $has_Is_conflicts = 0;
1245 sub internal_file_to_platform ($) {
1246 # Convert our file paths which have '/' separators to those of the
1250 return undef unless defined $file;
1252 return File::Spec->join(split '/', $file);
1255 sub file_exists ($) { # platform independent '-e'. This program internally
1256 # uses slash as a path separator.
1258 return 0 if ! defined $file;
1259 return -e internal_file_to_platform($file);
1263 # Returns the address of the blessed input object.
1264 # It doesn't check for blessedness because that would do a string eval
1265 # every call, and the program is structured so that this is never called
1266 # for a non-blessed object.
1268 no overloading; # If overloaded, numifying below won't work.
1270 # Numifying a ref gives its address.
1271 return pack 'J', $_[0];
1274 # These are used only if $annotate is true.
1275 # The entire range of Unicode characters is examined to populate these
1276 # after all the input has been processed. But most can be skipped, as they
1277 # have the same descriptive phrases, such as being unassigned
1278 my @viacode; # Contains the 1 million character names
1279 my @printable; # boolean: And are those characters printable?
1280 my @annotate_char_type; # Contains a type of those characters, specifically
1281 # for the purposes of annotation.
1282 my $annotate_ranges; # A map of ranges of code points that have the same
1283 # name for the purposes of annoation. They map to the
1284 # upper edge of the range, so that the end point can
1285 # be immediately found. This is used to skip ahead to
1286 # the end of a range, and avoid processing each
1287 # individual code point in it.
1288 my $unassigned_sans_noncharacters; # A Range_List of the unassigned
1289 # characters, but excluding those which are
1290 # also noncharacter code points
1292 # The annotation types are an extension of the regular range types, though
1293 # some of the latter are folded into one. Make the new types negative to
1294 # avoid conflicting with the regular types
1295 my $SURROGATE_TYPE = -1;
1296 my $UNASSIGNED_TYPE = -2;
1297 my $PRIVATE_USE_TYPE = -3;
1298 my $NONCHARACTER_TYPE = -4;
1299 my $CONTROL_TYPE = -5;
1300 my $UNKNOWN_TYPE = -6; # Used only if there is a bug in this program
1302 sub populate_char_info ($) {
1303 # Used only with the $annotate option. Populates the arrays with the
1304 # input code point's info that are needed for outputting more detailed
1305 # comments. If calling context wants a return, it is the end point of
1306 # any contiguous range of characters that share essentially the same info
1309 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
1311 $viacode[$i] = $perl_charname->value_of($i) || "";
1313 # A character is generally printable if Unicode says it is,
1314 # but below we make sure that most Unicode general category 'C' types
1316 $printable[$i] = $print->contains($i);
1318 $annotate_char_type[$i] = $perl_charname->type_of($i) || 0;
1320 # Only these two regular types are treated specially for annotations
1322 $annotate_char_type[$i] = 0 if $annotate_char_type[$i] != $CP_IN_NAME
1323 && $annotate_char_type[$i] != $HANGUL_SYLLABLE;
1325 # Give a generic name to all code points that don't have a real name.
1326 # We output ranges, if applicable, for these. Also calculate the end
1327 # point of the range.
1329 if (! $viacode[$i]) {
1330 if ($gc-> table('Surrogate')->contains($i)) {
1331 $viacode[$i] = 'Surrogate';
1332 $annotate_char_type[$i] = $SURROGATE_TYPE;
1334 $end = $gc->table('Surrogate')->containing_range($i)->end;
1336 elsif ($gc-> table('Private_use')->contains($i)) {
1337 $viacode[$i] = 'Private Use';
1338 $annotate_char_type[$i] = $PRIVATE_USE_TYPE;
1340 $end = $gc->table('Private_Use')->containing_range($i)->end;
1342 elsif (Property::property_ref('Noncharacter_Code_Point')-> table('Y')->
1345 $viacode[$i] = 'Noncharacter';
1346 $annotate_char_type[$i] = $NONCHARACTER_TYPE;
1348 $end = property_ref('Noncharacter_Code_Point')->table('Y')->
1349 containing_range($i)->end;
1351 elsif ($gc-> table('Control')->contains($i)) {
1352 $viacode[$i] = 'Control';
1353 $annotate_char_type[$i] = $CONTROL_TYPE;
1355 $end = 0x81 if $i == 0x80; # Hard-code this one known case
1357 elsif ($gc-> table('Unassigned')->contains($i)) {
1358 $viacode[$i] = 'Unassigned, block=' . $block-> value_of($i);
1359 $annotate_char_type[$i] = $UNASSIGNED_TYPE;
1362 # Because we name the unassigned by the blocks they are in, it
1363 # can't go past the end of that block, and it also can't go past
1364 # the unassigned range it is in. The special table makes sure
1365 # that the non-characters, which are unassigned, are separated
1367 $end = min($block->containing_range($i)->end,
1368 $unassigned_sans_noncharacters-> containing_range($i)->
1371 my_carp_bug("Can't figure out how to annotate"
1372 . sprintf("U+%04X", $i)
1373 . "Proceeding anyway.");
1374 $viacode[$i] = 'UNKNOWN';
1375 $annotate_char_type[$i] = $UNKNOWN_TYPE;
1380 # Here, has a name, but if it's one in which the code point number is
1381 # appended to the name, do that.
1382 elsif ($annotate_char_type[$i] == $CP_IN_NAME) {
1383 $viacode[$i] .= sprintf("-%04X", $i);
1384 $end = $perl_charname->containing_range($i)->end;
1387 # And here, has a name, but if it's a hangul syllable one, replace it with
1388 # the correct name from the Unicode algorithm
1389 elsif ($annotate_char_type[$i] == $HANGUL_SYLLABLE) {
1391 my $SIndex = $i - $SBase;
1392 my $L = $LBase + $SIndex / $NCount;
1393 my $V = $VBase + ($SIndex % $NCount) / $TCount;
1394 my $T = $TBase + $SIndex % $TCount;
1395 $viacode[$i] = "HANGUL SYLLABLE $Jamo{$L}$Jamo{$V}";
1396 $viacode[$i] .= $Jamo{$T} if $T != $TBase;
1397 $end = $perl_charname->containing_range($i)->end;
1400 return if ! defined wantarray;
1401 return $i if ! defined $end; # If not a range, return the input
1403 # Save this whole range so can find the end point quickly
1404 $annotate_ranges->add_map($i, $end, $end);
1409 # Commented code below should work on Perl 5.8.
1410 ## This 'require' doesn't necessarily work in miniperl, and even if it does,
1411 ## the native perl version of it (which is what would operate under miniperl)
1412 ## is extremely slow, as it does a string eval every call.
1413 #my $has_fast_scalar_util = $
\18 !~ /miniperl/
1414 # && defined eval "require Scalar::Util";
1417 # # Returns the address of the blessed input object. Uses the XS version if
1418 # # available. It doesn't check for blessedness because that would do a
1419 # # string eval every call, and the program is structured so that this is
1420 # # never called for a non-blessed object.
1422 # return Scalar::Util::refaddr($_[0]) if $has_fast_scalar_util;
1424 # # Check at least that is a ref.
1425 # my $pkg = ref($_[0]) or return undef;
1427 # # Change to a fake package to defeat any overloaded stringify
1428 # bless $_[0], 'main::Fake';
1430 # # Numifying a ref gives its address.
1431 # my $addr = pack 'J', $_[0];
1433 # # Return to original class
1434 # bless $_[0], $pkg;
1441 return $a if $a >= $b;
1448 return $a if $a <= $b;
1452 sub clarify_number ($) {
1453 # This returns the input number with underscores inserted every 3 digits
1454 # in large (5 digits or more) numbers. Input must be entirely digits, not
1458 my $pos = length($number) - 3;
1459 return $number if $pos <= 1;
1461 substr($number, $pos, 0) = '_';
1470 # These routines give a uniform treatment of messages in this program. They
1471 # are placed in the Carp package to cause the stack trace to not include them,
1472 # although an alternative would be to use another package and set @CARP_NOT
1475 our $Verbose = 1 if main::DEBUG; # Useful info when debugging
1477 # This is a work-around suggested by Nicholas Clark to fix a problem with Carp
1478 # and overload trying to load Scalar:Util under miniperl. See
1479 # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2009-11/msg01057.html
1480 undef $overload::VERSION;
1483 my $message = shift || "";
1484 my $nofold = shift || 0;
1487 $message = main::join_lines($message);
1488 $message =~ s/^$0: *//; # Remove initial program name
1489 $message =~ s/[.;,]+$//; # Remove certain ending punctuation
1490 $message = "\n$0: $message;";
1492 # Fold the message with program name, semi-colon end punctuation
1493 # (which looks good with the message that carp appends to it), and a
1494 # hanging indent for continuation lines.
1495 $message = main::simple_fold($message, "", 4) unless $nofold;
1496 $message =~ s/\n$//; # Remove the trailing nl so what carp
1497 # appends is to the same line
1500 return $message if defined wantarray; # If a caller just wants the msg
1507 # This is called when it is clear that the problem is caused by a bug in
1510 my $message = shift;
1511 $message =~ s/^$0: *//;
1512 $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");
1517 sub carp_too_few_args {
1519 my_carp_bug("Wrong number of arguments: to 'carp_too_few_arguments'. No action taken.");
1523 my $args_ref = shift;
1526 my_carp_bug("Need at least $count arguments to "
1528 . ". Instead got: '"
1529 . join ', ', @$args_ref
1530 . "'. No action taken.");
1534 sub carp_extra_args {
1535 my $args_ref = shift;
1536 my_carp_bug("Too many arguments to 'carp_extra_args': (" . join(', ', @_) . "); Extras ignored.") if @_;
1538 unless (ref $args_ref) {
1539 my_carp_bug("Argument to 'carp_extra_args' ($args_ref) must be a ref. Not checking arguments.");
1542 my ($package, $file, $line) = caller;
1543 my $subroutine = (caller 1)[3];
1546 if (ref $args_ref eq 'HASH') {
1547 foreach my $key (keys %$args_ref) {
1548 $args_ref->{$key} = $UNDEF unless defined $args_ref->{$key};
1550 $list = join ', ', each %{$args_ref};
1552 elsif (ref $args_ref eq 'ARRAY') {
1553 foreach my $arg (@$args_ref) {
1554 $arg = $UNDEF unless defined $arg;
1556 $list = join ', ', @$args_ref;
1559 my_carp_bug("Can't cope with ref "
1561 . " . argument to 'carp_extra_args'. Not checking arguments.");
1565 my_carp_bug("Unrecognized parameters in options: '$list' to $subroutine. Skipped.");
1573 # This program uses the inside-out method for objects, as recommended in
1574 # "Perl Best Practices". This closure aids in generating those. There
1575 # are two routines. setup_package() is called once per package to set
1576 # things up, and then set_access() is called for each hash representing a
1577 # field in the object. These routines arrange for the object to be
1578 # properly destroyed when no longer used, and for standard accessor
1579 # functions to be generated. If you need more complex accessors, just
1580 # write your own and leave those accesses out of the call to set_access().
1581 # More details below.
1583 my %constructor_fields; # fields that are to be used in constructors; see
1586 # The values of this hash will be the package names as keys to other
1587 # hashes containing the name of each field in the package as keys, and
1588 # references to their respective hashes as values.
1592 # Sets up the package, creating standard DESTROY and dump methods
1593 # (unless already defined). The dump method is used in debugging by
1595 # The optional parameters are:
1596 # a) a reference to a hash, that gets populated by later
1597 # set_access() calls with one of the accesses being
1598 # 'constructor'. The caller can then refer to this, but it is
1599 # not otherwise used by these two routines.
1600 # b) a reference to a callback routine to call during destruction
1601 # of the object, before any fields are actually destroyed
1604 my $constructor_ref = delete $args{'Constructor_Fields'};
1605 my $destroy_callback = delete $args{'Destroy_Callback'};
1606 Carp::carp_extra_args(\@_) if main::DEBUG && %args;
1609 my $package = (caller)[0];
1611 $package_fields{$package} = \%fields;
1612 $constructor_fields{$package} = $constructor_ref;
1614 unless ($package->can('DESTROY')) {
1615 my $destroy_name = "${package}::DESTROY";
1618 # Use typeglob to give the anonymous subroutine the name we want
1619 *$destroy_name = sub {
1621 my $addr = do { no overloading; pack 'J', $self; };
1623 $self->$destroy_callback if $destroy_callback;
1624 foreach my $field (keys %{$package_fields{$package}}) {
1625 #print STDERR __LINE__, ": Destroying ", ref $self, " ", sprintf("%04X", $addr), ": ", $field, "\n";
1626 delete $package_fields{$package}{$field}{$addr};
1632 unless ($package->can('dump')) {
1633 my $dump_name = "${package}::dump";
1637 return dump_inside_out($self, $package_fields{$package}, @_);
1644 # Arrange for the input field to be garbage collected when no longer
1645 # needed. Also, creates standard accessor functions for the field
1646 # based on the optional parameters-- none if none of these parameters:
1647 # 'addable' creates an 'add_NAME()' accessor function.
1648 # 'readable' or 'readable_array' creates a 'NAME()' accessor
1650 # 'settable' creates a 'set_NAME()' accessor function.
1651 # 'constructor' doesn't create an accessor function, but adds the
1652 # field to the hash that was previously passed to
1654 # Any of the accesses can be abbreviated down, so that 'a', 'ad',
1655 # 'add' etc. all mean 'addable'.
1656 # The read accessor function will work on both array and scalar
1657 # values. If another accessor in the parameter list is 'a', the read
1658 # access assumes an array. You can also force it to be array access
1659 # by specifying 'readable_array' instead of 'readable'
1661 # A sort-of 'protected' access can be set-up by preceding the addable,
1662 # readable or settable with some initial portion of 'protected_' (but,
1663 # the underscore is required), like 'p_a', 'pro_set', etc. The
1664 # "protection" is only by convention. All that happens is that the
1665 # accessor functions' names begin with an underscore. So instead of
1666 # calling set_foo, the call is _set_foo. (Real protection could be
1667 # accomplished by having a new subroutine, end_package, called at the
1668 # end of each package, and then storing the __LINE__ ranges and
1669 # checking them on every accessor. But that is way overkill.)
1671 # We create anonymous subroutines as the accessors and then use
1672 # typeglobs to assign them to the proper package and name
1674 my $name = shift; # Name of the field
1675 my $field = shift; # Reference to the inside-out hash containing the
1678 my $package = (caller)[0];
1680 if (! exists $package_fields{$package}) {
1681 croak "$0: Must call 'setup_package' before 'set_access'";
1684 # Stash the field so DESTROY can get it.
1685 $package_fields{$package}{$name} = $field;
1687 # Remaining arguments are the accessors. For each...
1688 foreach my $access (@_) {
1689 my $access = lc $access;
1693 # Match the input as far as it goes.
1694 if ($access =~ /^(p[^_]*)_/) {
1696 if (substr('protected_', 0, length $protected)
1700 # Add 1 for the underscore not included in $protected
1701 $access = substr($access, length($protected) + 1);
1709 if (substr('addable', 0, length $access) eq $access) {
1710 my $subname = "${package}::${protected}add_$name";
1713 # add_ accessor. Don't add if already there, which we
1714 # determine using 'eq' for scalars and '==' otherwise.
1717 return Carp::carp_too_few_args(\@_, 2) if main::DEBUG && @_ < 2;
1720 my $addr = do { no overloading; pack 'J', $self; };
1721 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
1723 return if grep { $value == $_ } @{$field->{$addr}};
1726 return if grep { $value eq $_ } @{$field->{$addr}};
1728 push @{$field->{$addr}}, $value;
1732 elsif (substr('constructor', 0, length $access) eq $access) {
1734 Carp::my_carp_bug("Can't set-up 'protected' constructors")
1737 $constructor_fields{$package}{$name} = $field;
1740 elsif (substr('readable_array', 0, length $access) eq $access) {
1742 # Here has read access. If one of the other parameters for
1743 # access is array, or this one specifies array (by being more
1744 # than just 'readable_'), then create a subroutine that
1745 # assumes the data is an array. Otherwise just a scalar
1746 my $subname = "${package}::${protected}$name";
1747 if (grep { /^a/i } @_
1748 or length($access) > length('readable_'))
1753 Carp::carp_extra_args(\@_) if main::DEBUG && @_ > 1;
1754 my $addr = do { no overloading; pack 'J', $_[0]; };
1755 if (ref $field->{$addr} ne 'ARRAY') {
1756 my $type = ref $field->{$addr};
1757 $type = 'scalar' unless $type;
1758 Carp::my_carp_bug("Trying to read $name as an array when it is a $type. Big problems.");
1761 return scalar @{$field->{$addr}} unless wantarray;
1763 # Make a copy; had problems with caller modifying the
1764 # original otherwise
1765 my @return = @{$field->{$addr}};
1771 # Here not an array value, a simpler function.
1775 Carp::carp_extra_args(\@_) if main::DEBUG && @_ > 1;
1777 return $field->{pack 'J', $_[0]};
1781 elsif (substr('settable', 0, length $access) eq $access) {
1782 my $subname = "${package}::${protected}set_$name";
1787 return Carp::carp_too_few_args(\@_, 2) if @_ < 2;
1788 Carp::carp_extra_args(\@_) if @_ > 2;
1790 # $self is $_[0]; $value is $_[1]
1792 $field->{pack 'J', $_[0]} = $_[1];
1797 Carp::my_carp_bug("Unknown accessor type $access. No accessor set.");
1806 # All input files use this object, which stores various attributes about them,
1807 # and provides for convenient, uniform handling. The run method wraps the
1808 # processing. It handles all the bookkeeping of opening, reading, and closing
1809 # the file, returning only significant input lines.
1811 # Each object gets a handler which processes the body of the file, and is
1812 # called by run(). Most should use the generic, default handler, which has
1813 # code scrubbed to handle things you might not expect. A handler should
1814 # basically be a while(next_line()) {...} loop.
1816 # You can also set up handlers to
1817 # 1) call before the first line is read for pre processing
1818 # 2) call to adjust each line of the input before the main handler gets them
1819 # 3) call upon EOF before the main handler exits its loop
1820 # 4) call at the end for post processing
1822 # $_ is used to store the input line, and is to be filtered by the
1823 # each_line_handler()s. So, if the format of the line is not in the desired
1824 # format for the main handler, these are used to do that adjusting. They can
1825 # be stacked (by enclosing them in an [ anonymous array ] in the constructor,
1826 # so the $_ output of one is used as the input to the next. None of the other
1827 # handlers are stackable, but could easily be changed to be so.
1829 # Most of the handlers can call insert_lines() or insert_adjusted_lines()
1830 # which insert the parameters as lines to be processed before the next input
1831 # file line is read. This allows the EOF handler to flush buffers, for
1832 # example. The difference between the two routines is that the lines inserted
1833 # by insert_lines() are subjected to the each_line_handler()s. (So if you
1834 # called it from such a handler, you would get infinite recursion.) Lines
1835 # inserted by insert_adjusted_lines() go directly to the main handler without
1836 # any adjustments. If the post-processing handler calls any of these, there
1837 # will be no effect. Some error checking for these conditions could be added,
1838 # but it hasn't been done.
1840 # carp_bad_line() should be called to warn of bad input lines, which clears $_
1841 # to prevent further processing of the line. This routine will output the
1842 # message as a warning once, and then keep a count of the lines that have the
1843 # same message, and output that count at the end of the file's processing.
1844 # This keeps the number of messages down to a manageable amount.
1846 # get_missings() should be called to retrieve any @missing input lines.
1847 # Messages will be raised if this isn't done if the options aren't to ignore
1850 sub trace { return main::trace(@_); }
1853 # Keep track of fields that are to be put into the constructor.
1854 my %constructor_fields;
1856 main::setup_package(Constructor_Fields => \%constructor_fields);
1858 my %file; # Input file name, required
1859 main::set_access('file', \%file, qw{ c r });
1861 my %first_released; # Unicode version file was first released in, required
1862 main::set_access('first_released', \%first_released, qw{ c r });
1864 my %handler; # Subroutine to process the input file, defaults to
1865 # 'process_generic_property_file'
1866 main::set_access('handler', \%handler, qw{ c });
1869 # name of property this file is for. defaults to none, meaning not
1870 # applicable, or is otherwise determinable, for example, from each line.
1871 main::set_access('property', \%property, qw{ c });
1874 # If this is true, the file is optional. If not present, no warning is
1875 # output. If it is present, the string given by this parameter is
1876 # evaluated, and if false the file is not processed.
1877 main::set_access('optional', \%optional, 'c', 'r');
1880 # This is used for debugging, to skip processing of all but a few input
1881 # files. Add 'non_skip => 1' to the constructor for those files you want
1882 # processed when you set the $debug_skip global.
1883 main::set_access('non_skip', \%non_skip, 'c');
1886 # This is used to skip processing of this input file semi-permanently.
1887 # It is used for files that we aren't planning to process anytime soon,
1888 # but want to allow to be in the directory and not raise a message that we
1889 # are not handling. Mostly for test files. This is in contrast to the
1890 # non_skip element, which is supposed to be used very temporarily for
1891 # debugging. Sets 'optional' to 1
1892 main::set_access('skip', \%skip, 'c');
1894 my %each_line_handler;
1895 # list of subroutines to look at and filter each non-comment line in the
1896 # file. defaults to none. The subroutines are called in order, each is
1897 # to adjust $_ for the next one, and the final one adjusts it for
1899 main::set_access('each_line_handler', \%each_line_handler, 'c');
1901 my %has_missings_defaults;
1902 # ? Are there lines in the file giving default values for code points
1903 # missing from it?. Defaults to NO_DEFAULTS. Otherwise NOT_IGNORED is
1904 # the norm, but IGNORED means it has such lines, but the handler doesn't
1905 # use them. Having these three states allows us to catch changes to the
1906 # UCD that this program should track
1907 main::set_access('has_missings_defaults',
1908 \%has_missings_defaults, qw{ c r });
1911 # Subroutine to call before doing anything else in the file. If undef, no
1912 # such handler is called.
1913 main::set_access('pre_handler', \%pre_handler, qw{ c });
1916 # Subroutine to call upon getting an EOF on the input file, but before
1917 # that is returned to the main handler. This is to allow buffers to be
1918 # flushed. The handler is expected to call insert_lines() or
1919 # insert_adjusted() with the buffered material
1920 main::set_access('eof_handler', \%eof_handler, qw{ c r });
1923 # Subroutine to call after all the lines of the file are read in and
1924 # processed. If undef, no such handler is called.
1925 main::set_access('post_handler', \%post_handler, qw{ c });
1927 my %progress_message;
1928 # Message to print to display progress in lieu of the standard one
1929 main::set_access('progress_message', \%progress_message, qw{ c });
1932 # cache open file handle, internal. Is undef if file hasn't been
1933 # processed at all, empty if has;
1934 main::set_access('handle', \%handle);
1937 # cache of lines added virtually to the file, internal
1938 main::set_access('added_lines', \%added_lines);
1941 # cache of errors found, internal
1942 main::set_access('errors', \%errors);
1945 # storage of '@missing' defaults lines
1946 main::set_access('missings', \%missings);
1951 my $self = bless \do{ my $anonymous_scalar }, $class;
1952 my $addr = do { no overloading; pack 'J', $self; };
1955 $handler{$addr} = \&main::process_generic_property_file;
1956 $non_skip{$addr} = 0;
1958 $has_missings_defaults{$addr} = $NO_DEFAULTS;
1959 $handle{$addr} = undef;
1960 $added_lines{$addr} = [ ];
1961 $each_line_handler{$addr} = [ ];
1962 $errors{$addr} = { };
1963 $missings{$addr} = [ ];
1965 # Two positional parameters.
1966 return Carp::carp_too_few_args(\@_, 2) if main::DEBUG && @_ < 2;
1967 $file{$addr} = main::internal_file_to_platform(shift);
1968 $first_released{$addr} = shift;
1970 # The rest of the arguments are key => value pairs
1971 # %constructor_fields has been set up earlier to list all possible
1972 # ones. Either set or push, depending on how the default has been set
1975 foreach my $key (keys %args) {
1976 my $argument = $args{$key};
1978 # Note that the fields are the lower case of the constructor keys
1979 my $hash = $constructor_fields{lc $key};
1980 if (! defined $hash) {
1981 Carp::my_carp_bug("Unrecognized parameters '$key => $argument' to new() for $self. Skipped");
1984 if (ref $hash->{$addr} eq 'ARRAY') {
1985 if (ref $argument eq 'ARRAY') {
1986 foreach my $argument (@{$argument}) {
1987 next if ! defined $argument;
1988 push @{$hash->{$addr}}, $argument;
1992 push @{$hash->{$addr}}, $argument if defined $argument;
1996 $hash->{$addr} = $argument;
2001 # If the file has a property for it, it means that the property is not
2002 # listed in the file's entries. So add a handler to the list of line
2003 # handlers to insert the property name into the lines, to provide a
2004 # uniform interface to the final processing subroutine.
2005 # the final code doesn't have to worry about that.
2006 if ($property{$addr}) {
2007 push @{$each_line_handler{$addr}}, \&_insert_property_into_line;
2010 if ($non_skip{$addr} && ! $debug_skip && $verbosity) {
2011 print "Warning: " . __PACKAGE__ . " constructor for $file{$addr} has useless 'non_skip' in it\n";
2014 $optional{$addr} = 1 if $skip{$addr};
2022 qw("") => "_operator_stringify",
2023 "." => \&main::_operator_dot,
2026 sub _operator_stringify {
2029 return __PACKAGE__ . " object for " . $self->file;
2032 # flag to make sure extracted files are processed early
2033 my $seen_non_extracted_non_age = 0;
2036 # Process the input object $self. This opens and closes the file and
2037 # calls all the handlers for it. Currently, this can only be called
2038 # once per file, as it destroy's the EOF handler
2041 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2043 my $addr = do { no overloading; pack 'J', $self; };
2045 my $file = $file{$addr};
2047 # Don't process if not expecting this file (because released later
2048 # than this Unicode version), and isn't there. This means if someone
2049 # copies it into an earlier version's directory, we will go ahead and
2051 return if $first_released{$addr} gt $v_version && ! -e $file;
2053 # If in debugging mode and this file doesn't have the non-skip
2054 # flag set, and isn't one of the critical files, skip it.
2056 && $first_released{$addr} ne v0
2057 && ! $non_skip{$addr})
2059 print "Skipping $file in debugging\n" if $verbosity;
2063 # File could be optional
2064 if ($optional{$addr}) {
2065 return unless -e $file;
2066 my $result = eval $optional{$addr};
2067 if (! defined $result) {
2068 Carp::my_carp_bug("Got '$@' when tried to eval $optional{$addr}. $file Skipped.");
2073 print STDERR "Skipping processing input file '$file' because '$optional{$addr}' is not true\n";
2079 if (! defined $file || ! -e $file) {
2081 # If the file doesn't exist, see if have internal data for it
2082 # (based on first_released being 0).
2083 if ($first_released{$addr} eq v0) {
2084 $handle{$addr} = 'pretend_is_open';
2087 if (! $optional{$addr} # File could be optional
2088 && $v_version ge $first_released{$addr})
2090 print STDERR "Skipping processing input file '$file' because not found\n" if $v_version ge $first_released{$addr};
2097 # Here, the file exists. Some platforms may change the case of
2099 if ($seen_non_extracted_non_age) {
2100 if ($file =~ /$EXTRACTED/i) {
2101 Carp::my_carp_bug(join_lines(<<END
2102 $file should be processed just after the 'Prop...Alias' files, and before
2103 anything not in the $EXTRACTED_DIR directory. Proceeding, but the results may
2104 have subtle problems
2109 elsif ($EXTRACTED_DIR
2110 && $first_released{$addr} ne v0
2111 && $file !~ /$EXTRACTED/i
2112 && lc($file) ne 'dage.txt')
2114 # We don't set this (by the 'if' above) if we have no
2115 # extracted directory, so if running on an early version,
2116 # this test won't work. Not worth worrying about.
2117 $seen_non_extracted_non_age = 1;
2120 # And mark the file as having being processed, and warn if it
2121 # isn't a file we are expecting. As we process the files,
2122 # they are deleted from the hash, so any that remain at the
2123 # end of the program are files that we didn't process.
2124 my $fkey = File::Spec->rel2abs($file);
2125 my $expecting = delete $potential_files{$fkey};
2126 $expecting = delete $potential_files{lc($fkey)} unless defined $expecting;
2127 Carp::my_carp("Was not expecting '$file'.") if
2129 && ! defined $handle{$addr};
2131 # Having deleted from expected files, we can quit if not to do
2132 # anything. Don't print progress unless really want verbosity
2134 print "Skipping $file.\n" if $verbosity >= $VERBOSE;
2138 # Open the file, converting the slashes used in this program
2139 # into the proper form for the OS
2141 if (not open $file_handle, "<", $file) {
2142 Carp::my_carp("Can't open $file. Skipping: $!");
2145 $handle{$addr} = $file_handle; # Cache the open file handle
2148 if ($verbosity >= $PROGRESS) {
2149 if ($progress_message{$addr}) {
2150 print "$progress_message{$addr}\n";
2153 # If using a virtual file, say so.
2154 print "Processing ", (-e $file)
2156 : "substitute $file",
2162 # Call any special handler for before the file.
2163 &{$pre_handler{$addr}}($self) if $pre_handler{$addr};
2165 # Then the main handler
2166 &{$handler{$addr}}($self);
2168 # Then any special post-file handler.
2169 &{$post_handler{$addr}}($self) if $post_handler{$addr};
2171 # If any errors have been accumulated, output the counts (as the first
2172 # error message in each class was output when it was encountered).
2173 if ($errors{$addr}) {
2176 foreach my $error (keys %{$errors{$addr}}) {
2177 $total += $errors{$addr}->{$error};
2178 delete $errors{$addr}->{$error};
2183 = "A total of $total lines had errors in $file. ";
2185 $message .= ($types == 1)
2186 ? '(Only the first one was displayed.)'
2187 : '(Only the first of each type was displayed.)';
2188 Carp::my_carp($message);
2192 if (@{$missings{$addr}}) {
2193 Carp::my_carp_bug("Handler for $file didn't look at all the \@missing lines. Generated tables likely are wrong");
2196 # If a real file handle, close it.
2197 close $handle{$addr} or Carp::my_carp("Can't close $file: $!") if
2199 $handle{$addr} = ""; # Uses empty to indicate that has already seen
2200 # the file, as opposed to undef
2205 # Sets $_ to be the next logical input line, if any. Returns non-zero
2206 # if such a line exists. 'logical' means that any lines that have
2207 # been added via insert_lines() will be returned in $_ before the file
2211 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2213 my $addr = do { no overloading; pack 'J', $self; };
2215 # Here the file is open (or if the handle is not a ref, is an open
2216 # 'virtual' file). Get the next line; any inserted lines get priority
2217 # over the file itself.
2221 while (1) { # Loop until find non-comment, non-empty line
2222 #local $to_trace = 1 if main::DEBUG;
2223 my $inserted_ref = shift @{$added_lines{$addr}};
2224 if (defined $inserted_ref) {
2225 ($adjusted, $_) = @{$inserted_ref};
2226 trace $adjusted, $_ if main::DEBUG && $to_trace;
2227 return 1 if $adjusted;
2230 last if ! ref $handle{$addr}; # Don't read unless is real file
2231 last if ! defined ($_ = readline $handle{$addr});
2234 trace $_ if main::DEBUG && $to_trace;
2236 # See if this line is the comment line that defines what property
2237 # value that code points that are not listed in the file should
2238 # have. The format or existence of these lines is not guaranteed
2239 # by Unicode since they are comments, but the documentation says
2240 # that this was added for machine-readability, so probably won't
2241 # change. This works starting in Unicode Version 5.0. They look
2244 # @missing: 0000..10FFFF; Not_Reordered
2245 # @missing: 0000..10FFFF; Decomposition_Mapping; <code point>
2246 # @missing: 0000..10FFFF; ; NaN
2248 # Save the line for a later get_missings() call.
2249 if (/$missing_defaults_prefix/) {
2250 if ($has_missings_defaults{$addr} == $NO_DEFAULTS) {
2251 $self->carp_bad_line("Unexpected \@missing line. Assuming no missing entries");
2253 elsif ($has_missings_defaults{$addr} == $NOT_IGNORED) {
2254 my @defaults = split /\s* ; \s*/x, $_;
2256 # The first field is the @missing, which ends in a
2257 # semi-colon, so can safely shift.
2260 # Some of these lines may have empty field placeholders
2261 # which get in the way. An example is:
2262 # @missing: 0000..10FFFF; ; NaN
2263 # Remove them. Process starting from the top so the
2264 # splice doesn't affect things still to be looked at.
2265 for (my $i = @defaults - 1; $i >= 0; $i--) {
2266 next if $defaults[$i] ne "";
2267 splice @defaults, $i, 1;
2270 # What's left should be just the property (maybe) and the
2271 # default. Having only one element means it doesn't have
2275 if (@defaults >= 1) {
2276 if (@defaults == 1) {
2277 $default = $defaults[0];
2280 $property = $defaults[0];
2281 $default = $defaults[1];
2287 || ($default =~ /^</
2288 && $default !~ /^<code *point>$/i
2289 && $default !~ /^<none>$/i))
2291 $self->carp_bad_line("Unrecognized \@missing line: $_. Assuming no missing entries");
2295 # If the property is missing from the line, it should
2296 # be the one for the whole file
2297 $property = $property{$addr} if ! defined $property;
2299 # Change <none> to the null string, which is what it
2300 # really means. If the default is the code point
2301 # itself, set it to <code point>, which is what
2302 # Unicode uses (but sometimes they've forgotten the
2304 if ($default =~ /^<none>$/i) {
2307 elsif ($default =~ /^<code *point>$/i) {
2308 $default = $CODE_POINT;
2311 # Store them as a sub-arrays with both components.
2312 push @{$missings{$addr}}, [ $default, $property ];
2316 # There is nothing for the caller to process on this comment
2321 # Remove comments and trailing space, and skip this line if the
2327 # Call any handlers for this line, and skip further processing of
2328 # the line if the handler sets the line to null.
2329 foreach my $sub_ref (@{$each_line_handler{$addr}}) {
2334 # Here the line is ok. return success.
2336 } # End of looping through lines.
2338 # If there is an EOF handler, call it (only once) and if it generates
2339 # more lines to process go back in the loop to handle them.
2340 if ($eof_handler{$addr}) {
2341 &{$eof_handler{$addr}}($self);
2342 $eof_handler{$addr} = ""; # Currently only get one shot at it.
2343 goto LINE if $added_lines{$addr};
2346 # Return failure -- no more lines.
2351 # Not currently used, not fully tested.
2353 # # Non-destructive look-ahead one non-adjusted, non-comment, non-blank
2354 # # record. Not callable from an each_line_handler(), nor does it call
2355 # # an each_line_handler() on the line.
2358 # my $addr = do { no overloading; pack 'J', $self; };
2360 # foreach my $inserted_ref (@{$added_lines{$addr}}) {
2361 # my ($adjusted, $line) = @{$inserted_ref};
2362 # next if $adjusted;
2364 # # Remove comments and trailing space, and return a non-empty
2367 # $line =~ s/\s+$//;
2368 # return $line if $line ne "";
2371 # return if ! ref $handle{$addr}; # Don't read unless is real file
2372 # while (1) { # Loop until find non-comment, non-empty line
2373 # local $to_trace = 1 if main::DEBUG;
2374 # trace $_ if main::DEBUG && $to_trace;
2375 # return if ! defined (my $line = readline $handle{$addr});
2377 # push @{$added_lines{$addr}}, [ 0, $line ];
2380 # $line =~ s/\s+$//;
2381 # return $line if $line ne "";
2389 # Lines can be inserted so that it looks like they were in the input
2390 # file at the place it was when this routine is called. See also
2391 # insert_adjusted_lines(). Lines inserted via this routine go through
2392 # any each_line_handler()
2396 # Each inserted line is an array, with the first element being 0 to
2397 # indicate that this line hasn't been adjusted, and needs to be
2400 push @{$added_lines{pack 'J', $self}}, map { [ 0, $_ ] } @_;
2404 sub insert_adjusted_lines {
2405 # Lines can be inserted so that it looks like they were in the input
2406 # file at the place it was when this routine is called. See also
2407 # insert_lines(). Lines inserted via this routine are already fully
2408 # adjusted, ready to be processed; each_line_handler()s handlers will
2409 # not be called. This means this is not a completely general
2410 # facility, as only the last each_line_handler on the stack should
2411 # call this. It could be made more general, by passing to each of the
2412 # line_handlers their position on the stack, which they would pass on
2413 # to this routine, and that would replace the boolean first element in
2414 # the anonymous array pushed here, so that the next_line routine could
2415 # use that to call only those handlers whose index is after it on the
2416 # stack. But this is overkill for what is needed now.
2419 trace $_[0] if main::DEBUG && $to_trace;
2421 # Each inserted line is an array, with the first element being 1 to
2422 # indicate that this line has been adjusted
2424 push @{$added_lines{pack 'J', $self}}, map { [ 1, $_ ] } @_;
2429 # Returns the stored up @missings lines' values, and clears the list.
2430 # The values are in an array, consisting of the default in the first
2431 # element, and the property in the 2nd. However, since these lines
2432 # can be stacked up, the return is an array of all these arrays.
2435 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2437 my $addr = do { no overloading; pack 'J', $self; };
2439 # If not accepting a list return, just return the first one.
2440 return shift @{$missings{$addr}} unless wantarray;
2442 my @return = @{$missings{$addr}};
2443 undef @{$missings{$addr}};
2447 sub _insert_property_into_line {
2448 # Add a property field to $_, if this file requires it.
2451 my $addr = do { no overloading; pack 'J', $self; };
2452 my $property = $property{$addr};
2453 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2455 $_ =~ s/(;|$)/; $property$1/;
2460 # Output consistent error messages, using either a generic one, or the
2461 # one given by the optional parameter. To avoid gazillions of the
2462 # same message in case the syntax of a file is way off, this routine
2463 # only outputs the first instance of each message, incrementing a
2464 # count so the totals can be output at the end of the file.
2467 my $message = shift;
2468 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2470 my $addr = do { no overloading; pack 'J', $self; };
2472 $message = 'Unexpected line' unless $message;
2474 # No trailing punctuation so as to fit with our addenda.
2475 $message =~ s/[.:;,]$//;
2477 # If haven't seen this exact message before, output it now. Otherwise
2478 # increment the count of how many times it has occurred
2479 unless ($errors{$addr}->{$message}) {
2480 Carp::my_carp("$message in '$_' in "
2482 . " at line $.. Skipping this line;");
2483 $errors{$addr}->{$message} = 1;
2486 $errors{$addr}->{$message}++;
2489 # Clear the line to prevent any further (meaningful) processing of it.
2496 package Multi_Default;
2498 # Certain properties in early versions of Unicode had more than one possible
2499 # default for code points missing from the files. In these cases, one
2500 # default applies to everything left over after all the others are applied,
2501 # and for each of the others, there is a description of which class of code
2502 # points applies to it. This object helps implement this by storing the
2503 # defaults, and for all but that final default, an eval string that generates
2504 # the class that it applies to.
2509 main::setup_package();
2512 # The defaults structure for the classes
2513 main::set_access('class_defaults', \%class_defaults);
2516 # The default that applies to everything left over.
2517 main::set_access('other_default', \%other_default, 'r');
2521 # The constructor is called with default => eval pairs, terminated by
2522 # the left-over default. e.g.
2523 # Multi_Default->new(
2524 # 'T' => '$gc->table("Mn") + $gc->table("Cf") - 0x200C
2526 # 'R' => 'some other expression that evaluates to code points',
2534 my $self = bless \do{my $anonymous_scalar}, $class;
2535 my $addr = do { no overloading; pack 'J', $self; };
2538 my $default = shift;
2540 $class_defaults{$addr}->{$default} = $eval;
2543 $other_default{$addr} = shift;
2548 sub get_next_defaults {
2549 # Iterates and returns the next class of defaults.
2551 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2553 my $addr = do { no overloading; pack 'J', $self; };
2555 return each %{$class_defaults{$addr}};
2561 # An alias is one of the names that a table goes by. This class defines them
2562 # including some attributes. Everything is currently setup in the
2568 main::setup_package();
2571 main::set_access('name', \%name, 'r');
2574 # Determined by the constructor code if this name should match loosely or
2575 # not. The constructor parameters can override this, but it isn't fully
2576 # implemented, as should have ability to override Unicode one's via
2577 # something like a set_loose_match()
2578 main::set_access('loose_match', \%loose_match, 'r');
2581 # Some aliases should not get their own entries because they are covered
2582 # by a wild-card, and some we want to discourage use of. Binary
2583 main::set_access('make_pod_entry', \%make_pod_entry, 'r');
2586 # Aliases have a status, like deprecated, or even suppressed (which means
2587 # they don't appear in documentation). Enum
2588 main::set_access('status', \%status, 'r');
2591 # Similarly, some aliases should not be considered as usable ones for
2592 # external use, such as file names, or we don't want documentation to
2593 # recommend them. Boolean
2594 main::set_access('externally_ok', \%externally_ok, 'r');
2599 my $self = bless \do { my $anonymous_scalar }, $class;
2600 my $addr = do { no overloading; pack 'J', $self; };
2602 $name{$addr} = shift;
2603 $loose_match{$addr} = shift;
2604 $make_pod_entry{$addr} = shift;
2605 $externally_ok{$addr} = shift;
2606 $status{$addr} = shift;
2608 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2610 # Null names are never ok externally
2611 $externally_ok{$addr} = 0 if $name{$addr} eq "";
2619 # A range is the basic unit for storing code points, and is described in the
2620 # comments at the beginning of the program. Each range has a starting code
2621 # point; an ending code point (not less than the starting one); a value
2622 # that applies to every code point in between the two end-points, inclusive;
2623 # and an enum type that applies to the value. The type is for the user's
2624 # convenience, and has no meaning here, except that a non-zero type is
2625 # considered to not obey the normal Unicode rules for having standard forms.
2627 # The same structure is used for both map and match tables, even though in the
2628 # latter, the value (and hence type) is irrelevant and could be used as a
2629 # comment. In map tables, the value is what all the code points in the range
2630 # map to. Type 0 values have the standardized version of the value stored as
2631 # well, so as to not have to recalculate it a lot.
2633 sub trace { return main::trace(@_); }
2637 main::setup_package();
2640 main::set_access('start', \%start, 'r', 's');
2643 main::set_access('end', \%end, 'r', 's');
2646 main::set_access('value', \%value, 'r');
2649 main::set_access('type', \%type, 'r');
2652 # The value in internal standard form. Defined only if the type is 0.
2653 main::set_access('standard_form', \%standard_form);
2655 # Note that if these fields change, the dump() method should as well
2658 return Carp::carp_too_few_args(\@_, 3) if main::DEBUG && @_ < 3;
2661 my $self = bless \do { my $anonymous_scalar }, $class;
2662 my $addr = do { no overloading; pack 'J', $self; };
2664 $start{$addr} = shift;
2665 $end{$addr} = shift;
2669 my $value = delete $args{'Value'}; # Can be 0
2670 $value = "" unless defined $value;
2671 $value{$addr} = $value;
2673 $type{$addr} = delete $args{'Type'} || 0;
2675 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
2677 if (! $type{$addr}) {
2678 $standard_form{$addr} = main::standardize($value);
2686 qw("") => "_operator_stringify",
2687 "." => \&main::_operator_dot,
2690 sub _operator_stringify {
2692 my $addr = do { no overloading; pack 'J', $self; };
2694 # Output it like '0041..0065 (value)'
2695 my $return = sprintf("%04X", $start{$addr})
2697 . sprintf("%04X", $end{$addr});
2698 my $value = $value{$addr};
2699 my $type = $type{$addr};
2701 $return .= "$value";
2702 $return .= ", Type=$type" if $type != 0;
2709 # The standard form is the value itself if the standard form is
2710 # undefined (that is if the value is special)
2713 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2715 my $addr = do { no overloading; pack 'J', $self; };
2717 return $standard_form{$addr} if defined $standard_form{$addr};
2718 return $value{$addr};
2722 # Human, not machine readable. For machine readable, comment out this
2723 # entire routine and let the standard one take effect.
2726 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2728 my $addr = do { no overloading; pack 'J', $self; };
2730 my $return = $indent
2731 . sprintf("%04X", $start{$addr})
2733 . sprintf("%04X", $end{$addr})
2734 . " '$value{$addr}';";
2735 if (! defined $standard_form{$addr}) {
2736 $return .= "(type=$type{$addr})";
2738 elsif ($standard_form{$addr} ne $value{$addr}) {
2739 $return .= "(standard '$standard_form{$addr}')";
2745 package _Range_List_Base;
2747 # Base class for range lists. A range list is simply an ordered list of
2748 # ranges, so that the ranges with the lowest starting numbers are first in it.
2750 # When a new range is added that is adjacent to an existing range that has the
2751 # same value and type, it merges with it to form a larger range.
2753 # Ranges generally do not overlap, except that there can be multiple entries
2754 # of single code point ranges. This is because of NameAliases.txt.
2756 # In this program, there is a standard value such that if two different
2757 # values, have the same standard value, they are considered equivalent. This
2758 # value was chosen so that it gives correct results on Unicode data
2760 # There are a number of methods to manipulate range lists, and some operators
2761 # are overloaded to handle them.
2763 sub trace { return main::trace(@_); }
2769 main::setup_package();
2772 # The list of ranges
2773 main::set_access('ranges', \%ranges, 'readable_array');
2776 # The highest code point in the list. This was originally a method, but
2777 # actual measurements said it was used a lot.
2778 main::set_access('max', \%max, 'r');
2780 my %each_range_iterator;
2781 # Iterator position for each_range()
2782 main::set_access('each_range_iterator', \%each_range_iterator);
2785 # Name of parent this is attached to, if any. Solely for better error
2787 main::set_access('owner_name_of', \%owner_name_of, 'p_r');
2789 my %_search_ranges_cache;
2790 # A cache of the previous result from _search_ranges(), for better
2792 main::set_access('_search_ranges_cache', \%_search_ranges_cache);
2798 # Optional initialization data for the range list.
2799 my $initialize = delete $args{'Initialize'};
2803 # Use _union() to initialize. _union() returns an object of this
2804 # class, which means that it will call this constructor recursively.
2805 # But it won't have this $initialize parameter so that it won't
2806 # infinitely loop on this.
2807 return _union($class, $initialize, %args) if defined $initialize;
2809 $self = bless \do { my $anonymous_scalar }, $class;
2810 my $addr = do { no overloading; pack 'J', $self; };
2812 # Optional parent object, only for debug info.
2813 $owner_name_of{$addr} = delete $args{'Owner'};
2814 $owner_name_of{$addr} = "" if ! defined $owner_name_of{$addr};
2816 # Stringify, in case it is an object.
2817 $owner_name_of{$addr} = "$owner_name_of{$addr}";
2819 # This is used only for error messages, and so a colon is added
2820 $owner_name_of{$addr} .= ": " if $owner_name_of{$addr} ne "";
2822 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
2824 # Max is initialized to a negative value that isn't adjacent to 0,
2828 $_search_ranges_cache{$addr} = 0;
2829 $ranges{$addr} = [];
2836 qw("") => "_operator_stringify",
2837 "." => \&main::_operator_dot,
2840 sub _operator_stringify {
2842 my $addr = do { no overloading; pack 'J', $self; };
2844 return "Range_List attached to '$owner_name_of{$addr}'"
2845 if $owner_name_of{$addr};
2846 return "anonymous Range_List " . \$self;
2850 # Returns the union of the input code points. It can be called as
2851 # either a constructor or a method. If called as a method, the result
2852 # will be a new() instance of the calling object, containing the union
2853 # of that object with the other parameter's code points; if called as
2854 # a constructor, the first parameter gives the class the new object
2855 # should be, and the second parameter gives the code points to go into
2857 # In either case, there are two parameters looked at by this routine;
2858 # any additional parameters are passed to the new() constructor.
2860 # The code points can come in the form of some object that contains
2861 # ranges, and has a conventionally named method to access them; or
2862 # they can be an array of individual code points (as integers); or
2863 # just a single code point.
2865 # If they are ranges, this routine doesn't make any effort to preserve
2866 # the range values of one input over the other. Therefore this base
2867 # class should not allow _union to be called from other than
2868 # initialization code, so as to prevent two tables from being added
2869 # together where the range values matter. The general form of this
2870 # routine therefore belongs in a derived class, but it was moved here
2871 # to avoid duplication of code. The failure to overload this in this
2872 # class keeps it safe.
2876 my @args; # Arguments to pass to the constructor
2880 # If a method call, will start the union with the object itself, and
2881 # the class of the new object will be the same as self.
2888 # Add the other required parameter.
2890 # Rest of parameters are passed on to the constructor
2892 # Accumulate all records from both lists.
2894 for my $arg (@args) {
2895 #local $to_trace = 0 if main::DEBUG;
2896 trace "argument = $arg" if main::DEBUG && $to_trace;
2897 if (! defined $arg) {
2899 if (defined $self) {
2901 $message .= $owner_name_of{pack 'J', $self};
2903 Carp::my_carp_bug($message .= "Undefined argument to _union. No union done.");
2906 $arg = [ $arg ] if ! ref $arg;
2907 my $type = ref $arg;
2908 if ($type eq 'ARRAY') {
2909 foreach my $element (@$arg) {
2910 push @records, Range->new($element, $element);
2913 elsif ($arg->isa('Range')) {
2914 push @records, $arg;
2916 elsif ($arg->can('ranges')) {
2917 push @records, $arg->ranges;
2921 if (defined $self) {
2923 $message .= $owner_name_of{pack 'J', $self};
2925 Carp::my_carp_bug($message . "Cannot take the union of a $type. No union done.");
2930 # Sort with the range containing the lowest ordinal first, but if
2931 # two ranges start at the same code point, sort with the bigger range
2932 # of the two first, because it takes fewer cycles.
2933 @records = sort { ($a->start <=> $b->start)
2935 # if b is shorter than a, b->end will be
2936 # less than a->end, and we want to select
2937 # a, so want to return -1
2938 ($b->end <=> $a->end)
2941 my $new = $class->new(@_);
2943 # Fold in records so long as they add new information.
2944 for my $set (@records) {
2945 my $start = $set->start;
2946 my $end = $set->end;
2947 my $value = $set->value;
2948 if ($start > $new->max) {
2949 $new->_add_delete('+', $start, $end, $value);
2951 elsif ($end > $new->max) {
2952 $new->_add_delete('+', $new->max +1, $end, $value);
2959 sub range_count { # Return the number of ranges in the range list
2961 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2964 return scalar @{$ranges{pack 'J', $self}};
2968 # Returns the minimum code point currently in the range list, or if
2969 # the range list is empty, 2 beyond the max possible. This is a
2970 # method because used so rarely, that not worth saving between calls,
2971 # and having to worry about changing it as ranges are added and
2975 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2977 my $addr = do { no overloading; pack 'J', $self; };
2979 # If the range list is empty, return a large value that isn't adjacent
2980 # to any that could be in the range list, for simpler tests
2981 return $LAST_UNICODE_CODEPOINT + 2 unless scalar @{$ranges{$addr}};
2982 return $ranges{$addr}->[0]->start;
2986 # Boolean: Is argument in the range list? If so returns $i such that:
2987 # range[$i]->end < $codepoint <= range[$i+1]->end
2988 # which is one beyond what you want; this is so that the 0th range
2989 # doesn't return false
2991 my $codepoint = shift;
2992 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2994 my $i = $self->_search_ranges($codepoint);
2995 return 0 unless defined $i;
2997 # The search returns $i, such that
2998 # range[$i-1]->end < $codepoint <= range[$i]->end
2999 # So is in the table if and only iff it is at least the start position
3002 return 0 if $ranges{pack 'J', $self}->[$i]->start > $codepoint;
3006 sub containing_range {
3007 # Returns the range object that contains the code point, undef if none
3010 my $codepoint = shift;
3011 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3013 my $i = $self->contains($codepoint);
3016 # contains() returns 1 beyond where we should look
3018 return $ranges{pack 'J', $self}->[$i-1];
3022 # Returns the value associated with the code point, undef if none
3025 my $codepoint = shift;
3026 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3028 my $range = $self->containing_range($codepoint);
3029 return unless defined $range;
3031 return $range->value;
3035 # Returns the type of the range containing the code point, undef if
3036 # the code point is not in the table
3039 my $codepoint = shift;
3040 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3042 my $range = $self->containing_range($codepoint);
3043 return unless defined $range;
3045 return $range->type;
3048 sub _search_ranges {
3049 # Find the range in the list which contains a code point, or where it
3050 # should go if were to add it. That is, it returns $i, such that:
3051 # range[$i-1]->end < $codepoint <= range[$i]->end
3052 # Returns undef if no such $i is possible (e.g. at end of table), or
3053 # if there is an error.
3056 my $code_point = shift;
3057 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3059 my $addr = do { no overloading; pack 'J', $self; };
3061 return if $code_point > $max{$addr};
3062 my $r = $ranges{$addr}; # The current list of ranges
3063 my $range_list_size = scalar @$r;
3066 use integer; # want integer division
3068 # Use the cached result as the starting guess for this one, because,
3069 # an experiment on 5.1 showed that 90% of the time the cache was the
3070 # same as the result on the next call (and 7% it was one less).
3071 $i = $_search_ranges_cache{$addr};
3072 $i = 0 if $i >= $range_list_size; # Reset if no longer valid (prob.
3073 # from an intervening deletion
3074 #local $to_trace = 1 if main::DEBUG;
3075 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);
3076 return $i if $code_point <= $r->[$i]->end
3077 && ($i == 0 || $r->[$i-1]->end < $code_point);
3079 # Here the cache doesn't yield the correct $i. Try adding 1.
3080 if ($i < $range_list_size - 1
3081 && $r->[$i]->end < $code_point &&
3082 $code_point <= $r->[$i+1]->end)
3085 trace "next \$i is correct: $i" if main::DEBUG && $to_trace;
3086 $_search_ranges_cache{$addr} = $i;
3090 # Here, adding 1 also didn't work. We do a binary search to
3091 # find the correct position, starting with current $i
3093 my $upper = $range_list_size - 1;
3095 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;
3097 if ($code_point <= $r->[$i]->end) {
3099 # Here we have met the upper constraint. We can quit if we
3100 # also meet the lower one.
3101 last if $i == 0 || $r->[$i-1]->end < $code_point;
3103 $upper = $i; # Still too high.
3108 # Here, $r[$i]->end < $code_point, so look higher up.
3112 # Split search domain in half to try again.
3113 my $temp = ($upper + $lower) / 2;
3115 # No point in continuing unless $i changes for next time
3119 # We can't reach the highest element because of the averaging.
3120 # So if one below the upper edge, force it there and try one
3122 if ($i == $range_list_size - 2) {
3124 trace "Forcing to upper edge" if main::DEBUG && $to_trace;
3125 $i = $range_list_size - 1;
3127 # Change $lower as well so if fails next time through,
3128 # taking the average will yield the same $i, and we will
3129 # quit with the error message just below.
3133 Carp::my_carp_bug("$owner_name_of{$addr}Can't find where the range ought to go. No action taken.");
3137 } # End of while loop
3139 if (main::DEBUG && $to_trace) {
3140 trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i;
3141 trace "i= [ $i ]", $r->[$i];
3142 trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < $range_list_size - 1;
3145 # Here we have found the offset. Cache it as a starting point for the
3147 $_search_ranges_cache{$addr} = $i;
3152 # Add, replace or delete ranges to or from a list. The $type
3153 # parameter gives which:
3154 # '+' => insert or replace a range, returning a list of any changed
3156 # '-' => delete a range, returning a list of any deleted ranges.
3158 # The next three parameters give respectively the start, end, and
3159 # value associated with the range. 'value' should be null unless the
3162 # The range list is kept sorted so that the range with the lowest
3163 # starting position is first in the list, and generally, adjacent
3164 # ranges with the same values are merged into a single larger one (see
3165 # exceptions below).
3167 # There are more parameters; all are key => value pairs:
3168 # Type gives the type of the value. It is only valid for '+'.
3169 # All ranges have types; if this parameter is omitted, 0 is
3170 # assumed. Ranges with type 0 are assumed to obey the
3171 # Unicode rules for casing, etc; ranges with other types are
3172 # not. Otherwise, the type is arbitrary, for the caller's
3173 # convenience, and looked at only by this routine to keep
3174 # adjacent ranges of different types from being merged into
3175 # a single larger range, and when Replace =>
3176 # $IF_NOT_EQUIVALENT is specified (see just below).
3177 # Replace determines what to do if the range list already contains
3178 # ranges which coincide with all or portions of the input
3179 # range. It is only valid for '+':
3180 # => $NO means that the new value is not to replace
3181 # any existing ones, but any empty gaps of the
3182 # range list coinciding with the input range
3183 # will be filled in with the new value.
3184 # => $UNCONDITIONALLY means to replace the existing values with
3185 # this one unconditionally. However, if the
3186 # new and old values are identical, the
3187 # replacement is skipped to save cycles
3188 # => $IF_NOT_EQUIVALENT means to replace the existing values
3189 # with this one if they are not equivalent.
3190 # Ranges are equivalent if their types are the
3191 # same, and they are the same string; or if
3192 # both are type 0 ranges, if their Unicode
3193 # standard forms are identical. In this last
3194 # case, the routine chooses the more "modern"
3195 # one to use. This is because some of the
3196 # older files are formatted with values that
3197 # are, for example, ALL CAPs, whereas the
3198 # derived files have a more modern style,
3199 # which looks better. By looking for this
3200 # style when the pre-existing and replacement
3201 # standard forms are the same, we can move to
3203 # => $MULTIPLE means that if this range duplicates an
3204 # existing one, but has a different value,
3205 # don't replace the existing one, but insert
3206 # this, one so that the same range can occur
3207 # multiple times. They are stored LIFO, so
3208 # that the final one inserted is the first one
3209 # returned in an ordered search of the table.
3210 # => anything else is the same as => $IF_NOT_EQUIVALENT
3212 # "same value" means identical for non-type-0 ranges, and it means
3213 # having the same standard forms for type-0 ranges.
3215 return Carp::carp_too_few_args(\@_, 5) if main::DEBUG && @_ < 5;
3218 my $operation = shift; # '+' for add/replace; '-' for delete;
3225 $value = "" if not defined $value; # warning: $value can be "0"
3227 my $replace = delete $args{'Replace'};
3228 $replace = $IF_NOT_EQUIVALENT unless defined $replace;
3230 my $type = delete $args{'Type'};
3231 $type = 0 unless defined $type;
3233 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
3235 my $addr = do { no overloading; pack 'J', $self; };
3237 if ($operation ne '+' && $operation ne '-') {
3238 Carp::my_carp_bug("$owner_name_of{$addr}First parameter to _add_delete must be '+' or '-'. No action taken.");
3241 unless (defined $start && defined $end) {
3242 Carp::my_carp_bug("$owner_name_of{$addr}Undefined start and/or end to _add_delete. No action taken.");
3245 unless ($end >= $start) {
3246 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.");
3249 #local $to_trace = 1 if main::DEBUG;
3251 if ($operation eq '-') {
3252 if ($replace != $IF_NOT_EQUIVALENT) {
3253 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.");
3254 $replace = $IF_NOT_EQUIVALENT;
3257 Carp::my_carp_bug("$owner_name_of{$addr}Type => 0 is required when deleting a range from a range list. Assuming Type => 0.");
3261 Carp::my_carp_bug("$owner_name_of{$addr}Value => \"\" is required when deleting a range from a range list. Assuming Value => \"\".");
3266 my $r = $ranges{$addr}; # The current list of ranges
3267 my $range_list_size = scalar @$r; # And its size
3268 my $max = $max{$addr}; # The current high code point in
3269 # the list of ranges
3271 # Do a special case requiring fewer machine cycles when the new range
3272 # starts after the current highest point. The Unicode input data is
3273 # structured so this is common.
3274 if ($start > $max) {
3276 trace "$owner_name_of{$addr} $operation", sprintf("%04X", $start) . '..' . sprintf("%04X", $end) . " ($value) type=$type" if main::DEBUG && $to_trace;
3277 return if $operation eq '-'; # Deleting a non-existing range is a
3280 # If the new range doesn't logically extend the current final one
3281 # in the range list, create a new range at the end of the range
3282 # list. (max cleverly is initialized to a negative number not
3283 # adjacent to 0 if the range list is empty, so even adding a range
3284 # to an empty range list starting at 0 will have this 'if'
3286 if ($start > $max + 1 # non-adjacent means can't extend.
3287 || @{$r}[-1]->value ne $value # values differ, can't extend.
3288 || @{$r}[-1]->type != $type # types differ, can't extend.
3290 push @$r, Range->new($start, $end,
3296 # Here, the new range starts just after the current highest in
3297 # the range list, and they have the same type and value.
3298 # Extend the current range to incorporate the new one.
3299 @{$r}[-1]->set_end($end);
3302 # This becomes the new maximum.
3307 #local $to_trace = 0 if main::DEBUG;
3309 trace "$owner_name_of{$addr} $operation", sprintf("%04X", $start) . '..' . sprintf("%04X", $end) . " ($value) replace=$replace" if main::DEBUG && $to_trace;
3311 # Here, the input range isn't after the whole rest of the range list.
3312 # Most likely 'splice' will be needed. The rest of the routine finds
3313 # the needed splice parameters, and if necessary, does the splice.
3314 # First, find the offset parameter needed by the splice function for
3315 # the input range. Note that the input range may span multiple
3316 # existing ones, but we'll worry about that later. For now, just find
3317 # the beginning. If the input range is to be inserted starting in a
3318 # position not currently in the range list, it must (obviously) come
3319 # just after the range below it, and just before the range above it.
3320 # Slightly less obviously, it will occupy the position currently
3321 # occupied by the range that is to come after it. More formally, we
3322 # are looking for the position, $i, in the array of ranges, such that:
3324 # r[$i-1]->start <= r[$i-1]->end < $start < r[$i]->start <= r[$i]->end
3326 # (The ordered relationships within existing ranges are also shown in
3327 # the equation above). However, if the start of the input range is
3328 # within an existing range, the splice offset should point to that
3329 # existing range's position in the list; that is $i satisfies a
3330 # somewhat different equation, namely:
3332 #r[$i-1]->start <= r[$i-1]->end < r[$i]->start <= $start <= r[$i]->end
3334 # More briefly, $start can come before or after r[$i]->start, and at
3335 # this point, we don't know which it will be. However, these
3336 # two equations share these constraints:
3338 # r[$i-1]->end < $start <= r[$i]->end
3340 # And that is good enough to find $i.
3342 my $i = $self->_search_ranges($start);
3344 Carp::my_carp_bug("Searching $self for range beginning with $start unexpectedly returned undefined. Operation '$operation' not performed");
3348 # The search function returns $i such that:
3350 # r[$i-1]->end < $start <= r[$i]->end
3352 # That means that $i points to the first range in the range list
3353 # that could possibly be affected by this operation. We still don't
3354 # know if the start of the input range is within r[$i], or if it
3355 # points to empty space between r[$i-1] and r[$i].
3356 trace "[$i] is the beginning splice point. Existing range there is ", $r->[$i] if main::DEBUG && $to_trace;
3358 # Special case the insertion of data that is not to replace any
3360 if ($replace == $NO) { # If $NO, has to be operation '+'
3361 #local $to_trace = 1 if main::DEBUG;
3362 trace "Doesn't replace" if main::DEBUG && $to_trace;
3364 # Here, the new range is to take effect only on those code points
3365 # that aren't already in an existing range. This can be done by
3366 # looking through the existing range list and finding the gaps in
3367 # the ranges that this new range affects, and then calling this
3368 # function recursively on each of those gaps, leaving untouched
3369 # anything already in the list. Gather up a list of the changed
3370 # gaps first so that changes to the internal state as new ranges
3371 # are added won't be a problem.
3374 # First, if the starting point of the input range is outside an
3375 # existing one, there is a gap from there to the beginning of the
3376 # existing range -- add a span to fill the part that this new
3378 if ($start < $r->[$i]->start) {
3379 push @gap_list, Range->new($start,
3381 $r->[$i]->start - 1),
3383 trace "gap before $r->[$i] [$i], will add", $gap_list[-1] if main::DEBUG && $to_trace;
3386 # Then look through the range list for other gaps until we reach
3387 # the highest range affected by the input one.
3389 for ($j = $i+1; $j < $range_list_size; $j++) {
3390 trace "j=[$j]", $r->[$j] if main::DEBUG && $to_trace;
3391 last if $end < $r->[$j]->start;
3393 # If there is a gap between when this range starts and the
3394 # previous one ends, add a span to fill it. Note that just
3395 # because there are two ranges doesn't mean there is a
3396 # non-zero gap between them. It could be that they have
3397 # different values or types
3398 if ($r->[$j-1]->end + 1 != $r->[$j]->start) {
3400 Range->new($r->[$j-1]->end + 1,
3401 $r->[$j]->start - 1,
3403 trace "gap between $r->[$j-1] and $r->[$j] [$j], will add: $gap_list[-1]" if main::DEBUG && $to_trace;
3407 # Here, we have either found an existing range in the range list,
3408 # beyond the area affected by the input one, or we fell off the
3409 # end of the loop because the input range affects the whole rest
3410 # of the range list. In either case, $j is 1 higher than the
3411 # highest affected range. If $j == $i, it means that there are no
3412 # affected ranges, that the entire insertion is in the gap between
3413 # r[$i-1], and r[$i], which we already have taken care of before
3415 # On the other hand, if there are affected ranges, it might be
3416 # that there is a gap that needs filling after the final such
3417 # range to the end of the input range
3418 if ($r->[$j-1]->end < $end) {
3419 push @gap_list, Range->new(main::max($start,
3420 $r->[$j-1]->end + 1),
3423 trace "gap after $r->[$j-1], will add $gap_list[-1]" if main::DEBUG && $to_trace;
3426 # Call recursively to fill in all the gaps.
3427 foreach my $gap (@gap_list) {
3428 $self->_add_delete($operation,
3438 # Here, we have taken care of the case where $replace is $NO.
3439 # Remember that here, r[$i-1]->end < $start <= r[$i]->end
3440 # If inserting a multiple record, this is where it goes, before the
3441 # first (if any) existing one. This implies an insertion, and no
3442 # change to any existing ranges. Note that $i can be -1 if this new
3443 # range doesn't actually duplicate any existing, and comes at the
3444 # beginning of the list.
3445 if ($replace == $MULTIPLE) {
3447 if ($start != $end) {
3448 Carp::my_carp_bug("$owner_name_of{$addr}Can't cope with adding a multiple record when the range ($start..$end) contains more than one code point. No action taken.");
3452 # Don't add an exact duplicate, as it isn't really a multiple
3453 if ($end >= $r->[$i]->start) {
3454 if ($r->[$i]->start != $r->[$i]->end) {
3455 Carp::my_carp_bug("$owner_name_of{$addr}Can't cope with adding a multiple record when the other range ($r->[$i]) contains more than one code point. No action taken.");
3458 return if $value eq $r->[$i]->value && $type eq $r->[$i]->type;
3461 trace "Adding multiple record at $i with $start..$end, $value" if main::DEBUG && $to_trace;
3462 my @return = splice @$r,
3469 if (main::DEBUG && $to_trace) {
3470 trace "After splice:";
3471 trace 'i-2=[', $i-2, ']', $r->[$i-2] if $i >= 2;
3472 trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i >= 1;
3473 trace "i =[", $i, "]", $r->[$i] if $i >= 0;
3474 trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < @$r - 1;
3475 trace 'i+2=[', $i+2, ']', $r->[$i+2] if $i < @$r - 2;
3476 trace 'i+3=[', $i+3, ']', $r->[$i+3] if $i < @$r - 3;
3481 # Here, we have taken care of $NO and $MULTIPLE replaces. This leaves
3482 # delete, insert, and replace either unconditionally or if not
3483 # equivalent. $i still points to the first potential affected range.
3484 # Now find the highest range affected, which will determine the length
3485 # parameter to splice. (The input range can span multiple existing
3486 # ones.) If this isn't a deletion, while we are looking through the
3487 # range list, see also if this is a replacement rather than a clean
3488 # insertion; that is if it will change the values of at least one
3489 # existing range. Start off assuming it is an insert, until find it
3491 my $clean_insert = $operation eq '+';
3492 my $j; # This will point to the highest affected range
3494 # For non-zero types, the standard form is the value itself;
3495 my $standard_form = ($type) ? $value : main::standardize($value);
3497 for ($j = $i; $j < $range_list_size; $j++) {
3498 trace "Looking for highest affected range; the one at $j is ", $r->[$j] if main::DEBUG && $to_trace;
3500 # If find a range that it doesn't overlap into, we can stop
3502 last if $end < $r->[$j]->start;
3504 # Here, overlaps the range at $j. If the values don't match,
3505 # and so far we think this is a clean insertion, it becomes a
3506 # non-clean insertion, i.e., a 'change' or 'replace' instead.
3507 if ($clean_insert) {
3508 if ($r->[$j]->standard_form ne $standard_form) {
3513 # Here, the two values are essentially the same. If the
3514 # two are actually identical, replacing wouldn't change
3515 # anything so skip it.
3516 my $pre_existing = $r->[$j]->value;
3517 if ($pre_existing ne $value) {
3519 # Here the new and old standardized values are the
3520 # same, but the non-standardized values aren't. If
3521 # replacing unconditionally, then replace
3522 if( $replace == $UNCONDITIONALLY) {
3527 # Here, are replacing conditionally. Decide to
3528 # replace or not based on which appears to look
3529 # the "nicest". If one is mixed case and the
3530 # other isn't, choose the mixed case one.
3531 my $new_mixed = $value =~ /[A-Z]/
3532 && $value =~ /[a-z]/;
3533 my $old_mixed = $pre_existing =~ /[A-Z]/
3534 && $pre_existing =~ /[a-z]/;
3536 if ($old_mixed != $new_mixed) {
3537 $clean_insert = 0 if $new_mixed;
3538 if (main::DEBUG && $to_trace) {
3539 if ($clean_insert) {
3540 trace "Retaining $pre_existing over $value";
3543 trace "Replacing $pre_existing with $value";
3549 # Here casing wasn't different between the two.
3550 # If one has hyphens or underscores and the
3551 # other doesn't, choose the one with the
3553 my $new_punct = $value =~ /[-_]/;
3554 my $old_punct = $pre_existing =~ /[-_]/;
3556 if ($old_punct != $new_punct) {
3557 $clean_insert = 0 if $new_punct;
3558 if (main::DEBUG && $to_trace) {
3559 if ($clean_insert) {
3560 trace "Retaining $pre_existing over $value";
3563 trace "Replacing $pre_existing with $value";
3566 } # else existing one is just as "good";
3567 # retain it to save cycles.
3573 } # End of loop looking for highest affected range.
3575 # Here, $j points to one beyond the highest range that this insertion
3576 # affects (hence to beyond the range list if that range is the final
3577 # one in the range list).
3579 # The splice length is all the affected ranges. Get it before
3580 # subtracting, for efficiency, so we don't have to later add 1.
3581 my $length = $j - $i;
3583 $j--; # $j now points to the highest affected range.
3584 trace "Final affected range is $j: $r->[$j]" if main::DEBUG && $to_trace;
3586 # Here, have taken care of $NO and $MULTIPLE replaces.
3587 # $j points to the highest affected range. But it can be < $i or even
3588 # -1. These happen only if the insertion is entirely in the gap
3589 # between r[$i-1] and r[$i]. Here's why: j < i means that the j loop
3590 # above exited first time through with $end < $r->[$i]->start. (And
3591 # then we subtracted one from j) This implies also that $start <
3592 # $r->[$i]->start, but we know from above that $r->[$i-1]->end <
3593 # $start, so the entire input range is in the gap.
3596 # Here the entire input range is in the gap before $i.
3598 if (main::DEBUG && $to_trace) {
3600 trace "Entire range is between $r->[$i-1] and $r->[$i]";
3603 trace "Entire range is before $r->[$i]";
3606 return if $operation ne '+'; # Deletion of a non-existent range is
3611 # Here part of the input range is not in the gap before $i. Thus,
3612 # there is at least one affected one, and $j points to the highest
3615 # At this point, here is the situation:
3616 # This is not an insertion of a multiple, nor of tentative ($NO)
3618 # $i points to the first element in the current range list that
3619 # may be affected by this operation. In fact, we know
3620 # that the range at $i is affected because we are in
3621 # the else branch of this 'if'
3622 # $j points to the highest affected range.
3624 # r[$i-1]->end < $start <= r[$i]->end
3626 # r[$i-1]->end < $start <= $end <= r[$j]->end
3629 # $clean_insert is a boolean which is set true if and only if
3630 # this is a "clean insertion", i.e., not a change nor a
3631 # deletion (multiple was handled above).
3633 # We now have enough information to decide if this call is a no-op
3634 # or not. It is a no-op if this is an insertion of already
3637 if (main::DEBUG && $to_trace && $clean_insert
3639 && $start >= $r->[$i]->start)
3643 return if $clean_insert
3644 && $i == $j # more than one affected range => not no-op
3646 # Here, r[$i-1]->end < $start <= $end <= r[$i]->end
3647 # Further, $start and/or $end is >= r[$i]->start
3648 # The test below hence guarantees that
3649 # r[$i]->start < $start <= $end <= r[$i]->end
3650 # This means the input range is contained entirely in
3651 # the one at $i, so is a no-op
3652 && $start >= $r->[$i]->start;
3655 # Here, we know that some action will have to be taken. We have
3656 # calculated the offset and length (though adjustments may be needed)
3657 # for the splice. Now start constructing the replacement list.
3659 my $splice_start = $i;
3664 # See if should extend any adjacent ranges.
3665 if ($operation eq '-') { # Don't extend deletions
3666 $extends_below = $extends_above = 0;
3668 else { # Here, should extend any adjacent ranges. See if there are
3670 $extends_below = ($i > 0
3671 # can't extend unless adjacent
3672 && $r->[$i-1]->end == $start -1
3673 # can't extend unless are same standard value
3674 && $r->[$i-1]->standard_form eq $standard_form
3675 # can't extend unless share type
3676 && $r->[$i-1]->type == $type);
3677 $extends_above = ($j+1 < $range_list_size
3678 && $r->[$j+1]->start == $end +1
3679 && $r->[$j+1]->standard_form eq $standard_form
3680 && $r->[$j-1]->type == $type);
3682 if ($extends_below && $extends_above) { # Adds to both
3683 $splice_start--; # start replace at element below
3684 $length += 2; # will replace on both sides
3685 trace "Extends both below and above ranges" if main::DEBUG && $to_trace;
3687 # The result will fill in any gap, replacing both sides, and
3688 # create one large range.
3689 @replacement = Range->new($r->[$i-1]->start,
3696 # Here we know that the result won't just be the conglomeration of
3697 # a new range with both its adjacent neighbors. But it could
3698 # extend one of them.
3700 if ($extends_below) {
3702 # Here the new element adds to the one below, but not to the
3703 # one above. If inserting, and only to that one range, can
3704 # just change its ending to include the new one.
3705 if ($length == 0 && $clean_insert) {
3706 $r->[$i-1]->set_end($end);
3707 trace "inserted range extends range to below so it is now $r->[$i-1]" if main::DEBUG && $to_trace;
3711 trace "Changing inserted range to start at ", sprintf("%04X", $r->[$i-1]->start), " instead of ", sprintf("%04X", $start) if main::DEBUG && $to_trace;
3712 $splice_start--; # start replace at element below
3713 $length++; # will replace the element below
3714 $start = $r->[$i-1]->start;
3717 elsif ($extends_above) {
3719 # Here the new element adds to the one above, but not below.
3720 # Mirror the code above
3721 if ($length == 0 && $clean_insert) {
3722 $r->[$j+1]->set_start($start);
3723 trace "inserted range extends range to above so it is now $r->[$j+1]" if main::DEBUG && $to_trace;
3727 trace "Changing inserted range to end at ", sprintf("%04X", $r->[$j+1]->end), " instead of ", sprintf("%04X", $end) if main::DEBUG && $to_trace;
3728 $length++; # will replace the element above
3729 $end = $r->[$j+1]->end;
3733 trace "Range at $i is $r->[$i]" if main::DEBUG && $to_trace;
3735 # Finally, here we know there will have to be a splice.
3736 # If the change or delete affects only the highest portion of the
3737 # first affected range, the range will have to be split. The
3738 # splice will remove the whole range, but will replace it by a new
3739 # range containing just the unaffected part. So, in this case,
3740 # add to the replacement list just this unaffected portion.
3741 if (! $extends_below
3742 && $start > $r->[$i]->start && $start <= $r->[$i]->end)
3745 Range->new($r->[$i]->start,
3747 Value => $r->[$i]->value,
3748 Type => $r->[$i]->type);
3751 # In the case of an insert or change, but not a delete, we have to
3752 # put in the new stuff; this comes next.
3753 if ($operation eq '+') {
3754 push @replacement, Range->new($start,
3760 trace "Range at $j is $r->[$j]" if main::DEBUG && $to_trace && $j != $i;
3761 #trace "$end >=", $r->[$j]->start, " && $end <", $r->[$j]->end if main::DEBUG && $to_trace;
3763 # And finally, if we're changing or deleting only a portion of the
3764 # highest affected range, it must be split, as the lowest one was.
3765 if (! $extends_above
3766 && $j >= 0 # Remember that j can be -1 if before first
3768 && $end >= $r->[$j]->start
3769 && $end < $r->[$j]->end)
3772 Range->new($end + 1,
3774 Value => $r->[$j]->value,
3775 Type => $r->[$j]->type);
3779 # And do the splice, as calculated above
3780 if (main::DEBUG && $to_trace) {
3781 trace "replacing $length element(s) at $i with ";
3782 foreach my $replacement (@replacement) {
3783 trace " $replacement";
3785 trace "Before splice:";
3786 trace 'i-2=[', $i-2, ']', $r->[$i-2] if $i >= 2;
3787 trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i >= 1;
3788 trace "i =[", $i, "]", $r->[$i];
3789 trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < @$r - 1;
3790 trace 'i+2=[', $i+2, ']', $r->[$i+2] if $i < @$r - 2;
3793 my @return = splice @$r, $splice_start, $length, @replacement;
3795 if (main::DEBUG && $to_trace) {
3796 trace "After splice:";
3797 trace 'i-2=[', $i-2, ']', $r->[$i-2] if $i >= 2;
3798 trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i >= 1;
3799 trace "i =[", $i, "]", $r->[$i];
3800 trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < @$r - 1;
3801 trace 'i+2=[', $i+2, ']', $r->[$i+2] if $i < @$r - 2;
3802 trace "removed @return";
3805 # An actual deletion could have changed the maximum in the list.
3806 # There was no deletion if the splice didn't return something, but
3807 # otherwise recalculate it. This is done too rarely to worry about
3809 if ($operation eq '-' && @return) {
3810 $max{$addr} = $r->[-1]->end;
3815 sub reset_each_range { # reset the iterator for each_range();
3817 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3820 undef $each_range_iterator{pack 'J', $self};
3825 # Iterate over each range in a range list. Results are undefined if
3826 # the range list is changed during the iteration.
3829 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3831 my $addr = do { no overloading; pack 'J', $self; };
3833 return if $self->is_empty;
3835 $each_range_iterator{$addr} = -1
3836 if ! defined $each_range_iterator{$addr};
3837 $each_range_iterator{$addr}++;
3838 return $ranges{$addr}->[$each_range_iterator{$addr}]
3839 if $each_range_iterator{$addr} < @{$ranges{$addr}};
3840 undef $each_range_iterator{$addr};
3844 sub count { # Returns count of code points in range list
3846 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3848 my $addr = do { no overloading; pack 'J', $self; };
3851 foreach my $range (@{$ranges{$addr}}) {
3852 $count += $range->end - $range->start + 1;
3857 sub delete_range { # Delete a range
3862 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3864 return $self->_add_delete('-', $start, $end, "");
3867 sub is_empty { # Returns boolean as to if a range list is empty
3869 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3872 return scalar @{$ranges{pack 'J', $self}} == 0;
3876 # Quickly returns a scalar suitable for separating tables into
3877 # buckets, i.e. it is a hash function of the contents of a table, so
3878 # there are relatively few conflicts.
3881 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3883 my $addr = do { no overloading; pack 'J', $self; };
3885 # These are quickly computable. Return looks like 'min..max;count'
3886 return $self->min . "..$max{$addr};" . scalar @{$ranges{$addr}};
3888 } # End closure for _Range_List_Base
3891 use base '_Range_List_Base';
3893 # A Range_List is a range list for match tables; i.e. the range values are
3894 # not significant. Thus a number of operations can be safely added to it,
3895 # such as inversion, intersection. Note that union is also an unsafe
3896 # operation when range values are cared about, and that method is in the base
3897 # class, not here. But things are set up so that that method is callable only
3898 # during initialization. Only in this derived class, is there an operation
3899 # that combines two tables. A Range_Map can thus be used to initialize a
3900 # Range_List, and its mappings will be in the list, but are not significant to
3903 sub trace { return main::trace(@_); }
3909 '+' => sub { my $self = shift;
3912 return $self->_union($other)
3914 '&' => sub { my $self = shift;
3917 return $self->_intersect($other, 0);
3924 # Returns a new Range_List that gives all code points not in $self.
3928 my $new = Range_List->new;
3930 # Go through each range in the table, finding the gaps between them
3931 my $max = -1; # Set so no gap before range beginning at 0
3932 for my $range ($self->ranges) {
3933 my $start = $range->start;
3934 my $end = $range->end;
3936 # If there is a gap before this range, the inverse will contain
3938 if ($start > $max + 1) {
3939 $new->add_range($max + 1, $start - 1);
3944 # And finally, add the gap from the end of the table to the max
3945 # possible code point
3946 if ($max < $LAST_UNICODE_CODEPOINT) {
3947 $new->add_range($max + 1, $LAST_UNICODE_CODEPOINT);
3953 # Returns a new Range_List with the argument deleted from it. The
3954 # argument can be a single code point, a range, or something that has
3955 # a range, with the _range_list() method on it returning them
3959 my $reversed = shift;
3960 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3963 Carp::my_carp_bug("Can't cope with a "
3965 . " being the second parameter in a '-'. Subtraction ignored.");
3969 my $new = Range_List->new(Initialize => $self);
3971 if (! ref $other) { # Single code point
3972 $new->delete_range($other, $other);
3974 elsif ($other->isa('Range')) {
3975 $new->delete_range($other->start, $other->end);
3977 elsif ($other->can('_range_list')) {
3978 foreach my $range ($other->_range_list->ranges) {
3979 $new->delete_range($range->start, $range->end);
3983 Carp::my_carp_bug("Can't cope with a "
3985 . " argument to '-'. Subtraction ignored."
3994 # Returns either a boolean giving whether the two inputs' range lists
3995 # intersect (overlap), or a new Range_List containing the intersection
3996 # of the two lists. The optional final parameter being true indicates
3997 # to do the check instead of the intersection.
3999 my $a_object = shift;
4000 my $b_object = shift;
4001 my $check_if_overlapping = shift;
4002 $check_if_overlapping = 0 unless defined $check_if_overlapping;
4003 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4005 if (! defined $b_object) {
4007 $message .= $a_object->_owner_name_of if defined $a_object;
4008 Carp::my_carp_bug($message .= "Called with undefined value. Intersection not done.");
4012 # a & b = !(!a | !b), or in our terminology = ~ ( ~a + -b )
4013 # Thus the intersection could be much more simply be written:
4014 # return ~(~$a_object + ~$b_object);
4015 # But, this is slower, and when taking the inverse of a large
4016 # range_size_1 table, back when such tables were always stored that
4017 # way, it became prohibitively slow, hence the code was changed to the
4020 if ($b_object->isa('Range')) {
4021 $b_object = Range_List->new(Initialize => $b_object,
4022 Owner => $a_object->_owner_name_of);
4024 $b_object = $b_object->_range_list if $b_object->can('_range_list');
4026 my @a_ranges = $a_object->ranges;
4027 my @b_ranges = $b_object->ranges;
4029 #local $to_trace = 1 if main::DEBUG;
4030 trace "intersecting $a_object with ", scalar @a_ranges, "ranges and $b_object with", scalar @b_ranges, " ranges" if main::DEBUG && $to_trace;
4032 # Start with the first range in each list
4034 my $range_a = $a_ranges[$a_i];
4036 my $range_b = $b_ranges[$b_i];
4038 my $new = __PACKAGE__->new(Owner => $a_object->_owner_name_of)
4039 if ! $check_if_overlapping;
4041 # If either list is empty, there is no intersection and no overlap
4042 if (! defined $range_a || ! defined $range_b) {
4043 return $check_if_overlapping ? 0 : $new;
4045 trace "range_a[$a_i]=$range_a; range_b[$b_i]=$range_b" if main::DEBUG && $to_trace;
4047 # Otherwise, must calculate the intersection/overlap. Start with the
4048 # very first code point in each list
4049 my $a = $range_a->start;
4050 my $b = $range_b->start;
4052 # Loop through all the ranges of each list; in each iteration, $a and
4053 # $b are the current code points in their respective lists
4056 # If $a and $b are the same code point, ...
4059 # it means the lists overlap. If just checking for overlap
4060 # know the answer now,
4061 return 1 if $check_if_overlapping;
4063 # The intersection includes this code point plus anything else
4064 # common to both current ranges.
4066 my $end = main::min($range_a->end, $range_b->end);
4067 if (! $check_if_overlapping) {
4068 trace "adding intersection range ", sprintf("%04X", $start) . ".." . sprintf("%04X", $end) if main::DEBUG && $to_trace;
4069 $new->add_range($start, $end);
4072 # Skip ahead to the end of the current intersect
4075 # If the current intersect ends at the end of either range (as
4076 # it must for at least one of them), the next possible one
4077 # will be the beginning code point in it's list's next range.
4078 if ($a == $range_a->end) {
4079 $range_a = $a_ranges[++$a_i];
4080 last unless defined $range_a;
4081 $a = $range_a->start;
4083 if ($b == $range_b->end) {
4084 $range_b = $b_ranges[++$b_i];
4085 last unless defined $range_b;
4086 $b = $range_b->start;
4089 trace "range_a[$a_i]=$range_a; range_b[$b_i]=$range_b" if main::DEBUG && $to_trace;
4093 # Not equal, but if the range containing $a encompasses $b,
4094 # change $a to be the middle of the range where it does equal
4095 # $b, so the next iteration will get the intersection
4096 if ($range_a->end >= $b) {
4101 # Here, the current range containing $a is entirely below
4102 # $b. Go try to find a range that could contain $b.
4103 $a_i = $a_object->_search_ranges($b);
4105 # If no range found, quit.
4106 last unless defined $a_i;
4108 # The search returns $a_i, such that
4109 # range_a[$a_i-1]->end < $b <= range_a[$a_i]->end
4110 # Set $a to the beginning of this new range, and repeat.
4111 $range_a = $a_ranges[$a_i];
4112 $a = $range_a->start;
4115 else { # Here, $b < $a.
4117 # Mirror image code to the leg just above
4118 if ($range_b->end >= $a) {
4122 $b_i = $b_object->_search_ranges($a);
4123 last unless defined $b_i;
4124 $range_b = $b_ranges[$b_i];
4125 $b = $range_b->start;
4128 } # End of looping through ranges.
4130 # Intersection fully computed, or now know that there is no overlap
4131 return $check_if_overlapping ? 0 : $new;
4135 # Returns boolean giving whether the two arguments overlap somewhere
4139 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4141 return $self->_intersect($other, 1);
4145 # Add a range to the list.
4150 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4152 return $self->_add_delete('+', $start, $end, "");
4155 sub matches_identically_to {
4156 # Return a boolean as to whether or not two Range_Lists match identical
4157 # sets of code points.
4161 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4163 # These are ordered in increasing real time to figure out (at least
4164 # until a patch changes that and doesn't change this)
4165 return 0 if $self->max != $other->max;
4166 return 0 if $self->min != $other->min;
4167 return 0 if $self->range_count != $other->range_count;
4168 return 0 if $self->count != $other->count;
4170 # Here they could be identical because all the tests above passed.
4171 # The loop below is somewhat simpler since we know they have the same
4172 # number of elements. Compare range by range, until reach the end or
4173 # find something that differs.
4174 my @a_ranges = $self->ranges;
4175 my @b_ranges = $other->ranges;
4176 for my $i (0 .. @a_ranges - 1) {
4177 my $a = $a_ranges[$i];
4178 my $b = $b_ranges[$i];
4179 trace "self $a; other $b" if main::DEBUG && $to_trace;
4180 return 0 if $a->start != $b->start || $a->end != $b->end;
4185 sub is_code_point_usable {
4186 # This used only for making the test script. See if the input
4187 # proposed trial code point is one that Perl will handle. If second
4188 # parameter is 0, it won't select some code points for various
4189 # reasons, noted below.
4192 my $try_hard = shift;
4193 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4195 return 0 if $code < 0; # Never use a negative
4197 # shun null. I'm (khw) not sure why this was done, but NULL would be
4198 # the character very frequently used.
4199 return $try_hard if $code == 0x0000;
4201 return 0 if $try_hard; # XXX Temporary until fix utf8.c
4203 # shun non-character code points.
4204 return $try_hard if $code >= 0xFDD0 && $code <= 0xFDEF;
4205 return $try_hard if ($code & 0xFFFE) == 0xFFFE; # includes FFFF
4207 return $try_hard if $code > $LAST_UNICODE_CODEPOINT; # keep in range
4208 return $try_hard if $code >= 0xD800 && $code <= 0xDFFF; # no surrogate
4213 sub get_valid_code_point {
4214 # Return a code point that's part of the range list. Returns nothing
4215 # if the table is empty or we can't find a suitable code point. This
4216 # used only for making the test script.
4219 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4221 my $addr = do { no overloading; pack 'J', $self; };
4223 # On first pass, don't choose less desirable code points; if no good
4224 # one is found, repeat, allowing a less desirable one to be selected.
4225 for my $try_hard (0, 1) {
4227 # Look through all the ranges for a usable code point.
4228 for my $set ($self->ranges) {
4230 # Try the edge cases first, starting with the end point of the
4232 my $end = $set->end;
4233 return $end if is_code_point_usable($end, $try_hard);
4235 # End point didn't, work. Start at the beginning and try
4236 # every one until find one that does work.
4237 for my $trial ($set->start .. $end - 1) {
4238 return $trial if is_code_point_usable($trial, $try_hard);
4242 return (); # If none found, give up.
4245 sub get_invalid_code_point {
4246 # Return a code point that's not part of the table. Returns nothing
4247 # if the table covers all code points or a suitable code point can't
4248 # be found. This used only for making the test script.
4251 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4253 # Just find a valid code point of the inverse, if any.
4254 return Range_List->new(Initialize => ~ $self)->get_valid_code_point;
4256 } # end closure for Range_List
4259 use base '_Range_List_Base';
4261 # A Range_Map is a range list in which the range values (called maps) are
4262 # significant, and hence shouldn't be manipulated by our other code, which
4263 # could be ambiguous or lose things. For example, in taking the union of two
4264 # lists, which share code points, but which have differing values, which one
4265 # has precedence in the union?
4266 # It turns out that these operations aren't really necessary for map tables,
4267 # and so this class was created to make sure they aren't accidentally
4273 # Add a range containing a mapping value to the list
4276 # Rest of parameters passed on
4278 return $self->_add_delete('+', @_);
4282 # Adds entry to a range list which can duplicate an existing entry
4285 my $code_point = shift;
4287 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4289 return $self->add_map($code_point, $code_point,
4290 $value, Replace => $MULTIPLE);
4292 } # End of closure for package Range_Map
4294 package _Base_Table;
4296 # A table is the basic data structure that gets written out into a file for
4297 # use by the Perl core. This is the abstract base class implementing the
4298 # common elements from the derived ones. A list of the methods to be
4299 # furnished by an implementing class is just after the constructor.
4301 sub standardize { return main::standardize($_[0]); }
4302 sub trace { return main::trace(@_); }
4306 main::setup_package();
4309 # Object containing the ranges of the table.
4310 main::set_access('range_list', \%range_list, 'p_r', 'p_s');
4313 # The full table name.
4314 main::set_access('full_name', \%full_name, 'r');
4317 # The table name, almost always shorter
4318 main::set_access('name', \%name, 'r');
4321 # The shortest of all the aliases for this table, with underscores removed
4322 main::set_access('short_name', \%short_name);
4324 my %nominal_short_name_length;
4325 # The length of short_name before removing underscores
4326 main::set_access('nominal_short_name_length',
4327 \%nominal_short_name_length);
4330 # The complete name, including property.
4331 main::set_access('complete_name', \%complete_name, 'r');
4334 # Parent property this table is attached to.
4335 main::set_access('property', \%property, 'r');
4338 # Ordered list of aliases of the table's name. The first ones in the list
4339 # are output first in comments
4340 main::set_access('aliases', \%aliases, 'readable_array');
4343 # A comment associated with the table for human readers of the files
4344 main::set_access('comment', \%comment, 's');
4347 # A comment giving a short description of the table's meaning for human
4348 # readers of the files.
4349 main::set_access('description', \%description, 'readable_array');
4352 # A comment giving a short note about the table for human readers of the
4354 main::set_access('note', \%note, 'readable_array');
4357 # Boolean; if set means any file that contains this table is marked as for
4358 # internal-only use.
4359 main::set_access('internal_only', \%internal_only);
4361 my %find_table_from_alias;
4362 # The parent property passes this pointer to a hash which this class adds
4363 # all its aliases to, so that the parent can quickly take an alias and
4365 main::set_access('find_table_from_alias', \%find_table_from_alias, 'p_r');
4368 # After this table is made equivalent to another one; we shouldn't go
4369 # changing the contents because that could mean it's no longer equivalent
4370 main::set_access('locked', \%locked, 'r');
4373 # This gives the final path to the file containing the table. Each
4374 # directory in the path is an element in the array
4375 main::set_access('file_path', \%file_path, 'readable_array');
4378 # What is the table's status, normal, $OBSOLETE, etc. Enum
4379 main::set_access('status', \%status, 'r');
4382 # A comment about its being obsolete, or whatever non normal status it has
4383 main::set_access('status_info', \%status_info, 'r');
4386 # Is the table to be output with each range only a single code point?
4387 # This is done to avoid breaking existing code that may have come to rely
4388 # on this behavior in previous versions of this program.)
4389 main::set_access('range_size_1', \%range_size_1, 'r', 's');
4392 # A boolean set iff this table is a Perl extension to the Unicode
4394 main::set_access('perl_extension', \%perl_extension, 'r');
4396 my %output_range_counts;
4397 # A boolean set iff this table is to have comments written in the
4398 # output file that contain the number of code points in the range.
4399 # The constructor can override the global flag of the same name.
4400 main::set_access('output_range_counts', \%output_range_counts, 'r');
4403 # The format of the entries of the table. This is calculated from the
4404 # data in the table (or passed in the constructor). This is an enum e.g.,
4406 main::set_access('format', \%format, 'r', 'p_s');
4409 # All arguments are key => value pairs, which you can see below, most
4410 # of which match fields documented above. Otherwise: Pod_Entry,
4411 # Externally_Ok, and Fuzzy apply to the names of the table, and are
4412 # documented in the Alias package
4414 return Carp::carp_too_few_args(\@_, 2) if main::DEBUG && @_ < 2;
4418 my $self = bless \do { my $anonymous_scalar }, $class;
4419 my $addr = do { no overloading; pack 'J', $self; };
4423 $name{$addr} = delete $args{'Name'};
4424 $find_table_from_alias{$addr} = delete $args{'_Alias_Hash'};
4425 $full_name{$addr} = delete $args{'Full_Name'};
4426 my $complete_name = $complete_name{$addr}
4427 = delete $args{'Complete_Name'};
4428 $format{$addr} = delete $args{'Format'};
4429 $internal_only{$addr} = delete $args{'Internal_Only_Warning'} || 0;
4430 $output_range_counts{$addr} = delete $args{'Output_Range_Counts'};
4431 $property{$addr} = delete $args{'_Property'};
4432 $range_list{$addr} = delete $args{'_Range_List'};
4433 $status{$addr} = delete $args{'Status'} || $NORMAL;
4434 $status_info{$addr} = delete $args{'_Status_Info'} || "";
4435 $range_size_1{$addr} = delete $args{'Range_Size_1'} || 0;
4437 my $description = delete $args{'Description'};
4438 my $externally_ok = delete $args{'Externally_Ok'};
4439 my $loose_match = delete $args{'Fuzzy'};
4440 my $note = delete $args{'Note'};
4441 my $make_pod_entry = delete $args{'Pod_Entry'};
4442 my $perl_extension = delete $args{'Perl_Extension'};
4444 # Shouldn't have any left over
4445 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
4447 # Can't use || above because conceivably the name could be 0, and
4448 # can't use // operator in case this program gets used in Perl 5.8
4449 $full_name{$addr} = $name{$addr} if ! defined $full_name{$addr};
4450 $output_range_counts{$addr} = $output_range_counts if
4451 ! defined $output_range_counts{$addr};
4453 $aliases{$addr} = [ ];
4454 $comment{$addr} = [ ];
4455 $description{$addr} = [ ];
4457 $file_path{$addr} = [ ];
4458 $locked{$addr} = "";
4460 push @{$description{$addr}}, $description if $description;
4461 push @{$note{$addr}}, $note if $note;
4463 if ($status{$addr} eq $PLACEHOLDER) {
4465 # A placeholder table doesn't get documented, is a perl extension,
4466 # and quite likely will be empty
4467 $make_pod_entry = 0 if ! defined $make_pod_entry;
4468 $perl_extension = 1 if ! defined $perl_extension;
4469 push @tables_that_may_be_empty, $complete_name{$addr};
4471 elsif (! $status{$addr}) {
4473 # If hasn't set its status already, see if it is on one of the
4474 # lists of properties or tables that have particular statuses; if
4475 # not, is normal. The lists are prioritized so the most serious
4476 # ones are checked first
4477 if (exists $why_suppressed{$complete_name}
4478 # Don't suppress if overriden
4479 && ! grep { $_ eq $complete_name{$addr} }
4480 @output_mapped_properties)
4482 $status{$addr} = $SUPPRESSED;
4484 elsif (exists $why_deprecated{$complete_name}) {
4485 $status{$addr} = $DEPRECATED;
4487 elsif (exists $why_stabilized{$complete_name}) {
4488 $status{$addr} = $STABILIZED;
4490 elsif (exists $why_obsolete{$complete_name}) {
4491 $status{$addr} = $OBSOLETE;
4494 # Existence above doesn't necessarily mean there is a message
4495 # associated with it. Use the most serious message.
4496 if ($status{$addr}) {
4497 if ($why_suppressed{$complete_name}) {
4499 = $why_suppressed{$complete_name};
4501 elsif ($why_deprecated{$complete_name}) {
4503 = $why_deprecated{$complete_name};
4505 elsif ($why_stabilized{$complete_name}) {
4507 = $why_stabilized{$complete_name};
4509 elsif ($why_obsolete{$complete_name}) {
4511 = $why_obsolete{$complete_name};
4516 $perl_extension{$addr} = $perl_extension || 0;
4518 # By convention what typically gets printed only or first is what's
4519 # first in the list, so put the full name there for good output
4520 # clarity. Other routines rely on the full name being first on the
4522 $self->add_alias($full_name{$addr},
4523 Externally_Ok => $externally_ok,
4524 Fuzzy => $loose_match,
4525 Pod_Entry => $make_pod_entry,
4526 Status => $status{$addr},
4529 # Then comes the other name, if meaningfully different.
4530 if (standardize($full_name{$addr}) ne standardize($name{$addr})) {
4531 $self->add_alias($name{$addr},
4532 Externally_Ok => $externally_ok,
4533 Fuzzy => $loose_match,
4534 Pod_Entry => $make_pod_entry,
4535 Status => $status{$addr},
4542 # Here are the methods that are required to be defined by any derived
4545 handle_special_range
4549 # write() knows how to write out normal ranges, but it calls
4550 # handle_special_range() when it encounters a non-normal one.
4551 # append_to_body() is called by it after it has handled all
4552 # ranges to add anything after the main portion of the table.
4553 # And finally, pre_body() is called after all this to build up
4554 # anything that should appear before the main portion of the
4555 # table. Doing it this way allows things in the middle to
4556 # affect what should appear before the main portion of the
4561 Carp::my_carp_bug( __LINE__
4562 . ": Must create method '$sub()' for "
4570 "." => \&main::_operator_dot,
4571 '!=' => \&main::_operator_not_equal,
4572 '==' => \&main::_operator_equal,
4576 # Returns the array of ranges associated with this table.
4579 return $range_list{pack 'J', shift}->ranges;
4583 # Add a synonym for this table.
4585 return Carp::carp_too_few_args(\@_, 3) if main::DEBUG && @_ < 3;
4588 my $name = shift; # The name to add.
4589 my $pointer = shift; # What the alias hash should point to. For
4590 # map tables, this is the parent property;
4591 # for match tables, it is the table itself.
4594 my $loose_match = delete $args{'Fuzzy'};
4596 my $make_pod_entry = delete $args{'Pod_Entry'};
4597 $make_pod_entry = $YES unless defined $make_pod_entry;
4599 my $externally_ok = delete $args{'Externally_Ok'};
4600 $externally_ok = 1 unless defined $externally_ok;
4602 my $status = delete $args{'Status'};
4603 $status = $NORMAL unless defined $status;
4605 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
4607 # Capitalize the first letter of the alias unless it is one of the CJK
4608 # ones which specifically begins with a lower 'k'. Do this because
4609 # Unicode has varied whether they capitalize first letters or not, and
4610 # have later changed their minds and capitalized them, but not the
4611 # other way around. So do it always and avoid changes from release to
4613 $name = ucfirst($name) unless $name =~ /^k[A-Z]/;
4615 my $addr = do { no overloading; pack 'J', $self; };
4617 # Figure out if should be loosely matched if not already specified.
4618 if (! defined $loose_match) {
4620 # Is a loose_match if isn't null, and doesn't begin with an
4621 # underscore and isn't just a number
4623 && substr($name, 0, 1) ne '_'
4624 && $name !~ qr{^[0-9_.+-/]+$})
4633 # If this alias has already been defined, do nothing.
4634 return if defined $find_table_from_alias{$addr}->{$name};
4636 # That includes if it is standardly equivalent to an existing alias,
4637 # in which case, add this name to the list, so won't have to search
4639 my $standard_name = main::standardize($name);
4640 if (defined $find_table_from_alias{$addr}->{$standard_name}) {
4641 $find_table_from_alias{$addr}->{$name}
4642 = $find_table_from_alias{$addr}->{$standard_name};
4646 # Set the index hash for this alias for future quick reference.
4647 $find_table_from_alias{$addr}->{$name} = $pointer;
4648 $find_table_from_alias{$addr}->{$standard_name} = $pointer;
4649 local $to_trace = 0 if main::DEBUG;
4650 trace "adding alias $name to $pointer" if main::DEBUG && $to_trace;
4651 trace "adding alias $standard_name to $pointer" if main::DEBUG && $to_trace;
4654 # Put the new alias at the end of the list of aliases unless the final
4655 # element begins with an underscore (meaning it is for internal perl
4656 # use) or is all numeric, in which case, put the new one before that
4657 # one. This floats any all-numeric or underscore-beginning aliases to
4658 # the end. This is done so that they are listed last in output lists,
4659 # to encourage the user to use a better name (either more descriptive
4660 # or not an internal-only one) instead. This ordering is relied on
4661 # implicitly elsewhere in this program, like in short_name()
4662 my $list = $aliases{$addr};
4663 my $insert_position = (@$list == 0
4664 || (substr($list->[-1]->name, 0, 1) ne '_'
4665 && $list->[-1]->name =~ /\D/))
4671 Alias->new($name, $loose_match, $make_pod_entry,
4672 $externally_ok, $status);
4674 # This name may be shorter than any existing ones, so clear the cache
4675 # of the shortest, so will have to be recalculated.
4677 undef $short_name{pack 'J', $self};
4682 # Returns a name suitable for use as the base part of a file name.
4683 # That is, shorter wins. It can return undef if there is no suitable
4684 # name. The name has all non-essential underscores removed.
4686 # The optional second parameter is a reference to a scalar in which
4687 # this routine will store the length the returned name had before the
4688 # underscores were removed, or undef if the return is undef.
4690 # The shortest name can change if new aliases are added. So using
4691 # this should be deferred until after all these are added. The code
4692 # that does that should clear this one's cache.
4693 # Any name with alphabetics is preferred over an all numeric one, even
4697 my $nominal_length_ptr = shift;
4698 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4700 my $addr = do { no overloading; pack 'J', $self; };
4702 # For efficiency, don't recalculate, but this means that adding new
4703 # aliases could change what the shortest is, so the code that does
4704 # that needs to undef this.
4705 if (defined $short_name{$addr}) {
4706 if ($nominal_length_ptr) {
4707 $$nominal_length_ptr = $nominal_short_name_length{$addr};
4709 return $short_name{$addr};
4712 # Look at each alias
4713 foreach my $alias ($self->aliases()) {
4715 # Don't use an alias that isn't ok to use for an external name.
4716 next if ! $alias->externally_ok;
4718 my $name = main::Standardize($alias->name);
4719 trace $self, $name if main::DEBUG && $to_trace;
4721 # Take the first one, or a shorter one that isn't numeric. This
4722 # relies on numeric aliases always being last in the array
4723 # returned by aliases(). Any alpha one will have precedence.
4724 if (! defined $short_name{$addr}
4726 && length($name) < length($short_name{$addr})))
4728 # Remove interior underscores.
4729 ($short_name{$addr} = $name) =~ s/ (?<= . ) _ (?= . ) //xg;
4731 $nominal_short_name_length{$addr} = length $name;
4735 # If no suitable external name return undef
4736 if (! defined $short_name{$addr}) {
4737 $$nominal_length_ptr = undef if $nominal_length_ptr;
4741 # Don't allow a null external name.
4742 if ($short_name{$addr} eq "") {
4743 $short_name{$addr} = '_';
4744 $nominal_short_name_length{$addr} = 1;
4747 trace $self, $short_name{$addr} if main::DEBUG && $to_trace;
4749 if ($nominal_length_ptr) {
4750 $$nominal_length_ptr = $nominal_short_name_length{$addr};
4752 return $short_name{$addr};
4756 # Returns the external name that this table should be known by. This
4757 # is usually the short_name, but not if the short_name is undefined.
4760 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4762 my $short = $self->short_name;
4763 return $short if defined $short;
4768 sub add_description { # Adds the parameter as a short description.
4771 my $description = shift;
4773 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4776 push @{$description{pack 'J', $self}}, $description;
4781 sub add_note { # Adds the parameter as a short note.
4786 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4789 push @{$note{pack 'J', $self}}, $note;
4794 sub add_comment { # Adds the parameter as a comment.
4797 my $comment = shift;
4798 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4803 push @{$comment{pack 'J', $self}}, $comment;
4809 # Return the current comment for this table. If called in list
4810 # context, returns the array of comments. In scalar, returns a string
4811 # of each element joined together with a period ending each.
4814 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4816 my $addr = do { no overloading; pack 'J', $self; };
4817 my @list = @{$comment{$addr}};
4818 return @list if wantarray;
4820 foreach my $sentence (@list) {
4821 $return .= '. ' if $return;
4822 $return .= $sentence;
4825 $return .= '.' if $return;
4830 # Initialize the table with the argument which is any valid
4831 # initialization for range lists.
4834 my $addr = do { no overloading; pack 'J', $self; };
4835 my $initialization = shift;
4836 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4838 # Replace the current range list with a new one of the same exact
4840 my $class = ref $range_list{$addr};
4841 $range_list{$addr} = $class->new(Owner => $self,
4842 Initialize => $initialization);
4848 # The header that is output for the table in the file it is written
4852 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4855 $return .= $DEVELOPMENT_ONLY if $compare_versions;
4858 $return .= $INTERNAL_ONLY if $internal_only{pack 'J', $self};
4863 # Write a representation of the table to its file. It calls several
4864 # functions furnished by sub-classes of this abstract base class to
4865 # handle non-normal ranges, to add stuff before the table, and at its
4869 my $tab_stops = shift; # The number of tab stops over to put any
4871 my $suppress_value = shift; # Optional, if the value associated with
4872 # a range equals this one, don't write
4874 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4876 my $addr = do { no overloading; pack 'J', $self; };
4878 # Start with the header
4879 my @HEADER = $self->header;
4882 push @HEADER, "\n", main::simple_fold($comment{$addr}, '# '), "\n"
4885 # Things discovered processing the main body of the document may
4886 # affect what gets output before it, therefore pre_body() isn't called
4887 # until after all other processing of the table is done.
4889 # The main body looks like a 'here' document. If annotating, get rid
4890 # of the comments before passing to the caller, as some callers, such
4891 # as charnames.pm, can't cope with them. (Outputting range counts
4892 # also introduces comments, but these don't show up in the tables that
4893 # can't cope with comments, and there aren't that many of them that
4894 # it's worth the extra real time to get rid of them).
4897 # Use the line below in Perls that don't have /r
4898 #push @OUT, 'return join "\n", map { s/\s*#.*//mg; $_ } split "\n", <<\'END\';' . "\n";
4899 push @OUT, "return <<'END' =~ s/\\s*#.*//mgr;\n";
4901 push @OUT, "return <<'END';\n";
4904 if ($range_list{$addr}->is_empty) {
4906 # This is a kludge for empty tables to silence a warning in
4907 # utf8.c, which can't really deal with empty tables, but it can
4908 # deal with a table that matches nothing, as the inverse of 'Any'
4910 push @OUT, "!utf8::IsAny\n";
4913 my $range_size_1 = $range_size_1{$addr};
4914 my $format; # Used only in $annotate option
4915 my $include_name; # Used only in $annotate option
4919 # if annotating each code point, must print 1 per line.
4920 # The variable could point to a subroutine, and we don't want
4921 # to lose that fact, so only set if not set already
4922 $range_size_1 = 1 if ! $range_size_1;
4924 $format = $self->format;
4926 # The name of the character is output only for tables that
4927 # don't already include the name in the output.
4928 my $property = $self->property;
4930 ! ($property == $perl_charname
4931 || $property == main::property_ref('Unicode_1_Name')
4932 || $property == main::property_ref('Name')
4933 || $property == main::property_ref('Name_Alias')
4937 # Output each range as part of the here document.
4939 for my $set ($range_list{$addr}->ranges) {
4940 if ($set->type != 0) {
4941 $self->handle_special_range($set);
4944 my $start = $set->start;
4945 my $end = $set->end;
4946 my $value = $set->value;
4948 # Don't output ranges whose value is the one to suppress
4949 next RANGE if defined $suppress_value
4950 && $value eq $suppress_value;
4952 # If there is a range and doesn't need a single point range
4954 if ($start != $end && ! $range_size_1) {
4955 push @OUT, sprintf "%04X\t%04X\t%s", $start, $end, $value;
4957 # Add a comment with the size of the range, if requested.
4958 # Expand Tabs to make sure they all start in the same
4959 # column, and then unexpand to use mostly tabs.
4960 if (! $output_range_counts{$addr}) {
4964 $OUT[-1] = Text::Tabs::expand($OUT[-1]);
4965 my $count = main::clarify_number($end - $start + 1);
4968 my $width = $tab_stops * 8 - 1;
4969 $OUT[-1] = sprintf("%-*s # [%s]\n",
4973 $OUT[-1] = Text::Tabs::unexpand($OUT[-1]);
4978 # Here to output a single code point per line
4980 # If not to annotate, use the simple formats
4983 # Use any passed in subroutine to output.
4984 if (ref $range_size_1 eq 'CODE') {
4985 for my $i ($start .. $end) {
4986 push @OUT, &{$range_size_1}($i, $value);
4991 # Here, caller is ok with default output.
4992 for (my $i = $start; $i <= $end; $i++) {
4993 push @OUT, sprintf "%04X\t\t%s\n", $i, $value;
4999 # Here, wants annotation.
5000 for (my $i = $start; $i <= $end; $i++) {
5002 # Get character information if don't have it already
5003 main::populate_char_info($i)
5004 if ! defined $viacode[$i];
5005 my $type = $annotate_char_type[$i];
5007 # Figure out if should output the next code points as part
5008 # of a range or not. If this is not in an annotation
5009 # range, then won't output as a range, so returns $i.
5010 # Otherwise use the end of the annotation range, but no
5011 # further than the maximum possible end point of the loop.
5012 my $range_end = main::min($annotate_ranges->value_of($i)
5016 # Use a range if it is a range, and either is one of the
5017 # special annotation ranges, or the range is at most 3
5018 # long. This last case causes the algorithmically named
5019 # code points to be output individually in spans of at
5020 # most 3, as they are the ones whose $type is > 0.
5021 if ($range_end != $i
5022 && ( $type < 0 || $range_end - $i > 2))
5024 # Here is to output a range. We don't allow a
5025 # caller-specified output format--just use the
5027 push @OUT, sprintf "%04X\t%04X\t%s\t#", $i,
5030 my $range_name = $viacode[$i];
5032 # For the code points which end in their hex value, we
5033 # eliminate that from the output annotation, and
5034 # capitalize only the first letter of each word.
5035 if ($type == $CP_IN_NAME) {
5036 my $hex = sprintf "%04X", $i;
5037 $range_name =~ s/-$hex$//;
5038 my @words = split " ", $range_name;
5039 for my $word (@words) {
5040 $word = ucfirst(lc($word)) if $word ne 'CJK';
5042 $range_name = join " ", @words;
5044 elsif ($type == $HANGUL_SYLLABLE) {
5045 $range_name = "Hangul Syllable";
5048 $OUT[-1] .= " $range_name" if $range_name;
5050 # Include the number of code points in the range
5051 my $count = main::clarify_number($range_end - $i + 1);
5052 $OUT[-1] .= " [$count]\n";
5054 # Skip to the end of the range
5057 else { # Not in a range.
5060 # When outputting the names of each character, use
5061 # the character itself if printable
5062 $comment .= "'" . chr($i) . "' " if $printable[$i];
5064 # To make it more readable, use a minimum indentation
5067 # Determine the annotation
5068 if ($format eq $DECOMP_STRING_FORMAT) {
5070 # This is very specialized, with the type of
5071 # decomposition beginning the line enclosed in
5072 # <...>, and the code points that the code point
5073 # decomposes to separated by blanks. Create two
5074 # strings, one of the printable characters, and
5075 # one of their official names.
5076 (my $map = $value) =~ s/ \ * < .*? > \ +//x;
5080 foreach my $to (split " ", $map) {
5081 $to = CORE::hex $to;
5082 $to_name .= " + " if $to_name;
5083 $to_chr .= chr($to);
5084 main::populate_char_info($to)
5085 if ! defined $viacode[$to];
5086 $to_name .= $viacode[$to];
5090 "=> '$to_chr'; $viacode[$i] => $to_name";
5091 $comment_indent = 25; # Determined by experiment
5095 # Assume that any table that has hex format is a
5096 # mapping of one code point to another.
5097 if ($format eq $HEX_FORMAT) {
5098 my $decimal_value = CORE::hex $value;
5099 main::populate_char_info($decimal_value)
5100 if ! defined $viacode[$decimal_value];
5102 . chr($decimal_value)
5103 . "'; " if $printable[$decimal_value];
5105 $comment .= $viacode[$i] if $include_name
5107 if ($format eq $HEX_FORMAT) {
5108 my $decimal_value = CORE::hex $value;
5109 $comment .= " => $viacode[$decimal_value]"
5110 if $viacode[$decimal_value];
5113 # If including the name, no need to indent, as the
5114 # name will already be way across the line.
5115 $comment_indent = ($include_name) ? 0 : 60;
5118 # Use any passed in routine to output the base part of
5120 if (ref $range_size_1 eq 'CODE') {
5121 my $base_part = &{$range_size_1}($i, $value);
5123 push @OUT, $base_part;
5126 push @OUT, sprintf "%04X\t\t%s", $i, $value;
5129 # And add the annotation.
5130 $OUT[-1] = sprintf "%-*s\t# %s", $comment_indent,
5132 $comment if $comment;
5136 } # End of loop through all the table's ranges
5139 # Add anything that goes after the main body, but within the here
5141 my $append_to_body = $self->append_to_body;
5142 push @OUT, $append_to_body if $append_to_body;
5144 # And finish the here document.
5147 # Done with the main portion of the body. Can now figure out what
5148 # should appear before it in the file.
5149 my $pre_body = $self->pre_body;
5150 push @HEADER, $pre_body, "\n" if $pre_body;
5152 # All these files have a .pl suffix
5153 $file_path{$addr}->[-1] .= '.pl';
5155 main::write($file_path{$addr},
5156 $annotate, # utf8 iff annotating
5162 sub set_status { # Set the table's status
5164 my $status = shift; # The status enum value
5165 my $info = shift; # Any message associated with it.
5166 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5168 my $addr = do { no overloading; pack 'J', $self; };
5170 $status{$addr} = $status;
5171 $status_info{$addr} = $info;
5176 # Don't allow changes to the table from now on. This stores a stack
5177 # trace of where it was called, so that later attempts to modify it
5178 # can immediately show where it got locked.
5181 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5183 my $addr = do { no overloading; pack 'J', $self; };
5185 $locked{$addr} = "";
5187 my $line = (caller(0))[2];
5190 # Accumulate the stack trace
5192 my ($pkg, $file, $caller_line, $caller) = caller $i++;
5194 last unless defined $caller;
5196 $locked{$addr} .= " called from $caller() at line $line\n";
5197 $line = $caller_line;
5199 $locked{$addr} .= " called from main at line $line\n";
5204 sub carp_if_locked {
5205 # Return whether a table is locked or not, and, by the way, complain
5209 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5211 my $addr = do { no overloading; pack 'J', $self; };
5213 return 0 if ! $locked{$addr};
5214 Carp::my_carp_bug("Can't modify a locked table. Stack trace of locking:\n$locked{$addr}\n\n");
5218 sub set_file_path { # Set the final directory path for this table
5220 # Rest of parameters passed on
5223 @{$file_path{pack 'J', $self}} = @_;
5227 # Accessors for the range list stored in this table. First for
5236 matches_identically_to
5250 return $range_list{pack 'J', $self}->$sub(@_);
5254 # Then for ones that should fail if locked
5264 return if $self->carp_if_locked;
5266 return $range_list{pack 'J', $self}->$sub(@_);
5273 use base '_Base_Table';
5275 # A Map Table is a table that contains the mappings from code points to
5276 # values. There are two weird cases:
5277 # 1) Anomalous entries are ones that aren't maps of ranges of code points, but
5278 # are written in the table's file at the end of the table nonetheless. It
5279 # requires specially constructed code to handle these; utf8.c can not read
5280 # these in, so they should not go in $map_directory. As of this writing,
5281 # the only case that these happen is for named sequences used in
5282 # charnames.pm. But this code doesn't enforce any syntax on these, so
5283 # something else could come along that uses it.
5284 # 2) Specials are anything that doesn't fit syntactically into the body of the
5285 # table. The ranges for these have a map type of non-zero. The code below
5286 # knows about and handles each possible type. In most cases, these are
5287 # written as part of the header.
5289 # A map table deliberately can't be manipulated at will unlike match tables.
5290 # This is because of the ambiguities having to do with what to do with
5291 # overlapping code points. And there just isn't a need for those things;
5292 # what one wants to do is just query, add, replace, or delete mappings, plus
5293 # write the final result.
5294 # However, there is a method to get the list of possible ranges that aren't in
5295 # this table to use for defaulting missing code point mappings. And,
5296 # map_add_or_replace_non_nulls() does allow one to add another table to this
5297 # one, but it is clearly very specialized, and defined that the other's
5298 # non-null values replace this one's if there is any overlap.
5300 sub trace { return main::trace(@_); }
5304 main::setup_package();
5307 # Many input files omit some entries; this gives what the mapping for the
5308 # missing entries should be
5309 main::set_access('default_map', \%default_map, 'r');
5311 my %anomalous_entries;
5312 # Things that go in the body of the table which don't fit the normal
5313 # scheme of things, like having a range. Not much can be done with these
5314 # once there except to output them. This was created to handle named
5316 main::set_access('anomalous_entry', \%anomalous_entries, 'a');
5317 main::set_access('anomalous_entries', # Append singular, read plural
5318 \%anomalous_entries,
5322 # This is a string, solely for documentation, indicating how one can get
5323 # access to this property via the Perl core.
5324 main::set_access('core_access', \%core_access, 'r', 's');
5327 # Boolean as to whether or not to write out this map table
5328 main::set_access('to_output_map', \%to_output_map, 's');
5337 # Optional initialization data for the table.
5338 my $initialize = delete $args{'Initialize'};
5340 my $core_access = delete $args{'Core_Access'};
5341 my $default_map = delete $args{'Default_Map'};
5342 my $property = delete $args{'_Property'};
5343 my $full_name = delete $args{'Full_Name'};
5344 # Rest of parameters passed on
5346 my $range_list = Range_Map->new(Owner => $property);
5348 my $self = $class->SUPER::new(
5350 Complete_Name => $full_name,
5351 Full_Name => $full_name,
5352 _Property => $property,
5353 _Range_List => $range_list,
5356 my $addr = do { no overloading; pack 'J', $self; };
5358 $anomalous_entries{$addr} = [];
5359 $core_access{$addr} = $core_access;
5360 $default_map{$addr} = $default_map;
5362 $self->initialize($initialize) if defined $initialize;
5369 qw("") => "_operator_stringify",
5372 sub _operator_stringify {
5375 my $name = $self->property->full_name;
5376 $name = '""' if $name eq "";
5377 return "Map table for Property '$name'";
5381 # Add a synonym for this table (which means the property itself)
5384 # Rest of parameters passed on.
5386 $self->SUPER::add_alias($name, $self->property, @_);
5391 # Add a range of code points to the list of specially-handled code
5392 # points. $MULTI_CP is assumed if the type of special is not passed
5401 my $type = delete $args{'Type'} || 0;
5402 # Rest of parameters passed on
5404 # Can't change the table if locked.
5405 return if $self->carp_if_locked;
5407 my $addr = do { no overloading; pack 'J', $self; };
5409 $self->_range_list->add_map($lower, $upper,
5416 sub append_to_body {
5417 # Adds to the written HERE document of the table's body any anomalous
5418 # entries in the table..
5421 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5423 my $addr = do { no overloading; pack 'J', $self; };
5425 return "" unless @{$anomalous_entries{$addr}};
5426 return join("\n", @{$anomalous_entries{$addr}}) . "\n";
5429 sub map_add_or_replace_non_nulls {
5430 # This adds the mappings in the table $other to $self. Non-null
5431 # mappings from $other override those in $self. It essentially merges
5432 # the two tables, with the second having priority except for null
5437 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5439 return if $self->carp_if_locked;
5441 if (! $other->isa(__PACKAGE__)) {
5442 Carp::my_carp_bug("$other should be a "
5450 my $addr = do { no overloading; pack 'J', $self; };
5451 my $other_addr = do { no overloading; pack 'J', $other; };
5453 local $to_trace = 0 if main::DEBUG;
5455 my $self_range_list = $self->_range_list;
5456 my $other_range_list = $other->_range_list;
5457 foreach my $range ($other_range_list->ranges) {
5458 my $value = $range->value;
5459 next if $value eq "";
5460 $self_range_list->_add_delete('+',
5464 Type => $range->type,
5465 Replace => $UNCONDITIONALLY);
5471 sub set_default_map {
5472 # Define what code points that are missing from the input files should
5477 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5479 my $addr = do { no overloading; pack 'J', $self; };
5481 # Convert the input to the standard equivalent, if any (won't have any
5482 # for $STRING properties)
5483 my $standard = $self->_find_table_from_alias->{$map};
5484 $map = $standard->name if defined $standard;
5486 # Warn if there already is a non-equivalent default map for this
5487 # property. Note that a default map can be a ref, which means that
5488 # what it actually means is delayed until later in the program, and it
5489 # IS permissible to override it here without a message.
5490 my $default_map = $default_map{$addr};
5491 if (defined $default_map
5492 && ! ref($default_map)
5493 && $default_map ne $map
5494 && main::Standardize($map) ne $default_map)
5496 my $property = $self->property;
5497 my $map_table = $property->table($map);
5498 my $default_table = $property->table($default_map);
5499 if (defined $map_table
5500 && defined $default_table
5501 && $map_table != $default_table)
5503 Carp::my_carp("Changing the default mapping for "
5505 . " from $default_map to $map'");
5509 $default_map{$addr} = $map;
5511 # Don't also create any missing table for this map at this point,
5512 # because if we did, it could get done before the main table add is
5513 # done for PropValueAliases.txt; instead the caller will have to make
5514 # sure it exists, if desired.
5519 # Returns boolean: should we write this map table?
5522 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5524 my $addr = do { no overloading; pack 'J', $self; };
5526 # If overridden, use that
5527 return $to_output_map{$addr} if defined $to_output_map{$addr};
5529 my $full_name = $self->full_name;
5531 # If table says to output, do so; if says to suppress it, do do.
5532 return 1 if grep { $_ eq $full_name } @output_mapped_properties;
5533 return 0 if $self->status eq $SUPPRESSED;
5535 my $type = $self->property->type;
5537 # Don't want to output binary map tables even for debugging.
5538 return 0 if $type == $BINARY;
5540 # But do want to output string ones.
5541 return 1 if $type == $STRING;
5543 # Otherwise is an $ENUM, don't output it
5548 # Returns a Range_List that is gaps of the current table. That is,
5552 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5554 my $current = Range_List->new(Initialize => $self->_range_list,
5555 Owner => $self->property);
5559 sub set_final_comment {
5560 # Just before output, create the comment that heads the file
5561 # containing this table.
5564 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5566 # No sense generating a comment if aren't going to write it out.
5567 return if ! $self->to_output_map;
5569 my $addr = do { no overloading; pack 'J', $self; };
5571 my $property = $self->property;
5573 # Get all the possible names for this property. Don't use any that
5574 # aren't ok for use in a file name, etc. This is perhaps causing that
5575 # flag to do double duty, and may have to be changed in the future to
5576 # have our own flag for just this purpose; but it works now to exclude
5577 # Perl generated synonyms from the lists for properties, where the
5578 # name is always the proper Unicode one.
5579 my @property_aliases = grep { $_->externally_ok } $self->aliases;
5581 my $count = $self->count;
5582 my $default_map = $default_map{$addr};
5584 # The ranges that map to the default aren't output, so subtract that
5585 # to get those actually output. A property with matching tables
5586 # already has the information calculated.
5587 if ($property->type != $STRING) {
5588 $count -= $property->table($default_map)->count;
5590 elsif (defined $default_map) {
5592 # But for $STRING properties, must calculate now. Subtract the
5593 # count from each range that maps to the default.
5594 foreach my $range ($self->_range_list->ranges) {
5595 if ($range->value eq $default_map) {
5596 $count -= $range->end +1 - $range->start;
5602 # Get a string version of $count with underscores in large numbers,
5604 my $string_count = main::clarify_number($count);
5606 my $code_points = ($count == 1)
5607 ? 'single code point'
5608 : "$string_count code points";
5613 if (@property_aliases <= 1) {
5614 $mapping = 'mapping';
5615 $these_mappings = 'this mapping';
5619 $mapping = 'synonymous mappings';
5620 $these_mappings = 'these mappings';
5624 if ($count >= $MAX_UNICODE_CODEPOINTS) {
5625 $cp = "any code point in Unicode Version $string_version";
5629 if ($default_map eq "") {
5630 $map_to = 'the null string';
5632 elsif ($default_map eq $CODE_POINT) {
5636 $map_to = "'$default_map'";
5639 $cp = "the single code point";
5642 $cp = "one of the $code_points";
5644 $cp .= " in Unicode Version $string_version for which the mapping is not to $map_to";
5649 my $status = $self->status;
5651 my $warn = uc $status_past_participles{$status};
5654 !!!!!!! $warn !!!!!!!!!!!!!!!!!!!
5655 All property or property=value combinations contained in this file are $warn.
5656 See $unicode_reference_url for what this means.
5660 $comment .= "This file returns the $mapping:\n";
5662 for my $i (0 .. @property_aliases - 1) {
5663 $comment .= sprintf("%-8s%s\n",
5665 $property_aliases[$i]->name . '(cp)'
5669 "\nwhere 'cp' is $cp. Note that $these_mappings $are ";
5671 my $access = $core_access{$addr};
5673 $comment .= "accessible through the Perl core via $access.";
5676 $comment .= "not accessible through the Perl core directly.";
5679 # And append any commentary already set from the actual property.
5680 $comment .= "\n\n" . $self->comment if $self->comment;
5681 if ($self->description) {
5682 $comment .= "\n\n" . join " ", $self->description;
5685 $comment .= "\n\n" . join " ", $self->note;
5689 if (! $self->perl_extension) {
5692 For information about what this property really means, see:
5693 $unicode_reference_url
5697 if ($count) { # Format differs for empty table
5698 $comment.= "\nThe format of the ";
5699 if ($self->range_size_1) {
5701 main body of lines of this file is: CODE_POINT\\t\\tMAPPING where CODE_POINT
5702 is in hex; MAPPING is what CODE_POINT maps to.
5707 # There are tables which end up only having one element per
5708 # range, but it is not worth keeping track of for making just
5709 # this comment a little better.
5711 non-comment portions of the main body of lines of this file is:
5712 START\\tSTOP\\tMAPPING where START is the starting code point of the
5713 range, in hex; STOP is the ending point, or if omitted, the range has just one
5714 code point; MAPPING is what each code point between START and STOP maps to.
5716 if ($self->output_range_counts) {
5718 Numbers in comments in [brackets] indicate how many code points are in the
5719 range (omitted when the range is a single code point or if the mapping is to
5725 $self->set_comment(main::join_lines($comment));
5729 my %swash_keys; # Makes sure don't duplicate swash names.
5731 # The remaining variables are temporaries used while writing each table,
5732 # to output special ranges.
5733 my $has_hangul_syllables;
5734 my @multi_code_point_maps; # Map is to more than one code point.
5736 # The key is the base name of the code point, and the value is an
5737 # array giving all the ranges that use this base name. Each range
5738 # is actually a hash giving the 'low' and 'high' values of it.
5739 my %names_ending_in_code_point;
5741 # Inverse mapping. The list of ranges that have these kinds of
5742 # names. Each element contains the low, high, and base names in a
5744 my @code_points_ending_in_code_point;
5746 sub handle_special_range {
5747 # Called in the middle of write when it finds a range it doesn't know
5752 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5754 my $addr = do { no overloading; pack 'J', $self; };
5756 my $type = $range->type;
5758 my $low = $range->start;
5759 my $high = $range->end;
5760 my $map = $range->value;
5762 # No need to output the range if it maps to the default.
5763 return if $map eq $default_map{$addr};
5765 # Switch based on the map type...
5766 if ($type == $HANGUL_SYLLABLE) {
5768 # These are entirely algorithmically determinable based on
5769 # some constants furnished by Unicode; for now, just set a
5770 # flag to indicate that have them. After everything is figured
5771 # out, we will output the code that does the algorithm.
5772 $has_hangul_syllables = 1;
5774 elsif ($type == $CP_IN_NAME) {
5776 # Code points whose the name ends in their code point are also
5777 # algorithmically determinable, but need information about the map
5778 # to do so. Both the map and its inverse are stored in data
5779 # structures output in the file.
5780 push @{$names_ending_in_code_point{$map}->{'low'}}, $low;
5781 push @{$names_ending_in_code_point{$map}->{'high'}}, $high;
5783 push @code_points_ending_in_code_point, { low => $low,
5788 elsif ($range->type == $MULTI_CP || $range->type == $NULL) {
5790 # Multi-code point maps and null string maps have an entry
5791 # for each code point in the range. They use the same
5793 for my $code_point ($low .. $high) {
5795 # The pack() below can't cope with surrogates.
5796 if ($code_point >= 0xD800 && $code_point <= 0xDFFF) {
5797 Carp::my_carp("Surrogage code point '$code_point' in mapping to '$map' in $self. No map created");
5801 # Generate the hash entries for these in the form that
5802 # utf8.c understands.
5806 foreach my $to (split " ", $map) {
5807 if ($to !~ /^$code_point_re$/) {
5808 Carp::my_carp("Illegal code point '$to' in mapping '$map' from $code_point in $self. No map created");
5811 $tostr .= sprintf "\\x{%s}", $to;
5812 $to = CORE::hex $to;
5814 $to_name .= " + " if $to_name;
5815 $to_chr .= chr($to);
5816 main::populate_char_info($to)
5817 if ! defined $viacode[$to];
5818 $to_name .= $viacode[$to];
5822 # I (khw) have never waded through this line to
5823 # understand it well enough to comment it.
5824 my $utf8 = sprintf(qq["%s" => "$tostr",],
5825 join("", map { sprintf "\\x%02X", $_ }
5826 unpack("U0C*", pack("U", $code_point))));
5828 # Add a comment so that a human reader can more easily
5829 # see what's going on.
5830 push @multi_code_point_maps,
5831 sprintf("%-45s # U+%04X", $utf8, $code_point);
5833 $multi_code_point_maps[-1] .= " => $map";
5836 main::populate_char_info($code_point)
5837 if ! defined $viacode[$code_point];
5838 $multi_code_point_maps[-1] .= " '"
5840 . "' => '$to_chr'; $viacode[$code_point] => $to_name";
5845 Carp::my_carp("Unrecognized map type '$range->type' in '$range' in $self. Not written");
5852 # Returns the string that should be output in the file before the main
5853 # body of this table. It isn't called until the main body is
5854 # calculated, saving a pass. The string includes some hash entries
5855 # identifying the format of the body, and what the single value should
5856 # be for all ranges missing from it. It also includes any code points
5857 # which have map_types that don't go in the main table.
5860 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5862 my $addr = do { no overloading; pack 'J', $self; };
5864 my $name = $self->property->swash_name;
5866 if (defined $swash_keys{$name}) {
5867 Carp::my_carp(join_lines(<<END
5868 Already created a swash name '$name' for $swash_keys{$name}. This means that
5869 the same name desired for $self shouldn't be used. Bad News. This must be
5870 fixed before production use, but proceeding anyway
5874 $swash_keys{$name} = "$self";
5878 # Here we assume we were called after have gone through the whole
5879 # file. If we actually generated anything for each map type, add its
5880 # respective header and trailer
5881 if (@multi_code_point_maps) {
5884 # Some code points require special handling because their mappings are each to
5885 # multiple code points. These do not appear in the main body, but are defined
5886 # in the hash below.
5888 # Each key is the string of N bytes that together make up the UTF-8 encoding
5889 # for the code point. (i.e. the same as looking at the code point's UTF-8
5890 # under "use bytes"). Each value is the UTF-8 of the translation, for speed.
5891 %utf8::ToSpec$name = (
5893 $pre_body .= join("\n", @multi_code_point_maps) . "\n);\n";
5896 if ($has_hangul_syllables || @code_points_ending_in_code_point) {
5898 # Convert these structures to output format.
5899 my $code_points_ending_in_code_point =
5900 main::simple_dumper(\@code_points_ending_in_code_point,
5902 my $names = main::simple_dumper(\%names_ending_in_code_point,
5905 # Do the same with the Hangul names,
5911 if ($has_hangul_syllables) {
5913 # Construct a regular expression of all the possible
5914 # combinations of the Hangul syllables.
5915 my @L_re; # Leading consonants
5916 for my $i ($LBase .. $LBase + $LCount - 1) {
5917 push @L_re, $Jamo{$i}
5919 my @V_re; # Middle vowels
5920 for my $i ($VBase .. $VBase + $VCount - 1) {
5921 push @V_re, $Jamo{$i}
5923 my @T_re; # Trailing consonants
5924 for my $i ($TBase + 1 .. $TBase + $TCount - 1) {
5925 push @T_re, $Jamo{$i}
5928 # The whole re is made up of the L V T combination.
5930 . join ('|', sort @L_re)
5932 . join ('|', sort @V_re)
5934 . join ('|', sort @T_re)
5937 # These hashes needed by the algorithm were generated
5938 # during reading of the Jamo.txt file
5939 $jamo = main::simple_dumper(\%Jamo, ' ' x 8);
5940 $jamo_l = main::simple_dumper(\%Jamo_L, ' ' x 8);
5941 $jamo_v = main::simple_dumper(\%Jamo_V, ' ' x 8);
5942 $jamo_t = main::simple_dumper(\%Jamo_T, ' ' x 8);
5947 # To achieve significant memory savings when this file is read in,
5948 # algorithmically derivable code points are omitted from the main body below.
5949 # Instead, the following routines can be used to translate between name and
5950 # code point and vice versa
5954 # Matches legal code point. 4-6 hex numbers, If there are 6, the
5955 # first two must be '10'; if there are 5, the first must not be a '0'.
5956 my \$code_point_re = qr/$code_point_re/;
5958 # In the following hash, the keys are the bases of names which includes
5959 # the code point in the name, like CJK UNIFIED IDEOGRAPH-4E01. The values
5960 # of each key is another hash which is used to get the low and high ends
5961 # for each range of code points that apply to the name
5962 my %names_ending_in_code_point = (
5966 # And the following array gives the inverse mapping from code points to
5967 # names. Lowest code points are first
5968 my \@code_points_ending_in_code_point = (
5969 $code_points_ending_in_code_point
5972 # Earlier releases didn't have Jamos. No sense outputting
5973 # them unless will be used.
5974 if ($has_hangul_syllables) {
5977 # Convert from code point to Jamo short name for use in composing Hangul
5983 # Leading consonant (can be null)
5993 # Optional trailing consonant
5998 # Computed re that splits up a Hangul name into LVT or LV syllables
5999 my \$syllable_re = qr/$jamo_re/;
6001 my \$HANGUL_SYLLABLE = "HANGUL SYLLABLE ";
6002 my \$HANGUL_SYLLABLE_LENGTH = length \$HANGUL_SYLLABLE;
6004 # These constants names and values were taken from the Unicode standard,
6005 # version 5.1, section 3.12. They are used in conjunction with Hangul
6007 my \$SBase = $SBase_string;
6008 my \$LBase = $LBase_string;
6009 my \$VBase = $VBase_string;
6010 my \$TBase = $TBase_string;
6011 my \$SCount = $SCount;
6012 my \$LCount = $LCount;
6013 my \$VCount = $VCount;
6014 my \$TCount = $TCount;
6015 my \$NCount = \$VCount * \$TCount;
6017 } # End of has Jamos
6019 $pre_body .= << 'END';
6021 sub name_to_code_point_special {
6024 # Returns undef if not one of the specially handled names; otherwise
6025 # returns the code point equivalent to the input name
6027 if ($has_hangul_syllables) {
6028 $pre_body .= << 'END';
6030 if (substr($name, 0, $HANGUL_SYLLABLE_LENGTH) eq $HANGUL_SYLLABLE) {
6031 $name = substr($name, $HANGUL_SYLLABLE_LENGTH);
6032 return if $name !~ qr/^$syllable_re$/;
6033 my $L = $Jamo_L{$1};
6034 my $V = $Jamo_V{$2};
6035 my $T = (defined $3) ? $Jamo_T{$3} : 0;
6036 return ($L * $VCount + $V) * $TCount + $T + $SBase;
6040 $pre_body .= << 'END';
6042 # Name must end in '-code_point' for this to handle.
6043 if ($name !~ /^ (.*) - ($code_point_re) $/x) {
6048 my $code_point = CORE::hex $2;
6050 # Name must be one of the ones which has the code point in it.
6051 return if ! $names_ending_in_code_point{$base};
6053 # Look through the list of ranges that apply to this name to see if
6054 # the code point is in one of them.
6055 for (my $i = 0; $i < scalar @{$names_ending_in_code_point{$base}{'low'}}; $i++) {
6056 return if $names_ending_in_code_point{$base}{'low'}->[$i] > $code_point;
6057 next if $names_ending_in_code_point{$base}{'high'}->[$i] < $code_point;
6059 # Here, the code point is in the range.
6063 # Here, looked like the name had a code point number in it, but
6064 # did not match one of the valid ones.
6068 sub code_point_to_name_special {
6069 my $code_point = shift;
6071 # Returns the name of a code point if algorithmically determinable;
6074 if ($has_hangul_syllables) {
6075 $pre_body .= << 'END';
6077 # If in the Hangul range, calculate the name based on Unicode's
6079 if ($code_point >= $SBase && $code_point <= $SBase + $SCount -1) {
6081 my $SIndex = $code_point - $SBase;
6082 my $L = $LBase + $SIndex / $NCount;
6083 my $V = $VBase + ($SIndex % $NCount) / $TCount;
6084 my $T = $TBase + $SIndex % $TCount;
6085 $name = "$HANGUL_SYLLABLE$Jamo{$L}$Jamo{$V}";
6086 $name .= $Jamo{$T} if $T != $TBase;
6091 $pre_body .= << 'END';
6093 # Look through list of these code points for one in range.
6094 foreach my $hash (@code_points_ending_in_code_point) {
6095 return if $code_point < $hash->{'low'};
6096 if ($code_point <= $hash->{'high'}) {
6097 return sprintf("%s-%04X", $hash->{'name'}, $code_point);
6100 return; # None found
6105 } # End of has hangul or code point in name maps.
6107 my $format = $self->format;
6110 # The name this swash is to be known by, with the format of the mappings in
6111 # the main body of the table, and what all code points missing from this file
6113 \$utf8::SwashInfo{'To$name'}{'format'} = '$format'; # $map_table_formats{$format}
6115 my $default_map = $default_map{$addr};
6116 $return .= "\$utf8::SwashInfo{'To$name'}{'missing'} = '$default_map';";
6118 if ($default_map eq $CODE_POINT) {
6119 $return .= ' # code point maps to itself';
6121 elsif ($default_map eq "") {
6122 $return .= ' # code point maps to the null string';
6126 $return .= $pre_body;
6132 # Write the table to the file.
6135 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6137 my $addr = do { no overloading; pack 'J', $self; };
6139 # Clear the temporaries
6140 $has_hangul_syllables = 0;
6141 undef @multi_code_point_maps;
6142 undef %names_ending_in_code_point;
6143 undef @code_points_ending_in_code_point;
6145 # Calculate the format of the table if not already done.
6146 my $format = $self->format;
6147 my $type = $self->property->type;
6148 my $default_map = $self->default_map;
6149 if (! defined $format) {
6150 if ($type == $BINARY) {
6152 # Don't bother checking the values, because we elsewhere
6153 # verify that a binary table has only 2 values.
6154 $format = $BINARY_FORMAT;
6157 my @ranges = $self->_range_list->ranges;
6159 # default an empty table based on its type and default map
6162 # But it turns out that the only one we can say is a
6163 # non-string (besides binary, handled above) is when the
6164 # table is a string and the default map is to a code point
6165 if ($type == $STRING && $default_map eq $CODE_POINT) {
6166 $format = $HEX_FORMAT;
6169 $format = $STRING_FORMAT;
6174 # Start with the most restrictive format, and as we find
6175 # something that doesn't fit with that, change to the next
6176 # most restrictive, and so on.
6177 $format = $DECIMAL_FORMAT;
6178 foreach my $range (@ranges) {
6179 next if $range->type != 0; # Non-normal ranges don't
6180 # affect the main body
6181 my $map = $range->value;
6182 if ($map ne $default_map) {
6183 last if $format eq $STRING_FORMAT; # already at
6186 $format = $INTEGER_FORMAT
6187 if $format eq $DECIMAL_FORMAT
6188 && $map !~ / ^ [0-9] $ /x;
6189 $format = $FLOAT_FORMAT
6190 if $format eq $INTEGER_FORMAT
6191 && $map !~ / ^ -? [0-9]+ $ /x;
6192 $format = $RATIONAL_FORMAT
6193 if $format eq $FLOAT_FORMAT
6194 && $map !~ / ^ -? [0-9]+ \. [0-9]* $ /x;
6195 $format = $HEX_FORMAT
6196 if $format eq $RATIONAL_FORMAT
6197 && $map !~ / ^ -? [0-9]+ ( \/ [0-9]+ )? $ /x;
6198 $format = $STRING_FORMAT if $format eq $HEX_FORMAT
6199 && $map =~ /[^0-9A-F]/;
6204 } # end of calculating format
6206 if ($default_map eq $CODE_POINT
6207 && $format ne $HEX_FORMAT
6208 && ! defined $self->format) # manual settings are always
6211 Carp::my_carp_bug("Expecting hex format for mapping table for $self, instead got '$format'")
6214 $self->_set_format($format);
6216 return $self->SUPER::write(
6217 ($self->property == $block)
6218 ? 7 # block file needs more tab stops
6220 $default_map); # don't write defaulteds
6223 # Accessors for the underlying list that should fail if locked.
6233 return if $self->carp_if_locked;
6234 return $self->_range_list->$sub(@_);
6237 } # End closure for Map_Table
6239 package Match_Table;
6240 use base '_Base_Table';
6242 # A Match table is one which is a list of all the code points that have
6243 # the same property and property value, for use in \p{property=value}
6244 # constructs in regular expressions. It adds very little data to the base
6245 # structure, but many methods, as these lists can be combined in many ways to
6247 # There are only a few concepts added:
6248 # 1) Equivalents and Relatedness.
6249 # Two tables can match the identical code points, but have different names.
6250 # This always happens when there is a perl single form extension
6251 # \p{IsProperty} for the Unicode compound form \P{Property=True}. The two
6252 # tables are set to be related, with the Perl extension being a child, and
6253 # the Unicode property being the parent.
6255 # It may be that two tables match the identical code points and we don't
6256 # know if they are related or not. This happens most frequently when the
6257 # Block and Script properties have the exact range. But note that a
6258 # revision to Unicode could add new code points to the script, which would
6259 # now have to be in a different block (as the block was filled, or there
6260 # would have been 'Unknown' script code points in it and they wouldn't have
6261 # been identical). So we can't rely on any two properties from Unicode
6262 # always matching the same code points from release to release, and thus
6263 # these tables are considered coincidentally equivalent--not related. When
6264 # two tables are unrelated but equivalent, one is arbitrarily chosen as the
6265 # 'leader', and the others are 'equivalents'. This concept is useful
6266 # to minimize the number of tables written out. Only one file is used for
6267 # any identical set of code points, with entries in Heavy.pl mapping all
6268 # the involved tables to it.
6270 # Related tables will always be identical; we set them up to be so. Thus
6271 # if the Unicode one is deprecated, the Perl one will be too. Not so for
6272 # unrelated tables. Relatedness makes generating the documentation easier.
6274 # 2) Conflicting. It may be that there will eventually be name clashes, with
6275 # the same name meaning different things. For a while, there actually were
6276 # conflicts, but they have so far been resolved by changing Perl's or
6277 # Unicode's definitions to match the other, but when this code was written,
6278 # it wasn't clear that that was what was going to happen. (Unicode changed
6279 # because of protests during their beta period.) Name clashes are warned
6280 # about during compilation, and the documentation. The generated tables
6281 # are sane, free of name clashes, because the code suppresses the Perl
6282 # version. But manual intervention to decide what the actual behavior
6283 # should be may be required should this happen. The introductory comments
6284 # have more to say about this.
6286 sub standardize { return main::standardize($_[0]); }
6287 sub trace { return main::trace(@_); }
6292 main::setup_package();
6295 # The leader table of this one; initially $self.
6296 main::set_access('leader', \%leader, 'r');
6299 # An array of any tables that have this one as their leader
6300 main::set_access('equivalents', \%equivalents, 'readable_array');
6303 # The parent table to this one, initially $self. This allows us to
6304 # distinguish between equivalent tables that are related, and those which
6305 # may not be, but share the same output file because they match the exact
6306 # same set of code points in the current Unicode release.
6307 main::set_access('parent', \%parent, 'r');
6310 # An array of any tables that have this one as their parent
6311 main::set_access('children', \%children, 'readable_array');
6314 # Array of any tables that would have the same name as this one with
6315 # a different meaning. This is used for the generated documentation.
6316 main::set_access('conflicting', \%conflicting, 'readable_array');
6319 # Set in the constructor for tables that are expected to match all code
6321 main::set_access('matches_all', \%matches_all, 'r');
6328 # The property for which this table is a listing of property values.
6329 my $property = delete $args{'_Property'};
6331 my $name = delete $args{'Name'};
6332 my $full_name = delete $args{'Full_Name'};
6333 $full_name = $name if ! defined $full_name;
6336 my $initialize = delete $args{'Initialize'};
6337 my $matches_all = delete $args{'Matches_All'} || 0;
6338 my $format = delete $args{'Format'};
6339 # Rest of parameters passed on.
6341 my $range_list = Range_List->new(Initialize => $initialize,
6342 Owner => $property);
6344 my $complete = $full_name;
6345 $complete = '""' if $complete eq ""; # A null name shouldn't happen,
6346 # but this helps debug if it
6348 # The complete name for a match table includes it's property in a
6349 # compound form 'property=table', except if the property is the
6350 # pseudo-property, perl, in which case it is just the single form,
6351 # 'table' (If you change the '=' must also change the ':' in lots of
6352 # places in this program that assume an equal sign)
6353 $complete = $property->full_name . "=$complete" if $property != $perl;
6355 my $self = $class->SUPER::new(%args,
6357 Complete_Name => $complete,
6358 Full_Name => $full_name,
6359 _Property => $property,
6360 _Range_List => $range_list,
6361 Format => $EMPTY_FORMAT,
6363 my $addr = do { no overloading; pack 'J', $self; };
6365 $conflicting{$addr} = [ ];
6366 $equivalents{$addr} = [ ];
6367 $children{$addr} = [ ];
6368 $matches_all{$addr} = $matches_all;
6369 $leader{$addr} = $self;
6370 $parent{$addr} = $self;
6372 if (defined $format && $format ne $EMPTY_FORMAT) {
6373 Carp::my_carp_bug("'Format' must be '$EMPTY_FORMAT' in a match table instead of '$format'. Using '$EMPTY_FORMAT'");
6379 # See this program's beginning comment block about overloading these.
6382 qw("") => "_operator_stringify",
6386 return if $self->carp_if_locked;
6394 return $self->_range_list + $other;
6400 return $self->_range_list & $other;
6406 return if $self->carp_if_locked;
6408 my $addr = do { no overloading; pack 'J', $self; };
6412 # Change the range list of this table to be the
6414 $self->_set_range_list($self->_range_list
6417 else { # $other is just a simple value
6418 $self->add_range($other, $other);
6422 '-' => sub { my $self = shift;
6424 my $reversed = shift;
6427 Carp::my_carp_bug("Can't cope with a "
6429 . " being the first parameter in a '-'. Subtraction ignored.");
6433 return $self->_range_list - $other;
6435 '~' => sub { my $self = shift;
6436 return ~ $self->_range_list;
6440 sub _operator_stringify {
6443 my $name = $self->complete_name;
6444 return "Table '$name'";
6448 # Add a synonym for this table. See the comments in the base class
6452 # Rest of parameters passed on.
6454 $self->SUPER::add_alias($name, $self, @_);
6458 sub add_conflicting {
6459 # Add the name of some other object to the list of ones that name
6460 # clash with this match table.
6463 my $conflicting_name = shift; # The name of the conflicting object
6464 my $p = shift || 'p'; # Optional, is this a \p{} or \P{} ?
6465 my $conflicting_object = shift; # Optional, the conflicting object
6466 # itself. This is used to
6467 # disambiguate the text if the input
6468 # name is identical to any of the
6469 # aliases $self is known by.
6470 # Sometimes the conflicting object is
6471 # merely hypothetical, so this has to
6472 # be an optional parameter.
6473 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6475 my $addr = do { no overloading; pack 'J', $self; };
6477 # Check if the conflicting name is exactly the same as any existing
6478 # alias in this table (as long as there is a real object there to
6479 # disambiguate with).
6480 if (defined $conflicting_object) {
6481 foreach my $alias ($self->aliases) {
6482 if ($alias->name eq $conflicting_name) {
6484 # Here, there is an exact match. This results in
6485 # ambiguous comments, so disambiguate by changing the
6486 # conflicting name to its object's complete equivalent.
6487 $conflicting_name = $conflicting_object->complete_name;
6493 # Convert to the \p{...} final name
6494 $conflicting_name = "\\$p" . "{$conflicting_name}";
6497 return if grep { $conflicting_name eq $_ } @{$conflicting{$addr}};
6499 push @{$conflicting{$addr}}, $conflicting_name;
6504 sub is_set_equivalent_to {
6505 # Return boolean of whether or not the other object is a table of this
6506 # type and has been marked equivalent to this one.
6510 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6512 return 0 if ! defined $other; # Can happen for incomplete early
6514 unless ($other->isa(__PACKAGE__)) {
6515 my $ref_other = ref $other;
6516 my $ref_self = ref $self;
6517 Carp::my_carp_bug("Argument to 'is_set_equivalent_to' must be another $ref_self, not a '$ref_other'. $other not set equivalent to $self.");
6521 # Two tables are equivalent if they have the same leader.
6523 return $leader{pack 'J', $self} == $leader{pack 'J', $other};
6527 sub set_equivalent_to {
6528 # Set $self equivalent to the parameter table.
6529 # The required Related => 'x' parameter is a boolean indicating
6530 # whether these tables are related or not. If related, $other becomes
6531 # the 'parent' of $self; if unrelated it becomes the 'leader'
6533 # Related tables share all characteristics except names; equivalents
6534 # not quite so many.
6535 # If they are related, one must be a perl extension. This is because
6536 # we can't guarantee that Unicode won't change one or the other in a
6537 # later release even if they are idential now.
6543 my $related = delete $args{'Related'};
6545 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
6547 return if ! defined $other; # Keep on going; happens in some early
6550 if (! defined $related) {
6551 Carp::my_carp_bug("set_equivalent_to must have 'Related => [01] parameter. Assuming $self is not related to $other");
6555 # If already are equivalent, no need to re-do it; if subroutine
6556 # returns null, it found an error, also do nothing
6557 my $are_equivalent = $self->is_set_equivalent_to($other);
6558 return if ! defined $are_equivalent || $are_equivalent;
6560 my $addr = do { no overloading; pack 'J', $self; };
6561 my $current_leader = ($related) ? $parent{$addr} : $leader{$addr};
6564 if ($current_leader->perl_extension) {
6565 if ($other->perl_extension) {
6566 Carp::my_carp_bug("Use add_alias() to set two Perl tables '$self' and '$other', equivalent.");
6569 } elsif (! $other->perl_extension) {
6570 Carp::my_carp_bug("set_equivalent_to should have 'Related => 0 for equivalencing two Unicode properties. Assuming $self is not related to $other");
6575 if (! $self->is_empty && ! $self->matches_identically_to($other)) {
6576 Carp::my_carp_bug("$self should be empty or match identically to $other. Not setting equivalent");
6580 my $leader = do { no overloading; pack 'J', $current_leader; };
6581 my $other_addr = do { no overloading; pack 'J', $other; };
6583 # Any tables that are equivalent to or children of this table must now
6584 # instead be equivalent to or (children) to the new leader (parent),
6585 # still equivalent. The equivalency includes their matches_all info,
6586 # and for related tables, their status
6587 # All related tables are of necessity equivalent, but the converse
6588 # isn't necessarily true
6589 my $status = $other->status;
6590 my $status_info = $other->status_info;
6591 my $matches_all = $matches_all{other_addr};
6592 foreach my $table ($current_leader, @{$equivalents{$leader}}) {
6593 next if $table == $other;
6594 trace "setting $other to be the leader of $table, status=$status" if main::DEBUG && $to_trace;
6596 my $table_addr = do { no overloading; pack 'J', $table; };
6597 $leader{$table_addr} = $other;
6598 $matches_all{$table_addr} = $matches_all;
6599 $self->_set_range_list($other->_range_list);
6600 push @{$equivalents{$other_addr}}, $table;
6602 $parent{$table_addr} = $other;
6603 push @{$children{$other_addr}}, $table;
6604 $table->set_status($status, $status_info);
6608 # Now that we've declared these to be equivalent, any changes to one
6609 # of the tables would invalidate that equivalency.
6615 sub add_range { # Add a range to the list for this table.
6617 # Rest of parameters passed on
6619 return if $self->carp_if_locked;
6620 return $self->_range_list->add_range(@_);
6623 sub pre_body { # Does nothing for match tables.
6627 sub append_to_body { # Does nothing for match tables.
6633 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6635 return $self->SUPER::write(2); # 2 tab stops
6638 sub set_final_comment {
6639 # This creates a comment for the file that is to hold the match table
6640 # $self. It is somewhat convoluted to make the English read nicely,
6641 # but, heh, it's just a comment.
6642 # This should be called only with the leader match table of all the
6643 # ones that share the same file. It lists all such tables, ordered so
6644 # that related ones are together.
6646 my $leader = shift; # Should only be called on the leader table of
6647 # an equivalent group
6648 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6650 my $addr = do { no overloading; pack 'J', $leader; };
6652 if ($leader{$addr} != $leader) {
6653 Carp::my_carp_bug(<<END
6654 set_final_comment() must be called on a leader table, which $leader is not.
6655 It is equivalent to $leader{$addr}. No comment created
6661 # Get the number of code points matched by each of the tables in this
6662 # file, and add underscores for clarity.
6663 my $count = $leader->count;
6664 my $string_count = main::clarify_number($count);
6666 my $loose_count = 0; # how many aliases loosely matched
6667 my $compound_name = ""; # ? Are any names compound?, and if so, an
6669 my $properties_with_compound_names = 0; # count of these
6672 my %flags; # The status flags used in the file
6673 my $total_entries = 0; # number of entries written in the comment
6674 my $matches_comment = ""; # The portion of the comment about the
6676 my @global_comments; # List of all the tables' comments that are
6677 # there before this routine was called.
6679 # Get list of all the parent tables that are equivalent to this one
6680 # (including itself).
6681 my @parents = grep { $parent{main::objaddr $_} == $_ }
6682 main::uniques($leader, @{$equivalents{$addr}});
6683 my $has_unrelated = (@parents >= 2); # boolean, ? are there unrelated
6686 for my $parent (@parents) {
6688 my $property = $parent->property;
6690 # Special case 'N' tables in properties with two match tables when
6691 # the other is a 'Y' one. These are likely to be binary tables,
6692 # but not necessarily. In either case, \P{} will match the
6693 # complement of \p{}, and so if something is a synonym of \p, the
6694 # complement of that something will be the synonym of \P. This
6695 # would be true of any property with just two match tables, not
6696 # just those whose values are Y and N; but that would require a
6697 # little extra work, and there are none such so far in Unicode.
6698 my $perl_p = 'p'; # which is it? \p{} or \P{}
6699 my @yes_perl_synonyms; # list of any synonyms for the 'Y' table
6701 if (scalar $property->tables == 2
6702 && $parent == $property->table('N')
6703 && defined (my $yes = $property->table('Y')))
6705 my $yes_addr = do { no overloading; pack 'J', $yes; };
6707 = grep { $_->property == $perl }
6710 $parent{$yes_addr}->children);
6712 # But these synonyms are \P{} ,not \p{}
6716 my @description; # Will hold the table description
6717 my @note; # Will hold the table notes.
6718 my @conflicting; # Will hold the table conflicts.
6720 # Look at the parent, any yes synonyms, and all the children
6721 my $parent_addr = do { no overloading; pack 'J', $parent; };
6722 for my $table ($parent,
6724 @{$children{$parent_addr}})
6726 my $table_addr = do { no overloading; pack 'J', $table; };
6727 my $table_property = $table->property;
6729 # Tables are separated by a blank line to create a grouping.
6730 $matches_comment .= "\n" if $matches_comment;
6732 # The table is named based on the property and value
6733 # combination it is for, like script=greek. But there may be
6734 # a number of synonyms for each side, like 'sc' for 'script',
6735 # and 'grek' for 'greek'. Any combination of these is a valid
6736 # name for this table. In this case, there are three more,
6737 # 'sc=grek', 'sc=greek', and 'script='grek'. Rather than
6738 # listing all possible combinations in the comment, we make
6739 # sure that each synonym occurs at least once, and add
6740 # commentary that the other combinations are possible.
6741 my @property_aliases = $table_property->aliases;
6742 my @table_aliases = $table->aliases;
6744 Carp::my_carp_bug("$table doesn't have any names. Proceeding anyway.") unless @table_aliases;
6746 # The alias lists above are already ordered in the order we
6747 # want to output them. To ensure that each synonym is listed,
6748 # we must use the max of the two numbers.
6749 my $listed_combos = main::max(scalar @table_aliases,
6750 scalar @property_aliases);
6751 trace "$listed_combos, tables=", scalar @table_aliases, "; names=", scalar @property_aliases if main::DEBUG;
6753 my $property_had_compound_name = 0;
6755 for my $i (0 .. $listed_combos - 1) {
6758 # The current alias for the property is the next one on
6759 # the list, or if beyond the end, start over. Similarly
6760 # for the table (\p{prop=table})
6761 my $property_alias = $property_aliases
6762 [$i % @property_aliases]->name;
6763 my $table_alias_object = $table_aliases
6764 [$i % @table_aliases];
6765 my $table_alias = $table_alias_object->name;
6766 my $loose_match = $table_alias_object->loose_match;
6768 if ($table_alias !~ /\D/) { # Clarify large numbers.
6769 $table_alias = main::clarify_number($table_alias)
6772 # Add a comment for this alias combination
6773 my $current_match_comment;
6774 if ($table_property == $perl) {
6775 $current_match_comment = "\\$perl_p"
6779 $current_match_comment
6780 = "\\p{$property_alias=$table_alias}";
6781 $property_had_compound_name = 1;
6784 # Flag any abnormal status for this table.
6785 my $flag = $property->status
6787 || $table_alias_object->status;
6789 if ($flag ne $PLACEHOLDER) {
6790 $flags{$flag} = $status_past_participles{$flag};
6792 $flags{$flag} = <<END;
6793 a placeholder because it is not in Version $string_version of Unicode, but is
6794 needed by the Perl core to work gracefully. Because it is not in this version
6795 of Unicode, it will not be listed in $pod_file.pod
6802 # Pretty up the comment. Note the \b; it says don't make
6803 # this line a continuation.
6804 $matches_comment .= sprintf("\b%-1s%-s%s\n",
6807 $current_match_comment);
6808 } # End of generating the entries for this table.
6810 # Save these for output after this group of related tables.
6811 push @description, $table->description;
6812 push @note, $table->note;
6813 push @conflicting, $table->conflicting;
6815 # And this for output after all the tables.
6816 push @global_comments, $table->comment;
6818 # Compute an alternate compound name using the final property
6819 # synonym and the first table synonym with a colon instead of
6820 # the equal sign used elsewhere.
6821 if ($property_had_compound_name) {
6822 $properties_with_compound_names ++;
6823 if (! $compound_name || @property_aliases > 1) {
6824 $compound_name = $property_aliases[-1]->name
6826 . $table_aliases[0]->name;
6829 } # End of looping through all children of this table
6831 # Here have assembled in $matches_comment all the related tables
6832 # to the current parent (preceded by the same info for all the
6833 # previous parents). Put out information that applies to all of
6834 # the current family.
6837 # But output the conflicting information now, as it applies to
6839 my $conflicting = join ", ", @conflicting;
6841 $matches_comment .= <<END;
6843 Note that contrary to what you might expect, the above is NOT the same as
6845 $matches_comment .= "any of: " if @conflicting > 1;
6846 $matches_comment .= "$conflicting\n";
6850 $matches_comment .= "\n Meaning: "
6851 . join('; ', @description)
6855 $matches_comment .= "\n Note: "
6856 . join("\n ", @note)
6859 } # End of looping through all tables
6867 $code_points = 'single code point';
6871 $code_points = "$string_count code points";
6876 if ($total_entries <= 1) {
6879 $any_of_these = 'this'
6882 $synonyms = " any of the following regular expression constructs";
6883 $entries = 'entries';
6884 $any_of_these = 'any of these'
6888 if ($has_unrelated) {
6890 This file is for tables that are not necessarily related: To conserve
6891 resources, every table that matches the identical set of code points in this
6892 version of Unicode uses this file. Each one is listed in a separate group
6893 below. It could be that the tables will match the same set of code points in
6894 other Unicode releases, or it could be purely coincidence that they happen to
6895 be the same in Unicode $string_version, and hence may not in other versions.
6901 foreach my $flag (sort keys %flags) {
6903 '$flag' below means that this form is $flags{$flag}.
6905 next if $flag eq $PLACEHOLDER;
6906 $comment .= "Consult $pod_file.pod\n";
6912 This file returns the $code_points in Unicode Version $string_version that
6916 $pod_file.pod should be consulted for the syntax rules for $any_of_these,
6917 including if adding or subtracting white space, underscore, and hyphen
6918 characters matters or doesn't matter, and other permissible syntactic
6919 variants. Upper/lower case distinctions never matter.
6922 if ($compound_name) {
6925 A colon can be substituted for the equals sign, and
6927 if ($properties_with_compound_names > 1) {
6929 within each group above,
6932 $compound_name = sprintf("%-8s\\p{%s}", " ", $compound_name);
6934 # Note the \b below, it says don't make that line a continuation.
6936 anything to the left of the equals (or colon) can be combined with anything to
6937 the right. Thus, for example,
6943 # And append any comment(s) from the actual tables. They are all
6944 # gathered here, so may not read all that well.
6945 if (@global_comments) {
6946 $comment .= "\n" . join("\n\n", @global_comments) . "\n";
6949 if ($count) { # The format differs if no code points, and needs no
6950 # explanation in that case
6953 The format of the lines of this file is:
6956 START\\tSTOP\\twhere START is the starting code point of the range, in hex;
6957 STOP is the ending point, or if omitted, the range has just one code point.
6959 if ($leader->output_range_counts) {
6961 Numbers in comments in [brackets] indicate how many code points are in the
6967 $leader->set_comment(main::join_lines($comment));
6971 # Accessors for the underlying list
6973 get_valid_code_point
6974 get_invalid_code_point
6982 return $self->_range_list->$sub(@_);
6985 } # End closure for Match_Table
6989 # The Property class represents a Unicode property, or the $perl
6990 # pseudo-property. It contains a map table initialized empty at construction
6991 # time, and for properties accessible through regular expressions, various
6992 # match tables, created through the add_match_table() method, and referenced
6993 # by the table('NAME') or tables() methods, the latter returning a list of all
6994 # of the match tables. Otherwise table operations implicitly are for the map
6997 # Most of the data in the property is actually about its map table, so it
6998 # mostly just uses that table's accessors for most methods. The two could
6999 # have been combined into one object, but for clarity because of their
7000 # differing semantics, they have been kept separate. It could be argued that
7001 # the 'file' and 'directory' fields should be kept with the map table.
7003 # Each property has a type. This can be set in the constructor, or in the
7004 # set_type accessor, but mostly it is figured out by the data. Every property
7005 # starts with unknown type, overridden by a parameter to the constructor, or
7006 # as match tables are added, or ranges added to the map table, the data is
7007 # inspected, and the type changed. After the table is mostly or entirely
7008 # filled, compute_type() should be called to finalize they analysis.
7010 # There are very few operations defined. One can safely remove a range from
7011 # the map table, and property_add_or_replace_non_nulls() adds the maps from another
7012 # table to this one, replacing any in the intersection of the two.
7014 sub standardize { return main::standardize($_[0]); }
7015 sub trace { return main::trace(@_) if main::DEBUG && $to_trace }
7019 # This hash will contain as keys, all the aliases of all properties, and
7020 # as values, pointers to their respective property objects. This allows
7021 # quick look-up of a property from any of its names.
7022 my %alias_to_property_of;
7024 sub dump_alias_to_property_of {
7027 print "\n", main::simple_dumper (\%alias_to_property_of), "\n";
7032 # This is a package subroutine, not called as a method.
7033 # If the single parameter is a literal '*' it returns a list of all
7034 # defined properties.
7035 # Otherwise, the single parameter is a name, and it returns a pointer
7036 # to the corresponding property object, or undef if none.
7038 # Properties can have several different names. The 'standard' form of
7039 # each of them is stored in %alias_to_property_of as they are defined.
7040 # But it's possible that this subroutine will be called with some
7041 # variant, so if the initial lookup fails, it is repeated with the
7042 # standarized form of the input name. If found, besides returning the
7043 # result, the input name is added to the list so future calls won't
7044 # have to do the conversion again.
7048 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7050 if (! defined $name) {
7051 Carp::my_carp_bug("Undefined input property. No action taken.");
7055 return main::uniques(values %alias_to_property_of) if $name eq '*';
7057 # Return cached result if have it.
7058 my $result = $alias_to_property_of{$name};
7059 return $result if defined $result;
7061 # Convert the input to standard form.
7062 my $standard_name = standardize($name);
7064 $result = $alias_to_property_of{$standard_name};
7065 return unless defined $result; # Don't cache undefs
7067 # Cache the result before returning it.
7068 $alias_to_property_of{$name} = $result;
7073 main::setup_package();
7076 # A pointer to the map table object for this property
7077 main::set_access('map', \%map);
7080 # The property's full name. This is a duplicate of the copy kept in the
7081 # map table, but is needed because stringify needs it during
7082 # construction of the map table, and then would have a chicken before egg
7084 main::set_access('full_name', \%full_name, 'r');
7087 # This hash will contain as keys, all the aliases of any match tables
7088 # attached to this property, and as values, the pointers to their
7089 # respective tables. This allows quick look-up of a table from any of its
7091 main::set_access('table_ref', \%table_ref);
7094 # The type of the property, $ENUM, $BINARY, etc
7095 main::set_access('type', \%type, 'r');
7098 # The filename where the map table will go (if actually written).
7099 # Normally defaulted, but can be overridden.
7100 main::set_access('file', \%file, 'r', 's');
7103 # The directory where the map table will go (if actually written).
7104 # Normally defaulted, but can be overridden.
7105 main::set_access('directory', \%directory, 's');
7107 my %pseudo_map_type;
7108 # This is used to affect the calculation of the map types for all the
7109 # ranges in the table. It should be set to one of the values that signify
7110 # to alter the calculation.
7111 main::set_access('pseudo_map_type', \%pseudo_map_type, 'r');
7113 my %has_only_code_point_maps;
7114 # A boolean used to help in computing the type of data in the map table.
7115 main::set_access('has_only_code_point_maps', \%has_only_code_point_maps);
7118 # A list of the first few distinct mappings this property has. This is
7119 # used to disambiguate between binary and enum property types, so don't
7120 # have to keep more than three.
7121 main::set_access('unique_maps', \%unique_maps);
7124 # The only required parameter is the positionally first, name. All
7125 # other parameters are key => value pairs. See the documentation just
7126 # above for the meanings of the ones not passed directly on to the map
7127 # table constructor.
7130 my $name = shift || "";
7132 my $self = property_ref($name);
7133 if (defined $self) {
7134 my $options_string = join ", ", @_;
7135 $options_string = ". Ignoring options $options_string" if $options_string;
7136 Carp::my_carp("$self is already in use. Using existing one$options_string;");
7142 $self = bless \do { my $anonymous_scalar }, $class;
7143 my $addr = do { no overloading; pack 'J', $self; };
7145 $directory{$addr} = delete $args{'Directory'};
7146 $file{$addr} = delete $args{'File'};
7147 $full_name{$addr} = delete $args{'Full_Name'} || $name;
7148 $type{$addr} = delete $args{'Type'} || $UNKNOWN;
7149 $pseudo_map_type{$addr} = delete $args{'Map_Type'};
7150 # Rest of parameters passed on.
7152 $has_only_code_point_maps{$addr} = 1;
7153 $table_ref{$addr} = { };
7154 $unique_maps{$addr} = { };
7156 $map{$addr} = Map_Table->new($name,
7157 Full_Name => $full_name{$addr},
7158 _Alias_Hash => \%alias_to_property_of,
7164 # See this program's beginning comment block about overloading the copy
7165 # constructor. Few operations are defined on properties, but a couple are
7166 # useful. It is safe to take the inverse of a property, and to remove a
7167 # single code point from it.
7170 qw("") => "_operator_stringify",
7171 "." => \&main::_operator_dot,
7172 '==' => \&main::_operator_equal,
7173 '!=' => \&main::_operator_not_equal,
7174 '=' => sub { return shift },
7175 '-=' => "_minus_and_equal",
7178 sub _operator_stringify {
7179 return "Property '" . shift->full_name . "'";
7182 sub _minus_and_equal {
7183 # Remove a single code point from the map table of a property.
7187 my $reversed = shift;
7188 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7191 Carp::my_carp_bug("Can't cope with a "
7193 . " argument to '-='. Subtraction ignored.");
7196 elsif ($reversed) { # Shouldnt happen in a -=, but just in case
7197 Carp::my_carp_bug("Can't cope with a "
7199 . " being the first parameter in a '-='. Subtraction ignored.");
7204 $map{pack 'J', $self}->delete_range($other, $other);
7209 sub add_match_table {
7210 # Add a new match table for this property, with name given by the
7211 # parameter. It returns a pointer to the table.
7217 my $addr = do { no overloading; pack 'J', $self; };
7219 my $table = $table_ref{$addr}{$name};
7220 my $standard_name = main::standardize($name);
7222 || (defined ($table = $table_ref{$addr}{$standard_name})))
7224 Carp::my_carp("Table '$name' in $self is already in use. Using existing one");
7225 $table_ref{$addr}{$name} = $table;
7230 # See if this is a perl extension, if not passed in.
7231 my $perl_extension = delete $args{'Perl_Extension'};
7233 = $self->perl_extension if ! defined $perl_extension;
7235 $table = Match_Table->new(
7237 Perl_Extension => $perl_extension,
7238 _Alias_Hash => $table_ref{$addr},
7241 # gets property's status by default
7242 Status => $self->status,
7243 _Status_Info => $self->status_info,
7245 Internal_Only_Warning => 1); # Override any
7247 return unless defined $table;
7250 # Save the names for quick look up
7251 $table_ref{$addr}{$standard_name} = $table;
7252 $table_ref{$addr}{$name} = $table;
7254 # Perhaps we can figure out the type of this property based on the
7255 # fact of adding this match table. First, string properties don't
7256 # have match tables; second, a binary property can't have 3 match
7258 if ($type{$addr} == $UNKNOWN) {
7259 $type{$addr} = $NON_STRING;
7261 elsif ($type{$addr} == $STRING) {
7262 Carp::my_carp("$self Added a match table '$name' to a string property '$self'. Changed it to a non-string property. Bad News.");
7263 $type{$addr} = $NON_STRING;
7265 elsif ($type{$addr} != $ENUM) {
7266 if (scalar main::uniques(values %{$table_ref{$addr}}) > 2
7267 && $type{$addr} == $BINARY)
7269 Carp::my_carp("$self now has more than 2 tables (with the addition of '$name'), and so is no longer binary. Changing its type to 'enum'. Bad News.");
7270 $type{$addr} = $ENUM;
7278 # Return a pointer to the match table (with name given by the
7279 # parameter) associated with this property; undef if none.
7283 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7285 my $addr = do { no overloading; pack 'J', $self; };
7287 return $table_ref{$addr}{$name} if defined $table_ref{$addr}{$name};
7289 # If quick look-up failed, try again using the standard form of the
7290 # input name. If that succeeds, cache the result before returning so
7291 # won't have to standardize this input name again.
7292 my $standard_name = main::standardize($name);
7293 return unless defined $table_ref{$addr}{$standard_name};
7295 $table_ref{$addr}{$name} = $table_ref{$addr}{$standard_name};
7296 return $table_ref{$addr}{$name};
7300 # Return a list of pointers to all the match tables attached to this
7304 return main::uniques(values %{$table_ref{pack 'J', shift}});
7308 # Returns the directory the map table for this property should be
7309 # output in. If a specific directory has been specified, that has
7310 # priority; 'undef' is returned if the type isn't defined;
7311 # or $map_directory for everything else.
7313 my $addr = do { no overloading; pack 'J', shift; };
7315 return $directory{$addr} if defined $directory{$addr};
7316 return undef if $type{$addr} == $UNKNOWN;
7317 return $map_directory;
7321 # Return the name that is used to both:
7322 # 1) Name the file that the map table is written to.
7323 # 2) The name of swash related stuff inside that file.
7324 # The reason for this is that the Perl core historically has used
7325 # certain names that aren't the same as the Unicode property names.
7326 # To continue using these, $file is hard-coded in this file for those,
7327 # but otherwise the standard name is used. This is different from the
7328 # external_name, so that the rest of the files, like in lib can use
7329 # the standard name always, without regard to historical precedent.
7332 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7334 my $addr = do { no overloading; pack 'J', $self; };
7336 return $file{$addr} if defined $file{$addr};
7337 return $map{$addr}->external_name;
7340 sub to_create_match_tables {
7341 # Returns a boolean as to whether or not match tables should be
7342 # created for this property.
7345 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7347 # The whole point of this pseudo property is match tables.
7348 return 1 if $self == $perl;
7350 my $addr = do { no overloading; pack 'J', $self; };
7352 # Don't generate tables of code points that match the property values
7353 # of a string property. Such a list would most likely have many
7354 # property values, each with just one or very few code points mapping
7356 return 0 if $type{$addr} == $STRING;
7358 # Don't generate anything for unimplemented properties.
7359 return 0 if grep { $self->complete_name eq $_ }
7360 @unimplemented_properties;
7365 sub property_add_or_replace_non_nulls {
7366 # This adds the mappings in the property $other to $self. Non-null
7367 # mappings from $other override those in $self. It essentially merges
7368 # the two properties, with the second having priority except for null
7373 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7375 if (! $other->isa(__PACKAGE__)) {
7376 Carp::my_carp_bug("$other should be a "
7385 return $map{pack 'J', $self}->map_add_or_replace_non_nulls($map{pack 'J', $other});
7389 # Set the type of the property. Mostly this is figured out by the
7390 # data in the table. But this is used to set it explicitly. The
7391 # reason it is not a standard accessor is that when setting a binary
7392 # property, we need to make sure that all the true/false aliases are
7393 # present, as they were omitted in early Unicode releases.
7397 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7399 if ($type != $ENUM && $type != $BINARY && $type != $STRING) {
7400 Carp::my_carp("Unrecognized type '$type'. Type not set");
7404 { no overloading; $type{pack 'J', $self} = $type; }
7405 return if $type != $BINARY;
7407 my $yes = $self->table('Y');
7408 $yes = $self->table('Yes') if ! defined $yes;
7409 $yes = $self->add_match_table('Y') if ! defined $yes;
7410 $yes->add_alias('Yes');
7411 $yes->add_alias('T');
7412 $yes->add_alias('True');
7414 my $no = $self->table('N');
7415 $no = $self->table('No') if ! defined $no;
7416 $no = $self->add_match_table('N') if ! defined $no;
7417 $no->add_alias('No');
7418 $no->add_alias('F');
7419 $no->add_alias('False');
7424 # Add a map to the property's map table. This also keeps
7425 # track of the maps so that the property type can be determined from
7429 my $start = shift; # First code point in range
7430 my $end = shift; # Final code point in range
7431 my $map = shift; # What the range maps to.
7432 # Rest of parameters passed on.
7434 my $addr = do { no overloading; pack 'J', $self; };
7436 # If haven't the type of the property, gather information to figure it
7438 if ($type{$addr} == $UNKNOWN) {
7440 # If the map contains an interior blank or dash, or most other
7441 # nonword characters, it will be a string property. This
7442 # heuristic may actually miss some string properties. If so, they
7443 # may need to have explicit set_types called for them. This
7444 # happens in the Unihan properties.
7445 if ($map =~ / (?<= . ) [ -] (?= . ) /x
7446 || $map =~ / [^\w.\/\ -] /x)
7448 $self->set_type($STRING);
7450 # $unique_maps is used for disambiguating between ENUM and
7451 # BINARY later; since we know the property is not going to be
7452 # one of those, no point in keeping the data around
7453 undef $unique_maps{$addr};
7457 # Not necessarily a string. The final decision has to be
7458 # deferred until all the data are in. We keep track of if all
7459 # the values are code points for that eventual decision.
7460 $has_only_code_point_maps{$addr} &=
7461 $map =~ / ^ $code_point_re $/x;
7463 # For the purposes of disambiguating between binary and other
7464 # enumerations at the end, we keep track of the first three
7465 # distinct property values. Once we get to three, we know
7466 # it's not going to be binary, so no need to track more.
7467 if (scalar keys %{$unique_maps{$addr}} < 3) {
7468 $unique_maps{$addr}{main::standardize($map)} = 1;
7473 # Add the mapping by calling our map table's method
7474 return $map{$addr}->add_map($start, $end, $map, @_);
7478 # Compute the type of the property: $ENUM, $STRING, or $BINARY. This
7479 # should be called after the property is mostly filled with its maps.
7480 # We have been keeping track of what the property values have been,
7481 # and now have the necessary information to figure out the type.
7484 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7486 my $addr = do { no overloading; pack 'J', $self; };
7488 my $type = $type{$addr};
7490 # If already have figured these out, no need to do so again, but we do
7491 # a double check on ENUMS to make sure that a string property hasn't
7492 # improperly been classified as an ENUM, so continue on with those.
7493 return if $type == $STRING || $type == $BINARY;
7495 # If every map is to a code point, is a string property.
7496 if ($type == $UNKNOWN
7497 && ($has_only_code_point_maps{$addr}
7498 || (defined $map{$addr}->default_map
7499 && $map{$addr}->default_map eq "")))
7501 $self->set_type($STRING);
7505 # Otherwise, it is to some sort of enumeration. (The case where
7506 # it is a Unicode miscellaneous property, and treated like a
7507 # string in this program is handled in add_map()). Distinguish
7508 # between binary and some other enumeration type. Of course, if
7509 # there are more than two values, it's not binary. But more
7510 # subtle is the test that the default mapping is defined means it
7511 # isn't binary. This in fact may change in the future if Unicode
7512 # changes the way its data is structured. But so far, no binary
7513 # properties ever have @missing lines for them, so the default map
7514 # isn't defined for them. The few properties that are two-valued
7515 # and aren't considered binary have the default map defined
7516 # starting in Unicode 5.0, when the @missing lines appeared; and
7517 # this program has special code to put in a default map for them
7518 # for earlier than 5.0 releases.
7520 || scalar keys %{$unique_maps{$addr}} > 2
7521 || defined $self->default_map)
7523 my $tables = $self->tables;
7524 my $count = $self->count;
7525 if ($verbosity && $count > 500 && $tables/$count > .1) {
7526 Carp::my_carp_bug("It appears that $self should be a \$STRING property, not an \$ENUM because it has too many match tables: $count\n");
7528 $self->set_type($ENUM);
7531 $self->set_type($BINARY);
7534 undef $unique_maps{$addr}; # Garbage collect
7538 # Most of the accessors for a property actually apply to its map table.
7539 # Setup up accessor functions for those, referring to %map
7588 # 'property' above is for symmetry, so that one can take
7589 # the property of a property and get itself, and so don't
7590 # have to distinguish between properties and tables in
7598 return $map{pack 'J', $self}->$sub(@_);
7608 # Returns lines of the input joined together, so that they can be folded
7610 # This causes continuation lines to be joined together into one long line
7611 # for folding. A continuation line is any line that doesn't begin with a
7612 # space or "\b" (the latter is stripped from the output). This is so
7613 # lines can be be in a HERE document so as to fit nicely in the terminal
7614 # width, but be joined together in one long line, and then folded with
7615 # indents, '#' prefixes, etc, properly handled.
7616 # A blank separates the joined lines except if there is a break; an extra
7617 # blank is inserted after a period ending a line.
7619 # Intialize the return with the first line.
7620 my ($return, @lines) = split "\n", shift;
7622 # If the first line is null, it was an empty line, add the \n back in
7623 $return = "\n" if $return eq "";
7625 # Now join the remainder of the physical lines.
7626 for my $line (@lines) {
7628 # An empty line means wanted a blank line, so add two \n's to get that
7629 # effect, and go to the next line.
7630 if (length $line == 0) {
7635 # Look at the last character of what we have so far.
7636 my $previous_char = substr($return, -1, 1);
7638 # And at the next char to be output.
7639 my $next_char = substr($line, 0, 1);
7641 if ($previous_char ne "\n") {
7643 # Here didn't end wth a nl. If the next char a blank or \b, it
7644 # means that here there is a break anyway. So add a nl to the
7646 if ($next_char eq " " || $next_char eq "\b") {
7647 $previous_char = "\n";
7648 $return .= $previous_char;
7651 # Add an extra space after periods.
7652 $return .= " " if $previous_char eq '.';
7655 # Here $previous_char is still the latest character to be output. If
7656 # it isn't a nl, it means that the next line is to be a continuation
7657 # line, with a blank inserted between them.
7658 $return .= " " if $previous_char ne "\n";
7661 substr($line, 0, 1) = "" if $next_char eq "\b";
7663 # And append this next line.
7670 sub simple_fold($;$$$) {
7671 # Returns a string of the input (string or an array of strings) folded
7672 # into multiple-lines each of no more than $MAX_LINE_WIDTH characters plus
7674 # This is tailored for the kind of text written by this program,
7675 # especially the pod file, which can have very long names with
7676 # underscores in the middle, or words like AbcDefgHij.... We allow
7677 # breaking in the middle of such constructs if the line won't fit
7678 # otherwise. The break in such cases will come either just after an
7679 # underscore, or just before one of the Capital letters.
7681 local $to_trace = 0 if main::DEBUG;
7684 my $prefix = shift; # Optional string to prepend to each output
7686 $prefix = "" unless defined $prefix;
7688 my $hanging_indent = shift; # Optional number of spaces to indent
7689 # continuation lines
7690 $hanging_indent = 0 unless $hanging_indent;
7692 my $right_margin = shift; # Optional number of spaces to narrow the
7694 $right_margin = 0 unless defined $right_margin;
7696 # Call carp with the 'nofold' option to avoid it from trying to call us
7698 Carp::carp_extra_args(\@_, 'nofold') if main::DEBUG && @_;
7700 # The space available doesn't include what's automatically prepended
7701 # to each line, or what's reserved on the right.
7702 my $max = $MAX_LINE_WIDTH - length($prefix) - $right_margin;
7703 # XXX Instead of using the 'nofold' perhaps better to look up the stack
7705 if (DEBUG && $hanging_indent >= $max) {
7706 Carp::my_carp("Too large a hanging indent ($hanging_indent); must be < $max. Using 0", 'nofold');
7707 $hanging_indent = 0;
7710 # First, split into the current physical lines.
7712 if (ref $line) { # Better be an array, because not bothering to
7714 foreach my $line (@{$line}) {
7715 push @line, split /\n/, $line;
7719 @line = split /\n/, $line;
7722 #local $to_trace = 1 if main::DEBUG;
7723 trace "", join(" ", @line), "\n" if main::DEBUG && $to_trace;
7725 # Look at each current physical line.
7726 for (my $i = 0; $i < @line; $i++) {
7727 Carp::my_carp("Tabs don't work well.", 'nofold') if $line[$i] =~ /\t/;
7728 #local $to_trace = 1 if main::DEBUG;
7729 trace "i=$i: $line[$i]\n" if main::DEBUG && $to_trace;
7731 # Remove prefix, because will be added back anyway, don't want
7733 $line[$i] =~ s/^$prefix//;
7735 # Remove trailing space
7736 $line[$i] =~ s/\s+\Z//;
7738 # If the line is too long, fold it.
7739 if (length $line[$i] > $max) {
7742 # Here needs to fold. Save the leading space in the line for
7744 $line[$i] =~ /^ ( \s* )/x;
7745 my $leading_space = $1;
7746 trace "line length", length $line[$i], "; lead length", length($leading_space) if main::DEBUG && $to_trace;
7748 # If character at final permissible position is white space,
7749 # fold there, which will delete that white space
7750 if (substr($line[$i], $max - 1, 1) =~ /\s/) {
7751 $remainder = substr($line[$i], $max);
7752 $line[$i] = substr($line[$i], 0, $max - 1);
7756 # Otherwise fold at an acceptable break char closest to
7757 # the max length. Look at just the maximal initial
7758 # segment of the line
7759 my $segment = substr($line[$i], 0, $max - 1);
7761 /^ ( .{$hanging_indent} # Don't look before the
7763 \ * # Don't look in leading
7764 # blanks past the indent
7765 [^ ] .* # Find the right-most
7766 (?: # acceptable break:
7767 [ \s = ] # space or equal
7768 | - (?! [.0-9] ) # or non-unary minus.
7769 ) # $1 includes the character
7772 # Split into the initial part that fits, and remaining
7774 $remainder = substr($line[$i], length $1);
7776 trace $line[$i] if DEBUG && $to_trace;
7777 trace $remainder if DEBUG && $to_trace;
7780 # If didn't find a good breaking spot, see if there is a
7781 # not-so-good breaking spot. These are just after
7782 # underscores or where the case changes from lower to
7783 # upper. Use \a as a soft hyphen, but give up
7784 # and don't break the line if there is actually a \a
7785 # already in the input. We use an ascii character for the
7786 # soft-hyphen to avoid any attempt by miniperl to try to
7787 # access the files that this program is creating.
7788 elsif ($segment !~ /\a/
7789 && ($segment =~ s/_/_\a/g
7790 || $segment =~ s/ ( [a-z] ) (?= [A-Z] )/$1\a/xg))
7792 # Here were able to find at least one place to insert
7793 # our substitute soft hyphen. Find the right-most one
7794 # and replace it by a real hyphen.
7795 trace $segment if DEBUG && $to_trace;
7797 rindex($segment, "\a"),
7800 # Then remove the soft hyphen substitutes.
7801 $segment =~ s/\a//g;
7802 trace $segment if DEBUG && $to_trace;
7804 # And split into the initial part that fits, and
7805 # remainder of the line
7806 my $pos = rindex($segment, '-');
7807 $remainder = substr($line[$i], $pos);
7808 trace $remainder if DEBUG && $to_trace;
7809 $line[$i] = substr($segment, 0, $pos + 1);
7813 # Here we know if we can fold or not. If we can, $remainder
7814 # is what remains to be processed in the next iteration.
7815 if (defined $remainder) {
7816 trace "folded='$line[$i]'" if main::DEBUG && $to_trace;
7818 # Insert the folded remainder of the line as a new element
7819 # of the array. (It may still be too long, but we will
7820 # deal with that next time through the loop.) Omit any
7821 # leading space in the remainder.
7822 $remainder =~ s/^\s+//;
7823 trace "remainder='$remainder'" if main::DEBUG && $to_trace;
7825 # But then indent by whichever is larger of:
7826 # 1) the leading space on the input line;
7827 # 2) the hanging indent.
7828 # This preserves indentation in the original line.
7829 my $lead = ($leading_space)
7830 ? length $leading_space
7832 $lead = max($lead, $hanging_indent);
7833 splice @line, $i+1, 0, (" " x $lead) . $remainder;
7837 # Ready to output the line. Get rid of any trailing space
7838 # And prefix by the required $prefix passed in.
7839 $line[$i] =~ s/\s+$//;
7840 $line[$i] = "$prefix$line[$i]\n";
7841 } # End of looping through all the lines.
7843 return join "", @line;
7846 sub property_ref { # Returns a reference to a property object.
7847 return Property::property_ref(@_);
7850 sub force_unlink ($) {
7851 my $filename = shift;
7852 return unless file_exists($filename);
7853 return if CORE::unlink($filename);
7855 # We might need write permission
7856 chmod 0777, $filename;
7857 CORE::unlink($filename) or Carp::my_carp("Couldn't unlink $filename. Proceeding anyway: $!");
7862 # Given a filename and references to arrays of lines, write the lines of
7863 # each array to the file
7864 # Filename can be given as an arrayref of directory names
7866 return Carp::carp_too_few_args(\@_, 3) if main::DEBUG && @_ < 3;
7869 my $use_utf8 = shift;
7871 # Get into a single string if an array, and get rid of, in Unix terms, any
7873 $file= File::Spec->join(@$file) if ref $file eq 'ARRAY';
7874 $file = File::Spec->canonpath($file);
7876 # If has directories, make sure that they all exist
7877 (undef, my $directories, undef) = File::Spec->splitpath($file);
7878 File::Path::mkpath($directories) if $directories && ! -d $directories;
7880 push @files_actually_output, $file;
7882 force_unlink ($file);
7885 if (not open $OUT, ">", $file) {
7886 Carp::my_carp("can't open $file for output. Skipping this file: $!");
7890 binmode $OUT, ":utf8" if $use_utf8;
7892 while (defined (my $lines_ref = shift)) {
7893 unless (@$lines_ref) {
7894 Carp::my_carp("An array of lines for writing to file '$file' is empty; writing it anyway;");
7897 print $OUT @$lines_ref or die Carp::my_carp("write to '$file' failed: $!");
7899 close $OUT or die Carp::my_carp("close '$file' failed: $!");
7901 print "$file written.\n" if $verbosity >= $VERBOSE;
7907 sub Standardize($) {
7908 # This converts the input name string into a standardized equivalent to
7912 unless (defined $name) {
7913 Carp::my_carp_bug("Standardize() called with undef. Returning undef.");
7917 # Remove any leading or trailing white space
7921 # Convert interior white space and hypens into underscores.
7922 $name =~ s/ (?<= .) [ -]+ (.) /_$1/xg;
7924 # Capitalize the letter following an underscore, and convert a sequence of
7925 # multiple underscores to a single one
7926 $name =~ s/ (?<= .) _+ (.) /_\u$1/xg;
7928 # And capitalize the first letter, but not for the special cjk ones.
7929 $name = ucfirst($name) unless $name =~ /^k[A-Z]/;
7933 sub standardize ($) {
7934 # Returns a lower-cased standardized name, without underscores. This form
7935 # is chosen so that it can distinguish between any real versus superficial
7936 # Unicode name differences. It relies on the fact that Unicode doesn't
7937 # have interior underscores, white space, nor dashes in any
7938 # stricter-matched name. It should not be used on Unicode code point
7939 # names (the Name property), as they mostly, but not always follow these
7942 my $name = Standardize(shift);
7943 return if !defined $name;
7945 $name =~ s/ (?<= .) _ (?= . ) //xg;
7951 my $indent_increment = " " x 2;
7954 $main::simple_dumper_nesting = 0;
7957 # Like Simple Data::Dumper. Good enough for our needs. We can't use
7958 # the real thing as we have to run under miniperl.
7960 # It is designed so that on input it is at the beginning of a line,
7961 # and the final thing output in any call is a trailing ",\n".
7965 $indent = "" if ! defined $indent;
7967 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7969 # nesting level is localized, so that as the call stack pops, it goes
7970 # back to the prior value.
7971 local $main::simple_dumper_nesting = $main::simple_dumper_nesting;
7972 undef %already_output if $main::simple_dumper_nesting == 0;
7973 $main::simple_dumper_nesting++;
7974 #print STDERR __LINE__, ": $main::simple_dumper_nesting: $indent$item\n";
7976 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7978 # Determine the indent for recursive calls.
7979 my $next_indent = $indent . $indent_increment;
7984 # Dump of scalar: just output it in quotes if not a number. To do
7985 # so we must escape certain characters, and therefore need to
7986 # operate on a copy to avoid changing the original
7988 $copy = $UNDEF unless defined $copy;
7990 # Quote non-numbers (numbers also have optional leading '-' and
7992 if ($copy eq "" || $copy !~ /^ -? \d+ ( \. \d+ )? $/x) {
7994 # Escape apostrophe and backslash
7995 $copy =~ s/ ( ['\\] ) /\\$1/xg;
7998 $output = "$indent$copy,\n";
8002 # Keep track of cycles in the input, and refuse to infinitely loop
8003 my $addr = do { no overloading; pack 'J', $item; };
8004 if (defined $already_output{$addr}) {
8005 return "${indent}ALREADY OUTPUT: $item\n";
8007 $already_output{$addr} = $item;
8009 if (ref $item eq 'ARRAY') {
8012 if ($main::simple_dumper_nesting > 1) {
8014 $using_brackets = 1;
8017 $using_brackets = 0;
8020 # If the array is empty, put the closing bracket on the same
8021 # line. Otherwise, recursively add each array element
8027 for (my $i = 0; $i < @$item; $i++) {
8029 # Indent array elements one level
8030 $output .= &simple_dumper($item->[$i], $next_indent);
8031 $output =~ s/\n$//; # Remove trailing nl so as to
8032 $output .= " # [$i]\n"; # add a comment giving the
8035 $output .= $indent; # Indent closing ']' to orig level
8037 $output .= ']' if $using_brackets;
8040 elsif (ref $item eq 'HASH') {
8045 # No surrounding braces at top level
8047 if ($main::simple_dumper_nesting > 1) {
8050 $body_indent = $next_indent;
8051 $next_indent .= $indent_increment;
8056 $body_indent = $indent;
8060 # Output hashes sorted alphabetically instead of apparently
8061 # random. Use caseless alphabetic sort
8062 foreach my $key (sort { lc $a cmp lc $b } keys %$item)
8064 if ($is_first_line) {
8068 $output .= "$body_indent";
8071 # The key must be a scalar, but this recursive call quotes
8073 $output .= &simple_dumper($key);
8075 # And change the trailing comma and nl to the hash fat
8076 # comma for clarity, and so the value can be on the same
8078 $output =~ s/,\n$/ => /;
8080 # Recursively call to get the value's dump.
8081 my $next = &simple_dumper($item->{$key}, $next_indent);
8083 # If the value is all on one line, remove its indent, so
8084 # will follow the => immediately. If it takes more than
8085 # one line, start it on a new line.
8086 if ($next !~ /\n.*\n/) {
8095 $output .= "$indent},\n" if $using_braces;
8097 elsif (ref $item eq 'CODE' || ref $item eq 'GLOB') {
8098 $output = $indent . ref($item) . "\n";
8099 # XXX see if blessed
8101 elsif ($item->can('dump')) {
8103 # By convention in this program, objects furnish a 'dump'
8104 # method. Since not doing any output at this level, just pass
8105 # on the input indent
8106 $output = $item->dump($indent);
8109 Carp::my_carp("Can't cope with dumping a " . ref($item) . ". Skipping.");
8116 sub dump_inside_out {
8117 # Dump inside-out hashes in an object's state by converting them to a
8118 # regular hash and then calling simple_dumper on that.
8121 my $fields_ref = shift;
8122 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8124 my $addr = do { no overloading; pack 'J', $object; };
8127 foreach my $key (keys %$fields_ref) {
8128 $hash{$key} = $fields_ref->{$key}{$addr};
8131 return simple_dumper(\%hash, @_);
8135 # Overloaded '.' method that is common to all packages. It uses the
8136 # package's stringify method.
8140 my $reversed = shift;
8141 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8143 $other = "" unless defined $other;
8145 foreach my $which (\$self, \$other) {
8146 next unless ref $$which;
8147 if ($$which->can('_operator_stringify')) {
8148 $$which = $$which->_operator_stringify;
8151 my $ref = ref $$which;
8152 my $addr = do { no overloading; pack 'J', $$which; };
8153 $$which = "$ref ($addr)";
8161 sub _operator_equal {
8162 # Generic overloaded '==' routine. To be equal, they must be the exact
8168 return 0 unless defined $other;
8169 return 0 unless ref $other;
8171 return $self == $other;
8174 sub _operator_not_equal {
8178 return ! _operator_equal($self, $other);
8181 sub process_PropertyAliases($) {
8182 # This reads in the PropertyAliases.txt file, which contains almost all
8183 # the character properties in Unicode and their equivalent aliases:
8184 # scf ; Simple_Case_Folding ; sfc
8186 # Field 0 is the preferred short name for the property.
8187 # Field 1 is the full name.
8188 # Any succeeding ones are other accepted names.
8191 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8193 # This whole file was non-existent in early releases, so use our own
8195 $file->insert_lines(get_old_property_aliases())
8196 if ! -e 'PropertyAliases.txt';
8198 # Add any cjk properties that may have been defined.
8199 $file->insert_lines(@cjk_properties);
8201 while ($file->next_line) {
8203 my @data = split /\s*;\s*/;
8205 my $full = $data[1];
8207 my $this = Property->new($data[0], Full_Name => $full);
8209 # Start looking for more aliases after these two.
8210 for my $i (2 .. @data - 1) {
8211 $this->add_alias($data[$i]);
8218 sub finish_property_setup {
8219 # Finishes setting up after PropertyAliases.
8222 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8224 # This entry was missing from this file in earlier Unicode versions
8225 if (-e 'Jamo.txt') {
8226 my $jsn = property_ref('JSN');
8227 if (! defined $jsn) {
8228 $jsn = Property->new('JSN', Full_Name => 'Jamo_Short_Name');
8232 # This entry is still missing as of 5.2, perhaps because no short name for
8234 if (-e 'NameAliases.txt') {
8235 my $aliases = property_ref('Name_Alias');
8236 if (! defined $aliases) {
8237 $aliases = Property->new('Name_Alias');
8241 # These are used so much, that we set globals for them.
8242 $gc = property_ref('General_Category');
8243 $block = property_ref('Block');
8245 # Perl adds this alias.
8246 $gc->add_alias('Category');
8248 # For backwards compatibility, these property files have particular names.
8249 my $upper = property_ref('Uppercase_Mapping');
8250 $upper->set_core_access('uc()');
8251 $upper->set_file('Upper'); # This is what utf8.c calls it
8253 my $lower = property_ref('Lowercase_Mapping');
8254 $lower->set_core_access('lc()');
8255 $lower->set_file('Lower');
8257 my $title = property_ref('Titlecase_Mapping');
8258 $title->set_core_access('ucfirst()');
8259 $title->set_file('Title');
8261 my $fold = property_ref('Case_Folding');
8262 $fold->set_file('Fold') if defined $fold;
8264 # utf8.c can't currently cope with non range-size-1 for these, and even if
8265 # it were changed to do so, someone else may be using them, expecting the
8267 foreach my $property (qw {
8274 property_ref($property)->set_range_size_1(1);
8277 # These two properties aren't actually used in the core, but unfortunately
8278 # the names just above that are in the core interfere with these, so
8279 # choose different names. These aren't a problem unless the map tables
8280 # for these files get written out.
8281 my $lowercase = property_ref('Lowercase');
8282 $lowercase->set_file('IsLower') if defined $lowercase;
8283 my $uppercase = property_ref('Uppercase');
8284 $uppercase->set_file('IsUpper') if defined $uppercase;
8286 # Set up the hard-coded default mappings, but only on properties defined
8288 foreach my $property (keys %default_mapping) {
8289 my $property_object = property_ref($property);
8290 next if ! defined $property_object;
8291 my $default_map = $default_mapping{$property};
8292 $property_object->set_default_map($default_map);
8294 # A map of <code point> implies the property is string.
8295 if ($property_object->type == $UNKNOWN
8296 && $default_map eq $CODE_POINT)
8298 $property_object->set_type($STRING);
8302 # The following use the Multi_Default class to create objects for
8305 # Bidi class has a complicated default, but the derived file takes care of
8306 # the complications, leaving just 'L'.
8307 if (file_exists("${EXTRACTED}DBidiClass.txt")) {
8308 property_ref('Bidi_Class')->set_default_map('L');
8313 # The derived file was introduced in 3.1.1. The values below are
8314 # taken from table 3-8, TUS 3.0
8316 'my $default = Range_List->new;
8317 $default->add_range(0x0590, 0x05FF);
8318 $default->add_range(0xFB1D, 0xFB4F);'
8321 # The defaults apply only to unassigned characters
8322 $default_R .= '$gc->table("Unassigned") & $default;';
8324 if ($v_version lt v3.0.0) {
8325 $default = Multi_Default->new(R => $default_R, 'L');
8329 # AL apparently not introduced until 3.0: TUS 2.x references are
8330 # not on-line to check it out
8332 'my $default = Range_List->new;
8333 $default->add_range(0x0600, 0x07BF);
8334 $default->add_range(0xFB50, 0xFDFF);
8335 $default->add_range(0xFE70, 0xFEFF);'
8338 # Non-character code points introduced in this release; aren't AL
8339 if ($v_version ge 3.1.0) {
8340 $default_AL .= '$default->delete_range(0xFDD0, 0xFDEF);';
8342 $default_AL .= '$gc->table("Unassigned") & $default';
8343 $default = Multi_Default->new(AL => $default_AL,
8347 property_ref('Bidi_Class')->set_default_map($default);
8350 # Joining type has a complicated default, but the derived file takes care
8351 # of the complications, leaving just 'U' (or Non_Joining), except the file
8353 if (file_exists("${EXTRACTED}DJoinType.txt") || -e 'ArabicShaping.txt') {
8354 if (file_exists("${EXTRACTED}DJoinType.txt") && $v_version ne 3.1.0) {
8355 property_ref('Joining_Type')->set_default_map('Non_Joining');
8359 # Otherwise, there are not one, but two possibilities for the
8360 # missing defaults: T and U.
8361 # The missing defaults that evaluate to T are given by:
8362 # T = Mn + Cf - ZWNJ - ZWJ
8363 # where Mn and Cf are the general category values. In other words,
8364 # any non-spacing mark or any format control character, except
8365 # U+200C ZERO WIDTH NON-JOINER (joining type U) and U+200D ZERO
8366 # WIDTH JOINER (joining type C).
8367 my $default = Multi_Default->new(
8368 'T' => '$gc->table("Mn") + $gc->table("Cf") - 0x200C - 0x200D',
8370 property_ref('Joining_Type')->set_default_map($default);
8374 # Line break has a complicated default in early releases. It is 'Unknown'
8375 # for non-assigned code points; 'AL' for assigned.
8376 if (file_exists("${EXTRACTED}DLineBreak.txt") || -e 'LineBreak.txt') {
8377 my $lb = property_ref('Line_Break');
8378 if ($v_version gt 3.2.0) {
8379 $lb->set_default_map('Unknown');
8382 my $default = Multi_Default->new( 'Unknown' => '$gc->table("Cn")',
8384 $lb->set_default_map($default);
8387 # If has the URS property, make sure that the standard aliases are in
8388 # it, since not in the input tables in some versions.
8389 my $urs = property_ref('Unicode_Radical_Stroke');
8391 $urs->add_alias('cjkRSUnicode');
8392 $urs->add_alias('kRSUnicode');
8398 sub get_old_property_aliases() {
8399 # Returns what would be in PropertyAliases.txt if it existed in very old
8400 # versions of Unicode. It was derived from the one in 3.2, and pared
8401 # down based on the data that was actually in the older releases.
8402 # An attempt was made to use the existence of files to mean inclusion or
8403 # not of various aliases, but if this was not sufficient, using version
8404 # numbers was resorted to.
8408 # These are to be used in all versions (though some are constructed by
8409 # this program if missing)
8410 push @return, split /\n/, <<'END';
8412 Bidi_M ; Bidi_Mirrored
8414 ccc ; Canonical_Combining_Class
8415 dm ; Decomposition_Mapping
8416 dt ; Decomposition_Type
8417 gc ; General_Category
8419 lc ; Lowercase_Mapping
8421 na1 ; Unicode_1_Name
8424 sfc ; Simple_Case_Folding
8425 slc ; Simple_Lowercase_Mapping
8426 stc ; Simple_Titlecase_Mapping
8427 suc ; Simple_Uppercase_Mapping
8428 tc ; Titlecase_Mapping
8429 uc ; Uppercase_Mapping
8432 if (-e 'Blocks.txt') {
8433 push @return, "blk ; Block\n";
8435 if (-e 'ArabicShaping.txt') {
8436 push @return, split /\n/, <<'END';
8441 if (-e 'PropList.txt') {
8443 # This first set is in the original old-style proplist.
8444 push @return, split /\n/, <<'END';
8446 Bidi_C ; Bidi_Control
8454 Join_C ; Join_Control
8456 QMark ; Quotation_Mark
8457 Term ; Terminal_Punctuation
8458 WSpace ; White_Space
8460 # The next sets were added later
8461 if ($v_version ge v3.0.0) {
8462 push @return, split /\n/, <<'END';
8467 if ($v_version ge v3.0.1) {
8468 push @return, split /\n/, <<'END';
8469 NChar ; Noncharacter_Code_Point
8472 # The next sets were added in the new-style
8473 if ($v_version ge v3.1.0) {
8474 push @return, split /\n/, <<'END';
8475 OAlpha ; Other_Alphabetic
8476 OLower ; Other_Lowercase
8478 OUpper ; Other_Uppercase
8481 if ($v_version ge v3.1.1) {
8482 push @return, "AHex ; ASCII_Hex_Digit\n";
8485 if (-e 'EastAsianWidth.txt') {
8486 push @return, "ea ; East_Asian_Width\n";
8488 if (-e 'CompositionExclusions.txt') {
8489 push @return, "CE ; Composition_Exclusion\n";
8491 if (-e 'LineBreak.txt') {
8492 push @return, "lb ; Line_Break\n";
8494 if (-e 'BidiMirroring.txt') {
8495 push @return, "bmg ; Bidi_Mirroring_Glyph\n";
8497 if (-e 'Scripts.txt') {
8498 push @return, "sc ; Script\n";
8500 if (-e 'DNormalizationProps.txt') {
8501 push @return, split /\n/, <<'END';
8502 Comp_Ex ; Full_Composition_Exclusion
8503 FC_NFKC ; FC_NFKC_Closure
8504 NFC_QC ; NFC_Quick_Check
8505 NFD_QC ; NFD_Quick_Check
8506 NFKC_QC ; NFKC_Quick_Check
8507 NFKD_QC ; NFKD_Quick_Check
8508 XO_NFC ; Expands_On_NFC
8509 XO_NFD ; Expands_On_NFD
8510 XO_NFKC ; Expands_On_NFKC
8511 XO_NFKD ; Expands_On_NFKD
8514 if (-e 'DCoreProperties.txt') {
8515 push @return, split /\n/, <<'END';
8520 # These can also appear in some versions of PropList.txt
8521 push @return, "Lower ; Lowercase\n"
8522 unless grep { $_ =~ /^Lower\b/} @return;
8523 push @return, "Upper ; Uppercase\n"
8524 unless grep { $_ =~ /^Upper\b/} @return;
8527 # This flag requires the DAge.txt file to be copied into the directory.
8528 if (DEBUG && $compare_versions) {
8529 push @return, 'age ; Age';
8535 sub process_PropValueAliases {
8536 # This file contains values that properties look like:
8537 # bc ; AL ; Arabic_Letter
8538 # blk; n/a ; Greek_And_Coptic ; Greek
8540 # Field 0 is the property.
8541 # Field 1 is the short name of a property value or 'n/a' if no
8542 # short name exists;
8543 # Field 2 is the full property value name;
8544 # Any other fields are more synonyms for the property value.
8545 # Purely numeric property values are omitted from the file; as are some
8546 # others, fewer and fewer in later releases
8548 # Entries for the ccc property have an extra field before the
8550 # ccc; 0; NR ; Not_Reordered
8551 # It is the numeric value that the names are synonyms for.
8553 # There are comment entries for values missing from this file:
8554 # # @missing: 0000..10FFFF; ISO_Comment; <none>
8555 # # @missing: 0000..10FFFF; Lowercase_Mapping; <code point>
8558 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8560 # This whole file was non-existent in early releases, so use our own
8561 # internal one if necessary.
8562 if (! -e 'PropValueAliases.txt') {
8563 $file->insert_lines(get_old_property_value_aliases());
8566 # Add any explicit cjk values
8567 $file->insert_lines(@cjk_property_values);
8569 # This line is used only for testing the code that checks for name
8570 # conflicts. There is a script Inherited, and when this line is executed
8571 # it causes there to be a name conflict with the 'Inherited' that this
8572 # program generates for this block property value
8573 #$file->insert_lines('blk; n/a; Herited');
8576 # Process each line of the file ...
8577 while ($file->next_line) {
8579 my ($property, @data) = split /\s*;\s*/;
8581 # The full name for the ccc property value is in field 2 of the
8582 # remaining ones; field 1 for all other properties. Swap ccc fields 1
8583 # and 2. (Rightmost splice removes field 2, returning it; left splice
8584 # inserts that into field 1, thus shifting former field 1 to field 2.)
8585 splice (@data, 1, 0, splice(@data, 2, 1)) if $property eq 'ccc';
8587 # If there is no short name, use the full one in element 1
8588 $data[0] = $data[1] if $data[0] eq "n/a";
8590 # Earlier releases had the pseudo property 'qc' that should expand to
8591 # the ones that replace it below.
8592 if ($property eq 'qc') {
8593 if (lc $data[0] eq 'y') {
8594 $file->insert_lines('NFC_QC; Y ; Yes',
8600 elsif (lc $data[0] eq 'n') {
8601 $file->insert_lines('NFC_QC; N ; No',
8607 elsif (lc $data[0] eq 'm') {
8608 $file->insert_lines('NFC_QC; M ; Maybe',
8609 'NFKC_QC; M ; Maybe',
8613 $file->carp_bad_line("qc followed by unexpected '$data[0]");
8618 # The first field is the short name, 2nd is the full one.
8619 my $property_object = property_ref($property);
8620 my $table = $property_object->add_match_table($data[0],
8621 Full_Name => $data[1]);
8623 # Start looking for more aliases after these two.
8624 for my $i (2 .. @data - 1) {
8625 $table->add_alias($data[$i]);
8627 } # End of looping through the file
8629 # As noted in the comments early in the program, it generates tables for
8630 # the default values for all releases, even those for which the concept
8631 # didn't exist at the time. Here we add those if missing.
8632 my $age = property_ref('age');
8633 if (defined $age && ! defined $age->table('Unassigned')) {
8634 $age->add_match_table('Unassigned');
8636 $block->add_match_table('No_Block') if -e 'Blocks.txt'
8637 && ! defined $block->table('No_Block');
8640 # Now set the default mappings of the properties from the file. This is
8641 # done after the loop because a number of properties have only @missings
8642 # entries in the file, and may not show up until the end.
8643 my @defaults = $file->get_missings;
8644 foreach my $default_ref (@defaults) {
8645 my $default = $default_ref->[0];
8646 my $property = property_ref($default_ref->[1]);
8647 $property->set_default_map($default);
8652 sub get_old_property_value_aliases () {
8653 # Returns what would be in PropValueAliases.txt if it existed in very old
8654 # versions of Unicode. It was derived from the one in 3.2, and pared
8655 # down. An attempt was made to use the existence of files to mean
8656 # inclusion or not of various aliases, but if this was not sufficient,
8657 # using version numbers was resorted to.
8659 my @return = split /\n/, <<'END';
8660 bc ; AN ; Arabic_Number
8661 bc ; B ; Paragraph_Separator
8662 bc ; CS ; Common_Separator
8663 bc ; EN ; European_Number
8664 bc ; ES ; European_Separator
8665 bc ; ET ; European_Terminator
8666 bc ; L ; Left_To_Right
8667 bc ; ON ; Other_Neutral
8668 bc ; R ; Right_To_Left
8669 bc ; WS ; White_Space
8671 # The standard combining classes are very much different in v1, so only use
8672 # ones that look right (not checked thoroughly)
8673 ccc; 0; NR ; Not_Reordered
8674 ccc; 1; OV ; Overlay
8676 ccc; 8; KV ; Kana_Voicing
8678 ccc; 202; ATBL ; Attached_Below_Left
8679 ccc; 216; ATAR ; Attached_Above_Right
8680 ccc; 218; BL ; Below_Left
8682 ccc; 222; BR ; Below_Right
8684 ccc; 228; AL ; Above_Left
8686 ccc; 232; AR ; Above_Right
8687 ccc; 234; DA ; Double_Above
8689 dt ; can ; canonical
8703 gc ; C ; Other # Cc | Cf | Cn | Co | Cs
8705 gc ; Cn ; Unassigned
8706 gc ; Co ; Private_Use
8707 gc ; L ; Letter # Ll | Lm | Lo | Lt | Lu
8708 gc ; LC ; Cased_Letter # Ll | Lt | Lu
8709 gc ; Ll ; Lowercase_Letter
8710 gc ; Lm ; Modifier_Letter
8711 gc ; Lo ; Other_Letter
8712 gc ; Lu ; Uppercase_Letter
8713 gc ; M ; Mark # Mc | Me | Mn
8714 gc ; Mc ; Spacing_Mark
8715 gc ; Mn ; Nonspacing_Mark
8716 gc ; N ; Number # Nd | Nl | No
8717 gc ; Nd ; Decimal_Number
8718 gc ; No ; Other_Number
8719 gc ; P ; Punctuation # Pc | Pd | Pe | Pf | Pi | Po | Ps
8720 gc ; Pd ; Dash_Punctuation
8721 gc ; Pe ; Close_Punctuation
8722 gc ; Po ; Other_Punctuation
8723 gc ; Ps ; Open_Punctuation
8724 gc ; S ; Symbol # Sc | Sk | Sm | So
8725 gc ; Sc ; Currency_Symbol
8726 gc ; Sm ; Math_Symbol
8727 gc ; So ; Other_Symbol
8728 gc ; Z ; Separator # Zl | Zp | Zs
8729 gc ; Zl ; Line_Separator
8730 gc ; Zp ; Paragraph_Separator
8731 gc ; Zs ; Space_Separator
8739 if (-e 'ArabicShaping.txt') {
8740 push @return, split /\n/, <<'END';
8747 jg ; n/a ; NO_JOINING_GROUP
8755 jt ; C ; Join_Causing
8756 jt ; D ; Dual_Joining
8757 jt ; L ; Left_Joining
8758 jt ; R ; Right_Joining
8759 jt ; U ; Non_Joining
8760 jt ; T ; Transparent
8762 if ($v_version ge v3.0.0) {
8763 push @return, split /\n/, <<'END';
8767 jg ; n/a ; DALATH_RISH
8770 jg ; n/a ; FINAL_SEMKATH
8773 jg ; n/a ; HAMZA_ON_HEH_GOAL
8780 jg ; n/a ; KNOTTED_HEH
8787 jg ; n/a ; REVERSED_PE
8791 jg ; n/a ; SWASH_KAF
8793 jg ; n/a ; TEH_MARBUTA
8796 jg ; n/a ; YEH_BARREE
8797 jg ; n/a ; YEH_WITH_TAIL
8806 if (-e 'EastAsianWidth.txt') {
8807 push @return, split /\n/, <<'END';
8817 if (-e 'LineBreak.txt') {
8818 push @return, split /\n/, <<'END';
8820 lb ; AL ; Alphabetic
8821 lb ; B2 ; Break_Both
8822 lb ; BA ; Break_After
8823 lb ; BB ; Break_Before
8824 lb ; BK ; Mandatory_Break
8825 lb ; CB ; Contingent_Break
8826 lb ; CL ; Close_Punctuation
8827 lb ; CM ; Combining_Mark
8828 lb ; CR ; Carriage_Return
8829 lb ; EX ; Exclamation
8832 lb ; ID ; Ideographic
8833 lb ; IN ; Inseperable
8834 lb ; IS ; Infix_Numeric
8836 lb ; NS ; Nonstarter
8838 lb ; OP ; Open_Punctuation
8839 lb ; PO ; Postfix_Numeric
8840 lb ; PR ; Prefix_Numeric
8842 lb ; SA ; Complex_Context
8845 lb ; SY ; Break_Symbols
8851 if (-e 'DNormalizationProps.txt') {
8852 push @return, split /\n/, <<'END';
8859 if (-e 'Scripts.txt') {
8860 push @return, split /\n/, <<'END';
8862 sc ; Armn ; Armenian
8864 sc ; Bopo ; Bopomofo
8865 sc ; Cans ; Canadian_Aboriginal
8866 sc ; Cher ; Cherokee
8867 sc ; Cyrl ; Cyrillic
8868 sc ; Deva ; Devanagari
8870 sc ; Ethi ; Ethiopic
8871 sc ; Geor ; Georgian
8874 sc ; Gujr ; Gujarati
8875 sc ; Guru ; Gurmukhi
8879 sc ; Hira ; Hiragana
8880 sc ; Ital ; Old_Italic
8881 sc ; Kana ; Katakana
8886 sc ; Mlym ; Malayalam
8887 sc ; Mong ; Mongolian
8891 sc ; Qaai ; Inherited
8905 if ($v_version ge v2.0.0) {
8906 push @return, split /\n/, <<'END';
8910 dt ; vert ; vertical
8915 gc ; Lt ; Titlecase_Letter
8916 gc ; Me ; Enclosing_Mark
8917 gc ; Nl ; Letter_Number
8918 gc ; Pc ; Connector_Punctuation
8919 gc ; Sk ; Modifier_Symbol
8922 if ($v_version ge v2.1.2) {
8923 push @return, "bc ; S ; Segment_Separator\n";
8925 if ($v_version ge v2.1.5) {
8926 push @return, split /\n/, <<'END';
8927 gc ; Pf ; Final_Punctuation
8928 gc ; Pi ; Initial_Punctuation
8931 if ($v_version ge v2.1.8) {
8932 push @return, "ccc; 240; IS ; Iota_Subscript\n";
8935 if ($v_version ge v3.0.0) {
8936 push @return, split /\n/, <<'END';
8937 bc ; AL ; Arabic_Letter
8938 bc ; BN ; Boundary_Neutral
8939 bc ; LRE ; Left_To_Right_Embedding
8940 bc ; LRO ; Left_To_Right_Override
8941 bc ; NSM ; Nonspacing_Mark
8942 bc ; PDF ; Pop_Directional_Format
8943 bc ; RLE ; Right_To_Left_Embedding
8944 bc ; RLO ; Right_To_Left_Override
8946 ccc; 233; DB ; Double_Below
8950 if ($v_version ge v3.1.0) {
8951 push @return, "ccc; 226; R ; Right\n";
8957 sub output_perl_charnames_line ($$) {
8959 # Output the entries in Perl_charnames specially, using 5 digits instead
8960 # of four. This makes the entries a constant length, and simplifies
8961 # charnames.pm which this table is for. Unicode can have 6 digit
8962 # ordinals, but they are all private use or noncharacters which do not
8963 # have names, so won't be in this table.
8965 return sprintf "%05X\t%s\n", $_[0], $_[1];
8969 # This is used to store the range list of all the code points usable when
8970 # the little used $compare_versions feature is enabled.
8971 my $compare_versions_range_list;
8973 sub process_generic_property_file {
8974 # This processes a file containing property mappings and puts them
8975 # into internal map tables. It should be used to handle any property
8976 # files that have mappings from a code point or range thereof to
8977 # something else. This means almost all the UCD .txt files.
8978 # each_line_handlers() should be set to adjust the lines of these
8979 # files, if necessary, to what this routine understands:
8984 # the fields are: "codepoint-range ; property; map"
8986 # meaning the codepoints in the range all have the value 'map' under
8988 # Beginning and trailing white space in each field are not signficant.
8989 # Note there is not a trailing semi-colon in the above. A trailing
8990 # semi-colon means the map is a null-string. An omitted map, as
8991 # opposed to a null-string, is assumed to be 'Y', based on Unicode
8992 # table syntax. (This could have been hidden from this routine by
8993 # doing it in the $file object, but that would require parsing of the
8994 # line there, so would have to parse it twice, or change the interface
8995 # to pass this an array. So not done.)
8997 # The map field may begin with a sequence of commands that apply to
8998 # this range. Each such command begins and ends with $CMD_DELIM.
8999 # These are used to indicate, for example, that the mapping for a
9000 # range has a non-default type.
9002 # This loops through the file, calling it's next_line() method, and
9003 # then taking the map and adding it to the property's table.
9004 # Complications arise because any number of properties can be in the
9005 # file, in any order, interspersed in any way. The first time a
9006 # property is seen, it gets information about that property and
9007 # caches it for quick retrieval later. It also normalizes the maps
9008 # so that only one of many synonym is stored. The Unicode input files
9009 # do use some multiple synonyms.
9012 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
9014 my %property_info; # To keep track of what properties
9015 # have already had entries in the
9016 # current file, and info about each,
9017 # so don't have to recompute.
9018 my $property_name; # property currently being worked on
9019 my $property_type; # and its type
9020 my $previous_property_name = ""; # name from last time through loop
9021 my $property_object; # pointer to the current property's
9023 my $property_addr; # the address of that object
9024 my $default_map; # the string that code points missing
9025 # from the file map to
9026 my $default_table; # For non-string properties, a
9027 # reference to the match table that
9028 # will contain the list of code
9029 # points that map to $default_map.
9031 # Get the next real non-comment line
9033 while ($file->next_line) {
9035 # Default replacement type; means that if parts of the range have
9036 # already been stored in our tables, the new map overrides them if
9037 # they differ more than cosmetically
9038 my $replace = $IF_NOT_EQUIVALENT;
9039 my $map_type; # Default type for the map of this range
9041 #local $to_trace = 1 if main::DEBUG;
9042 trace $_ if main::DEBUG && $to_trace;
9044 # Split the line into components
9045 my ($range, $property_name, $map, @remainder)
9046 = split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields
9048 # If more or less on the line than we are expecting, warn and skip
9051 $file->carp_bad_line('Extra fields');
9054 elsif ( ! defined $property_name) {
9055 $file->carp_bad_line('Missing property');
9059 # Examine the range.
9060 if ($range !~ /^ ($code_point_re) (?:\.\. ($code_point_re) )? $/x)
9062 $file->carp_bad_line("Range '$range' not of the form 'CP1' or 'CP1..CP2' (where CP1,2 are code points in hex)");
9066 my $high = (defined $2) ? hex $2 : $low;
9068 # For the very specialized case of comparing two Unicode
9070 if (DEBUG && $compare_versions) {
9071 if ($property_name eq 'Age') {
9073 # Only allow code points at least as old as the version
9075 my $age = pack "C*", split(/\./, $map); # v string
9076 next LINE if $age gt $compare_versions;
9080 # Again, we throw out code points younger than those of
9081 # the specified version. By now, the Age property is
9082 # populated. We use the intersection of each input range
9083 # with this property to find what code points in it are
9084 # valid. To do the intersection, we have to convert the
9085 # Age property map to a Range_list. We only have to do
9087 if (! defined $compare_versions_range_list) {
9088 my $age = property_ref('Age');
9089 if (! -e 'DAge.txt') {
9090 croak "Need to have 'DAge.txt' file to do version comparison";
9092 elsif ($age->count == 0) {
9093 croak "The 'Age' table is empty, but its file exists";
9095 $compare_versions_range_list
9096 = Range_List->new(Initialize => $age);
9099 # An undefined map is always 'Y'
9100 $map = 'Y' if ! defined $map;
9102 # Calculate the intersection of the input range with the
9103 # code points that are known in the specified version
9104 my @ranges = ($compare_versions_range_list
9105 & Range->new($low, $high))->ranges;
9107 # If the intersection is empty, throw away this range
9108 next LINE unless @ranges;
9110 # Only examine the first range this time through the loop.
9111 my $this_range = shift @ranges;
9113 # Put any remaining ranges in the queue to be processed
9114 # later. Note that there is unnecessary work here, as we
9115 # will do the intersection again for each of these ranges
9116 # during some future iteration of the LINE loop, but this
9117 # code is not used in production. The later intersections
9118 # are guaranteed to not splinter, so this will not become
9120 my $line = join ';', $property_name, $map;
9121 foreach my $range (@ranges) {
9122 $file->insert_adjusted_lines(sprintf("%04X..%04X; %s",
9128 # And process the first range, like any other.
9129 $low = $this_range->start;
9130 $high = $this_range->end;
9132 } # End of $compare_versions
9134 # If changing to a new property, get the things constant per
9136 if ($previous_property_name ne $property_name) {
9138 $property_object = property_ref($property_name);
9139 if (! defined $property_object) {
9140 $file->carp_bad_line("Unexpected property '$property_name'. Skipped");
9143 { no overloading; $property_addr = pack 'J', $property_object; }
9145 # Defer changing names until have a line that is acceptable
9146 # (the 'next' statement above means is unacceptable)
9147 $previous_property_name = $property_name;
9149 # If not the first time for this property, retrieve info about
9151 if (defined ($property_info{$property_addr}{'type'})) {
9152 $property_type = $property_info{$property_addr}{'type'};
9153 $default_map = $property_info{$property_addr}{'default'};
9155 = $property_info{$property_addr}{'pseudo_map_type'};
9157 = $property_info{$property_addr}{'default_table'};
9161 # Here, is the first time for this property. Set up the
9163 $property_type = $property_info{$property_addr}{'type'}
9164 = $property_object->type;
9166 = $property_info{$property_addr}{'pseudo_map_type'}
9167 = $property_object->pseudo_map_type;
9169 # The Unicode files are set up so that if the map is not
9170 # defined, it is a binary property
9171 if (! defined $map && $property_type != $BINARY) {
9172 if ($property_type != $UNKNOWN
9173 && $property_type != $NON_STRING)
9175 $file->carp_bad_line("No mapping defined on a non-binary property. Using 'Y' for the map");
9178 $property_object->set_type($BINARY);
9180 = $property_info{$property_addr}{'type'}
9185 # Get any @missings default for this property. This
9186 # should precede the first entry for the property in the
9187 # input file, and is located in a comment that has been
9188 # stored by the Input_file class until we access it here.
9189 # It's possible that there is more than one such line
9190 # waiting for us; collect them all, and parse
9191 my @missings_list = $file->get_missings
9192 if $file->has_missings_defaults;
9193 foreach my $default_ref (@missings_list) {
9194 my $default = $default_ref->[0];
9195 my $addr = do { no overloading; pack 'J', property_ref($default_ref->[1]); };
9197 # For string properties, the default is just what the
9198 # file says, but non-string properties should already
9199 # have set up a table for the default property value;
9200 # use the table for these, so can resolve synonyms
9201 # later to a single standard one.
9202 if ($property_type == $STRING
9203 || $property_type == $UNKNOWN)
9205 $property_info{$addr}{'missings'} = $default;
9208 $property_info{$addr}{'missings'}
9209 = $property_object->table($default);
9213 # Finished storing all the @missings defaults in the input
9214 # file so far. Get the one for the current property.
9215 my $missings = $property_info{$property_addr}{'missings'};
9217 # But we likely have separately stored what the default
9218 # should be. (This is to accommodate versions of the
9219 # standard where the @missings lines are absent or
9220 # incomplete.) Hopefully the two will match. But check
9222 $default_map = $property_object->default_map;
9224 # If the map is a ref, it means that the default won't be
9225 # processed until later, so undef it, so next few lines
9226 # will redefine it to something that nothing will match
9227 undef $default_map if ref $default_map;
9229 # Create a $default_map if don't have one; maybe a dummy
9230 # that won't match anything.
9231 if (! defined $default_map) {
9233 # Use any @missings line in the file.
9234 if (defined $missings) {
9235 if (ref $missings) {
9236 $default_map = $missings->full_name;
9237 $default_table = $missings;
9240 $default_map = $missings;
9243 # And store it with the property for outside use.
9244 $property_object->set_default_map($default_map);
9248 # Neither an @missings nor a default map. Create
9249 # a dummy one, so won't have to test definedness
9251 $default_map = '_Perl This will never be in a file
9256 # Here, we have $default_map defined, possibly in terms of
9257 # $missings, but maybe not, and possibly is a dummy one.
9258 if (defined $missings) {
9260 # Make sure there is no conflict between the two.
9261 # $missings has priority.
9262 if (ref $missings) {
9264 = $property_object->table($default_map);
9265 if (! defined $default_table
9266 || $default_table != $missings)
9268 if (! defined $default_table) {
9269 $default_table = $UNDEF;
9271 $file->carp_bad_line(<<END
9272 The \@missings line for $property_name in $file says that missings default to
9273 $missings, but we expect it to be $default_table. $missings used.
9276 $default_table = $missings;
9277 $default_map = $missings->full_name;
9279 $property_info{$property_addr}{'default_table'}
9282 elsif ($default_map ne $missings) {
9283 $file->carp_bad_line(<<END
9284 The \@missings line for $property_name in $file says that missings default to
9285 $missings, but we expect it to be $default_map. $missings used.
9288 $default_map = $missings;
9292 $property_info{$property_addr}{'default'}
9295 # If haven't done so already, find the table corresponding
9296 # to this map for non-string properties.
9297 if (! defined $default_table
9298 && $property_type != $STRING
9299 && $property_type != $UNKNOWN)
9301 $default_table = $property_info{$property_addr}
9303 = $property_object->table($default_map);
9305 } # End of is first time for this property
9306 } # End of switching properties.
9308 # Ready to process the line.
9309 # The Unicode files are set up so that if the map is not defined,
9310 # it is a binary property with value 'Y'
9311 if (! defined $map) {
9316 # If the map begins with a special command to us (enclosed in
9317 # delimiters), extract the command(s).
9318 if (substr($map, 0, 1) eq $CMD_DELIM) {
9319 while ($map =~ s/ ^ $CMD_DELIM (.*?) $CMD_DELIM //x) {
9321 if ($command =~ / ^ $REPLACE_CMD= (.*) /x) {
9324 elsif ($command =~ / ^ $MAP_TYPE_CMD= (.*) /x) {
9328 $file->carp_bad_line("Unknown command line: '$1'");
9335 if ($default_map eq $CODE_POINT && $map =~ / ^ $code_point_re $/x)
9338 # Here, we have a map to a particular code point, and the
9339 # default map is to a code point itself. If the range
9340 # includes the particular code point, change that portion of
9341 # the range to the default. This makes sure that in the final
9342 # table only the non-defaults are listed.
9343 my $decimal_map = hex $map;
9344 if ($low <= $decimal_map && $decimal_map <= $high) {
9346 # If the range includes stuff before or after the map
9347 # we're changing, split it and process the split-off parts
9349 if ($low < $decimal_map) {
9350 $file->insert_adjusted_lines(
9351 sprintf("%04X..%04X; %s; %s",
9357 if ($high > $decimal_map) {
9358 $file->insert_adjusted_lines(
9359 sprintf("%04X..%04X; %s; %s",
9365 $low = $high = $decimal_map;
9370 # If we can tell that this is a synonym for the default map, use
9371 # the default one instead.
9372 if ($property_type != $STRING
9373 && $property_type != $UNKNOWN)
9375 my $table = $property_object->table($map);
9376 if (defined $table && $table == $default_table) {
9377 $map = $default_map;
9381 # And figure out the map type if not known.
9382 if (! defined $map_type || $map_type == $COMPUTE_NO_MULTI_CP) {
9383 if ($map eq "") { # Nulls are always $NULL map type
9385 } # Otherwise, non-strings, and those that don't allow
9386 # $MULTI_CP, and those that aren't multiple code points are
9389 (($property_type != $STRING && $property_type != $UNKNOWN)
9390 || (defined $map_type && $map_type == $COMPUTE_NO_MULTI_CP)
9391 || $map !~ /^ $code_point_re ( \ $code_point_re )+ $ /x)
9396 $map_type = $MULTI_CP;
9400 $property_object->add_map($low, $high,
9403 Replace => $replace);
9404 } # End of loop through file's lines
9410 { # Closure for UnicodeData.txt handling
9412 # This file was the first one in the UCD; its design leads to some
9413 # awkwardness in processing. Here is a sample line:
9414 # 0041;LATIN CAPITAL LETTER A;Lu;0;L;;;;;N;;;;0061;
9415 # The fields in order are:
9416 my $i = 0; # The code point is in field 0, and is shifted off.
9417 my $CHARNAME = $i++; # character name (e.g. "LATIN CAPITAL LETTER A")
9418 my $CATEGORY = $i++; # category (e.g. "Lu")
9419 my $CCC = $i++; # Canonical combining class (e.g. "230")
9420 my $BIDI = $i++; # directional class (e.g. "L")
9421 my $PERL_DECOMPOSITION = $i++; # decomposition mapping
9422 my $PERL_DECIMAL_DIGIT = $i++; # decimal digit value
9423 my $NUMERIC_TYPE_OTHER_DIGIT = $i++; # digit value, like a superscript
9424 # Dual-use in this program; see below
9425 my $NUMERIC = $i++; # numeric value
9426 my $MIRRORED = $i++; # ? mirrored
9427 my $UNICODE_1_NAME = $i++; # name in Unicode 1.0
9428 my $COMMENT = $i++; # iso comment
9429 my $UPPER = $i++; # simple uppercase mapping
9430 my $LOWER = $i++; # simple lowercase mapping
9431 my $TITLE = $i++; # simple titlecase mapping
9432 my $input_field_count = $i;
9434 # This routine in addition outputs these extra fields:
9435 my $DECOMP_TYPE = $i++; # Decomposition type
9437 # These fields are modifications of ones above, and are usually
9438 # suppressed; they must come last, as for speed, the loop upper bound is
9439 # normally set to ignore them
9440 my $NAME = $i++; # This is the strict name field, not the one that
9442 my $DECOMP_MAP = $i++; # Strict decomposition mapping; not the one used
9443 # by Unicode::Normalize
9444 my $last_field = $i - 1;
9446 # All these are read into an array for each line, with the indices defined
9447 # above. The empty fields in the example line above indicate that the
9448 # value is defaulted. The handler called for each line of the input
9449 # changes these to their defaults.
9451 # Here are the official names of the properties, in a parallel array:
9453 $field_names[$BIDI] = 'Bidi_Class';
9454 $field_names[$CATEGORY] = 'General_Category';
9455 $field_names[$CCC] = 'Canonical_Combining_Class';
9456 $field_names[$CHARNAME] = 'Perl_Charnames';
9457 $field_names[$COMMENT] = 'ISO_Comment';
9458 $field_names[$DECOMP_MAP] = 'Decomposition_Mapping';
9459 $field_names[$DECOMP_TYPE] = 'Decomposition_Type';
9460 $field_names[$LOWER] = 'Lowercase_Mapping';
9461 $field_names[$MIRRORED] = 'Bidi_Mirrored';
9462 $field_names[$NAME] = 'Name';
9463 $field_names[$NUMERIC] = 'Numeric_Value';
9464 $field_names[$NUMERIC_TYPE_OTHER_DIGIT] = 'Numeric_Type';
9465 $field_names[$PERL_DECIMAL_DIGIT] = 'Perl_Decimal_Digit';
9466 $field_names[$PERL_DECOMPOSITION] = 'Perl_Decomposition_Mapping';
9467 $field_names[$TITLE] = 'Titlecase_Mapping';
9468 $field_names[$UNICODE_1_NAME] = 'Unicode_1_Name';
9469 $field_names[$UPPER] = 'Uppercase_Mapping';
9471 # Some of these need a little more explanation:
9472 # The $PERL_DECIMAL_DIGIT field does not lead to an official Unicode
9473 # property, but is used in calculating the Numeric_Type. Perl however,
9474 # creates a file from this field, so a Perl property is created from it.
9475 # Similarly, the Other_Digit field is used only for calculating the
9476 # Numeric_Type, and so it can be safely re-used as the place to store
9477 # the value for Numeric_Type; hence it is referred to as
9478 # $NUMERIC_TYPE_OTHER_DIGIT.
9479 # The input field named $PERL_DECOMPOSITION is a combination of both the
9480 # decomposition mapping and its type. Perl creates a file containing
9481 # exactly this field, so it is used for that. The two properties are
9482 # separated into two extra output fields, $DECOMP_MAP and $DECOMP_TYPE.
9483 # $DECOMP_MAP is usually suppressed (unless the lists are changed to
9484 # output it), as Perl doesn't use it directly.
9485 # The input field named here $CHARNAME is used to construct the
9486 # Perl_Charnames property, which is a combination of the Name property
9487 # (which the input field contains), and the Unicode_1_Name property, and
9488 # others from other files. Since, the strict Name property is not used
9489 # by Perl, this field is used for the table that Perl does use. The
9490 # strict Name property table is usually suppressed (unless the lists are
9491 # changed to output it), so it is accumulated in a separate field,
9492 # $NAME, which to save time is discarded unless the table is actually to
9495 # This file is processed like most in this program. Control is passed to
9496 # process_generic_property_file() which calls filter_UnicodeData_line()
9497 # for each input line. This filter converts the input into line(s) that
9498 # process_generic_property_file() understands. There is also a setup
9499 # routine called before any of the file is processed, and a handler for
9500 # EOF processing, all in this closure.
9502 # A huge speed-up occurred at the cost of some added complexity when these
9503 # routines were altered to buffer the outputs into ranges. Almost all the
9504 # lines of the input file apply to just one code point, and for most
9505 # properties, the map for the next code point up is the same as the
9506 # current one. So instead of creating a line for each property for each
9507 # input line, filter_UnicodeData_line() remembers what the previous map
9508 # of a property was, and doesn't generate a line to pass on until it has
9509 # to, as when the map changes; and that passed-on line encompasses the
9510 # whole contiguous range of code points that have the same map for that
9511 # property. This means a slight amount of extra setup, and having to
9512 # flush these buffers on EOF, testing if the maps have changed, plus
9513 # remembering state information in the closure. But it means a lot less
9514 # real time in not having to change the data base for each property on
9517 # Another complication is that there are already a few ranges designated
9518 # in the input. There are two lines for each, with the same maps except
9519 # the code point and name on each line. This was actually the hardest
9520 # thing to design around. The code points in those ranges may actually
9521 # have real maps not given by these two lines. These maps will either
9522 # be algorthimically determinable, or in the extracted files furnished
9523 # with the UCD. In the event of conflicts between these extracted files,
9524 # and this one, Unicode says that this one prevails. But it shouldn't
9525 # prevail for conflicts that occur in these ranges. The data from the
9526 # extracted files prevails in those cases. So, this program is structured
9527 # so that those files are processed first, storing maps. Then the other
9528 # files are processed, generally overwriting what the extracted files
9529 # stored. But just the range lines in this input file are processed
9530 # without overwriting. This is accomplished by adding a special string to
9531 # the lines output to tell process_generic_property_file() to turn off the
9532 # overwriting for just this one line.
9533 # A similar mechanism is used to tell it that the map is of a non-default
9536 sub setup_UnicodeData { # Called before any lines of the input are read
9538 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
9540 # Create a new property specially located that is a combination of the
9541 # various Name properties: Name, Unicode_1_Name, Named Sequences, and
9542 # Name_Alias properties. (The final duplicates elements of the
9543 # first.) A comment for it will later be constructed based on the
9544 # actual properties present and used
9545 $perl_charname = Property->new('Perl_Charnames',
9546 Core_Access => '\N{...} and "use charnames"',
9548 Directory => File::Spec->curdir(),
9550 Internal_Only_Warning => 1,
9551 Perl_Extension => 1,
9552 Range_Size_1 => \&output_perl_charnames_line,
9556 my $Perl_decomp = Property->new('Perl_Decomposition_Mapping',
9557 Directory => File::Spec->curdir(),
9558 File => 'Decomposition',
9559 Format => $DECOMP_STRING_FORMAT,
9560 Internal_Only_Warning => 1,
9561 Perl_Extension => 1,
9562 Default_Map => $CODE_POINT,
9564 # normalize.pm can't cope with these
9565 Output_Range_Counts => 0,
9567 # This is a specially formatted table
9568 # explicitly for normalize.pm, which
9569 # is expecting a particular format,
9570 # which means that mappings containing
9571 # multiple code points are in the main
9573 Map_Type => $COMPUTE_NO_MULTI_CP,
9576 $Perl_decomp->add_comment(join_lines(<<END
9577 This mapping is a combination of the Unicode 'Decomposition_Type' and
9578 'Decomposition_Mapping' properties, formatted for use by normalize.pm. It is
9579 identical to the official Unicode 'Decomposition_Mapping' property except for
9581 1) It omits the algorithmically determinable Hangul syllable decompositions,
9582 which normalize.pm handles algorithmically.
9583 2) It contains the decomposition type as well. Non-canonical decompositions
9584 begin with a word in angle brackets, like <super>, which denotes the
9585 compatible decomposition type. If the map does not begin with the <angle
9586 brackets>, the decomposition is canonical.
9590 my $Decimal_Digit = Property->new("Perl_Decimal_Digit",
9592 Perl_Extension => 1,
9593 File => 'Digit', # Trad. location
9594 Directory => $map_directory,
9598 $Decimal_Digit->add_comment(join_lines(<<END
9599 This file gives the mapping of all code points which represent a single
9600 decimal digit [0-9] to their respective digits. For example, the code point
9601 U+0031 (an ASCII '1') is mapped to a numeric 1. These code points are those
9602 that have Numeric_Type=Decimal; not special things, like subscripts nor Roman
9607 # These properties are not used for generating anything else, and are
9608 # usually not output. By making them last in the list, we can just
9609 # change the high end of the loop downwards to avoid the work of
9610 # generating a table(s) that is/are just going to get thrown away.
9611 if (! property_ref('Decomposition_Mapping')->to_output_map
9612 && ! property_ref('Name')->to_output_map)
9614 $last_field = min($NAME, $DECOMP_MAP) - 1;
9615 } elsif (property_ref('Decomposition_Mapping')->to_output_map) {
9616 $last_field = $DECOMP_MAP;
9617 } elsif (property_ref('Name')->to_output_map) {
9618 $last_field = $NAME;
9623 my $first_time = 1; # ? Is this the first line of the file
9624 my $in_range = 0; # ? Are we in one of the file's ranges
9625 my $previous_cp; # hex code point of previous line
9626 my $decimal_previous_cp = -1; # And its decimal equivalent
9627 my @start; # For each field, the current starting
9628 # code point in hex for the range
9629 # being accumulated.
9630 my @fields; # The input fields;
9631 my @previous_fields; # And those from the previous call
9633 sub filter_UnicodeData_line {
9634 # Handle a single input line from UnicodeData.txt; see comments above
9635 # Conceptually this takes a single line from the file containing N
9636 # properties, and converts it into N lines with one property per line,
9637 # which is what the final handler expects. But there are
9638 # complications due to the quirkiness of the input file, and to save
9639 # time, it accumulates ranges where the property values don't change
9640 # and only emits lines when necessary. This is about an order of
9641 # magnitude fewer lines emitted.
9644 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
9646 # $_ contains the input line.
9647 # -1 in split means retain trailing null fields
9648 (my $cp, @fields) = split /\s*;\s*/, $_, -1;
9650 #local $to_trace = 1 if main::DEBUG;
9651 trace $cp, @fields , $input_field_count if main::DEBUG && $to_trace;
9652 if (@fields > $input_field_count) {
9653 $file->carp_bad_line('Extra fields');
9658 my $decimal_cp = hex $cp;
9660 # We have to output all the buffered ranges when the next code point
9661 # is not exactly one after the previous one, which means there is a
9662 # gap in the ranges.
9663 my $force_output = ($decimal_cp != $decimal_previous_cp + 1);
9665 # The decomposition mapping field requires special handling. It looks
9668 # <compat> 0032 0020
9671 # The decomposition type is enclosed in <brackets>; if missing, it
9672 # means the type is canonical. There are two decomposition mapping
9673 # tables: the one for use by Perl's normalize.pm has a special format
9674 # which is this field intact; the other, for general use is of
9675 # standard format. In either case we have to find the decomposition
9676 # type. Empty fields have None as their type, and map to the code
9678 if ($fields[$PERL_DECOMPOSITION] eq "") {
9679 $fields[$DECOMP_TYPE] = 'None';
9680 $fields[$DECOMP_MAP] = $fields[$PERL_DECOMPOSITION] = $CODE_POINT;
9683 ($fields[$DECOMP_TYPE], my $map) = $fields[$PERL_DECOMPOSITION]
9684 =~ / < ( .+? ) > \s* ( .+ ) /x;
9685 if (! defined $fields[$DECOMP_TYPE]) {
9686 $fields[$DECOMP_TYPE] = 'Canonical';
9687 $fields[$DECOMP_MAP] = $fields[$PERL_DECOMPOSITION];
9690 $fields[$DECOMP_MAP] = $map;
9694 # The 3 numeric fields also require special handling. The 2 digit
9695 # fields must be either empty or match the number field. This means
9696 # that if it is empty, they must be as well, and the numeric type is
9697 # None, and the numeric value is 'Nan'.
9698 # The decimal digit field must be empty or match the other digit
9699 # field. If the decimal digit field is non-empty, the code point is
9700 # a decimal digit, and the other two fields will have the same value.
9701 # If it is empty, but the other digit field is non-empty, the code
9702 # point is an 'other digit', and the number field will have the same
9703 # value as the other digit field. If the other digit field is empty,
9704 # but the number field is non-empty, the code point is a generic
9706 if ($fields[$NUMERIC] eq "") {
9707 if ($fields[$PERL_DECIMAL_DIGIT] ne ""
9708 || $fields[$NUMERIC_TYPE_OTHER_DIGIT] ne ""
9710 $file->carp_bad_line("Numeric values inconsistent. Trying to process anyway");
9712 $fields[$NUMERIC_TYPE_OTHER_DIGIT] = 'None';
9713 $fields[$NUMERIC] = 'NaN';
9716 $file->carp_bad_line("'$fields[$NUMERIC]' should be a whole or rational number. Processing as if it were") if $fields[$NUMERIC] !~ qr{ ^ -? \d+ ( / \d+ )? $ }x;
9717 if ($fields[$PERL_DECIMAL_DIGIT] ne "") {
9718 $file->carp_bad_line("$fields[$PERL_DECIMAL_DIGIT] should equal $fields[$NUMERIC]. Processing anyway") if $fields[$PERL_DECIMAL_DIGIT] != $fields[$NUMERIC];
9719 $fields[$NUMERIC_TYPE_OTHER_DIGIT] = 'Decimal';
9721 elsif ($fields[$NUMERIC_TYPE_OTHER_DIGIT] ne "") {
9722 $file->carp_bad_line("$fields[$NUMERIC_TYPE_OTHER_DIGIT] should equal $fields[$NUMERIC]. Processing anyway") if $fields[$NUMERIC_TYPE_OTHER_DIGIT] != $fields[$NUMERIC];
9723 $fields[$NUMERIC_TYPE_OTHER_DIGIT] = 'Digit';
9726 $fields[$NUMERIC_TYPE_OTHER_DIGIT] = 'Numeric';
9728 # Rationals require extra effort.
9729 register_fraction($fields[$NUMERIC])
9730 if $fields[$NUMERIC] =~ qr{/};
9734 # For the properties that have empty fields in the file, and which
9735 # mean something different from empty, change them to that default.
9736 # Certain fields just haven't been empty so far in any Unicode
9737 # version, so don't look at those, namely $MIRRORED, $BIDI, $CCC,
9738 # $CATEGORY. This leaves just the two fields, and so we hard-code in
9739 # the defaults; which are very unlikely to ever change.
9740 $fields[$UPPER] = $CODE_POINT if $fields[$UPPER] eq "";
9741 $fields[$LOWER] = $CODE_POINT if $fields[$LOWER] eq "";
9743 # UAX44 says that if title is empty, it is the same as whatever upper
9745 $fields[$TITLE] = $fields[$UPPER] if $fields[$TITLE] eq "";
9747 # There are a few pairs of lines like:
9748 # AC00;<Hangul Syllable, First>;Lo;0;L;;;;;N;;;;;
9749 # D7A3;<Hangul Syllable, Last>;Lo;0;L;;;;;N;;;;;
9750 # that define ranges. These should be processed after the fields are
9751 # adjusted above, as they may override some of them; but mostly what
9752 # is left is to possibly adjust the $CHARNAME field. The names of all the
9753 # paired lines start with a '<', but this is also true of '<control>,
9754 # which isn't one of these special ones.
9755 if ($fields[$CHARNAME] eq '<control>') {
9757 # Some code points in this file have the pseudo-name
9758 # '<control>', but the official name for such ones is the null
9759 # string. For charnames.pm, we use the Unicode version 1 name
9760 $fields[$NAME] = "";
9761 $fields[$CHARNAME] = $fields[$UNICODE_1_NAME];
9763 # We had better not be in between range lines.
9765 $file->carp_bad_line("Expecting a closing range line, not a $fields[$CHARNAME]'. Trying anyway");
9769 elsif (substr($fields[$CHARNAME], 0, 1) ne '<') {
9771 # Here is a non-range line. We had better not be in between range
9774 $file->carp_bad_line("Expecting a closing range line, not a $fields[$CHARNAME]'. Trying anyway");
9777 if ($fields[$CHARNAME] =~ s/- $cp $//x) {
9779 # These are code points whose names end in their code points,
9780 # which means the names are algorithmically derivable from the
9781 # code points. To shorten the output Name file, the algorithm
9782 # for deriving these is placed in the file instead of each
9783 # code point, so they have map type $CP_IN_NAME
9784 $fields[$CHARNAME] = $CMD_DELIM
9789 . $fields[$CHARNAME];
9791 $fields[$NAME] = $fields[$CHARNAME];
9793 elsif ($fields[$CHARNAME] =~ /^<(.+), First>$/) {
9794 $fields[$CHARNAME] = $fields[$NAME] = $1;
9796 # Here we are at the beginning of a range pair.
9798 $file->carp_bad_line("Expecting a closing range line, not a beginning one, $fields[$CHARNAME]'. Trying anyway");
9802 # Because the properties in the range do not overwrite any already
9803 # in the db, we must flush the buffers of what's already there, so
9804 # they get handled in the normal scheme.
9808 elsif ($fields[$CHARNAME] !~ s/^<(.+), Last>$/$1/) {
9809 $file->carp_bad_line("Unexpected name starting with '<' $fields[$CHARNAME]. Ignoring this line.");
9813 else { # Here, we are at the last line of a range pair.
9816 $file->carp_bad_line("Unexpected end of range $fields[$CHARNAME] when not in one. Ignoring this line.");
9822 $fields[$NAME] = $fields[$CHARNAME];
9824 # Check that the input is valid: that the closing of the range is
9825 # the same as the beginning.
9826 foreach my $i (0 .. $last_field) {
9827 next if $fields[$i] eq $previous_fields[$i];
9828 $file->carp_bad_line("Expecting '$fields[$i]' to be the same as '$previous_fields[$i]'. Bad News. Trying anyway");
9831 # The processing differs depending on the type of range,
9832 # determined by its $CHARNAME
9833 if ($fields[$CHARNAME] =~ /^Hangul Syllable/) {
9835 # Check that the data looks right.
9836 if ($decimal_previous_cp != $SBase) {
9837 $file->carp_bad_line("Unexpected Hangul syllable start = $previous_cp. Bad News. Results will be wrong");
9839 if ($decimal_cp != $SBase + $SCount - 1) {
9840 $file->carp_bad_line("Unexpected Hangul syllable end = $cp. Bad News. Results will be wrong");
9843 # The Hangul syllable range has a somewhat complicated name
9844 # generation algorithm. Each code point in it has a canonical
9845 # decomposition also computable by an algorithm. The
9846 # perl decomposition map table built from these is used only
9847 # by normalize.pm, which has the algorithm built in it, so the
9848 # decomposition maps are not needed, and are large, so are
9849 # omitted from it. If the full decomposition map table is to
9850 # be output, the decompositions are generated for it, in the
9851 # EOF handling code for this input file.
9853 $previous_fields[$DECOMP_TYPE] = 'Canonical';
9855 # This range is stored in our internal structure with its
9856 # own map type, different from all others.
9857 $previous_fields[$CHARNAME] = $previous_fields[$NAME]
9863 . $fields[$CHARNAME];
9865 elsif ($fields[$CHARNAME] =~ /^CJK/) {
9867 # The name for these contains the code point itself, and all
9868 # are defined to have the same base name, regardless of what
9869 # is in the file. They are stored in our internal structure
9870 # with a map type of $CP_IN_NAME
9871 $previous_fields[$CHARNAME] = $previous_fields[$NAME]
9877 . 'CJK UNIFIED IDEOGRAPH';
9880 elsif ($fields[$CATEGORY] eq 'Co'
9881 || $fields[$CATEGORY] eq 'Cs')
9883 # The names of all the code points in these ranges are set to
9884 # null, as there are no names for the private use and
9885 # surrogate code points.
9887 $previous_fields[$CHARNAME] = $previous_fields[$NAME] = "";
9890 $file->carp_bad_line("Unexpected code point range $fields[$CHARNAME] because category is $fields[$CATEGORY]. Attempting to process it.");
9893 # The first line of the range caused everything else to be output,
9894 # and then its values were stored as the beginning values for the
9895 # next set of ranges, which this one ends. Now, for each value,
9896 # add a command to tell the handler that these values should not
9897 # replace any existing ones in our database.
9898 foreach my $i (0 .. $last_field) {
9899 $previous_fields[$i] = $CMD_DELIM
9904 . $previous_fields[$i];
9907 # And change things so it looks like the entire range has been
9908 # gone through with this being the final part of it. Adding the
9909 # command above to each field will cause this range to be flushed
9910 # during the next iteration, as it guaranteed that the stored
9911 # field won't match whatever value the next one has.
9913 $decimal_previous_cp = $decimal_cp;
9915 # We are now set up for the next iteration; so skip the remaining
9916 # code in this subroutine that does the same thing, but doesn't
9917 # know about these ranges.
9923 # On the very first line, we fake it so the code below thinks there is
9924 # nothing to output, and initialize so that when it does get output it
9925 # uses the first line's values for the lowest part of the range.
9926 # (One could avoid this by using peek(), but then one would need to
9927 # know the adjustments done above and do the same ones in the setup
9928 # routine; not worth it)
9931 @previous_fields = @fields;
9932 @start = ($cp) x scalar @fields;
9933 $decimal_previous_cp = $decimal_cp - 1;
9936 # For each field, output the stored up ranges that this code point
9937 # doesn't fit in. Earlier we figured out if all ranges should be
9938 # terminated because of changing the replace or map type styles, or if
9939 # there is a gap between this new code point and the previous one, and
9940 # that is stored in $force_output. But even if those aren't true, we
9941 # need to output the range if this new code point's value for the
9942 # given property doesn't match the stored range's.
9943 #local $to_trace = 1 if main::DEBUG;
9944 foreach my $i (0 .. $last_field) {
9945 my $field = $fields[$i];
9946 if ($force_output || $field ne $previous_fields[$i]) {
9948 # Flush the buffer of stored values.
9949 $file->insert_adjusted_lines("$start[$i]..$previous_cp; $field_names[$i]; $previous_fields[$i]");
9951 # Start a new range with this code point and its value
9953 $previous_fields[$i] = $field;
9957 # Set the values for the next time.
9959 $decimal_previous_cp = $decimal_cp;
9961 # The input line has generated whatever adjusted lines are needed, and
9962 # should not be looked at further.
9967 sub EOF_UnicodeData {
9968 # Called upon EOF to flush the buffers, and create the Hangul
9969 # decomposition mappings if needed.
9972 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
9974 # Flush the buffers.
9975 foreach my $i (1 .. $last_field) {
9976 $file->insert_adjusted_lines("$start[$i]..$previous_cp; $field_names[$i]; $previous_fields[$i]");
9979 if (-e 'Jamo.txt') {
9981 # The algorithm is published by Unicode, based on values in
9982 # Jamo.txt, (which should have been processed before this
9983 # subroutine), and the results left in %Jamo
9985 Carp::my_carp_bug("Jamo.txt should be processed before Unicode.txt. Hangul syllables not generated.");
9989 # If the full decomposition map table is being output, insert
9990 # into it the Hangul syllable mappings. This is to avoid having
9991 # to publish a subroutine in it to compute them. (which would
9992 # essentially be this code.) This uses the algorithm published by
9994 if (property_ref('Decomposition_Mapping')->to_output_map) {
9995 for (my $S = $SBase; $S < $SBase + $SCount; $S++) {
9997 my $SIndex = $S - $SBase;
9998 my $L = $LBase + $SIndex / $NCount;
9999 my $V = $VBase + ($SIndex % $NCount) / $TCount;
10000 my $T = $TBase + $SIndex % $TCount;
10002 trace "L=$L, V=$V, T=$T" if main::DEBUG && $to_trace;
10003 my $decomposition = sprintf("%04X %04X", $L, $V);
10004 $decomposition .= sprintf(" %04X", $T) if $T != $TBase;
10005 $file->insert_adjusted_lines(
10006 sprintf("%04X; Decomposition_Mapping; %s",
10016 sub filter_v1_ucd {
10017 # Fix UCD lines in version 1. This is probably overkill, but this
10018 # fixes some glaring errors in Version 1 UnicodeData.txt. That file:
10019 # 1) had many Hangul (U+3400 - U+4DFF) code points that were later
10020 # removed. This program retains them
10021 # 2) didn't include ranges, which it should have, and which are now
10022 # added in @corrected_lines below. It was hand populated by
10023 # taking the data from Version 2, verified by analyzing
10025 # 3) There is a syntax error in the entry for U+09F8 which could
10026 # cause problems for utf8_heavy, and so is changed. It's
10027 # numeric value was simply a minus sign, without any number.
10028 # (Eventually Unicode changed the code point to non-numeric.)
10029 # 4) The decomposition types often don't match later versions
10030 # exactly, and the whole syntax of that field is different; so
10031 # the syntax is changed as well as the types to their later
10032 # terminology. Otherwise normalize.pm would be very unhappy
10033 # 5) Many ccc classes are different. These are left intact.
10034 # 6) U+FF10 - U+FF19 are missing their numeric values in all three
10035 # fields. These are unchanged because it doesn't really cause
10036 # problems for Perl.
10037 # 7) A number of code points, such as controls, don't have their
10038 # Unicode Version 1 Names in this file. These are unchanged.
10040 my @corrected_lines = split /\n/, <<'END';
10041 4E00;<CJK Ideograph, First>;Lo;0;L;;;;;N;;;;;
10042 9FA5;<CJK Ideograph, Last>;Lo;0;L;;;;;N;;;;;
10043 E000;<Private Use, First>;Co;0;L;;;;;N;;;;;
10044 F8FF;<Private Use, Last>;Co;0;L;;;;;N;;;;;
10045 F900;<CJK Compatibility Ideograph, First>;Lo;0;L;;;;;N;;;;;
10046 FA2D;<CJK Compatibility Ideograph, Last>;Lo;0;L;;;;;N;;;;;
10050 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10052 #local $to_trace = 1 if main::DEBUG;
10053 trace $_ if main::DEBUG && $to_trace;
10055 # -1 => retain trailing null fields
10056 my ($code_point, @fields) = split /\s*;\s*/, $_, -1;
10058 # At the first place that is wrong in the input, insert all the
10059 # corrections, replacing the wrong line.
10060 if ($code_point eq '4E00') {
10061 my @copy = @corrected_lines;
10063 ($code_point, @fields) = split /\s*;\s*/, $_, -1;
10065 $file->insert_lines(@copy);
10069 if ($fields[$NUMERIC] eq '-') {
10070 $fields[$NUMERIC] = '-1'; # This is what 2.0 made it.
10073 if ($fields[$PERL_DECOMPOSITION] ne "") {
10075 # Several entries have this change to superscript 2 or 3 in the
10076 # middle. Convert these to the modern version, which is to use
10077 # the actual U+00B2 and U+00B3 (the superscript forms) instead.
10078 # So 'HHHH HHHH <+sup> 0033 <-sup> HHHH' becomes
10079 # 'HHHH HHHH 00B3 HHHH'.
10080 # It turns out that all of these that don't have another
10081 # decomposition defined at the beginning of the line have the
10082 # <square> decomposition in later releases.
10083 if ($code_point ne '00B2' && $code_point ne '00B3') {
10084 if ($fields[$PERL_DECOMPOSITION]
10085 =~ s/<\+sup> 003([23]) <-sup>/00B$1/)
10087 if (substr($fields[$PERL_DECOMPOSITION], 0, 1) ne '<') {
10088 $fields[$PERL_DECOMPOSITION] = '<square> '
10089 . $fields[$PERL_DECOMPOSITION];
10094 # If is like '<+circled> 0052 <-circled>', convert to
10096 $fields[$PERL_DECOMPOSITION] =~
10097 s/ < \+ ( .*? ) > \s* (.*?) \s* <-\1> /<$1> $2/x;
10099 # Convert '<join> HHHH HHHH <join>' to '<medial> HHHH HHHH', etc.
10100 $fields[$PERL_DECOMPOSITION] =~
10101 s/ <join> \s* (.*?) \s* <no-join> /<final> $1/x
10102 or $fields[$PERL_DECOMPOSITION] =~
10103 s/ <join> \s* (.*?) \s* <join> /<medial> $1/x
10104 or $fields[$PERL_DECOMPOSITION] =~
10105 s/ <no-join> \s* (.*?) \s* <join> /<initial> $1/x
10106 or $fields[$PERL_DECOMPOSITION] =~
10107 s/ <no-join> \s* (.*?) \s* <no-join> /<isolated> $1/x;
10109 # Convert '<break> HHHH HHHH <break>' to '<break> HHHH', etc.
10110 $fields[$PERL_DECOMPOSITION] =~
10111 s/ <(break|no-break)> \s* (.*?) \s* <\1> /<$1> $2/x;
10113 # Change names to modern form.
10114 $fields[$PERL_DECOMPOSITION] =~ s/<font variant>/<font>/g;
10115 $fields[$PERL_DECOMPOSITION] =~ s/<no-break>/<noBreak>/g;
10116 $fields[$PERL_DECOMPOSITION] =~ s/<circled>/<circle>/g;
10117 $fields[$PERL_DECOMPOSITION] =~ s/<break>/<fraction>/g;
10119 # One entry has weird braces
10120 $fields[$PERL_DECOMPOSITION] =~ s/[{}]//g;
10123 $_ = join ';', $code_point, @fields;
10124 trace $_ if main::DEBUG && $to_trace;
10128 sub filter_v2_1_5_ucd {
10129 # A dozen entries in this 2.1.5 file had the mirrored and numeric
10130 # columns swapped; These all had mirrored be 'N'. So if the numeric
10131 # column appears to be N, swap it back.
10133 my ($code_point, @fields) = split /\s*;\s*/, $_, -1;
10134 if ($fields[$NUMERIC] eq 'N') {
10135 $fields[$NUMERIC] = $fields[$MIRRORED];
10136 $fields[$MIRRORED] = 'N';
10137 $_ = join ';', $code_point, @fields;
10141 } # End closure for UnicodeData
10143 sub process_GCB_test {
10146 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10148 while ($file->next_line) {
10149 push @backslash_X_tests, $_;
10155 sub process_NamedSequences {
10156 # NamedSequences.txt entries are just added to an array. Because these
10157 # don't look like the other tables, they have their own handler.
10159 # LATIN CAPITAL LETTER A WITH MACRON AND GRAVE;0100 0300
10161 # This just adds the sequence to an array for later handling
10164 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10166 while ($file->next_line) {
10167 my ($name, $sequence, @remainder) = split /\s*;\s*/, $_, -1;
10169 $file->carp_bad_line(
10170 "Doesn't look like 'KHMER VOWEL SIGN OM;17BB 17C6'");
10174 # Note single \t in keeping with special output format of
10175 # Perl_charnames. But it turns out that the code points don't have to
10176 # be 5 digits long, like the rest, based on the internal workings of
10177 # charnames.pm. This could be easily changed for consistency.
10178 push @named_sequences, "$sequence\t$name";
10187 sub filter_early_ea_lb {
10188 # Fixes early EastAsianWidth.txt and LineBreak.txt files. These had a
10189 # third field be the name of the code point, which can be ignored in
10190 # most cases. But it can be meaningful if it marks a range:
10191 # 33FE;W;IDEOGRAPHIC TELEGRAPH SYMBOL FOR DAY THIRTY-ONE
10192 # 3400;W;<CJK Ideograph Extension A, First>
10194 # We need to see the First in the example above to know it's a range.
10195 # They did not use the later range syntaxes. This routine changes it
10196 # to use the modern syntax.
10197 # $1 is the Input_file object.
10199 my @fields = split /\s*;\s*/;
10200 if ($fields[2] =~ /^<.*, First>/) {
10201 $first_range = $fields[0];
10204 elsif ($fields[2] =~ /^<.*, Last>/) {
10205 $_ = $_ = "$first_range..$fields[0]; $fields[1]";
10208 undef $first_range;
10209 $_ = "$fields[0]; $fields[1]";
10216 sub filter_old_style_arabic_shaping {
10217 # Early versions used a different term for the later one.
10219 my @fields = split /\s*;\s*/;
10220 $fields[3] =~ s/<no shaping>/No_Joining_Group/;
10221 $fields[3] =~ s/\s+/_/g; # Change spaces to underscores
10222 $_ = join ';', @fields;
10226 sub filter_arabic_shaping_line {
10227 # ArabicShaping.txt has entries that look like:
10228 # 062A; TEH; D; BEH
10229 # The field containing 'TEH' is not used. The next field is Joining_Type
10230 # and the last is Joining_Group
10231 # This generates two lines to pass on, one for each property on the input
10235 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10237 my @fields = split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields
10240 $file->carp_bad_line('Extra fields');
10245 $file->insert_adjusted_lines("$fields[0]; Joining_Group; $fields[3]");
10246 $_ = "$fields[0]; Joining_Type; $fields[2]";
10251 sub setup_special_casing {
10252 # SpecialCasing.txt contains the non-simple case change mappings. The
10253 # simple ones are in UnicodeData.txt, which should already have been read
10254 # in to the full property data structures, so as to initialize these with
10255 # the simple ones. Then the SpecialCasing.txt entries overwrite the ones
10256 # which have different full mappings.
10258 # This routine sees if the simple mappings are to be output, and if so,
10259 # copies what has already been put into the full mapping tables, while
10260 # they still contain only the simple mappings.
10262 # The reason it is done this way is that the simple mappings are probably
10263 # not going to be output, so it saves work to initialize the full tables
10264 # with the simple mappings, and then overwrite those relatively few
10265 # entries in them that have different full mappings, and thus skip the
10266 # simple mapping tables altogether.
10269 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10271 # For each of the case change mappings...
10272 foreach my $case ('lc', 'tc', 'uc') {
10273 my $full = property_ref($case);
10274 unless (defined $full && ! $full->is_empty) {
10275 Carp::my_carp_bug("Need to process UnicodeData before SpecialCasing. Only special casing will be generated.");
10278 # The simple version's name in each mapping merely has an 's' in front
10279 # of the full one's
10280 my $simple = property_ref('s' . $case);
10281 $simple->initialize($full) if $simple->to_output_map();
10287 sub filter_special_casing_line {
10288 # Change the format of $_ from SpecialCasing.txt into something that the
10289 # generic handler understands. Each input line contains three case
10290 # mappings. This will generate three lines to pass to the generic handler
10291 # for each of those.
10293 # The input syntax (after stripping comments and trailing white space is
10294 # like one of the following (with the final two being entries that we
10296 # 00DF; 00DF; 0053 0073; 0053 0053; # LATIN SMALL LETTER SHARP S
10297 # 03A3; 03C2; 03A3; 03A3; Final_Sigma;
10298 # 0307; ; 0307; 0307; tr After_I; # COMBINING DOT ABOVE
10299 # Note the trailing semi-colon, unlike many of the input files. That
10300 # means that there will be an extra null field generated by the split
10303 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10305 my @fields = split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields
10307 # field #4 is when this mapping is conditional. If any of these get
10308 # implemented, it would be by hard-coding in the casing functions in the
10309 # Perl core, not through tables. But if there is a new condition we don't
10310 # know about, output a warning. We know about all the conditions through
10312 if ($fields[4] ne "") {
10313 my @conditions = split ' ', $fields[4];
10314 if ($conditions[0] ne 'tr' # We know that these languages have
10315 # conditions, and some are multiple
10316 && $conditions[0] ne 'az'
10317 && $conditions[0] ne 'lt'
10319 # And, we know about a single condition Final_Sigma, but
10321 && ($v_version gt v5.2.0
10322 && (@conditions > 1 || $conditions[0] ne 'Final_Sigma')))
10324 $file->carp_bad_line("Unknown condition '$fields[4]'. You should inspect it and either add code to handle it, or add to list of those that are to ignore");
10326 elsif ($conditions[0] ne 'Final_Sigma') {
10328 # Don't print out a message for Final_Sigma, because we have
10329 # hard-coded handling for it. (But the standard could change
10330 # what the rule should be, but it wouldn't show up here
10333 print "# SKIPPING Special Casing: $_\n"
10334 if $verbosity >= $VERBOSE;
10339 elsif (@fields > 6 || (@fields == 6 && $fields[5] ne "" )) {
10340 $file->carp_bad_line('Extra fields');
10345 $_ = "$fields[0]; lc; $fields[1]";
10346 $file->insert_adjusted_lines("$fields[0]; tc; $fields[2]");
10347 $file->insert_adjusted_lines("$fields[0]; uc; $fields[3]");
10352 sub filter_old_style_case_folding {
10353 # This transforms $_ containing the case folding style of 3.0.1, to 3.1
10354 # and later style. Different letters were used in the earlier.
10357 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10359 my @fields = split /\s*;\s*/;
10360 if ($fields[0] =~ /^ 013 [01] $/x) { # The two turkish fields
10363 elsif ($fields[1] eq 'L') {
10364 $fields[1] = 'C'; # L => C always
10366 elsif ($fields[1] eq 'E') {
10367 if ($fields[2] =~ / /) { # E => C if one code point; F otherwise
10375 $file->carp_bad_line("Expecting L or E in second field");
10379 $_ = join("; ", @fields) . ';';
10383 { # Closure for case folding
10385 # Create the map for simple only if are going to output it, for otherwise
10386 # it takes no part in anything we do.
10387 my $to_output_simple;
10390 # These are experimental, perhaps will need these to pass to regcomp.c to
10391 # handle the cases where for example the Kelvin sign character folds to k,
10392 # and in regcomp, we need to know which of the characters can have a
10393 # non-latin1 char fold to it, so it doesn't do the optimizations it might
10395 my @latin1_singly_folded;
10398 sub setup_case_folding($) {
10399 # Read in the case foldings in CaseFolding.txt. This handles both
10400 # simple and full case folding.
10403 = property_ref('Simple_Case_Folding')->to_output_map;
10408 sub filter_case_folding_line {
10409 # Called for each line in CaseFolding.txt
10410 # Input lines look like:
10411 # 0041; C; 0061; # LATIN CAPITAL LETTER A
10412 # 00DF; F; 0073 0073; # LATIN SMALL LETTER SHARP S
10413 # 1E9E; S; 00DF; # LATIN CAPITAL LETTER SHARP S
10415 # 'C' means that folding is the same for both simple and full
10416 # 'F' that it is only for full folding
10417 # 'S' that it is only for simple folding
10418 # 'T' is locale-dependent, and ignored
10419 # 'I' is a type of 'F' used in some early releases.
10420 # Note the trailing semi-colon, unlike many of the input files. That
10421 # means that there will be an extra null field generated by the split
10422 # below, which we ignore and hence is not an error.
10425 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10427 my ($range, $type, $map, @remainder) = split /\s*;\s*/, $_, -1;
10428 if (@remainder > 1 || (@remainder == 1 && $remainder[0] ne "" )) {
10429 $file->carp_bad_line('Extra fields');
10434 if ($type eq 'T') { # Skip Turkic case folding, is locale dependent
10439 # C: complete, F: full, or I: dotted uppercase I -> dotless lowercase
10440 # I are all full foldings
10441 if ($type eq 'C' || $type eq 'F' || $type eq 'I') {
10442 $_ = "$range; Case_Folding; $map";
10446 if ($type ne 'S') {
10447 $file->carp_bad_line('Expecting C F I S or T in second field');
10452 # C and S are simple foldings, but simple case folding is not needed
10453 # unless we explicitly want its map table output.
10454 if ($to_output_simple && $type eq 'C' || $type eq 'S') {
10455 $file->insert_adjusted_lines("$range; Simple_Case_Folding; $map");
10458 # XXX Experimental, see comment above
10459 if ($type ne 'S' && hex($range) >= 256) { # assumes range is 1 point
10460 my @folded = split ' ', $map;
10461 if (hex $folded[0] < 256 && @folded == 1) {
10462 push @latin1_singly_folded, hex $folded[0];
10464 foreach my $folded (@folded) {
10465 push @latin1_folded, hex $folded if hex $folded < 256;
10473 # XXX Experimental, see comment above
10476 #local $to_trace = 1 if main::DEBUG;
10477 @latin1_singly_folded = uniques(@latin1_singly_folded);
10478 @latin1_folded = uniques(@latin1_folded);
10479 trace "latin1 single folded:", map { chr $_ } sort { $a <=> $b } @latin1_singly_folded if main::DEBUG && $to_trace;
10480 trace "latin1 folded:", map { chr $_ } sort { $a <=> $b } @latin1_folded if main::DEBUG && $to_trace;
10483 } # End case fold closure
10485 sub filter_jamo_line {
10486 # Filter Jamo.txt lines. This routine mainly is used to populate hashes
10487 # from this file that is used in generating the Name property for Jamo
10488 # code points. But, it also is used to convert early versions' syntax
10489 # into the modern form. Here are two examples:
10490 # 1100; G # HANGUL CHOSEONG KIYEOK # Modern syntax
10491 # U+1100; G; HANGUL CHOSEONG KIYEOK # 2.0 syntax
10493 # The input is $_, the output is $_ filtered.
10495 my @fields = split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields
10497 # Let the caller handle unexpected input. In earlier versions, there was
10498 # a third field which is supposed to be a comment, but did not have a '#'
10500 return if @fields > (($v_version gt v3.0.0) ? 2 : 3);
10502 $fields[0] =~ s/^U\+//; # Also, early versions had this extraneous
10505 # Some 2.1 versions had this wrong. Causes havoc with the algorithm.
10506 $fields[1] = 'R' if $fields[0] eq '1105';
10508 # Add to structure so can generate Names from it.
10509 my $cp = hex $fields[0];
10510 my $short_name = $fields[1];
10511 $Jamo{$cp} = $short_name;
10512 if ($cp <= $LBase + $LCount) {
10513 $Jamo_L{$short_name} = $cp - $LBase;
10515 elsif ($cp <= $VBase + $VCount) {
10516 $Jamo_V{$short_name} = $cp - $VBase;
10518 elsif ($cp <= $TBase + $TCount) {
10519 $Jamo_T{$short_name} = $cp - $TBase;
10522 Carp::my_carp_bug("Unexpected Jamo code point in $_");
10526 # Reassemble using just the first two fields to look like a typical
10527 # property file line
10528 $_ = "$fields[0]; $fields[1]";
10533 sub register_fraction($) {
10534 # This registers the input rational number so that it can be passed on to
10535 # utf8_heavy.pl, both in rational and floating forms.
10537 my $rational = shift;
10539 my $float = eval $rational;
10540 $nv_floating_to_rational{$float} = $rational;
10544 sub filter_numeric_value_line {
10545 # DNumValues contains lines of a different syntax than the typical
10547 # 0F33 ; -0.5 ; ; -1/2 # No TIBETAN DIGIT HALF ZERO
10549 # This routine transforms $_ containing the anomalous syntax to the
10550 # typical, by filtering out the extra columns, and convert early version
10551 # decimal numbers to strings that look like rational numbers.
10554 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10556 # Starting in 5.1, there is a rational field. Just use that, omitting the
10557 # extra columns. Otherwise convert the decimal number in the second field
10558 # to a rational, and omit extraneous columns.
10559 my @fields = split /\s*;\s*/, $_, -1;
10562 if ($v_version ge v5.1.0) {
10563 if (@fields != 4) {
10564 $file->carp_bad_line('Not 4 semi-colon separated fields');
10568 $rational = $fields[3];
10569 $_ = join '; ', @fields[ 0, 3 ];
10573 # Here, is an older Unicode file, which has decimal numbers instead of
10574 # rationals in it. Use the fraction to calculate the denominator and
10575 # convert to rational.
10577 if (@fields != 2 && @fields != 3) {
10578 $file->carp_bad_line('Not 2 or 3 semi-colon separated fields');
10583 my $codepoints = $fields[0];
10584 my $decimal = $fields[1];
10585 if ($decimal =~ s/\.0+$//) {
10587 # Anything ending with a decimal followed by nothing but 0's is an
10589 $_ = "$codepoints; $decimal";
10590 $rational = $decimal;
10595 if ($decimal =~ /\.50*$/) {
10599 # Here have the hardcoded repeating decimals in the fraction, and
10600 # the denominator they imply. There were only a few denominators
10601 # in the older Unicode versions of this file which this code
10602 # handles, so it is easy to convert them.
10604 # The 4 is because of a round-off error in the Unicode 3.2 files
10605 elsif ($decimal =~ /\.33*[34]$/ || $decimal =~ /\.6+7$/) {
10608 elsif ($decimal =~ /\.[27]50*$/) {
10611 elsif ($decimal =~ /\.[2468]0*$/) {
10614 elsif ($decimal =~ /\.16+7$/ || $decimal =~ /\.83+$/) {
10617 elsif ($decimal =~ /\.(12|37|62|87)50*$/) {
10620 if ($denominator) {
10621 my $sign = ($decimal < 0) ? "-" : "";
10622 my $numerator = int((abs($decimal) * $denominator) + .5);
10623 $rational = "$sign$numerator/$denominator";
10624 $_ = "$codepoints; $rational";
10627 $file->carp_bad_line("Can't cope with number '$decimal'.");
10634 register_fraction($rational) if $rational =~ qr{/};
10639 my %unihan_properties;
10644 # Do any special setup for Unihan properties.
10646 # This property gives the wrong computed type, so override.
10647 my $usource = property_ref('kIRG_USource');
10648 $usource->set_type($STRING) if defined $usource;
10650 # This property is to be considered binary, so change all the values
10652 $iicore = property_ref('kIICore');
10653 if (defined $iicore) {
10654 $iicore->add_match_table('Y') if ! defined $iicore->table('Y');
10656 # We have to change the default map, because the @missing line is
10657 # misleading, given that we are treating it as binary.
10658 $iicore->set_default_map('N');
10659 $iicore->set_type($BINARY);
10665 sub filter_unihan_line {
10666 # Change unihan db lines to look like the others in the db. Here is
10668 # U+341C kCangjie IEKN
10670 # Tabs are used instead of semi-colons to separate fields; therefore
10671 # they may have semi-colons embedded in them. Change these to periods
10672 # so won't screw up the rest of the code.
10675 # Remove lines that don't look like ones we accept.
10676 if ($_ !~ /^ [^\t]* \t ( [^\t]* ) /x) {
10681 # Extract the property, and save a reference to its object.
10683 if (! exists $unihan_properties{$property}) {
10684 $unihan_properties{$property} = property_ref($property);
10687 # Don't do anything unless the property is one we're handling, which
10688 # we determine by seeing if there is an object defined for it or not
10689 if (! defined $unihan_properties{$property}) {
10694 # The iicore property is supposed to be a boolean, so convert to our
10695 # standard boolean form.
10696 if (defined $iicore && $unihan_properties{$property} == $iicore) {
10697 $_ =~ s/$property.*/$property\tY/
10700 # Convert the tab separators to our standard semi-colons, and convert
10701 # the U+HHHH notation to the rest of the standard's HHHH
10703 s/\b U \+ (?= $code_point_re )//xg;
10705 #local $to_trace = 1 if main::DEBUG;
10706 trace $_ if main::DEBUG && $to_trace;
10712 sub filter_blocks_lines {
10713 # In the Blocks.txt file, the names of the blocks don't quite match the
10714 # names given in PropertyValueAliases.txt, so this changes them so they
10715 # do match: Blanks and hyphens are changed into underscores. Also makes
10716 # early release versions look like later ones
10718 # $_ is transformed to the correct value.
10721 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10723 if ($v_version lt v3.2.0) {
10724 if (/FEFF.*Specials/) { # Bug in old versions: line wrongly inserted
10729 # Old versions used a different syntax to mark the range.
10730 $_ =~ s/;\s+/../ if $v_version lt v3.1.0;
10733 my @fields = split /\s*;\s*/, $_, -1;
10734 if (@fields != 2) {
10735 $file->carp_bad_line("Expecting exactly two fields");
10740 # Change hyphens and blanks in the block name field only
10741 $fields[1] =~ s/[ -]/_/g;
10742 $fields[1] =~ s/_ ( [a-z] ) /_\u$1/g; # Capitalize first letter of word
10744 $_ = join("; ", @fields);
10749 my $current_property;
10751 sub filter_old_style_proplist {
10752 # PropList.txt has been in Unicode since version 2.0. Until 3.1, it
10753 # was in a completely different syntax. Ken Whistler of Unicode says
10754 # that it was something he used as an aid for his own purposes, but
10755 # was never an official part of the standard. However, comments in
10756 # DAge.txt indicate that non-character code points were available in
10757 # the UCD as of 3.1. It is unclear to me (khw) how they could be
10758 # there except through this file (but on the other hand, they first
10759 # appeared there in 3.0.1), so maybe it was part of the UCD, and maybe
10760 # not. But the claim is that it was published as an aid to others who
10761 # might want some more information than was given in the official UCD
10762 # of the time. Many of the properties in it were incorporated into
10763 # the later PropList.txt, but some were not. This program uses this
10764 # early file to generate property tables that are otherwise not
10765 # accessible in the early UCD's, and most were probably not really
10766 # official at that time, so one could argue that it should be ignored,
10767 # and you can easily modify things to skip this. And there are bugs
10768 # in this file in various versions. (For example, the 2.1.9 version
10769 # removes from Alphabetic the CJK range starting at 4E00, and they
10770 # weren't added back in until 3.1.0.) Many of this file's properties
10771 # were later sanctioned, so this code generates tables for those
10772 # properties that aren't otherwise in the UCD of the time but
10773 # eventually did become official, and throws away the rest. Here is a
10774 # list of all the ones that are thrown away:
10775 # Bidi=* duplicates UnicodeData.txt
10776 # Combining never made into official property;
10778 # Composite never made into official property.
10779 # Currency Symbol duplicates UnicodeData.txt: gc=sc
10780 # Decimal Digit duplicates UnicodeData.txt: gc=nd
10781 # Delimiter never made into official property;
10783 # Format Control never made into official property;
10785 # High Surrogate duplicates Blocks.txt
10786 # Ignorable Control never made into official property;
10788 # ISO Control duplicates UnicodeData.txt: gc=cc
10789 # Left of Pair never made into official property;
10790 # Line Separator duplicates UnicodeData.txt: gc=zl
10791 # Low Surrogate duplicates Blocks.txt
10792 # Non-break was actually listed as a property
10793 # in 3.2, but without any code
10794 # points. Unicode denies that this
10795 # was ever an official property
10796 # Non-spacing duplicate UnicodeData.txt: gc=mn
10797 # Numeric duplicates UnicodeData.txt: gc=cc
10798 # Paired Punctuation never made into official property;
10799 # appears to be gc=ps + gc=pe
10800 # Paragraph Separator duplicates UnicodeData.txt: gc=cc
10801 # Private Use duplicates UnicodeData.txt: gc=co
10802 # Private Use High Surrogate duplicates Blocks.txt
10803 # Punctuation duplicates UnicodeData.txt: gc=p
10804 # Space different definition than eventual
10806 # Titlecase duplicates UnicodeData.txt: gc=lt
10807 # Unassigned Code Value duplicates UnicodeData.txt: gc=cc
10808 # Zero-width never made into offical property;
10810 # Most of the properties have the same names in this file as in later
10811 # versions, but a couple do not.
10813 # This subroutine filters $_, converting it from the old style into
10814 # the new style. Here's a sample of the old-style
10816 # *******************************************
10818 # Property dump for: 0x100000A0 (Join Control)
10820 # 200C..200D (2 chars)
10822 # In the example, the property is "Join Control". It is kept in this
10823 # closure between calls to the subroutine. The numbers beginning with
10824 # 0x were internal to Ken's program that generated this file.
10826 # If this line contains the property name, extract it.
10827 if (/^Property dump for: [^(]*\((.*)\)/) {
10830 # Convert white space to underscores.
10833 # Convert the few properties that don't have the same name as
10834 # their modern counterparts
10835 s/Identifier_Part/ID_Continue/
10836 or s/Not_a_Character/NChar/;
10838 # If the name matches an existing property, use it.
10839 if (defined property_ref($_)) {
10840 trace "new property=", $_ if main::DEBUG && $to_trace;
10841 $current_property = $_;
10843 else { # Otherwise discard it
10844 trace "rejected property=", $_ if main::DEBUG && $to_trace;
10845 undef $current_property;
10847 $_ = ""; # The property is saved for the next lines of the
10848 # file, but this defining line is of no further use,
10849 # so clear it so that the caller won't process it
10852 elsif (! defined $current_property || $_ !~ /^$code_point_re/) {
10854 # Here, the input line isn't a header defining a property for the
10855 # following section, and either we aren't in such a section, or
10856 # the line doesn't look like one that defines the code points in
10857 # such a section. Ignore this line.
10862 # Here, we have a line defining the code points for the current
10863 # stashed property. Anything starting with the first blank is
10864 # extraneous. Otherwise, it should look like a normal range to
10865 # the caller. Append the property name so that it looks just like
10866 # a modern PropList entry.
10869 $_ .= "; $current_property";
10871 trace $_ if main::DEBUG && $to_trace;
10874 } # End closure for old style proplist
10876 sub filter_old_style_normalization_lines {
10877 # For early releases of Unicode, the lines were like:
10878 # 74..2A76 ; NFKD_NO
10879 # For later releases this became:
10880 # 74..2A76 ; NFKD_QC; N
10881 # Filter $_ to look like those in later releases.
10882 # Similarly for MAYBEs
10884 s/ _NO \b /_QC; N/x || s/ _MAYBE \b /_QC; M/x;
10886 # Also, the property FC_NFKC was abbreviated to FNC
10891 sub finish_Unicode() {
10892 # This routine should be called after all the Unicode files have been read
10894 # 1) Adds the mappings for code points missing from the files which have
10895 # defaults specified for them.
10896 # 2) At this this point all mappings are known, so it computes the type of
10897 # each property whose type hasn't been determined yet.
10898 # 3) Calculates all the regular expression match tables based on the
10900 # 3) Calculates and adds the tables which are defined by Unicode, but
10901 # which aren't derived by them
10903 # For each property, fill in any missing mappings, and calculate the re
10904 # match tables. If a property has more than one missing mapping, the
10905 # default is a reference to a data structure, and requires data from other
10906 # properties to resolve. The sort is used to cause these to be processed
10907 # last, after all the other properties have been calculated.
10908 # (Fortunately, the missing properties so far don't depend on each other.)
10909 foreach my $property
10910 (sort { (defined $a->default_map && ref $a->default_map) ? 1 : -1 }
10913 # $perl has been defined, but isn't one of the Unicode properties that
10914 # need to be finished up.
10915 next if $property == $perl;
10917 # Handle the properties that have more than one possible default
10918 if (ref $property->default_map) {
10919 my $default_map = $property->default_map;
10921 # These properties have stored in the default_map:
10923 # 1) A default map which applies to all code points in a
10925 # 2) an expression which will evaluate to the list of code
10926 # points in that class
10928 # 3) the default map which applies to every other missing code
10931 # Go through each list.
10932 while (my ($default, $eval) = $default_map->get_next_defaults) {
10934 # Get the class list, and intersect it with all the so-far
10935 # unspecified code points yielding all the code points
10936 # in the class that haven't been specified.
10937 my $list = eval $eval;
10939 Carp::my_carp("Can't set some defaults for missing code points for $property because eval '$eval' failed with '$@'");
10943 # Narrow down the list to just those code points we don't have
10945 $list = $list & $property->inverse_list;
10947 # Add mappings to the property for each code point in the list
10948 foreach my $range ($list->ranges) {
10949 $property->add_map($range->start, $range->end, $default);
10953 # All remaining code points have the other mapping. Set that up
10954 # so the normal single-default mapping code will work on them
10955 $property->set_default_map($default_map->other_default);
10957 # And fall through to do that
10960 # We should have enough data now to compute the type of the property.
10961 $property->compute_type;
10962 my $property_type = $property->type;
10964 next if ! $property->to_create_match_tables;
10966 # Here want to create match tables for this property
10968 # The Unicode db always (so far, and they claim into the future) have
10969 # the default for missing entries in binary properties be 'N' (unless
10970 # there is a '@missing' line that specifies otherwise)
10971 if ($property_type == $BINARY && ! defined $property->default_map) {
10972 $property->set_default_map('N');
10975 # Add any remaining code points to the mapping, using the default for
10976 # missing code points
10977 if (defined (my $default_map = $property->default_map)) {
10978 foreach my $range ($property->inverse_list->ranges) {
10979 $property->add_map($range->start, $range->end, $default_map);
10982 # Make sure there is a match table for the default
10983 if (! defined $property->table($default_map)) {
10984 $property->add_match_table($default_map);
10988 # Have all we need to populate the match tables.
10989 my $property_name = $property->name;
10990 foreach my $range ($property->ranges) {
10991 my $map = $range->value;
10992 my $table = property_ref($property_name)->table($map);
10993 if (! defined $table) {
10995 # Integral and rational property values are not necessarily
10996 # defined in PropValueAliases, but all other ones should be,
10998 if ($v_version ge v5.1.0
10999 && $map !~ /^ -? \d+ ( \/ \d+ )? $/x)
11001 Carp::my_carp("Table '$property_name=$map' should have been defined. Defining it now.")
11003 $table = property_ref($property_name)->add_match_table($map);
11006 $table->add_range($range->start, $range->end);
11009 # And add the Is_ prefix synonyms for Perl 5.6 compatibility, in which
11010 # all properties have this optional prefix. These do not get a
11011 # separate entry in the pod file, because are covered by a wild-card
11013 foreach my $alias ($property->aliases) {
11014 my $Is_name = 'Is_' . $alias->name;
11015 if (! defined (my $pre_existing = property_ref($Is_name))) {
11016 $property->add_alias($Is_name,
11018 Status => $alias->status,
11019 Externally_Ok => 0);
11023 # It seemed too much work to add in these warnings when it
11024 # appears that Unicode has made a decision never to begin a
11025 # property name with 'Is_', so this shouldn't happen, but just
11026 # in case, it is a warning.
11027 Carp::my_carp(<<END
11028 There is already an alias named $Is_name (from " . $pre_existing . "), so not
11029 creating this alias for $property. The generated table and pod files do not
11030 warn users of this conflict.
11033 $has_Is_conflicts++;
11035 } # End of loop through aliases for this property
11036 } # End of loop through all Unicode properties.
11038 # Fill in the mappings that Unicode doesn't completely furnish. First the
11039 # single letter major general categories. If Unicode were to start
11040 # delivering the values, this would be redundant, but better that than to
11041 # try to figure out if should skip and not get it right. Ths could happen
11042 # if a new major category were to be introduced, and the hard-coded test
11043 # wouldn't know about it.
11044 # This routine depends on the standard names for the general categories
11045 # being what it thinks they are, like 'Cn'. The major categories are the
11046 # union of all the general category tables which have the same first
11047 # letters. eg. L = Lu + Lt + Ll + Lo + Lm
11048 foreach my $minor_table ($gc->tables) {
11049 my $minor_name = $minor_table->name;
11050 next if length $minor_name == 1;
11051 if (length $minor_name != 2) {
11052 Carp::my_carp_bug("Unexpected general category '$minor_name'. Skipped.");
11056 my $major_name = uc(substr($minor_name, 0, 1));
11057 my $major_table = $gc->table($major_name);
11058 $major_table += $minor_table;
11061 # LC is Ll, Lu, and Lt. (used to be L& or L_, but PropValueAliases.txt
11062 # defines it as LC)
11063 my $LC = $gc->table('LC');
11064 $LC->add_alias('L_', Status => $DISCOURAGED); # For backwards...
11065 $LC->add_alias('L&', Status => $DISCOURAGED); # compatibility.
11068 if ($LC->is_empty) { # Assume if not empty that Unicode has started to
11069 # deliver the correct values in it
11070 $LC->initialize($gc->table('Ll') + $gc->table('Lu'));
11072 # Lt not in release 1.
11073 $LC += $gc->table('Lt') if defined $gc->table('Lt');
11075 $LC->add_description('[\p{Ll}\p{Lu}\p{Lt}]');
11077 my $Cs = $gc->table('Cs');
11079 $Cs->add_note('Mostly not usable in Perl.');
11080 $Cs->add_comment(join_lines(<<END
11081 Surrogates are used exclusively for I/O in UTF-16, and should not appear in
11082 Unicode text, and hence their use will generate (usually fatal) messages
11088 # Folding information was introduced later into Unicode data. To get
11089 # Perl's case ignore (/i) to work at all in releases that don't have
11090 # folding, use the best available alternative, which is lower casing.
11091 my $fold = property_ref('Simple_Case_Folding');
11092 if ($fold->is_empty) {
11093 $fold->initialize(property_ref('Simple_Lowercase_Mapping'));
11094 $fold->add_note(join_lines(<<END
11095 WARNING: This table uses lower case as a substitute for missing fold
11101 # Multiple-character mapping was introduced later into Unicode data. If
11102 # missing, use the single-characters maps as best available alternative
11103 foreach my $map (qw { Uppercase_Mapping
11108 my $full = property_ref($map);
11109 if ($full->is_empty) {
11110 my $simple = property_ref('Simple_' . $map);
11111 $full->initialize($simple);
11112 $full->add_comment($simple->comment) if ($simple->comment);
11113 $full->add_note(join_lines(<<END
11114 WARNING: This table uses simple mapping (single-character only) as a
11115 substitute for missing multiple-character information
11123 sub compile_perl() {
11124 # Create perl-defined tables. Almost all are part of the pseudo-property
11125 # named 'perl' internally to this program. Many of these are recommended
11126 # in UTS#18 "Unicode Regular Expressions", and their derivations are based
11127 # on those found there.
11128 # Almost all of these are equivalent to some Unicode property.
11129 # A number of these properties have equivalents restricted to the ASCII
11130 # range, with their names prefaced by 'Posix', to signify that these match
11131 # what the Posix standard says they should match. A couple are
11132 # effectively this, but the name doesn't have 'Posix' in it because there
11133 # just isn't any Posix equivalent.
11135 # 'Any' is all code points. As an error check, instead of just setting it
11136 # to be that, construct it to be the union of all the major categories
11137 my $Any = $perl->add_match_table('Any',
11138 Description => "[\\x{0000}-\\x{$LAST_UNICODE_CODEPOINT_STRING}]",
11141 foreach my $major_table ($gc->tables) {
11143 # Major categories are the ones with single letter names.
11144 next if length($major_table->name) != 1;
11146 $Any += $major_table;
11149 if ($Any->max != $LAST_UNICODE_CODEPOINT) {
11150 Carp::my_carp_bug("Generated highest code point ("
11151 . sprintf("%X", $Any->max)
11152 . ") doesn't match expected value $LAST_UNICODE_CODEPOINT_STRING.")
11154 if ($Any->range_count != 1 || $Any->min != 0) {
11155 Carp::my_carp_bug("Generated table 'Any' doesn't match all code points.")
11158 $Any->add_alias('All');
11160 # Assigned is the opposite of gc=unassigned
11161 my $Assigned = $perl->add_match_table('Assigned',
11162 Description => "All assigned code points",
11163 Initialize => ~ $gc->table('Unassigned'),
11166 # Our internal-only property should be treated as more than just a
11168 $perl->add_match_table('_CombAbove')
11169 ->set_equivalent_to(property_ref('ccc')->table('Above'),
11172 my $ASCII = $perl->add_match_table('ASCII', Description => '[[:ASCII:]]');
11173 if (defined $block) { # This is equivalent to the block if have it.
11174 my $Unicode_ASCII = $block->table('Basic_Latin');
11175 if (defined $Unicode_ASCII && ! $Unicode_ASCII->is_empty) {
11176 $ASCII->set_equivalent_to($Unicode_ASCII, Related => 1);
11180 # Very early releases didn't have blocks, so initialize ASCII ourselves if
11182 if ($ASCII->is_empty) {
11183 $ASCII->initialize([ 0..127 ]);
11186 # Get the best available case definitions. Early Unicode versions didn't
11187 # have Uppercase and Lowercase defined, so use the general category
11188 # instead for them.
11189 my $Lower = $perl->add_match_table('Lower');
11190 my $Unicode_Lower = property_ref('Lowercase');
11191 if (defined $Unicode_Lower && ! $Unicode_Lower->is_empty) {
11192 $Lower->set_equivalent_to($Unicode_Lower->table('Y'), Related => 1);
11195 $Lower->set_equivalent_to($gc->table('Lowercase_Letter'),
11198 $perl->add_match_table("PosixLower",
11199 Description => "[a-z]",
11200 Initialize => $Lower & $ASCII,
11203 my $Upper = $perl->add_match_table('Upper');
11204 my $Unicode_Upper = property_ref('Uppercase');
11205 if (defined $Unicode_Upper && ! $Unicode_Upper->is_empty) {
11206 $Upper->set_equivalent_to($Unicode_Upper->table('Y'), Related => 1);
11209 $Upper->set_equivalent_to($gc->table('Uppercase_Letter'),
11212 $perl->add_match_table("PosixUpper",
11213 Description => "[A-Z]",
11214 Initialize => $Upper & $ASCII,
11217 # Earliest releases didn't have title case. Initialize it to empty if not
11218 # otherwise present
11219 my $Title = $perl->add_match_table('Title');
11220 my $lt = $gc->table('Lt');
11222 $Title->set_equivalent_to($lt, Related => 1);
11225 # If this Unicode version doesn't have Cased, set up our own. From
11226 # Unicode 5.1: Definition D120: A character C is defined to be cased if
11227 # and only if C has the Lowercase or Uppercase property or has a
11228 # General_Category value of Titlecase_Letter.
11229 unless (defined property_ref('Cased')) {
11230 my $cased = $perl->add_match_table('Cased',
11231 Initialize => $Lower + $Upper + $Title,
11232 Description => 'Uppercase or Lowercase or Titlecase',
11236 # Similarly, set up our own Case_Ignorable property if this Unicode
11237 # version doesn't have it. From Unicode 5.1: Definition D121: A character
11238 # C is defined to be case-ignorable if C has the value MidLetter or the
11239 # value MidNumLet for the Word_Break property or its General_Category is
11240 # one of Nonspacing_Mark (Mn), Enclosing_Mark (Me), Format (Cf),
11241 # Modifier_Letter (Lm), or Modifier_Symbol (Sk).
11243 # Perl has long had an internal-only alias for this property.
11244 my $perl_case_ignorable = $perl->add_match_table('_Case_Ignorable');
11245 my $case_ignorable = property_ref('Case_Ignorable');
11246 if (defined $case_ignorable && ! $case_ignorable->is_empty) {
11247 $perl_case_ignorable->set_equivalent_to($case_ignorable->table('Y'),
11252 $perl_case_ignorable->initialize($gc->table('Mn') + $gc->table('Lm'));
11254 # The following three properties are not in early releases
11255 $perl_case_ignorable += $gc->table('Me') if defined $gc->table('Me');
11256 $perl_case_ignorable += $gc->table('Cf') if defined $gc->table('Cf');
11257 $perl_case_ignorable += $gc->table('Sk') if defined $gc->table('Sk');
11259 # For versions 4.1 - 5.0, there is no MidNumLet property, and
11260 # correspondingly the case-ignorable definition lacks that one. For
11261 # 4.0, it appears that it was meant to be the same definition, but was
11262 # inadvertently omitted from the standard's text, so add it if the
11263 # property actually is there
11264 my $wb = property_ref('Word_Break');
11266 my $midlet = $wb->table('MidLetter');
11267 $perl_case_ignorable += $midlet if defined $midlet;
11268 my $midnumlet = $wb->table('MidNumLet');
11269 $perl_case_ignorable += $midnumlet if defined $midnumlet;
11273 # In earlier versions of the standard, instead of the above two
11274 # properties , just the following characters were used:
11275 $perl_case_ignorable += 0x0027 # APOSTROPHE
11276 + 0x00AD # SOFT HYPHEN (SHY)
11277 + 0x2019; # RIGHT SINGLE QUOTATION MARK
11281 # The remaining perl defined tables are mostly based on Unicode TR 18,
11282 # "Annex C: Compatibility Properties". All of these have two versions,
11283 # one whose name generally begins with Posix that is posix-compliant, and
11284 # one that matches Unicode characters beyond the Posix, ASCII range
11286 my $Alpha = $perl->add_match_table('Alpha');
11288 # Alphabetic was not present in early releases
11289 my $Alphabetic = property_ref('Alphabetic');
11290 if (defined $Alphabetic && ! $Alphabetic->is_empty) {
11291 $Alpha->set_equivalent_to($Alphabetic->table('Y'), Related => 1);
11295 # For early releases, we don't get it exactly right. The below
11296 # includes more than it should, which in 5.2 terms is: L + Nl +
11297 # Other_Alphabetic. Other_Alphabetic contains many characters from
11298 # Mn and Mc. It's better to match more than we should, than less than
11300 $Alpha->initialize($gc->table('Letter')
11302 + $gc->table('Mc'));
11303 $Alpha += $gc->table('Nl') if defined $gc->table('Nl');
11304 $Alpha->add_description('Alphabetic');
11306 $perl->add_match_table("PosixAlpha",
11307 Description => "[A-Za-z]",
11308 Initialize => $Alpha & $ASCII,
11311 my $Alnum = $perl->add_match_table('Alnum',
11312 Description => 'Alphabetic and (Decimal) Numeric',
11313 Initialize => $Alpha + $gc->table('Decimal_Number'),
11315 $perl->add_match_table("PosixAlnum",
11316 Description => "[A-Za-z0-9]",
11317 Initialize => $Alnum & $ASCII,
11320 my $Word = $perl->add_match_table('Word',
11321 Description => '\w, including beyond ASCII',
11322 Initialize => $Alnum + $gc->table('Mark'),
11324 my $Pc = $gc->table('Connector_Punctuation'); # 'Pc' Not in release 1
11325 $Word += $Pc if defined $Pc;
11327 # This is a Perl extension, so the name doesn't begin with Posix.
11328 $perl->add_match_table('PerlWord',
11329 Description => '\w, restricted to ASCII = [A-Za-z0-9_]',
11330 Initialize => $Word & $ASCII,
11333 my $Blank = $perl->add_match_table('Blank',
11334 Description => '\h, Horizontal white space',
11336 # 200B is Zero Width Space which is for line
11337 # break control, and was listed as
11338 # Space_Separator in early releases
11339 Initialize => $gc->table('Space_Separator')
11343 $Blank->add_alias('HorizSpace'); # Another name for it.
11344 $perl->add_match_table("PosixBlank",
11345 Description => "\\t and ' '",
11346 Initialize => $Blank & $ASCII,
11349 my $VertSpace = $perl->add_match_table('VertSpace',
11350 Description => '\v',
11351 Initialize => $gc->table('Line_Separator')
11352 + $gc->table('Paragraph_Separator')
11353 + 0x000A # LINE FEED
11354 + 0x000B # VERTICAL TAB
11355 + 0x000C # FORM FEED
11356 + 0x000D # CARRIAGE RETURN
11359 # No Posix equivalent for vertical space
11361 my $Space = $perl->add_match_table('Space',
11362 Description => '\s including beyond ASCII plus vertical tab',
11363 Initialize => $Blank + $VertSpace,
11365 $perl->add_match_table("PosixSpace",
11366 Description => "\\t, \\n, \\cK, \\f, \\r, and ' '. (\\cK is vertical tab)",
11367 Initialize => $Space & $ASCII,
11370 # Perl's traditional space doesn't include Vertical Tab
11371 my $SpacePerl = $perl->add_match_table('SpacePerl',
11372 Description => '\s, including beyond ASCII',
11373 Initialize => $Space - 0x000B,
11375 $perl->add_match_table('PerlSpace',
11376 Description => '\s, restricted to ASCII',
11377 Initialize => $SpacePerl & $ASCII,
11380 my $Cntrl = $perl->add_match_table('Cntrl',
11381 Description => 'Control characters');
11382 $Cntrl->set_equivalent_to($gc->table('Cc'), Related => 1);
11383 $perl->add_match_table("PosixCntrl",
11384 Description => "ASCII control characters: NUL, SOH, STX, ETX, EOT, ENQ, ACK, BEL, BS, HT, LF, VT, FF, CR, SO, SI, DLE, DC1, DC2, DC3, DC4, NAK, SYN, ETB, CAN, EOM, SUB, ESC, FS, GS, RS, US, and DEL",
11385 Initialize => $Cntrl & $ASCII,
11388 # $controls is a temporary used to construct Graph.
11389 my $controls = Range_List->new(Initialize => $gc->table('Unassigned')
11390 + $gc->table('Control'));
11391 # Cs not in release 1
11392 $controls += $gc->table('Surrogate') if defined $gc->table('Surrogate');
11394 # Graph is ~space & ~(Cc|Cs|Cn) = ~(space + $controls)
11395 my $Graph = $perl->add_match_table('Graph',
11396 Description => 'Characters that are graphical',
11397 Initialize => ~ ($Space + $controls),
11399 $perl->add_match_table("PosixGraph",
11401 '[-!"#$%&\'()*+,./:;<>?@[\\\]^_`{|}~0-9A-Za-z]',
11402 Initialize => $Graph & $ASCII,
11405 $print = $perl->add_match_table('Print',
11406 Description => 'Characters that are graphical plus space characters (but no controls)',
11407 Initialize => $Blank + $Graph - $gc->table('Control'),
11409 $perl->add_match_table("PosixPrint",
11411 '[- 0-9A-Za-z!"#$%&\'()*+,./:;<>?@[\\\]^_`{|}~]',
11412 Initialize => $print & $ASCII,
11415 my $Punct = $perl->add_match_table('Punct');
11416 $Punct->set_equivalent_to($gc->table('Punctuation'), Related => 1);
11418 # \p{punct} doesn't include the symbols, which posix does
11419 $perl->add_match_table('PosixPunct',
11420 Description => '[-!"#$%&\'()*+,./:;<>?@[\\\]^_`{|}~]',
11421 Initialize => $ASCII & ($gc->table('Punctuation')
11422 + $gc->table('Symbol')),
11425 my $Digit = $perl->add_match_table('Digit',
11426 Description => '\d, extended beyond just [0-9]');
11427 $Digit->set_equivalent_to($gc->table('Decimal_Number'), Related => 1);
11428 my $PosixDigit = $perl->add_match_table("PosixDigit",
11429 Description => '[0-9]',
11430 Initialize => $Digit & $ASCII,
11433 # Hex_Digit was not present in first release
11434 my $Xdigit = $perl->add_match_table('XDigit');
11435 my $Hex = property_ref('Hex_Digit');
11436 if (defined $Hex && ! $Hex->is_empty) {
11437 $Xdigit->set_equivalent_to($Hex->table('Y'), Related => 1);
11440 # (Have to use hex instead of e.g. '0', because could be running on an
11441 # non-ASCII machine, and we want the Unicode (ASCII) values)
11442 $Xdigit->initialize([ 0x30..0x39, 0x41..0x46, 0x61..0x66,
11443 0xFF10..0xFF19, 0xFF21..0xFF26, 0xFF41..0xFF46]);
11444 $Xdigit->add_description('[0-9A-Fa-f] and corresponding fullwidth versions, like U+FF10: FULLWIDTH DIGIT ZERO');
11447 my $dt = property_ref('Decomposition_Type');
11448 $dt->add_match_table('Non_Canon', Full_Name => 'Non_Canonical',
11449 Initialize => ~ ($dt->table('None') + $dt->table('Canonical')),
11450 Perl_Extension => 1,
11451 Note => 'Union of all non-canonical decompositions',
11454 # _CanonDCIJ is equivalent to Soft_Dotted, but if on a release earlier
11455 # than SD appeared, construct it ourselves, based on the first release SD
11457 my $CanonDCIJ = $perl->add_match_table('_CanonDCIJ');
11458 my $soft_dotted = property_ref('Soft_Dotted');
11459 if (defined $soft_dotted && ! $soft_dotted->is_empty) {
11460 $CanonDCIJ->set_equivalent_to($soft_dotted->table('Y'), Related => 1);
11464 # This list came from 3.2 Soft_Dotted.
11465 $CanonDCIJ->initialize([ 0x0069,
11474 $CanonDCIJ = $CanonDCIJ & $Assigned;
11477 # These are used in Unicode's definition of \X
11478 my $begin = $perl->add_match_table('_X_Begin', Perl_Extension => 1);
11479 my $extend = $perl->add_match_table('_X_Extend', Perl_Extension => 1);
11481 my $gcb = property_ref('Grapheme_Cluster_Break');
11483 # The 'extended' grapheme cluster came in 5.1. The non-extended
11484 # definition differs too much from the traditional Perl one to use.
11485 if (defined $gcb && defined $gcb->table('SpacingMark')) {
11487 # Note that assumes HST is defined; it came in an earlier release than
11488 # GCB. In the line below, two negatives means: yes hangul
11489 $begin += ~ property_ref('Hangul_Syllable_Type')
11490 ->table('Not_Applicable')
11491 + ~ ($gcb->table('Control')
11492 + $gcb->table('CR')
11493 + $gcb->table('LF'));
11494 $begin->add_comment('For use in \X; matches: Hangul_Syllable | ! Control');
11496 $extend += $gcb->table('Extend') + $gcb->table('SpacingMark');
11497 $extend->add_comment('For use in \X; matches: Extend | SpacingMark');
11499 else { # Old definition, used on early releases.
11500 $extend += $gc->table('Mark')
11503 $begin += ~ $extend;
11505 # Here we may have a release that has the regular grapheme cluster
11506 # defined, or a release that doesn't have anything defined.
11507 # We set things up so the Perl core degrades gracefully, possibly with
11508 # placeholders that match nothing.
11510 if (! defined $gcb) {
11511 $gcb = Property->new('GCB', Status => $PLACEHOLDER);
11513 my $hst = property_ref('HST');
11514 if (!defined $hst) {
11515 $hst = Property->new('HST', Status => $PLACEHOLDER);
11516 $hst->add_match_table('Not_Applicable',
11517 Initialize => $Any,
11521 # On some releases, here we may not have the needed tables for the
11522 # perl core, in some releases we may.
11523 foreach my $name (qw{ L LV LVT T V prepend }) {
11524 my $table = $gcb->table($name);
11525 if (! defined $table) {
11526 $table = $gcb->add_match_table($name);
11527 push @tables_that_may_be_empty, $table->complete_name;
11530 # The HST property predates the GCB one, and has identical tables
11531 # for some of them, so use it if we can.
11532 if ($table->is_empty
11534 && defined $hst->table($name))
11536 $table += $hst->table($name);
11541 # More GCB. If we found some hangul syllables, populate a combined
11543 my $lv_lvt_v = $perl->add_match_table('_X_LV_LVT_V');
11544 my $LV = $gcb->table('LV');
11545 if ($LV->is_empty) {
11546 push @tables_that_may_be_empty, $lv_lvt_v->complete_name;
11548 $lv_lvt_v += $LV + $gcb->table('LVT') + $gcb->table('V');
11549 $lv_lvt_v->add_comment('For use in \X; matches: HST=LV | HST=LVT | HST=V');
11552 # Was previously constructed to contain both Name and Unicode_1_Name
11553 my @composition = ('Name', 'Unicode_1_Name');
11555 if (@named_sequences) {
11556 push @composition, 'Named_Sequence';
11557 foreach my $sequence (@named_sequences) {
11558 $perl_charname->add_anomalous_entry($sequence);
11562 my $alias_sentence = "";
11563 my $alias = property_ref('Name_Alias');
11564 if (defined $alias) {
11565 push @composition, 'Name_Alias';
11566 $alias->reset_each_range;
11567 while (my ($range) = $alias->each_range) {
11568 next if $range->value eq "";
11569 if ($range->start != $range->end) {
11570 Carp::my_carp("Expecting only one code point in the range $range. Just to keep going, using just the first code point;");
11572 $perl_charname->add_duplicate($range->start, $range->value);
11574 $alias_sentence = <<END;
11575 The Name_Alias property adds duplicate code point entries with a corrected
11576 name. The original (less correct, but still valid) name will be physically
11581 if (@composition <= 2) { # Always at least 2
11582 $comment = join " and ", @composition;
11585 $comment = join ", ", @composition[0 .. scalar @composition - 2];
11586 $comment .= ", and $composition[-1]";
11589 $perl_charname->add_comment(join_lines( <<END
11590 This file is for charnames.pm. It is the union of the $comment properties.
11591 Unicode_1_Name entries are used only for otherwise nameless code
11597 # The combining class property used by Perl's normalize.pm is not located
11598 # in the normal mapping directory; create a copy for it.
11599 my $ccc = property_ref('Canonical_Combining_Class');
11600 my $perl_ccc = Property->new('Perl_ccc',
11601 Default_Map => $ccc->default_map,
11602 Full_Name => 'Perl_Canonical_Combining_Class',
11603 Internal_Only_Warning => 1,
11604 Perl_Extension => 1,
11607 Initialize => $ccc,
11608 File => 'CombiningClass',
11609 Directory => File::Spec->curdir(),
11611 $perl_ccc->set_to_output_map(1);
11612 $perl_ccc->add_comment(join_lines(<<END
11613 This mapping is for normalize.pm. It is currently identical to the Unicode
11614 Canonical_Combining_Class property.
11618 # This one match table for it is needed for calculations on output
11619 my $default = $perl_ccc->add_match_table($ccc->default_map,
11620 Initialize => $ccc->table($ccc->default_map),
11621 Status => $SUPPRESSED);
11623 # Construct the Present_In property from the Age property.
11624 if (-e 'DAge.txt' && defined (my $age = property_ref('Age'))) {
11625 my $default_map = $age->default_map;
11626 my $in = Property->new('In',
11627 Default_Map => $default_map,
11628 Full_Name => "Present_In",
11629 Internal_Only_Warning => 1,
11630 Perl_Extension => 1,
11632 Initialize => $age,
11634 $in->add_comment(join_lines(<<END
11635 This file should not be used for any purpose. The values in this file are the
11636 same as for $age, and not for what $in really means. This is because anything
11637 defined in a given release should have multiple values: that release and all
11638 higher ones. But only one value per code point can be represented in a table
11643 # The Age tables are named like 1.5, 2.0, 2.1, .... Sort so that the
11644 # lowest numbered (earliest) come first, with the non-numeric one
11646 my ($first_age, @rest_ages) = sort { ($a->name !~ /^[\d.]*$/)
11648 : ($b->name !~ /^[\d.]*$/)
11650 : $a->name <=> $b->name
11653 # The Present_In property is the cumulative age properties. The first
11654 # one hence is identical to the first age one.
11655 my $previous_in = $in->add_match_table($first_age->name);
11656 $previous_in->set_equivalent_to($first_age, Related => 1);
11658 my $description_start = "Code point's usage introduced in version ";
11659 $first_age->add_description($description_start . $first_age->name);
11661 # To construct the accumlated values, for each of the age tables
11662 # starting with the 2nd earliest, merge the earliest with it, to get
11663 # all those code points existing in the 2nd earliest. Repeat merging
11664 # the new 2nd earliest with the 3rd earliest to get all those existing
11665 # in the 3rd earliest, and so on.
11666 foreach my $current_age (@rest_ages) {
11667 next if $current_age->name !~ /^[\d.]*$/; # Skip the non-numeric
11669 my $current_in = $in->add_match_table(
11670 $current_age->name,
11671 Initialize => $current_age + $previous_in,
11672 Description => $description_start
11673 . $current_age->name
11676 $previous_in = $current_in;
11678 # Add clarifying material for the corresponding age file. This is
11679 # in part because of the confusing and contradictory information
11680 # given in the Standard's documentation itself, as of 5.2.
11681 $current_age->add_description(
11682 "Code point's usage was introduced in version "
11683 . $current_age->name);
11684 $current_age->add_note("See also $in");
11688 # And finally the code points whose usages have yet to be decided are
11689 # the same in both properties. Note that permanently unassigned code
11690 # points actually have their usage assigned (as being permanently
11691 # unassigned), so that these tables are not the same as gc=cn.
11692 my $unassigned = $in->add_match_table($default_map);
11693 my $age_default = $age->table($default_map);
11694 $age_default->add_description(<<END
11695 Code point's usage has not been assigned in any Unicode release thus far.
11698 $unassigned->set_equivalent_to($age_default, Related => 1);
11702 # Finished creating all the perl properties. All non-internal non-string
11703 # ones have a synonym of 'Is_' prefixed. (Internal properties begin with
11704 # an underscore.) These do not get a separate entry in the pod file
11705 foreach my $table ($perl->tables) {
11706 foreach my $alias ($table->aliases) {
11707 next if $alias->name =~ /^_/;
11708 $table->add_alias('Is_' . $alias->name,
11710 Status => $alias->status,
11711 Externally_Ok => 0);
11715 # Here done with all the basic stuff. Ready to populate the information
11716 # about each character if annotating them.
11719 # See comments at its declaration
11720 $annotate_ranges = Range_Map->new;
11722 # This separates out the non-characters from the other unassigneds, so
11723 # can give different annotations for each.
11724 $unassigned_sans_noncharacters = Range_List->new(
11725 Initialize => $gc->table('Unassigned')
11726 & property_ref('Noncharacter_Code_Point')->table('N'));
11728 for (my $i = 0; $i <= $LAST_UNICODE_CODEPOINT; $i++ ) {
11729 $i = populate_char_info($i); # Note sets $i so may cause skips
11736 sub add_perl_synonyms() {
11737 # A number of Unicode tables have Perl synonyms that are expressed in
11738 # the single-form, \p{name}. These are:
11739 # All the binary property Y tables, so that \p{Name=Y} gets \p{Name} and
11740 # \p{Is_Name} as synonyms
11741 # \p{Script=Value} gets \p{Value}, \p{Is_Value} as synonyms
11742 # \p{General_Category=Value} gets \p{Value}, \p{Is_Value} as synonyms
11743 # \p{Block=Value} gets \p{In_Value} as a synonym, and, if there is no
11744 # conflict, \p{Value} and \p{Is_Value} as well
11746 # This routine generates these synonyms, warning of any unexpected
11749 # Construct the list of tables to get synonyms for. Start with all the
11750 # binary and the General_Category ones.
11751 my @tables = grep { $_->type == $BINARY } property_ref('*');
11752 push @tables, $gc->tables;
11754 # If the version of Unicode includes the Script property, add its tables
11755 if (defined property_ref('Script')) {
11756 push @tables, property_ref('Script')->tables;
11759 # The Block tables are kept separate because they are treated differently.
11760 # And the earliest versions of Unicode didn't include them, so add only if
11763 push @blocks, $block->tables if defined $block;
11765 # Here, have the lists of tables constructed. Process blocks last so that
11766 # if there are name collisions with them, blocks have lowest priority.
11767 # Should there ever be other collisions, manual intervention would be
11768 # required. See the comments at the beginning of the program for a
11769 # possible way to handle those semi-automatically.
11770 foreach my $table (@tables, @blocks) {
11772 # For non-binary properties, the synonym is just the name of the
11773 # table, like Greek, but for binary properties the synonym is the name
11774 # of the property, and means the code points in its 'Y' table.
11775 my $nominal = $table;
11776 my $nominal_property = $nominal->property;
11778 if (! $nominal->isa('Property')) {
11783 # Here is a binary property. Use the 'Y' table. Verify that is
11785 my $yes = $nominal->table('Y');
11786 unless (defined $yes) { # Must be defined, but is permissible to
11788 Carp::my_carp_bug("Undefined $nominal, 'Y'. Skipping.");
11794 foreach my $alias ($nominal->aliases) {
11796 # Attempt to create a table in the perl directory for the
11797 # candidate table, using whatever aliases in it that don't
11798 # conflict. Also add non-conflicting aliases for all these
11799 # prefixed by 'Is_' (and/or 'In_' for Block property tables)
11801 foreach my $prefix ("", 'Is_', 'In_') {
11803 # Only Block properties can have added 'In_' aliases.
11804 next if $prefix eq 'In_' and $nominal_property != $block;
11806 my $proposed_name = $prefix . $alias->name;
11808 # No Is_Is, In_In, nor combinations thereof
11809 trace "$proposed_name is a no-no" if main::DEBUG && $to_trace && $proposed_name =~ /^ I [ns] _I [ns] _/x;
11810 next if $proposed_name =~ /^ I [ns] _I [ns] _/x;
11812 trace "Seeing if can add alias or table: 'perl=$proposed_name' based on $nominal" if main::DEBUG && $to_trace;
11814 # Get a reference to any existing table in the perl
11815 # directory with the desired name.
11816 my $pre_existing = $perl->table($proposed_name);
11818 if (! defined $pre_existing) {
11820 # No name collision, so ok to add the perl synonym.
11822 my $make_pod_entry;
11824 my $status = $actual->status;
11825 if ($nominal_property == $block) {
11827 # For block properties, the 'In' form is preferred for
11828 # external use; the pod file contains wild cards for
11829 # this and the 'Is' form so no entries for those; and
11830 # we don't want people using the name without the
11831 # 'In', so discourage that.
11832 if ($prefix eq "") {
11833 $make_pod_entry = 1;
11834 $status = $status || $DISCOURAGED;
11835 $externally_ok = 0;
11837 elsif ($prefix eq 'In_') {
11838 $make_pod_entry = 0;
11839 $status = $status || $NORMAL;
11840 $externally_ok = 1;
11843 $make_pod_entry = 0;
11844 $status = $status || $DISCOURAGED;
11845 $externally_ok = 0;
11848 elsif ($prefix ne "") {
11850 # The 'Is' prefix is handled in the pod by a wild
11851 # card, and we won't use it for an external name
11852 $make_pod_entry = 0;
11853 $status = $status || $NORMAL;
11854 $externally_ok = 0;
11858 # Here, is an empty prefix, non block. This gets its
11859 # own pod entry and can be used for an external name.
11860 $make_pod_entry = 1;
11861 $status = $status || $NORMAL;
11862 $externally_ok = 1;
11865 # Here, there isn't a perl pre-existing table with the
11866 # name. Look through the list of equivalents of this
11867 # table to see if one is a perl table.
11868 foreach my $equivalent ($actual->leader->equivalents) {
11869 next if $equivalent->property != $perl;
11871 # Here, have found a table for $perl. Add this alias
11872 # to it, and are done with this prefix.
11873 $equivalent->add_alias($proposed_name,
11874 Pod_Entry => $make_pod_entry,
11876 Externally_Ok => $externally_ok);
11877 trace "adding alias perl=$proposed_name to $equivalent" if main::DEBUG && $to_trace;
11881 # Here, $perl doesn't already have a table that is a
11882 # synonym for this property, add one.
11883 my $added_table = $perl->add_match_table($proposed_name,
11884 Pod_Entry => $make_pod_entry,
11886 Externally_Ok => $externally_ok);
11887 # And it will be related to the actual table, since it is
11889 $added_table->set_equivalent_to($actual, Related => 1);
11890 trace "added ", $perl->table($proposed_name) if main::DEBUG && $to_trace;
11892 } # End of no pre-existing.
11894 # Here, there is a pre-existing table that has the proposed
11895 # name. We could be in trouble, but not if this is just a
11896 # synonym for another table that we have already made a child
11897 # of the pre-existing one.
11898 if ($pre_existing->is_set_equivalent_to($actual)) {
11899 trace "$pre_existing is already equivalent to $actual; adding alias perl=$proposed_name to it" if main::DEBUG && $to_trace;
11900 $pre_existing->add_alias($proposed_name);
11904 # Here, there is a name collision, but it still could be ok if
11905 # the tables match the identical set of code points, in which
11906 # case, we can combine the names. Compare each table's code
11907 # point list to see if they are identical.
11908 trace "Potential name conflict with $pre_existing having ", $pre_existing->count, " code points" if main::DEBUG && $to_trace;
11909 if ($pre_existing->matches_identically_to($actual)) {
11911 # Here, they do match identically. Not a real conflict.
11912 # Make the perl version a child of the Unicode one, except
11913 # in the non-obvious case of where the perl name is
11914 # already a synonym of another Unicode property. (This is
11915 # excluded by the test for it being its own parent.) The
11916 # reason for this exclusion is that then the two Unicode
11917 # properties become related; and we don't really know if
11918 # they are or not. We generate documentation based on
11919 # relatedness, and this would be misleading. Code
11920 # later executed in the process will cause the tables to
11921 # be represented by a single file anyway, without making
11922 # it look in the pod like they are necessarily related.
11923 if ($pre_existing->parent == $pre_existing
11924 && ($pre_existing->property == $perl
11925 || $actual->property == $perl))
11927 trace "Setting $pre_existing equivalent to $actual since one is \$perl, and match identical sets" if main::DEBUG && $to_trace;
11928 $pre_existing->set_equivalent_to($actual, Related => 1);
11930 elsif (main::DEBUG && $to_trace) {
11931 trace "$pre_existing is equivalent to $actual since match identical sets, but not setting them equivalent, to preserve the separateness of the perl aliases";
11932 trace $pre_existing->parent;
11937 # Here they didn't match identically, there is a real conflict
11938 # between our new name and a pre-existing property.
11939 $actual->add_conflicting($proposed_name, 'p', $pre_existing);
11940 $pre_existing->add_conflicting($nominal->full_name,
11944 # Don't output a warning for aliases for the block
11945 # properties (unless they start with 'In_') as it is
11946 # expected that there will be conflicts and the block
11948 if ($verbosity >= $NORMAL_VERBOSITY
11949 && ($actual->property != $block || $prefix eq 'In_'))
11951 print simple_fold(join_lines(<<END
11952 There is already an alias named $proposed_name (from " . $pre_existing . "),
11953 so not creating this alias for " . $actual
11958 # Keep track for documentation purposes.
11959 $has_In_conflicts++ if $prefix eq 'In_';
11960 $has_Is_conflicts++ if $prefix eq 'Is_';
11965 # There are some properties which have No and Yes (and N and Y) as
11966 # property values, but aren't binary, and could possibly be confused with
11967 # binary ones. So create caveats for them. There are tables that are
11968 # named 'No', and tables that are named 'N', but confusion is not likely
11969 # unless they are the same table. For example, N meaning Number or
11970 # Neutral is not likely to cause confusion, so don't add caveats to things
11972 foreach my $property (grep { $_->type != $BINARY } property_ref('*')) {
11973 my $yes = $property->table('Yes');
11974 if (defined $yes) {
11975 my $y = $property->table('Y');
11976 if (defined $y && $yes == $y) {
11977 foreach my $alias ($property->aliases) {
11978 $yes->add_conflicting($alias->name);
11982 my $no = $property->table('No');
11984 my $n = $property->table('N');
11985 if (defined $n && $no == $n) {
11986 foreach my $alias ($property->aliases) {
11987 $no->add_conflicting($alias->name, 'P');
11996 sub register_file_for_name($$$) {
11997 # Given info about a table and a datafile that it should be associated
11998 # with, register that assocation
12001 my $directory_ref = shift; # Array of the directory path for the file
12002 my $file = shift; # The file name in the final directory, [-1].
12003 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
12005 trace "table=$table, file=$file, directory=@$directory_ref" if main::DEBUG && $to_trace;
12007 if ($table->isa('Property')) {
12008 $table->set_file_path(@$directory_ref, $file);
12009 push @map_properties, $table
12010 if $directory_ref->[0] eq $map_directory;
12014 # Do all of the work for all equivalent tables when called with the leader
12015 # table, so skip if isn't the leader.
12016 return if $table->leader != $table;
12018 # Join all the file path components together, using slashes.
12019 my $full_filename = join('/', @$directory_ref, $file);
12021 # All go in the same subdirectory of unicore
12022 if ($directory_ref->[0] ne $matches_directory) {
12023 Carp::my_carp("Unexpected directory in "
12024 . join('/', @{$directory_ref}, $file));
12027 # For this table and all its equivalents ...
12028 foreach my $table ($table, $table->equivalents) {
12030 # Associate it with its file internally. Don't include the
12031 # $matches_directory first component
12032 $table->set_file_path(@$directory_ref, $file);
12033 my $sub_filename = join('/', $directory_ref->[1, -1], $file);
12035 my $property = $table->property;
12036 $property = ($property == $perl)
12037 ? "" # 'perl' is never explicitly stated
12038 : standardize($property->name) . '=';
12040 my $deprecated = ($table->status eq $DEPRECATED)
12041 ? $table->status_info
12044 # And for each of the table's aliases... This inner loop eventually
12045 # goes through all aliases in the UCD that we generate regex match
12047 foreach my $alias ($table->aliases) {
12048 my $name = $alias->name;
12050 # Generate an entry in either the loose or strict hashes, which
12051 # will translate the property and alias names combination into the
12052 # file where the table for them is stored.
12054 if ($alias->loose_match) {
12055 $standard = $property . standardize($alias->name);
12056 if (exists $loose_to_file_of{$standard}) {
12057 Carp::my_carp("Can't change file registered to $loose_to_file_of{$standard} to '$sub_filename'.");
12060 $loose_to_file_of{$standard} = $sub_filename;
12064 $standard = lc ($property . $name);
12065 if (exists $stricter_to_file_of{$standard}) {
12066 Carp::my_carp("Can't change file registered to $stricter_to_file_of{$standard} to '$sub_filename'.");
12069 $stricter_to_file_of{$standard} = $sub_filename;
12071 # Tightly coupled with how utf8_heavy.pl works, for a
12072 # floating point number that is a whole number, get rid of
12073 # the trailing decimal point and 0's, so that utf8_heavy
12074 # will work. Also note that this assumes that such a
12075 # number is matched strictly; so if that were to change,
12076 # this would be wrong.
12077 if ((my $integer_name = $name)
12078 =~ s/^ ( -? \d+ ) \.0+ $ /$1/x)
12080 $stricter_to_file_of{$property . $integer_name}
12086 # Keep a list of the deprecated properties and their filenames
12088 $utf8::why_deprecated{$sub_filename} = $deprecated;
12097 my %base_names; # Names already used for avoiding DOS 8.3 filesystem
12099 my %full_dir_name_of; # Full length names of directories used.
12101 sub construct_filename($$$) {
12102 # Return a file name for a table, based on the table name, but perhaps
12103 # changed to get rid of non-portable characters in it, and to make
12104 # sure that it is unique on a file system that allows the names before
12105 # any period to be at most 8 characters (DOS). While we're at it
12106 # check and complain if there are any directory conflicts.
12108 my $name = shift; # The name to start with
12109 my $mutable = shift; # Boolean: can it be changed? If no, but
12110 # yet it must be to work properly, a warning
12112 my $directories_ref = shift; # A reference to an array containing the
12113 # path to the file, with each element one path
12114 # component. This is used because the same
12115 # name can be used in different directories.
12116 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
12118 my $warn = ! defined wantarray; # If true, then if the name is
12119 # changed, a warning is issued as well.
12121 if (! defined $name) {
12122 Carp::my_carp("Undefined name in directory "
12123 . File::Spec->join(@$directories_ref)
12128 # Make sure that no directory names conflict with each other. Look at
12129 # each directory in the input file's path. If it is already in use,
12130 # assume it is correct, and is merely being re-used, but if we
12131 # truncate it to 8 characters, and find that there are two directories
12132 # that are the same for the first 8 characters, but differ after that,
12133 # then that is a problem.
12134 foreach my $directory (@$directories_ref) {
12135 my $short_dir = substr($directory, 0, 8);
12136 if (defined $full_dir_name_of{$short_dir}) {
12137 next if $full_dir_name_of{$short_dir} eq $directory;
12138 Carp::my_carp("$directory conflicts with $full_dir_name_of{$short_dir}. Bad News. Continuing anyway");
12141 $full_dir_name_of{$short_dir} = $directory;
12145 my $path = join '/', @$directories_ref;
12146 $path .= '/' if $path;
12148 # Remove interior underscores.
12149 (my $filename = $name) =~ s/ (?<=.) _ (?=.) //xg;
12151 # Change any non-word character into an underscore, and truncate to 8.
12152 $filename =~ s/\W+/_/g; # eg., "L&" -> "L_"
12153 substr($filename, 8) = "" if length($filename) > 8;
12155 # Make sure the basename doesn't conflict with something we
12156 # might have already written. If we have, say,
12163 while (my $num = $base_names{$path}{lc $filename}++) {
12164 $num++; # so basenames with numbers start with '2', which
12165 # just looks more natural.
12167 # Want to append $num, but if it'll make the basename longer
12168 # than 8 characters, pre-truncate $filename so that the result
12170 my $delta = length($filename) + length($num) - 8;
12172 substr($filename, -$delta) = $num;
12177 if ($warn && ! $warned) {
12179 Carp::my_carp("'$path$name' conflicts with another name on a filesystem with 8 significant characters (like DOS). Proceeding anyway.");
12183 return $filename if $mutable;
12185 # If not changeable, must return the input name, but warn if needed to
12186 # change it beyond shortening it.
12187 if ($name ne $filename
12188 && substr($name, 0, length($filename)) ne $filename) {
12189 Carp::my_carp("'$path$name' had to be changed into '$filename'. Bad News. Proceeding anyway.");
12195 # The pod file contains a very large table. Many of the lines in that table
12196 # would exceed a typical output window's size, and so need to be wrapped with
12197 # a hanging indent to make them look good. The pod language is really
12198 # insufficient here. There is no general construct to do that in pod, so it
12199 # is done here by beginning each such line with a space to cause the result to
12200 # be output without formatting, and doing all the formatting here. This leads
12201 # to the result that if the eventual display window is too narrow it won't
12202 # look good, and if the window is too wide, no advantage is taken of that
12203 # extra width. A further complication is that the output may be indented by
12204 # the formatter so that there is less space than expected. What I (khw) have
12205 # done is to assume that that indent is a particular number of spaces based on
12206 # what it is in my Linux system; people can always resize their windows if
12207 # necessary, but this is obviously less than desirable, but the best that can
12209 my $automatic_pod_indent = 8;
12211 # Try to format so that uses fewest lines, but few long left column entries
12212 # slide into the right column. An experiment on 5.1 data yielded the
12213 # following percentages that didn't cut into the other side along with the
12214 # associated first-column widths
12216 # 80% not too bad except for a few blocks
12217 # 90% = 33; # , cuts 353/3053 lines from 37 = 12%
12219 my $indent_info_column = 27; # 75% of lines didn't have overlap
12221 my $FILLER = 3; # Length of initial boiler-plate columns in a pod line
12222 # The 3 is because of:
12223 # 1 for the leading space to tell the pod formatter to
12226 # 1 for the space between the flag and the main data
12228 sub format_pod_line ($$$;$$) {
12229 # Take a pod line and return it, formatted properly
12231 my $first_column_width = shift;
12232 my $entry = shift; # Contents of left column
12233 my $info = shift; # Contents of right column
12235 my $status = shift || ""; # Any flag
12237 my $loose_match = shift; # Boolean.
12238 $loose_match = 1 unless defined $loose_match;
12240 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
12243 $flags .= $STRICTER if ! $loose_match;
12245 $flags .= $status if $status;
12247 # There is a blank in the left column to cause the pod formatter to
12248 # output the line as-is.
12249 return sprintf " %-*s%-*s %s\n",
12250 # The first * in the format is replaced by this, the -1 is
12251 # to account for the leading blank. There isn't a
12252 # hard-coded blank after this to separate the flags from
12253 # the rest of the line, so that in the unlikely event that
12254 # multiple flags are shown on the same line, they both
12255 # will get displayed at the expense of that separation,
12256 # but since they are left justified, a blank will be
12257 # inserted in the normal case.
12261 # The other * in the format is replaced by this number to
12262 # cause the first main column to right fill with blanks.
12263 # The -1 is for the guaranteed blank following it.
12264 $first_column_width - $FILLER - 1,
12269 my @zero_match_tables; # List of tables that have no matches in this release
12271 sub make_table_pod_entries($) {
12272 # This generates the entries for the pod file for a given table.
12273 # Also done at this time are any children tables. The output looks like:
12274 # \p{Common} \p{Script=Common} (Short: \p{Zyyy}) (5178)
12276 my $input_table = shift; # Table the entry is for
12277 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
12279 # Generate parent and all its children at the same time.
12280 return if $input_table->parent != $input_table;
12282 my $property = $input_table->property;
12283 my $type = $property->type;
12284 my $full_name = $property->full_name;
12286 my $count = $input_table->count;
12287 my $string_count = clarify_number($count);
12288 my $status = $input_table->status;
12289 my $status_info = $input_table->status_info;
12291 my $entry_for_first_table; # The entry for the first table output.
12292 # Almost certainly, it is the parent.
12294 # For each related table (including itself), we will generate a pod entry
12295 # for each name each table goes by
12296 foreach my $table ($input_table, $input_table->children) {
12298 # utf8_heavy.pl cannot deal with null string property values, so don't
12300 next if $table->name eq "";
12302 # First, gather all the info that applies to this table as a whole.
12304 push @zero_match_tables, $table if $count == 0;
12306 my $table_property = $table->property;
12308 # The short name has all the underscores removed, while the full name
12309 # retains them. Later, we decide whether to output a short synonym
12310 # for the full one, we need to compare apples to apples, so we use the
12311 # short name's length including underscores.
12312 my $table_property_short_name_length;
12313 my $table_property_short_name
12314 = $table_property->short_name(\$table_property_short_name_length);
12315 my $table_property_full_name = $table_property->full_name;
12317 # Get how much savings there is in the short name over the full one
12318 # (delta will always be <= 0)
12319 my $table_property_short_delta = $table_property_short_name_length
12320 - length($table_property_full_name);
12321 my @table_description = $table->description;
12322 my @table_note = $table->note;
12324 # Generate an entry for each alias in this table.
12325 my $entry_for_first_alias; # saves the first one encountered.
12326 foreach my $alias ($table->aliases) {
12328 # Skip if not to go in pod.
12329 next unless $alias->make_pod_entry;
12331 # Start gathering all the components for the entry
12332 my $name = $alias->name;
12334 my $entry; # Holds the left column, may include extras
12335 my $entry_ref; # To refer to the left column's contents from
12336 # another entry; has no extras
12338 # First the left column of the pod entry. Tables for the $perl
12339 # property always use the single form.
12340 if ($table_property == $perl) {
12341 $entry = "\\p{$name}";
12342 $entry_ref = "\\p{$name}";
12344 else { # Compound form.
12346 # Only generate one entry for all the aliases that mean true
12347 # or false in binary properties. Append a '*' to indicate
12348 # some are missing. (The heading comment notes this.)
12349 my $wild_card_mark;
12350 if ($type == $BINARY) {
12351 next if $name ne 'N' && $name ne 'Y';
12352 $wild_card_mark = '*';
12355 $wild_card_mark = "";
12358 # Colon-space is used to give a little more space to be easier
12361 . $table_property_full_name
12362 . ": $name$wild_card_mark}";
12364 # But for the reference to this entry, which will go in the
12365 # right column, where space is at a premium, use equals
12367 $entry_ref = "\\p{" . $table_property_full_name . "=$name}";
12370 # Then the right (info) column. This is stored as components of
12371 # an array for the moment, then joined into a string later. For
12372 # non-internal only properties, begin the info with the entry for
12373 # the first table we encountered (if any), as things are ordered
12374 # so that that one is the most descriptive. This leads to the
12375 # info column of an entry being a more descriptive version of the
12378 if ($name =~ /^_/) {
12380 '(For internal use by Perl, not necessarily stable)';
12382 elsif ($entry_for_first_alias) {
12383 push @info, $entry_for_first_alias;
12386 # If this entry is equivalent to another, add that to the info,
12387 # using the first such table we encountered
12388 if ($entry_for_first_table) {
12390 push @info, "(= $entry_for_first_table)";
12393 push @info, $entry_for_first_table;
12397 # If the name is a large integer, add an equivalent with an
12398 # exponent for better readability
12399 if ($name =~ /^[+-]?[\d]+$/ && $name >= 10_000) {
12400 push @info, sprintf "(= %.1e)", $name
12403 my $parenthesized = "";
12404 if (! $entry_for_first_alias) {
12406 # This is the first alias for the current table. The alias
12407 # array is ordered so that this is the fullest, most
12408 # descriptive alias, so it gets the fullest info. The other
12409 # aliases are mostly merely pointers to this one, using the
12410 # information already added above.
12412 # Display any status message, but only on the parent table
12413 if ($status && ! $entry_for_first_table) {
12414 push @info, $status_info;
12417 # Put out any descriptive info
12418 if (@table_description || @table_note) {
12419 push @info, join "; ", @table_description, @table_note;
12422 # Look to see if there is a shorter name we can point people
12424 my $standard_name = standardize($name);
12426 my $proposed_short = $table->short_name;
12427 if (defined $proposed_short) {
12428 my $standard_short = standardize($proposed_short);
12430 # If the short name is shorter than the standard one, or
12431 # even it it's not, but the combination of it and its
12432 # short property name (as in \p{prop=short} ($perl doesn't
12433 # have this form)) saves at least two characters, then,
12434 # cause it to be listed as a shorter synonym.
12435 if (length $standard_short < length $standard_name
12436 || ($table_property != $perl
12437 && (length($standard_short)
12438 - length($standard_name)
12439 + $table_property_short_delta) # (<= 0)
12442 $short_name = $proposed_short;
12443 if ($table_property != $perl) {
12444 $short_name = $table_property_short_name
12447 $short_name = "\\p{$short_name}";
12451 # And if this is a compound form name, see if there is a
12452 # single form equivalent
12454 if ($table_property != $perl) {
12456 # Special case the binary N tables, so that will print
12457 # \P{single}, but use the Y table values to populate
12458 # 'single', as we haven't populated the N table.
12461 if ($type == $BINARY
12462 && $input_table == $property->table('No'))
12464 $test_table = $property->table('Yes');
12468 $test_table = $input_table;
12472 # Look for a single form amongst all the children.
12473 foreach my $table ($test_table->children) {
12474 next if $table->property != $perl;
12475 my $proposed_name = $table->short_name;
12476 next if ! defined $proposed_name;
12478 # Don't mention internal-only properties as a possible
12479 # single form synonym
12480 next if substr($proposed_name, 0, 1) eq '_';
12482 $proposed_name = "\\$p\{$proposed_name}";
12483 if (! defined $single_form
12484 || length($proposed_name) < length $single_form)
12486 $single_form = $proposed_name;
12488 # The goal here is to find a single form; not the
12489 # shortest possible one. We've already found a
12490 # short name. So, stop at the first single form
12491 # found, which is likely to be closer to the
12498 # Ouput both short and single in the same parenthesized
12499 # expression, but with only one of 'Single', 'Short' if there
12501 if ($short_name || $single_form || $table->conflicting) {
12502 $parenthesized .= '(';
12503 $parenthesized .= "Short: $short_name" if $short_name;
12504 if ($short_name && $single_form) {
12505 $parenthesized .= ', ';
12507 elsif ($single_form) {
12508 $parenthesized .= 'Single: ';
12510 $parenthesized .= $single_form if $single_form;
12515 # Warn if this property isn't the same as one that a
12516 # semi-casual user might expect. The other components of this
12517 # parenthesized structure are calculated only for the first entry
12518 # for this table, but the conflicting is deemed important enough
12519 # to go on every entry.
12520 my $conflicting = join " NOR ", $table->conflicting;
12521 if ($conflicting) {
12522 $parenthesized .= '(' if ! $parenthesized;
12523 $parenthesized .= '; ' if $parenthesized ne '(';
12524 $parenthesized .= "NOT $conflicting";
12526 $parenthesized .= ')' if $parenthesized;
12528 push @info, $parenthesized if $parenthesized;
12530 if ($table_property != $perl && $table->perl_extension) {
12531 push @info, '(Perl extension)';
12533 push @info, "($string_count)" if $output_range_counts;
12535 # Now, we have both the entry and info so add them to the
12536 # list of all the properties.
12537 push @match_properties,
12538 format_pod_line($indent_info_column,
12542 $alias->loose_match);
12544 $entry_for_first_alias = $entry_ref unless $entry_for_first_alias;
12545 } # End of looping through the aliases for this table.
12547 if (! $entry_for_first_table) {
12548 $entry_for_first_table = $entry_for_first_alias;
12550 } # End of looping through all the related tables
12554 sub pod_alphanumeric_sort {
12555 # Sort pod entries alphanumerically.
12557 # The first few character columns are filler, plus the '\p{'; and get rid
12558 # of all the trailing stuff, starting with the trailing '}', so as to sort
12559 # on just 'Name=Value'
12560 (my $a = lc $a) =~ s/^ .*? { //x;
12562 (my $b = lc $b) =~ s/^ .*? { //x;
12565 # Determine if the two operands are both internal only or both not.
12566 # Character 0 should be a '\'; 1 should be a p; 2 should be '{', so 3
12567 # should be the underscore that begins internal only
12568 my $a_is_internal = (substr($a, 0, 1) eq '_');
12569 my $b_is_internal = (substr($b, 0, 1) eq '_');
12571 # Sort so the internals come last in the table instead of first (which the
12572 # leading underscore would otherwise indicate).
12573 if ($a_is_internal != $b_is_internal) {
12574 return 1 if $a_is_internal;
12578 # Determine if the two operands are numeric property values or not.
12579 # A numeric property will look like xyz: 3. But the number
12580 # can begin with an optional minus sign, and may have a
12581 # fraction or rational component, like xyz: 3/2. If either
12582 # isn't numeric, use alphabetic sort.
12583 my ($a_initial, $a_number) =
12584 ($a =~ /^ ( [^:=]+ [:=] \s* ) (-? \d+ (?: [.\/] \d+)? )/ix);
12585 return $a cmp $b unless defined $a_number;
12586 my ($b_initial, $b_number) =
12587 ($b =~ /^ ( [^:=]+ [:=] \s* ) (-? \d+ (?: [.\/] \d+)? )/ix);
12588 return $a cmp $b unless defined $b_number;
12590 # Here they are both numeric, but use alphabetic sort if the
12591 # initial parts don't match
12592 return $a cmp $b if $a_initial ne $b_initial;
12594 # Convert rationals to floating for the comparison.
12595 $a_number = eval $a_number if $a_number =~ qr{/};
12596 $b_number = eval $b_number if $b_number =~ qr{/};
12598 return $a_number <=> $b_number;
12602 # Create the .pod file. This generates the various subsections and then
12603 # combines them in one big HERE document.
12605 return unless defined $pod_directory;
12606 print "Making pod file\n" if $verbosity >= $PROGRESS;
12608 my $exception_message =
12609 '(Any exceptions are individually noted beginning with the word NOT.)';
12611 if (-e 'Blocks.txt') {
12613 # Add the line: '\p{In_*} \p{Block: *}', with the warning message
12614 # if the global $has_In_conflicts indicates we have them.
12615 push @match_properties, format_pod_line($indent_info_column,
12618 . (($has_In_conflicts)
12619 ? " $exception_message"
12621 @block_warning = << "END";
12623 Matches in the Block property have shortcuts that begin with 'In_'. For
12624 example, \\p{Block=Latin1} can be written as \\p{In_Latin1}. For backward
12625 compatibility, if there is no conflict with another shortcut, these may also
12626 be written as \\p{Latin1} or \\p{Is_Latin1}. But, N.B., there are numerous
12627 such conflicting shortcuts. Use of these forms for Block is discouraged, and
12628 are flagged as such, not only because of the potential confusion as to what is
12629 meant, but also because a later release of Unicode may preempt the shortcut,
12630 and your program would no longer be correct. Use the 'In_' form instead to
12631 avoid this, or even more clearly, use the compound form, e.g.,
12632 \\p{blk:latin1}. See L<perlunicode/"Blocks"> for more information about this.
12635 my $text = "If an entry has flag(s) at its beginning, like '$DEPRECATED', the 'Is_' form has the same flag(s)";
12636 $text = "$exception_message $text" if $has_Is_conflicts;
12638 # And the 'Is_ line';
12639 push @match_properties, format_pod_line($indent_info_column,
12643 # Sort the properties array for output. It is sorted alphabetically
12644 # except numerically for numeric properties, and only output unique lines.
12645 @match_properties = sort pod_alphanumeric_sort uniques @match_properties;
12647 my $formatted_properties = simple_fold(\@match_properties,
12649 # indent succeeding lines by two extra
12650 # which looks better
12651 $indent_info_column + 2,
12653 # shorten the line length by how much
12654 # the formatter indents, so the folded
12655 # line will fit in the space
12656 # presumably available
12657 $automatic_pod_indent);
12658 # Add column headings, indented to be a little more centered, but not
12660 $formatted_properties = format_pod_line($indent_info_column,
12664 . $formatted_properties;
12666 # Generate pod documentation lines for the tables that match nothing
12668 if (@zero_match_tables) {
12669 @zero_match_tables = uniques(@zero_match_tables);
12670 $zero_matches = join "\n\n",
12671 map { $_ = '=item \p{' . $_->complete_name . "}" }
12672 sort { $a->complete_name cmp $b->complete_name }
12673 uniques(@zero_match_tables);
12675 $zero_matches = <<END;
12677 =head2 Legal \\p{} and \\P{} constructs that match no characters
12679 Unicode has some property-value pairs that currently don't match anything.
12680 This happens generally either because they are obsolete, or for symmetry with
12681 other forms, but no language has yet been encoded that uses them. In this
12682 version of Unicode, the following match zero code points:
12693 # Generate list of properties that we don't accept, grouped by the reasons
12694 # why. This is so only put out the 'why' once, and then list all the
12695 # properties that have that reason under it.
12697 my %why_list; # The keys are the reasons; the values are lists of
12698 # properties that have the key as their reason
12700 # For each property, add it to the list that are suppressed for its reason
12701 # The sort will cause the alphabetically first properties to be added to
12702 # each list first, so each list will be sorted.
12703 foreach my $property (sort keys %why_suppressed) {
12704 push @{$why_list{$why_suppressed{$property}}}, $property;
12707 # For each reason (sorted by the first property that has that reason)...
12708 my @bad_re_properties;
12709 foreach my $why (sort { $why_list{$a}->[0] cmp $why_list{$b}->[0] }
12712 # Add to the output, all the properties that have that reason. Start
12713 # with an empty line.
12714 push @bad_re_properties, "\n\n";
12716 my $has_item = 0; # Flag if actually output anything.
12717 foreach my $name (@{$why_list{$why}}) {
12719 # Split compound names into $property and $table components
12720 my $property = $name;
12722 if ($property =~ / (.*) = (.*) /x) {
12727 # This release of Unicode may not have a property that is
12728 # suppressed, so don't reference a non-existent one.
12729 $property = property_ref($property);
12730 next if ! defined $property;
12732 # And since this list is only for match tables, don't list the
12733 # ones that don't have match tables.
12734 next if ! $property->to_create_match_tables;
12736 # Find any abbreviation, and turn it into a compound name if this
12737 # is a property=value pair.
12738 my $short_name = $property->name;
12739 $short_name .= '=' . $property->table($table)->name if $table;
12741 # And add the property as an item for the reason.
12742 push @bad_re_properties, "\n=item I<$name> ($short_name)\n";
12746 # And add the reason under the list of properties, if such a list
12747 # actually got generated. Note that the header got added
12748 # unconditionally before. But pod ignores extra blank lines, so no
12750 push @bad_re_properties, "\n$why\n" if $has_item;
12752 } # End of looping through each reason.
12754 # Generate a list of the properties whose map table we output, from the
12755 # global @map_properties.
12756 my @map_tables_actually_output;
12757 my $info_indent = 20; # Left column is narrower than \p{} table.
12758 foreach my $property (@map_properties) {
12760 # Get the path to the file; don't output any not in the standard
12762 my @path = $property->file_path;
12763 next if $path[0] ne $map_directory;
12764 shift @path; # Remove the standard name
12766 my $file = join '/', @path; # In case is in sub directory
12767 my $info = $property->full_name;
12768 my $short_name = $property->name;
12769 if ($info ne $short_name) {
12770 $info .= " ($short_name)";
12772 foreach my $more_info ($property->description,
12774 $property->status_info)
12776 next unless $more_info;
12778 $info .= ". $more_info";
12780 push @map_tables_actually_output, format_pod_line($info_indent,
12783 $property->status);
12786 # Sort alphabetically, and fold for output
12787 @map_tables_actually_output = sort
12788 pod_alphanumeric_sort @map_tables_actually_output;
12789 @map_tables_actually_output
12790 = simple_fold(\@map_tables_actually_output,
12793 $automatic_pod_indent);
12795 # Generate a list of the formats that can appear in the map tables.
12796 my @map_table_formats;
12797 foreach my $format (sort keys %map_table_formats) {
12798 push @map_table_formats, " $format $map_table_formats{$format}\n";
12801 # Everything is ready to assemble.
12802 my @OUT = << "END";
12807 To change this file, edit $0 instead.
12813 $pod_file - Index of Unicode Version $string_version properties in Perl
12817 There are many properties in Unicode, and Perl provides access to almost all of
12818 them, as well as some additional extensions and short-cut synonyms.
12820 And just about all of the few that aren't accessible through the Perl
12821 core are accessible through the modules: Unicode::Normalize and
12822 Unicode::UCD, and for Unihan properties, via the CPAN module Unicode::Unihan.
12824 This document merely lists all available properties and does not attempt to
12825 explain what each property really means. There is a brief description of each
12826 Perl extension. There is some detail about Blocks, Scripts, General_Category,
12827 and Bidi_Class in L<perlunicode>, but to find out about the intricacies of the
12828 Unicode properties, refer to the Unicode standard. A good starting place is
12829 L<$unicode_reference_url>. More information on the Perl extensions is in
12830 L<perlrecharclass>.
12832 Note that you can define your own properties; see
12833 L<perlunicode/"User-Defined Character Properties">.
12835 =head1 Properties accessible through \\p{} and \\P{}
12837 The Perl regular expression \\p{} and \\P{} constructs give access to most of
12838 the Unicode character properties. The table below shows all these constructs,
12839 both single and compound forms.
12841 B<Compound forms> consist of two components, separated by an equals sign or a
12842 colon. The first component is the property name, and the second component is
12843 the particular value of the property to match against, for example,
12844 '\\p{Script: Greek}' or '\\p{Script=Greek}' both mean to match characters
12845 whose Script property is Greek.
12847 B<Single forms>, like '\\p{Greek}', are mostly Perl-defined shortcuts for
12848 their equivalent compound forms. The table shows these equivalences. (In our
12849 example, '\\p{Greek}' is a just a shortcut for '\\p{Script=Greek}'.)
12850 There are also a few Perl-defined single forms that are not shortcuts for a
12851 compound form. One such is \\p{Word}. These are also listed in the table.
12853 In parsing these constructs, Perl always ignores Upper/lower case differences
12854 everywhere within the {braces}. Thus '\\p{Greek}' means the same thing as
12855 '\\p{greek}'. But note that changing the case of the 'p' or 'P' before the
12856 left brace completely changes the meaning of the construct, from "match" (for
12857 '\\p{}') to "doesn't match" (for '\\P{}'). Casing in this document is for
12858 improved legibility.
12860 Also, white space, hyphens, and underscores are also normally ignored
12861 everywhere between the {braces}, and hence can be freely added or removed
12862 even if the C</x> modifier hasn't been specified on the regular expression.
12863 But $a_bold_stricter at the beginning of an entry in the table below
12864 means that tighter (stricter) rules are used for that entry:
12868 =item Single form (\\p{name}) tighter rules:
12870 White space, hyphens, and underscores ARE significant
12875 =item * white space adjacent to a non-word character
12877 =item * underscores separating digits in numbers
12881 That means, for example, that you can freely add or remove white space
12882 adjacent to (but within) the braces without affecting the meaning.
12884 =item Compound form (\\p{name=value} or \\p{name:value}) tighter rules:
12886 The tighter rules given above for the single form apply to everything to the
12887 right of the colon or equals; the looser rules still apply to everything to
12890 That means, for example, that you can freely add or remove white space
12891 adjacent to (but within) the braces and the colon or equal sign.
12895 Some properties are considered obsolete, but still available. There are
12896 several varieties of obsolesence:
12902 Properties marked with $a_bold_obsolete in the table are considered
12903 obsolete. At the time of this writing (Unicode version 5.2) there is no
12904 information in the Unicode standard about the implications of a property being
12909 Obsolete properties may be stabilized. This means that they are not actively
12910 maintained by Unicode, and will not be extended as new characters are added to
12911 the standard. Such properties are marked with $a_bold_stabilized in the
12912 table. At the time of this writing (Unicode version 5.2) there is no further
12913 information in the Unicode standard about the implications of a property being
12918 Obsolete properties may be deprecated. This means that their use is strongly
12919 discouraged, so much so that a warning will be issued if used, unless the
12920 regular expression is in the scope of a C<S<no warnings 'deprecated'>>
12921 statement. $A_bold_deprecated flags each such entry in the table, and
12922 the entry there for the longest, most descriptive version of the property will
12923 give the reason it is deprecated, and perhaps advice. Perl may issue such a
12924 warning, even for properties that aren't officially deprecated by Unicode,
12925 when there used to be characters or code points that were matched by them, but
12926 no longer. This is to warn you that your program may not work like it did on
12927 earlier Unicode releases.
12929 A deprecated property may be made unavailable in a future Perl version, so it
12930 is best to move away from them.
12934 Some Perl extensions are present for backwards compatibility and are
12935 discouraged from being used, but not obsolete. $A_bold_discouraged
12936 flags each such entry in the table.
12940 The table below has two columns. The left column contains the \\p{}
12941 constructs to look up, possibly preceeded by the flags mentioned above; and
12942 the right column contains information about them, like a description, or
12943 synonyms. It shows both the single and compound forms for each property that
12944 has them. If the left column is a short name for a property, the right column
12945 will give its longer, more descriptive name; and if the left column is the
12946 longest name, the right column will show any equivalent shortest name, in both
12947 single and compound forms if applicable.
12949 The right column will also caution you if a property means something different
12950 than what might normally be expected.
12952 All single forms are Perl extensions; a few compound forms are as well, and
12955 Numbers in (parentheses) indicate the total number of code points matched by
12956 the property. For emphasis, those properties that match no code points at all
12957 are listed as well in a separate section following the table.
12959 There is no description given for most non-Perl defined properties (See
12960 $unicode_reference_url for that).
12962 For compactness, 'B<*>' is used as a wildcard instead of showing all possible
12963 combinations. For example, entries like:
12965 \\p{Gc: *} \\p{General_Category: *}
12967 mean that 'Gc' is a synonym for 'General_Category', and anything that is valid
12968 for the latter is also valid for the former. Similarly,
12972 means that if and only if, for example, \\p{Foo} exists, then \\p{Is_Foo} and
12973 \\p{IsFoo} are also valid and all mean the same thing. And similarly,
12974 \\p{Foo=Bar} means the same as \\p{Is_Foo=Bar} and \\p{IsFoo=Bar}. '*' here
12975 is restricted to something not beginning with an underscore.
12977 Also, in binary properties, 'Yes', 'T', and 'True' are all synonyms for 'Y'.
12978 And 'No', 'F', and 'False' are all synonyms for 'N'. The table shows 'Y*' and
12979 'N*' to indicate this, and doesn't have separate entries for the other
12980 possibilities. Note that not all properties which have values 'Yes' and 'No'
12981 are binary, and they have all their values spelled out without using this wild
12982 card, and a C<NOT> clause in their description that highlights their not being
12983 binary. These also require the compound form to match them, whereas true
12984 binary properties have both single and compound forms available.
12986 Note that all non-essential underscores are removed in the display of the
12993 =item B<*> is a wild-card
12995 =item B<(\\d+)> in the info column gives the number of code points matched by
12998 =item B<$DEPRECATED> means this is deprecated.
13000 =item B<$OBSOLETE> means this is obsolete.
13002 =item B<$STABILIZED> means this is stabilized.
13004 =item B<$STRICTER> means tighter (stricter) name matching applies.
13006 =item B<$DISCOURAGED> means use of this form is discouraged.
13010 $formatted_properties
13014 =head1 Properties not accessible through \\p{} and \\P{}
13016 A few properties are accessible in Perl via various function calls only.
13018 Lowercase_Mapping lc() and lcfirst()
13019 Titlecase_Mapping ucfirst()
13020 Uppercase_Mapping uc()
13022 Case_Folding is accessible through the /i modifier in regular expressions.
13024 The Name property is accessible through the \\N{} interpolation in
13025 double-quoted strings and regular expressions, but both usages require a C<use
13026 charnames;> to be specified, which also contains related functions viacode(),
13027 vianame(), and string_vianame().
13029 =head1 Unicode regular expression properties that are NOT accepted by Perl
13031 Perl will generate an error for a few character properties in Unicode when
13032 used in a regular expression. The non-Unihan ones are listed below, with the
13033 reasons they are not accepted, perhaps with work-arounds. The short names for
13034 the properties are listed enclosed in (parentheses).
13042 An installation can choose to allow any of these to be matched by changing the
13043 controlling lists contained in the program C<\$Config{privlib}>/F<unicore/$0>
13044 and then re-running F<$0>. (C<\%Config> is available from the Config module).
13046 =head1 Files in the I<To> directory (for serious hackers only)
13048 All Unicode properties are really mappings (in the mathematical sense) from
13049 code points to their respective values. As part of its build process,
13050 Perl constructs tables containing these mappings for all properties that it
13051 deals with. But only a few of these are written out into files.
13052 Those written out are in the directory C<\$Config{privlib}>/F<unicore/To/>
13053 (%Config is available from the Config module).
13055 Those ones written are ones needed by Perl internally during execution, or for
13056 which there is some demand, and those for which there is no access through the
13057 Perl core. Generally, properties that can be used in regular expression
13058 matching do not have their map tables written, like Script. Nor are the
13059 simplistic properties that have a better, more complete version, such as
13060 Simple_Uppercase_Mapping (Uppercase_Mapping is written instead).
13062 None of the properties in the I<To> directory are currently directly
13063 accessible through the Perl core, although some may be accessed indirectly.
13064 For example, the uc() function implements the Uppercase_Mapping property and
13065 uses the F<Upper.pl> file found in this directory.
13067 The available files in the current installation, with their properties (short
13068 names in parentheses), and any flags or comments about them, are:
13070 @map_tables_actually_output
13072 An installation can choose to change which files are generated by changing the
13073 controlling lists contained in the program C<\$Config{privlib}>/F<unicore/$0>
13074 and then re-running F<$0>.
13076 Each of these files defines two hash entries to help reading programs decipher
13077 it. One of them looks like this:
13079 \$utf8::SwashInfo{'ToNAME'}{'format'} = 's';
13081 where 'NAME' is a name to indicate the property. For backwards compatibility,
13082 this is not necessarily the property's official Unicode name. (The 'To' is
13083 also for backwards compatibility.) The hash entry gives the format of the
13084 mapping fields of the table, currently one of the following:
13088 This format applies only to the entries in the main body of the table.
13089 Entries defined in hashes or ones that are missing from the list can have a
13092 The value that the missing entries have is given by the other SwashInfo hash
13093 entry line; it looks like this:
13095 \$utf8::SwashInfo{'ToNAME'}{'missing'} = 'NaN';
13097 This example line says that any Unicode code points not explicitly listed in
13098 the file have the value 'NaN' under the property indicated by NAME. If the
13099 value is the special string C<< <code point> >>, it means that the value for
13100 any missing code point is the code point itself. This happens, for example,
13101 in the file for Uppercase_Mapping (To/Upper.pl), in which code points like the
13102 character 'A', are missing because the uppercase of 'A' is itself.
13106 L<$unicode_reference_url>
13114 # And write it. The 0 means no utf8.
13115 main::write([ $pod_directory, "$pod_file.pod" ], 0, \@OUT);
13119 sub make_Heavy () {
13120 # Create and write Heavy.pl, which passes info about the tables to
13127 # This file is for the use of utf8_heavy.pl
13129 # Maps property names in loose standard form to its standard name
13130 \%utf8::loose_property_name_of = (
13133 push @heavy, simple_dumper (\%loose_property_name_of, ' ' x 4);
13134 push @heavy, <<END;
13137 # Maps property, table to file for those using stricter matching
13138 \%utf8::stricter_to_file_of = (
13140 push @heavy, simple_dumper (\%stricter_to_file_of, ' ' x 4);
13141 push @heavy, <<END;
13144 # Maps property, table to file for those using loose matching
13145 \%utf8::loose_to_file_of = (
13147 push @heavy, simple_dumper (\%loose_to_file_of, ' ' x 4);
13148 push @heavy, <<END;
13151 # Maps floating point to fractional form
13152 \%utf8::nv_floating_to_rational = (
13154 push @heavy, simple_dumper (\%nv_floating_to_rational, ' ' x 4);
13155 push @heavy, <<END;
13158 # If a floating point number doesn't have enough digits in it to get this
13159 # close to a fraction, it isn't considered to be that fraction even if all the
13160 # digits it does have match.
13161 \$utf8::max_floating_slop = $MAX_FLOATING_SLOP;
13163 # Deprecated tables to generate a warning for. The key is the file containing
13164 # the table, so as to avoid duplication, as many property names can map to the
13165 # file, but we only need one entry for all of them.
13166 \%utf8::why_deprecated = (
13169 push @heavy, simple_dumper (\%utf8::why_deprecated, ' ' x 4);
13170 push @heavy, <<END;
13176 main::write("Heavy.pl", 0, \@heavy); # The 0 means no utf8.
13180 sub write_all_tables() {
13181 # Write out all the tables generated by this program to files, as well as
13182 # the supporting data structures, pod file, and .t file.
13184 my @writables; # List of tables that actually get written
13185 my %match_tables_to_write; # Used to collapse identical match tables
13186 # into one file. Each key is a hash function
13187 # result to partition tables into buckets.
13188 # Each value is an array of the tables that
13189 # fit in the bucket.
13191 # For each property ...
13192 # (sort so that if there is an immutable file name, it has precedence, so
13193 # some other property can't come in and take over its file name. If b's
13194 # file name is defined, will return 1, meaning to take it first; don't
13195 # care if both defined, as they had better be different anyway)
13197 foreach my $property (sort { defined $b->file } property_ref('*')) {
13198 my $type = $property->type;
13200 # And for each table for that property, starting with the mapping
13203 foreach my $table($property,
13205 # and all the match tables for it (if any), sorted so
13206 # the ones with the shortest associated file name come
13207 # first. The length sorting prevents problems of a
13208 # longer file taking a name that might have to be used
13209 # by a shorter one. The alphabetic sorting prevents
13210 # differences between releases
13211 sort { my $ext_a = $a->external_name;
13212 return 1 if ! defined $ext_a;
13213 my $ext_b = $b->external_name;
13214 return -1 if ! defined $ext_b;
13215 my $cmp = length $ext_a <=> length $ext_b;
13217 # Return result if lengths not equal
13218 return $cmp if $cmp;
13220 # Alphabetic if lengths equal
13221 return $ext_a cmp $ext_b
13222 } $property->tables
13226 # Here we have a table associated with a property. It could be
13227 # the map table (done first for each property), or one of the
13228 # other tables. Determine which type.
13229 my $is_property = $table->isa('Property');
13231 my $name = $table->name;
13232 my $complete_name = $table->complete_name;
13234 # See if should suppress the table if is empty, but warn if it
13235 # contains something.
13236 my $suppress_if_empty_warn_if_not = grep { $complete_name eq $_ }
13237 keys %why_suppress_if_empty_warn_if_not;
13239 # Calculate if this table should have any code points associated
13241 my $expected_empty =
13243 # $perl should be empty, as well as properties that we just
13244 # don't do anything with
13246 && ($table == $perl
13247 || grep { $complete_name eq $_ }
13248 @unimplemented_properties
13252 # Match tables in properties we skipped populating should be
13254 || (! $is_property && ! $property->to_create_match_tables)
13256 # Tables and properties that are expected to have no code
13257 # points should be empty
13258 || $suppress_if_empty_warn_if_not
13261 # Set a boolean if this table is the complement of an empty binary
13263 my $is_complement_of_empty_binary =
13264 $type == $BINARY &&
13265 (($table == $property->table('Y')
13266 && $property->table('N')->is_empty)
13267 || ($table == $property->table('N')
13268 && $property->table('Y')->is_empty));
13271 # Some tables should match everything
13272 my $expected_full =
13274 ? # All these types of map tables will be full because
13275 # they will have been populated with defaults
13276 ($type == $ENUM || $type == $BINARY)
13278 : # A match table should match everything if its method
13280 ($table->matches_all
13282 # The complement of an empty binary table will match
13284 || $is_complement_of_empty_binary
13288 if ($table->is_empty) {
13291 if ($suppress_if_empty_warn_if_not) {
13292 $table->set_status($SUPPRESSED,
13293 $why_suppress_if_empty_warn_if_not{$complete_name});
13296 # Suppress expected empty tables.
13297 next TABLE if $expected_empty;
13299 # And setup to later output a warning for those that aren't
13300 # known to be allowed to be empty. Don't do the warning if
13301 # this table is a child of another one to avoid duplicating
13302 # the warning that should come from the parent one.
13303 if (($table == $property || $table->parent == $table)
13304 && $table->status ne $SUPPRESSED
13305 && ! grep { $complete_name =~ /^$_$/ }
13306 @tables_that_may_be_empty)
13308 push @unhandled_properties, "$table";
13311 elsif ($expected_empty) {
13313 if ($suppress_if_empty_warn_if_not) {
13314 $because = " because $why_suppress_if_empty_warn_if_not{$complete_name}";
13317 Carp::my_carp("Not expecting property $table$because. Generating file for it anyway.");
13320 my $count = $table->count;
13321 if ($expected_full) {
13322 if ($count != $MAX_UNICODE_CODEPOINTS) {
13323 Carp::my_carp("$table matches only "
13324 . clarify_number($count)
13325 . " Unicode code points but should match "
13326 . clarify_number($MAX_UNICODE_CODEPOINTS)
13328 . clarify_number(abs($MAX_UNICODE_CODEPOINTS - $count))
13329 . "). Proceeding anyway.");
13332 # Here is expected to be full. If it is because it is the
13333 # complement of an (empty) binary table that is to be
13334 # suppressed, then suppress this one as well.
13335 if ($is_complement_of_empty_binary) {
13336 my $opposing_name = ($name eq 'Y') ? 'N' : 'Y';
13337 my $opposing = $property->table($opposing_name);
13338 my $opposing_status = $opposing->status;
13339 if ($opposing_status) {
13340 $table->set_status($opposing_status,
13341 $opposing->status_info);
13345 elsif ($count == $MAX_UNICODE_CODEPOINTS) {
13346 if ($table == $property || $table->leader == $table) {
13347 Carp::my_carp("$table unexpectedly matches all Unicode code points. Proceeding anyway.");
13351 if ($table->status eq $SUPPRESSED) {
13352 if (! $is_property) {
13353 my @children = $table->children;
13354 foreach my $child (@children) {
13355 if ($child->status ne $SUPPRESSED) {
13356 Carp::my_carp_bug("'$table' is suppressed and has a child '$child' which isn't");
13363 if (! $is_property) {
13365 # Several things need to be done just once for each related
13366 # group of match tables. Do them on the parent.
13367 if ($table->parent == $table) {
13369 # Add an entry in the pod file for the table; it also does
13371 make_table_pod_entries($table) if defined $pod_directory;
13373 # See if the the table matches identical code points with
13374 # something that has already been output. In that case,
13375 # no need to have two files with the same code points in
13376 # them. We use the table's hash() method to store these
13377 # in buckets, so that it is quite likely that if two
13378 # tables are in the same bucket they will be identical, so
13379 # don't have to compare tables frequently. The tables
13380 # have to have the same status to share a file, so add
13381 # this to the bucket hash. (The reason for this latter is
13382 # that Heavy.pl associates a status with a file.)
13383 my $hash = $table->hash . ';' . $table->status;
13385 # Look at each table that is in the same bucket as this
13387 foreach my $comparison (@{$match_tables_to_write{$hash}})
13389 if ($table->matches_identically_to($comparison)) {
13390 $table->set_equivalent_to($comparison,
13396 # Here, not equivalent, add this table to the bucket.
13397 push @{$match_tables_to_write{$hash}}, $table;
13402 # Here is the property itself.
13403 # Don't write out or make references to the $perl property
13404 next if $table == $perl;
13406 if ($type != $STRING) {
13408 # There is a mapping stored of the various synonyms to the
13409 # standardized name of the property for utf8_heavy.pl.
13410 # Also, the pod file contains entries of the form:
13411 # \p{alias: *} \p{full: *}
13412 # rather than show every possible combination of things.
13414 my @property_aliases = $property->aliases;
13416 # The full name of this property is stored by convention
13417 # first in the alias array
13418 my $full_property_name =
13419 '\p{' . $property_aliases[0]->name . ': *}';
13420 my $standard_property_name = standardize($table->name);
13422 # For each synonym ...
13423 for my $i (0 .. @property_aliases - 1) {
13424 my $alias = $property_aliases[$i];
13425 my $alias_name = $alias->name;
13426 my $alias_standard = standardize($alias_name);
13428 # Set the mapping for utf8_heavy of the alias to the
13430 if (exists ($loose_property_name_of{$alias_standard}))
13432 Carp::my_carp("There already is a property with the same standard name as $alias_name: $loose_property_name_of{$alias_standard}. Old name is retained");
13435 $loose_property_name_of{$alias_standard}
13436 = $standard_property_name;
13439 # Now for the pod entry for this alias. Skip if not
13440 # outputting a pod; skip the first one, which is the
13441 # full name so won't have an entry like: '\p{full: *}
13442 # \p{full: *}', and skip if don't want an entry for
13445 || ! defined $pod_directory
13446 || ! $alias->make_pod_entry;
13448 my $rhs = $full_property_name;
13449 if ($property != $perl && $table->perl_extension) {
13450 $rhs .= ' (Perl extension)';
13452 push @match_properties,
13453 format_pod_line($indent_info_column,
13454 '\p{' . $alias->name . ': *}',
13458 } # End of non-string-like property code
13461 # Don't output a mapping file if not desired.
13462 next if ! $property->to_output_map;
13465 # Here, we know we want to write out the table, but don't do it
13466 # yet because there may be other tables that come along and will
13467 # want to share the file, and the file's comments will change to
13468 # mention them. So save for later.
13469 push @writables, $table;
13471 } # End of looping through the property and all its tables.
13472 } # End of looping through all properties.
13474 # Now have all the tables that will have files written for them. Do it.
13475 foreach my $table (@writables) {
13478 my $property = $table->property;
13479 my $is_property = ($table == $property);
13480 if (! $is_property) {
13482 # Match tables for the property go in lib/$subdirectory, which is
13483 # the property's name. Don't use the standard file name for this,
13484 # as may get an unfamiliar alias
13485 @directory = ($matches_directory, $property->external_name);
13489 @directory = $table->directory;
13490 $filename = $table->file;
13493 # Use specified filename if avaliable, or default to property's
13494 # shortest name. We need an 8.3 safe filename (which means "an 8
13495 # safe" filename, since after the dot is only 'pl', which is < 3)
13496 # The 2nd parameter is if the filename shouldn't be changed, and
13497 # it shouldn't iff there is a hard-coded name for this table.
13498 $filename = construct_filename(
13499 $filename || $table->external_name,
13500 ! $filename, # mutable if no filename
13503 register_file_for_name($table, \@directory, $filename);
13505 # Only need to write one file when shared by more than one
13507 next if ! $is_property && $table->leader != $table;
13509 # Construct a nice comment to add to the file
13510 $table->set_final_comment;
13516 # Write out the pod file
13522 make_property_test_script() if $make_test_script;
13526 my @white_space_separators = ( # This used only for making the test script.
13533 sub generate_separator($) {
13534 # This used only for making the test script. It generates the colon or
13535 # equal separator between the property and property value, with random
13536 # white space surrounding the separator
13540 return "" if $lhs eq ""; # No separator if there's only one (the r) side
13542 # Choose space before and after randomly
13543 my $spaces_before =$white_space_separators[rand(@white_space_separators)];
13544 my $spaces_after = $white_space_separators[rand(@white_space_separators)];
13546 # And return the whole complex, half the time using a colon, half the
13548 return $spaces_before
13549 . (rand() < 0.5) ? '=' : ':'
13553 sub generate_tests($$$$$) {
13554 # This used only for making the test script. It generates test cases that
13555 # are expected to compile successfully in perl. Note that the lhs and
13556 # rhs are assumed to already be as randomized as the caller wants.
13558 my $lhs = shift; # The property: what's to the left of the colon
13559 # or equals separator
13560 my $rhs = shift; # The property value; what's to the right
13561 my $valid_code = shift; # A code point that's known to be in the
13562 # table given by lhs=rhs; undef if table is
13564 my $invalid_code = shift; # A code point known to not be in the table;
13565 # undef if the table is all code points
13566 my $warning = shift;
13568 # Get the colon or equal
13569 my $separator = generate_separator($lhs);
13571 # The whole 'property=value'
13572 my $name = "$lhs$separator$rhs";
13575 # Create a complete set of tests, with complements.
13576 if (defined $valid_code) {
13577 push @output, <<"EOC"
13578 Expect(1, $valid_code, '\\p{$name}', $warning);
13579 Expect(0, $valid_code, '\\p{^$name}', $warning);
13580 Expect(0, $valid_code, '\\P{$name}', $warning);
13581 Expect(1, $valid_code, '\\P{^$name}', $warning);
13584 if (defined $invalid_code) {
13585 push @output, <<"EOC"
13586 Expect(0, $invalid_code, '\\p{$name}', $warning);
13587 Expect(1, $invalid_code, '\\p{^$name}', $warning);
13588 Expect(1, $invalid_code, '\\P{$name}', $warning);
13589 Expect(0, $invalid_code, '\\P{^$name}', $warning);
13595 sub generate_error($$$) {
13596 # This used only for making the test script. It generates test cases that
13597 # are expected to not only not match, but to be syntax or similar errors
13599 my $lhs = shift; # The property: what's to the left of the
13600 # colon or equals separator
13601 my $rhs = shift; # The property value; what's to the right
13602 my $already_in_error = shift; # Boolean; if true it's known that the
13603 # unmodified lhs and rhs will cause an error.
13604 # This routine should not force another one
13605 # Get the colon or equal
13606 my $separator = generate_separator($lhs);
13608 # Since this is an error only, don't bother to randomly decide whether to
13609 # put the error on the left or right side; and assume that the rhs is
13610 # loosely matched, again for convenience rather than rigor.
13611 $rhs = randomize_loose_name($rhs, 'ERROR') unless $already_in_error;
13613 my $property = $lhs . $separator . $rhs;
13616 Error('\\p{$property}');
13617 Error('\\P{$property}');
13621 # These are used only for making the test script
13622 # XXX Maybe should also have a bad strict seps, which includes underscore.
13624 my @good_loose_seps = (
13631 my @bad_loose_seps = (
13636 sub randomize_stricter_name {
13637 # This used only for making the test script. Take the input name and
13638 # return a randomized, but valid version of it under the stricter matching
13642 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
13644 # If the name looks like a number (integer, floating, or rational), do
13646 if ($name =~ qr{ ^ ( -? ) (\d+ ( ( [./] ) \d+ )? ) $ }x) {
13649 my $separator = $3;
13651 # If there isn't a sign, part of the time add a plus
13652 # Note: Not testing having any denominator having a minus sign
13654 $sign = '+' if rand() <= .3;
13657 # And add 0 or more leading zeros.
13658 $name = $sign . ('0' x int rand(10)) . $number;
13660 if (defined $separator) {
13661 my $extra_zeros = '0' x int rand(10);
13663 if ($separator eq '.') {
13665 # Similarly, add 0 or more trailing zeros after a decimal
13667 $name .= $extra_zeros;
13671 # Or, leading zeros before the denominator
13672 $name =~ s,/,/$extra_zeros,;
13677 # For legibility of the test, only change the case of whole sections at a
13678 # time. To do this, first split into sections. The split returns the
13681 for my $section (split / ( [ - + \s _ . ]+ ) /x, $name) {
13682 trace $section if main::DEBUG && $to_trace;
13684 if (length $section > 1 && $section !~ /\D/) {
13686 # If the section is a sequence of digits, about half the time
13687 # randomly add underscores between some of them.
13690 # Figure out how many underscores to add. max is 1 less than
13691 # the number of digits. (But add 1 at the end to make sure
13692 # result isn't 0, and compensate earlier by subtracting 2
13694 my $num_underscores = int rand(length($section) - 2) + 1;
13696 # And add them evenly throughout, for convenience, not rigor
13698 my $spacing = (length($section) - 1)/ $num_underscores;
13699 my $temp = $section;
13701 for my $i (1 .. $num_underscores) {
13702 $section .= substr($temp, 0, $spacing, "") . '_';
13706 push @sections, $section;
13710 # Here not a sequence of digits. Change the case of the section
13712 my $switch = int rand(4);
13713 if ($switch == 0) {
13714 push @sections, uc $section;
13716 elsif ($switch == 1) {
13717 push @sections, lc $section;
13719 elsif ($switch == 2) {
13720 push @sections, ucfirst $section;
13723 push @sections, $section;
13727 trace "returning", join "", @sections if main::DEBUG && $to_trace;
13728 return join "", @sections;
13731 sub randomize_loose_name($;$) {
13732 # This used only for making the test script
13735 my $want_error = shift; # if true, make an error
13736 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
13738 $name = randomize_stricter_name($name);
13741 push @parts, $good_loose_seps[rand(@good_loose_seps)];
13742 for my $part (split /[-\s_]+/, $name) {
13744 if ($want_error and rand() < 0.3) {
13745 push @parts, $bad_loose_seps[rand(@bad_loose_seps)];
13749 push @parts, $good_loose_seps[rand(@good_loose_seps)];
13752 push @parts, $part;
13754 my $new = join("", @parts);
13755 trace "$name => $new" if main::DEBUG && $to_trace;
13758 if (rand() >= 0.5) {
13759 $new .= $bad_loose_seps[rand(@bad_loose_seps)];
13762 $new = $bad_loose_seps[rand(@bad_loose_seps)] . $new;
13768 # Used to make sure don't generate duplicate test cases.
13769 my %test_generated;
13771 sub make_property_test_script() {
13772 # This used only for making the test script
13773 # this written directly -- it's huge.
13775 print "Making test script\n" if $verbosity >= $PROGRESS;
13777 # This uses randomness to test different possibilities without testing all
13778 # possibilities. To ensure repeatability, set the seed to 0. But if
13779 # tests are added, it will perturb all later ones in the .t file
13782 $t_path = 'TestProp.pl' unless defined $t_path; # the traditional name
13784 # Keep going down an order of magnitude
13785 # until find that adding this quantity to
13786 # 1 remains 1; but put an upper limit on
13787 # this so in case this algorithm doesn't
13788 # work properly on some platform, that we
13789 # won't loop forever.
13791 my $min_floating_slop = 1;
13792 while (1+ $min_floating_slop != 1
13795 my $next = $min_floating_slop / 10;
13796 last if $next == 0; # If underflows,
13798 $min_floating_slop = $next;
13801 # It doesn't matter whether the elements of this array contain single lines
13802 # or multiple lines. main::write doesn't count the lines.
13805 foreach my $property (property_ref('*')) {
13806 foreach my $table ($property->tables) {
13808 # Find code points that match, and don't match this table.
13809 my $valid = $table->get_valid_code_point;
13810 my $invalid = $table->get_invalid_code_point;
13811 my $warning = ($table->status eq $DEPRECATED)
13815 # Test each possible combination of the property's aliases with
13816 # the table's. If this gets to be too many, could do what is done
13817 # in the set_final_comment() for Tables
13818 my @table_aliases = $table->aliases;
13819 my @property_aliases = $table->property->aliases;
13820 my $max = max(scalar @table_aliases, scalar @property_aliases);
13821 for my $j (0 .. $max - 1) {
13823 # The current alias for property is the next one on the list,
13824 # or if beyond the end, start over. Similarly for table
13826 = $property_aliases[$j % @property_aliases]->name;
13828 $property_name = "" if $table->property == $perl;
13829 my $table_alias = $table_aliases[$j % @table_aliases];
13830 my $table_name = $table_alias->name;
13831 my $loose_match = $table_alias->loose_match;
13833 # If the table doesn't have a file, any test for it is
13834 # already guaranteed to be in error
13835 my $already_error = ! $table->file_path;
13837 # Generate error cases for this alias.
13838 push @output, generate_error($property_name,
13842 # If the table is guaranteed to always generate an error,
13843 # quit now without generating success cases.
13844 next if $already_error;
13846 # Now for the success cases.
13848 if ($loose_match) {
13850 # For loose matching, create an extra test case for the
13852 my $standard = standardize($table_name);
13854 # $test_name should be a unique combination for each test
13855 # case; used just to avoid duplicate tests
13856 my $test_name = "$property_name=$standard";
13858 # Don't output duplicate test cases.
13859 if (! exists $test_generated{$test_name}) {
13860 $test_generated{$test_name} = 1;
13861 push @output, generate_tests($property_name,
13868 $random = randomize_loose_name($table_name)
13870 else { # Stricter match
13871 $random = randomize_stricter_name($table_name);
13874 # Now for the main test case for this alias.
13875 my $test_name = "$property_name=$random";
13876 if (! exists $test_generated{$test_name}) {
13877 $test_generated{$test_name} = 1;
13878 push @output, generate_tests($property_name,
13885 # If the name is a rational number, add tests for the
13886 # floating point equivalent.
13887 if ($table_name =~ qr{/}) {
13889 # Calculate the float, and find just the fraction.
13890 my $float = eval $table_name;
13891 my ($whole, $fraction)
13892 = $float =~ / (.*) \. (.*) /x;
13894 # Starting with one digit after the decimal point,
13895 # create a test for each possible precision (number of
13896 # digits past the decimal point) until well beyond the
13897 # native number found on this machine. (If we started
13898 # with 0 digits, it would be an integer, which could
13899 # well match an unrelated table)
13901 for my $i (1 .. $min_floating_slop + 3) {
13902 my $table_name = sprintf("%.*f", $i, $float);
13903 if ($i < $MIN_FRACTION_LENGTH) {
13905 # If the test case has fewer digits than the
13906 # minimum acceptable precision, it shouldn't
13907 # succeed, so we expect an error for it.
13908 # E.g., 2/3 = .7 at one decimal point, and we
13909 # shouldn't say it matches .7. We should make
13910 # it be .667 at least before agreeing that the
13911 # intent was to match 2/3. But at the
13912 # less-than- acceptable level of precision, it
13913 # might actually match an unrelated number.
13914 # So don't generate a test case if this
13915 # conflating is possible. In our example, we
13916 # don't want 2/3 matching 7/10, if there is
13917 # a 7/10 code point.
13919 (keys %nv_floating_to_rational)
13922 if abs($table_name - $existing)
13923 < $MAX_FLOATING_SLOP;
13925 push @output, generate_error($property_name,
13927 1 # 1 => already an error
13932 # Here the number of digits exceeds the
13933 # minimum we think is needed. So generate a
13934 # success test case for it.
13935 push @output, generate_tests($property_name,
13953 (map {"Test_X('$_');\n"} @backslash_X_tests),
13958 # This is a list of the input files and how to handle them. The files are
13959 # processed in their order in this list. Some reordering is possible if
13960 # desired, but the v0 files should be first, and the extracted before the
13961 # others except DAge.txt (as data in an extracted file can be over-ridden by
13962 # the non-extracted. Some other files depend on data derived from an earlier
13963 # file, like UnicodeData requires data from Jamo, and the case changing and
13964 # folding requires data from Unicode. Mostly, it safest to order by first
13965 # version releases in (except the Jamo). DAge.txt is read before the
13966 # extracted ones because of the rarely used feature $compare_versions. In the
13967 # unlikely event that there were ever an extracted file that contained the Age
13968 # property information, it would have to go in front of DAge.
13970 # The version strings allow the program to know whether to expect a file or
13971 # not, but if a file exists in the directory, it will be processed, even if it
13972 # is in a version earlier than expected, so you can copy files from a later
13973 # release into an earlier release's directory.
13974 my @input_file_objects = (
13975 Input_file->new('PropertyAliases.txt', v0,
13976 Handler => \&process_PropertyAliases,
13978 Input_file->new(undef, v0, # No file associated with this
13979 Progress_Message => 'Finishing property setup',
13980 Handler => \&finish_property_setup,
13982 Input_file->new('PropValueAliases.txt', v0,
13983 Handler => \&process_PropValueAliases,
13984 Has_Missings_Defaults => $NOT_IGNORED,
13986 Input_file->new('DAge.txt', v3.2.0,
13987 Has_Missings_Defaults => $NOT_IGNORED,
13990 Input_file->new("${EXTRACTED}DGeneralCategory.txt", v3.1.0,
13991 Property => 'General_Category',
13993 Input_file->new("${EXTRACTED}DCombiningClass.txt", v3.1.0,
13994 Property => 'Canonical_Combining_Class',
13995 Has_Missings_Defaults => $NOT_IGNORED,
13997 Input_file->new("${EXTRACTED}DNumType.txt", v3.1.0,
13998 Property => 'Numeric_Type',
13999 Has_Missings_Defaults => $NOT_IGNORED,
14001 Input_file->new("${EXTRACTED}DEastAsianWidth.txt", v3.1.0,
14002 Property => 'East_Asian_Width',
14003 Has_Missings_Defaults => $NOT_IGNORED,
14005 Input_file->new("${EXTRACTED}DLineBreak.txt", v3.1.0,
14006 Property => 'Line_Break',
14007 Has_Missings_Defaults => $NOT_IGNORED,
14009 Input_file->new("${EXTRACTED}DBidiClass.txt", v3.1.1,
14010 Property => 'Bidi_Class',
14011 Has_Missings_Defaults => $NOT_IGNORED,
14013 Input_file->new("${EXTRACTED}DDecompositionType.txt", v3.1.0,
14014 Property => 'Decomposition_Type',
14015 Has_Missings_Defaults => $NOT_IGNORED,
14017 Input_file->new("${EXTRACTED}DBinaryProperties.txt", v3.1.0),
14018 Input_file->new("${EXTRACTED}DNumValues.txt", v3.1.0,
14019 Property => 'Numeric_Value',
14020 Each_Line_Handler => \&filter_numeric_value_line,
14021 Has_Missings_Defaults => $NOT_IGNORED,
14023 Input_file->new("${EXTRACTED}DJoinGroup.txt", v3.1.0,
14024 Property => 'Joining_Group',
14025 Has_Missings_Defaults => $NOT_IGNORED,
14028 Input_file->new("${EXTRACTED}DJoinType.txt", v3.1.0,
14029 Property => 'Joining_Type',
14030 Has_Missings_Defaults => $NOT_IGNORED,
14032 Input_file->new('Jamo.txt', v2.0.0,
14033 Property => 'Jamo_Short_Name',
14034 Each_Line_Handler => \&filter_jamo_line,
14036 Input_file->new('UnicodeData.txt', v1.1.5,
14037 Pre_Handler => \&setup_UnicodeData,
14039 # We clean up this file for some early versions.
14040 Each_Line_Handler => [ (($v_version lt v2.0.0 )
14042 : ($v_version eq v2.1.5)
14043 ? \&filter_v2_1_5_ucd
14046 # And the main filter
14047 \&filter_UnicodeData_line,
14049 EOF_Handler => \&EOF_UnicodeData,
14051 Input_file->new('ArabicShaping.txt', v2.0.0,
14052 Each_Line_Handler =>
14053 [ ($v_version lt 4.1.0)
14054 ? \&filter_old_style_arabic_shaping
14056 \&filter_arabic_shaping_line,
14058 Has_Missings_Defaults => $NOT_IGNORED,
14060 Input_file->new('Blocks.txt', v2.0.0,
14061 Property => 'Block',
14062 Has_Missings_Defaults => $NOT_IGNORED,
14063 Each_Line_Handler => \&filter_blocks_lines
14065 Input_file->new('PropList.txt', v2.0.0,
14066 Each_Line_Handler => (($v_version lt v3.1.0)
14067 ? \&filter_old_style_proplist
14070 Input_file->new('Unihan.txt', v2.0.0,
14071 Pre_Handler => \&setup_unihan,
14073 Each_Line_Handler => \&filter_unihan_line,
14075 Input_file->new('SpecialCasing.txt', v2.1.8,
14076 Each_Line_Handler => \&filter_special_casing_line,
14077 Pre_Handler => \&setup_special_casing,
14080 'LineBreak.txt', v3.0.0,
14081 Has_Missings_Defaults => $NOT_IGNORED,
14082 Property => 'Line_Break',
14083 # Early versions had problematic syntax
14084 Each_Line_Handler => (($v_version lt v3.1.0)
14085 ? \&filter_early_ea_lb
14088 Input_file->new('EastAsianWidth.txt', v3.0.0,
14089 Property => 'East_Asian_Width',
14090 Has_Missings_Defaults => $NOT_IGNORED,
14091 # Early versions had problematic syntax
14092 Each_Line_Handler => (($v_version lt v3.1.0)
14093 ? \&filter_early_ea_lb
14096 Input_file->new('CompositionExclusions.txt', v3.0.0,
14097 Property => 'Composition_Exclusion',
14099 Input_file->new('BidiMirroring.txt', v3.0.1,
14100 Property => 'Bidi_Mirroring_Glyph',
14102 Input_file->new("NormalizationTest.txt", v3.0.1,
14105 Input_file->new('CaseFolding.txt', v3.0.1,
14106 Pre_Handler => \&setup_case_folding,
14107 Each_Line_Handler =>
14108 [ ($v_version lt v3.1.0)
14109 ? \&filter_old_style_case_folding
14111 \&filter_case_folding_line
14113 Post_Handler => \&post_fold,
14115 Input_file->new('DCoreProperties.txt', v3.1.0,
14116 # 5.2 changed this file
14117 Has_Missings_Defaults => (($v_version ge v5.2.0)
14121 Input_file->new('Scripts.txt', v3.1.0,
14122 Property => 'Script',
14123 Has_Missings_Defaults => $NOT_IGNORED,
14125 Input_file->new('DNormalizationProps.txt', v3.1.0,
14126 Has_Missings_Defaults => $NOT_IGNORED,
14127 Each_Line_Handler => (($v_version lt v4.0.1)
14128 ? \&filter_old_style_normalization_lines
14131 Input_file->new('HangulSyllableType.txt', v4.0.0,
14132 Has_Missings_Defaults => $NOT_IGNORED,
14133 Property => 'Hangul_Syllable_Type'),
14134 Input_file->new("$AUXILIARY/WordBreakProperty.txt", v4.1.0,
14135 Property => 'Word_Break',
14136 Has_Missings_Defaults => $NOT_IGNORED,
14138 Input_file->new("$AUXILIARY/GraphemeBreakProperty.txt", v4.1.0,
14139 Property => 'Grapheme_Cluster_Break',
14140 Has_Missings_Defaults => $NOT_IGNORED,
14142 Input_file->new("$AUXILIARY/GCBTest.txt", v4.1.0,
14143 Handler => \&process_GCB_test,
14145 Input_file->new("$AUXILIARY/LBTest.txt", v4.1.0,
14148 Input_file->new("$AUXILIARY/SBTest.txt", v4.1.0,
14151 Input_file->new("$AUXILIARY/WBTest.txt", v4.1.0,
14154 Input_file->new("$AUXILIARY/SentenceBreakProperty.txt", v4.1.0,
14155 Property => 'Sentence_Break',
14156 Has_Missings_Defaults => $NOT_IGNORED,
14158 Input_file->new('NamedSequences.txt', v4.1.0,
14159 Handler => \&process_NamedSequences
14161 Input_file->new('NameAliases.txt', v5.0.0,
14162 Property => 'Name_Alias',
14164 Input_file->new("BidiTest.txt", v5.2.0,
14167 Input_file->new('UnihanIndicesDictionary.txt', v5.2.0,
14169 Each_Line_Handler => \&filter_unihan_line,
14171 Input_file->new('UnihanDataDictionaryLike.txt', v5.2.0,
14173 Each_Line_Handler => \&filter_unihan_line,
14175 Input_file->new('UnihanIRGSources.txt', v5.2.0,
14177 Pre_Handler => \&setup_unihan,
14178 Each_Line_Handler => \&filter_unihan_line,
14180 Input_file->new('UnihanNumericValues.txt', v5.2.0,
14182 Each_Line_Handler => \&filter_unihan_line,
14184 Input_file->new('UnihanOtherMappings.txt', v5.2.0,
14186 Each_Line_Handler => \&filter_unihan_line,
14188 Input_file->new('UnihanRadicalStrokeCounts.txt', v5.2.0,
14190 Each_Line_Handler => \&filter_unihan_line,
14192 Input_file->new('UnihanReadings.txt', v5.2.0,
14194 Each_Line_Handler => \&filter_unihan_line,
14196 Input_file->new('UnihanVariants.txt', v5.2.0,
14198 Each_Line_Handler => \&filter_unihan_line,
14202 # End of all the preliminaries.
14205 if ($compare_versions) {
14206 Carp::my_carp(<<END
14207 Warning. \$compare_versions is set. Output is not suitable for production
14212 # Put into %potential_files a list of all the files in the directory structure
14213 # that could be inputs to this program, excluding those that we should ignore.
14214 # Use absolute file names because it makes it easier across machine types.
14215 my @ignored_files_full_names = map { File::Spec->rel2abs(
14216 internal_file_to_platform($_))
14217 } keys %ignored_files;
14220 return unless /\.txt$/i; # Some platforms change the name's case
14221 my $full = lc(File::Spec->rel2abs($_));
14222 $potential_files{$full} = 1
14223 if ! grep { $full eq lc($_) } @ignored_files_full_names;
14226 }, File::Spec->curdir());
14228 my @mktables_list_output_files;
14229 my $old_start_time = 0;
14231 if (! -e $file_list) {
14232 print "'$file_list' doesn't exist, so forcing rebuild.\n" if $verbosity >= $VERBOSE;
14233 $write_unchanged_files = 1;
14234 } elsif ($write_unchanged_files) {
14235 print "Not checking file list '$file_list'.\n" if $verbosity >= $VERBOSE;
14238 print "Reading file list '$file_list'\n" if $verbosity >= $VERBOSE;
14240 if (! open $file_handle, "<", $file_list) {
14241 Carp::my_carp("Failed to open '$file_list'; turning on -globlist option instead: $!");
14247 # Read and parse mktables.lst, placing the results from the first part
14248 # into @input, and the second part into @mktables_list_output_files
14249 for my $list ( \@input, \@mktables_list_output_files ) {
14250 while (<$file_handle>) {
14251 s/^ \s+ | \s+ $//xg;
14252 if (/^ \s* \# .* Autogenerated\ starting\ on\ (\d+)/x) {
14253 $old_start_time = $1;
14255 next if /^ \s* (?: \# .* )? $/x;
14257 my ( $file ) = split /\t/;
14258 push @$list, $file;
14260 @$list = uniques(@$list);
14264 # Look through all the input files
14265 foreach my $input (@input) {
14266 next if $input eq 'version'; # Already have checked this.
14268 # Ignore if doesn't exist. The checking about whether we care or
14269 # not is done via the Input_file object.
14270 next if ! file_exists($input);
14272 # The paths are stored with relative names, and with '/' as the
14273 # delimiter; convert to absolute on this machine
14274 my $full = lc(File::Spec->rel2abs(internal_file_to_platform($input)));
14275 $potential_files{$full} = 1
14276 if ! grep { lc($full) eq lc($_) } @ignored_files_full_names;
14280 close $file_handle;
14285 # Here wants to process all .txt files in the directory structure.
14286 # Convert them to full path names. They are stored in the platform's
14289 foreach my $object (@input_file_objects) {
14290 my $file = $object->file;
14291 next unless defined $file;
14292 push @known_files, File::Spec->rel2abs($file);
14295 my @unknown_input_files;
14296 foreach my $file (keys %potential_files) {
14297 next if grep { lc($file) eq lc($_) } @known_files;
14299 # Here, the file is unknown to us. Get relative path name
14300 $file = File::Spec->abs2rel($file);
14301 push @unknown_input_files, $file;
14303 # What will happen is we create a data structure for it, and add it to
14304 # the list of input files to process. First get the subdirectories
14306 my (undef, $directories, undef) = File::Spec->splitpath($file);
14307 $directories =~ s;/$;;; # Can have extraneous trailing '/'
14308 my @directories = File::Spec->splitdir($directories);
14310 # If the file isn't extracted (meaning none of the directories is the
14311 # extracted one), just add it to the end of the list of inputs.
14312 if (! grep { $EXTRACTED_DIR eq $_ } @directories) {
14313 push @input_file_objects, Input_file->new($file, v0);
14317 # Here, the file is extracted. It needs to go ahead of most other
14318 # processing. Search for the first input file that isn't a
14319 # special required property (that is, find one whose first_release
14320 # is non-0), and isn't extracted. Also, the Age property file is
14321 # processed before the extracted ones, just in case
14322 # $compare_versions is set.
14323 for (my $i = 0; $i < @input_file_objects; $i++) {
14324 if ($input_file_objects[$i]->first_released ne v0
14325 && lc($input_file_objects[$i]->file) ne 'dage.txt'
14326 && $input_file_objects[$i]->file !~ /$EXTRACTED_DIR/i)
14328 splice @input_file_objects, $i, 0,
14329 Input_file->new($file, v0);
14336 if (@unknown_input_files) {
14337 print STDERR simple_fold(join_lines(<<END
14339 The following files are unknown as to how to handle. Assuming they are
14340 typical property files. You'll know by later error messages if it worked or
14343 ) . " " . join(", ", @unknown_input_files) . "\n\n");
14345 } # End of looking through directory structure for more .txt files.
14347 # Create the list of input files from the objects we have defined, plus
14349 my @input_files = 'version';
14350 foreach my $object (@input_file_objects) {
14351 my $file = $object->file;
14352 next if ! defined $file; # Not all objects have files
14353 next if $object->optional && ! -e $file;
14354 push @input_files, $file;
14357 if ( $verbosity >= $VERBOSE ) {
14358 print "Expecting ".scalar( @input_files )." input files. ",
14359 "Checking ".scalar( @mktables_list_output_files )." output files.\n";
14362 # We set $most_recent to be the most recently changed input file, including
14363 # this program itself (done much earlier in this file)
14364 foreach my $in (@input_files) {
14365 next unless -e $in; # Keep going even if missing a file
14366 my $mod_time = (stat $in)[9];
14367 $most_recent = $mod_time if $mod_time > $most_recent;
14369 # See that the input files have distinct names, to warn someone if they
14370 # are adding a new one
14372 my ($volume, $directories, $file ) = File::Spec->splitpath($in);
14373 $directories =~ s;/$;;; # Can have extraneous trailing '/'
14374 my @directories = File::Spec->splitdir($directories);
14375 my $base = $file =~ s/\.txt$//;
14376 construct_filename($file, 'mutable', \@directories);
14380 my $rebuild = $write_unchanged_files # Rebuild: if unconditional rebuild
14381 || ! scalar @mktables_list_output_files # or if no outputs known
14382 || $old_start_time < $most_recent; # or out-of-date
14384 # Now we check to see if any output files are older than youngest, if
14385 # they are, we need to continue on, otherwise we can presumably bail.
14387 foreach my $out (@mktables_list_output_files) {
14388 if ( ! file_exists($out)) {
14389 print "'$out' is missing.\n" if $verbosity >= $VERBOSE;
14393 #local $to_trace = 1 if main::DEBUG;
14394 trace $most_recent, (stat $out)[9] if main::DEBUG && $to_trace;
14395 if ( (stat $out)[9] <= $most_recent ) {
14396 #trace "$out: most recent mod time: ", (stat $out)[9], ", youngest: $most_recent\n" if main::DEBUG && $to_trace;
14397 print "'$out' is too old.\n" if $verbosity >= $VERBOSE;
14404 print "Files seem to be ok, not bothering to rebuild. Add '-w' option to force build\n";
14407 print "Must rebuild tables.\n" if $verbosity >= $VERBOSE;
14409 # Ready to do the major processing. First create the perl pseudo-property.
14410 $perl = Property->new('perl', Type => $NON_STRING, Perl_Extension => 1);
14412 # Process each input file
14413 foreach my $file (@input_file_objects) {
14417 # Finish the table generation.
14419 print "Finishing processing Unicode properties\n" if $verbosity >= $PROGRESS;
14422 print "Compiling Perl properties\n" if $verbosity >= $PROGRESS;
14425 print "Creating Perl synonyms\n" if $verbosity >= $PROGRESS;
14426 add_perl_synonyms();
14428 print "Writing tables\n" if $verbosity >= $PROGRESS;
14429 write_all_tables();
14431 # Write mktables.lst
14432 if ( $file_list and $make_list ) {
14434 print "Updating '$file_list'\n" if $verbosity >= $PROGRESS;
14435 foreach my $file (@input_files, @files_actually_output) {
14436 my (undef, $directories, $file) = File::Spec->splitpath($file);
14437 my @directories = File::Spec->splitdir($directories);
14438 $file = join '/', @directories, $file;
14442 if (! open $ofh,">",$file_list) {
14443 Carp::my_carp("Can't write to '$file_list'. Skipping: $!");
14447 my $localtime = localtime $start_time;
14448 print $ofh <<"END";
14450 # $file_list -- File list for $0.
14452 # Autogenerated starting on $start_time ($localtime)
14454 # - First section is input files
14455 # ($0 itself is not listed but is automatically considered an input)
14456 # - Section seperator is /^=+\$/
14457 # - Second section is a list of output files.
14458 # - Lines matching /^\\s*#/ are treated as comments
14459 # which along with blank lines are ignored.
14465 print $ofh "$_\n" for sort(@input_files);
14466 print $ofh "\n=================================\n# Output files:\n\n";
14467 print $ofh "$_\n" for sort @files_actually_output;
14468 print $ofh "\n# ",scalar(@input_files)," input files\n",
14469 "# ",scalar(@files_actually_output)+1," output files\n\n",
14472 or Carp::my_carp("Failed to close $ofh: $!");
14474 print "Filelist has ",scalar(@input_files)," input files and ",
14475 scalar(@files_actually_output)+1," output files\n"
14476 if $verbosity >= $VERBOSE;
14480 # Output these warnings unless -q explicitly specified.
14481 if ($verbosity >= $NORMAL_VERBOSITY) {
14482 if (@unhandled_properties) {
14483 print "\nProperties and tables that unexpectedly have no code points\n";
14484 foreach my $property (sort @unhandled_properties) {
14485 print $property, "\n";
14489 if (%potential_files) {
14490 print "\nInput files that are not considered:\n";
14491 foreach my $file (sort keys %potential_files) {
14492 print File::Spec->abs2rel($file), "\n";
14495 print "\nAll done\n" if $verbosity >= $VERBOSE;
14499 # TRAILING CODE IS USED BY make_property_test_script()
14505 # If run outside the normal test suite on an ASCII platform, you can
14506 # just create a latin1_to_native() function that just returns its
14507 # inputs, because that's the only function used from test.pl
14510 # Test qr/\X/ and the \p{} regular expression constructs. This file is
14511 # constructed by mktables from the tables it generates, so if mktables is
14512 # buggy, this won't necessarily catch those bugs. Tests are generated for all
14513 # feasible properties; a few aren't currently feasible; see
14514 # is_code_point_usable() in mktables for details.
14516 # Standard test packages are not used because this manipulates SIG_WARN. It
14517 # exits 0 if every non-skipped test succeeded; -1 if any failed.
14523 my $expected = shift;
14526 my $warning_type = shift; # Type of warning message, like 'deprecated'
14528 my $line = (caller)[2];
14529 $ord = ord(latin1_to_native(chr($ord)));
14531 # Convert the code point to hex form
14532 my $string = sprintf "\"\\x{%04X}\"", $ord;
14536 # The first time through, use all warnings. If the input should generate
14537 # a warning, add another time through with them turned off
14538 push @tests, "no warnings '$warning_type';" if $warning_type;
14540 foreach my $no_warnings (@tests) {
14542 # Store any warning messages instead of outputting them
14543 local $SIG{__WARN__} = $SIG{__WARN__};
14544 my $warning_message;
14545 $SIG{__WARN__} = sub { $warning_message = $_[0] };
14549 # A string eval is needed because of the 'no warnings'.
14550 # Assumes no parens in the regular expression
14551 my $result = eval "$no_warnings
14552 my \$RegObj = qr($regex);
14553 $string =~ \$RegObj ? 1 : 0";
14554 if (not defined $result) {
14555 print "not ok $Tests - couldn't compile /$regex/; line $line: $@\n";
14558 elsif ($result ^ $expected) {
14559 print "not ok $Tests - expected $expected but got $result for $string =~ qr/$regex/; line $line\n";
14562 elsif ($warning_message) {
14563 if (! $warning_type || ($warning_type && $no_warnings)) {
14564 print "not ok $Tests - for qr/$regex/ did not expect warning message '$warning_message'; line $line\n";
14568 print "ok $Tests - expected and got a warning message for qr/$regex/; line $line\n";
14571 elsif ($warning_type && ! $no_warnings) {
14572 print "not ok $Tests - for qr/$regex/ expected a $warning_type warning message, but got none; line $line\n";
14576 print "ok $Tests - got $result for $string =~ qr/$regex/; line $line\n";
14585 if (eval { 'x' =~ qr/$regex/; 1 }) {
14587 my $line = (caller)[2];
14588 print "not ok $Tests - re compiled ok, but expected error for qr/$regex/; line $line: $@\n";
14591 my $line = (caller)[2];
14592 print "ok $Tests - got and expected error for qr/$regex/; line $line\n";
14597 # GCBTest.txt character that separates grapheme clusters
14598 my $breakable_utf8 = my $breakable = chr(0xF7);
14599 utf8::upgrade($breakable_utf8);
14601 # GCBTest.txt character that indicates that the adjoining code points are part
14602 # of the same grapheme cluster
14603 my $nobreak_utf8 = my $nobreak = chr(0xD7);
14604 utf8::upgrade($nobreak_utf8);
14607 # Test qr/\X/ matches. The input is a line from auxiliary/GCBTest.txt
14608 # Each such line is a sequence of code points given by their hex numbers,
14609 # separated by the two characters defined just before this subroutine that
14610 # indicate that either there can or cannot be a break between the adjacent
14611 # code points. If there isn't a break, that means the sequence forms an
14612 # extended grapheme cluster, which means that \X should match the whole
14613 # thing. If there is a break, \X should stop there. This is all
14614 # converted by this routine into a match:
14615 # $string =~ /(\X)/,
14616 # Each \X should match the next cluster; and that is what is checked.
14618 my $template = shift;
14620 my $line = (caller)[2];
14622 # The line contains characters above the ASCII range, but in Latin1. It
14623 # may or may not be in utf8, and if it is, it may or may not know it. So,
14624 # convert these characters to 8 bits. If knows is in utf8, simply
14626 if (utf8::is_utf8($template)) {
14627 utf8::downgrade($template);
14630 # Otherwise, if it is in utf8, but doesn't know it, the next lines
14631 # convert the two problematic characters to their 8-bit equivalents.
14632 # If it isn't in utf8, they don't harm anything.
14634 $template =~ s/$nobreak_utf8/$nobreak/g;
14635 $template =~ s/$breakable_utf8/$breakable/g;
14638 # Get rid of the leading and trailing breakables
14639 $template =~ s/^ \s* $breakable \s* //x;
14640 $template =~ s/ \s* $breakable \s* $ //x;
14642 # And no-breaks become just a space.
14643 $template =~ s/ \s* $nobreak \s* / /xg;
14645 # Split the input into segments that are breakable between them.
14646 my @segments = split /\s*$breakable\s*/, $template;
14649 my $display_string = "";
14651 my @should_display;
14653 # Convert the code point sequence in each segment into a Perl string of
14655 foreach my $segment (@segments) {
14656 my @code_points = split /\s+/, $segment;
14657 my $this_string = "";
14658 my $this_display = "";
14659 foreach my $code_point (@code_points) {
14660 $this_string .= latin1_to_native(chr(hex $code_point));
14661 $this_display .= "\\x{$code_point}";
14664 # The next cluster should match the string in this segment.
14665 push @should_match, $this_string;
14666 push @should_display, $this_display;
14667 $string .= $this_string;
14668 $display_string .= $this_display;
14671 # If a string can be represented in both non-ut8 and utf8, test both cases
14673 for my $to_upgrade (0 .. 1) {
14677 # If already in utf8, would just be a repeat
14678 next UPGRADE if utf8::is_utf8($string);
14680 utf8::upgrade($string);
14683 # Finally, do the \X match.
14684 my @matches = $string =~ /(\X)/g;
14686 # Look through each matched cluster to verify that it matches what we
14688 my $min = (@matches < @should_match) ? @matches : @should_match;
14689 for my $i (0 .. $min - 1) {
14691 if ($matches[$i] eq $should_match[$i]) {
14692 print "ok $Tests - ";
14694 print "In \"$display_string\" =~ /(\\X)/g, \\X #1";
14696 print "And \\X #", $i + 1,
14698 print " correctly matched $should_display[$i]; line $line\n";
14700 $matches[$i] = join("", map { sprintf "\\x{%04X}", $_ }
14701 unpack("U*", $matches[$i]));
14702 print "not ok $Tests - In \"$display_string\" =~ /(\\X)/g, \\X #",
14704 " should have matched $should_display[$i]",
14705 " but instead matched $matches[$i]",
14706 ". Abandoning rest of line $line\n";
14711 # And the number of matches should equal the number of expected matches.
14713 if (@matches == @should_match) {
14714 print "ok $Tests - Nothing was left over; line $line\n";
14716 print "not ok $Tests - There were ", scalar @should_match, " \\X matches expected, but got ", scalar @matches, " instead; line $line\n";
14724 print "1..$Tests\n";
14725 exit($Fails ? -1 : 0);
14728 Error('\p{Script=InGreek}'); # Bug #69018
14729 Test_X("1100 $nobreak 1161"); # Bug #70940
14730 Expect(0, 0x2028, '\p{Print}', ""); # Bug # 71722
14731 Expect(0, 0x2029, '\p{Print}', ""); # Bug # 71722
14732 Expect(1, 0xFF10, '\p{XDigit}', ""); # Bug # 71726