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; { no overloading; $addr = 0+$self; }
14 # my $addr = main::objaddr $self;
15 # (or reverse commit 9b01bafde4b022706c3d6f947a0963f821b2e50b
16 # that instituted this change.)
27 sub DEBUG () { 0 } # Set to 0 for production; 1 for development
29 ##########################################################################
31 # mktables -- create the runtime Perl Unicode files (lib/unicore/.../*.pl),
32 # from the Unicode database files (lib/unicore/.../*.txt), It also generates
33 # a pod file and a .t file
35 # The structure of this file is:
36 # First these introductory comments; then
37 # code needed for everywhere, such as debugging stuff; then
38 # code to handle input parameters; then
39 # data structures likely to be of external interest (some of which depend on
40 # the input parameters, so follows them; then
41 # more data structures and subroutine and package (class) definitions; then
42 # the small actual loop to process the input files and finish up; then
43 # a __DATA__ section, for the .t tests
45 # This program works on all releases of Unicode through at least 5.2. The
46 # outputs have been scrutinized most intently for release 5.1. The others
47 # have been checked for somewhat more than just sanity. It can handle all
48 # existing Unicode character properties in those releases.
50 # This program is mostly about Unicode character (or code point) properties.
51 # A property describes some attribute or quality of a code point, like if it
52 # is lowercase or not, its name, what version of Unicode it was first defined
53 # in, or what its uppercase equivalent is. Unicode deals with these disparate
54 # possibilities by making all properties into mappings from each code point
55 # into some corresponding value. In the case of it being lowercase or not,
56 # the mapping is either to 'Y' or 'N' (or various synonyms thereof). Each
57 # property maps each Unicode code point to a single value, called a "property
58 # value". (Hence each Unicode property is a true mathematical function with
59 # exactly one value per code point.)
61 # When using a property in a regular expression, what is desired isn't the
62 # mapping of the code point to its property's value, but the reverse (or the
63 # mathematical "inverse relation"): starting with the property value, "Does a
64 # code point map to it?" These are written in a "compound" form:
65 # \p{property=value}, e.g., \p{category=punctuation}. This program generates
66 # files containing the lists of code points that map to each such regular
67 # expression property value, one file per list
69 # There is also a single form shortcut that Perl adds for many of the commonly
70 # used properties. This happens for all binary properties, plus script,
71 # general_category, and block properties.
73 # Thus the outputs of this program are files. There are map files, mostly in
74 # the 'To' directory; and there are list files for use in regular expression
75 # matching, all in subdirectories of the 'lib' directory, with each
76 # subdirectory being named for the property that the lists in it are for.
77 # Bookkeeping, test, and documentation files are also generated.
79 my $matches_directory = 'lib'; # Where match (\p{}) files go.
80 my $map_directory = 'To'; # Where map files go.
84 # The major data structures of this program are Property, of course, but also
85 # Table. There are two kinds of tables, very similar to each other.
86 # "Match_Table" is the data structure giving the list of code points that have
87 # a particular property value, mentioned above. There is also a "Map_Table"
88 # data structure which gives the property's mapping from code point to value.
89 # There are two structures because the match tables need to be combined in
90 # various ways, such as constructing unions, intersections, complements, etc.,
91 # and the map ones don't. And there would be problems, perhaps subtle, if
92 # a map table were inadvertently operated on in some of those ways.
93 # The use of separate classes with operations defined on one but not the other
94 # prevents accidentally confusing the two.
96 # At the heart of each table's data structure is a "Range_List", which is just
97 # an ordered list of "Ranges", plus ancillary information, and methods to
98 # operate on them. A Range is a compact way to store property information.
99 # Each range has a starting code point, an ending code point, and a value that
100 # is meant to apply to all the code points between the two end points,
101 # inclusive. For a map table, this value is the property value for those
102 # code points. Two such ranges could be written like this:
103 # 0x41 .. 0x5A, 'Upper',
104 # 0x61 .. 0x7A, 'Lower'
106 # Each range also has a type used as a convenience to classify the values.
107 # Most ranges in this program will be Type 0, or normal, but there are some
108 # ranges that have a non-zero type. These are used only in map tables, and
109 # are for mappings that don't fit into the normal scheme of things. Mappings
110 # that require a hash entry to communicate with utf8.c are one example;
111 # another example is mappings for charnames.pm to use which indicate a name
112 # that is algorithmically determinable from its code point (and vice-versa).
113 # These are used to significantly compact these tables, instead of listing
114 # each one of the tens of thousands individually.
116 # In a match table, the value of a range is irrelevant (and hence the type as
117 # well, which will always be 0), and arbitrarily set to the null string.
118 # Using the example above, there would be two match tables for those two
119 # entries, one named Upper would contain the 0x41..0x5A range, and the other
120 # named Lower would contain 0x61..0x7A.
122 # Actually, there are two types of range lists, "Range_Map" is the one
123 # associated with map tables, and "Range_List" with match tables.
124 # Again, this is so that methods can be defined on one and not the other so as
125 # to prevent operating on them in incorrect ways.
127 # Eventually, most tables are written out to files to be read by utf8_heavy.pl
128 # in the perl core. All tables could in theory be written, but some are
129 # suppressed because there is no current practical use for them. It is easy
130 # to change which get written by changing various lists that are near the top
131 # of the actual code in this file. The table data structures contain enough
132 # ancillary information to allow them to be treated as separate entities for
133 # writing, such as the path to each one's file. There is a heading in each
134 # map table that gives the format of its entries, and what the map is for all
135 # the code points missing from it. (This allows tables to be more compact.)
137 # The Property data structure contains one or more tables. All properties
138 # contain a map table (except the $perl property which is a
139 # pseudo-property containing only match tables), and any properties that
140 # are usable in regular expression matches also contain various matching
141 # tables, one for each value the property can have. A binary property can
142 # have two values, True and False (or Y and N, which are preferred by Unicode
143 # terminology). Thus each of these properties will have a map table that
144 # takes every code point and maps it to Y or N (but having ranges cuts the
145 # number of entries in that table way down), and two match tables, one
146 # which has a list of all the code points that map to Y, and one for all the
147 # code points that map to N. (For each of these, a third table is also
148 # generated for the pseudo Perl property. It contains the identical code
149 # points as the Y table, but can be written, not in the compound form, but in
150 # a "single" form like \p{IsUppercase}.) Many properties are binary, but some
151 # properties have several possible values, some have many, and properties like
152 # Name have a different value for every named code point. Those will not,
153 # unless the controlling lists are changed, have their match tables written
154 # out. But all the ones which can be used in regular expression \p{} and \P{}
155 # constructs will. Generally a property will have either its map table or its
156 # match tables written but not both. Again, what gets written is controlled
157 # by lists which can easily be changed.
159 # For information about the Unicode properties, see Unicode's UAX44 document:
161 my $unicode_reference_url = 'http://www.unicode.org/reports/tr44/';
163 # As stated earlier, this program will work on any release of Unicode so far.
164 # Most obvious problems in earlier data have NOT been corrected except when
165 # necessary to make Perl or this program work reasonably. For example, no
166 # folding information was given in early releases, so this program uses the
167 # substitute of lower case, just so that a regular expression with the /i
168 # option will do something that actually gives the right results in many
169 # cases. There are also a couple other corrections for version 1.1.5,
170 # commented at the point they are made. As an example of corrections that
171 # weren't made (but could be) is this statement from DerivedAge.txt: "The
172 # supplementary private use code points and the non-character code points were
173 # assigned in version 2.0, but not specifically listed in the UCD until
174 # versions 3.0 and 3.1 respectively." (To be precise it was 3.0.1 not 3.0.0)
175 # More information on Unicode version glitches is further down in these
176 # introductory comments.
178 # This program works on all properties as of 5.2, though the files for some
179 # are suppressed from apparent lack of demand for them. You can change which
180 # are output by changing lists in this program.
182 # The old version of mktables emphasized the term "Fuzzy" to mean Unocde's
183 # loose matchings rules (from Unicode TR18):
185 # The recommended names for UCD properties and property values are in
186 # PropertyAliases.txt [Prop] and PropertyValueAliases.txt
187 # [PropValue]. There are both abbreviated names and longer, more
188 # descriptive names. It is strongly recommended that both names be
189 # recognized, and that loose matching of property names be used,
190 # whereby the case distinctions, whitespace, hyphens, and underbar
192 # The program still allows Fuzzy to override its determination of if loose
193 # matching should be used, but it isn't currently used, as it is no longer
194 # needed; the calculations it makes are good enough.
196 # SUMMARY OF HOW IT WORKS:
200 # A list is constructed containing each input file that is to be processed
202 # Each file on the list is processed in a loop, using the associated handler
204 # The PropertyAliases.txt and PropValueAliases.txt files are processed
205 # first. These files name the properties and property values.
206 # Objects are created of all the property and property value names
207 # that the rest of the input should expect, including all synonyms.
208 # The other input files give mappings from properties to property
209 # values. That is, they list code points and say what the mapping
210 # is under the given property. Some files give the mappings for
211 # just one property; and some for many. This program goes through
212 # each file and populates the properties from them. Some properties
213 # are listed in more than one file, and Unicode has set up a
214 # precedence as to which has priority if there is a conflict. Thus
215 # the order of processing matters, and this program handles the
216 # conflict possibility by processing the overriding input files
217 # last, so that if necessary they replace earlier values.
218 # After this is all done, the program creates the property mappings not
219 # furnished by Unicode, but derivable from what it does give.
220 # The tables of code points that match each property value in each
221 # property that is accessible by regular expressions are created.
222 # The Perl-defined properties are created and populated. Many of these
223 # require data determined from the earlier steps
224 # Any Perl-defined synonyms are created, and name clashes between Perl
225 # and Unicode are reconciled and warned about.
226 # All the properties are written to files
227 # Any other files are written, and final warnings issued.
229 # For clarity, a number of operators have been overloaded to work on tables:
230 # ~ means invert (take all characters not in the set). The more
231 # conventional '!' is not used because of the possibility of confusing
232 # it with the actual boolean operation.
234 # - means subtraction
235 # & means intersection
236 # The precedence of these is the order listed. Parentheses should be
237 # copiously used. These are not a general scheme. The operations aren't
238 # defined for a number of things, deliberately, to avoid getting into trouble.
239 # Operations are done on references and affect the underlying structures, so
240 # that the copy constructors for them have been overloaded to not return a new
241 # clone, but the input object itself.
243 # The bool operator is deliberately not overloaded to avoid confusion with
244 # "should it mean if the object merely exists, or also is non-empty?".
246 # WHY CERTAIN DESIGN DECISIONS WERE MADE
248 # This program needs to be able to run under miniperl. Therefore, it uses a
249 # minimum of other modules, and hence implements some things itself that could
250 # be gotten from CPAN
252 # This program uses inputs published by the Unicode Consortium. These can
253 # change incompatibly between releases without the Perl maintainers realizing
254 # it. Therefore this program is now designed to try to flag these. It looks
255 # at the directories where the inputs are, and flags any unrecognized files.
256 # It keeps track of all the properties in the files it handles, and flags any
257 # that it doesn't know how to handle. It also flags any input lines that
258 # don't match the expected syntax, among other checks.
260 # It is also designed so if a new input file matches one of the known
261 # templates, one hopefully just needs to add it to a list to have it
264 # As mentioned earlier, some properties are given in more than one file. In
265 # particular, the files in the extracted directory are supposedly just
266 # reformattings of the others. But they contain information not easily
267 # derivable from the other files, including results for Unihan, which this
268 # program doesn't ordinarily look at, and for unassigned code points. They
269 # also have historically had errors or been incomplete. In an attempt to
270 # create the best possible data, this program thus processes them first to
271 # glean information missing from the other files; then processes those other
272 # files to override any errors in the extracted ones. Much of the design was
273 # driven by this need to store things and then possibly override them.
275 # It tries to keep fatal errors to a minimum, to generate something usable for
276 # testing purposes. It always looks for files that could be inputs, and will
277 # warn about any that it doesn't know how to handle (the -q option suppresses
280 # Why have files written out for binary 'N' matches?
281 # For binary properties, if you know the mapping for either Y or N; the
282 # other is trivial to construct, so could be done at Perl run-time by just
283 # complementing the result, instead of having a file for it. That is, if
284 # someone types in \p{foo: N}, Perl could translate that to \P{foo: Y} and
285 # not need a file. The problem is communicating to Perl that a given
286 # property is binary. Perl can't figure it out from looking at the N (or
287 # No), as some non-binary properties have these as property values. So
288 # rather than inventing a way to communicate this info back to the core,
289 # which would have required changes there as well, it was simpler just to
290 # add the extra tables.
292 # Why is there more than one type of range?
293 # This simplified things. There are some very specialized code points that
294 # have to be handled specially for output, such as Hangul syllable names.
295 # By creating a range type (done late in the development process), it
296 # allowed this to be stored with the range, and overridden by other input.
297 # Originally these were stored in another data structure, and it became a
298 # mess trying to decide if a second file that was for the same property was
299 # overriding the earlier one or not.
301 # Why are there two kinds of tables, match and map?
302 # (And there is a base class shared by the two as well.) As stated above,
303 # they actually are for different things. Development proceeded much more
304 # smoothly when I (khw) realized the distinction. Map tables are used to
305 # give the property value for every code point (actually every code point
306 # that doesn't map to a default value). Match tables are used for regular
307 # expression matches, and are essentially the inverse mapping. Separating
308 # the two allows more specialized methods, and error checks so that one
309 # can't just take the intersection of two map tables, for example, as that
312 # There are no match tables generated for matches of the null string. These
313 # would like like qr/\p{JSN=}/ currently without modifying the regex code.
314 # Perhaps something like them could be added if necessary. The JSN does have
315 # a real code point U+110B that maps to the null string, but it is a
316 # contributory property, and therefore not output by default. And it's easily
317 # handled so far by making the null string the default where it is a
322 # This program is written so it will run under miniperl. Occasionally changes
323 # will cause an error where the backtrace doesn't work well under miniperl.
324 # To diagnose the problem, you can instead run it under regular perl, if you
327 # There is a good trace facility. To enable it, first sub DEBUG must be set
328 # to return true. Then a line like
330 # local $to_trace = 1 if main::DEBUG;
332 # can be added to enable tracing in its lexical scope or until you insert
335 # local $to_trace = 0 if main::DEBUG;
337 # then use a line like "trace $a, @b, %c, ...;
339 # Some of the more complex subroutines already have trace statements in them.
340 # Permanent trace statements should be like:
342 # trace ... if main::DEBUG && $to_trace;
344 # If there is just one or a few files that you're debugging, you can easily
345 # cause most everything else to be skipped. Change the line
347 # my $debug_skip = 0;
349 # to 1, and every file whose object is in @input_file_objects and doesn't have
350 # a, 'non_skip => 1,' in its constructor will be skipped.
354 # The program would break if Unicode were to change its names so that
355 # interior white space, underscores, or dashes differences were significant
356 # within property and property value names.
358 # It might be easier to use the xml versions of the UCD if this program ever
359 # would need heavy revision, and the ability to handle old versions was not
362 # There is the potential for name collisions, in that Perl has chosen names
363 # that Unicode could decide it also likes. There have been such collisions in
364 # the past, with mostly Perl deciding to adopt the Unicode definition of the
365 # name. However in the 5.2 Unicode beta testing, there were a number of such
366 # collisions, which were withdrawn before the final release, because of Perl's
367 # and other's protests. These all involved new properties which began with
368 # 'Is'. Based on the protests, Unicode is unlikely to try that again. Also,
369 # many of the Perl-defined synonyms, like Any, Word, etc, are listed in a
370 # Unicode document, so they are unlikely to be used by Unicode for another
371 # purpose. However, they might try something beginning with 'In', or use any
372 # of the other Perl-defined properties. This program will warn you of name
373 # collisions, and refuse to generate tables with them, but manual intervention
374 # will be required in this event. One scheme that could be implemented, if
375 # necessary, would be to have this program generate another file, or add a
376 # field to mktables.lst that gives the date of first definition of a property.
377 # Each new release of Unicode would use that file as a basis for the next
378 # iteration. And the Perl synonym addition code could sort based on the age
379 # of the property, so older properties get priority, and newer ones that clash
380 # would be refused; hence existing code would not be impacted, and some other
381 # synonym would have to be used for the new property. This is ugly, and
382 # manual intervention would certainly be easier to do in the short run; lets
383 # hope it never comes to this.
387 # This program can generate tables from the Unihan database. But it doesn't
388 # by default, letting the CPAN module Unicode::Unihan handle them. Prior to
389 # version 5.2, this database was in a single file, Unihan.txt. In 5.2 the
390 # database was split into 8 different files, all beginning with the letters
391 # 'Unihan'. This program will read those file(s) if present, but it needs to
392 # know which of the many properties in the file(s) should have tables created
393 # for them. It will create tables for any properties listed in
394 # PropertyAliases.txt and PropValueAliases.txt, plus any listed in the
395 # @cjk_properties array and the @cjk_property_values array. Thus, if a
396 # property you want is not in those files of the release you are building
397 # against, you must add it to those two arrays. Starting in 4.0, the
398 # Unicode_Radical_Stroke was listed in those files, so if the Unihan database
399 # is present in the directory, a table will be generated for that property.
400 # In 5.2, several more properties were added. For your convenience, the two
401 # arrays are initialized with all the 5.2 listed properties that are also in
402 # earlier releases. But these are commented out. You can just uncomment the
403 # ones you want, or use them as a template for adding entries for other
406 # You may need to adjust the entries to suit your purposes. setup_unihan(),
407 # and filter_unihan_line() are the functions where this is done. This program
408 # already does some adjusting to make the lines look more like the rest of the
409 # Unicode DB; You can see what that is in filter_unihan_line()
411 # There is a bug in the 3.2 data file in which some values for the
412 # kPrimaryNumeric property have commas and an unexpected comment. A filter
413 # could be added for these; or for a particular installation, the Unihan.txt
414 # file could be edited to fix them.
417 # HOW TO ADD A FILE TO BE PROCESSED
419 # A new file from Unicode needs to have an object constructed for it in
420 # @input_file_objects, probably at the end or at the end of the extracted
421 # ones. The program should warn you if its name will clash with others on
422 # restrictive file systems, like DOS. If so, figure out a better name, and
423 # add lines to the README.perl file giving that. If the file is a character
424 # property, it should be in the format that Unicode has by default
425 # standardized for such files for the more recently introduced ones.
426 # If so, the Input_file constructor for @input_file_objects can just be the
427 # file name and release it first appeared in. If not, then it should be
428 # possible to construct an each_line_handler() to massage the line into the
431 # For non-character properties, more code will be needed. You can look at
432 # the existing entries for clues.
434 # UNICODE VERSIONS NOTES
436 # The Unicode UCD has had a number of errors in it over the versions. And
437 # these remain, by policy, in the standard for that version. Therefore it is
438 # risky to correct them, because code may be expecting the error. So this
439 # program doesn't generally make changes, unless the error breaks the Perl
440 # core. As an example, some versions of 2.1.x Jamo.txt have the wrong value
441 # for U+1105, which causes real problems for the algorithms for Jamo
442 # calculations, so it is changed here.
444 # But it isn't so clear cut as to what to do about concepts that are
445 # introduced in a later release; should they extend back to earlier releases
446 # where the concept just didn't exist? It was easier to do this than to not,
447 # so that's what was done. For example, the default value for code points not
448 # in the files for various properties was probably undefined until changed by
449 # some version. No_Block for blocks is such an example. This program will
450 # assign No_Block even in Unicode versions that didn't have it. This has the
451 # benefit that code being written doesn't have to special case earlier
452 # versions; and the detriment that it doesn't match the Standard precisely for
453 # the affected versions.
455 # Here are some observations about some of the issues in early versions:
457 # The number of code points in \p{alpha} halve in 2.1.9. It turns out that
458 # the reason is that the CJK block starting at 4E00 was removed from PropList,
459 # and was not put back in until 3.1.0
461 # Unicode introduced the synonym Space for White_Space in 4.1. Perl has
462 # always had a \p{Space}. In release 3.2 only, they are not synonymous. The
463 # reason is that 3.2 introduced U+205F=medium math space, which was not
464 # classed as white space, but Perl figured out that it should have been. 4.0
465 # reclassified it correctly.
467 # Another change between 3.2 and 4.0 is the CCC property value ATBL. In 3.2
468 # this was erroneously a synonym for 202. In 4.0, ATB became 202, and ATBL
469 # was left with no code points, as all the ones that mapped to 202 stayed
470 # mapped to 202. Thus if your program used the numeric name for the class,
471 # it would not have been affected, but if it used the mnemonic, it would have
474 # \p{Script=Hrkt} (Katakana_Or_Hiragana) came in 4.0.1. Before that code
475 # points which eventually came to have this script property value, instead
476 # mapped to "Unknown". But in the next release all these code points were
477 # moved to \p{sc=common} instead.
479 # The default for missing code points for BidiClass is complicated. Starting
480 # in 3.1.1, the derived file DBidiClass.txt handles this, but this program
481 # tries to do the best it can for earlier releases. It is done in
482 # process_PropertyAliases()
484 ##############################################################################
486 my $UNDEF = ':UNDEF:'; # String to print out for undefined values in tracing
488 my $MAX_LINE_WIDTH = 78;
490 # Debugging aid to skip most files so as to not be distracted by them when
491 # concentrating on the ones being debugged. Add
493 # to the constructor for those files you want processed when you set this.
494 # Files with a first version number of 0 are special: they are always
495 # processed regardless of the state of this flag.
498 # Set to 1 to enable tracing.
501 { # Closure for trace: debugging aid
502 my $print_caller = 1; # ? Include calling subroutine name
503 my $main_with_colon = 'main::';
504 my $main_colon_length = length($main_with_colon);
507 return unless $to_trace; # Do nothing if global flag not set
511 local $DB::trace = 0;
512 $DB::trace = 0; # Quiet 'used only once' message
516 # Loop looking up the stack to get the first non-trace caller
521 $line_number = $caller_line;
522 (my $pkg, my $file, $caller_line, my $caller) = caller $i++;
523 $caller = $main_with_colon unless defined $caller;
525 $caller_name = $caller;
528 $caller_name =~ s/.*:://;
529 if (substr($caller_name, 0, $main_colon_length)
532 $caller_name = substr($caller_name, $main_colon_length);
535 } until ($caller_name ne 'trace');
537 # If the stack was empty, we were called from the top level
538 $caller_name = 'main' if ($caller_name eq ""
539 || $caller_name eq 'trace');
542 foreach my $string (@input) {
543 #print STDERR __LINE__, ": ", join ", ", @input, "\n";
544 if (ref $string eq 'ARRAY' || ref $string eq 'HASH') {
545 $output .= simple_dumper($string);
548 $string = "$string" if ref $string;
549 $string = $UNDEF unless defined $string;
551 $string = '""' if $string eq "";
552 $output .= " " if $output ne ""
554 && substr($output, -1, 1) ne " "
555 && substr($string, 0, 1) ne " ";
560 print STDERR sprintf "%4d: ", $line_number if defined $line_number;
561 print STDERR "$caller_name: " if $print_caller;
562 print STDERR $output, "\n";
567 # This is for a rarely used development feature that allows you to compare two
568 # versions of the Unicode standard without having to deal with changes caused
569 # by the code points introduced in the later verson. Change the 0 to a SINGLE
570 # dotted Unicode release number (e.g. 2.1). Only code points introduced in
571 # that release and earlier will be used; later ones are thrown away. You use
572 # the version number of the earliest one you want to compare; then run this
573 # program on directory structures containing each release, and compare the
574 # outputs. These outputs will therefore include only the code points common
575 # to both releases, and you can see the changes caused just by the underlying
576 # release semantic changes. For versions earlier than 3.2, you must copy a
577 # version of DAge.txt into the directory.
578 my $string_compare_versions = DEBUG && 0; # e.g., v2.1;
579 my $compare_versions = DEBUG
580 && $string_compare_versions
581 && pack "C*", split /\./, $string_compare_versions;
584 # Returns non-duplicated input values. From "Perl Best Practices:
585 # Encapsulated Cleverness". p. 455 in first edition.
588 return grep { ! $seen{$_}++ } @_;
591 $0 = File::Spec->canonpath($0);
593 my $make_test_script = 0; # ? Should we output a test script
594 my $write_unchanged_files = 0; # ? Should we update the output files even if
595 # we don't think they have changed
596 my $use_directory = ""; # ? Should we chdir somewhere.
597 my $pod_directory; # input directory to store the pod file.
598 my $pod_file = 'perluniprops';
599 my $t_path; # Path to the .t test file
600 my $file_list = 'mktables.lst'; # File to store input and output file names.
601 # This is used to speed up the build, by not
602 # executing the main body of the program if
603 # nothing on the list has changed since the
605 my $make_list = 1; # ? Should we write $file_list. Set to always
606 # make a list so that when the pumpking is
607 # preparing a release, s/he won't have to do
609 my $glob_list = 0; # ? Should we try to include unknown .txt files
611 my $output_range_counts = 1; # ? Should we include the number of code points
612 # in ranges in the output
613 my $output_names = 0; # ? Should character names be in the output
614 my @viacode; # Contains the 1 million character names, if
615 # $output_names is true
617 # Verbosity levels; 0 is quiet
618 my $NORMAL_VERBOSITY = 1;
622 my $verbosity = $NORMAL_VERBOSITY;
626 my $arg = shift @ARGV;
628 $verbosity = $VERBOSE;
630 elsif ($arg eq '-p') {
631 $verbosity = $PROGRESS;
632 $| = 1; # Flush buffers as we go.
634 elsif ($arg eq '-q') {
637 elsif ($arg eq '-w') {
638 $write_unchanged_files = 1; # update the files even if havent changed
640 elsif ($arg eq '-check') {
641 my $this = shift @ARGV;
642 my $ok = shift @ARGV;
644 print "Skipping as check params are not the same.\n";
648 elsif ($arg eq '-P' && defined ($pod_directory = shift)) {
649 -d $pod_directory or croak "Directory '$pod_directory' doesn't exist";
651 elsif ($arg eq '-maketest' || ($arg eq '-T' && defined ($t_path = shift)))
653 $make_test_script = 1;
655 elsif ($arg eq '-makelist') {
658 elsif ($arg eq '-C' && defined ($use_directory = shift)) {
659 -d $use_directory or croak "Unknown directory '$use_directory'";
661 elsif ($arg eq '-L') {
663 # Existence not tested until have chdir'd
666 elsif ($arg eq '-globlist') {
669 elsif ($arg eq '-c') {
670 $output_range_counts = ! $output_range_counts
672 elsif ($arg eq '-output_names') {
677 $with_c .= 'out' if $output_range_counts; # Complements the state
679 usage: $0 [-c|-p|-q|-v|-w] [-C dir] [-L filelist] [ -P pod_dir ]
680 [ -T test_file_path ] [-globlist] [-makelist] [-maketest]
682 -c : Output comments $with_c number of code points in ranges
683 -q : Quiet Mode: Only output serious warnings.
684 -p : Set verbosity level to normal plus show progress.
685 -v : Set Verbosity level high: Show progress and non-serious
687 -w : Write files regardless
688 -C dir : Change to this directory before proceeding. All relative paths
689 except those specified by the -P and -T options will be done
690 with respect to this directory.
691 -P dir : Output $pod_file file to directory 'dir'.
692 -T path : Create a test script as 'path'; overrides -maketest
693 -L filelist : Use alternate 'filelist' instead of standard one
694 -globlist : Take as input all non-Test *.txt files in current and sub
696 -maketest : Make test script 'TestProp.pl' in current (or -C directory),
698 -makelist : Rewrite the file list $file_list based on current setup
699 -output_names : Output each character's name in the table files; useful for
700 doing what-ifs, looking at diffs; is slow, memory intensive,
701 resulting tables are usable but very large.
702 -check A B : Executes $0 only if A and B are the same
707 # Stores the most-recently changed file. If none have changed, can skip the
709 my $youngest = -M $0; # Do this before the chdir!
711 # Change directories now, because need to read 'version' early.
712 if ($use_directory) {
713 if ($pod_directory && ! File::Spec->file_name_is_absolute($pod_directory)) {
714 $pod_directory = File::Spec->rel2abs($pod_directory);
716 if ($t_path && ! File::Spec->file_name_is_absolute($t_path)) {
717 $t_path = File::Spec->rel2abs($t_path);
719 chdir $use_directory or croak "Failed to chdir to '$use_directory':$!";
720 if ($pod_directory && File::Spec->file_name_is_absolute($pod_directory)) {
721 $pod_directory = File::Spec->abs2rel($pod_directory);
723 if ($t_path && File::Spec->file_name_is_absolute($t_path)) {
724 $t_path = File::Spec->abs2rel($t_path);
728 # Get Unicode version into regular and v-string. This is done now because
729 # various tables below get populated based on it. These tables are populated
730 # here to be near the top of the file, and so easily seeable by those needing
732 open my $VERSION, "<", "version"
733 or croak "$0: can't open required file 'version': $!\n";
734 my $string_version = <$VERSION>;
736 chomp $string_version;
737 my $v_version = pack "C*", split /\./, $string_version; # v string
739 # The following are the complete names of properties with property values that
740 # are known to not match any code points in some versions of Unicode, but that
741 # may change in the future so they should be matchable, hence an empty file is
742 # generated for them.
743 my @tables_that_may_be_empty = (
744 'Joining_Type=Left_Joining',
746 push @tables_that_may_be_empty, 'Script=Common' if $v_version le v4.0.1;
747 push @tables_that_may_be_empty, 'Title' if $v_version lt v2.0.0;
748 push @tables_that_may_be_empty, 'Script=Katakana_Or_Hiragana'
749 if $v_version ge v4.1.0;
751 # The lists below are hashes, so the key is the item in the list, and the
752 # value is the reason why it is in the list. This makes generation of
753 # documentation easier.
755 my %why_suppressed; # No file generated for these.
757 # Files aren't generated for empty extraneous properties. This is arguable.
758 # Extraneous properties generally come about because a property is no longer
759 # used in a newer version of Unicode. If we generated a file without code
760 # points, programs that used to work on that property will still execute
761 # without errors. It just won't ever match (or will always match, with \P{}).
762 # This means that the logic is now likely wrong. I (khw) think its better to
763 # find this out by getting an error message. Just move them to the table
764 # above to change this behavior
765 my %why_suppress_if_empty_warn_if_not = (
767 # It is the only property that has ever officially been removed from the
768 # Standard. The database never contained any code points for it.
769 'Special_Case_Condition' => 'Obsolete',
771 # Apparently never official, but there were code points in some versions of
772 # old-style PropList.txt
773 'Non_Break' => 'Obsolete',
776 # These would normally go in the warn table just above, but they were changed
777 # a long time before this program was written, so warnings about them are
779 if ($v_version gt v3.2.0) {
780 push @tables_that_may_be_empty,
781 'Canonical_Combining_Class=Attached_Below_Left'
784 # These are listed in the Property aliases file in 5.2, but Unihan is ignored
785 # unless explicitly added.
786 if ($v_version ge v5.2.0) {
787 my $unihan = 'Unihan; remove from list if using Unihan';
788 foreach my $table qw (
792 kCompatibilityVariant
806 $why_suppress_if_empty_warn_if_not{$table} = $unihan;
810 # Properties that this program ignores.
811 my @unimplemented_properties = (
812 'Unicode_Radical_Stroke' # Remove if changing to handle this one.
815 # There are several types of obsolete properties defined by Unicode. These
816 # must be hand-edited for every new Unicode release.
817 my %why_deprecated; # Generates a deprecated warning message if used.
818 my %why_stabilized; # Documentation only
819 my %why_obsolete; # Documentation only
822 my $simple = 'Perl uses the more complete version of this property';
823 my $unihan = 'Unihan properties are by default not enabled in the Perl core. Instead use CPAN: Unicode::Unihan';
825 my $other_properties = 'other properties';
826 my $contributory = "Used by Unicode internally for generating $other_properties and not intended to be used stand-alone";
827 my $why_no_expand = "Easily computed, and yet doesn't cover the common encoding forms (UTF-16/8)",
830 'Grapheme_Link' => 'Deprecated by Unicode. Use ccc=vr (Canonical_Combining_Class=Virama) instead',
831 'Jamo_Short_Name' => $contributory,
832 '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',
833 'Other_Alphabetic' => $contributory,
834 'Other_Default_Ignorable_Code_Point' => $contributory,
835 'Other_Grapheme_Extend' => $contributory,
836 'Other_ID_Continue' => $contributory,
837 'Other_ID_Start' => $contributory,
838 'Other_Lowercase' => $contributory,
839 'Other_Math' => $contributory,
840 'Other_Uppercase' => $contributory,
844 # There is a lib/unicore/Decomposition.pl (used by normalize.pm) which
845 # contains the same information, but without the algorithmically
846 # determinable Hangul syllables'. This file is not published, so it's
847 # existence is not noted in the comment.
848 'Decomposition_Mapping' => 'Accessible via Unicode::Normalize',
850 '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',
851 '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",
853 'Simple_Case_Folding' => "$simple. Can access this through Unicode::UCD::casefold",
854 'Simple_Lowercase_Mapping' => "$simple. Can access this through Unicode::UCD::charinfo",
855 'Simple_Titlecase_Mapping' => "$simple. Can access this through Unicode::UCD::charinfo",
856 'Simple_Uppercase_Mapping' => "$simple. Can access this through Unicode::UCD::charinfo",
858 'Name' => "Accessible via 'use charnames;'",
859 'Name_Alias' => "Accessible via 'use charnames;'",
861 # These are sort of jumping the gun; deprecation is proposed for
862 # Unicode version 6.0, but they have never been exposed by Perl, and
863 # likely are soon to be deprecated, so best not to expose them.
864 FC_NFKC_Closure => 'Use NFKC_Casefold instead',
865 Expands_On_NFC => $why_no_expand,
866 Expands_On_NFD => $why_no_expand,
867 Expands_On_NFKC => $why_no_expand,
868 Expands_On_NFKD => $why_no_expand,
871 # The following are suppressed because they were made contributory or
872 # deprecated by Unicode before Perl ever thought about supporting them.
873 foreach my $property ('Jamo_Short_Name', 'Grapheme_Link') {
874 $why_suppressed{$property} = $why_deprecated{$property};
877 # Customize the message for all the 'Other_' properties
878 foreach my $property (keys %why_deprecated) {
879 next if (my $main_property = $property) !~ s/^Other_//;
880 $why_deprecated{$property} =~ s/$other_properties/the $main_property property (which should be used instead)/;
884 if ($v_version ge 4.0.0) {
885 $why_stabilized{'Hyphen'} = 'Use the Line_Break property instead; see www.unicode.org/reports/tr14';
887 if ($v_version ge 5.2.0) {
888 $why_obsolete{'ISO_Comment'} = 'Code points for it have been removed';
891 # Probably obsolete forever
892 if ($v_version ge v4.1.0) {
893 $why_suppressed{'Script=Katakana_Or_Hiragana'} = 'Obsolete. All code points previously matched by this have been moved to "Script=Common"';
896 # This program can create files for enumerated-like properties, such as
897 # 'Numeric_Type'. This file would be the same format as for a string
898 # property, with a mapping from code point to its value, so you could look up,
899 # for example, the script a code point is in. But no one so far wants this
900 # mapping, or they have found another way to get it since this is a new
901 # feature. So no file is generated except if it is in this list.
902 my @output_mapped_properties = split "\n", <<END;
905 # If you are using the Unihan database, you need to add the properties that
906 # you want to extract from it to this table. For your convenience, the
907 # properties in the 5.2 PropertyAliases.txt file are listed, commented out
908 my @cjk_properties = split "\n", <<'END';
909 #cjkAccountingNumeric; kAccountingNumeric
910 #cjkOtherNumeric; kOtherNumeric
911 #cjkPrimaryNumeric; kPrimaryNumeric
912 #cjkCompatibilityVariant; kCompatibilityVariant
914 #cjkIRG_GSource; kIRG_GSource
915 #cjkIRG_HSource; kIRG_HSource
916 #cjkIRG_JSource; kIRG_JSource
917 #cjkIRG_KPSource; kIRG_KPSource
918 #cjkIRG_KSource; kIRG_KSource
919 #cjkIRG_TSource; kIRG_TSource
920 #cjkIRG_USource; kIRG_USource
921 #cjkIRG_VSource; kIRG_VSource
922 #cjkRSUnicode; kRSUnicode ; Unicode_Radical_Stroke; URS
925 # Similarly for the property values. For your convenience, the lines in the
926 # 5.2 PropertyAliases.txt file are listed. Just remove the first BUT NOT both
928 my @cjk_property_values = split "\n", <<'END';
929 ## @missing: 0000..10FFFF; cjkAccountingNumeric; NaN
930 ## @missing: 0000..10FFFF; cjkCompatibilityVariant; <code point>
931 ## @missing: 0000..10FFFF; cjkIICore; <none>
932 ## @missing: 0000..10FFFF; cjkIRG_GSource; <none>
933 ## @missing: 0000..10FFFF; cjkIRG_HSource; <none>
934 ## @missing: 0000..10FFFF; cjkIRG_JSource; <none>
935 ## @missing: 0000..10FFFF; cjkIRG_KPSource; <none>
936 ## @missing: 0000..10FFFF; cjkIRG_KSource; <none>
937 ## @missing: 0000..10FFFF; cjkIRG_TSource; <none>
938 ## @missing: 0000..10FFFF; cjkIRG_USource; <none>
939 ## @missing: 0000..10FFFF; cjkIRG_VSource; <none>
940 ## @missing: 0000..10FFFF; cjkOtherNumeric; NaN
941 ## @missing: 0000..10FFFF; cjkPrimaryNumeric; NaN
942 ## @missing: 0000..10FFFF; cjkRSUnicode; <none>
945 # The input files don't list every code point. Those not listed are to be
946 # defaulted to some value. Below are hard-coded what those values are for
947 # non-binary properties as of 5.1. Starting in 5.0, there are
948 # machine-parsable comment lines in the files the give the defaults; so this
949 # list shouldn't have to be extended. The claim is that all missing entries
950 # for binary properties will default to 'N'. Unicode tried to change that in
951 # 5.2, but the beta period produced enough protest that they backed off.
953 # The defaults for the fields that appear in UnicodeData.txt in this hash must
954 # be in the form that it expects. The others may be synonyms.
955 my $CODE_POINT = '<code point>';
956 my %default_mapping = (
958 # Bidi_Class => Complicated; set in code
959 Bidi_Mirroring_Glyph => "",
961 Canonical_Combining_Class => 0,
962 Case_Folding => $CODE_POINT,
963 Decomposition_Mapping => $CODE_POINT,
964 Decomposition_Type => 'None',
965 East_Asian_Width => "Neutral",
966 FC_NFKC_Closure => $CODE_POINT,
967 General_Category => 'Cn',
968 Grapheme_Cluster_Break => 'Other',
969 Hangul_Syllable_Type => 'NA',
971 Jamo_Short_Name => "",
972 Joining_Group => "No_Joining_Group",
973 # Joining_Type => Complicated; set in code
974 kIICore => 'N', # Is converted to binary
975 #Line_Break => Complicated; set in code
976 Lowercase_Mapping => $CODE_POINT,
983 Numeric_Type => 'None',
984 Numeric_Value => 'NaN',
985 Script => ($v_version le 4.1.0) ? 'Common' : 'Unknown',
986 Sentence_Break => 'Other',
987 Simple_Case_Folding => $CODE_POINT,
988 Simple_Lowercase_Mapping => $CODE_POINT,
989 Simple_Titlecase_Mapping => $CODE_POINT,
990 Simple_Uppercase_Mapping => $CODE_POINT,
991 Titlecase_Mapping => $CODE_POINT,
992 Unicode_1_Name => "",
993 Unicode_Radical_Stroke => "",
994 Uppercase_Mapping => $CODE_POINT,
995 Word_Break => 'Other',
998 # Below are files that Unicode furnishes, but this program ignores, and why
999 my %ignored_files = (
1000 'CJKRadicals.txt' => 'Unihan data',
1001 'Index.txt' => 'An index, not actual data',
1002 'NamedSqProv.txt' => 'Not officially part of the Unicode standard; Append it to NamedSequences.txt if you want to process the contents.',
1003 'NamesList.txt' => 'Just adds commentary',
1004 'NormalizationCorrections.txt' => 'Data is already in other files.',
1005 'Props.txt' => 'Adds nothing to PropList.txt; only in very early releases',
1006 'ReadMe.txt' => 'Just comments',
1007 'README.TXT' => 'Just comments',
1008 'StandardizedVariants.txt' => 'Only for glyph changes, not a Unicode character property. Does not fit into current scheme where one code point is mapped',
1011 ### End of externally interesting definitions, except for @input_file_objects
1014 # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
1015 # This file is machine-generated by $0 from the Unicode
1016 # database, Version $string_version. Any changes made here will be lost!
1019 my $INTERNAL_ONLY=<<"EOF";
1021 # !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
1022 # This file is for internal use by the Perl program only. The format and even
1023 # the name or existence of this file are subject to change without notice.
1024 # Don't use it directly.
1027 my $DEVELOPMENT_ONLY=<<"EOF";
1028 # !!!!!!! DEVELOPMENT USE ONLY !!!!!!!
1029 # This file contains information artificially constrained to code points
1030 # present in Unicode release $string_compare_versions.
1031 # IT CANNOT BE RELIED ON. It is for use during development only and should
1032 # not be used for production.
1036 my $LAST_UNICODE_CODEPOINT_STRING = "10FFFF";
1037 my $LAST_UNICODE_CODEPOINT = hex $LAST_UNICODE_CODEPOINT_STRING;
1038 my $MAX_UNICODE_CODEPOINTS = $LAST_UNICODE_CODEPOINT + 1;
1040 # Matches legal code point. 4-6 hex numbers, If there are 6, the first
1041 # two must be 10; if there are 5, the first must not be a 0. Written this way
1042 # to decrease backtracking
1044 qr/ \b (?: 10[0-9A-F]{4} | [1-9A-F][0-9A-F]{4} | [0-9A-F]{4} ) \b/x;
1046 # This matches the beginning of the line in the Unicode db files that give the
1047 # defaults for code points not listed (i.e., missing) in the file. The code
1048 # depends on this ending with a semi-colon, so it can assume it is a valid
1049 # field when the line is split() by semi-colons
1050 my $missing_defaults_prefix =
1051 qr/^#\s+\@missing:\s+0000\.\.$LAST_UNICODE_CODEPOINT_STRING\s*;/;
1053 # Property types. Unicode has more types, but these are sufficient for our
1055 my $UNKNOWN = -1; # initialized to illegal value
1056 my $NON_STRING = 1; # Either binary or enum
1058 my $ENUM = 3; # Include catalog
1059 my $STRING = 4; # Anything else: string or misc
1061 # Some input files have lines that give default values for code points not
1062 # contained in the file. Sometimes these should be ignored.
1063 my $NO_DEFAULTS = 0; # Must evaluate to false
1064 my $NOT_IGNORED = 1;
1067 # Range types. Each range has a type. Most ranges are type 0, for normal,
1068 # and will appear in the main body of the tables in the output files, but
1069 # there are other types of ranges as well, listed below, that are specially
1070 # handled. There are pseudo-types as well that will never be stored as a
1071 # type, but will affect the calculation of the type.
1073 # 0 is for normal, non-specials
1074 my $MULTI_CP = 1; # Sequence of more than code point
1075 my $HANGUL_SYLLABLE = 2;
1076 my $CP_IN_NAME = 3; # The NAME contains the code point appended to it.
1077 my $NULL = 4; # The map is to the null string; utf8.c can't
1078 # handle these, nor is there an accepted syntax
1079 # for them in \p{} constructs
1080 my $COMPUTE_NO_MULTI_CP = 5; # Pseudo-type; means that ranges that would
1081 # otherwise be $MULTI_CP type are instead type 0
1083 # process_generic_property_file() can accept certain overrides in its input.
1084 # Each of these must begin AND end with $CMD_DELIM.
1085 my $CMD_DELIM = "\a";
1086 my $REPLACE_CMD = 'replace'; # Override the Replace
1087 my $MAP_TYPE_CMD = 'map_type'; # Override the Type
1092 # Values for the Replace argument to add_range.
1093 # $NO # Don't replace; add only the code points not
1095 my $IF_NOT_EQUIVALENT = 1; # Replace only under certain conditions; details in
1096 # the comments at the subroutine definition.
1097 my $UNCONDITIONALLY = 2; # Replace without conditions.
1098 my $MULTIPLE = 4; # Don't replace, but add a duplicate record if
1101 # Flags to give property statuses. The phrases are to remind maintainers that
1102 # if the flag is changed, the indefinite article referring to it in the
1103 # documentation may need to be as well.
1105 my $SUPPRESSED = 'z'; # The character should never actually be seen, since
1107 my $PLACEHOLDER = 'P'; # Implies no pod entry generated
1108 my $DEPRECATED = 'D';
1109 my $a_bold_deprecated = "a 'B<$DEPRECATED>'";
1110 my $A_bold_deprecated = "A 'B<$DEPRECATED>'";
1111 my $DISCOURAGED = 'X';
1112 my $a_bold_discouraged = "an 'B<$DISCOURAGED>'";
1113 my $A_bold_discouraged = "An 'B<$DISCOURAGED>'";
1115 my $a_bold_stricter = "a 'B<$STRICTER>'";
1116 my $A_bold_stricter = "A 'B<$STRICTER>'";
1117 my $STABILIZED = 'S';
1118 my $a_bold_stabilized = "an 'B<$STABILIZED>'";
1119 my $A_bold_stabilized = "An 'B<$STABILIZED>'";
1121 my $a_bold_obsolete = "an 'B<$OBSOLETE>'";
1122 my $A_bold_obsolete = "An 'B<$OBSOLETE>'";
1124 my %status_past_participles = (
1125 $DISCOURAGED => 'discouraged',
1126 $SUPPRESSED => 'should never be generated',
1127 $STABILIZED => 'stabilized',
1128 $OBSOLETE => 'obsolete',
1129 $DEPRECATED => 'deprecated',
1132 # The format of the values of the map tables:
1133 my $BINARY_FORMAT = 'b';
1134 my $DECIMAL_FORMAT = 'd';
1135 my $FLOAT_FORMAT = 'f';
1136 my $INTEGER_FORMAT = 'i';
1137 my $HEX_FORMAT = 'x';
1138 my $RATIONAL_FORMAT = 'r';
1139 my $STRING_FORMAT = 's';
1141 my %map_table_formats = (
1142 $BINARY_FORMAT => 'binary',
1143 $DECIMAL_FORMAT => 'single decimal digit',
1144 $FLOAT_FORMAT => 'floating point number',
1145 $INTEGER_FORMAT => 'integer',
1146 $HEX_FORMAT => 'positive hex whole number; a code point',
1147 $RATIONAL_FORMAT => 'rational: an integer or a fraction',
1148 $STRING_FORMAT => 'arbitrary string',
1151 # Unicode didn't put such derived files in a separate directory at first.
1152 my $EXTRACTED_DIR = (-d 'extracted') ? 'extracted' : "";
1153 my $EXTRACTED = ($EXTRACTED_DIR) ? "$EXTRACTED_DIR/" : "";
1154 my $AUXILIARY = 'auxiliary';
1156 # Hashes that will eventually go into Heavy.pl for the use of utf8_heavy.pl
1157 my %loose_to_file_of; # loosely maps table names to their respective
1159 my %stricter_to_file_of; # same; but for stricter mapping.
1160 my %nv_floating_to_rational; # maps numeric values floating point numbers to
1161 # their rational equivalent
1162 my %loose_property_name_of; # Loosely maps property names to standard form
1164 # These constants names and values were taken from the Unicode standard,
1165 # version 5.1, section 3.12. They are used in conjunction with Hangul
1175 my $NCount = $VCount * $TCount;
1177 # For Hangul syllables; These store the numbers from Jamo.txt in conjunction
1178 # with the above published constants.
1180 my %Jamo_L; # Leading consonants
1181 my %Jamo_V; # Vowels
1182 my %Jamo_T; # Trailing consonants
1184 my @backslash_X_tests; # List of tests read in for testing \X
1185 my @unhandled_properties; # Will contain a list of properties found in
1186 # the input that we didn't process.
1187 my @match_properties; # Properties that have match tables, to be
1189 my @map_properties; # Properties that get map files written
1190 my @named_sequences; # NamedSequences.txt contents.
1191 my %potential_files; # Generated list of all .txt files in the directory
1192 # structure so we can warn if something is being
1194 my @files_actually_output; # List of files we generated.
1195 my @more_Names; # Some code point names are compound; this is used
1196 # to store the extra components of them.
1197 my $MIN_FRACTION_LENGTH = 3; # How many digits of a floating point number at
1198 # the minimum before we consider it equivalent to a
1199 # candidate rational
1200 my $MAX_FLOATING_SLOP = 10 ** - $MIN_FRACTION_LENGTH; # And in floating terms
1202 # These store references to certain commonly used property objects
1207 # Are there conflicting names because of beginning with 'In_', or 'Is_'
1208 my $has_In_conflicts = 0;
1209 my $has_Is_conflicts = 0;
1211 sub internal_file_to_platform ($) {
1212 # Convert our file paths which have '/' separators to those of the
1216 return undef unless defined $file;
1218 return File::Spec->join(split '/', $file);
1221 sub file_exists ($) { # platform independent '-e'. This program internally
1222 # uses slash as a path separator.
1224 return 0 if ! defined $file;
1225 return -e internal_file_to_platform($file);
1229 # Returns the address of the blessed input object.
1230 # It doesn't check for blessedness because that would do a string eval
1231 # every call, and the program is structured so that this is never called
1232 # for a non-blessed object.
1234 no overloading; # If overloaded, numifying below won't work.
1236 # Numifying a ref gives its address.
1240 # Commented code below should work on Perl 5.8.
1241 ## This 'require' doesn't necessarily work in miniperl, and even if it does,
1242 ## the native perl version of it (which is what would operate under miniperl)
1243 ## is extremely slow, as it does a string eval every call.
1244 #my $has_fast_scalar_util = $
\18 !~ /miniperl/
1245 # && defined eval "require Scalar::Util";
1248 # # Returns the address of the blessed input object. Uses the XS version if
1249 # # available. It doesn't check for blessedness because that would do a
1250 # # string eval every call, and the program is structured so that this is
1251 # # never called for a non-blessed object.
1253 # return Scalar::Util::refaddr($_[0]) if $has_fast_scalar_util;
1255 # # Check at least that is a ref.
1256 # my $pkg = ref($_[0]) or return undef;
1258 # # Change to a fake package to defeat any overloaded stringify
1259 # bless $_[0], 'main::Fake';
1261 # # Numifying a ref gives its address.
1262 # my $addr = 0 + $_[0];
1264 # # Return to original class
1265 # bless $_[0], $pkg;
1272 return $a if $a >= $b;
1279 return $a if $a <= $b;
1283 sub clarify_number ($) {
1284 # This returns the input number with underscores inserted every 3 digits
1285 # in large (5 digits or more) numbers. Input must be entirely digits, not
1289 my $pos = length($number) - 3;
1290 return $number if $pos <= 1;
1292 substr($number, $pos, 0) = '_';
1301 # These routines give a uniform treatment of messages in this program. They
1302 # are placed in the Carp package to cause the stack trace to not include them,
1303 # although an alternative would be to use another package and set @CARP_NOT
1306 our $Verbose = 1 if main::DEBUG; # Useful info when debugging
1308 # This is a work-around suggested by Nicholas Clark to fix a problem with Carp
1309 # and overload trying to load Scalar:Util under miniperl. See
1310 # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2009-11/msg01057.html
1311 undef $overload::VERSION;
1314 my $message = shift || "";
1315 my $nofold = shift || 0;
1318 $message = main::join_lines($message);
1319 $message =~ s/^$0: *//; # Remove initial program name
1320 $message =~ s/[.;,]+$//; # Remove certain ending punctuation
1321 $message = "\n$0: $message;";
1323 # Fold the message with program name, semi-colon end punctuation
1324 # (which looks good with the message that carp appends to it), and a
1325 # hanging indent for continuation lines.
1326 $message = main::simple_fold($message, "", 4) unless $nofold;
1327 $message =~ s/\n$//; # Remove the trailing nl so what carp
1328 # appends is to the same line
1331 return $message if defined wantarray; # If a caller just wants the msg
1338 # This is called when it is clear that the problem is caused by a bug in
1341 my $message = shift;
1342 $message =~ s/^$0: *//;
1343 $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");
1348 sub carp_too_few_args {
1350 my_carp_bug("Wrong number of arguments: to 'carp_too_few_arguments'. No action taken.");
1354 my $args_ref = shift;
1357 my_carp_bug("Need at least $count arguments to "
1359 . ". Instead got: '"
1360 . join ', ', @$args_ref
1361 . "'. No action taken.");
1365 sub carp_extra_args {
1366 my $args_ref = shift;
1367 my_carp_bug("Too many arguments to 'carp_extra_args': (" . join(', ', @_) . "); Extras ignored.") if @_;
1369 unless (ref $args_ref) {
1370 my_carp_bug("Argument to 'carp_extra_args' ($args_ref) must be a ref. Not checking arguments.");
1373 my ($package, $file, $line) = caller;
1374 my $subroutine = (caller 1)[3];
1377 if (ref $args_ref eq 'HASH') {
1378 foreach my $key (keys %$args_ref) {
1379 $args_ref->{$key} = $UNDEF unless defined $args_ref->{$key};
1381 $list = join ', ', each %{$args_ref};
1383 elsif (ref $args_ref eq 'ARRAY') {
1384 foreach my $arg (@$args_ref) {
1385 $arg = $UNDEF unless defined $arg;
1387 $list = join ', ', @$args_ref;
1390 my_carp_bug("Can't cope with ref "
1392 . " . argument to 'carp_extra_args'. Not checking arguments.");
1396 my_carp_bug("Unrecognized parameters in options: '$list' to $subroutine. Skipped.");
1404 # This program uses the inside-out method for objects, as recommended in
1405 # "Perl Best Practices". This closure aids in generating those. There
1406 # are two routines. setup_package() is called once per package to set
1407 # things up, and then set_access() is called for each hash representing a
1408 # field in the object. These routines arrange for the object to be
1409 # properly destroyed when no longer used, and for standard accessor
1410 # functions to be generated. If you need more complex accessors, just
1411 # write your own and leave those accesses out of the call to set_access().
1412 # More details below.
1414 my %constructor_fields; # fields that are to be used in constructors; see
1417 # The values of this hash will be the package names as keys to other
1418 # hashes containing the name of each field in the package as keys, and
1419 # references to their respective hashes as values.
1423 # Sets up the package, creating standard DESTROY and dump methods
1424 # (unless already defined). The dump method is used in debugging by
1426 # The optional parameters are:
1427 # a) a reference to a hash, that gets populated by later
1428 # set_access() calls with one of the accesses being
1429 # 'constructor'. The caller can then refer to this, but it is
1430 # not otherwise used by these two routines.
1431 # b) a reference to a callback routine to call during destruction
1432 # of the object, before any fields are actually destroyed
1435 my $constructor_ref = delete $args{'Constructor_Fields'};
1436 my $destroy_callback = delete $args{'Destroy_Callback'};
1437 Carp::carp_extra_args(\@_) if main::DEBUG && %args;
1440 my $package = (caller)[0];
1442 $package_fields{$package} = \%fields;
1443 $constructor_fields{$package} = $constructor_ref;
1445 unless ($package->can('DESTROY')) {
1446 my $destroy_name = "${package}::DESTROY";
1449 # Use typeglob to give the anonymous subroutine the name we want
1450 *$destroy_name = sub {
1452 my $addr; { no overloading; $addr = 0+$self; }
1454 $self->$destroy_callback if $destroy_callback;
1455 foreach my $field (keys %{$package_fields{$package}}) {
1456 #print STDERR __LINE__, ": Destroying ", ref $self, " ", sprintf("%04X", $addr), ": ", $field, "\n";
1457 delete $package_fields{$package}{$field}{$addr};
1463 unless ($package->can('dump')) {
1464 my $dump_name = "${package}::dump";
1468 return dump_inside_out($self, $package_fields{$package}, @_);
1475 # Arrange for the input field to be garbage collected when no longer
1476 # needed. Also, creates standard accessor functions for the field
1477 # based on the optional parameters-- none if none of these parameters:
1478 # 'addable' creates an 'add_NAME()' accessor function.
1479 # 'readable' or 'readable_array' creates a 'NAME()' accessor
1481 # 'settable' creates a 'set_NAME()' accessor function.
1482 # 'constructor' doesn't create an accessor function, but adds the
1483 # field to the hash that was previously passed to
1485 # Any of the accesses can be abbreviated down, so that 'a', 'ad',
1486 # 'add' etc. all mean 'addable'.
1487 # The read accessor function will work on both array and scalar
1488 # values. If another accessor in the parameter list is 'a', the read
1489 # access assumes an array. You can also force it to be array access
1490 # by specifying 'readable_array' instead of 'readable'
1492 # A sort-of 'protected' access can be set-up by preceding the addable,
1493 # readable or settable with some initial portion of 'protected_' (but,
1494 # the underscore is required), like 'p_a', 'pro_set', etc. The
1495 # "protection" is only by convention. All that happens is that the
1496 # accessor functions' names begin with an underscore. So instead of
1497 # calling set_foo, the call is _set_foo. (Real protection could be
1498 # accomplished by having a new subroutine, end_package called at the
1499 # end of each package, and then storing the __LINE__ ranges and
1500 # checking them on every accessor. But that is way overkill.)
1502 # We create anonymous subroutines as the accessors and then use
1503 # typeglobs to assign them to the proper package and name
1505 my $name = shift; # Name of the field
1506 my $field = shift; # Reference to the inside-out hash containing the
1509 my $package = (caller)[0];
1511 if (! exists $package_fields{$package}) {
1512 croak "$0: Must call 'setup_package' before 'set_access'";
1515 # Stash the field so DESTROY can get it.
1516 $package_fields{$package}{$name} = $field;
1518 # Remaining arguments are the accessors. For each...
1519 foreach my $access (@_) {
1520 my $access = lc $access;
1524 # Match the input as far as it goes.
1525 if ($access =~ /^(p[^_]*)_/) {
1527 if (substr('protected_', 0, length $protected)
1531 # Add 1 for the underscore not included in $protected
1532 $access = substr($access, length($protected) + 1);
1540 if (substr('addable', 0, length $access) eq $access) {
1541 my $subname = "${package}::${protected}add_$name";
1544 # add_ accessor. Don't add if already there, which we
1545 # determine using 'eq' for scalars and '==' otherwise.
1548 return Carp::carp_too_few_args(\@_, 2) if main::DEBUG && @_ < 2;
1551 my $addr; { no overloading; $addr = 0+$self; }
1552 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
1554 return if grep { $value == $_ } @{$field->{$addr}};
1557 return if grep { $value eq $_ } @{$field->{$addr}};
1559 push @{$field->{$addr}}, $value;
1563 elsif (substr('constructor', 0, length $access) eq $access) {
1565 Carp::my_carp_bug("Can't set-up 'protected' constructors")
1568 $constructor_fields{$package}{$name} = $field;
1571 elsif (substr('readable_array', 0, length $access) eq $access) {
1573 # Here has read access. If one of the other parameters for
1574 # access is array, or this one specifies array (by being more
1575 # than just 'readable_'), then create a subroutine that
1576 # assumes the data is an array. Otherwise just a scalar
1577 my $subname = "${package}::${protected}$name";
1578 if (grep { /^a/i } @_
1579 or length($access) > length('readable_'))
1584 Carp::carp_extra_args(\@_) if main::DEBUG && @_ > 1;
1585 my $addr; { no overloading; $addr = 0+$_[0]; }
1586 if (ref $field->{$addr} ne 'ARRAY') {
1587 my $type = ref $field->{$addr};
1588 $type = 'scalar' unless $type;
1589 Carp::my_carp_bug("Trying to read $name as an array when it is a $type. Big problems.");
1592 return scalar @{$field->{$addr}} unless wantarray;
1594 # Make a copy; had problems with caller modifying the
1595 # original otherwise
1596 my @return = @{$field->{$addr}};
1602 # Here not an array value, a simpler function.
1606 Carp::carp_extra_args(\@_) if main::DEBUG && @_ > 1;
1608 return $field->{0+$_[0]};
1612 elsif (substr('settable', 0, length $access) eq $access) {
1613 my $subname = "${package}::${protected}set_$name";
1618 return Carp::carp_too_few_args(\@_, 2) if @_ < 2;
1619 Carp::carp_extra_args(\@_) if @_ > 2;
1621 # $self is $_[0]; $value is $_[1]
1623 $field->{0+$_[0]} = $_[1];
1628 Carp::my_carp_bug("Unknown accessor type $access. No accessor set.");
1637 # All input files use this object, which stores various attributes about them,
1638 # and provides for convenient, uniform handling. The run method wraps the
1639 # processing. It handles all the bookkeeping of opening, reading, and closing
1640 # the file, returning only significant input lines.
1642 # Each object gets a handler which processes the body of the file, and is
1643 # called by run(). Most should use the generic, default handler, which has
1644 # code scrubbed to handle things you might not expect. A handler should
1645 # basically be a while(next_line()) {...} loop.
1647 # You can also set up handlers to
1648 # 1) call before the first line is read for pre processing
1649 # 2) call to adjust each line of the input before the main handler gets them
1650 # 3) call upon EOF before the main handler exits its loop
1651 # 4) call at the end for post processing
1653 # $_ is used to store the input line, and is to be filtered by the
1654 # each_line_handler()s. So, if the format of the line is not in the desired
1655 # format for the main handler, these are used to do that adjusting. They can
1656 # be stacked (by enclosing them in an [ anonymous array ] in the constructor,
1657 # so the $_ output of one is used as the input to the next. None of the other
1658 # handlers are stackable, but could easily be changed to be so.
1660 # Most of the handlers can call insert_lines() or insert_adjusted_lines()
1661 # which insert the parameters as lines to be processed before the next input
1662 # file line is read. This allows the EOF handler to flush buffers, for
1663 # example. The difference between the two routines is that the lines inserted
1664 # by insert_lines() are subjected to the each_line_handler()s. (So if you
1665 # called it from such a handler, you would get infinite recursion.) Lines
1666 # inserted by insert_adjusted_lines() go directly to the main handler without
1667 # any adjustments. If the post-processing handler calls any of these, there
1668 # will be no effect. Some error checking for these conditions could be added,
1669 # but it hasn't been done.
1671 # carp_bad_line() should be called to warn of bad input lines, which clears $_
1672 # to prevent further processing of the line. This routine will output the
1673 # message as a warning once, and then keep a count of the lines that have the
1674 # same message, and output that count at the end of the file's processing.
1675 # This keeps the number of messages down to a manageable amount.
1677 # get_missings() should be called to retrieve any @missing input lines.
1678 # Messages will be raised if this isn't done if the options aren't to ignore
1681 sub trace { return main::trace(@_); }
1684 # Keep track of fields that are to be put into the constructor.
1685 my %constructor_fields;
1687 main::setup_package(Constructor_Fields => \%constructor_fields);
1689 my %file; # Input file name, required
1690 main::set_access('file', \%file, qw{ c r });
1692 my %first_released; # Unicode version file was first released in, required
1693 main::set_access('first_released', \%first_released, qw{ c r });
1695 my %handler; # Subroutine to process the input file, defaults to
1696 # 'process_generic_property_file'
1697 main::set_access('handler', \%handler, qw{ c });
1700 # name of property this file is for. defaults to none, meaning not
1701 # applicable, or is otherwise determinable, for example, from each line.
1702 main::set_access('property', \%property, qw{ c });
1705 # If this is true, the file is optional. If not present, no warning is
1706 # output. If it is present, the string given by this parameter is
1707 # evaluated, and if false the file is not processed.
1708 main::set_access('optional', \%optional, 'c', 'r');
1711 # This is used for debugging, to skip processing of all but a few input
1712 # files. Add 'non_skip => 1' to the constructor for those files you want
1713 # processed when you set the $debug_skip global.
1714 main::set_access('non_skip', \%non_skip, 'c');
1717 # This is used to skip processing of this input file semi-permanently.
1718 # It is used for files that we aren't planning to process anytime soon,
1719 # but want to allow to be in the directory and not raise a message that we
1720 # are not handling. Mostly for test files. This is in contrast to the
1721 # non_skip element, which is supposed to be used very temporarily for
1722 # debugging. Sets 'optional' to 1
1723 main::set_access('skip', \%skip, 'c');
1725 my %each_line_handler;
1726 # list of subroutines to look at and filter each non-comment line in the
1727 # file. defaults to none. The subroutines are called in order, each is
1728 # to adjust $_ for the next one, and the final one adjusts it for
1730 main::set_access('each_line_handler', \%each_line_handler, 'c');
1732 my %has_missings_defaults;
1733 # ? Are there lines in the file giving default values for code points
1734 # missing from it?. Defaults to NO_DEFAULTS. Otherwise NOT_IGNORED is
1735 # the norm, but IGNORED means it has such lines, but the handler doesn't
1736 # use them. Having these three states allows us to catch changes to the
1737 # UCD that this program should track
1738 main::set_access('has_missings_defaults',
1739 \%has_missings_defaults, qw{ c r });
1742 # Subroutine to call before doing anything else in the file. If undef, no
1743 # such handler is called.
1744 main::set_access('pre_handler', \%pre_handler, qw{ c });
1747 # Subroutine to call upon getting an EOF on the input file, but before
1748 # that is returned to the main handler. This is to allow buffers to be
1749 # flushed. The handler is expected to call insert_lines() or
1750 # insert_adjusted() with the buffered material
1751 main::set_access('eof_handler', \%eof_handler, qw{ c r });
1754 # Subroutine to call after all the lines of the file are read in and
1755 # processed. If undef, no such handler is called.
1756 main::set_access('post_handler', \%post_handler, qw{ c });
1758 my %progress_message;
1759 # Message to print to display progress in lieu of the standard one
1760 main::set_access('progress_message', \%progress_message, qw{ c });
1763 # cache open file handle, internal. Is undef if file hasn't been
1764 # processed at all, empty if has;
1765 main::set_access('handle', \%handle);
1768 # cache of lines added virtually to the file, internal
1769 main::set_access('added_lines', \%added_lines);
1772 # cache of errors found, internal
1773 main::set_access('errors', \%errors);
1776 # storage of '@missing' defaults lines
1777 main::set_access('missings', \%missings);
1782 my $self = bless \do{ my $anonymous_scalar }, $class;
1783 my $addr; { no overloading; $addr = 0+$self; }
1786 $handler{$addr} = \&main::process_generic_property_file;
1787 $non_skip{$addr} = 0;
1789 $has_missings_defaults{$addr} = $NO_DEFAULTS;
1790 $handle{$addr} = undef;
1791 $added_lines{$addr} = [ ];
1792 $each_line_handler{$addr} = [ ];
1793 $errors{$addr} = { };
1794 $missings{$addr} = [ ];
1796 # Two positional parameters.
1797 return Carp::carp_too_few_args(\@_, 2) if main::DEBUG && @_ < 2;
1798 $file{$addr} = main::internal_file_to_platform(shift);
1799 $first_released{$addr} = shift;
1801 # The rest of the arguments are key => value pairs
1802 # %constructor_fields has been set up earlier to list all possible
1803 # ones. Either set or push, depending on how the default has been set
1806 foreach my $key (keys %args) {
1807 my $argument = $args{$key};
1809 # Note that the fields are the lower case of the constructor keys
1810 my $hash = $constructor_fields{lc $key};
1811 if (! defined $hash) {
1812 Carp::my_carp_bug("Unrecognized parameters '$key => $argument' to new() for $self. Skipped");
1815 if (ref $hash->{$addr} eq 'ARRAY') {
1816 if (ref $argument eq 'ARRAY') {
1817 foreach my $argument (@{$argument}) {
1818 next if ! defined $argument;
1819 push @{$hash->{$addr}}, $argument;
1823 push @{$hash->{$addr}}, $argument if defined $argument;
1827 $hash->{$addr} = $argument;
1832 # If the file has a property for it, it means that the property is not
1833 # listed in the file's entries. So add a handler to the list of line
1834 # handlers to insert the property name into the lines, to provide a
1835 # uniform interface to the final processing subroutine.
1836 # the final code doesn't have to worry about that.
1837 if ($property{$addr}) {
1838 push @{$each_line_handler{$addr}}, \&_insert_property_into_line;
1841 if ($non_skip{$addr} && ! $debug_skip && $verbosity) {
1842 print "Warning: " . __PACKAGE__ . " constructor for $file{$addr} has useless 'non_skip' in it\n";
1845 $optional{$addr} = 1 if $skip{$addr};
1853 qw("") => "_operator_stringify",
1854 "." => \&main::_operator_dot,
1857 sub _operator_stringify {
1860 return __PACKAGE__ . " object for " . $self->file;
1863 # flag to make sure extracted files are processed early
1864 my $seen_non_extracted_non_age = 0;
1867 # Process the input object $self. This opens and closes the file and
1868 # calls all the handlers for it. Currently, this can only be called
1869 # once per file, as it destroy's the EOF handler
1872 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
1874 my $addr; { no overloading; $addr = 0+$self; }
1876 my $file = $file{$addr};
1878 # Don't process if not expecting this file (because released later
1879 # than this Unicode version), and isn't there. This means if someone
1880 # copies it into an earlier version's directory, we will go ahead and
1882 return if $first_released{$addr} gt $v_version && ! -e $file;
1884 # If in debugging mode and this file doesn't have the non-skip
1885 # flag set, and isn't one of the critical files, skip it.
1887 && $first_released{$addr} ne v0
1888 && ! $non_skip{$addr})
1890 print "Skipping $file in debugging\n" if $verbosity;
1894 # File could be optional
1895 if ($optional{$addr}) {
1896 return unless -e $file;
1897 my $result = eval $optional{$addr};
1898 if (! defined $result) {
1899 Carp::my_carp_bug("Got '$@' when tried to eval $optional{$addr}. $file Skipped.");
1904 print STDERR "Skipping processing input file '$file' because '$optional{$addr}' is not true\n";
1910 if (! defined $file || ! -e $file) {
1912 # If the file doesn't exist, see if have internal data for it
1913 # (based on first_released being 0).
1914 if ($first_released{$addr} eq v0) {
1915 $handle{$addr} = 'pretend_is_open';
1918 if (! $optional{$addr} # File could be optional
1919 && $v_version ge $first_released{$addr})
1921 print STDERR "Skipping processing input file '$file' because not found\n" if $v_version ge $first_released{$addr};
1928 # Here, the file exists. Some platforms may change the case of
1930 if ($seen_non_extracted_non_age) {
1931 if ($file =~ /$EXTRACTED/i) {
1932 Carp::my_carp_bug(join_lines(<<END
1933 $file should be processed just after the 'Prop...Alias' files, and before
1934 anything not in the $EXTRACTED_DIR directory. Proceeding, but the results may
1935 have subtle problems
1940 elsif ($EXTRACTED_DIR
1941 && $first_released{$addr} ne v0
1942 && $file !~ /$EXTRACTED/i
1943 && lc($file) ne 'dage.txt')
1945 # We don't set this (by the 'if' above) if we have no
1946 # extracted directory, so if running on an early version,
1947 # this test won't work. Not worth worrying about.
1948 $seen_non_extracted_non_age = 1;
1951 # And mark the file as having being processed, and warn if it
1952 # isn't a file we are expecting. As we process the files,
1953 # they are deleted from the hash, so any that remain at the
1954 # end of the program are files that we didn't process.
1955 my $fkey = File::Spec->rel2abs($file);
1956 my $expecting = delete $potential_files{$fkey};
1957 $expecting = delete $potential_files{lc($fkey)} unless defined $expecting;
1958 Carp::my_carp("Was not expecting '$file'.") if
1960 && ! defined $handle{$addr};
1962 # Having deleted from expected files, we can quit if not to do
1963 # anything. Don't print progress unless really want verbosity
1965 print "Skipping $file.\n" if $verbosity >= $VERBOSE;
1969 # Open the file, converting the slashes used in this program
1970 # into the proper form for the OS
1972 if (not open $file_handle, "<", $file) {
1973 Carp::my_carp("Can't open $file. Skipping: $!");
1976 $handle{$addr} = $file_handle; # Cache the open file handle
1979 if ($verbosity >= $PROGRESS) {
1980 if ($progress_message{$addr}) {
1981 print "$progress_message{$addr}\n";
1984 # If using a virtual file, say so.
1985 print "Processing ", (-e $file)
1987 : "substitute $file",
1993 # Call any special handler for before the file.
1994 &{$pre_handler{$addr}}($self) if $pre_handler{$addr};
1996 # Then the main handler
1997 &{$handler{$addr}}($self);
1999 # Then any special post-file handler.
2000 &{$post_handler{$addr}}($self) if $post_handler{$addr};
2002 # If any errors have been accumulated, output the counts (as the first
2003 # error message in each class was output when it was encountered).
2004 if ($errors{$addr}) {
2007 foreach my $error (keys %{$errors{$addr}}) {
2008 $total += $errors{$addr}->{$error};
2009 delete $errors{$addr}->{$error};
2014 = "A total of $total lines had errors in $file. ";
2016 $message .= ($types == 1)
2017 ? '(Only the first one was displayed.)'
2018 : '(Only the first of each type was displayed.)';
2019 Carp::my_carp($message);
2023 if (@{$missings{$addr}}) {
2024 Carp::my_carp_bug("Handler for $file didn't look at all the \@missing lines. Generated tables likely are wrong");
2027 # If a real file handle, close it.
2028 close $handle{$addr} or Carp::my_carp("Can't close $file: $!") if
2030 $handle{$addr} = ""; # Uses empty to indicate that has already seen
2031 # the file, as opposed to undef
2036 # Sets $_ to be the next logical input line, if any. Returns non-zero
2037 # if such a line exists. 'logical' means that any lines that have
2038 # been added via insert_lines() will be returned in $_ before the file
2042 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2044 my $addr; { no overloading; $addr = 0+$self; }
2046 # Here the file is open (or if the handle is not a ref, is an open
2047 # 'virtual' file). Get the next line; any inserted lines get priority
2048 # over the file itself.
2052 while (1) { # Loop until find non-comment, non-empty line
2053 #local $to_trace = 1 if main::DEBUG;
2054 my $inserted_ref = shift @{$added_lines{$addr}};
2055 if (defined $inserted_ref) {
2056 ($adjusted, $_) = @{$inserted_ref};
2057 trace $adjusted, $_ if main::DEBUG && $to_trace;
2058 return 1 if $adjusted;
2061 last if ! ref $handle{$addr}; # Don't read unless is real file
2062 last if ! defined ($_ = readline $handle{$addr});
2065 trace $_ if main::DEBUG && $to_trace;
2067 # See if this line is the comment line that defines what property
2068 # value that code points that are not listed in the file should
2069 # have. The format or existence of these lines is not guaranteed
2070 # by Unicode since they are comments, but the documentation says
2071 # that this was added for machine-readability, so probably won't
2072 # change. This works starting in Unicode Version 5.0. They look
2075 # @missing: 0000..10FFFF; Not_Reordered
2076 # @missing: 0000..10FFFF; Decomposition_Mapping; <code point>
2077 # @missing: 0000..10FFFF; ; NaN
2079 # Save the line for a later get_missings() call.
2080 if (/$missing_defaults_prefix/) {
2081 if ($has_missings_defaults{$addr} == $NO_DEFAULTS) {
2082 $self->carp_bad_line("Unexpected \@missing line. Assuming no missing entries");
2084 elsif ($has_missings_defaults{$addr} == $NOT_IGNORED) {
2085 my @defaults = split /\s* ; \s*/x, $_;
2087 # The first field is the @missing, which ends in a
2088 # semi-colon, so can safely shift.
2091 # Some of these lines may have empty field placeholders
2092 # which get in the way. An example is:
2093 # @missing: 0000..10FFFF; ; NaN
2094 # Remove them. Process starting from the top so the
2095 # splice doesn't affect things still to be looked at.
2096 for (my $i = @defaults - 1; $i >= 0; $i--) {
2097 next if $defaults[$i] ne "";
2098 splice @defaults, $i, 1;
2101 # What's left should be just the property (maybe) and the
2102 # default. Having only one element means it doesn't have
2106 if (@defaults >= 1) {
2107 if (@defaults == 1) {
2108 $default = $defaults[0];
2111 $property = $defaults[0];
2112 $default = $defaults[1];
2118 || ($default =~ /^</
2119 && $default !~ /^<code *point>$/i
2120 && $default !~ /^<none>$/i))
2122 $self->carp_bad_line("Unrecognized \@missing line: $_. Assuming no missing entries");
2126 # If the property is missing from the line, it should
2127 # be the one for the whole file
2128 $property = $property{$addr} if ! defined $property;
2130 # Change <none> to the null string, which is what it
2131 # really means. If the default is the code point
2132 # itself, set it to <code point>, which is what
2133 # Unicode uses (but sometimes they've forgotten the
2135 if ($default =~ /^<none>$/i) {
2138 elsif ($default =~ /^<code *point>$/i) {
2139 $default = $CODE_POINT;
2142 # Store them as a sub-arrays with both components.
2143 push @{$missings{$addr}}, [ $default, $property ];
2147 # There is nothing for the caller to process on this comment
2152 # Remove comments and trailing space, and skip this line if the
2158 # Call any handlers for this line, and skip further processing of
2159 # the line if the handler sets the line to null.
2160 foreach my $sub_ref (@{$each_line_handler{$addr}}) {
2165 # Here the line is ok. return success.
2167 } # End of looping through lines.
2169 # If there is an EOF handler, call it (only once) and if it generates
2170 # more lines to process go back in the loop to handle them.
2171 if ($eof_handler{$addr}) {
2172 &{$eof_handler{$addr}}($self);
2173 $eof_handler{$addr} = ""; # Currently only get one shot at it.
2174 goto LINE if $added_lines{$addr};
2177 # Return failure -- no more lines.
2182 # Not currently used, not fully tested.
2184 # # Non-destructive look-ahead one non-adjusted, non-comment, non-blank
2185 # # record. Not callable from an each_line_handler(), nor does it call
2186 # # an each_line_handler() on the line.
2189 # my $addr; { no overloading; $addr = 0+$self; }
2191 # foreach my $inserted_ref (@{$added_lines{$addr}}) {
2192 # my ($adjusted, $line) = @{$inserted_ref};
2193 # next if $adjusted;
2195 # # Remove comments and trailing space, and return a non-empty
2198 # $line =~ s/\s+$//;
2199 # return $line if $line ne "";
2202 # return if ! ref $handle{$addr}; # Don't read unless is real file
2203 # while (1) { # Loop until find non-comment, non-empty line
2204 # local $to_trace = 1 if main::DEBUG;
2205 # trace $_ if main::DEBUG && $to_trace;
2206 # return if ! defined (my $line = readline $handle{$addr});
2208 # push @{$added_lines{$addr}}, [ 0, $line ];
2211 # $line =~ s/\s+$//;
2212 # return $line if $line ne "";
2220 # Lines can be inserted so that it looks like they were in the input
2221 # file at the place it was when this routine is called. See also
2222 # insert_adjusted_lines(). Lines inserted via this routine go through
2223 # any each_line_handler()
2227 # Each inserted line is an array, with the first element being 0 to
2228 # indicate that this line hasn't been adjusted, and needs to be
2231 push @{$added_lines{0+$self}}, map { [ 0, $_ ] } @_;
2235 sub insert_adjusted_lines {
2236 # Lines can be inserted so that it looks like they were in the input
2237 # file at the place it was when this routine is called. See also
2238 # insert_lines(). Lines inserted via this routine are already fully
2239 # adjusted, ready to be processed; each_line_handler()s handlers will
2240 # not be called. This means this is not a completely general
2241 # facility, as only the last each_line_handler on the stack should
2242 # call this. It could be made more general, by passing to each of the
2243 # line_handlers their position on the stack, which they would pass on
2244 # to this routine, and that would replace the boolean first element in
2245 # the anonymous array pushed here, so that the next_line routine could
2246 # use that to call only those handlers whose index is after it on the
2247 # stack. But this is overkill for what is needed now.
2250 trace $_[0] if main::DEBUG && $to_trace;
2252 # Each inserted line is an array, with the first element being 1 to
2253 # indicate that this line has been adjusted
2255 push @{$added_lines{0+$self}}, map { [ 1, $_ ] } @_;
2260 # Returns the stored up @missings lines' values, and clears the list.
2261 # The values are in an array, consisting of the default in the first
2262 # element, and the property in the 2nd. However, since these lines
2263 # can be stacked up, the return is an array of all these arrays.
2266 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2268 my $addr; { no overloading; $addr = 0+$self; }
2270 # If not accepting a list return, just return the first one.
2271 return shift @{$missings{$addr}} unless wantarray;
2273 my @return = @{$missings{$addr}};
2274 undef @{$missings{$addr}};
2278 sub _insert_property_into_line {
2279 # Add a property field to $_, if this file requires it.
2282 my $addr; { no overloading; $addr = 0+$self; }
2283 my $property = $property{$addr};
2284 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2286 $_ =~ s/(;|$)/; $property$1/;
2291 # Output consistent error messages, using either a generic one, or the
2292 # one given by the optional parameter. To avoid gazillions of the
2293 # same message in case the syntax of a file is way off, this routine
2294 # only outputs the first instance of each message, incrementing a
2295 # count so the totals can be output at the end of the file.
2298 my $message = shift;
2299 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2301 my $addr; { no overloading; $addr = 0+$self; }
2303 $message = 'Unexpected line' unless $message;
2305 # No trailing punctuation so as to fit with our addenda.
2306 $message =~ s/[.:;,]$//;
2308 # If haven't seen this exact message before, output it now. Otherwise
2309 # increment the count of how many times it has occurred
2310 unless ($errors{$addr}->{$message}) {
2311 Carp::my_carp("$message in '$_' in "
2313 . " at line $.. Skipping this line;");
2314 $errors{$addr}->{$message} = 1;
2317 $errors{$addr}->{$message}++;
2320 # Clear the line to prevent any further (meaningful) processing of it.
2327 package Multi_Default;
2329 # Certain properties in early versions of Unicode had more than one possible
2330 # default for code points missing from the files. In these cases, one
2331 # default applies to everything left over after all the others are applied,
2332 # and for each of the others, there is a description of which class of code
2333 # points applies to it. This object helps implement this by storing the
2334 # defaults, and for all but that final default, an eval string that generates
2335 # the class that it applies to.
2340 main::setup_package();
2343 # The defaults structure for the classes
2344 main::set_access('class_defaults', \%class_defaults);
2347 # The default that applies to everything left over.
2348 main::set_access('other_default', \%other_default, 'r');
2352 # The constructor is called with default => eval pairs, terminated by
2353 # the left-over default. e.g.
2354 # Multi_Default->new(
2355 # 'T' => '$gc->table("Mn") + $gc->table("Cf") - 0x200C
2357 # 'R' => 'some other expression that evaluates to code points',
2365 my $self = bless \do{my $anonymous_scalar}, $class;
2366 my $addr; { no overloading; $addr = 0+$self; }
2369 my $default = shift;
2371 $class_defaults{$addr}->{$default} = $eval;
2374 $other_default{$addr} = shift;
2379 sub get_next_defaults {
2380 # Iterates and returns the next class of defaults.
2382 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2384 my $addr; { no overloading; $addr = 0+$self; }
2386 return each %{$class_defaults{$addr}};
2392 # An alias is one of the names that a table goes by. This class defines them
2393 # including some attributes. Everything is currently setup in the
2399 main::setup_package();
2402 main::set_access('name', \%name, 'r');
2405 # Determined by the constructor code if this name should match loosely or
2406 # not. The constructor parameters can override this, but it isn't fully
2407 # implemented, as should have ability to override Unicode one's via
2408 # something like a set_loose_match()
2409 main::set_access('loose_match', \%loose_match, 'r');
2412 # Some aliases should not get their own entries because they are covered
2413 # by a wild-card, and some we want to discourage use of. Binary
2414 main::set_access('make_pod_entry', \%make_pod_entry, 'r');
2417 # Aliases have a status, like deprecated, or even suppressed (which means
2418 # they don't appear in documentation). Enum
2419 main::set_access('status', \%status, 'r');
2422 # Similarly, some aliases should not be considered as usable ones for
2423 # external use, such as file names, or we don't want documentation to
2424 # recommend them. Boolean
2425 main::set_access('externally_ok', \%externally_ok, 'r');
2430 my $self = bless \do { my $anonymous_scalar }, $class;
2431 my $addr; { no overloading; $addr = 0+$self; }
2433 $name{$addr} = shift;
2434 $loose_match{$addr} = shift;
2435 $make_pod_entry{$addr} = shift;
2436 $externally_ok{$addr} = shift;
2437 $status{$addr} = shift;
2439 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2441 # Null names are never ok externally
2442 $externally_ok{$addr} = 0 if $name{$addr} eq "";
2450 # A range is the basic unit for storing code points, and is described in the
2451 # comments at the beginning of the program. Each range has a starting code
2452 # point; an ending code point (not less than the starting one); a value
2453 # that applies to every code point in between the two end-points, inclusive;
2454 # and an enum type that applies to the value. The type is for the user's
2455 # convenience, and has no meaning here, except that a non-zero type is
2456 # considered to not obey the normal Unicode rules for having standard forms.
2458 # The same structure is used for both map and match tables, even though in the
2459 # latter, the value (and hence type) is irrelevant and could be used as a
2460 # comment. In map tables, the value is what all the code points in the range
2461 # map to. Type 0 values have the standardized version of the value stored as
2462 # well, so as to not have to recalculate it a lot.
2464 sub trace { return main::trace(@_); }
2468 main::setup_package();
2471 main::set_access('start', \%start, 'r', 's');
2474 main::set_access('end', \%end, 'r', 's');
2477 main::set_access('value', \%value, 'r');
2480 main::set_access('type', \%type, 'r');
2483 # The value in internal standard form. Defined only if the type is 0.
2484 main::set_access('standard_form', \%standard_form);
2486 # Note that if these fields change, the dump() method should as well
2489 return Carp::carp_too_few_args(\@_, 3) if main::DEBUG && @_ < 3;
2492 my $self = bless \do { my $anonymous_scalar }, $class;
2493 my $addr; { no overloading; $addr = 0+$self; }
2495 $start{$addr} = shift;
2496 $end{$addr} = shift;
2500 my $value = delete $args{'Value'}; # Can be 0
2501 $value = "" unless defined $value;
2502 $value{$addr} = $value;
2504 $type{$addr} = delete $args{'Type'} || 0;
2506 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
2508 if (! $type{$addr}) {
2509 $standard_form{$addr} = main::standardize($value);
2517 qw("") => "_operator_stringify",
2518 "." => \&main::_operator_dot,
2521 sub _operator_stringify {
2523 my $addr; { no overloading; $addr = 0+$self; }
2525 # Output it like '0041..0065 (value)'
2526 my $return = sprintf("%04X", $start{$addr})
2528 . sprintf("%04X", $end{$addr});
2529 my $value = $value{$addr};
2530 my $type = $type{$addr};
2532 $return .= "$value";
2533 $return .= ", Type=$type" if $type != 0;
2540 # The standard form is the value itself if the standard form is
2541 # undefined (that is if the value is special)
2544 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2546 my $addr; { no overloading; $addr = 0+$self; }
2548 return $standard_form{$addr} if defined $standard_form{$addr};
2549 return $value{$addr};
2553 # Human, not machine readable. For machine readable, comment out this
2554 # entire routine and let the standard one take effect.
2557 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2559 my $addr; { no overloading; $addr = 0+$self; }
2561 my $return = $indent
2562 . sprintf("%04X", $start{$addr})
2564 . sprintf("%04X", $end{$addr})
2565 . " '$value{$addr}';";
2566 if (! defined $standard_form{$addr}) {
2567 $return .= "(type=$type{$addr})";
2569 elsif ($standard_form{$addr} ne $value{$addr}) {
2570 $return .= "(standard '$standard_form{$addr}')";
2576 package _Range_List_Base;
2578 # Base class for range lists. A range list is simply an ordered list of
2579 # ranges, so that the ranges with the lowest starting numbers are first in it.
2581 # When a new range is added that is adjacent to an existing range that has the
2582 # same value and type, it merges with it to form a larger range.
2584 # Ranges generally do not overlap, except that there can be multiple entries
2585 # of single code point ranges. This is because of NameAliases.txt.
2587 # In this program, there is a standard value such that if two different
2588 # values, have the same standard value, they are considered equivalent. This
2589 # value was chosen so that it gives correct results on Unicode data
2591 # There are a number of methods to manipulate range lists, and some operators
2592 # are overloaded to handle them.
2594 sub trace { return main::trace(@_); }
2600 main::setup_package();
2603 # The list of ranges
2604 main::set_access('ranges', \%ranges, 'readable_array');
2607 # The highest code point in the list. This was originally a method, but
2608 # actual measurements said it was used a lot.
2609 main::set_access('max', \%max, 'r');
2611 my %each_range_iterator;
2612 # Iterator position for each_range()
2613 main::set_access('each_range_iterator', \%each_range_iterator);
2616 # Name of parent this is attached to, if any. Solely for better error
2618 main::set_access('owner_name_of', \%owner_name_of, 'p_r');
2620 my %_search_ranges_cache;
2621 # A cache of the previous result from _search_ranges(), for better
2623 main::set_access('_search_ranges_cache', \%_search_ranges_cache);
2629 # Optional initialization data for the range list.
2630 my $initialize = delete $args{'Initialize'};
2634 # Use _union() to initialize. _union() returns an object of this
2635 # class, which means that it will call this constructor recursively.
2636 # But it won't have this $initialize parameter so that it won't
2637 # infinitely loop on this.
2638 return _union($class, $initialize, %args) if defined $initialize;
2640 $self = bless \do { my $anonymous_scalar }, $class;
2641 my $addr; { no overloading; $addr = 0+$self; }
2643 # Optional parent object, only for debug info.
2644 $owner_name_of{$addr} = delete $args{'Owner'};
2645 $owner_name_of{$addr} = "" if ! defined $owner_name_of{$addr};
2647 # Stringify, in case it is an object.
2648 $owner_name_of{$addr} = "$owner_name_of{$addr}";
2650 # This is used only for error messages, and so a colon is added
2651 $owner_name_of{$addr} .= ": " if $owner_name_of{$addr} ne "";
2653 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
2655 # Max is initialized to a negative value that isn't adjacent to 0,
2659 $_search_ranges_cache{$addr} = 0;
2660 $ranges{$addr} = [];
2667 qw("") => "_operator_stringify",
2668 "." => \&main::_operator_dot,
2671 sub _operator_stringify {
2673 my $addr; { no overloading; $addr = 0+$self; }
2675 return "Range_List attached to '$owner_name_of{$addr}'"
2676 if $owner_name_of{$addr};
2677 return "anonymous Range_List " . \$self;
2681 # Returns the union of the input code points. It can be called as
2682 # either a constructor or a method. If called as a method, the result
2683 # will be a new() instance of the calling object, containing the union
2684 # of that object with the other parameter's code points; if called as
2685 # a constructor, the first parameter gives the class the new object
2686 # should be, and the second parameter gives the code points to go into
2688 # In either case, there are two parameters looked at by this routine;
2689 # any additional parameters are passed to the new() constructor.
2691 # The code points can come in the form of some object that contains
2692 # ranges, and has a conventionally named method to access them; or
2693 # they can be an array of individual code points (as integers); or
2694 # just a single code point.
2696 # If they are ranges, this routine doesn't make any effort to preserve
2697 # the range values of one input over the other. Therefore this base
2698 # class should not allow _union to be called from other than
2699 # initialization code, so as to prevent two tables from being added
2700 # together where the range values matter. The general form of this
2701 # routine therefore belongs in a derived class, but it was moved here
2702 # to avoid duplication of code. The failure to overload this in this
2703 # class keeps it safe.
2707 my @args; # Arguments to pass to the constructor
2711 # If a method call, will start the union with the object itself, and
2712 # the class of the new object will be the same as self.
2719 # Add the other required parameter.
2721 # Rest of parameters are passed on to the constructor
2723 # Accumulate all records from both lists.
2725 for my $arg (@args) {
2726 #local $to_trace = 0 if main::DEBUG;
2727 trace "argument = $arg" if main::DEBUG && $to_trace;
2728 if (! defined $arg) {
2730 if (defined $self) {
2732 $message .= $owner_name_of{0+$self};
2734 Carp::my_carp_bug($message .= "Undefined argument to _union. No union done.");
2737 $arg = [ $arg ] if ! ref $arg;
2738 my $type = ref $arg;
2739 if ($type eq 'ARRAY') {
2740 foreach my $element (@$arg) {
2741 push @records, Range->new($element, $element);
2744 elsif ($arg->isa('Range')) {
2745 push @records, $arg;
2747 elsif ($arg->can('ranges')) {
2748 push @records, $arg->ranges;
2752 if (defined $self) {
2754 $message .= $owner_name_of{0+$self};
2756 Carp::my_carp_bug($message . "Cannot take the union of a $type. No union done.");
2761 # Sort with the range containing the lowest ordinal first, but if
2762 # two ranges start at the same code point, sort with the bigger range
2763 # of the two first, because it takes fewer cycles.
2764 @records = sort { ($a->start <=> $b->start)
2766 # if b is shorter than a, b->end will be
2767 # less than a->end, and we want to select
2768 # a, so want to return -1
2769 ($b->end <=> $a->end)
2772 my $new = $class->new(@_);
2774 # Fold in records so long as they add new information.
2775 for my $set (@records) {
2776 my $start = $set->start;
2777 my $end = $set->end;
2778 my $value = $set->value;
2779 if ($start > $new->max) {
2780 $new->_add_delete('+', $start, $end, $value);
2782 elsif ($end > $new->max) {
2783 $new->_add_delete('+', $new->max +1, $end, $value);
2790 sub range_count { # Return the number of ranges in the range list
2792 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2795 return scalar @{$ranges{0+$self}};
2799 # Returns the minimum code point currently in the range list, or if
2800 # the range list is empty, 2 beyond the max possible. This is a
2801 # method because used so rarely, that not worth saving between calls,
2802 # and having to worry about changing it as ranges are added and
2806 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2808 my $addr; { no overloading; $addr = 0+$self; }
2810 # If the range list is empty, return a large value that isn't adjacent
2811 # to any that could be in the range list, for simpler tests
2812 return $LAST_UNICODE_CODEPOINT + 2 unless scalar @{$ranges{$addr}};
2813 return $ranges{$addr}->[0]->start;
2817 # Boolean: Is argument in the range list? If so returns $i such that:
2818 # range[$i]->end < $codepoint <= range[$i+1]->end
2819 # which is one beyond what you want; this is so that the 0th range
2820 # doesn't return false
2822 my $codepoint = shift;
2823 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2825 my $i = $self->_search_ranges($codepoint);
2826 return 0 unless defined $i;
2828 # The search returns $i, such that
2829 # range[$i-1]->end < $codepoint <= range[$i]->end
2830 # So is in the table if and only iff it is at least the start position
2833 return 0 if $ranges{0+$self}->[$i]->start > $codepoint;
2838 # Returns the value associated with the code point, undef if none
2841 my $codepoint = shift;
2842 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2844 my $i = $self->contains($codepoint);
2847 # contains() returns 1 beyond where we should look
2849 return $ranges{0+$self}->[$i-1]->value;
2852 sub _search_ranges {
2853 # Find the range in the list which contains a code point, or where it
2854 # should go if were to add it. That is, it returns $i, such that:
2855 # range[$i-1]->end < $codepoint <= range[$i]->end
2856 # Returns undef if no such $i is possible (e.g. at end of table), or
2857 # if there is an error.
2860 my $code_point = shift;
2861 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2863 my $addr; { no overloading; $addr = 0+$self; }
2865 return if $code_point > $max{$addr};
2866 my $r = $ranges{$addr}; # The current list of ranges
2867 my $range_list_size = scalar @$r;
2870 use integer; # want integer division
2872 # Use the cached result as the starting guess for this one, because,
2873 # an experiment on 5.1 showed that 90% of the time the cache was the
2874 # same as the result on the next call (and 7% it was one less).
2875 $i = $_search_ranges_cache{$addr};
2876 $i = 0 if $i >= $range_list_size; # Reset if no longer valid (prob.
2877 # from an intervening deletion
2878 #local $to_trace = 1 if main::DEBUG;
2879 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);
2880 return $i if $code_point <= $r->[$i]->end
2881 && ($i == 0 || $r->[$i-1]->end < $code_point);
2883 # Here the cache doesn't yield the correct $i. Try adding 1.
2884 if ($i < $range_list_size - 1
2885 && $r->[$i]->end < $code_point &&
2886 $code_point <= $r->[$i+1]->end)
2889 trace "next \$i is correct: $i" if main::DEBUG && $to_trace;
2890 $_search_ranges_cache{$addr} = $i;
2894 # Here, adding 1 also didn't work. We do a binary search to
2895 # find the correct position, starting with current $i
2897 my $upper = $range_list_size - 1;
2899 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;
2901 if ($code_point <= $r->[$i]->end) {
2903 # Here we have met the upper constraint. We can quit if we
2904 # also meet the lower one.
2905 last if $i == 0 || $r->[$i-1]->end < $code_point;
2907 $upper = $i; # Still too high.
2912 # Here, $r[$i]->end < $code_point, so look higher up.
2916 # Split search domain in half to try again.
2917 my $temp = ($upper + $lower) / 2;
2919 # No point in continuing unless $i changes for next time
2923 # We can't reach the highest element because of the averaging.
2924 # So if one below the upper edge, force it there and try one
2926 if ($i == $range_list_size - 2) {
2928 trace "Forcing to upper edge" if main::DEBUG && $to_trace;
2929 $i = $range_list_size - 1;
2931 # Change $lower as well so if fails next time through,
2932 # taking the average will yield the same $i, and we will
2933 # quit with the error message just below.
2937 Carp::my_carp_bug("$owner_name_of{$addr}Can't find where the range ought to go. No action taken.");
2941 } # End of while loop
2943 if (main::DEBUG && $to_trace) {
2944 trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i;
2945 trace "i= [ $i ]", $r->[$i];
2946 trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < $range_list_size - 1;
2949 # Here we have found the offset. Cache it as a starting point for the
2951 $_search_ranges_cache{$addr} = $i;
2956 # Add, replace or delete ranges to or from a list. The $type
2957 # parameter gives which:
2958 # '+' => insert or replace a range, returning a list of any changed
2960 # '-' => delete a range, returning a list of any deleted ranges.
2962 # The next three parameters give respectively the start, end, and
2963 # value associated with the range. 'value' should be null unless the
2966 # The range list is kept sorted so that the range with the lowest
2967 # starting position is first in the list, and generally, adjacent
2968 # ranges with the same values are merged into single larger one (see
2969 # exceptions below).
2971 # There are more parameters, all are key => value pairs:
2972 # Type gives the type of the value. It is only valid for '+'.
2973 # All ranges have types; if this parameter is omitted, 0 is
2974 # assumed. Ranges with type 0 are assumed to obey the
2975 # Unicode rules for casing, etc; ranges with other types are
2976 # not. Otherwise, the type is arbitrary, for the caller's
2977 # convenience, and looked at only by this routine to keep
2978 # adjacent ranges of different types from being merged into
2979 # a single larger range, and when Replace =>
2980 # $IF_NOT_EQUIVALENT is specified (see just below).
2981 # Replace determines what to do if the range list already contains
2982 # ranges which coincide with all or portions of the input
2983 # range. It is only valid for '+':
2984 # => $NO means that the new value is not to replace
2985 # any existing ones, but any empty gaps of the
2986 # range list coinciding with the input range
2987 # will be filled in with the new value.
2988 # => $UNCONDITIONALLY means to replace the existing values with
2989 # this one unconditionally. However, if the
2990 # new and old values are identical, the
2991 # replacement is skipped to save cycles
2992 # => $IF_NOT_EQUIVALENT means to replace the existing values
2993 # with this one if they are not equivalent.
2994 # Ranges are equivalent if their types are the
2995 # same, and they are the same string, or if
2996 # both are type 0 ranges, if their Unicode
2997 # standard forms are identical. In this last
2998 # case, the routine chooses the more "modern"
2999 # one to use. This is because some of the
3000 # older files are formatted with values that
3001 # are, for example, ALL CAPs, whereas the
3002 # derived files have a more modern style,
3003 # which looks better. By looking for this
3004 # style when the pre-existing and replacement
3005 # standard forms are the same, we can move to
3007 # => $MULTIPLE means that if this range duplicates an
3008 # existing one, but has a different value,
3009 # don't replace the existing one, but insert
3010 # this, one so that the same range can occur
3012 # => anything else is the same as => $IF_NOT_EQUIVALENT
3014 # "same value" means identical for type-0 ranges, and it means having
3015 # the same standard forms for non-type-0 ranges.
3017 return Carp::carp_too_few_args(\@_, 5) if main::DEBUG && @_ < 5;
3020 my $operation = shift; # '+' for add/replace; '-' for delete;
3027 $value = "" if not defined $value; # warning: $value can be "0"
3029 my $replace = delete $args{'Replace'};
3030 $replace = $IF_NOT_EQUIVALENT unless defined $replace;
3032 my $type = delete $args{'Type'};
3033 $type = 0 unless defined $type;
3035 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
3037 my $addr; { no overloading; $addr = 0+$self; }
3039 if ($operation ne '+' && $operation ne '-') {
3040 Carp::my_carp_bug("$owner_name_of{$addr}First parameter to _add_delete must be '+' or '-'. No action taken.");
3043 unless (defined $start && defined $end) {
3044 Carp::my_carp_bug("$owner_name_of{$addr}Undefined start and/or end to _add_delete. No action taken.");
3047 unless ($end >= $start) {
3048 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.");
3051 #local $to_trace = 1 if main::DEBUG;
3053 if ($operation eq '-') {
3054 if ($replace != $IF_NOT_EQUIVALENT) {
3055 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.");
3056 $replace = $IF_NOT_EQUIVALENT;
3059 Carp::my_carp_bug("$owner_name_of{$addr}Type => 0 is required when deleting a range from a range list. Assuming Type => 0.");
3063 Carp::my_carp_bug("$owner_name_of{$addr}Value => \"\" is required when deleting a range from a range list. Assuming Value => \"\".");
3068 my $r = $ranges{$addr}; # The current list of ranges
3069 my $range_list_size = scalar @$r; # And its size
3070 my $max = $max{$addr}; # The current high code point in
3071 # the list of ranges
3073 # Do a special case requiring fewer machine cycles when the new range
3074 # starts after the current highest point. The Unicode input data is
3075 # structured so this is common.
3076 if ($start > $max) {
3078 trace "$owner_name_of{$addr} $operation", sprintf("%04X", $start) . '..' . sprintf("%04X", $end) . " ($value) type=$type" if main::DEBUG && $to_trace;
3079 return if $operation eq '-'; # Deleting a non-existing range is a
3082 # If the new range doesn't logically extend the current final one
3083 # in the range list, create a new range at the end of the range
3084 # list. (max cleverly is initialized to a negative number not
3085 # adjacent to 0 if the range list is empty, so even adding a range
3086 # to an empty range list starting at 0 will have this 'if'
3088 if ($start > $max + 1 # non-adjacent means can't extend.
3089 || @{$r}[-1]->value ne $value # values differ, can't extend.
3090 || @{$r}[-1]->type != $type # types differ, can't extend.
3092 push @$r, Range->new($start, $end,
3098 # Here, the new range starts just after the current highest in
3099 # the range list, and they have the same type and value.
3100 # Extend the current range to incorporate the new one.
3101 @{$r}[-1]->set_end($end);
3104 # This becomes the new maximum.
3109 #local $to_trace = 0 if main::DEBUG;
3111 trace "$owner_name_of{$addr} $operation", sprintf("%04X", $start) . '..' . sprintf("%04X", $end) . " ($value) replace=$replace" if main::DEBUG && $to_trace;
3113 # Here, the input range isn't after the whole rest of the range list.
3114 # Most likely 'splice' will be needed. The rest of the routine finds
3115 # the needed splice parameters, and if necessary, does the splice.
3116 # First, find the offset parameter needed by the splice function for
3117 # the input range. Note that the input range may span multiple
3118 # existing ones, but we'll worry about that later. For now, just find
3119 # the beginning. If the input range is to be inserted starting in a
3120 # position not currently in the range list, it must (obviously) come
3121 # just after the range below it, and just before the range above it.
3122 # Slightly less obviously, it will occupy the position currently
3123 # occupied by the range that is to come after it. More formally, we
3124 # are looking for the position, $i, in the array of ranges, such that:
3126 # r[$i-1]->start <= r[$i-1]->end < $start < r[$i]->start <= r[$i]->end
3128 # (The ordered relationships within existing ranges are also shown in
3129 # the equation above). However, if the start of the input range is
3130 # within an existing range, the splice offset should point to that
3131 # existing range's position in the list; that is $i satisfies a
3132 # somewhat different equation, namely:
3134 #r[$i-1]->start <= r[$i-1]->end < r[$i]->start <= $start <= r[$i]->end
3136 # More briefly, $start can come before or after r[$i]->start, and at
3137 # this point, we don't know which it will be. However, these
3138 # two equations share these constraints:
3140 # r[$i-1]->end < $start <= r[$i]->end
3142 # And that is good enough to find $i.
3144 my $i = $self->_search_ranges($start);
3146 Carp::my_carp_bug("Searching $self for range beginning with $start unexpectedly returned undefined. Operation '$operation' not performed");
3150 # The search function returns $i such that:
3152 # r[$i-1]->end < $start <= r[$i]->end
3154 # That means that $i points to the first range in the range list
3155 # that could possibly be affected by this operation. We still don't
3156 # know if the start of the input range is within r[$i], or if it
3157 # points to empty space between r[$i-1] and r[$i].
3158 trace "[$i] is the beginning splice point. Existing range there is ", $r->[$i] if main::DEBUG && $to_trace;
3160 # Special case the insertion of data that is not to replace any
3162 if ($replace == $NO) { # If $NO, has to be operation '+'
3163 #local $to_trace = 1 if main::DEBUG;
3164 trace "Doesn't replace" if main::DEBUG && $to_trace;
3166 # Here, the new range is to take effect only on those code points
3167 # that aren't already in an existing range. This can be done by
3168 # looking through the existing range list and finding the gaps in
3169 # the ranges that this new range affects, and then calling this
3170 # function recursively on each of those gaps, leaving untouched
3171 # anything already in the list. Gather up a list of the changed
3172 # gaps first so that changes to the internal state as new ranges
3173 # are added won't be a problem.
3176 # First, if the starting point of the input range is outside an
3177 # existing one, there is a gap from there to the beginning of the
3178 # existing range -- add a span to fill the part that this new
3180 if ($start < $r->[$i]->start) {
3181 push @gap_list, Range->new($start,
3183 $r->[$i]->start - 1),
3185 trace "gap before $r->[$i] [$i], will add", $gap_list[-1] if main::DEBUG && $to_trace;
3188 # Then look through the range list for other gaps until we reach
3189 # the highest range affected by the input one.
3191 for ($j = $i+1; $j < $range_list_size; $j++) {
3192 trace "j=[$j]", $r->[$j] if main::DEBUG && $to_trace;
3193 last if $end < $r->[$j]->start;
3195 # If there is a gap between when this range starts and the
3196 # previous one ends, add a span to fill it. Note that just
3197 # because there are two ranges doesn't mean there is a
3198 # non-zero gap between them. It could be that they have
3199 # different values or types
3200 if ($r->[$j-1]->end + 1 != $r->[$j]->start) {
3202 Range->new($r->[$j-1]->end + 1,
3203 $r->[$j]->start - 1,
3205 trace "gap between $r->[$j-1] and $r->[$j] [$j], will add: $gap_list[-1]" if main::DEBUG && $to_trace;
3209 # Here, we have either found an existing range in the range list,
3210 # beyond the area affected by the input one, or we fell off the
3211 # end of the loop because the input range affects the whole rest
3212 # of the range list. In either case, $j is 1 higher than the
3213 # highest affected range. If $j == $i, it means that there are no
3214 # affected ranges, that the entire insertion is in the gap between
3215 # r[$i-1], and r[$i], which we already have taken care of before
3217 # On the other hand, if there are affected ranges, it might be
3218 # that there is a gap that needs filling after the final such
3219 # range to the end of the input range
3220 if ($r->[$j-1]->end < $end) {
3221 push @gap_list, Range->new(main::max($start,
3222 $r->[$j-1]->end + 1),
3225 trace "gap after $r->[$j-1], will add $gap_list[-1]" if main::DEBUG && $to_trace;
3228 # Call recursively to fill in all the gaps.
3229 foreach my $gap (@gap_list) {
3230 $self->_add_delete($operation,
3240 # Here, we have taken care of the case where $replace is $NO, which
3241 # means that whatever action we now take is done unconditionally. It
3242 # still could be that this call will result in a no-op, if duplicates
3243 # aren't allowed, and we are inserting a range that merely duplicates
3244 # data already in the range list; or also if deleting a non-existent
3246 # $i still points to the first potential affected range. Now find the
3247 # highest range affected, which will determine the length parameter to
3248 # splice. (The input range can span multiple existing ones.) While
3249 # we are looking through the range list, see also if this is an
3250 # insertion that will change the values of at least one of the
3251 # affected ranges. We don't need to do this check unless this is an
3252 # insertion of non-multiples, and also since this is a boolean, we
3253 # don't need to do it if have already determined that it will make a
3254 # change; just unconditionally change them. $cdm is created to be 1
3255 # if either of these is true. (The 'c' in the name comes from below)
3256 my $cdm = ($operation eq '-' || $replace == $MULTIPLE);
3257 my $j; # This will point to the highest affected range
3259 # For non-zero types, the standard form is the value itself;
3260 my $standard_form = ($type) ? $value : main::standardize($value);
3262 for ($j = $i; $j < $range_list_size; $j++) {
3263 trace "Looking for highest affected range; the one at $j is ", $r->[$j] if main::DEBUG && $to_trace;
3265 # If find a range that it doesn't overlap into, we can stop
3267 last if $end < $r->[$j]->start;
3269 # Here, overlaps the range at $j. If the value's don't match,
3270 # and this is supposedly an insertion, it becomes a change
3271 # instead. This is what the 'c' stands for in $cdm.
3273 if ($r->[$j]->standard_form ne $standard_form) {
3278 # Here, the two values are essentially the same. If the
3279 # two are actually identical, replacing wouldn't change
3280 # anything so skip it.
3281 my $pre_existing = $r->[$j]->value;
3282 if ($pre_existing ne $value) {
3284 # Here the new and old standardized values are the
3285 # same, but the non-standardized values aren't. If
3286 # replacing unconditionally, then replace
3287 if( $replace == $UNCONDITIONALLY) {
3292 # Here, are replacing conditionally. Decide to
3293 # replace or not based on which appears to look
3294 # the "nicest". If one is mixed case and the
3295 # other isn't, choose the mixed case one.
3296 my $new_mixed = $value =~ /[A-Z]/
3297 && $value =~ /[a-z]/;
3298 my $old_mixed = $pre_existing =~ /[A-Z]/
3299 && $pre_existing =~ /[a-z]/;
3301 if ($old_mixed != $new_mixed) {
3302 $cdm = 1 if $new_mixed;
3303 if (main::DEBUG && $to_trace) {
3305 trace "Replacing $pre_existing with $value";
3308 trace "Retaining $pre_existing over $value";
3314 # Here casing wasn't different between the two.
3315 # If one has hyphens or underscores and the
3316 # other doesn't, choose the one with the
3318 my $new_punct = $value =~ /[-_]/;
3319 my $old_punct = $pre_existing =~ /[-_]/;
3321 if ($old_punct != $new_punct) {
3322 $cdm = 1 if $new_punct;
3323 if (main::DEBUG && $to_trace) {
3325 trace "Replacing $pre_existing with $value";
3328 trace "Retaining $pre_existing over $value";
3331 } # else existing one is just as "good";
3332 # retain it to save cycles.
3338 } # End of loop looking for highest affected range.
3340 # Here, $j points to one beyond the highest range that this insertion
3341 # affects (hence to beyond the range list if that range is the final
3342 # one in the range list).
3344 # The splice length is all the affected ranges. Get it before
3345 # subtracting, for efficiency, so we don't have to later add 1.
3346 my $length = $j - $i;
3348 $j--; # $j now points to the highest affected range.
3349 trace "Final affected range is $j: $r->[$j]" if main::DEBUG && $to_trace;
3351 # If inserting a multiple record, this is where it goes, after all the
3352 # existing ones for this range. This implies an insertion, and no
3353 # change to any existing ranges. Note that $j can be -1 if this new
3354 # range doesn't actually duplicate any existing, and comes at the
3355 # beginning of the list, in which case we can handle it like any other
3356 # insertion, and is easier to do so.
3357 if ($replace == $MULTIPLE && $j >= 0) {
3359 # This restriction could be remedied with a little extra work, but
3360 # it won't hopefully ever be necessary
3361 if ($r->[$j]->start != $r->[$j]->end) {
3362 Carp::my_carp_bug("$owner_name_of{$addr}Can't cope with adding a multiple when the other range ($r->[$j]) contains more than one code point. No action taken.");
3366 # Don't add an exact duplicate, as it isn't really a multiple
3367 return if $value eq $r->[$j]->value && $type eq $r->[$j]->type;
3369 trace "Adding multiple record at $j+1 with $start..$end, $value" if main::DEBUG && $to_trace;
3370 my @return = splice @$r,
3377 if (main::DEBUG && $to_trace) {
3378 trace "After splice:";
3379 trace 'j-2=[', $j-2, ']', $r->[$j-2] if $j >= 2;
3380 trace 'j-1=[', $j-1, ']', $r->[$j-1] if $j >= 1;
3381 trace "j =[", $j, "]", $r->[$j] if $j >= 0;
3382 trace 'j+1=[', $j+1, ']', $r->[$j+1] if $j < @$r - 1;
3383 trace 'j+2=[', $j+2, ']', $r->[$j+2] if $j < @$r - 2;
3384 trace 'j+3=[', $j+3, ']', $r->[$j+3] if $j < @$r - 3;
3389 # Here, have taken care of $NO and $MULTIPLE replaces.
3390 # $j points to the highest affected range. But it can be < $i or even
3391 # -1. These happen only if the insertion is entirely in the gap
3392 # between r[$i-1] and r[$i]. Here's why: j < i means that the j loop
3393 # above exited first time through with $end < $r->[$i]->start. (And
3394 # then we subtracted one from j) This implies also that $start <
3395 # $r->[$i]->start, but we know from above that $r->[$i-1]->end <
3396 # $start, so the entire input range is in the gap.
3399 # Here the entire input range is in the gap before $i.
3401 if (main::DEBUG && $to_trace) {
3403 trace "Entire range is between $r->[$i-1] and $r->[$i]";
3406 trace "Entire range is before $r->[$i]";
3409 return if $operation ne '+'; # Deletion of a non-existent range is
3414 # Here the entire input range is not in the gap before $i. There
3415 # is an affected one, and $j points to the highest such one.
3417 # At this point, here is the situation:
3418 # This is not an insertion of a multiple, nor of tentative ($NO)
3420 # $i points to the first element in the current range list that
3421 # may be affected by this operation. In fact, we know
3422 # that the range at $i is affected because we are in
3423 # the else branch of this 'if'
3424 # $j points to the highest affected range.
3426 # r[$i-1]->end < $start <= r[$i]->end
3428 # r[$i-1]->end < $start <= $end <= r[$j]->end
3431 # $cdm is a boolean which is set true if and only if this is a
3432 # change or deletion (multiple was handled above). In
3433 # other words, it could be renamed to be just $cd.
3435 # We now have enough information to decide if this call is a no-op
3436 # or not. It is a no-op if it is a deletion of a non-existent
3437 # range, or an insertion of already existing data.
3439 if (main::DEBUG && $to_trace && ! $cdm
3441 && $start >= $r->[$i]->start)
3445 return if ! $cdm # change or delete => not no-op
3446 && $i == $j # more than one affected range => not no-op
3448 # Here, r[$i-1]->end < $start <= $end <= r[$i]->end
3449 # Further, $start and/or $end is >= r[$i]->start
3450 # The test below hence guarantees that
3451 # r[$i]->start < $start <= $end <= r[$i]->end
3452 # This means the input range is contained entirely in
3453 # the one at $i, so is a no-op
3454 && $start >= $r->[$i]->start;
3457 # Here, we know that some action will have to be taken. We have
3458 # calculated the offset and length (though adjustments may be needed)
3459 # for the splice. Now start constructing the replacement list.
3461 my $splice_start = $i;
3466 # See if should extend any adjacent ranges.
3467 if ($operation eq '-') { # Don't extend deletions
3468 $extends_below = $extends_above = 0;
3470 else { # Here, should extend any adjacent ranges. See if there are
3472 $extends_below = ($i > 0
3473 # can't extend unless adjacent
3474 && $r->[$i-1]->end == $start -1
3475 # can't extend unless are same standard value
3476 && $r->[$i-1]->standard_form eq $standard_form
3477 # can't extend unless share type
3478 && $r->[$i-1]->type == $type);
3479 $extends_above = ($j+1 < $range_list_size
3480 && $r->[$j+1]->start == $end +1
3481 && $r->[$j+1]->standard_form eq $standard_form
3482 && $r->[$j-1]->type == $type);
3484 if ($extends_below && $extends_above) { # Adds to both
3485 $splice_start--; # start replace at element below
3486 $length += 2; # will replace on both sides
3487 trace "Extends both below and above ranges" if main::DEBUG && $to_trace;
3489 # The result will fill in any gap, replacing both sides, and
3490 # create one large range.
3491 @replacement = Range->new($r->[$i-1]->start,
3498 # Here we know that the result won't just be the conglomeration of
3499 # a new range with both its adjacent neighbors. But it could
3500 # extend one of them.
3502 if ($extends_below) {
3504 # Here the new element adds to the one below, but not to the
3505 # one above. If inserting, and only to that one range, can
3506 # just change its ending to include the new one.
3507 if ($length == 0 && ! $cdm) {
3508 $r->[$i-1]->set_end($end);
3509 trace "inserted range extends range to below so it is now $r->[$i-1]" if main::DEBUG && $to_trace;
3513 trace "Changing inserted range to start at ", sprintf("%04X", $r->[$i-1]->start), " instead of ", sprintf("%04X", $start) if main::DEBUG && $to_trace;
3514 $splice_start--; # start replace at element below
3515 $length++; # will replace the element below
3516 $start = $r->[$i-1]->start;
3519 elsif ($extends_above) {
3521 # Here the new element adds to the one above, but not below.
3522 # Mirror the code above
3523 if ($length == 0 && ! $cdm) {
3524 $r->[$j+1]->set_start($start);
3525 trace "inserted range extends range to above so it is now $r->[$j+1]" if main::DEBUG && $to_trace;
3529 trace "Changing inserted range to end at ", sprintf("%04X", $r->[$j+1]->end), " instead of ", sprintf("%04X", $end) if main::DEBUG && $to_trace;
3530 $length++; # will replace the element above
3531 $end = $r->[$j+1]->end;
3535 trace "Range at $i is $r->[$i]" if main::DEBUG && $to_trace;
3537 # Finally, here we know there will have to be a splice.
3538 # If the change or delete affects only the highest portion of the
3539 # first affected range, the range will have to be split. The
3540 # splice will remove the whole range, but will replace it by a new
3541 # range containing just the unaffected part. So, in this case,
3542 # add to the replacement list just this unaffected portion.
3543 if (! $extends_below
3544 && $start > $r->[$i]->start && $start <= $r->[$i]->end)
3547 Range->new($r->[$i]->start,
3549 Value => $r->[$i]->value,
3550 Type => $r->[$i]->type);
3553 # In the case of an insert or change, but not a delete, we have to
3554 # put in the new stuff; this comes next.
3555 if ($operation eq '+') {
3556 push @replacement, Range->new($start,
3562 trace "Range at $j is $r->[$j]" if main::DEBUG && $to_trace && $j != $i;
3563 #trace "$end >=", $r->[$j]->start, " && $end <", $r->[$j]->end if main::DEBUG && $to_trace;
3565 # And finally, if we're changing or deleting only a portion of the
3566 # highest affected range, it must be split, as the lowest one was.
3567 if (! $extends_above
3568 && $j >= 0 # Remember that j can be -1 if before first
3570 && $end >= $r->[$j]->start
3571 && $end < $r->[$j]->end)
3574 Range->new($end + 1,
3576 Value => $r->[$j]->value,
3577 Type => $r->[$j]->type);
3581 # And do the splice, as calculated above
3582 if (main::DEBUG && $to_trace) {
3583 trace "replacing $length element(s) at $i with ";
3584 foreach my $replacement (@replacement) {
3585 trace " $replacement";
3587 trace "Before splice:";
3588 trace 'i-2=[', $i-2, ']', $r->[$i-2] if $i >= 2;
3589 trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i >= 1;
3590 trace "i =[", $i, "]", $r->[$i];
3591 trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < @$r - 1;
3592 trace 'i+2=[', $i+2, ']', $r->[$i+2] if $i < @$r - 2;
3595 my @return = splice @$r, $splice_start, $length, @replacement;
3597 if (main::DEBUG && $to_trace) {
3598 trace "After splice:";
3599 trace 'i-2=[', $i-2, ']', $r->[$i-2] if $i >= 2;
3600 trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i >= 1;
3601 trace "i =[", $i, "]", $r->[$i];
3602 trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < @$r - 1;
3603 trace 'i+2=[', $i+2, ']', $r->[$i+2] if $i < @$r - 2;
3604 trace "removed @return";
3607 # An actual deletion could have changed the maximum in the list.
3608 # There was no deletion if the splice didn't return something, but
3609 # otherwise recalculate it. This is done too rarely to worry about
3611 if ($operation eq '-' && @return) {
3612 $max{$addr} = $r->[-1]->end;
3617 sub reset_each_range { # reset the iterator for each_range();
3619 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3622 undef $each_range_iterator{0+$self};
3627 # Iterate over each range in a range list. Results are undefined if
3628 # the range list is changed during the iteration.
3631 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3633 my $addr; { no overloading; $addr = 0+$self; }
3635 return if $self->is_empty;
3637 $each_range_iterator{$addr} = -1
3638 if ! defined $each_range_iterator{$addr};
3639 $each_range_iterator{$addr}++;
3640 return $ranges{$addr}->[$each_range_iterator{$addr}]
3641 if $each_range_iterator{$addr} < @{$ranges{$addr}};
3642 undef $each_range_iterator{$addr};
3646 sub count { # Returns count of code points in range list
3648 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3650 my $addr; { no overloading; $addr = 0+$self; }
3653 foreach my $range (@{$ranges{$addr}}) {
3654 $count += $range->end - $range->start + 1;
3659 sub delete_range { # Delete a range
3664 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3666 return $self->_add_delete('-', $start, $end, "");
3669 sub is_empty { # Returns boolean as to if a range list is empty
3671 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3674 return scalar @{$ranges{0+$self}} == 0;
3678 # Quickly returns a scalar suitable for separating tables into
3679 # buckets, i.e. it is a hash function of the contents of a table, so
3680 # there are relatively few conflicts.
3683 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3685 my $addr; { no overloading; $addr = 0+$self; }
3687 # These are quickly computable. Return looks like 'min..max;count'
3688 return $self->min . "..$max{$addr};" . scalar @{$ranges{$addr}};
3690 } # End closure for _Range_List_Base
3693 use base '_Range_List_Base';
3695 # A Range_List is a range list for match tables; i.e. the range values are
3696 # not significant. Thus a number of operations can be safely added to it,
3697 # such as inversion, intersection. Note that union is also an unsafe
3698 # operation when range values are cared about, and that method is in the base
3699 # class, not here. But things are set up so that that method is callable only
3700 # during initialization. Only in this derived class, is there an operation
3701 # that combines two tables. A Range_Map can thus be used to initialize a
3702 # Range_List, and its mappings will be in the list, but are not significant to
3705 sub trace { return main::trace(@_); }
3711 '+' => sub { my $self = shift;
3714 return $self->_union($other)
3716 '&' => sub { my $self = shift;
3719 return $self->_intersect($other, 0);
3726 # Returns a new Range_List that gives all code points not in $self.
3730 my $new = Range_List->new;
3732 # Go through each range in the table, finding the gaps between them
3733 my $max = -1; # Set so no gap before range beginning at 0
3734 for my $range ($self->ranges) {
3735 my $start = $range->start;
3736 my $end = $range->end;
3738 # If there is a gap before this range, the inverse will contain
3740 if ($start > $max + 1) {
3741 $new->add_range($max + 1, $start - 1);
3746 # And finally, add the gap from the end of the table to the max
3747 # possible code point
3748 if ($max < $LAST_UNICODE_CODEPOINT) {
3749 $new->add_range($max + 1, $LAST_UNICODE_CODEPOINT);
3755 # Returns a new Range_List with the argument deleted from it. The
3756 # argument can be a single code point, a range, or something that has
3757 # a range, with the _range_list() method on it returning them
3761 my $reversed = shift;
3762 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3765 Carp::my_carp_bug("Can't cope with a "
3767 . " being the second parameter in a '-'. Subtraction ignored.");
3771 my $new = Range_List->new(Initialize => $self);
3773 if (! ref $other) { # Single code point
3774 $new->delete_range($other, $other);
3776 elsif ($other->isa('Range')) {
3777 $new->delete_range($other->start, $other->end);
3779 elsif ($other->can('_range_list')) {
3780 foreach my $range ($other->_range_list->ranges) {
3781 $new->delete_range($range->start, $range->end);
3785 Carp::my_carp_bug("Can't cope with a "
3787 . " argument to '-'. Subtraction ignored."
3796 # Returns either a boolean giving whether the two inputs' range lists
3797 # intersect (overlap), or a new Range_List containing the intersection
3798 # of the two lists. The optional final parameter being true indicates
3799 # to do the check instead of the intersection.
3801 my $a_object = shift;
3802 my $b_object = shift;
3803 my $check_if_overlapping = shift;
3804 $check_if_overlapping = 0 unless defined $check_if_overlapping;
3805 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3807 if (! defined $b_object) {
3809 $message .= $a_object->_owner_name_of if defined $a_object;
3810 Carp::my_carp_bug($message .= "Called with undefined value. Intersection not done.");
3814 # a & b = !(!a | !b), or in our terminology = ~ ( ~a + -b )
3815 # Thus the intersection could be much more simply be written:
3816 # return ~(~$a_object + ~$b_object);
3817 # But, this is slower, and when taking the inverse of a large
3818 # range_size_1 table, back when such tables were always stored that
3819 # way, it became prohibitively slow, hence the code was changed to the
3822 if ($b_object->isa('Range')) {
3823 $b_object = Range_List->new(Initialize => $b_object,
3824 Owner => $a_object->_owner_name_of);
3826 $b_object = $b_object->_range_list if $b_object->can('_range_list');
3828 my @a_ranges = $a_object->ranges;
3829 my @b_ranges = $b_object->ranges;
3831 #local $to_trace = 1 if main::DEBUG;
3832 trace "intersecting $a_object with ", scalar @a_ranges, "ranges and $b_object with", scalar @b_ranges, " ranges" if main::DEBUG && $to_trace;
3834 # Start with the first range in each list
3836 my $range_a = $a_ranges[$a_i];
3838 my $range_b = $b_ranges[$b_i];
3840 my $new = __PACKAGE__->new(Owner => $a_object->_owner_name_of)
3841 if ! $check_if_overlapping;
3843 # If either list is empty, there is no intersection and no overlap
3844 if (! defined $range_a || ! defined $range_b) {
3845 return $check_if_overlapping ? 0 : $new;
3847 trace "range_a[$a_i]=$range_a; range_b[$b_i]=$range_b" if main::DEBUG && $to_trace;
3849 # Otherwise, must calculate the intersection/overlap. Start with the
3850 # very first code point in each list
3851 my $a = $range_a->start;
3852 my $b = $range_b->start;
3854 # Loop through all the ranges of each list; in each iteration, $a and
3855 # $b are the current code points in their respective lists
3858 # If $a and $b are the same code point, ...
3861 # it means the lists overlap. If just checking for overlap
3862 # know the answer now,
3863 return 1 if $check_if_overlapping;
3865 # The intersection includes this code point plus anything else
3866 # common to both current ranges.
3868 my $end = main::min($range_a->end, $range_b->end);
3869 if (! $check_if_overlapping) {
3870 trace "adding intersection range ", sprintf("%04X", $start) . ".." . sprintf("%04X", $end) if main::DEBUG && $to_trace;
3871 $new->add_range($start, $end);
3874 # Skip ahead to the end of the current intersect
3877 # If the current intersect ends at the end of either range (as
3878 # it must for at least one of them), the next possible one
3879 # will be the beginning code point in it's list's next range.
3880 if ($a == $range_a->end) {
3881 $range_a = $a_ranges[++$a_i];
3882 last unless defined $range_a;
3883 $a = $range_a->start;
3885 if ($b == $range_b->end) {
3886 $range_b = $b_ranges[++$b_i];
3887 last unless defined $range_b;
3888 $b = $range_b->start;
3891 trace "range_a[$a_i]=$range_a; range_b[$b_i]=$range_b" if main::DEBUG && $to_trace;
3895 # Not equal, but if the range containing $a encompasses $b,
3896 # change $a to be the middle of the range where it does equal
3897 # $b, so the next iteration will get the intersection
3898 if ($range_a->end >= $b) {
3903 # Here, the current range containing $a is entirely below
3904 # $b. Go try to find a range that could contain $b.
3905 $a_i = $a_object->_search_ranges($b);
3907 # If no range found, quit.
3908 last unless defined $a_i;
3910 # The search returns $a_i, such that
3911 # range_a[$a_i-1]->end < $b <= range_a[$a_i]->end
3912 # Set $a to the beginning of this new range, and repeat.
3913 $range_a = $a_ranges[$a_i];
3914 $a = $range_a->start;
3917 else { # Here, $b < $a.
3919 # Mirror image code to the leg just above
3920 if ($range_b->end >= $a) {
3924 $b_i = $b_object->_search_ranges($a);
3925 last unless defined $b_i;
3926 $range_b = $b_ranges[$b_i];
3927 $b = $range_b->start;
3930 } # End of looping through ranges.
3932 # Intersection fully computed, or now know that there is no overlap
3933 return $check_if_overlapping ? 0 : $new;
3937 # Returns boolean giving whether the two arguments overlap somewhere
3941 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3943 return $self->_intersect($other, 1);
3947 # Add a range to the list.
3952 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3954 return $self->_add_delete('+', $start, $end, "");
3957 sub is_code_point_usable {
3958 # This used only for making the test script. See if the input
3959 # proposed trial code point is one that Perl will handle. If second
3960 # parameter is 0, it won't select some code points for various
3961 # reasons, noted below.
3964 my $try_hard = shift;
3965 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3967 return 0 if $code < 0; # Never use a negative
3969 # shun null. I'm (khw) not sure why this was done, but NULL would be
3970 # the character very frequently used.
3971 return $try_hard if $code == 0x0000;
3973 return 0 if $try_hard; # XXX Temporary until fix utf8.c
3975 # shun non-character code points.
3976 return $try_hard if $code >= 0xFDD0 && $code <= 0xFDEF;
3977 return $try_hard if ($code & 0xFFFE) == 0xFFFE; # includes FFFF
3979 return $try_hard if $code > $LAST_UNICODE_CODEPOINT; # keep in range
3980 return $try_hard if $code >= 0xD800 && $code <= 0xDFFF; # no surrogate
3985 sub get_valid_code_point {
3986 # Return a code point that's part of the range list. Returns nothing
3987 # if the table is empty or we can't find a suitable code point. This
3988 # used only for making the test script.
3991 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3993 my $addr; { no overloading; $addr = 0+$self; }
3995 # On first pass, don't choose less desirable code points; if no good
3996 # one is found, repeat, allowing a less desirable one to be selected.
3997 for my $try_hard (0, 1) {
3999 # Look through all the ranges for a usable code point.
4000 for my $set ($self->ranges) {
4002 # Try the edge cases first, starting with the end point of the
4004 my $end = $set->end;
4005 return $end if is_code_point_usable($end, $try_hard);
4007 # End point didn't, work. Start at the beginning and try
4008 # every one until find one that does work.
4009 for my $trial ($set->start .. $end - 1) {
4010 return $trial if is_code_point_usable($trial, $try_hard);
4014 return (); # If none found, give up.
4017 sub get_invalid_code_point {
4018 # Return a code point that's not part of the table. Returns nothing
4019 # if the table covers all code points or a suitable code point can't
4020 # be found. This used only for making the test script.
4023 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4025 # Just find a valid code point of the inverse, if any.
4026 return Range_List->new(Initialize => ~ $self)->get_valid_code_point;
4028 } # end closure for Range_List
4031 use base '_Range_List_Base';
4033 # A Range_Map is a range list in which the range values (called maps) are
4034 # significant, and hence shouldn't be manipulated by our other code, which
4035 # could be ambiguous or lose things. For example, in taking the union of two
4036 # lists, which share code points, but which have differing values, which one
4037 # has precedence in the union?
4038 # It turns out that these operations aren't really necessary for map tables,
4039 # and so this class was created to make sure they aren't accidentally
4045 # Add a range containing a mapping value to the list
4048 # Rest of parameters passed on
4050 return $self->_add_delete('+', @_);
4054 # Adds entry to a range list which can duplicate an existing entry
4057 my $code_point = shift;
4059 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4061 return $self->add_map($code_point, $code_point,
4062 $value, Replace => $MULTIPLE);
4064 } # End of closure for package Range_Map
4066 package _Base_Table;
4068 # A table is the basic data structure that gets written out into a file for
4069 # use by the Perl core. This is the abstract base class implementing the
4070 # common elements from the derived ones. A list of the methods to be
4071 # furnished by an implementing class is just after the constructor.
4073 sub standardize { return main::standardize($_[0]); }
4074 sub trace { return main::trace(@_); }
4078 main::setup_package();
4081 # Object containing the ranges of the table.
4082 main::set_access('range_list', \%range_list, 'p_r', 'p_s');
4085 # The full table name.
4086 main::set_access('full_name', \%full_name, 'r');
4089 # The table name, almost always shorter
4090 main::set_access('name', \%name, 'r');
4093 # The shortest of all the aliases for this table, with underscores removed
4094 main::set_access('short_name', \%short_name);
4096 my %nominal_short_name_length;
4097 # The length of short_name before removing underscores
4098 main::set_access('nominal_short_name_length',
4099 \%nominal_short_name_length);
4102 # The complete name, including property.
4103 main::set_access('complete_name', \%complete_name, 'r');
4106 # Parent property this table is attached to.
4107 main::set_access('property', \%property, 'r');
4110 # Ordered list of aliases of the table's name. The first ones in the list
4111 # are output first in comments
4112 main::set_access('aliases', \%aliases, 'readable_array');
4115 # A comment associated with the table for human readers of the files
4116 main::set_access('comment', \%comment, 's');
4119 # A comment giving a short description of the table's meaning for human
4120 # readers of the files.
4121 main::set_access('description', \%description, 'readable_array');
4124 # A comment giving a short note about the table for human readers of the
4126 main::set_access('note', \%note, 'readable_array');
4129 # Boolean; if set means any file that contains this table is marked as for
4130 # internal-only use.
4131 main::set_access('internal_only', \%internal_only);
4133 my %find_table_from_alias;
4134 # The parent property passes this pointer to a hash which this class adds
4135 # all its aliases to, so that the parent can quickly take an alias and
4137 main::set_access('find_table_from_alias', \%find_table_from_alias, 'p_r');
4140 # After this table is made equivalent to another one; we shouldn't go
4141 # changing the contents because that could mean it's no longer equivalent
4142 main::set_access('locked', \%locked, 'r');
4145 # This gives the final path to the file containing the table. Each
4146 # directory in the path is an element in the array
4147 main::set_access('file_path', \%file_path, 'readable_array');
4150 # What is the table's status, normal, $OBSOLETE, etc. Enum
4151 main::set_access('status', \%status, 'r');
4154 # A comment about its being obsolete, or whatever non normal status it has
4155 main::set_access('status_info', \%status_info, 'r');
4158 # Is the table to be output with each range only a single code point?
4159 # This is done to avoid breaking existing code that may have come to rely
4160 # on this behavior in previous versions of this program.)
4161 main::set_access('range_size_1', \%range_size_1, 'r', 's');
4164 # A boolean set iff this table is a Perl extension to the Unicode
4166 main::set_access('perl_extension', \%perl_extension, 'r');
4168 my %output_range_counts;
4169 # A boolean set iff this table is to have comments written in the
4170 # output file that contain the number of code points in the range.
4171 # The constructor can override the global flag of the same name.
4172 main::set_access('output_range_counts', \%output_range_counts, 'r');
4175 # All arguments are key => value pairs, which you can see below, most
4176 # of which match fields documented above. Otherwise: Pod_Entry,
4177 # Externally_Ok, and Fuzzy apply to the names of the table, and are
4178 # documented in the Alias package
4180 return Carp::carp_too_few_args(\@_, 2) if main::DEBUG && @_ < 2;
4184 my $self = bless \do { my $anonymous_scalar }, $class;
4185 my $addr; { no overloading; $addr = 0+$self; }
4189 $name{$addr} = delete $args{'Name'};
4190 $find_table_from_alias{$addr} = delete $args{'_Alias_Hash'};
4191 $full_name{$addr} = delete $args{'Full_Name'};
4192 my $complete_name = $complete_name{$addr}
4193 = delete $args{'Complete_Name'};
4194 $internal_only{$addr} = delete $args{'Internal_Only_Warning'} || 0;
4195 $output_range_counts{$addr} = delete $args{'Output_Range_Counts'};
4196 $property{$addr} = delete $args{'_Property'};
4197 $range_list{$addr} = delete $args{'_Range_List'};
4198 $status{$addr} = delete $args{'Status'} || $NORMAL;
4199 $status_info{$addr} = delete $args{'_Status_Info'} || "";
4200 $range_size_1{$addr} = delete $args{'Range_Size_1'} || 0;
4201 $range_size_1{$addr} = 1 if $output_names; # Make sure 1 name per line
4203 my $description = delete $args{'Description'};
4204 my $externally_ok = delete $args{'Externally_Ok'};
4205 my $loose_match = delete $args{'Fuzzy'};
4206 my $note = delete $args{'Note'};
4207 my $make_pod_entry = delete $args{'Pod_Entry'};
4208 my $perl_extension = delete $args{'Perl_Extension'};
4210 # Shouldn't have any left over
4211 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
4213 # Can't use || above because conceivably the name could be 0, and
4214 # can't use // operator in case this program gets used in Perl 5.8
4215 $full_name{$addr} = $name{$addr} if ! defined $full_name{$addr};
4216 $output_range_counts{$addr} = $output_range_counts if
4217 ! defined $output_range_counts{$addr};
4219 $aliases{$addr} = [ ];
4220 $comment{$addr} = [ ];
4221 $description{$addr} = [ ];
4223 $file_path{$addr} = [ ];
4224 $locked{$addr} = "";
4226 push @{$description{$addr}}, $description if $description;
4227 push @{$note{$addr}}, $note if $note;
4229 if ($status{$addr} eq $PLACEHOLDER) {
4231 # A placeholder table doesn't get documented, is a perl extension,
4232 # and quite likely will be empty
4233 $make_pod_entry = 0 if ! defined $make_pod_entry;
4234 $perl_extension = 1 if ! defined $perl_extension;
4235 push @tables_that_may_be_empty, $complete_name{$addr};
4237 elsif (! $status{$addr}) {
4239 # If hasn't set its status already, see if it is on one of the
4240 # lists of properties or tables that have particular statuses; if
4241 # not, is normal. The lists are prioritized so the most serious
4242 # ones are checked first
4243 if (exists $why_suppressed{$complete_name}
4244 # Don't suppress if overriden
4245 && ! grep { $_ eq $complete_name{$addr} }
4246 @output_mapped_properties)
4248 $status{$addr} = $SUPPRESSED;
4250 elsif (exists $why_deprecated{$complete_name}) {
4251 $status{$addr} = $DEPRECATED;
4253 elsif (exists $why_stabilized{$complete_name}) {
4254 $status{$addr} = $STABILIZED;
4256 elsif (exists $why_obsolete{$complete_name}) {
4257 $status{$addr} = $OBSOLETE;
4260 # Existence above doesn't necessarily mean there is a message
4261 # associated with it. Use the most serious message.
4262 if ($status{$addr}) {
4263 if ($why_suppressed{$complete_name}) {
4265 = $why_suppressed{$complete_name};
4267 elsif ($why_deprecated{$complete_name}) {
4269 = $why_deprecated{$complete_name};
4271 elsif ($why_stabilized{$complete_name}) {
4273 = $why_stabilized{$complete_name};
4275 elsif ($why_obsolete{$complete_name}) {
4277 = $why_obsolete{$complete_name};
4282 $perl_extension{$addr} = $perl_extension || 0;
4284 # By convention what typically gets printed only or first is what's
4285 # first in the list, so put the full name there for good output
4286 # clarity. Other routines rely on the full name being first on the
4288 $self->add_alias($full_name{$addr},
4289 Externally_Ok => $externally_ok,
4290 Fuzzy => $loose_match,
4291 Pod_Entry => $make_pod_entry,
4292 Status => $status{$addr},
4295 # Then comes the other name, if meaningfully different.
4296 if (standardize($full_name{$addr}) ne standardize($name{$addr})) {
4297 $self->add_alias($name{$addr},
4298 Externally_Ok => $externally_ok,
4299 Fuzzy => $loose_match,
4300 Pod_Entry => $make_pod_entry,
4301 Status => $status{$addr},
4308 # Here are the methods that are required to be defined by any derived
4314 # append_to_body and pre_body are called in the write() method
4315 # to add stuff after the main body of the table, but before
4316 # its close; and to prepend stuff before the beginning of the
4321 Carp::my_carp_bug( __LINE__
4322 . ": Must create method '$sub()' for "
4330 "." => \&main::_operator_dot,
4331 '!=' => \&main::_operator_not_equal,
4332 '==' => \&main::_operator_equal,
4336 # Returns the array of ranges associated with this table.
4339 return $range_list{0+shift}->ranges;
4343 # Add a synonym for this table.
4345 return Carp::carp_too_few_args(\@_, 3) if main::DEBUG && @_ < 3;
4348 my $name = shift; # The name to add.
4349 my $pointer = shift; # What the alias hash should point to. For
4350 # map tables, this is the parent property;
4351 # for match tables, it is the table itself.
4354 my $loose_match = delete $args{'Fuzzy'};
4356 my $make_pod_entry = delete $args{'Pod_Entry'};
4357 $make_pod_entry = $YES unless defined $make_pod_entry;
4359 my $externally_ok = delete $args{'Externally_Ok'};
4360 $externally_ok = 1 unless defined $externally_ok;
4362 my $status = delete $args{'Status'};
4363 $status = $NORMAL unless defined $status;
4365 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
4367 # Capitalize the first letter of the alias unless it is one of the CJK
4368 # ones which specifically begins with a lower 'k'. Do this because
4369 # Unicode has varied whether they capitalize first letters or not, and
4370 # have later changed their minds and capitalized them, but not the
4371 # other way around. So do it always and avoid changes from release to
4373 $name = ucfirst($name) unless $name =~ /^k[A-Z]/;
4375 my $addr; { no overloading; $addr = 0+$self; }
4377 # Figure out if should be loosely matched if not already specified.
4378 if (! defined $loose_match) {
4380 # Is a loose_match if isn't null, and doesn't begin with an
4381 # underscore and isn't just a number
4383 && substr($name, 0, 1) ne '_'
4384 && $name !~ qr{^[0-9_.+-/]+$})
4393 # If this alias has already been defined, do nothing.
4394 return if defined $find_table_from_alias{$addr}->{$name};
4396 # That includes if it is standardly equivalent to an existing alias,
4397 # in which case, add this name to the list, so won't have to search
4399 my $standard_name = main::standardize($name);
4400 if (defined $find_table_from_alias{$addr}->{$standard_name}) {
4401 $find_table_from_alias{$addr}->{$name}
4402 = $find_table_from_alias{$addr}->{$standard_name};
4406 # Set the index hash for this alias for future quick reference.
4407 $find_table_from_alias{$addr}->{$name} = $pointer;
4408 $find_table_from_alias{$addr}->{$standard_name} = $pointer;
4409 local $to_trace = 0 if main::DEBUG;
4410 trace "adding alias $name to $pointer" if main::DEBUG && $to_trace;
4411 trace "adding alias $standard_name to $pointer" if main::DEBUG && $to_trace;
4414 # Put the new alias at the end of the list of aliases unless the final
4415 # element begins with an underscore (meaning it is for internal perl
4416 # use) or is all numeric, in which case, put the new one before that
4417 # one. This floats any all-numeric or underscore-beginning aliases to
4418 # the end. This is done so that they are listed last in output lists,
4419 # to encourage the user to use a better name (either more descriptive
4420 # or not an internal-only one) instead. This ordering is relied on
4421 # implicitly elsewhere in this program, like in short_name()
4422 my $list = $aliases{$addr};
4423 my $insert_position = (@$list == 0
4424 || (substr($list->[-1]->name, 0, 1) ne '_'
4425 && $list->[-1]->name =~ /\D/))
4431 Alias->new($name, $loose_match, $make_pod_entry,
4432 $externally_ok, $status);
4434 # This name may be shorter than any existing ones, so clear the cache
4435 # of the shortest, so will have to be recalculated.
4437 undef $short_name{0+$self};
4442 # Returns a name suitable for use as the base part of a file name.
4443 # That is, shorter wins. It can return undef if there is no suitable
4444 # name. The name has all non-essential underscores removed.
4446 # The optional second parameter is a reference to a scalar in which
4447 # this routine will store the length the returned name had before the
4448 # underscores were removed, or undef if the return is undef.
4450 # The shortest name can change if new aliases are added. So using
4451 # this should be deferred until after all these are added. The code
4452 # that does that should clear this one's cache.
4453 # Any name with alphabetics is preferred over an all numeric one, even
4457 my $nominal_length_ptr = shift;
4458 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4460 my $addr; { no overloading; $addr = 0+$self; }
4462 # For efficiency, don't recalculate, but this means that adding new
4463 # aliases could change what the shortest is, so the code that does
4464 # that needs to undef this.
4465 if (defined $short_name{$addr}) {
4466 if ($nominal_length_ptr) {
4467 $$nominal_length_ptr = $nominal_short_name_length{$addr};
4469 return $short_name{$addr};
4472 # Look at each alias
4473 foreach my $alias ($self->aliases()) {
4475 # Don't use an alias that isn't ok to use for an external name.
4476 next if ! $alias->externally_ok;
4478 my $name = main::Standardize($alias->name);
4479 trace $self, $name if main::DEBUG && $to_trace;
4481 # Take the first one, or a shorter one that isn't numeric. This
4482 # relies on numeric aliases always being last in the array
4483 # returned by aliases(). Any alpha one will have precedence.
4484 if (! defined $short_name{$addr}
4486 && length($name) < length($short_name{$addr})))
4488 # Remove interior underscores.
4489 ($short_name{$addr} = $name) =~ s/ (?<= . ) _ (?= . ) //xg;
4491 $nominal_short_name_length{$addr} = length $name;
4495 # If no suitable external name return undef
4496 if (! defined $short_name{$addr}) {
4497 $$nominal_length_ptr = undef if $nominal_length_ptr;
4501 # Don't allow a null external name.
4502 if ($short_name{$addr} eq "") {
4503 $short_name{$addr} = '_';
4504 $nominal_short_name_length{$addr} = 1;
4507 trace $self, $short_name{$addr} if main::DEBUG && $to_trace;
4509 if ($nominal_length_ptr) {
4510 $$nominal_length_ptr = $nominal_short_name_length{$addr};
4512 return $short_name{$addr};
4516 # Returns the external name that this table should be known by. This
4517 # is usually the short_name, but not if the short_name is undefined.
4520 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4522 my $short = $self->short_name;
4523 return $short if defined $short;
4528 sub add_description { # Adds the parameter as a short description.
4531 my $description = shift;
4533 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4536 push @{$description{0+$self}}, $description;
4541 sub add_note { # Adds the parameter as a short note.
4546 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4549 push @{$note{0+$self}}, $note;
4554 sub add_comment { # Adds the parameter as a comment.
4557 my $comment = shift;
4558 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4563 push @{$comment{0+$self}}, $comment;
4569 # Return the current comment for this table. If called in list
4570 # context, returns the array of comments. In scalar, returns a string
4571 # of each element joined together with a period ending each.
4574 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4576 my $addr; { no overloading; $addr = 0+$self; }
4577 my @list = @{$comment{$addr}};
4578 return @list if wantarray;
4580 foreach my $sentence (@list) {
4581 $return .= '. ' if $return;
4582 $return .= $sentence;
4585 $return .= '.' if $return;
4590 # Initialize the table with the argument which is any valid
4591 # initialization for range lists.
4594 my $addr; { no overloading; $addr = 0+$self; }
4595 my $initialization = shift;
4596 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4598 # Replace the current range list with a new one of the same exact
4600 my $class = ref $range_list{$addr};
4601 $range_list{$addr} = $class->new(Owner => $self,
4602 Initialize => $initialization);
4608 # The header that is output for the table in the file it is written
4612 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4615 $return .= $DEVELOPMENT_ONLY if $compare_versions;
4618 $return .= $INTERNAL_ONLY if $internal_only{0+$self};
4623 # Write a representation of the table to its file.
4626 my $tab_stops = shift; # The number of tab stops over to put any
4628 my $suppress_value = shift; # Optional, if the value associated with
4629 # a range equals this one, don't write
4631 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4633 my $addr; { no overloading; $addr = 0+$self; }
4635 # Start with the header
4636 my @OUT = $self->header;
4639 push @OUT, "\n", main::simple_fold($comment{$addr}, '# '), "\n"
4642 # Then any pre-body stuff.
4643 my $pre_body = $self->pre_body;
4644 push @OUT, $pre_body, "\n" if $pre_body;
4646 # The main body looks like a 'here' document
4647 push @OUT, "return <<'END';\n";
4649 if ($range_list{$addr}->is_empty) {
4651 # This is a kludge for empty tables to silence a warning in
4652 # utf8.c, which can't really deal with empty tables, but it can
4653 # deal with a table that matches nothing, as the inverse of 'Any'
4655 push @OUT, "!utf8::IsAny\n";
4658 my $range_size_1 = $range_size_1{$addr};
4660 # Output each range as part of the here document.
4661 for my $set ($range_list{$addr}->ranges) {
4662 my $start = $set->start;
4663 my $end = $set->end;
4664 my $value = $set->value;
4666 # Don't output ranges whose value is the one to suppress
4667 next if defined $suppress_value && $value eq $suppress_value;
4669 # If has or wants a single point range output
4670 if ($start == $end || $range_size_1) {
4671 for my $i ($start .. $end) {
4672 push @OUT, sprintf "%04X\t\t%s\n", $i, $value;
4673 if ($output_names) {
4674 if (! defined $viacode[$i]) {
4676 Property::property_ref('Perl_Charnames')
4680 $OUT[-1] =~ s/\n/\t# $viacode[$i]\n/;
4685 push @OUT, sprintf "%04X\t%04X\t%s", $start, $end, $value;
4687 # Add a comment with the size of the range, if requested.
4688 # Expand Tabs to make sure they all start in the same
4689 # column, and then unexpand to use mostly tabs.
4690 if (! $output_range_counts{$addr}) {
4694 $OUT[-1] = Text::Tabs::expand($OUT[-1]);
4695 my $count = main::clarify_number($end - $start + 1);
4698 my $width = $tab_stops * 8 - 1;
4699 $OUT[-1] = sprintf("%-*s # [%s]\n",
4703 $OUT[-1] = Text::Tabs::unexpand($OUT[-1]);
4706 } # End of loop through all the table's ranges
4709 # Add anything that goes after the main body, but within the here
4711 my $append_to_body = $self->append_to_body;
4712 push @OUT, $append_to_body if $append_to_body;
4714 # And finish the here document.
4717 # All these files have a .pl suffix
4718 $file_path{$addr}->[-1] .= '.pl';
4720 main::write($file_path{$addr}, \@OUT);
4724 sub set_status { # Set the table's status
4726 my $status = shift; # The status enum value
4727 my $info = shift; # Any message associated with it.
4728 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4730 my $addr; { no overloading; $addr = 0+$self; }
4732 $status{$addr} = $status;
4733 $status_info{$addr} = $info;
4738 # Don't allow changes to the table from now on. This stores a stack
4739 # trace of where it was called, so that later attempts to modify it
4740 # can immediately show where it got locked.
4743 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4745 my $addr; { no overloading; $addr = 0+$self; }
4747 $locked{$addr} = "";
4749 my $line = (caller(0))[2];
4752 # Accumulate the stack trace
4754 my ($pkg, $file, $caller_line, $caller) = caller $i++;
4756 last unless defined $caller;
4758 $locked{$addr} .= " called from $caller() at line $line\n";
4759 $line = $caller_line;
4761 $locked{$addr} .= " called from main at line $line\n";
4766 sub carp_if_locked {
4767 # Return whether a table is locked or not, and, by the way, complain
4771 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4773 my $addr; { no overloading; $addr = 0+$self; }
4775 return 0 if ! $locked{$addr};
4776 Carp::my_carp_bug("Can't modify a locked table. Stack trace of locking:\n$locked{$addr}\n\n");
4780 sub set_file_path { # Set the final directory path for this table
4782 # Rest of parameters passed on
4785 @{$file_path{0+$self}} = @_;
4789 # Accessors for the range list stored in this table. First for
4809 return $range_list{0+$self}->$sub(@_);
4813 # Then for ones that should fail if locked
4823 return if $self->carp_if_locked;
4825 return $range_list{0+$self}->$sub(@_);
4832 use base '_Base_Table';
4834 # A Map Table is a table that contains the mappings from code points to
4835 # values. There are two weird cases:
4836 # 1) Anomalous entries are ones that aren't maps of ranges of code points, but
4837 # are written in the table's file at the end of the table nonetheless. It
4838 # requires specially constructed code to handle these; utf8.c can not read
4839 # these in, so they should not go in $map_directory. As of this writing,
4840 # the only case that these happen is for named sequences used in
4841 # charnames.pm. But this code doesn't enforce any syntax on these, so
4842 # something else could come along that uses it.
4843 # 2) Specials are anything that doesn't fit syntactically into the body of the
4844 # table. The ranges for these have a map type of non-zero. The code below
4845 # knows about and handles each possible type. In most cases, these are
4846 # written as part of the header.
4848 # A map table deliberately can't be manipulated at will unlike match tables.
4849 # This is because of the ambiguities having to do with what to do with
4850 # overlapping code points. And there just isn't a need for those things;
4851 # what one wants to do is just query, add, replace, or delete mappings, plus
4852 # write the final result.
4853 # However, there is a method to get the list of possible ranges that aren't in
4854 # this table to use for defaulting missing code point mappings. And,
4855 # map_add_or_replace_non_nulls() does allow one to add another table to this
4856 # one, but it is clearly very specialized, and defined that the other's
4857 # non-null values replace this one's if there is any overlap.
4859 sub trace { return main::trace(@_); }
4863 main::setup_package();
4866 # Many input files omit some entries; this gives what the mapping for the
4867 # missing entries should be
4868 main::set_access('default_map', \%default_map, 'r');
4870 my %anomalous_entries;
4871 # Things that go in the body of the table which don't fit the normal
4872 # scheme of things, like having a range. Not much can be done with these
4873 # once there except to output them. This was created to handle named
4875 main::set_access('anomalous_entry', \%anomalous_entries, 'a');
4876 main::set_access('anomalous_entries', # Append singular, read plural
4877 \%anomalous_entries,
4881 # The format of the entries of the table. This is calculated from the
4882 # data in the table (or passed in the constructor). This is an enum e.g.,
4884 main::set_access('format', \%format);
4887 # This is a string, solely for documentation, indicating how one can get
4888 # access to this property via the Perl core.
4889 main::set_access('core_access', \%core_access, 'r', 's');
4892 # Boolean set when non-zero map-type ranges are added to this table,
4893 # which happens in only a few tables. This is purely for performance, to
4894 # avoid having to search through every table upon output, so if all the
4895 # non-zero maps got deleted before output, this would remain set, and the
4896 # only penalty would be performance. Currently, most map tables that get
4897 # output have specials in them, so this doesn't help that much anyway.
4898 main::set_access('has_specials', \%has_specials);
4901 # Boolean as to whether or not to write out this map table
4902 main::set_access('to_output_map', \%to_output_map, 's');
4911 # Optional initialization data for the table.
4912 my $initialize = delete $args{'Initialize'};
4914 my $core_access = delete $args{'Core_Access'};
4915 my $default_map = delete $args{'Default_Map'};
4916 my $format = delete $args{'Format'};
4917 my $property = delete $args{'_Property'};
4918 my $full_name = delete $args{'Full_Name'};
4919 # Rest of parameters passed on
4921 my $range_list = Range_Map->new(Owner => $property);
4923 my $self = $class->SUPER::new(
4925 Complete_Name => $full_name,
4926 Full_Name => $full_name,
4927 _Property => $property,
4928 _Range_List => $range_list,
4931 my $addr; { no overloading; $addr = 0+$self; }
4933 $anomalous_entries{$addr} = [];
4934 $core_access{$addr} = $core_access;
4935 $default_map{$addr} = $default_map;
4936 $format{$addr} = $format;
4938 $self->initialize($initialize) if defined $initialize;
4945 qw("") => "_operator_stringify",
4948 sub _operator_stringify {
4951 my $name = $self->property->full_name;
4952 $name = '""' if $name eq "";
4953 return "Map table for Property '$name'";
4957 # Add a synonym for this table (which means the property itself)
4960 # Rest of parameters passed on.
4962 $self->SUPER::add_alias($name, $self->property, @_);
4967 # Add a range of code points to the list of specially-handled code
4968 # points. $MULTI_CP is assumed if the type of special is not passed
4977 my $type = delete $args{'Type'} || 0;
4978 # Rest of parameters passed on
4980 # Can't change the table if locked.
4981 return if $self->carp_if_locked;
4983 my $addr; { no overloading; $addr = 0+$self; }
4985 $has_specials{$addr} = 1 if $type;
4987 $self->_range_list->add_map($lower, $upper,
4994 sub append_to_body {
4995 # Adds to the written HERE document of the table's body any anomalous
4996 # entries in the table..
4999 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5001 my $addr; { no overloading; $addr = 0+$self; }
5003 return "" unless @{$anomalous_entries{$addr}};
5004 return join("\n", @{$anomalous_entries{$addr}}) . "\n";
5007 sub map_add_or_replace_non_nulls {
5008 # This adds the mappings in the table $other to $self. Non-null
5009 # mappings from $other override those in $self. It essentially merges
5010 # the two tables, with the second having priority except for null
5015 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5017 return if $self->carp_if_locked;
5019 if (! $other->isa(__PACKAGE__)) {
5020 Carp::my_carp_bug("$other should be a "
5028 my $addr; { no overloading; $addr = 0+$self; }
5029 my $other_addr; { no overloading; $other_addr = 0+$other; }
5031 local $to_trace = 0 if main::DEBUG;
5033 my $self_range_list = $self->_range_list;
5034 my $other_range_list = $other->_range_list;
5035 foreach my $range ($other_range_list->ranges) {
5036 my $value = $range->value;
5037 next if $value eq "";
5038 $self_range_list->_add_delete('+',
5042 Type => $range->type,
5043 Replace => $UNCONDITIONALLY);
5046 # Copy the specials information from the other table to $self
5047 if ($has_specials{$other_addr}) {
5048 $has_specials{$addr} = 1;
5054 sub set_default_map {
5055 # Define what code points that are missing from the input files should
5060 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5062 my $addr; { no overloading; $addr = 0+$self; }
5064 # Convert the input to the standard equivalent, if any (won't have any
5065 # for $STRING properties)
5066 my $standard = $self->_find_table_from_alias->{$map};
5067 $map = $standard->name if defined $standard;
5069 # Warn if there already is a non-equivalent default map for this
5070 # property. Note that a default map can be a ref, which means that
5071 # what it actually means is delayed until later in the program, and it
5072 # IS permissible to override it here without a message.
5073 my $default_map = $default_map{$addr};
5074 if (defined $default_map
5075 && ! ref($default_map)
5076 && $default_map ne $map
5077 && main::Standardize($map) ne $default_map)
5079 my $property = $self->property;
5080 my $map_table = $property->table($map);
5081 my $default_table = $property->table($default_map);
5082 if (defined $map_table
5083 && defined $default_table
5084 && $map_table != $default_table)
5086 Carp::my_carp("Changing the default mapping for "
5088 . " from $default_map to $map'");
5092 $default_map{$addr} = $map;
5094 # Don't also create any missing table for this map at this point,
5095 # because if we did, it could get done before the main table add is
5096 # done for PropValueAliases.txt; instead the caller will have to make
5097 # sure it exists, if desired.
5102 # Returns boolean: should we write this map table?
5105 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5107 my $addr; { no overloading; $addr = 0+$self; }
5109 # If overridden, use that
5110 return $to_output_map{$addr} if defined $to_output_map{$addr};
5112 my $full_name = $self->full_name;
5114 # If table says to output, do so; if says to suppress it, do do.
5115 return 1 if grep { $_ eq $full_name } @output_mapped_properties;
5116 return 0 if $self->status eq $SUPPRESSED;
5118 my $type = $self->property->type;
5120 # Don't want to output binary map tables even for debugging.
5121 return 0 if $type == $BINARY;
5123 # But do want to output string ones.
5124 return 1 if $type == $STRING;
5126 # Otherwise is an $ENUM, don't output it
5131 # Returns a Range_List that is gaps of the current table. That is,
5135 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5137 my $current = Range_List->new(Initialize => $self->_range_list,
5138 Owner => $self->property);
5142 sub set_final_comment {
5143 # Just before output, create the comment that heads the file
5144 # containing this table.
5147 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5149 # No sense generating a comment if aren't going to write it out.
5150 return if ! $self->to_output_map;
5152 my $addr; { no overloading; $addr = 0+$self; }
5154 my $property = $self->property;
5156 # Get all the possible names for this property. Don't use any that
5157 # aren't ok for use in a file name, etc. This is perhaps causing that
5158 # flag to do double duty, and may have to be changed in the future to
5159 # have our own flag for just this purpose; but it works now to exclude
5160 # Perl generated synonyms from the lists for properties, where the
5161 # name is always the proper Unicode one.
5162 my @property_aliases = grep { $_->externally_ok } $self->aliases;
5164 my $count = $self->count;
5165 my $default_map = $default_map{$addr};
5167 # The ranges that map to the default aren't output, so subtract that
5168 # to get those actually output. A property with matching tables
5169 # already has the information calculated.
5170 if ($property->type != $STRING) {
5171 $count -= $property->table($default_map)->count;
5173 elsif (defined $default_map) {
5175 # But for $STRING properties, must calculate now. Subtract the
5176 # count from each range that maps to the default.
5177 foreach my $range ($self->_range_list->ranges) {
5178 if ($range->value eq $default_map) {
5179 $count -= $range->end +1 - $range->start;
5185 # Get a string version of $count with underscores in large numbers,
5187 my $string_count = main::clarify_number($count);
5189 my $code_points = ($count == 1)
5190 ? 'single code point'
5191 : "$string_count code points";
5196 if (@property_aliases <= 1) {
5197 $mapping = 'mapping';
5198 $these_mappings = 'this mapping';
5202 $mapping = 'synonymous mappings';
5203 $these_mappings = 'these mappings';
5207 if ($count >= $MAX_UNICODE_CODEPOINTS) {
5208 $cp = "any code point in Unicode Version $string_version";
5212 if ($default_map eq "") {
5213 $map_to = 'the null string';
5215 elsif ($default_map eq $CODE_POINT) {
5219 $map_to = "'$default_map'";
5222 $cp = "the single code point";
5225 $cp = "one of the $code_points";
5227 $cp .= " in Unicode Version $string_version for which the mapping is not to $map_to";
5232 my $status = $self->status;
5234 my $warn = uc $status_past_participles{$status};
5237 !!!!!!! $warn !!!!!!!!!!!!!!!!!!!
5238 All property or property=value combinations contained in this file are $warn.
5239 See $unicode_reference_url for what this means.
5243 $comment .= "This file returns the $mapping:\n";
5245 for my $i (0 .. @property_aliases - 1) {
5246 $comment .= sprintf("%-8s%s\n",
5248 $property_aliases[$i]->name . '(cp)'
5252 "\nwhere 'cp' is $cp. Note that $these_mappings $are ";
5254 my $access = $core_access{$addr};
5256 $comment .= "accessible through the Perl core via $access.";
5259 $comment .= "not accessible through the Perl core directly.";
5262 # And append any commentary already set from the actual property.
5263 $comment .= "\n\n" . $self->comment if $self->comment;
5264 if ($self->description) {
5265 $comment .= "\n\n" . join " ", $self->description;
5268 $comment .= "\n\n" . join " ", $self->note;
5272 if (! $self->perl_extension) {
5275 For information about what this property really means, see:
5276 $unicode_reference_url
5280 if ($count) { # Format differs for empty table
5281 $comment.= "\nThe format of the ";
5282 if ($self->range_size_1) {
5284 main body of lines of this file is: CODE_POINT\\t\\tMAPPING where CODE_POINT
5285 is in hex; MAPPING is what CODE_POINT maps to.
5290 # There are tables which end up only having one element per
5291 # range, but it is not worth keeping track of for making just
5292 # this comment a little better.
5294 non-comment portions of the main body of lines of this file is:
5295 START\\tSTOP\\tMAPPING where START is the starting code point of the
5296 range, in hex; STOP is the ending point, or if omitted, the range has just one
5297 code point; MAPPING is what each code point between START and STOP maps to.
5299 if ($self->output_range_counts) {
5301 Numbers in comments in [brackets] indicate how many code points are in the
5302 range (omitted when the range is a single code point or if the mapping is to
5308 $self->set_comment(main::join_lines($comment));
5312 my %swash_keys; # Makes sure don't duplicate swash names.
5315 # Returns the string that should be output in the file before the main
5316 # body of this table. This includes some hash entries identifying the
5317 # format of the body, and what the single value should be for all
5318 # ranges missing from it. It also includes any code points which have
5319 # map_types that don't go in the main table.
5322 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5324 my $addr; { no overloading; $addr = 0+$self; }
5326 my $name = $self->property->swash_name;
5328 if (defined $swash_keys{$name}) {
5329 Carp::my_carp(join_lines(<<END
5330 Already created a swash name '$name' for $swash_keys{$name}. This means that
5331 the same name desired for $self shouldn't be used. Bad News. This must be
5332 fixed before production use, but proceeding anyway
5336 $swash_keys{$name} = "$self";
5338 my $default_map = $default_map{$addr};
5341 if ($has_specials{$addr}) {
5343 # Here, some maps with non-zero type have been added to the table.
5344 # Go through the table and handle each of them. None will appear
5345 # in the body of the table, so delete each one as we go. The
5346 # code point count has already been calculated, so ok to delete
5349 my @multi_code_point_maps;
5350 my $has_hangul_syllables = 0;
5352 # The key is the base name of the code point, and the value is an
5353 # array giving all the ranges that use this base name. Each range
5354 # is actually a hash giving the 'low' and 'high' values of it.
5355 my %names_ending_in_code_point;
5357 # Inverse mapping. The list of ranges that have these kinds of
5358 # names. Each element contains the low, high, and base names in a
5360 my @code_points_ending_in_code_point;
5362 my $range_map = $self->_range_list;
5363 foreach my $range ($range_map->ranges) {
5364 next unless $range->type != 0;
5365 my $low = $range->start;
5366 my $high = $range->end;
5367 my $map = $range->value;
5368 my $type = $range->type;
5370 # No need to output the range if it maps to the default. And
5371 # the write method won't output it either, so no need to
5372 # delete it to keep it from being output, and is faster to
5373 # skip than to delete anyway.
5374 next if $map eq $default_map;
5376 # Delete the range to keep write() from trying to output it
5377 $range_map->delete_range($low, $high);
5379 # Switch based on the map type...
5380 if ($type == $HANGUL_SYLLABLE) {
5382 # These are entirely algorithmically determinable based on
5383 # some constants furnished by Unicode; for now, just set a
5384 # flag to indicate that have them. Below we will output
5385 # the code that does the algorithm.
5386 $has_hangul_syllables = 1;
5388 elsif ($type == $CP_IN_NAME) {
5390 # If the name ends in the code point it represents, are
5391 # also algorithmically determinable, but need information
5392 # about the map to do so. Both the map and its inverse
5393 # are stored in data structures output in the file.
5394 push @{$names_ending_in_code_point{$map}->{'low'}}, $low;
5395 push @{$names_ending_in_code_point{$map}->{'high'}}, $high;
5397 push @code_points_ending_in_code_point, { low => $low,
5402 elsif ($range->type == $MULTI_CP || $range->type == $NULL) {
5404 # Multi-code point maps and null string maps have an entry
5405 # for each code point in the range. They use the same
5407 for my $code_point ($low .. $high) {
5409 # The pack() below can't cope with surrogates.
5410 if ($code_point >= 0xD800 && $code_point <= 0xDFFF) {
5411 Carp::my_carp("Surrogage code point '$code_point' in mapping to '$map' in $self. No map created");
5415 # Generate the hash entries for these in the form that
5416 # utf8.c understands.
5418 foreach my $to (split " ", $map) {
5419 if ($to !~ /^$code_point_re$/) {
5420 Carp::my_carp("Illegal code point '$to' in mapping '$map' from $code_point in $self. No map created");
5423 $tostr .= sprintf "\\x{%s}", $to;
5426 # I (khw) have never waded through this line to
5427 # understand it well enough to comment it.
5428 my $utf8 = sprintf(qq["%s" => "$tostr",],
5429 join("", map { sprintf "\\x%02X", $_ }
5430 unpack("U0C*", pack("U", $code_point))));
5432 # Add a comment so that a human reader can more easily
5433 # see what's going on.
5434 push @multi_code_point_maps,
5435 sprintf("%-45s # U+%04X => %s", $utf8,
5441 Carp::my_carp("Unrecognized map type '$range->type' in '$range' in $self. Using type 0 instead");
5442 $range_map->add_map($low, $high, $map, Replace => $UNCONDITIONALLY, Type => 0);
5444 } # End of loop through all ranges
5446 # Here have gone through the whole file. If actually generated
5447 # anything for each map type, add its respective header and
5449 if (@multi_code_point_maps) {
5452 # Some code points require special handling because their mappings are each to
5453 # multiple code points. These do not appear in the main body, but are defined
5454 # in the hash below.
5456 # The key: UTF-8 _bytes_, the value: UTF-8 (speed hack)
5457 %utf8::ToSpec$name = (
5459 $pre_body .= join("\n", @multi_code_point_maps) . "\n);\n";
5462 if ($has_hangul_syllables || @code_points_ending_in_code_point) {
5464 # Convert these structures to output format.
5465 my $code_points_ending_in_code_point =
5466 main::simple_dumper(\@code_points_ending_in_code_point,
5468 my $names = main::simple_dumper(\%names_ending_in_code_point,
5471 # Do the same with the Hangul names,
5477 if ($has_hangul_syllables) {
5479 # Construct a regular expression of all the possible
5480 # combinations of the Hangul syllables.
5481 my @L_re; # Leading consonants
5482 for my $i ($LBase .. $LBase + $LCount - 1) {
5483 push @L_re, $Jamo{$i}
5485 my @V_re; # Middle vowels
5486 for my $i ($VBase .. $VBase + $VCount - 1) {
5487 push @V_re, $Jamo{$i}
5489 my @T_re; # Trailing consonants
5490 for my $i ($TBase + 1 .. $TBase + $TCount - 1) {
5491 push @T_re, $Jamo{$i}
5494 # The whole re is made up of the L V T combination.
5496 . join ('|', sort @L_re)
5498 . join ('|', sort @V_re)
5500 . join ('|', sort @T_re)
5503 # These hashes needed by the algorithm were generated
5504 # during reading of the Jamo.txt file
5505 $jamo = main::simple_dumper(\%Jamo, ' ' x 8);
5506 $jamo_l = main::simple_dumper(\%Jamo_L, ' ' x 8);
5507 $jamo_v = main::simple_dumper(\%Jamo_V, ' ' x 8);
5508 $jamo_t = main::simple_dumper(\%Jamo_T, ' ' x 8);
5513 # To achieve significant memory savings when this file is read in,
5514 # algorithmically derivable code points are omitted from the main body below.
5515 # Instead, the following routines can be used to translate between name and
5516 # code point and vice versa
5520 # Matches legal code point. 4-6 hex numbers, If there are 6, the
5521 # first two must be '10'; if there are 5, the first must not be a '0'.
5522 my \$code_point_re = qr/$code_point_re/;
5524 # In the following hash, the keys are the bases of names which includes
5525 # the code point in the name, like CJK UNIFIED IDEOGRAPH-4E01. The values
5526 # of each key is another hash which is used to get the low and high ends
5527 # for each range of code points that apply to the name
5528 my %names_ending_in_code_point = (
5532 # And the following array gives the inverse mapping from code points to
5533 # names. Lowest code points are first
5534 my \@code_points_ending_in_code_point = (
5535 $code_points_ending_in_code_point
5538 # Earlier releases didn't have Jamos. No sense outputting
5539 # them unless will be used.
5540 if ($has_hangul_syllables) {
5543 # Convert from code point to Jamo short name for use in composing Hangul
5549 # Leading consonant (can be null)
5559 # Optional trailing consonant
5564 # Computed re that splits up a Hangul name into LVT or LV syllables
5565 my \$syllable_re = qr/$jamo_re/;
5567 my \$HANGUL_SYLLABLE = "HANGUL SYLLABLE ";
5568 my \$HANGUL_SYLLABLE_LENGTH = length \$HANGUL_SYLLABLE;
5570 # These constants names and values were taken from the Unicode standard,
5571 # version 5.1, section 3.12. They are used in conjunction with Hangul
5573 my \$SBase = 0xAC00;
5574 my \$LBase = 0x1100;
5575 my \$VBase = 0x1161;
5576 my \$TBase = 0x11A7;
5577 my \$SCount = 11172;
5581 my \$NCount = \$VCount * \$TCount;
5583 } # End of has Jamos
5585 $pre_body .= << 'END';
5587 sub name_to_code_point_special {
5590 # Returns undef if not one of the specially handled names; otherwise
5591 # returns the code point equivalent to the input name
5593 if ($has_hangul_syllables) {
5594 $pre_body .= << 'END';
5596 if (substr($name, 0, $HANGUL_SYLLABLE_LENGTH) eq $HANGUL_SYLLABLE) {
5597 $name = substr($name, $HANGUL_SYLLABLE_LENGTH);
5598 return if $name !~ qr/^$syllable_re$/;
5599 my $L = $Jamo_L{$1};
5600 my $V = $Jamo_V{$2};
5601 my $T = (defined $3) ? $Jamo_T{$3} : 0;
5602 return ($L * $VCount + $V) * $TCount + $T + $SBase;
5606 $pre_body .= << 'END';
5608 # Name must end in '-code_point' for this to handle.
5609 if ($name !~ /^ (.*) - ($code_point_re) $/x) {
5614 my $code_point = CORE::hex $2;
5616 # Name must be one of the ones which has the code point in it.
5617 return if ! $names_ending_in_code_point{$base};
5619 # Look through the list of ranges that apply to this name to see if
5620 # the code point is in one of them.
5621 for (my $i = 0; $i < scalar @{$names_ending_in_code_point{$base}{'low'}}; $i++) {
5622 return if $names_ending_in_code_point{$base}{'low'}->[$i] > $code_point;
5623 next if $names_ending_in_code_point{$base}{'high'}->[$i] < $code_point;
5625 # Here, the code point is in the range.
5629 # Here, looked like the name had a code point number in it, but
5630 # did not match one of the valid ones.
5634 sub code_point_to_name_special {
5635 my $code_point = shift;
5637 # Returns the name of a code point if algorithmically determinable;
5640 if ($has_hangul_syllables) {
5641 $pre_body .= << 'END';
5643 # If in the Hangul range, calculate the name based on Unicode's
5645 if ($code_point >= $SBase && $code_point <= $SBase + $SCount -1) {
5647 my $SIndex = $code_point - $SBase;
5648 my $L = $LBase + $SIndex / $NCount;
5649 my $V = $VBase + ($SIndex % $NCount) / $TCount;
5650 my $T = $TBase + $SIndex % $TCount;
5651 $name = "$HANGUL_SYLLABLE $Jamo{$L}$Jamo{$V}";
5652 $name .= $Jamo{$T} if $T != $TBase;
5657 $pre_body .= << 'END';
5659 # Look through list of these code points for one in range.
5660 foreach my $hash (@code_points_ending_in_code_point) {
5661 return if $code_point < $hash->{'low'};
5662 if ($code_point <= $hash->{'high'}) {
5663 return sprintf("%s-%04X", $hash->{'name'}, $code_point);
5666 return; # None found
5671 } # End of has hangul or code point in name maps.
5672 } # End of has specials
5674 # Calculate the format of the table if not already done.
5675 my $format = $format{$addr};
5676 my $property = $self->property;
5677 my $type = $property->type;
5678 if (! defined $format) {
5679 if ($type == $BINARY) {
5681 # Don't bother checking the values, because we elsewhere
5682 # verify that a binary table has only 2 values.
5683 $format = $BINARY_FORMAT;
5686 my @ranges = $self->_range_list->ranges;
5688 # default an empty table based on its type and default map
5691 # But it turns out that the only one we can say is a
5692 # non-string (besides binary, handled above) is when the
5693 # table is a string and the default map is to a code point
5694 if ($type == $STRING && $default_map eq $CODE_POINT) {
5695 $format = $HEX_FORMAT;
5698 $format = $STRING_FORMAT;
5703 # Start with the most restrictive format, and as we find
5704 # something that doesn't fit with that, change to the next
5705 # most restrictive, and so on.
5706 $format = $DECIMAL_FORMAT;
5707 foreach my $range (@ranges) {
5708 my $map = $range->value;
5709 if ($map ne $default_map) {
5710 last if $format eq $STRING_FORMAT; # already at
5713 $format = $INTEGER_FORMAT
5714 if $format eq $DECIMAL_FORMAT
5715 && $map !~ / ^ [0-9] $ /x;
5716 $format = $FLOAT_FORMAT
5717 if $format eq $INTEGER_FORMAT
5718 && $map !~ / ^ -? [0-9]+ $ /x;
5719 $format = $RATIONAL_FORMAT
5720 if $format eq $FLOAT_FORMAT
5721 && $map !~ / ^ -? [0-9]+ \. [0-9]* $ /x;
5722 $format = $HEX_FORMAT
5723 if $format eq $RATIONAL_FORMAT
5724 && $map !~ / ^ -? [0-9]+ ( \/ [0-9]+ )? $ /x;
5725 $format = $STRING_FORMAT if $format eq $HEX_FORMAT
5726 && $map =~ /[^0-9A-F]/;
5731 } # end of calculating format
5734 # The name this swash is to be known by, with the format of the mappings in
5735 # the main body of the table, and what all code points missing from this file
5737 \$utf8::SwashInfo{'To$name'}{'format'} = '$format'; # $map_table_formats{$format}
5739 my $missing = $default_map;
5740 if ($missing eq $CODE_POINT
5741 && $format ne $HEX_FORMAT
5742 && ! defined $format{$addr}) # Is expected if was manually set
5744 Carp::my_carp_bug("Expecting hex format for mapping table for $self, instead got '$format'")
5746 $format{$addr} = $format;
5747 $return .= "\$utf8::SwashInfo{'To$name'}{'missing'} = '$missing';";
5748 if ($missing eq $CODE_POINT) {
5749 $return .= ' # code point maps to itself';
5751 elsif ($missing eq "") {
5752 $return .= ' # code point maps to the null string';
5756 $return .= $pre_body;
5762 # Write the table to the file.
5765 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5767 my $addr; { no overloading; $addr = 0+$self; }
5769 return $self->SUPER::write(
5770 ($self->property == $block)
5771 ? 7 # block file needs more tab stops
5773 $default_map{$addr}); # don't write defaulteds
5776 # Accessors for the underlying list that should fail if locked.
5786 return if $self->carp_if_locked;
5787 return $self->_range_list->$sub(@_);
5790 } # End closure for Map_Table
5792 package Match_Table;
5793 use base '_Base_Table';
5795 # A Match table is one which is a list of all the code points that have
5796 # the same property and property value, for use in \p{property=value}
5797 # constructs in regular expressions. It adds very little data to the base
5798 # structure, but many methods, as these lists can be combined in many ways to
5800 # There are only a few concepts added:
5801 # 1) Equivalents and Relatedness.
5802 # Two tables can match the identical code points, but have different names.
5803 # This always happens when there is a perl single form extension
5804 # \p{IsProperty} for the Unicode compound form \P{Property=True}. The two
5805 # tables are set to be related, with the Perl extension being a child, and
5806 # the Unicode property being the parent.
5808 # It may be that two tables match the identical code points and we don't
5809 # know if they are related or not. This happens most frequently when the
5810 # Block and Script properties have the exact range. But note that a
5811 # revision to Unicode could add new code points to the script, which would
5812 # now have to be in a different block (as the block was filled, or there
5813 # would have been 'Unknown' script code points in it and they wouldn't have
5814 # been identical). So we can't rely on any two properties from Unicode
5815 # always matching the same code points from release to release, and thus
5816 # these tables are considered coincidentally equivalent--not related. When
5817 # two tables are unrelated but equivalent, one is arbitrarily chosen as the
5818 # 'leader', and the others are 'equivalents'. This concept is useful
5819 # to minimize the number of tables written out. Only one file is used for
5820 # any identical set of code points, with entries in Heavy.pl mapping all
5821 # the involved tables to it.
5823 # Related tables will always be identical; we set them up to be so. Thus
5824 # if the Unicode one is deprecated, the Perl one will be too. Not so for
5825 # unrelated tables. Relatedness makes generating the documentation easier.
5827 # 2) Conflicting. It may be that there will eventually be name clashes, with
5828 # the same name meaning different things. For a while, there actually were
5829 # conflicts, but they have so far been resolved by changing Perl's or
5830 # Unicode's definitions to match the other, but when this code was written,
5831 # it wasn't clear that that was what was going to happen. (Unicode changed
5832 # because of protests during their beta period.) Name clashes are warned
5833 # about during compilation, and the documentation. The generated tables
5834 # are sane, free of name clashes, because the code suppresses the Perl
5835 # version. But manual intervention to decide what the actual behavior
5836 # should be may be required should this happen. The introductory comments
5837 # have more to say about this.
5839 sub standardize { return main::standardize($_[0]); }
5840 sub trace { return main::trace(@_); }
5845 main::setup_package();
5848 # The leader table of this one; initially $self.
5849 main::set_access('leader', \%leader, 'r');
5852 # An array of any tables that have this one as their leader
5853 main::set_access('equivalents', \%equivalents, 'readable_array');
5856 # The parent table to this one, initially $self. This allows us to
5857 # distinguish between equivalent tables that are related, and those which
5858 # may not be, but share the same output file because they match the exact
5859 # same set of code points in the current Unicode release.
5860 main::set_access('parent', \%parent, 'r');
5863 # An array of any tables that have this one as their parent
5864 main::set_access('children', \%children, 'readable_array');
5867 # Array of any tables that would have the same name as this one with
5868 # a different meaning. This is used for the generated documentation.
5869 main::set_access('conflicting', \%conflicting, 'readable_array');
5872 # Set in the constructor for tables that are expected to match all code
5874 main::set_access('matches_all', \%matches_all, 'r');
5881 # The property for which this table is a listing of property values.
5882 my $property = delete $args{'_Property'};
5884 my $name = delete $args{'Name'};
5885 my $full_name = delete $args{'Full_Name'};
5886 $full_name = $name if ! defined $full_name;
5889 my $initialize = delete $args{'Initialize'};
5890 my $matches_all = delete $args{'Matches_All'} || 0;
5891 # Rest of parameters passed on.
5893 my $range_list = Range_List->new(Initialize => $initialize,
5894 Owner => $property);
5896 my $complete = $full_name;
5897 $complete = '""' if $complete eq ""; # A null name shouldn't happen,
5898 # but this helps debug if it
5900 # The complete name for a match table includes it's property in a
5901 # compound form 'property=table', except if the property is the
5902 # pseudo-property, perl, in which case it is just the single form,
5903 # 'table' (If you change the '=' must also change the ':' in lots of
5904 # places in this program that assume an equal sign)
5905 $complete = $property->full_name . "=$complete" if $property != $perl;
5907 my $self = $class->SUPER::new(%args,
5909 Complete_Name => $complete,
5910 Full_Name => $full_name,
5911 _Property => $property,
5912 _Range_List => $range_list,
5914 my $addr; { no overloading; $addr = 0+$self; }
5916 $conflicting{$addr} = [ ];
5917 $equivalents{$addr} = [ ];
5918 $children{$addr} = [ ];
5919 $matches_all{$addr} = $matches_all;
5920 $leader{$addr} = $self;
5921 $parent{$addr} = $self;
5926 # See this program's beginning comment block about overloading these.
5929 qw("") => "_operator_stringify",
5933 return if $self->carp_if_locked;
5941 return $self->_range_list + $other;
5947 return $self->_range_list & $other;
5953 return if $self->carp_if_locked;
5955 my $addr; { no overloading; $addr = 0+$self; }
5959 # Change the range list of this table to be the
5961 $self->_set_range_list($self->_range_list
5964 else { # $other is just a simple value
5965 $self->add_range($other, $other);
5969 '-' => sub { my $self = shift;
5971 my $reversed = shift;
5974 Carp::my_carp_bug("Can't cope with a "
5976 . " being the first parameter in a '-'. Subtraction ignored.");
5980 return $self->_range_list - $other;
5982 '~' => sub { my $self = shift;
5983 return ~ $self->_range_list;
5987 sub _operator_stringify {
5990 my $name = $self->complete_name;
5991 return "Table '$name'";
5995 # Add a synonym for this table. See the comments in the base class
5999 # Rest of parameters passed on.
6001 $self->SUPER::add_alias($name, $self, @_);
6005 sub add_conflicting {
6006 # Add the name of some other object to the list of ones that name
6007 # clash with this match table.
6010 my $conflicting_name = shift; # The name of the conflicting object
6011 my $p = shift || 'p'; # Optional, is this a \p{} or \P{} ?
6012 my $conflicting_object = shift; # Optional, the conflicting object
6013 # itself. This is used to
6014 # disambiguate the text if the input
6015 # name is identical to any of the
6016 # aliases $self is known by.
6017 # Sometimes the conflicting object is
6018 # merely hypothetical, so this has to
6019 # be an optional parameter.
6020 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6022 my $addr; { no overloading; $addr = 0+$self; }
6024 # Check if the conflicting name is exactly the same as any existing
6025 # alias in this table (as long as there is a real object there to
6026 # disambiguate with).
6027 if (defined $conflicting_object) {
6028 foreach my $alias ($self->aliases) {
6029 if ($alias->name eq $conflicting_name) {
6031 # Here, there is an exact match. This results in
6032 # ambiguous comments, so disambiguate by changing the
6033 # conflicting name to its object's complete equivalent.
6034 $conflicting_name = $conflicting_object->complete_name;
6040 # Convert to the \p{...} final name
6041 $conflicting_name = "\\$p" . "{$conflicting_name}";
6044 return if grep { $conflicting_name eq $_ } @{$conflicting{$addr}};
6046 push @{$conflicting{$addr}}, $conflicting_name;
6051 sub is_equivalent_to {
6052 # Return boolean of whether or not the other object is a table of this
6053 # type and has been marked equivalent to this one.
6057 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6059 return 0 if ! defined $other; # Can happen for incomplete early
6061 unless ($other->isa(__PACKAGE__)) {
6062 my $ref_other = ref $other;
6063 my $ref_self = ref $self;
6064 Carp::my_carp_bug("Argument to 'is_equivalent_to' must be another $ref_self, not a '$ref_other'. $other not set equivalent to $self.");
6068 # Two tables are equivalent if they have the same leader.
6070 return $leader{0+$self} == $leader{0+$other};
6074 sub matches_identically_to {
6075 # Return a boolean as to whether or not two tables match identical
6076 # sets of code points.
6080 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6082 unless ($other->isa(__PACKAGE__)) {
6083 my $ref_other = ref $other;
6084 my $ref_self = ref $self;
6085 Carp::my_carp_bug("Argument to 'matches_identically_to' must be another $ref_self, not a '$ref_other'. $other not set equivalent to $self.");
6089 # These are ordered in increasing real time to figure out (at least
6090 # until a patch changes that and doesn't change this)
6091 return 0 if $self->max != $other->max;
6092 return 0 if $self->min != $other->min;
6093 return 0 if $self->range_count != $other->range_count;
6094 return 0 if $self->count != $other->count;
6096 # Here they could be identical because all the tests above passed.
6097 # The loop below is somewhat simpler since we know they have the same
6098 # number of elements. Compare range by range, until reach the end or
6099 # find something that differs.
6100 my @a_ranges = $self->_range_list->ranges;
6101 my @b_ranges = $other->_range_list->ranges;
6102 for my $i (0 .. @a_ranges - 1) {
6103 my $a = $a_ranges[$i];
6104 my $b = $b_ranges[$i];
6105 trace "self $a; other $b" if main::DEBUG && $to_trace;
6106 return 0 if $a->start != $b->start || $a->end != $b->end;
6111 sub set_equivalent_to {
6112 # Set $self equivalent to the parameter table.
6113 # The required Related => 'x' parameter is a boolean indicating
6114 # whether these tables are related or not. If related, $other becomes
6115 # the 'parent' of $self; if unrelated it becomes the 'leader'
6117 # Related tables share all characteristics except names; equivalents
6118 # not quite so many.
6119 # If they are related, one must be a perl extension. This is because
6120 # we can't guarantee that Unicode won't change one or the other in a
6121 # later release even if they are idential now.
6127 my $related = delete $args{'Related'};
6129 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
6131 return if ! defined $other; # Keep on going; happens in some early
6134 if (! defined $related) {
6135 Carp::my_carp_bug("set_equivalent_to must have 'Related => [01] parameter. Assuming $self is not related to $other");
6139 # If already are equivalent, no need to re-do it; if subroutine
6140 # returns null, it found an error, also do nothing
6141 my $are_equivalent = $self->is_equivalent_to($other);
6142 return if ! defined $are_equivalent || $are_equivalent;
6144 my $addr; { no overloading; $addr = 0+$self; }
6145 my $current_leader = ($related) ? $parent{$addr} : $leader{$addr};
6148 ! $other->perl_extension
6149 && ! $current_leader->perl_extension)
6151 Carp::my_carp_bug("set_equivalent_to should have 'Related => 0 for equivalencing two Unicode properties. Assuming $self is not related to $other");
6155 my $leader; { no overloading; $leader = 0+$current_leader; }
6156 my $other_addr; { no overloading; $other_addr = 0+$other; }
6158 # Any tables that are equivalent to or children of this table must now
6159 # instead be equivalent to or (children) to the new leader (parent),
6160 # still equivalent. The equivalency includes their matches_all info,
6161 # and for related tables, their status
6162 # All related tables are of necessity equivalent, but the converse
6163 # isn't necessarily true
6164 my $status = $other->status;
6165 my $status_info = $other->status_info;
6166 my $matches_all = $matches_all{other_addr};
6167 foreach my $table ($current_leader, @{$equivalents{$leader}}) {
6168 next if $table == $other;
6169 trace "setting $other to be the leader of $table, status=$status" if main::DEBUG && $to_trace;
6171 my $table_addr; { no overloading; $table_addr = 0+$table; }
6172 $leader{$table_addr} = $other;
6173 $matches_all{$table_addr} = $matches_all;
6174 $self->_set_range_list($other->_range_list);
6175 push @{$equivalents{$other_addr}}, $table;
6177 $parent{$table_addr} = $other;
6178 push @{$children{$other_addr}}, $table;
6179 $table->set_status($status, $status_info);
6183 # Now that we've declared these to be equivalent, any changes to one
6184 # of the tables would invalidate that equivalency.
6190 sub add_range { # Add a range to the list for this table.
6192 # Rest of parameters passed on
6194 return if $self->carp_if_locked;
6195 return $self->_range_list->add_range(@_);
6198 sub pre_body { # Does nothing for match tables.
6202 sub append_to_body { # Does nothing for match tables.
6208 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6210 return $self->SUPER::write(2); # 2 tab stops
6213 sub set_final_comment {
6214 # This creates a comment for the file that is to hold the match table
6215 # $self. It is somewhat convoluted to make the English read nicely,
6216 # but, heh, it's just a comment.
6217 # This should be called only with the leader match table of all the
6218 # ones that share the same file. It lists all such tables, ordered so
6219 # that related ones are together.
6221 my $leader = shift; # Should only be called on the leader table of
6222 # an equivalent group
6223 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6225 my $addr; { no overloading; $addr = 0+$leader; }
6227 if ($leader{$addr} != $leader) {
6228 Carp::my_carp_bug(<<END
6229 set_final_comment() must be called on a leader table, which $leader is not.
6230 It is equivalent to $leader{$addr}. No comment created
6236 # Get the number of code points matched by each of the tables in this
6237 # file, and add underscores for clarity.
6238 my $count = $leader->count;
6239 my $string_count = main::clarify_number($count);
6241 my $loose_count = 0; # how many aliases loosely matched
6242 my $compound_name = ""; # ? Are any names compound?, and if so, an
6244 my $properties_with_compound_names = 0; # count of these
6247 my %flags; # The status flags used in the file
6248 my $total_entries = 0; # number of entries written in the comment
6249 my $matches_comment = ""; # The portion of the comment about the
6251 my @global_comments; # List of all the tables' comments that are
6252 # there before this routine was called.
6254 # Get list of all the parent tables that are equivalent to this one
6255 # (including itself).
6256 my @parents = grep { $parent{main::objaddr $_} == $_ }
6257 main::uniques($leader, @{$equivalents{$addr}});
6258 my $has_unrelated = (@parents >= 2); # boolean, ? are there unrelated
6261 for my $parent (@parents) {
6263 my $property = $parent->property;
6265 # Special case 'N' tables in properties with two match tables when
6266 # the other is a 'Y' one. These are likely to be binary tables,
6267 # but not necessarily. In either case, \P{} will match the
6268 # complement of \p{}, and so if something is a synonym of \p, the
6269 # complement of that something will be the synonym of \P. This
6270 # would be true of any property with just two match tables, not
6271 # just those whose values are Y and N; but that would require a
6272 # little extra work, and there are none such so far in Unicode.
6273 my $perl_p = 'p'; # which is it? \p{} or \P{}
6274 my @yes_perl_synonyms; # list of any synonyms for the 'Y' table
6276 if (scalar $property->tables == 2
6277 && $parent == $property->table('N')
6278 && defined (my $yes = $property->table('Y')))
6280 my $yes_addr; { no overloading; $yes_addr = 0+$yes; }
6282 = grep { $_->property == $perl }
6285 $parent{$yes_addr}->children);
6287 # But these synonyms are \P{} ,not \p{}
6291 my @description; # Will hold the table description
6292 my @note; # Will hold the table notes.
6293 my @conflicting; # Will hold the table conflicts.
6295 # Look at the parent, any yes synonyms, and all the children
6296 my $parent_addr; { no overloading; $parent_addr = 0+$parent; }
6297 for my $table ($parent,
6299 @{$children{$parent_addr}})
6301 my $table_addr; { no overloading; $table_addr = 0+$table; }
6302 my $table_property = $table->property;
6304 # Tables are separated by a blank line to create a grouping.
6305 $matches_comment .= "\n" if $matches_comment;
6307 # The table is named based on the property and value
6308 # combination it is for, like script=greek. But there may be
6309 # a number of synonyms for each side, like 'sc' for 'script',
6310 # and 'grek' for 'greek'. Any combination of these is a valid
6311 # name for this table. In this case, there are three more,
6312 # 'sc=grek', 'sc=greek', and 'script='grek'. Rather than
6313 # listing all possible combinations in the comment, we make
6314 # sure that each synonym occurs at least once, and add
6315 # commentary that the other combinations are possible.
6316 my @property_aliases = $table_property->aliases;
6317 my @table_aliases = $table->aliases;
6319 Carp::my_carp_bug("$table doesn't have any names. Proceeding anyway.") unless @table_aliases;
6321 # The alias lists above are already ordered in the order we
6322 # want to output them. To ensure that each synonym is listed,
6323 # we must use the max of the two numbers.
6324 my $listed_combos = main::max(scalar @table_aliases,
6325 scalar @property_aliases);
6326 trace "$listed_combos, tables=", scalar @table_aliases, "; names=", scalar @property_aliases if main::DEBUG;
6328 my $property_had_compound_name = 0;
6330 for my $i (0 .. $listed_combos - 1) {
6333 # The current alias for the property is the next one on
6334 # the list, or if beyond the end, start over. Similarly
6335 # for the table (\p{prop=table})
6336 my $property_alias = $property_aliases
6337 [$i % @property_aliases]->name;
6338 my $table_alias_object = $table_aliases
6339 [$i % @table_aliases];
6340 my $table_alias = $table_alias_object->name;
6341 my $loose_match = $table_alias_object->loose_match;
6343 if ($table_alias !~ /\D/) { # Clarify large numbers.
6344 $table_alias = main::clarify_number($table_alias)
6347 # Add a comment for this alias combination
6348 my $current_match_comment;
6349 if ($table_property == $perl) {
6350 $current_match_comment = "\\$perl_p"
6354 $current_match_comment
6355 = "\\p{$property_alias=$table_alias}";
6356 $property_had_compound_name = 1;
6359 # Flag any abnormal status for this table.
6360 my $flag = $property->status
6362 || $table_alias_object->status;
6364 if ($flag ne $PLACEHOLDER) {
6365 $flags{$flag} = $status_past_participles{$flag};
6367 $flags{$flag} = <<END;
6368 a placeholder because it is not in Version $string_version of Unicode, but is
6369 needed by the Perl core to work gracefully. Because it is not in this version
6370 of Unicode, it will not be listed in $pod_file.pod
6377 # Pretty up the comment. Note the \b; it says don't make
6378 # this line a continuation.
6379 $matches_comment .= sprintf("\b%-1s%-s%s\n",
6382 $current_match_comment);
6383 } # End of generating the entries for this table.
6385 # Save these for output after this group of related tables.
6386 push @description, $table->description;
6387 push @note, $table->note;
6388 push @conflicting, $table->conflicting;
6390 # And this for output after all the tables.
6391 push @global_comments, $table->comment;
6393 # Compute an alternate compound name using the final property
6394 # synonym and the first table synonym with a colon instead of
6395 # the equal sign used elsewhere.
6396 if ($property_had_compound_name) {
6397 $properties_with_compound_names ++;
6398 if (! $compound_name || @property_aliases > 1) {
6399 $compound_name = $property_aliases[-1]->name
6401 . $table_aliases[0]->name;
6404 } # End of looping through all children of this table
6406 # Here have assembled in $matches_comment all the related tables
6407 # to the current parent (preceded by the same info for all the
6408 # previous parents). Put out information that applies to all of
6409 # the current family.
6412 # But output the conflicting information now, as it applies to
6414 my $conflicting = join ", ", @conflicting;
6416 $matches_comment .= <<END;
6418 Note that contrary to what you might expect, the above is NOT the same as
6420 $matches_comment .= "any of: " if @conflicting > 1;
6421 $matches_comment .= "$conflicting\n";
6425 $matches_comment .= "\n Meaning: "
6426 . join('; ', @description)
6430 $matches_comment .= "\n Note: "
6431 . join("\n ", @note)
6434 } # End of looping through all tables
6442 $code_points = 'single code point';
6446 $code_points = "$string_count code points";
6451 if ($total_entries <= 1) {
6454 $any_of_these = 'this'
6457 $synonyms = " any of the following regular expression constructs";
6458 $entries = 'entries';
6459 $any_of_these = 'any of these'
6463 if ($has_unrelated) {
6465 This file is for tables that are not necessarily related: To conserve
6466 resources, every table that matches the identical set of code points in this
6467 version of Unicode uses this file. Each one is listed in a separate group
6468 below. It could be that the tables will match the same set of code points in
6469 other Unicode releases, or it could be purely coincidence that they happen to
6470 be the same in Unicode $string_version, and hence may not in other versions.
6476 foreach my $flag (sort keys %flags) {
6478 '$flag' below means that this form is $flags{$flag}.
6480 next if $flag eq $PLACEHOLDER;
6481 $comment .= "Consult $pod_file.pod\n";
6487 This file returns the $code_points in Unicode Version $string_version that
6491 $pod_file.pod should be consulted for the syntax rules for $any_of_these,
6492 including if adding or subtracting white space, underscore, and hyphen
6493 characters matters or doesn't matter, and other permissible syntactic
6494 variants. Upper/lower case distinctions never matter.
6497 if ($compound_name) {
6500 A colon can be substituted for the equals sign, and
6502 if ($properties_with_compound_names > 1) {
6504 within each group above,
6507 $compound_name = sprintf("%-8s\\p{%s}", " ", $compound_name);
6509 # Note the \b below, it says don't make that line a continuation.
6511 anything to the left of the equals (or colon) can be combined with anything to
6512 the right. Thus, for example,
6518 # And append any comment(s) from the actual tables. They are all
6519 # gathered here, so may not read all that well.
6520 if (@global_comments) {
6521 $comment .= "\n" . join("\n\n", @global_comments) . "\n";
6524 if ($count) { # The format differs if no code points, and needs no
6525 # explanation in that case
6528 The format of the lines of this file is:
6531 START\\tSTOP\\twhere START is the starting code point of the range, in hex;
6532 STOP is the ending point, or if omitted, the range has just one code point.
6534 if ($leader->output_range_counts) {
6536 Numbers in comments in [brackets] indicate how many code points are in the
6542 $leader->set_comment(main::join_lines($comment));
6546 # Accessors for the underlying list
6548 get_valid_code_point
6549 get_invalid_code_point
6557 return $self->_range_list->$sub(@_);
6560 } # End closure for Match_Table
6564 # The Property class represents a Unicode property, or the $perl
6565 # pseudo-property. It contains a map table initialized empty at construction
6566 # time, and for properties accessible through regular expressions, various
6567 # match tables, created through the add_match_table() method, and referenced
6568 # by the table('NAME') or tables() methods, the latter returning a list of all
6569 # of the match tables. Otherwise table operations implicitly are for the map
6572 # Most of the data in the property is actually about its map table, so it
6573 # mostly just uses that table's accessors for most methods. The two could
6574 # have been combined into one object, but for clarity because of their
6575 # differing semantics, they have been kept separate. It could be argued that
6576 # the 'file' and 'directory' fields should be kept with the map table.
6578 # Each property has a type. This can be set in the constructor, or in the
6579 # set_type accessor, but mostly it is figured out by the data. Every property
6580 # starts with unknown type, overridden by a parameter to the constructor, or
6581 # as match tables are added, or ranges added to the map table, the data is
6582 # inspected, and the type changed. After the table is mostly or entirely
6583 # filled, compute_type() should be called to finalize they analysis.
6585 # There are very few operations defined. One can safely remove a range from
6586 # the map table, and property_add_or_replace_non_nulls() adds the maps from another
6587 # table to this one, replacing any in the intersection of the two.
6589 sub standardize { return main::standardize($_[0]); }
6590 sub trace { return main::trace(@_) if main::DEBUG && $to_trace }
6594 # This hash will contain as keys, all the aliases of all properties, and
6595 # as values, pointers to their respective property objects. This allows
6596 # quick look-up of a property from any of its names.
6597 my %alias_to_property_of;
6599 sub dump_alias_to_property_of {
6602 print "\n", main::simple_dumper (\%alias_to_property_of), "\n";
6607 # This is a package subroutine, not called as a method.
6608 # If the single parameter is a literal '*' it returns a list of all
6609 # defined properties.
6610 # Otherwise, the single parameter is a name, and it returns a pointer
6611 # to the corresponding property object, or undef if none.
6613 # Properties can have several different names. The 'standard' form of
6614 # each of them is stored in %alias_to_property_of as they are defined.
6615 # But it's possible that this subroutine will be called with some
6616 # variant, so if the initial lookup fails, it is repeated with the
6617 # standarized form of the input name. If found, besides returning the
6618 # result, the input name is added to the list so future calls won't
6619 # have to do the conversion again.
6623 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6625 if (! defined $name) {
6626 Carp::my_carp_bug("Undefined input property. No action taken.");
6630 return main::uniques(values %alias_to_property_of) if $name eq '*';
6632 # Return cached result if have it.
6633 my $result = $alias_to_property_of{$name};
6634 return $result if defined $result;
6636 # Convert the input to standard form.
6637 my $standard_name = standardize($name);
6639 $result = $alias_to_property_of{$standard_name};
6640 return unless defined $result; # Don't cache undefs
6642 # Cache the result before returning it.
6643 $alias_to_property_of{$name} = $result;
6648 main::setup_package();
6651 # A pointer to the map table object for this property
6652 main::set_access('map', \%map);
6655 # The property's full name. This is a duplicate of the copy kept in the
6656 # map table, but is needed because stringify needs it during
6657 # construction of the map table, and then would have a chicken before egg
6659 main::set_access('full_name', \%full_name, 'r');
6662 # This hash will contain as keys, all the aliases of any match tables
6663 # attached to this property, and as values, the pointers to their
6664 # respective tables. This allows quick look-up of a table from any of its
6666 main::set_access('table_ref', \%table_ref);
6669 # The type of the property, $ENUM, $BINARY, etc
6670 main::set_access('type', \%type, 'r');
6673 # The filename where the map table will go (if actually written).
6674 # Normally defaulted, but can be overridden.
6675 main::set_access('file', \%file, 'r', 's');
6678 # The directory where the map table will go (if actually written).
6679 # Normally defaulted, but can be overridden.
6680 main::set_access('directory', \%directory, 's');
6682 my %pseudo_map_type;
6683 # This is used to affect the calculation of the map types for all the
6684 # ranges in the table. It should be set to one of the values that signify
6685 # to alter the calculation.
6686 main::set_access('pseudo_map_type', \%pseudo_map_type, 'r');
6688 my %has_only_code_point_maps;
6689 # A boolean used to help in computing the type of data in the map table.
6690 main::set_access('has_only_code_point_maps', \%has_only_code_point_maps);
6693 # A list of the first few distinct mappings this property has. This is
6694 # used to disambiguate between binary and enum property types, so don't
6695 # have to keep more than three.
6696 main::set_access('unique_maps', \%unique_maps);
6699 # The only required parameter is the positionally first, name. All
6700 # other parameters are key => value pairs. See the documentation just
6701 # above for the meanings of the ones not passed directly on to the map
6702 # table constructor.
6705 my $name = shift || "";
6707 my $self = property_ref($name);
6708 if (defined $self) {
6709 my $options_string = join ", ", @_;
6710 $options_string = ". Ignoring options $options_string" if $options_string;
6711 Carp::my_carp("$self is already in use. Using existing one$options_string;");
6717 $self = bless \do { my $anonymous_scalar }, $class;
6718 my $addr; { no overloading; $addr = 0+$self; }
6720 $directory{$addr} = delete $args{'Directory'};
6721 $file{$addr} = delete $args{'File'};
6722 $full_name{$addr} = delete $args{'Full_Name'} || $name;
6723 $type{$addr} = delete $args{'Type'} || $UNKNOWN;
6724 $pseudo_map_type{$addr} = delete $args{'Map_Type'};
6725 # Rest of parameters passed on.
6727 $has_only_code_point_maps{$addr} = 1;
6728 $table_ref{$addr} = { };
6729 $unique_maps{$addr} = { };
6731 $map{$addr} = Map_Table->new($name,
6732 Full_Name => $full_name{$addr},
6733 _Alias_Hash => \%alias_to_property_of,
6739 # See this program's beginning comment block about overloading the copy
6740 # constructor. Few operations are defined on properties, but a couple are
6741 # useful. It is safe to take the inverse of a property, and to remove a
6742 # single code point from it.
6745 qw("") => "_operator_stringify",
6746 "." => \&main::_operator_dot,
6747 '==' => \&main::_operator_equal,
6748 '!=' => \&main::_operator_not_equal,
6749 '=' => sub { return shift },
6750 '-=' => "_minus_and_equal",
6753 sub _operator_stringify {
6754 return "Property '" . shift->full_name . "'";
6757 sub _minus_and_equal {
6758 # Remove a single code point from the map table of a property.
6762 my $reversed = shift;
6763 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6766 Carp::my_carp_bug("Can't cope with a "
6768 . " argument to '-='. Subtraction ignored.");
6771 elsif ($reversed) { # Shouldnt happen in a -=, but just in case
6772 Carp::my_carp_bug("Can't cope with a "
6774 . " being the first parameter in a '-='. Subtraction ignored.");
6779 $map{0+$self}->delete_range($other, $other);
6784 sub add_match_table {
6785 # Add a new match table for this property, with name given by the
6786 # parameter. It returns a pointer to the table.
6792 my $addr; { no overloading; $addr = 0+$self; }
6794 my $table = $table_ref{$addr}{$name};
6795 my $standard_name = main::standardize($name);
6797 || (defined ($table = $table_ref{$addr}{$standard_name})))
6799 Carp::my_carp("Table '$name' in $self is already in use. Using existing one");
6800 $table_ref{$addr}{$name} = $table;
6805 # See if this is a perl extension, if not passed in.
6806 my $perl_extension = delete $args{'Perl_Extension'};
6808 = $self->perl_extension if ! defined $perl_extension;
6810 $table = Match_Table->new(
6812 Perl_Extension => $perl_extension,
6813 _Alias_Hash => $table_ref{$addr},
6816 # gets property's status by default
6817 Status => $self->status,
6818 _Status_Info => $self->status_info,
6820 Internal_Only_Warning => 1); # Override any
6822 return unless defined $table;
6825 # Save the names for quick look up
6826 $table_ref{$addr}{$standard_name} = $table;
6827 $table_ref{$addr}{$name} = $table;
6829 # Perhaps we can figure out the type of this property based on the
6830 # fact of adding this match table. First, string properties don't
6831 # have match tables; second, a binary property can't have 3 match
6833 if ($type{$addr} == $UNKNOWN) {
6834 $type{$addr} = $NON_STRING;
6836 elsif ($type{$addr} == $STRING) {
6837 Carp::my_carp("$self Added a match table '$name' to a string property '$self'. Changed it to a non-string property. Bad News.");
6838 $type{$addr} = $NON_STRING;
6840 elsif ($type{$addr} != $ENUM) {
6841 if (scalar main::uniques(values %{$table_ref{$addr}}) > 2
6842 && $type{$addr} == $BINARY)
6844 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.");
6845 $type{$addr} = $ENUM;
6853 # Return a pointer to the match table (with name given by the
6854 # parameter) associated with this property; undef if none.
6858 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6860 my $addr; { no overloading; $addr = 0+$self; }
6862 return $table_ref{$addr}{$name} if defined $table_ref{$addr}{$name};
6864 # If quick look-up failed, try again using the standard form of the
6865 # input name. If that succeeds, cache the result before returning so
6866 # won't have to standardize this input name again.
6867 my $standard_name = main::standardize($name);
6868 return unless defined $table_ref{$addr}{$standard_name};
6870 $table_ref{$addr}{$name} = $table_ref{$addr}{$standard_name};
6871 return $table_ref{$addr}{$name};
6875 # Return a list of pointers to all the match tables attached to this
6879 return main::uniques(values %{$table_ref{0+shift}});
6883 # Returns the directory the map table for this property should be
6884 # output in. If a specific directory has been specified, that has
6885 # priority; 'undef' is returned if the type isn't defined;
6886 # or $map_directory for everything else.
6888 my $addr; { no overloading; $addr = 0+shift; }
6890 return $directory{$addr} if defined $directory{$addr};
6891 return undef if $type{$addr} == $UNKNOWN;
6892 return $map_directory;
6896 # Return the name that is used to both:
6897 # 1) Name the file that the map table is written to.
6898 # 2) The name of swash related stuff inside that file.
6899 # The reason for this is that the Perl core historically has used
6900 # certain names that aren't the same as the Unicode property names.
6901 # To continue using these, $file is hard-coded in this file for those,
6902 # but otherwise the standard name is used. This is different from the
6903 # external_name, so that the rest of the files, like in lib can use
6904 # the standard name always, without regard to historical precedent.
6907 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6909 my $addr; { no overloading; $addr = 0+$self; }
6911 return $file{$addr} if defined $file{$addr};
6912 return $map{$addr}->external_name;
6915 sub to_create_match_tables {
6916 # Returns a boolean as to whether or not match tables should be
6917 # created for this property.
6920 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6922 # The whole point of this pseudo property is match tables.
6923 return 1 if $self == $perl;
6925 my $addr; { no overloading; $addr = 0+$self; }
6927 # Don't generate tables of code points that match the property values
6928 # of a string property. Such a list would most likely have many
6929 # property values, each with just one or very few code points mapping
6931 return 0 if $type{$addr} == $STRING;
6933 # Don't generate anything for unimplemented properties.
6934 return 0 if grep { $self->complete_name eq $_ }
6935 @unimplemented_properties;
6940 sub property_add_or_replace_non_nulls {
6941 # This adds the mappings in the property $other to $self. Non-null
6942 # mappings from $other override those in $self. It essentially merges
6943 # the two properties, with the second having priority except for null
6948 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6950 if (! $other->isa(__PACKAGE__)) {
6951 Carp::my_carp_bug("$other should be a "
6960 return $map{0+$self}->map_add_or_replace_non_nulls($map{0+$other});
6964 # Set the type of the property. Mostly this is figured out by the
6965 # data in the table. But this is used to set it explicitly. The
6966 # reason it is not a standard accessor is that when setting a binary
6967 # property, we need to make sure that all the true/false aliases are
6968 # present, as they were omitted in early Unicode releases.
6972 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6974 if ($type != $ENUM && $type != $BINARY && $type != $STRING) {
6975 Carp::my_carp("Unrecognized type '$type'. Type not set");
6979 { no overloading; $type{0+$self} = $type; }
6980 return if $type != $BINARY;
6982 my $yes = $self->table('Y');
6983 $yes = $self->table('Yes') if ! defined $yes;
6984 $yes = $self->add_match_table('Y') if ! defined $yes;
6985 $yes->add_alias('Yes');
6986 $yes->add_alias('T');
6987 $yes->add_alias('True');
6989 my $no = $self->table('N');
6990 $no = $self->table('No') if ! defined $no;
6991 $no = $self->add_match_table('N') if ! defined $no;
6992 $no->add_alias('No');
6993 $no->add_alias('F');
6994 $no->add_alias('False');
6999 # Add a map to the property's map table. This also keeps
7000 # track of the maps so that the property type can be determined from
7004 my $start = shift; # First code point in range
7005 my $end = shift; # Final code point in range
7006 my $map = shift; # What the range maps to.
7007 # Rest of parameters passed on.
7009 my $addr; { no overloading; $addr = 0+$self; }
7011 # If haven't the type of the property, gather information to figure it
7013 if ($type{$addr} == $UNKNOWN) {
7015 # If the map contains an interior blank or dash, or most other
7016 # nonword characters, it will be a string property. This
7017 # heuristic may actually miss some string properties. If so, they
7018 # may need to have explicit set_types called for them. This
7019 # happens in the Unihan properties.
7020 if ($map =~ / (?<= . ) [ -] (?= . ) /x
7021 || $map =~ / [^\w.\/\ -] /x)
7023 $self->set_type($STRING);
7025 # $unique_maps is used for disambiguating between ENUM and
7026 # BINARY later; since we know the property is not going to be
7027 # one of those, no point in keeping the data around
7028 undef $unique_maps{$addr};
7032 # Not necessarily a string. The final decision has to be
7033 # deferred until all the data are in. We keep track of if all
7034 # the values are code points for that eventual decision.
7035 $has_only_code_point_maps{$addr} &=
7036 $map =~ / ^ $code_point_re $/x;
7038 # For the purposes of disambiguating between binary and other
7039 # enumerations at the end, we keep track of the first three
7040 # distinct property values. Once we get to three, we know
7041 # it's not going to be binary, so no need to track more.
7042 if (scalar keys %{$unique_maps{$addr}} < 3) {
7043 $unique_maps{$addr}{main::standardize($map)} = 1;
7048 # Add the mapping by calling our map table's method
7049 return $map{$addr}->add_map($start, $end, $map, @_);
7053 # Compute the type of the property: $ENUM, $STRING, or $BINARY. This
7054 # should be called after the property is mostly filled with its maps.
7055 # We have been keeping track of what the property values have been,
7056 # and now have the necessary information to figure out the type.
7059 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7061 my $addr; { no overloading; $addr = 0+$self; }
7063 my $type = $type{$addr};
7065 # If already have figured these out, no need to do so again, but we do
7066 # a double check on ENUMS to make sure that a string property hasn't
7067 # improperly been classified as an ENUM, so continue on with those.
7068 return if $type == $STRING || $type == $BINARY;
7070 # If every map is to a code point, is a string property.
7071 if ($type == $UNKNOWN
7072 && ($has_only_code_point_maps{$addr}
7073 || (defined $map{$addr}->default_map
7074 && $map{$addr}->default_map eq "")))
7076 $self->set_type($STRING);
7080 # Otherwise, it is to some sort of enumeration. (The case where
7081 # it is a Unicode miscellaneous property, and treated like a
7082 # string in this program is handled in add_map()). Distinguish
7083 # between binary and some other enumeration type. Of course, if
7084 # there are more than two values, it's not binary. But more
7085 # subtle is the test that the default mapping is defined means it
7086 # isn't binary. This in fact may change in the future if Unicode
7087 # changes the way its data is structured. But so far, no binary
7088 # properties ever have @missing lines for them, so the default map
7089 # isn't defined for them. The few properties that are two-valued
7090 # and aren't considered binary have the default map defined
7091 # starting in Unicode 5.0, when the @missing lines appeared; and
7092 # this program has special code to put in a default map for them
7093 # for earlier than 5.0 releases.
7095 || scalar keys %{$unique_maps{$addr}} > 2
7096 || defined $self->default_map)
7098 my $tables = $self->tables;
7099 my $count = $self->count;
7100 if ($verbosity && $count > 500 && $tables/$count > .1) {
7101 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");
7103 $self->set_type($ENUM);
7106 $self->set_type($BINARY);
7109 undef $unique_maps{$addr}; # Garbage collect
7113 # Most of the accessors for a property actually apply to its map table.
7114 # Setup up accessor functions for those, referring to %map
7161 # 'property' above is for symmetry, so that one can take
7162 # the property of a property and get itself, and so don't
7163 # have to distinguish between properties and tables in
7171 return $map{0+$self}->$sub(@_);
7181 # Returns lines of the input joined together, so that they can be folded
7183 # This causes continuation lines to be joined together into one long line
7184 # for folding. A continuation line is any line that doesn't begin with a
7185 # space or "\b" (the latter is stripped from the output). This is so
7186 # lines can be be in a HERE document so as to fit nicely in the terminal
7187 # width, but be joined together in one long line, and then folded with
7188 # indents, '#' prefixes, etc, properly handled.
7189 # A blank separates the joined lines except if there is a break; an extra
7190 # blank is inserted after a period ending a line.
7192 # Intialize the return with the first line.
7193 my ($return, @lines) = split "\n", shift;
7195 # If the first line is null, it was an empty line, add the \n back in
7196 $return = "\n" if $return eq "";
7198 # Now join the remainder of the physical lines.
7199 for my $line (@lines) {
7201 # An empty line means wanted a blank line, so add two \n's to get that
7202 # effect, and go to the next line.
7203 if (length $line == 0) {
7208 # Look at the last character of what we have so far.
7209 my $previous_char = substr($return, -1, 1);
7211 # And at the next char to be output.
7212 my $next_char = substr($line, 0, 1);
7214 if ($previous_char ne "\n") {
7216 # Here didn't end wth a nl. If the next char a blank or \b, it
7217 # means that here there is a break anyway. So add a nl to the
7219 if ($next_char eq " " || $next_char eq "\b") {
7220 $previous_char = "\n";
7221 $return .= $previous_char;
7224 # Add an extra space after periods.
7225 $return .= " " if $previous_char eq '.';
7228 # Here $previous_char is still the latest character to be output. If
7229 # it isn't a nl, it means that the next line is to be a continuation
7230 # line, with a blank inserted between them.
7231 $return .= " " if $previous_char ne "\n";
7234 substr($line, 0, 1) = "" if $next_char eq "\b";
7236 # And append this next line.
7243 sub simple_fold($;$$$) {
7244 # Returns a string of the input (string or an array of strings) folded
7245 # into multiple-lines each of no more than $MAX_LINE_WIDTH characters plus
7247 # This is tailored for the kind of text written by this program,
7248 # especially the pod file, which can have very long names with
7249 # underscores in the middle, or words like AbcDefgHij.... We allow
7250 # breaking in the middle of such constructs if the line won't fit
7251 # otherwise. The break in such cases will come either just after an
7252 # underscore, or just before one of the Capital letters.
7254 local $to_trace = 0 if main::DEBUG;
7257 my $prefix = shift; # Optional string to prepend to each output
7259 $prefix = "" unless defined $prefix;
7261 my $hanging_indent = shift; # Optional number of spaces to indent
7262 # continuation lines
7263 $hanging_indent = 0 unless $hanging_indent;
7265 my $right_margin = shift; # Optional number of spaces to narrow the
7267 $right_margin = 0 unless defined $right_margin;
7269 # Call carp with the 'nofold' option to avoid it from trying to call us
7271 Carp::carp_extra_args(\@_, 'nofold') if main::DEBUG && @_;
7273 # The space available doesn't include what's automatically prepended
7274 # to each line, or what's reserved on the right.
7275 my $max = $MAX_LINE_WIDTH - length($prefix) - $right_margin;
7276 # XXX Instead of using the 'nofold' perhaps better to look up the stack
7278 if (DEBUG && $hanging_indent >= $max) {
7279 Carp::my_carp("Too large a hanging indent ($hanging_indent); must be < $max. Using 0", 'nofold');
7280 $hanging_indent = 0;
7283 # First, split into the current physical lines.
7285 if (ref $line) { # Better be an array, because not bothering to
7287 foreach my $line (@{$line}) {
7288 push @line, split /\n/, $line;
7292 @line = split /\n/, $line;
7295 #local $to_trace = 1 if main::DEBUG;
7296 trace "", join(" ", @line), "\n" if main::DEBUG && $to_trace;
7298 # Look at each current physical line.
7299 for (my $i = 0; $i < @line; $i++) {
7300 Carp::my_carp("Tabs don't work well.", 'nofold') if $line[$i] =~ /\t/;
7301 #local $to_trace = 1 if main::DEBUG;
7302 trace "i=$i: $line[$i]\n" if main::DEBUG && $to_trace;
7304 # Remove prefix, because will be added back anyway, don't want
7306 $line[$i] =~ s/^$prefix//;
7308 # Remove trailing space
7309 $line[$i] =~ s/\s+\Z//;
7311 # If the line is too long, fold it.
7312 if (length $line[$i] > $max) {
7315 # Here needs to fold. Save the leading space in the line for
7317 $line[$i] =~ /^ ( \s* )/x;
7318 my $leading_space = $1;
7319 trace "line length", length $line[$i], "; lead length", length($leading_space) if main::DEBUG && $to_trace;
7321 # If character at final permissible position is white space,
7322 # fold there, which will delete that white space
7323 if (substr($line[$i], $max - 1, 1) =~ /\s/) {
7324 $remainder = substr($line[$i], $max);
7325 $line[$i] = substr($line[$i], 0, $max - 1);
7329 # Otherwise fold at an acceptable break char closest to
7330 # the max length. Look at just the maximal initial
7331 # segment of the line
7332 my $segment = substr($line[$i], 0, $max - 1);
7334 /^ ( .{$hanging_indent} # Don't look before the
7336 \ * # Don't look in leading
7337 # blanks past the indent
7338 [^ ] .* # Find the right-most
7339 (?: # acceptable break:
7340 [ \s = ] # space or equal
7341 | - (?! [.0-9] ) # or non-unary minus.
7342 ) # $1 includes the character
7345 # Split into the initial part that fits, and remaining
7347 $remainder = substr($line[$i], length $1);
7349 trace $line[$i] if DEBUG && $to_trace;
7350 trace $remainder if DEBUG && $to_trace;
7353 # If didn't find a good breaking spot, see if there is a
7354 # not-so-good breaking spot. These are just after
7355 # underscores or where the case changes from lower to
7356 # upper. Use \a as a soft hyphen, but give up
7357 # and don't break the line if there is actually a \a
7358 # already in the input. We use an ascii character for the
7359 # soft-hyphen to avoid any attempt by miniperl to try to
7360 # access the files that this program is creating.
7361 elsif ($segment !~ /\a/
7362 && ($segment =~ s/_/_\a/g
7363 || $segment =~ s/ ( [a-z] ) (?= [A-Z] )/$1\a/xg))
7365 # Here were able to find at least one place to insert
7366 # our substitute soft hyphen. Find the right-most one
7367 # and replace it by a real hyphen.
7368 trace $segment if DEBUG && $to_trace;
7370 rindex($segment, "\a"),
7373 # Then remove the soft hyphen substitutes.
7374 $segment =~ s/\a//g;
7375 trace $segment if DEBUG && $to_trace;
7377 # And split into the initial part that fits, and
7378 # remainder of the line
7379 my $pos = rindex($segment, '-');
7380 $remainder = substr($line[$i], $pos);
7381 trace $remainder if DEBUG && $to_trace;
7382 $line[$i] = substr($segment, 0, $pos + 1);
7386 # Here we know if we can fold or not. If we can, $remainder
7387 # is what remains to be processed in the next iteration.
7388 if (defined $remainder) {
7389 trace "folded='$line[$i]'" if main::DEBUG && $to_trace;
7391 # Insert the folded remainder of the line as a new element
7392 # of the array. (It may still be too long, but we will
7393 # deal with that next time through the loop.) Omit any
7394 # leading space in the remainder.
7395 $remainder =~ s/^\s+//;
7396 trace "remainder='$remainder'" if main::DEBUG && $to_trace;
7398 # But then indent by whichever is larger of:
7399 # 1) the leading space on the input line;
7400 # 2) the hanging indent.
7401 # This preserves indentation in the original line.
7402 my $lead = ($leading_space)
7403 ? length $leading_space
7405 $lead = max($lead, $hanging_indent);
7406 splice @line, $i+1, 0, (" " x $lead) . $remainder;
7410 # Ready to output the line. Get rid of any trailing space
7411 # And prefix by the required $prefix passed in.
7412 $line[$i] =~ s/\s+$//;
7413 $line[$i] = "$prefix$line[$i]\n";
7414 } # End of looping through all the lines.
7416 return join "", @line;
7419 sub property_ref { # Returns a reference to a property object.
7420 return Property::property_ref(@_);
7423 sub force_unlink ($) {
7424 my $filename = shift;
7425 return unless file_exists($filename);
7426 return if CORE::unlink($filename);
7428 # We might need write permission
7429 chmod 0777, $filename;
7430 CORE::unlink($filename) or Carp::my_carp("Couldn't unlink $filename. Proceeding anyway: $!");
7435 # Given a filename and a reference to an array of lines, write the lines
7437 # Filename can be given as an arrayref of directory names
7440 my $lines_ref = shift;
7441 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7443 if (! defined $lines_ref) {
7444 Carp::my_carp("Missing lines to write parameter for $file. Writing skipped;");
7448 # Get into a single string if an array, and get rid of, in Unix terms, any
7450 $file= File::Spec->join(@$file) if ref $file eq 'ARRAY';
7451 $file = File::Spec->canonpath($file);
7453 # If has directories, make sure that they all exist
7454 (undef, my $directories, undef) = File::Spec->splitpath($file);
7455 File::Path::mkpath($directories) if $directories && ! -d $directories;
7457 push @files_actually_output, $file;
7461 $text = join "", @$lines_ref;
7465 Carp::my_carp("Output file '$file' is empty; writing it anyway;");
7468 force_unlink ($file);
7471 if (not open $OUT, ">", $file) {
7472 Carp::my_carp("can't open $file for output. Skipping this file: $!");
7475 print "$file written.\n" if $verbosity >= $VERBOSE;
7483 sub Standardize($) {
7484 # This converts the input name string into a standardized equivalent to
7488 unless (defined $name) {
7489 Carp::my_carp_bug("Standardize() called with undef. Returning undef.");
7493 # Remove any leading or trailing white space
7497 # Convert interior white space and hypens into underscores.
7498 $name =~ s/ (?<= .) [ -]+ (.) /_$1/xg;
7500 # Capitalize the letter following an underscore, and convert a sequence of
7501 # multiple underscores to a single one
7502 $name =~ s/ (?<= .) _+ (.) /_\u$1/xg;
7504 # And capitalize the first letter, but not for the special cjk ones.
7505 $name = ucfirst($name) unless $name =~ /^k[A-Z]/;
7509 sub standardize ($) {
7510 # Returns a lower-cased standardized name, without underscores. This form
7511 # is chosen so that it can distinguish between any real versus superficial
7512 # Unicode name differences. It relies on the fact that Unicode doesn't
7513 # have interior underscores, white space, nor dashes in any
7514 # stricter-matched name. It should not be used on Unicode code point
7515 # names (the Name property), as they mostly, but not always follow these
7518 my $name = Standardize(shift);
7519 return if !defined $name;
7521 $name =~ s/ (?<= .) _ (?= . ) //xg;
7527 my $indent_increment = " " x 2;
7530 $main::simple_dumper_nesting = 0;
7533 # Like Simple Data::Dumper. Good enough for our needs. We can't use
7534 # the real thing as we have to run under miniperl.
7536 # It is designed so that on input it is at the beginning of a line,
7537 # and the final thing output in any call is a trailing ",\n".
7541 $indent = "" if ! defined $indent;
7543 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7545 # nesting level is localized, so that as the call stack pops, it goes
7546 # back to the prior value.
7547 local $main::simple_dumper_nesting = $main::simple_dumper_nesting;
7548 undef %already_output if $main::simple_dumper_nesting == 0;
7549 $main::simple_dumper_nesting++;
7550 #print STDERR __LINE__, ": $main::simple_dumper_nesting: $indent$item\n";
7552 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7554 # Determine the indent for recursive calls.
7555 my $next_indent = $indent . $indent_increment;
7560 # Dump of scalar: just output it in quotes if not a number. To do
7561 # so we must escape certain characters, and therefore need to
7562 # operate on a copy to avoid changing the original
7564 $copy = $UNDEF unless defined $copy;
7566 # Quote non-numbers (numbers also have optional leading '-' and
7568 if ($copy eq "" || $copy !~ /^ -? \d+ ( \. \d+ )? $/x) {
7570 # Escape apostrophe and backslash
7571 $copy =~ s/ ( ['\\] ) /\\$1/xg;
7574 $output = "$indent$copy,\n";
7578 # Keep track of cycles in the input, and refuse to infinitely loop
7579 my $addr; { no overloading; $addr = 0+$item; }
7580 if (defined $already_output{$addr}) {
7581 return "${indent}ALREADY OUTPUT: $item\n";
7583 $already_output{$addr} = $item;
7585 if (ref $item eq 'ARRAY') {
7588 if ($main::simple_dumper_nesting > 1) {
7590 $using_brackets = 1;
7593 $using_brackets = 0;
7596 # If the array is empty, put the closing bracket on the same
7597 # line. Otherwise, recursively add each array element
7603 for (my $i = 0; $i < @$item; $i++) {
7605 # Indent array elements one level
7606 $output .= &simple_dumper($item->[$i], $next_indent);
7607 $output =~ s/\n$//; # Remove trailing nl so as to
7608 $output .= " # [$i]\n"; # add a comment giving the
7611 $output .= $indent; # Indent closing ']' to orig level
7613 $output .= ']' if $using_brackets;
7616 elsif (ref $item eq 'HASH') {
7621 # No surrounding braces at top level
7623 if ($main::simple_dumper_nesting > 1) {
7626 $body_indent = $next_indent;
7627 $next_indent .= $indent_increment;
7632 $body_indent = $indent;
7636 # Output hashes sorted alphabetically instead of apparently
7637 # random. Use caseless alphabetic sort
7638 foreach my $key (sort { lc $a cmp lc $b } keys %$item)
7640 if ($is_first_line) {
7644 $output .= "$body_indent";
7647 # The key must be a scalar, but this recursive call quotes
7649 $output .= &simple_dumper($key);
7651 # And change the trailing comma and nl to the hash fat
7652 # comma for clarity, and so the value can be on the same
7654 $output =~ s/,\n$/ => /;
7656 # Recursively call to get the value's dump.
7657 my $next = &simple_dumper($item->{$key}, $next_indent);
7659 # If the value is all on one line, remove its indent, so
7660 # will follow the => immediately. If it takes more than
7661 # one line, start it on a new line.
7662 if ($next !~ /\n.*\n/) {
7671 $output .= "$indent},\n" if $using_braces;
7673 elsif (ref $item eq 'CODE' || ref $item eq 'GLOB') {
7674 $output = $indent . ref($item) . "\n";
7675 # XXX see if blessed
7677 elsif ($item->can('dump')) {
7679 # By convention in this program, objects furnish a 'dump'
7680 # method. Since not doing any output at this level, just pass
7681 # on the input indent
7682 $output = $item->dump($indent);
7685 Carp::my_carp("Can't cope with dumping a " . ref($item) . ". Skipping.");
7692 sub dump_inside_out {
7693 # Dump inside-out hashes in an object's state by converting them to a
7694 # regular hash and then calling simple_dumper on that.
7697 my $fields_ref = shift;
7698 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7700 my $addr; { no overloading; $addr = 0+$object; }
7703 foreach my $key (keys %$fields_ref) {
7704 $hash{$key} = $fields_ref->{$key}{$addr};
7707 return simple_dumper(\%hash, @_);
7711 # Overloaded '.' method that is common to all packages. It uses the
7712 # package's stringify method.
7716 my $reversed = shift;
7717 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7719 $other = "" unless defined $other;
7721 foreach my $which (\$self, \$other) {
7722 next unless ref $$which;
7723 if ($$which->can('_operator_stringify')) {
7724 $$which = $$which->_operator_stringify;
7727 my $ref = ref $$which;
7728 my $addr; { no overloading; $addr = 0+$$which; }
7729 $$which = "$ref ($addr)";
7737 sub _operator_equal {
7738 # Generic overloaded '==' routine. To be equal, they must be the exact
7744 return 0 unless defined $other;
7745 return 0 unless ref $other;
7747 return 0+$self == 0+$other;
7750 sub _operator_not_equal {
7754 return ! _operator_equal($self, $other);
7757 sub process_PropertyAliases($) {
7758 # This reads in the PropertyAliases.txt file, which contains almost all
7759 # the character properties in Unicode and their equivalent aliases:
7760 # scf ; Simple_Case_Folding ; sfc
7762 # Field 0 is the preferred short name for the property.
7763 # Field 1 is the full name.
7764 # Any succeeding ones are other accepted names.
7767 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7769 # This whole file was non-existent in early releases, so use our own
7771 $file->insert_lines(get_old_property_aliases())
7772 if ! -e 'PropertyAliases.txt';
7774 # Add any cjk properties that may have been defined.
7775 $file->insert_lines(@cjk_properties);
7777 while ($file->next_line) {
7779 my @data = split /\s*;\s*/;
7781 my $full = $data[1];
7783 my $this = Property->new($data[0], Full_Name => $full);
7785 # Start looking for more aliases after these two.
7786 for my $i (2 .. @data - 1) {
7787 $this->add_alias($data[$i]);
7794 sub finish_property_setup {
7795 # Finishes setting up after PropertyAliases.
7798 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7800 # This entry was missing from this file in earlier Unicode versions
7801 if (-e 'Jamo.txt') {
7802 my $jsn = property_ref('JSN');
7803 if (! defined $jsn) {
7804 $jsn = Property->new('JSN', Full_Name => 'Jamo_Short_Name');
7808 # This entry is still missing as of 5.2, perhaps because no short name for
7810 if (-e 'NameAliases.txt') {
7811 my $aliases = property_ref('Name_Alias');
7812 if (! defined $aliases) {
7813 $aliases = Property->new('Name_Alias');
7817 # These are used so much, that we set globals for them.
7818 $gc = property_ref('General_Category');
7819 $block = property_ref('Block');
7821 # Perl adds this alias.
7822 $gc->add_alias('Category');
7824 # For backwards compatibility, these property files have particular names.
7825 my $upper = property_ref('Uppercase_Mapping');
7826 $upper->set_core_access('uc()');
7827 $upper->set_file('Upper'); # This is what utf8.c calls it
7829 my $lower = property_ref('Lowercase_Mapping');
7830 $lower->set_core_access('lc()');
7831 $lower->set_file('Lower');
7833 my $title = property_ref('Titlecase_Mapping');
7834 $title->set_core_access('ucfirst()');
7835 $title->set_file('Title');
7837 my $fold = property_ref('Case_Folding');
7838 $fold->set_file('Fold') if defined $fold;
7840 # utf8.c can't currently cope with non range-size-1 for these, and even if
7841 # it were changed to do so, someone else may be using them, expecting the
7843 foreach my $property (qw {
7850 property_ref($property)->set_range_size_1(1);
7853 # These two properties aren't actually used in the core, but unfortunately
7854 # the names just above that are in the core interfere with these, so
7855 # choose different names. These aren't a problem unless the map tables
7856 # for these files get written out.
7857 my $lowercase = property_ref('Lowercase');
7858 $lowercase->set_file('IsLower') if defined $lowercase;
7859 my $uppercase = property_ref('Uppercase');
7860 $uppercase->set_file('IsUpper') if defined $uppercase;
7862 # Set up the hard-coded default mappings, but only on properties defined
7864 foreach my $property (keys %default_mapping) {
7865 my $property_object = property_ref($property);
7866 next if ! defined $property_object;
7867 my $default_map = $default_mapping{$property};
7868 $property_object->set_default_map($default_map);
7870 # A map of <code point> implies the property is string.
7871 if ($property_object->type == $UNKNOWN
7872 && $default_map eq $CODE_POINT)
7874 $property_object->set_type($STRING);
7878 # The following use the Multi_Default class to create objects for
7881 # Bidi class has a complicated default, but the derived file takes care of
7882 # the complications, leaving just 'L'.
7883 if (file_exists("${EXTRACTED}DBidiClass.txt")) {
7884 property_ref('Bidi_Class')->set_default_map('L');
7889 # The derived file was introduced in 3.1.1. The values below are
7890 # taken from table 3-8, TUS 3.0
7892 'my $default = Range_List->new;
7893 $default->add_range(0x0590, 0x05FF);
7894 $default->add_range(0xFB1D, 0xFB4F);'
7897 # The defaults apply only to unassigned characters
7898 $default_R .= '$gc->table("Cn") & $default;';
7900 if ($v_version lt v3.0.0) {
7901 $default = Multi_Default->new(R => $default_R, 'L');
7905 # AL apparently not introduced until 3.0: TUS 2.x references are
7906 # not on-line to check it out
7908 'my $default = Range_List->new;
7909 $default->add_range(0x0600, 0x07BF);
7910 $default->add_range(0xFB50, 0xFDFF);
7911 $default->add_range(0xFE70, 0xFEFF);'
7914 # Non-character code points introduced in this release; aren't AL
7915 if ($v_version ge 3.1.0) {
7916 $default_AL .= '$default->delete_range(0xFDD0, 0xFDEF);';
7918 $default_AL .= '$gc->table("Cn") & $default';
7919 $default = Multi_Default->new(AL => $default_AL,
7923 property_ref('Bidi_Class')->set_default_map($default);
7926 # Joining type has a complicated default, but the derived file takes care
7927 # of the complications, leaving just 'U' (or Non_Joining), except the file
7929 if (file_exists("${EXTRACTED}DJoinType.txt") || -e 'ArabicShaping.txt') {
7930 if (file_exists("${EXTRACTED}DJoinType.txt") && $v_version ne 3.1.0) {
7931 property_ref('Joining_Type')->set_default_map('Non_Joining');
7935 # Otherwise, there are not one, but two possibilities for the
7936 # missing defaults: T and U.
7937 # The missing defaults that evaluate to T are given by:
7938 # T = Mn + Cf - ZWNJ - ZWJ
7939 # where Mn and Cf are the general category values. In other words,
7940 # any non-spacing mark or any format control character, except
7941 # U+200C ZERO WIDTH NON-JOINER (joining type U) and U+200D ZERO
7942 # WIDTH JOINER (joining type C).
7943 my $default = Multi_Default->new(
7944 'T' => '$gc->table("Mn") + $gc->table("Cf") - 0x200C - 0x200D',
7946 property_ref('Joining_Type')->set_default_map($default);
7950 # Line break has a complicated default in early releases. It is 'Unknown'
7951 # for non-assigned code points; 'AL' for assigned.
7952 if (file_exists("${EXTRACTED}DLineBreak.txt") || -e 'LineBreak.txt') {
7953 my $lb = property_ref('Line_Break');
7954 if ($v_version gt 3.2.0) {
7955 $lb->set_default_map('Unknown');
7958 my $default = Multi_Default->new( 'Unknown' => '$gc->table("Cn")',
7960 $lb->set_default_map($default);
7963 # If has the URS property, make sure that the standard aliases are in
7964 # it, since not in the input tables in some versions.
7965 my $urs = property_ref('Unicode_Radical_Stroke');
7967 $urs->add_alias('cjkRSUnicode');
7968 $urs->add_alias('kRSUnicode');
7974 sub get_old_property_aliases() {
7975 # Returns what would be in PropertyAliases.txt if it existed in very old
7976 # versions of Unicode. It was derived from the one in 3.2, and pared
7977 # down based on the data that was actually in the older releases.
7978 # An attempt was made to use the existence of files to mean inclusion or
7979 # not of various aliases, but if this was not sufficient, using version
7980 # numbers was resorted to.
7984 # These are to be used in all versions (though some are constructed by
7985 # this program if missing)
7986 push @return, split /\n/, <<'END';
7988 Bidi_M ; Bidi_Mirrored
7990 ccc ; Canonical_Combining_Class
7991 dm ; Decomposition_Mapping
7992 dt ; Decomposition_Type
7993 gc ; General_Category
7995 lc ; Lowercase_Mapping
7997 na1 ; Unicode_1_Name
8000 sfc ; Simple_Case_Folding
8001 slc ; Simple_Lowercase_Mapping
8002 stc ; Simple_Titlecase_Mapping
8003 suc ; Simple_Uppercase_Mapping
8004 tc ; Titlecase_Mapping
8005 uc ; Uppercase_Mapping
8008 if (-e 'Blocks.txt') {
8009 push @return, "blk ; Block\n";
8011 if (-e 'ArabicShaping.txt') {
8012 push @return, split /\n/, <<'END';
8017 if (-e 'PropList.txt') {
8019 # This first set is in the original old-style proplist.
8020 push @return, split /\n/, <<'END';
8022 Bidi_C ; Bidi_Control
8030 Join_C ; Join_Control
8032 QMark ; Quotation_Mark
8033 Term ; Terminal_Punctuation
8034 WSpace ; White_Space
8036 # The next sets were added later
8037 if ($v_version ge v3.0.0) {
8038 push @return, split /\n/, <<'END';
8043 if ($v_version ge v3.0.1) {
8044 push @return, split /\n/, <<'END';
8045 NChar ; Noncharacter_Code_Point
8048 # The next sets were added in the new-style
8049 if ($v_version ge v3.1.0) {
8050 push @return, split /\n/, <<'END';
8051 OAlpha ; Other_Alphabetic
8052 OLower ; Other_Lowercase
8054 OUpper ; Other_Uppercase
8057 if ($v_version ge v3.1.1) {
8058 push @return, "AHex ; ASCII_Hex_Digit\n";
8061 if (-e 'EastAsianWidth.txt') {
8062 push @return, "ea ; East_Asian_Width\n";
8064 if (-e 'CompositionExclusions.txt') {
8065 push @return, "CE ; Composition_Exclusion\n";
8067 if (-e 'LineBreak.txt') {
8068 push @return, "lb ; Line_Break\n";
8070 if (-e 'BidiMirroring.txt') {
8071 push @return, "bmg ; Bidi_Mirroring_Glyph\n";
8073 if (-e 'Scripts.txt') {
8074 push @return, "sc ; Script\n";
8076 if (-e 'DNormalizationProps.txt') {
8077 push @return, split /\n/, <<'END';
8078 Comp_Ex ; Full_Composition_Exclusion
8079 FC_NFKC ; FC_NFKC_Closure
8080 NFC_QC ; NFC_Quick_Check
8081 NFD_QC ; NFD_Quick_Check
8082 NFKC_QC ; NFKC_Quick_Check
8083 NFKD_QC ; NFKD_Quick_Check
8084 XO_NFC ; Expands_On_NFC
8085 XO_NFD ; Expands_On_NFD
8086 XO_NFKC ; Expands_On_NFKC
8087 XO_NFKD ; Expands_On_NFKD
8090 if (-e 'DCoreProperties.txt') {
8091 push @return, split /\n/, <<'END';
8096 # These can also appear in some versions of PropList.txt
8097 push @return, "Lower ; Lowercase\n"
8098 unless grep { $_ =~ /^Lower\b/} @return;
8099 push @return, "Upper ; Uppercase\n"
8100 unless grep { $_ =~ /^Upper\b/} @return;
8103 # This flag requires the DAge.txt file to be copied into the directory.
8104 if (DEBUG && $compare_versions) {
8105 push @return, 'age ; Age';
8111 sub process_PropValueAliases {
8112 # This file contains values that properties look like:
8113 # bc ; AL ; Arabic_Letter
8114 # blk; n/a ; Greek_And_Coptic ; Greek
8116 # Field 0 is the property.
8117 # Field 1 is the short name of a property value or 'n/a' if no
8118 # short name exists;
8119 # Field 2 is the full property value name;
8120 # Any other fields are more synonyms for the property value.
8121 # Purely numeric property values are omitted from the file; as are some
8122 # others, fewer and fewer in later releases
8124 # Entries for the ccc property have an extra field before the
8126 # ccc; 0; NR ; Not_Reordered
8127 # It is the numeric value that the names are synonyms for.
8129 # There are comment entries for values missing from this file:
8130 # # @missing: 0000..10FFFF; ISO_Comment; <none>
8131 # # @missing: 0000..10FFFF; Lowercase_Mapping; <code point>
8134 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8136 # This whole file was non-existent in early releases, so use our own
8137 # internal one if necessary.
8138 if (! -e 'PropValueAliases.txt') {
8139 $file->insert_lines(get_old_property_value_aliases());
8142 # Add any explicit cjk values
8143 $file->insert_lines(@cjk_property_values);
8145 # This line is used only for testing the code that checks for name
8146 # conflicts. There is a script Inherited, and when this line is executed
8147 # it causes there to be a name conflict with the 'Inherited' that this
8148 # program generates for this block property value
8149 #$file->insert_lines('blk; n/a; Herited');
8152 # Process each line of the file ...
8153 while ($file->next_line) {
8155 my ($property, @data) = split /\s*;\s*/;
8157 # The full name for the ccc property value is in field 2 of the
8158 # remaining ones; field 1 for all other properties. Swap ccc fields 1
8159 # and 2. (Rightmost splice removes field 2, returning it; left splice
8160 # inserts that into field 1, thus shifting former field 1 to field 2.)
8161 splice (@data, 1, 0, splice(@data, 2, 1)) if $property eq 'ccc';
8163 # If there is no short name, use the full one in element 1
8164 $data[0] = $data[1] if $data[0] eq "n/a";
8166 # Earlier releases had the pseudo property 'qc' that should expand to
8167 # the ones that replace it below.
8168 if ($property eq 'qc') {
8169 if (lc $data[0] eq 'y') {
8170 $file->insert_lines('NFC_QC; Y ; Yes',
8176 elsif (lc $data[0] eq 'n') {
8177 $file->insert_lines('NFC_QC; N ; No',
8183 elsif (lc $data[0] eq 'm') {
8184 $file->insert_lines('NFC_QC; M ; Maybe',
8185 'NFKC_QC; M ; Maybe',
8189 $file->carp_bad_line("qc followed by unexpected '$data[0]");
8194 # The first field is the short name, 2nd is the full one.
8195 my $property_object = property_ref($property);
8196 my $table = $property_object->add_match_table($data[0],
8197 Full_Name => $data[1]);
8199 # Start looking for more aliases after these two.
8200 for my $i (2 .. @data - 1) {
8201 $table->add_alias($data[$i]);
8203 } # End of looping through the file
8205 # As noted in the comments early in the program, it generates tables for
8206 # the default values for all releases, even those for which the concept
8207 # didn't exist at the time. Here we add those if missing.
8208 my $age = property_ref('age');
8209 if (defined $age && ! defined $age->table('Unassigned')) {
8210 $age->add_match_table('Unassigned');
8212 $block->add_match_table('No_Block') if -e 'Blocks.txt'
8213 && ! defined $block->table('No_Block');
8216 # Now set the default mappings of the properties from the file. This is
8217 # done after the loop because a number of properties have only @missings
8218 # entries in the file, and may not show up until the end.
8219 my @defaults = $file->get_missings;
8220 foreach my $default_ref (@defaults) {
8221 my $default = $default_ref->[0];
8222 my $property = property_ref($default_ref->[1]);
8223 $property->set_default_map($default);
8228 sub get_old_property_value_aliases () {
8229 # Returns what would be in PropValueAliases.txt if it existed in very old
8230 # versions of Unicode. It was derived from the one in 3.2, and pared
8231 # down. An attempt was made to use the existence of files to mean
8232 # inclusion or not of various aliases, but if this was not sufficient,
8233 # using version numbers was resorted to.
8235 my @return = split /\n/, <<'END';
8236 bc ; AN ; Arabic_Number
8237 bc ; B ; Paragraph_Separator
8238 bc ; CS ; Common_Separator
8239 bc ; EN ; European_Number
8240 bc ; ES ; European_Separator
8241 bc ; ET ; European_Terminator
8242 bc ; L ; Left_To_Right
8243 bc ; ON ; Other_Neutral
8244 bc ; R ; Right_To_Left
8245 bc ; WS ; White_Space
8247 # The standard combining classes are very much different in v1, so only use
8248 # ones that look right (not checked thoroughly)
8249 ccc; 0; NR ; Not_Reordered
8250 ccc; 1; OV ; Overlay
8252 ccc; 8; KV ; Kana_Voicing
8254 ccc; 202; ATBL ; Attached_Below_Left
8255 ccc; 216; ATAR ; Attached_Above_Right
8256 ccc; 218; BL ; Below_Left
8258 ccc; 222; BR ; Below_Right
8260 ccc; 228; AL ; Above_Left
8262 ccc; 232; AR ; Above_Right
8263 ccc; 234; DA ; Double_Above
8265 dt ; can ; canonical
8279 gc ; C ; Other # Cc | Cf | Cn | Co | Cs
8281 gc ; Cn ; Unassigned
8282 gc ; Co ; Private_Use
8283 gc ; L ; Letter # Ll | Lm | Lo | Lt | Lu
8284 gc ; LC ; Cased_Letter # Ll | Lt | Lu
8285 gc ; Ll ; Lowercase_Letter
8286 gc ; Lm ; Modifier_Letter
8287 gc ; Lo ; Other_Letter
8288 gc ; Lu ; Uppercase_Letter
8289 gc ; M ; Mark # Mc | Me | Mn
8290 gc ; Mc ; Spacing_Mark
8291 gc ; Mn ; Nonspacing_Mark
8292 gc ; N ; Number # Nd | Nl | No
8293 gc ; Nd ; Decimal_Number
8294 gc ; No ; Other_Number
8295 gc ; P ; Punctuation # Pc | Pd | Pe | Pf | Pi | Po | Ps
8296 gc ; Pd ; Dash_Punctuation
8297 gc ; Pe ; Close_Punctuation
8298 gc ; Po ; Other_Punctuation
8299 gc ; Ps ; Open_Punctuation
8300 gc ; S ; Symbol # Sc | Sk | Sm | So
8301 gc ; Sc ; Currency_Symbol
8302 gc ; Sm ; Math_Symbol
8303 gc ; So ; Other_Symbol
8304 gc ; Z ; Separator # Zl | Zp | Zs
8305 gc ; Zl ; Line_Separator
8306 gc ; Zp ; Paragraph_Separator
8307 gc ; Zs ; Space_Separator
8315 if (-e 'ArabicShaping.txt') {
8316 push @return, split /\n/, <<'END';
8323 jg ; n/a ; NO_JOINING_GROUP
8331 jt ; C ; Join_Causing
8332 jt ; D ; Dual_Joining
8333 jt ; L ; Left_Joining
8334 jt ; R ; Right_Joining
8335 jt ; U ; Non_Joining
8336 jt ; T ; Transparent
8338 if ($v_version ge v3.0.0) {
8339 push @return, split /\n/, <<'END';
8343 jg ; n/a ; DALATH_RISH
8346 jg ; n/a ; FINAL_SEMKATH
8349 jg ; n/a ; HAMZA_ON_HEH_GOAL
8356 jg ; n/a ; KNOTTED_HEH
8363 jg ; n/a ; REVERSED_PE
8367 jg ; n/a ; SWASH_KAF
8369 jg ; n/a ; TEH_MARBUTA
8372 jg ; n/a ; YEH_BARREE
8373 jg ; n/a ; YEH_WITH_TAIL
8382 if (-e 'EastAsianWidth.txt') {
8383 push @return, split /\n/, <<'END';
8393 if (-e 'LineBreak.txt') {
8394 push @return, split /\n/, <<'END';
8396 lb ; AL ; Alphabetic
8397 lb ; B2 ; Break_Both
8398 lb ; BA ; Break_After
8399 lb ; BB ; Break_Before
8400 lb ; BK ; Mandatory_Break
8401 lb ; CB ; Contingent_Break
8402 lb ; CL ; Close_Punctuation
8403 lb ; CM ; Combining_Mark
8404 lb ; CR ; Carriage_Return
8405 lb ; EX ; Exclamation
8408 lb ; ID ; Ideographic
8409 lb ; IN ; Inseperable
8410 lb ; IS ; Infix_Numeric
8412 lb ; NS ; Nonstarter
8414 lb ; OP ; Open_Punctuation
8415 lb ; PO ; Postfix_Numeric
8416 lb ; PR ; Prefix_Numeric
8418 lb ; SA ; Complex_Context
8421 lb ; SY ; Break_Symbols
8427 if (-e 'DNormalizationProps.txt') {
8428 push @return, split /\n/, <<'END';
8435 if (-e 'Scripts.txt') {
8436 push @return, split /\n/, <<'END';
8438 sc ; Armn ; Armenian
8440 sc ; Bopo ; Bopomofo
8441 sc ; Cans ; Canadian_Aboriginal
8442 sc ; Cher ; Cherokee
8443 sc ; Cyrl ; Cyrillic
8444 sc ; Deva ; Devanagari
8446 sc ; Ethi ; Ethiopic
8447 sc ; Geor ; Georgian
8450 sc ; Gujr ; Gujarati
8451 sc ; Guru ; Gurmukhi
8455 sc ; Hira ; Hiragana
8456 sc ; Ital ; Old_Italic
8457 sc ; Kana ; Katakana
8462 sc ; Mlym ; Malayalam
8463 sc ; Mong ; Mongolian
8467 sc ; Qaai ; Inherited
8481 if ($v_version ge v2.0.0) {
8482 push @return, split /\n/, <<'END';
8486 dt ; vert ; vertical
8491 gc ; Lt ; Titlecase_Letter
8492 gc ; Me ; Enclosing_Mark
8493 gc ; Nl ; Letter_Number
8494 gc ; Pc ; Connector_Punctuation
8495 gc ; Sk ; Modifier_Symbol
8498 if ($v_version ge v2.1.2) {
8499 push @return, "bc ; S ; Segment_Separator\n";
8501 if ($v_version ge v2.1.5) {
8502 push @return, split /\n/, <<'END';
8503 gc ; Pf ; Final_Punctuation
8504 gc ; Pi ; Initial_Punctuation
8507 if ($v_version ge v2.1.8) {
8508 push @return, "ccc; 240; IS ; Iota_Subscript\n";
8511 if ($v_version ge v3.0.0) {
8512 push @return, split /\n/, <<'END';
8513 bc ; AL ; Arabic_Letter
8514 bc ; BN ; Boundary_Neutral
8515 bc ; LRE ; Left_To_Right_Embedding
8516 bc ; LRO ; Left_To_Right_Override
8517 bc ; NSM ; Nonspacing_Mark
8518 bc ; PDF ; Pop_Directional_Format
8519 bc ; RLE ; Right_To_Left_Embedding
8520 bc ; RLO ; Right_To_Left_Override
8522 ccc; 233; DB ; Double_Below
8526 if ($v_version ge v3.1.0) {
8527 push @return, "ccc; 226; R ; Right\n";
8534 # This is used to store the range list of all the code points usable when
8535 # the little used $compare_versions feature is enabled.
8536 my $compare_versions_range_list;
8538 sub process_generic_property_file {
8539 # This processes a file containing property mappings and puts them
8540 # into internal map tables. It should be used to handle any property
8541 # files that have mappings from a code point or range thereof to
8542 # something else. This means almost all the UCD .txt files.
8543 # each_line_handlers() should be set to adjust the lines of these
8544 # files, if necessary, to what this routine understands:
8549 # the fields are: "codepoint range ; property; map"
8551 # meaning the codepoints in the range all have the value 'map' under
8553 # Beginning and trailing white space in each field are not signficant.
8554 # Note there is not a trailing semi-colon in the above. A trailing
8555 # semi-colon means the map is a null-string. An omitted map, as
8556 # opposed to a null-string, is assumed to be 'Y', based on Unicode
8557 # table syntax. (This could have been hidden from this routine by
8558 # doing it in the $file object, but that would require parsing of the
8559 # line there, so would have to parse it twice, or change the interface
8560 # to pass this an array. So not done.)
8562 # The map field may begin with a sequence of commands that apply to
8563 # this range. Each such command begins and ends with $CMD_DELIM.
8564 # These are used to indicate, for example, that the mapping for a
8565 # range has a non-default type.
8567 # This loops through the file, calling it's next_line() method, and
8568 # then taking the map and adding it to the property's table.
8569 # Complications arise because any number of properties can be in the
8570 # file, in any order, interspersed in any way. The first time a
8571 # property is seen, it gets information about that property and
8572 # caches it for quick retrieval later. It also normalizes the maps
8573 # so that only one of many synonym is stored. The Unicode input files
8574 # do use some multiple synonyms.
8577 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8579 my %property_info; # To keep track of what properties
8580 # have already had entries in the
8581 # current file, and info about each,
8582 # so don't have to recompute.
8583 my $property_name; # property currently being worked on
8584 my $property_type; # and its type
8585 my $previous_property_name = ""; # name from last time through loop
8586 my $property_object; # pointer to the current property's
8588 my $property_addr; # the address of that object
8589 my $default_map; # the string that code points missing
8590 # from the file map to
8591 my $default_table; # For non-string properties, a
8592 # reference to the match table that
8593 # will contain the list of code
8594 # points that map to $default_map.
8596 # Get the next real non-comment line
8598 while ($file->next_line) {
8600 # Default replacement type; means that if parts of the range have
8601 # already been stored in our tables, the new map overrides them if
8602 # they differ more than cosmetically
8603 my $replace = $IF_NOT_EQUIVALENT;
8604 my $map_type; # Default type for the map of this range
8606 #local $to_trace = 1 if main::DEBUG;
8607 trace $_ if main::DEBUG && $to_trace;
8609 # Split the line into components
8610 my ($range, $property_name, $map, @remainder)
8611 = split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields
8613 # If more or less on the line than we are expecting, warn and skip
8616 $file->carp_bad_line('Extra fields');
8619 elsif ( ! defined $property_name) {
8620 $file->carp_bad_line('Missing property');
8624 # Examine the range.
8625 if ($range !~ /^ ($code_point_re) (?:\.\. ($code_point_re) )? $/x)
8627 $file->carp_bad_line("Range '$range' not of the form 'CP1' or 'CP1..CP2' (where CP1,2 are code points in hex)");
8631 my $high = (defined $2) ? hex $2 : $low;
8633 # For the very specialized case of comparing two Unicode
8635 if (DEBUG && $compare_versions) {
8636 if ($property_name eq 'Age') {
8638 # Only allow code points at least as old as the version
8640 my $age = pack "C*", split(/\./, $map); # v string
8641 next LINE if $age gt $compare_versions;
8645 # Again, we throw out code points younger than those of
8646 # the specified version. By now, the Age property is
8647 # populated. We use the intersection of each input range
8648 # with this property to find what code points in it are
8649 # valid. To do the intersection, we have to convert the
8650 # Age property map to a Range_list. We only have to do
8652 if (! defined $compare_versions_range_list) {
8653 my $age = property_ref('Age');
8654 if (! -e 'DAge.txt') {
8655 croak "Need to have 'DAge.txt' file to do version comparison";
8657 elsif ($age->count == 0) {
8658 croak "The 'Age' table is empty, but its file exists";
8660 $compare_versions_range_list
8661 = Range_List->new(Initialize => $age);
8664 # An undefined map is always 'Y'
8665 $map = 'Y' if ! defined $map;
8667 # Calculate the intersection of the input range with the
8668 # code points that are known in the specified version
8669 my @ranges = ($compare_versions_range_list
8670 & Range->new($low, $high))->ranges;
8672 # If the intersection is empty, throw away this range
8673 next LINE unless @ranges;
8675 # Only examine the first range this time through the loop.
8676 my $this_range = shift @ranges;
8678 # Put any remaining ranges in the queue to be processed
8679 # later. Note that there is unnecessary work here, as we
8680 # will do the intersection again for each of these ranges
8681 # during some future iteration of the LINE loop, but this
8682 # code is not used in production. The later intersections
8683 # are guaranteed to not splinter, so this will not become
8685 my $line = join ';', $property_name, $map;
8686 foreach my $range (@ranges) {
8687 $file->insert_adjusted_lines(sprintf("%04X..%04X; %s",
8693 # And process the first range, like any other.
8694 $low = $this_range->start;
8695 $high = $this_range->end;
8697 } # End of $compare_versions
8699 # If changing to a new property, get the things constant per
8701 if ($previous_property_name ne $property_name) {
8703 $property_object = property_ref($property_name);
8704 if (! defined $property_object) {
8705 $file->carp_bad_line("Unexpected property '$property_name'. Skipped");
8708 { no overloading; $property_addr = 0+($property_object); }
8710 # Defer changing names until have a line that is acceptable
8711 # (the 'next' statement above means is unacceptable)
8712 $previous_property_name = $property_name;
8714 # If not the first time for this property, retrieve info about
8716 if (defined ($property_info{$property_addr}{'type'})) {
8717 $property_type = $property_info{$property_addr}{'type'};
8718 $default_map = $property_info{$property_addr}{'default'};
8720 = $property_info{$property_addr}{'pseudo_map_type'};
8722 = $property_info{$property_addr}{'default_table'};
8726 # Here, is the first time for this property. Set up the
8728 $property_type = $property_info{$property_addr}{'type'}
8729 = $property_object->type;
8731 = $property_info{$property_addr}{'pseudo_map_type'}
8732 = $property_object->pseudo_map_type;
8734 # The Unicode files are set up so that if the map is not
8735 # defined, it is a binary property
8736 if (! defined $map && $property_type != $BINARY) {
8737 if ($property_type != $UNKNOWN
8738 && $property_type != $NON_STRING)
8740 $file->carp_bad_line("No mapping defined on a non-binary property. Using 'Y' for the map");
8743 $property_object->set_type($BINARY);
8745 = $property_info{$property_addr}{'type'}
8750 # Get any @missings default for this property. This
8751 # should precede the first entry for the property in the
8752 # input file, and is located in a comment that has been
8753 # stored by the Input_file class until we access it here.
8754 # It's possible that there is more than one such line
8755 # waiting for us; collect them all, and parse
8756 my @missings_list = $file->get_missings
8757 if $file->has_missings_defaults;
8758 foreach my $default_ref (@missings_list) {
8759 my $default = $default_ref->[0];
8760 my $addr; { no overloading; $addr = 0+property_ref($default_ref->[1]); }
8762 # For string properties, the default is just what the
8763 # file says, but non-string properties should already
8764 # have set up a table for the default property value;
8765 # use the table for these, so can resolve synonyms
8766 # later to a single standard one.
8767 if ($property_type == $STRING
8768 || $property_type == $UNKNOWN)
8770 $property_info{$addr}{'missings'} = $default;
8773 $property_info{$addr}{'missings'}
8774 = $property_object->table($default);
8778 # Finished storing all the @missings defaults in the input
8779 # file so far. Get the one for the current property.
8780 my $missings = $property_info{$property_addr}{'missings'};
8782 # But we likely have separately stored what the default
8783 # should be. (This is to accommodate versions of the
8784 # standard where the @missings lines are absent or
8785 # incomplete.) Hopefully the two will match. But check
8787 $default_map = $property_object->default_map;
8789 # If the map is a ref, it means that the default won't be
8790 # processed until later, so undef it, so next few lines
8791 # will redefine it to something that nothing will match
8792 undef $default_map if ref $default_map;
8794 # Create a $default_map if don't have one; maybe a dummy
8795 # that won't match anything.
8796 if (! defined $default_map) {
8798 # Use any @missings line in the file.
8799 if (defined $missings) {
8800 if (ref $missings) {
8801 $default_map = $missings->full_name;
8802 $default_table = $missings;
8805 $default_map = $missings;
8808 # And store it with the property for outside use.
8809 $property_object->set_default_map($default_map);
8813 # Neither an @missings nor a default map. Create
8814 # a dummy one, so won't have to test definedness
8816 $default_map = '_Perl This will never be in a file
8821 # Here, we have $default_map defined, possibly in terms of
8822 # $missings, but maybe not, and possibly is a dummy one.
8823 if (defined $missings) {
8825 # Make sure there is no conflict between the two.
8826 # $missings has priority.
8827 if (ref $missings) {
8829 = $property_object->table($default_map);
8830 if (! defined $default_table
8831 || $default_table != $missings)
8833 if (! defined $default_table) {
8834 $default_table = $UNDEF;
8836 $file->carp_bad_line(<<END
8837 The \@missings line for $property_name in $file says that missings default to
8838 $missings, but we expect it to be $default_table. $missings used.
8841 $default_table = $missings;
8842 $default_map = $missings->full_name;
8844 $property_info{$property_addr}{'default_table'}
8847 elsif ($default_map ne $missings) {
8848 $file->carp_bad_line(<<END
8849 The \@missings line for $property_name in $file says that missings default to
8850 $missings, but we expect it to be $default_map. $missings used.
8853 $default_map = $missings;
8857 $property_info{$property_addr}{'default'}
8860 # If haven't done so already, find the table corresponding
8861 # to this map for non-string properties.
8862 if (! defined $default_table
8863 && $property_type != $STRING
8864 && $property_type != $UNKNOWN)
8866 $default_table = $property_info{$property_addr}
8868 = $property_object->table($default_map);
8870 } # End of is first time for this property
8871 } # End of switching properties.
8873 # Ready to process the line.
8874 # The Unicode files are set up so that if the map is not defined,
8875 # it is a binary property with value 'Y'
8876 if (! defined $map) {
8881 # If the map begins with a special command to us (enclosed in
8882 # delimiters), extract the command(s).
8883 if (substr($map, 0, 1) eq $CMD_DELIM) {
8884 while ($map =~ s/ ^ $CMD_DELIM (.*?) $CMD_DELIM //x) {
8886 if ($command =~ / ^ $REPLACE_CMD= (.*) /x) {
8889 elsif ($command =~ / ^ $MAP_TYPE_CMD= (.*) /x) {
8893 $file->carp_bad_line("Unknown command line: '$1'");
8900 if ($default_map eq $CODE_POINT && $map =~ / ^ $code_point_re $/x)
8903 # Here, we have a map to a particular code point, and the
8904 # default map is to a code point itself. If the range
8905 # includes the particular code point, change that portion of
8906 # the range to the default. This makes sure that in the final
8907 # table only the non-defaults are listed.
8908 my $decimal_map = hex $map;
8909 if ($low <= $decimal_map && $decimal_map <= $high) {
8911 # If the range includes stuff before or after the map
8912 # we're changing, split it and process the split-off parts
8914 if ($low < $decimal_map) {
8915 $file->insert_adjusted_lines(
8916 sprintf("%04X..%04X; %s; %s",
8922 if ($high > $decimal_map) {
8923 $file->insert_adjusted_lines(
8924 sprintf("%04X..%04X; %s; %s",
8930 $low = $high = $decimal_map;
8935 # If we can tell that this is a synonym for the default map, use
8936 # the default one instead.
8937 if ($property_type != $STRING
8938 && $property_type != $UNKNOWN)
8940 my $table = $property_object->table($map);
8941 if (defined $table && $table == $default_table) {
8942 $map = $default_map;
8946 # And figure out the map type if not known.
8947 if (! defined $map_type || $map_type == $COMPUTE_NO_MULTI_CP) {
8948 if ($map eq "") { # Nulls are always $NULL map type
8950 } # Otherwise, non-strings, and those that don't allow
8951 # $MULTI_CP, and those that aren't multiple code points are
8954 (($property_type != $STRING && $property_type != $UNKNOWN)
8955 || (defined $map_type && $map_type == $COMPUTE_NO_MULTI_CP)
8956 || $map !~ /^ $code_point_re ( \ $code_point_re )+ $ /x)
8961 $map_type = $MULTI_CP;
8965 $property_object->add_map($low, $high,
8968 Replace => $replace);
8969 } # End of loop through file's lines
8975 # XXX Unused until revise charnames;
8976 #sub check_and_handle_compound_name {
8977 # This looks at Name properties for parenthesized components and splits
8978 # them off. Thus it finds FF as an equivalent to Form Feed.
8979 # my $code_point = shift;
8981 # if ($name =~ /^ ( .*? ) ( \s* ) \( ( [^)]* ) \) (.*) $/x) {
8982 # #local $to_trace = 1 if main::DEBUG;
8983 # trace $1, $2, $3, $4 if main::DEBUG && $to_trace;
8984 # push @more_Names, "$code_point; $1";
8985 # push @more_Names, "$code_point; $3";
8986 # Carp::my_carp_bug("Expecting blank space before left parenthesis in '$_'. Proceeding and assuming it was there;") if $2 ne " ";
8987 # Carp::my_carp_bug("Not expecting anything after the right parenthesis in '$_'. Proceeding and ignoring that;") if $4 ne "";
8992 { # Closure for UnicodeData.txt handling
8994 # This file was the first one in the UCD; its design leads to some
8995 # awkwardness in processing. Here is a sample line:
8996 # 0041;LATIN CAPITAL LETTER A;Lu;0;L;;;;;N;;;;0061;
8997 # The fields in order are:
8998 my $i = 0; # The code point is in field 0, and is shifted off.
8999 my $CHARNAME = $i++; # character name (e.g. "LATIN CAPITAL LETTER A")
9000 my $CATEGORY = $i++; # category (e.g. "Lu")
9001 my $CCC = $i++; # Canonical combining class (e.g. "230")
9002 my $BIDI = $i++; # directional class (e.g. "L")
9003 my $PERL_DECOMPOSITION = $i++; # decomposition mapping
9004 my $PERL_DECIMAL_DIGIT = $i++; # decimal digit value
9005 my $NUMERIC_TYPE_OTHER_DIGIT = $i++; # digit value, like a superscript
9006 # Dual-use in this program; see below
9007 my $NUMERIC = $i++; # numeric value
9008 my $MIRRORED = $i++; # ? mirrored
9009 my $UNICODE_1_NAME = $i++; # name in Unicode 1.0
9010 my $COMMENT = $i++; # iso comment
9011 my $UPPER = $i++; # simple uppercase mapping
9012 my $LOWER = $i++; # simple lowercase mapping
9013 my $TITLE = $i++; # simple titlecase mapping
9014 my $input_field_count = $i;
9016 # This routine in addition outputs these extra fields:
9017 my $DECOMP_TYPE = $i++; # Decomposition type
9019 # These fields are modifications of ones above, and are usually
9020 # suppressed; they must come last, as for speed, the loop upper bound is
9021 # normally set to ignore them
9022 my $NAME = $i++; # This is the strict name field, not the one that
9024 my $DECOMP_MAP = $i++; # Strict decomposition mapping; not the one used
9025 # by Unicode::Normalize
9026 my $last_field = $i - 1;
9028 # All these are read into an array for each line, with the indices defined
9029 # above. The empty fields in the example line above indicate that the
9030 # value is defaulted. The handler called for each line of the input
9031 # changes these to their defaults.
9033 # Here are the official names of the properties, in a parallel array:
9035 $field_names[$BIDI] = 'Bidi_Class';
9036 $field_names[$CATEGORY] = 'General_Category';
9037 $field_names[$CCC] = 'Canonical_Combining_Class';
9038 $field_names[$CHARNAME] = 'Perl_Charnames';
9039 $field_names[$COMMENT] = 'ISO_Comment';
9040 $field_names[$DECOMP_MAP] = 'Decomposition_Mapping';
9041 $field_names[$DECOMP_TYPE] = 'Decomposition_Type';
9042 $field_names[$LOWER] = 'Lowercase_Mapping';
9043 $field_names[$MIRRORED] = 'Bidi_Mirrored';
9044 $field_names[$NAME] = 'Name';
9045 $field_names[$NUMERIC] = 'Numeric_Value';
9046 $field_names[$NUMERIC_TYPE_OTHER_DIGIT] = 'Numeric_Type';
9047 $field_names[$PERL_DECIMAL_DIGIT] = 'Perl_Decimal_Digit';
9048 $field_names[$PERL_DECOMPOSITION] = 'Perl_Decomposition_Mapping';
9049 $field_names[$TITLE] = 'Titlecase_Mapping';
9050 $field_names[$UNICODE_1_NAME] = 'Unicode_1_Name';
9051 $field_names[$UPPER] = 'Uppercase_Mapping';
9053 # Some of these need a little more explanation:
9054 # The $PERL_DECIMAL_DIGIT field does not lead to an official Unicode
9055 # property, but is used in calculating the Numeric_Type. Perl however,
9056 # creates a file from this field, so a Perl property is created from it.
9057 # Similarly, the Other_Digit field is used only for calculating the
9058 # Numeric_Type, and so it can be safely re-used as the place to store
9059 # the value for Numeric_Type; hence it is referred to as
9060 # $NUMERIC_TYPE_OTHER_DIGIT.
9061 # The input field named $PERL_DECOMPOSITION is a combination of both the
9062 # decomposition mapping and its type. Perl creates a file containing
9063 # exactly this field, so it is used for that. The two properties are
9064 # separated into two extra output fields, $DECOMP_MAP and $DECOMP_TYPE.
9065 # $DECOMP_MAP is usually suppressed (unless the lists are changed to
9066 # output it), as Perl doesn't use it directly.
9067 # The input field named here $CHARNAME is used to construct the
9068 # Perl_Charnames property, which is a combination of the Name property
9069 # (which the input field contains), and the Unicode_1_Name property, and
9070 # others from other files. Since, the strict Name property is not used
9071 # by Perl, this field is used for the table that Perl does use. The
9072 # strict Name property table is usually suppressed (unless the lists are
9073 # changed to output it), so it is accumulated in a separate field,
9074 # $NAME, which to save time is discarded unless the table is actually to
9077 # This file is processed like most in this program. Control is passed to
9078 # process_generic_property_file() which calls filter_UnicodeData_line()
9079 # for each input line. This filter converts the input into line(s) that
9080 # process_generic_property_file() understands. There is also a setup
9081 # routine called before any of the file is processed, and a handler for
9082 # EOF processing, all in this closure.
9084 # A huge speed-up occurred at the cost of some added complexity when these
9085 # routines were altered to buffer the outputs into ranges. Almost all the
9086 # lines of the input file apply to just one code point, and for most
9087 # properties, the map for the next code point up is the same as the
9088 # current one. So instead of creating a line for each property for each
9089 # input line, filter_UnicodeData_line() remembers what the previous map
9090 # of a property was, and doesn't generate a line to pass on until it has
9091 # to, as when the map changes; and that passed-on line encompasses the
9092 # whole contiguous range of code points that have the same map for that
9093 # property. This means a slight amount of extra setup, and having to
9094 # flush these buffers on EOF, testing if the maps have changed, plus
9095 # remembering state information in the closure. But it means a lot less
9096 # real time in not having to change the data base for each property on
9099 # Another complication is that there are already a few ranges designated
9100 # in the input. There are two lines for each, with the same maps except
9101 # the code point and name on each line. This was actually the hardest
9102 # thing to design around. The code points in those ranges may actually
9103 # have real maps not given by these two lines. These maps will either
9104 # be algorthimically determinable, or in the extracted files furnished
9105 # with the UCD. In the event of conflicts between these extracted files,
9106 # and this one, Unicode says that this one prevails. But it shouldn't
9107 # prevail for conflicts that occur in these ranges. The data from the
9108 # extracted files prevails in those cases. So, this program is structured
9109 # so that those files are processed first, storing maps. Then the other
9110 # files are processed, generally overwriting what the extracted files
9111 # stored. But just the range lines in this input file are processed
9112 # without overwriting. This is accomplished by adding a special string to
9113 # the lines output to tell process_generic_property_file() to turn off the
9114 # overwriting for just this one line.
9115 # A similar mechanism is used to tell it that the map is of a non-default
9118 sub setup_UnicodeData { # Called before any lines of the input are read
9120 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
9122 # Create a new property specially located that is a combination of the
9123 # various Name properties: Name, Unicode_1_Name, Named Sequences, and
9124 # Name_Alias properties. (The final duplicates elements of the
9125 # first.) A comment for it will later be constructed based on the
9126 # actual properties present and used
9127 Property->new('Perl_Charnames',
9128 Core_Access => '\N{...} and "use charnames"',
9130 Directory => File::Spec->curdir(),
9132 Internal_Only_Warning => 1,
9133 Perl_Extension => 1,
9138 my $Perl_decomp = Property->new('Perl_Decomposition_Mapping',
9139 Directory => File::Spec->curdir(),
9140 File => 'Decomposition',
9141 Format => $STRING_FORMAT,
9142 Internal_Only_Warning => 1,
9143 Perl_Extension => 1,
9144 Default_Map => $CODE_POINT,
9146 # normalize.pm can't cope with these
9147 Output_Range_Counts => 0,
9149 # This is a specially formatted table
9150 # explicitly for normalize.pm, which
9151 # is expecting a particular format,
9152 # which means that mappings containing
9153 # multiple code points are in the main
9155 Map_Type => $COMPUTE_NO_MULTI_CP,
9158 $Perl_decomp->add_comment(join_lines(<<END
9159 This mapping is a combination of the Unicode 'Decomposition_Type' and
9160 'Decomposition_Mapping' properties, formatted for use by normalize.pm. It is
9161 identical to the official Unicode 'Decomposition_Mapping' property except for
9163 1) It omits the algorithmically determinable Hangul syllable decompositions,
9164 which normalize.pm handles algorithmically.
9165 2) It contains the decomposition type as well. Non-canonical decompositions
9166 begin with a word in angle brackets, like <super>, which denotes the
9167 compatible decomposition type. If the map does not begin with the <angle
9168 brackets>, the decomposition is canonical.
9172 my $Decimal_Digit = Property->new("Perl_Decimal_Digit",
9174 Perl_Extension => 1,
9175 File => 'Digit', # Trad. location
9176 Directory => $map_directory,
9180 $Decimal_Digit->add_comment(join_lines(<<END
9181 This file gives the mapping of all code points which represent a single
9182 decimal digit [0-9] to their respective digits. For example, the code point
9183 U+0031 (an ASCII '1') is mapped to a numeric 1. These code points are those
9184 that have Numeric_Type=Decimal; not special things, like subscripts nor Roman
9189 # These properties are not used for generating anything else, and are
9190 # usually not output. By making them last in the list, we can just
9191 # change the high end of the loop downwards to avoid the work of
9192 # generating a table(s) that is/are just going to get thrown away.
9193 if (! property_ref('Decomposition_Mapping')->to_output_map
9194 && ! property_ref('Name')->to_output_map)
9196 $last_field = min($NAME, $DECOMP_MAP) - 1;
9197 } elsif (property_ref('Decomposition_Mapping')->to_output_map) {
9198 $last_field = $DECOMP_MAP;
9199 } elsif (property_ref('Name')->to_output_map) {
9200 $last_field = $NAME;
9205 my $first_time = 1; # ? Is this the first line of the file
9206 my $in_range = 0; # ? Are we in one of the file's ranges
9207 my $previous_cp; # hex code point of previous line
9208 my $decimal_previous_cp = -1; # And its decimal equivalent
9209 my @start; # For each field, the current starting
9210 # code point in hex for the range
9211 # being accumulated.
9212 my @fields; # The input fields;
9213 my @previous_fields; # And those from the previous call
9215 sub filter_UnicodeData_line {
9216 # Handle a single input line from UnicodeData.txt; see comments above
9217 # Conceptually this takes a single line from the file containing N
9218 # properties, and converts it into N lines with one property per line,
9219 # which is what the final handler expects. But there are
9220 # complications due to the quirkiness of the input file, and to save
9221 # time, it accumulates ranges where the property values don't change
9222 # and only emits lines when necessary. This is about an order of
9223 # magnitude fewer lines emitted.
9226 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
9228 # $_ contains the input line.
9229 # -1 in split means retain trailing null fields
9230 (my $cp, @fields) = split /\s*;\s*/, $_, -1;
9232 #local $to_trace = 1 if main::DEBUG;
9233 trace $cp, @fields , $input_field_count if main::DEBUG && $to_trace;
9234 if (@fields > $input_field_count) {
9235 $file->carp_bad_line('Extra fields');
9240 my $decimal_cp = hex $cp;
9242 # We have to output all the buffered ranges when the next code point
9243 # is not exactly one after the previous one, which means there is a
9244 # gap in the ranges.
9245 my $force_output = ($decimal_cp != $decimal_previous_cp + 1);
9247 # The decomposition mapping field requires special handling. It looks
9250 # <compat> 0032 0020
9253 # The decomposition type is enclosed in <brackets>; if missing, it
9254 # means the type is canonical. There are two decomposition mapping
9255 # tables: the one for use by Perl's normalize.pm has a special format
9256 # which is this field intact; the other, for general use is of
9257 # standard format. In either case we have to find the decomposition
9258 # type. Empty fields have None as their type, and map to the code
9260 if ($fields[$PERL_DECOMPOSITION] eq "") {
9261 $fields[$DECOMP_TYPE] = 'None';
9262 $fields[$DECOMP_MAP] = $fields[$PERL_DECOMPOSITION] = $CODE_POINT;
9265 ($fields[$DECOMP_TYPE], my $map) = $fields[$PERL_DECOMPOSITION]
9266 =~ / < ( .+? ) > \s* ( .+ ) /x;
9267 if (! defined $fields[$DECOMP_TYPE]) {
9268 $fields[$DECOMP_TYPE] = 'Canonical';
9269 $fields[$DECOMP_MAP] = $fields[$PERL_DECOMPOSITION];
9272 $fields[$DECOMP_MAP] = $map;
9276 # The 3 numeric fields also require special handling. The 2 digit
9277 # fields must be either empty or match the number field. This means
9278 # that if it is empty, they must be as well, and the numeric type is
9279 # None, and the numeric value is 'Nan'.
9280 # The decimal digit field must be empty or match the other digit
9281 # field. If the decimal digit field is non-empty, the code point is
9282 # a decimal digit, and the other two fields will have the same value.
9283 # If it is empty, but the other digit field is non-empty, the code
9284 # point is an 'other digit', and the number field will have the same
9285 # value as the other digit field. If the other digit field is empty,
9286 # but the number field is non-empty, the code point is a generic
9288 if ($fields[$NUMERIC] eq "") {
9289 if ($fields[$PERL_DECIMAL_DIGIT] ne ""
9290 || $fields[$NUMERIC_TYPE_OTHER_DIGIT] ne ""
9292 $file->carp_bad_line("Numeric values inconsistent. Trying to process anyway");
9294 $fields[$NUMERIC_TYPE_OTHER_DIGIT] = 'None';
9295 $fields[$NUMERIC] = 'NaN';
9298 $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;
9299 if ($fields[$PERL_DECIMAL_DIGIT] ne "") {
9300 $file->carp_bad_line("$fields[$PERL_DECIMAL_DIGIT] should equal $fields[$NUMERIC]. Processing anyway") if $fields[$PERL_DECIMAL_DIGIT] != $fields[$NUMERIC];
9301 $fields[$NUMERIC_TYPE_OTHER_DIGIT] = 'Decimal';
9303 elsif ($fields[$NUMERIC_TYPE_OTHER_DIGIT] ne "") {
9304 $file->carp_bad_line("$fields[$NUMERIC_TYPE_OTHER_DIGIT] should equal $fields[$NUMERIC]. Processing anyway") if $fields[$NUMERIC_TYPE_OTHER_DIGIT] != $fields[$NUMERIC];
9305 $fields[$NUMERIC_TYPE_OTHER_DIGIT] = 'Digit';
9308 $fields[$NUMERIC_TYPE_OTHER_DIGIT] = 'Numeric';
9310 # Rationals require extra effort.
9311 register_fraction($fields[$NUMERIC])
9312 if $fields[$NUMERIC] =~ qr{/};
9316 # For the properties that have empty fields in the file, and which
9317 # mean something different from empty, change them to that default.
9318 # Certain fields just haven't been empty so far in any Unicode
9319 # version, so don't look at those, namely $MIRRORED, $BIDI, $CCC,
9320 # $CATEGORY. This leaves just the two fields, and so we hard-code in
9321 # the defaults; which are verly unlikely to ever change.
9322 $fields[$UPPER] = $CODE_POINT if $fields[$UPPER] eq "";
9323 $fields[$LOWER] = $CODE_POINT if $fields[$LOWER] eq "";
9325 # UAX44 says that if title is empty, it is the same as whatever upper
9327 $fields[$TITLE] = $fields[$UPPER] if $fields[$TITLE] eq "";
9329 # There are a few pairs of lines like:
9330 # AC00;<Hangul Syllable, First>;Lo;0;L;;;;;N;;;;;
9331 # D7A3;<Hangul Syllable, Last>;Lo;0;L;;;;;N;;;;;
9332 # that define ranges. These should be processed after the fields are
9333 # adjusted above, as they may override some of them; but mostly what
9334 # is left is to possibly adjust the $CHARNAME field. The names of all the
9335 # paired lines start with a '<', but this is also true of '<control>,
9336 # which isn't one of these special ones.
9337 if ($fields[$CHARNAME] eq '<control>') {
9339 # Some code points in this file have the pseudo-name
9340 # '<control>', but the official name for such ones is the null
9341 # string. For charnames.pm, we use the Unicode version 1 name
9342 $fields[$NAME] = "";
9343 $fields[$CHARNAME] = $fields[$UNICODE_1_NAME];
9345 # We had better not be in between range lines.
9347 $file->carp_bad_line("Expecting a closing range line, not a $fields[$CHARNAME]'. Trying anyway");
9351 elsif (substr($fields[$CHARNAME], 0, 1) ne '<') {
9353 # Here is a non-range line. We had better not be in between range
9356 $file->carp_bad_line("Expecting a closing range line, not a $fields[$CHARNAME]'. Trying anyway");
9359 # XXX until charnames catches up.
9360 # if ($fields[$CHARNAME] =~ s/- $cp $//x) {
9362 # # These are code points whose names end in their code points,
9363 # # which means the names are algorithmically derivable from the
9364 # # code points. To shorten the output Name file, the algorithm
9365 # # for deriving these is placed in the file instead of each
9366 # # code point, so they have map type $CP_IN_NAME
9367 # $fields[$CHARNAME] = $CMD_DELIM
9372 # . $fields[$CHARNAME];
9374 $fields[$NAME] = $fields[$CHARNAME];
9376 # Some official names are really two alternate names with one in
9377 # parentheses. What we do here is use the full official one for
9378 # the standard property (stored just above), but for the charnames
9379 # table, we add two more entries, one for each of the alternate
9382 #check_and_handle_compound_name($cp, $fields[$CHARNAME]);
9383 #check_and_handle_compound_name($cp, $unicode_1_name);
9384 # XXX until charnames catches up.
9386 elsif ($fields[$CHARNAME] =~ /^<(.+), First>$/) {
9387 $fields[$CHARNAME] = $fields[$NAME] = $1;
9389 # Here we are at the beginning of a range pair.
9391 $file->carp_bad_line("Expecting a closing range line, not a beginning one, $fields[$CHARNAME]'. Trying anyway");
9395 # Because the properties in the range do not overwrite any already
9396 # in the db, we must flush the buffers of what's already there, so
9397 # they get handled in the normal scheme.
9401 elsif ($fields[$CHARNAME] !~ s/^<(.+), Last>$/$1/) {
9402 $file->carp_bad_line("Unexpected name starting with '<' $fields[$CHARNAME]. Ignoring this line.");
9406 else { # Here, we are at the last line of a range pair.
9409 $file->carp_bad_line("Unexpected end of range $fields[$CHARNAME] when not in one. Ignoring this line.");
9415 $fields[$NAME] = $fields[$CHARNAME];
9417 # Check that the input is valid: that the closing of the range is
9418 # the same as the beginning.
9419 foreach my $i (0 .. $last_field) {
9420 next if $fields[$i] eq $previous_fields[$i];
9421 $file->carp_bad_line("Expecting '$fields[$i]' to be the same as '$previous_fields[$i]'. Bad News. Trying anyway");
9424 # The processing differs depending on the type of range,
9425 # determined by its $CHARNAME
9426 if ($fields[$CHARNAME] =~ /^Hangul Syllable/) {
9428 # Check that the data looks right.
9429 if ($decimal_previous_cp != $SBase) {
9430 $file->carp_bad_line("Unexpected Hangul syllable start = $previous_cp. Bad News. Results will be wrong");
9432 if ($decimal_cp != $SBase + $SCount - 1) {
9433 $file->carp_bad_line("Unexpected Hangul syllable end = $cp. Bad News. Results will be wrong");
9436 # The Hangul syllable range has a somewhat complicated name
9437 # generation algorithm. Each code point in it has a canonical
9438 # decomposition also computable by an algorithm. The
9439 # perl decomposition map table built from these is used only
9440 # by normalize.pm, which has the algorithm built in it, so the
9441 # decomposition maps are not needed, and are large, so are
9442 # omitted from it. If the full decomposition map table is to
9443 # be output, the decompositions are generated for it, in the
9444 # EOF handling code for this input file.
9446 $previous_fields[$DECOMP_TYPE] = 'Canonical';
9448 # This range is stored in our internal structure with its
9449 # own map type, different from all others.
9450 $previous_fields[$CHARNAME] = $previous_fields[$NAME]
9456 . $fields[$CHARNAME];
9458 elsif ($fields[$CHARNAME] =~ /^CJK/) {
9460 # The name for these contains the code point itself, and all
9461 # are defined to have the same base name, regardless of what
9462 # is in the file. They are stored in our internal structure
9463 # with a map type of $CP_IN_NAME
9464 $previous_fields[$CHARNAME] = $previous_fields[$NAME]
9470 . 'CJK UNIFIED IDEOGRAPH';
9473 elsif ($fields[$CATEGORY] eq 'Co'
9474 || $fields[$CATEGORY] eq 'Cs')
9476 # The names of all the code points in these ranges are set to
9477 # null, as there are no names for the private use and
9478 # surrogate code points.
9480 $previous_fields[$CHARNAME] = $previous_fields[$NAME] = "";
9483 $file->carp_bad_line("Unexpected code point range $fields[$CHARNAME] because category is $fields[$CATEGORY]. Attempting to process it.");
9486 # The first line of the range caused everything else to be output,
9487 # and then its values were stored as the beginning values for the
9488 # next set of ranges, which this one ends. Now, for each value,
9489 # add a command to tell the handler that these values should not
9490 # replace any existing ones in our database.
9491 foreach my $i (0 .. $last_field) {
9492 $previous_fields[$i] = $CMD_DELIM
9497 . $previous_fields[$i];
9500 # And change things so it looks like the entire range has been
9501 # gone through with this being the final part of it. Adding the
9502 # command above to each field will cause this range to be flushed
9503 # during the next iteration, as it guaranteed that the stored
9504 # field won't match whatever value the next one has.
9506 $decimal_previous_cp = $decimal_cp;
9508 # We are now set up for the next iteration; so skip the remaining
9509 # code in this subroutine that does the same thing, but doesn't
9510 # know about these ranges.
9515 # On the very first line, we fake it so the code below thinks there is
9516 # nothing to output, and initialize so that when it does get output it
9517 # uses the first line's values for the lowest part of the range.
9518 # (One could avoid this by using peek(), but then one would need to
9519 # know the adjustments done above and do the same ones in the setup
9520 # routine; not worth it)
9523 @previous_fields = @fields;
9524 @start = ($cp) x scalar @fields;
9525 $decimal_previous_cp = $decimal_cp - 1;
9528 # For each field, output the stored up ranges that this code point
9529 # doesn't fit in. Earlier we figured out if all ranges should be
9530 # terminated because of changing the replace or map type styles, or if
9531 # there is a gap between this new code point and the previous one, and
9532 # that is stored in $force_output. But even if those aren't true, we
9533 # need to output the range if this new code point's value for the
9534 # given property doesn't match the stored range's.
9535 #local $to_trace = 1 if main::DEBUG;
9536 foreach my $i (0 .. $last_field) {
9537 my $field = $fields[$i];
9538 if ($force_output || $field ne $previous_fields[$i]) {
9540 # Flush the buffer of stored values.
9541 $file->insert_adjusted_lines("$start[$i]..$previous_cp; $field_names[$i]; $previous_fields[$i]");
9543 # Start a new range with this code point and its value
9545 $previous_fields[$i] = $field;
9549 # Set the values for the next time.
9551 $decimal_previous_cp = $decimal_cp;
9553 # The input line has generated whatever adjusted lines are needed, and
9554 # should not be looked at further.
9559 sub EOF_UnicodeData {
9560 # Called upon EOF to flush the buffers, and create the Hangul
9561 # decomposition mappings if needed.
9564 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
9566 # Flush the buffers.
9567 foreach my $i (1 .. $last_field) {
9568 $file->insert_adjusted_lines("$start[$i]..$previous_cp; $field_names[$i]; $previous_fields[$i]");
9571 if (-e 'Jamo.txt') {
9573 # The algorithm is published by Unicode, based on values in
9574 # Jamo.txt, (which should have been processed before this
9575 # subroutine), and the results left in %Jamo
9577 Carp::my_carp_bug("Jamo.txt should be processed before Unicode.txt. Hangul syllables not generated.");
9581 # If the full decomposition map table is being output, insert
9582 # into it the Hangul syllable mappings. This is to avoid having
9583 # to publish a subroutine in it to compute them. (which would
9584 # essentially be this code.) This uses the algorithm published by
9586 if (property_ref('Decomposition_Mapping')->to_output_map) {
9587 local $to_trace = 1 if main::DEBUG;
9588 for (my $S = $SBase; $S < $SBase + $SCount; $S++) {
9590 my $SIndex = $S - $SBase;
9591 my $L = $LBase + $SIndex / $NCount;
9592 my $V = $VBase + ($SIndex % $NCount) / $TCount;
9593 my $T = $TBase + $SIndex % $TCount;
9595 trace "L=$L, V=$V, T=$T" if main::DEBUG && $to_trace;
9596 my $decomposition = sprintf("%04X %04X", $L, $V);
9597 $decomposition .= sprintf(" %04X", $T) if $T != $TBase;
9598 $file->insert_adjusted_lines(
9599 sprintf("%04X; Decomposition_Mapping; %s",
9610 # Fix UCD lines in version 1. This is probably overkill, but this
9611 # fixes some glaring errors in Version 1 UnicodeData.txt. That file:
9612 # 1) had many Hangul (U+3400 - U+4DFF) code points that were later
9613 # removed. This program retains them
9614 # 2) didn't include ranges, which it should have, and which are now
9615 # added in @corrected_lines below. It was hand populated by
9616 # taking the data from Version 2, verified by analyzing
9618 # 3) There is a syntax error in the entry for U+09F8 which could
9619 # cause problems for utf8_heavy, and so is changed. It's
9620 # numeric value was simply a minus sign, without any number.
9621 # (Eventually Unicode changed the code point to non-numeric.)
9622 # 4) The decomposition types often don't match later versions
9623 # exactly, and the whole syntax of that field is different; so
9624 # the syntax is changed as well as the types to their later
9625 # terminology. Otherwise normalize.pm would be very unhappy
9626 # 5) Many ccc classes are different. These are left intact.
9627 # 6) U+FF10 - U+FF19 are missing their numeric values in all three
9628 # fields. These are unchanged because it doesn't really cause
9629 # problems for Perl.
9630 # 7) A number of code points, such as controls, don't have their
9631 # Unicode Version 1 Names in this file. These are unchanged.
9633 my @corrected_lines = split /\n/, <<'END';
9634 4E00;<CJK Ideograph, First>;Lo;0;L;;;;;N;;;;;
9635 9FA5;<CJK Ideograph, Last>;Lo;0;L;;;;;N;;;;;
9636 E000;<Private Use, First>;Co;0;L;;;;;N;;;;;
9637 F8FF;<Private Use, Last>;Co;0;L;;;;;N;;;;;
9638 F900;<CJK Compatibility Ideograph, First>;Lo;0;L;;;;;N;;;;;
9639 FA2D;<CJK Compatibility Ideograph, Last>;Lo;0;L;;;;;N;;;;;
9643 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
9645 #local $to_trace = 1 if main::DEBUG;
9646 trace $_ if main::DEBUG && $to_trace;
9648 # -1 => retain trailing null fields
9649 my ($code_point, @fields) = split /\s*;\s*/, $_, -1;
9651 # At the first place that is wrong in the input, insert all the
9652 # corrections, replacing the wrong line.
9653 if ($code_point eq '4E00') {
9654 my @copy = @corrected_lines;
9656 ($code_point, @fields) = split /\s*;\s*/, $_, -1;
9658 $file->insert_lines(@copy);
9662 if ($fields[$NUMERIC] eq '-') {
9663 $fields[$NUMERIC] = '-1'; # This is what 2.0 made it.
9666 if ($fields[$PERL_DECOMPOSITION] ne "") {
9668 # Several entries have this change to superscript 2 or 3 in the
9669 # middle. Convert these to the modern version, which is to use
9670 # the actual U+00B2 and U+00B3 (the superscript forms) instead.
9671 # So 'HHHH HHHH <+sup> 0033 <-sup> HHHH' becomes
9672 # 'HHHH HHHH 00B3 HHHH'.
9673 # It turns out that all of these that don't have another
9674 # decomposition defined at the beginning of the line have the
9675 # <square> decomposition in later releases.
9676 if ($code_point ne '00B2' && $code_point ne '00B3') {
9677 if ($fields[$PERL_DECOMPOSITION]
9678 =~ s/<\+sup> 003([23]) <-sup>/00B$1/)
9680 if (substr($fields[$PERL_DECOMPOSITION], 0, 1) ne '<') {
9681 $fields[$PERL_DECOMPOSITION] = '<square> '
9682 . $fields[$PERL_DECOMPOSITION];
9687 # If is like '<+circled> 0052 <-circled>', convert to
9689 $fields[$PERL_DECOMPOSITION] =~
9690 s/ < \+ ( .*? ) > \s* (.*?) \s* <-\1> /<$1> $2/x;
9692 # Convert '<join> HHHH HHHH <join>' to '<medial> HHHH HHHH', etc.
9693 $fields[$PERL_DECOMPOSITION] =~
9694 s/ <join> \s* (.*?) \s* <no-join> /<final> $1/x
9695 or $fields[$PERL_DECOMPOSITION] =~
9696 s/ <join> \s* (.*?) \s* <join> /<medial> $1/x
9697 or $fields[$PERL_DECOMPOSITION] =~
9698 s/ <no-join> \s* (.*?) \s* <join> /<initial> $1/x
9699 or $fields[$PERL_DECOMPOSITION] =~
9700 s/ <no-join> \s* (.*?) \s* <no-join> /<isolated> $1/x;
9702 # Convert '<break> HHHH HHHH <break>' to '<break> HHHH', etc.
9703 $fields[$PERL_DECOMPOSITION] =~
9704 s/ <(break|no-break)> \s* (.*?) \s* <\1> /<$1> $2/x;
9706 # Change names to modern form.
9707 $fields[$PERL_DECOMPOSITION] =~ s/<font variant>/<font>/g;
9708 $fields[$PERL_DECOMPOSITION] =~ s/<no-break>/<noBreak>/g;
9709 $fields[$PERL_DECOMPOSITION] =~ s/<circled>/<circle>/g;
9710 $fields[$PERL_DECOMPOSITION] =~ s/<break>/<fraction>/g;
9712 # One entry has weird braces
9713 $fields[$PERL_DECOMPOSITION] =~ s/[{}]//g;
9716 $_ = join ';', $code_point, @fields;
9717 trace $_ if main::DEBUG && $to_trace;
9721 sub filter_v2_1_5_ucd {
9722 # A dozen entries in this 2.1.5 file had the mirrored and numeric
9723 # columns swapped; These all had mirrored be 'N'. So if the numeric
9724 # column appears to be N, swap it back.
9726 my ($code_point, @fields) = split /\s*;\s*/, $_, -1;
9727 if ($fields[$NUMERIC] eq 'N') {
9728 $fields[$NUMERIC] = $fields[$MIRRORED];
9729 $fields[$MIRRORED] = 'N';
9730 $_ = join ';', $code_point, @fields;
9734 } # End closure for UnicodeData
9736 sub process_GCB_test {
9739 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
9741 while ($file->next_line) {
9742 push @backslash_X_tests, $_;
9748 sub process_NamedSequences {
9749 # NamedSequences.txt entries are just added to an array. Because these
9750 # don't look like the other tables, they have their own handler.
9752 # LATIN CAPITAL LETTER A WITH MACRON AND GRAVE;0100 0300
9754 # This just adds the sequence to an array for later handling
9756 return; # XXX Until charnames catches up
9758 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
9760 while ($file->next_line) {
9761 my ($name, $sequence, @remainder) = split /\s*;\s*/, $_, -1;
9763 $file->carp_bad_line(
9764 "Doesn't look like 'KHMER VOWEL SIGN OM;17BB 17C6'");
9767 push @named_sequences, "$sequence\t\t$name";
9776 sub filter_early_ea_lb {
9777 # Fixes early EastAsianWidth.txt and LineBreak.txt files. These had a
9778 # third field be the name of the code point, which can be ignored in
9779 # most cases. But it can be meaningful if it marks a range:
9780 # 33FE;W;IDEOGRAPHIC TELEGRAPH SYMBOL FOR DAY THIRTY-ONE
9781 # 3400;W;<CJK Ideograph Extension A, First>
9783 # We need to see the First in the example above to know it's a range.
9784 # They did not use the later range syntaxes. This routine changes it
9785 # to use the modern syntax.
9786 # $1 is the Input_file object.
9788 my @fields = split /\s*;\s*/;
9789 if ($fields[2] =~ /^<.*, First>/) {
9790 $first_range = $fields[0];
9793 elsif ($fields[2] =~ /^<.*, Last>/) {
9794 $_ = $_ = "$first_range..$fields[0]; $fields[1]";
9798 $_ = "$fields[0]; $fields[1]";
9805 sub filter_old_style_arabic_shaping {
9806 # Early versions used a different term for the later one.
9808 my @fields = split /\s*;\s*/;
9809 $fields[3] =~ s/<no shaping>/No_Joining_Group/;
9810 $fields[3] =~ s/\s+/_/g; # Change spaces to underscores
9811 $_ = join ';', @fields;
9815 sub filter_arabic_shaping_line {
9816 # ArabicShaping.txt has entries that look like:
9818 # The field containing 'TEH' is not used. The next field is Joining_Type
9819 # and the last is Joining_Group
9820 # This generates two lines to pass on, one for each property on the input
9824 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
9826 my @fields = split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields
9829 $file->carp_bad_line('Extra fields');
9834 $file->insert_adjusted_lines("$fields[0]; Joining_Group; $fields[3]");
9835 $_ = "$fields[0]; Joining_Type; $fields[2]";
9840 sub setup_special_casing {
9841 # SpecialCasing.txt contains the non-simple case change mappings. The
9842 # simple ones are in UnicodeData.txt, which should already have been read
9843 # in to the full property data structures, so as to initialize these with
9844 # the simple ones. Then the SpecialCasing.txt entries overwrite the ones
9845 # which have different full mappings.
9847 # This routine sees if the simple mappings are to be output, and if so,
9848 # copies what has already been put into the full mapping tables, while
9849 # they still contain only the simple mappings.
9851 # The reason it is done this way is that the simple mappings are probably
9852 # not going to be output, so it saves work to initialize the full tables
9853 # with the simple mappings, and then overwrite those relatively few
9854 # entries in them that have different full mappings, and thus skip the
9855 # simple mapping tables altogether.
9858 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
9860 # For each of the case change mappings...
9861 foreach my $case ('lc', 'tc', 'uc') {
9862 my $full = property_ref($case);
9863 unless (defined $full && ! $full->is_empty) {
9864 Carp::my_carp_bug("Need to process UnicodeData before SpecialCasing. Only special casing will be generated.");
9867 # The simple version's name in each mapping merely has an 's' in front
9869 my $simple = property_ref('s' . $case);
9870 $simple->initialize($case) if $simple->to_output_map();
9876 sub filter_special_casing_line {
9877 # Change the format of $_ from SpecialCasing.txt into something that the
9878 # generic handler understands. Each input line contains three case
9879 # mappings. This will generate three lines to pass to the generic handler
9880 # for each of those.
9882 # The input syntax (after stripping comments and trailing white space is
9883 # like one of the following (with the final two being entries that we
9885 # 00DF; 00DF; 0053 0073; 0053 0053; # LATIN SMALL LETTER SHARP S
9886 # 03A3; 03C2; 03A3; 03A3; Final_Sigma;
9887 # 0307; ; 0307; 0307; tr After_I; # COMBINING DOT ABOVE
9888 # Note the trailing semi-colon, unlike many of the input files. That
9889 # means that there will be an extra null field generated by the split
9892 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
9894 my @fields = split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields
9896 # field #4 is when this mapping is conditional. If any of these get
9897 # implemented, it would be by hard-coding in the casing functions in the
9898 # Perl core, not through tables. But if there is a new condition we don't
9899 # know about, output a warning. We know about all the conditions through
9901 if ($fields[4] ne "") {
9902 my @conditions = split ' ', $fields[4];
9903 if ($conditions[0] ne 'tr' # We know that these languages have
9904 # conditions, and some are multiple
9905 && $conditions[0] ne 'az'
9906 && $conditions[0] ne 'lt'
9908 # And, we know about a single condition Final_Sigma, but
9910 && ($v_version gt v5.2.0
9911 && (@conditions > 1 || $conditions[0] ne 'Final_Sigma')))
9913 $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");
9915 elsif ($conditions[0] ne 'Final_Sigma') {
9917 # Don't print out a message for Final_Sigma, because we have
9918 # hard-coded handling for it. (But the standard could change
9919 # what the rule should be, but it wouldn't show up here
9922 print "# SKIPPING Special Casing: $_\n"
9923 if $verbosity >= $VERBOSE;
9928 elsif (@fields > 6 || (@fields == 6 && $fields[5] ne "" )) {
9929 $file->carp_bad_line('Extra fields');
9934 $_ = "$fields[0]; lc; $fields[1]";
9935 $file->insert_adjusted_lines("$fields[0]; tc; $fields[2]");
9936 $file->insert_adjusted_lines("$fields[0]; uc; $fields[3]");
9941 sub filter_old_style_case_folding {
9942 # This transforms $_ containing the case folding style of 3.0.1, to 3.1
9943 # and later style. Different letters were used in the earlier.
9946 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
9948 my @fields = split /\s*;\s*/;
9949 if ($fields[0] =~ /^ 013 [01] $/x) { # The two turkish fields
9952 elsif ($fields[1] eq 'L') {
9953 $fields[1] = 'C'; # L => C always
9955 elsif ($fields[1] eq 'E') {
9956 if ($fields[2] =~ / /) { # E => C if one code point; F otherwise
9964 $file->carp_bad_line("Expecting L or E in second field");
9968 $_ = join("; ", @fields) . ';';
9972 { # Closure for case folding
9974 # Create the map for simple only if are going to output it, for otherwise
9975 # it takes no part in anything we do.
9976 my $to_output_simple;
9978 # These are experimental, perhaps will need these to pass to regcomp.c to
9979 # handle the cases where for example the Kelvin sign character folds to k,
9980 # and in regcomp, we need to know which of the characters can have a
9981 # non-latin1 char fold to it, so it doesn't do the optimizations it might
9983 my @latin1_singly_folded;
9986 sub setup_case_folding($) {
9987 # Read in the case foldings in CaseFolding.txt. This handles both
9988 # simple and full case folding.
9991 = property_ref('Simple_Case_Folding')->to_output_map;
9996 sub filter_case_folding_line {
9997 # Called for each line in CaseFolding.txt
9998 # Input lines look like:
9999 # 0041; C; 0061; # LATIN CAPITAL LETTER A
10000 # 00DF; F; 0073 0073; # LATIN SMALL LETTER SHARP S
10001 # 1E9E; S; 00DF; # LATIN CAPITAL LETTER SHARP S
10003 # 'C' means that folding is the same for both simple and full
10004 # 'F' that it is only for full folding
10005 # 'S' that it is only for simple folding
10006 # 'T' is locale-dependent, and ignored
10007 # 'I' is a type of 'F' used in some early releases.
10008 # Note the trailing semi-colon, unlike many of the input files. That
10009 # means that there will be an extra null field generated by the split
10010 # below, which we ignore and hence is not an error.
10013 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10015 my ($range, $type, $map, @remainder) = split /\s*;\s*/, $_, -1;
10016 if (@remainder > 1 || (@remainder == 1 && $remainder[0] ne "" )) {
10017 $file->carp_bad_line('Extra fields');
10022 if ($type eq 'T') { # Skip Turkic case folding, is locale dependent
10027 # C: complete, F: full, or I: dotted uppercase I -> dotless lowercase
10028 # I are all full foldings
10029 if ($type eq 'C' || $type eq 'F' || $type eq 'I') {
10030 $_ = "$range; Case_Folding; $map";
10034 if ($type ne 'S') {
10035 $file->carp_bad_line('Expecting C F I S or T in second field');
10040 # C and S are simple foldings, but simple case folding is not needed
10041 # unless we explicitly want its map table output.
10042 if ($to_output_simple && $type eq 'C' || $type eq 'S') {
10043 $file->insert_adjusted_lines("$range; Simple_Case_Folding; $map");
10046 # Experimental, see comment above
10047 if ($type ne 'S' && hex($range) >= 256) { # assumes range is 1 point
10048 my @folded = split ' ', $map;
10049 if (hex $folded[0] < 256 && @folded == 1) {
10050 push @latin1_singly_folded, hex $folded[0];
10052 foreach my $folded (@folded) {
10053 push @latin1_folded, hex $folded if hex $folded < 256;
10061 # Experimental, see comment above
10064 #local $to_trace = 1 if main::DEBUG;
10065 @latin1_singly_folded = uniques(@latin1_singly_folded);
10066 @latin1_folded = uniques(@latin1_folded);
10067 trace "latin1 single folded:", map { chr $_ } sort { $a <=> $b } @latin1_singly_folded if main::DEBUG && $to_trace;
10068 trace "latin1 folded:", map { chr $_ } sort { $a <=> $b } @latin1_folded if main::DEBUG && $to_trace;
10071 } # End case fold closure
10073 sub filter_jamo_line {
10074 # Filter Jamo.txt lines. This routine mainly is used to populate hashes
10075 # from this file that is used in generating the Name property for Jamo
10076 # code points. But, it also is used to convert early versions' syntax
10077 # into the modern form. Here are two examples:
10078 # 1100; G # HANGUL CHOSEONG KIYEOK # Modern syntax
10079 # U+1100; G; HANGUL CHOSEONG KIYEOK # 2.0 syntax
10081 # The input is $_, the output is $_ filtered.
10083 my @fields = split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields
10085 # Let the caller handle unexpected input. In earlier versions, there was
10086 # a third field which is supposed to be a comment, but did not have a '#'
10088 return if @fields > (($v_version gt v3.0.0) ? 2 : 3);
10090 $fields[0] =~ s/^U\+//; # Also, early versions had this extraneous
10093 # Some 2.1 versions had this wrong. Causes havoc with the algorithm.
10094 $fields[1] = 'R' if $fields[0] eq '1105';
10096 # Add to structure so can generate Names from it.
10097 my $cp = hex $fields[0];
10098 my $short_name = $fields[1];
10099 $Jamo{$cp} = $short_name;
10100 if ($cp <= $LBase + $LCount) {
10101 $Jamo_L{$short_name} = $cp - $LBase;
10103 elsif ($cp <= $VBase + $VCount) {
10104 $Jamo_V{$short_name} = $cp - $VBase;
10106 elsif ($cp <= $TBase + $TCount) {
10107 $Jamo_T{$short_name} = $cp - $TBase;
10110 Carp::my_carp_bug("Unexpected Jamo code point in $_");
10114 # Reassemble using just the first two fields to look like a typical
10115 # property file line
10116 $_ = "$fields[0]; $fields[1]";
10121 sub register_fraction($) {
10122 # This registers the input rational number so that it can be passed on to
10123 # utf8_heavy.pl, both in rational and floating forms.
10125 my $rational = shift;
10127 my $float = eval $rational;
10128 $nv_floating_to_rational{$float} = $rational;
10132 sub filter_numeric_value_line {
10133 # DNumValues contains lines of a different syntax than the typical
10135 # 0F33 ; -0.5 ; ; -1/2 # No TIBETAN DIGIT HALF ZERO
10137 # This routine transforms $_ containing the anomalous syntax to the
10138 # typical, by filtering out the extra columns, and convert early version
10139 # decimal numbers to strings that look like rational numbers.
10142 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10144 # Starting in 5.1, there is a rational field. Just use that, omitting the
10145 # extra columns. Otherwise convert the decimal number in the second field
10146 # to a rational, and omit extraneous columns.
10147 my @fields = split /\s*;\s*/, $_, -1;
10150 if ($v_version ge v5.1.0) {
10151 if (@fields != 4) {
10152 $file->carp_bad_line('Not 4 semi-colon separated fields');
10156 $rational = $fields[3];
10157 $_ = join '; ', @fields[ 0, 3 ];
10161 # Here, is an older Unicode file, which has decimal numbers instead of
10162 # rationals in it. Use the fraction to calculate the denominator and
10163 # convert to rational.
10165 if (@fields != 2 && @fields != 3) {
10166 $file->carp_bad_line('Not 2 or 3 semi-colon separated fields');
10171 my $codepoints = $fields[0];
10172 my $decimal = $fields[1];
10173 if ($decimal =~ s/\.0+$//) {
10175 # Anything ending with a decimal followed by nothing but 0's is an
10177 $_ = "$codepoints; $decimal";
10178 $rational = $decimal;
10183 if ($decimal =~ /\.50*$/) {
10187 # Here have the hardcoded repeating decimals in the fraction, and
10188 # the denominator they imply. There were only a few denominators
10189 # in the older Unicode versions of this file which this code
10190 # handles, so it is easy to convert them.
10192 # The 4 is because of a round-off error in the Unicode 3.2 files
10193 elsif ($decimal =~ /\.33*[34]$/ || $decimal =~ /\.6+7$/) {
10196 elsif ($decimal =~ /\.[27]50*$/) {
10199 elsif ($decimal =~ /\.[2468]0*$/) {
10202 elsif ($decimal =~ /\.16+7$/ || $decimal =~ /\.83+$/) {
10205 elsif ($decimal =~ /\.(12|37|62|87)50*$/) {
10208 if ($denominator) {
10209 my $sign = ($decimal < 0) ? "-" : "";
10210 my $numerator = int((abs($decimal) * $denominator) + .5);
10211 $rational = "$sign$numerator/$denominator";
10212 $_ = "$codepoints; $rational";
10215 $file->carp_bad_line("Can't cope with number '$decimal'.");
10222 register_fraction($rational) if $rational =~ qr{/};
10227 my %unihan_properties;
10232 # Do any special setup for Unihan properties.
10234 # This property gives the wrong computed type, so override.
10235 my $usource = property_ref('kIRG_USource');
10236 $usource->set_type($STRING) if defined $usource;
10238 # This property is to be considered binary, so change all the values
10240 $iicore = property_ref('kIICore');
10241 if (defined $iicore) {
10242 $iicore->add_match_table('Y') if ! defined $iicore->table('Y');
10244 # We have to change the default map, because the @missing line is
10245 # misleading, given that we are treating it as binary.
10246 $iicore->set_default_map('N');
10247 $iicore->set_type($BINARY);
10253 sub filter_unihan_line {
10254 # Change unihan db lines to look like the others in the db. Here is
10256 # U+341C kCangjie IEKN
10258 # Tabs are used instead of semi-colons to separate fields; therefore
10259 # they may have semi-colons embedded in them. Change these to periods
10260 # so won't screw up the rest of the code.
10263 # Remove lines that don't look like ones we accept.
10264 if ($_ !~ /^ [^\t]* \t ( [^\t]* ) /x) {
10269 # Extract the property, and save a reference to its object.
10271 if (! exists $unihan_properties{$property}) {
10272 $unihan_properties{$property} = property_ref($property);
10275 # Don't do anything unless the property is one we're handling, which
10276 # we determine by seeing if there is an object defined for it or not
10277 if (! defined $unihan_properties{$property}) {
10282 # The iicore property is supposed to be a boolean, so convert to our
10283 # standard boolean form.
10284 if (defined $iicore && $unihan_properties{$property} == $iicore) {
10285 $_ =~ s/$property.*/$property\tY/
10288 # Convert the tab separators to our standard semi-colons, and convert
10289 # the U+HHHH notation to the rest of the standard's HHHH
10291 s/\b U \+ (?= $code_point_re )//xg;
10293 #local $to_trace = 1 if main::DEBUG;
10294 trace $_ if main::DEBUG && $to_trace;
10300 sub filter_blocks_lines {
10301 # In the Blocks.txt file, the names of the blocks don't quite match the
10302 # names given in PropertyValueAliases.txt, so this changes them so they
10303 # do match: Blanks and hyphens are changed into underscores. Also makes
10304 # early release versions look like later ones
10306 # $_ is transformed to the correct value.
10309 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10311 if ($v_version lt v3.2.0) {
10312 if (/FEFF.*Specials/) { # Bug in old versions: line wrongly inserted
10317 # Old versions used a different syntax to mark the range.
10318 $_ =~ s/;\s+/../ if $v_version lt v3.1.0;
10321 my @fields = split /\s*;\s*/, $_, -1;
10322 if (@fields != 2) {
10323 $file->carp_bad_line("Expecting exactly two fields");
10328 # Change hyphens and blanks in the block name field only
10329 $fields[1] =~ s/[ -]/_/g;
10330 $fields[1] =~ s/_ ( [a-z] ) /_\u$1/g; # Capitalize first letter of word
10332 $_ = join("; ", @fields);
10337 my $current_property;
10339 sub filter_old_style_proplist {
10340 # PropList.txt has been in Unicode since version 2.0. Until 3.1, it
10341 # was in a completely different syntax. Ken Whistler of Unicode says
10342 # that it was something he used as an aid for his own purposes, but
10343 # was never an official part of the standard. However, comments in
10344 # DAge.txt indicate that non-character code points were available in
10345 # the UCD as of 3.1. It is unclear to me (khw) how they could be
10346 # there except through this file (but on the other hand, they first
10347 # appeared there in 3.0.1), so maybe it was part of the UCD, and maybe
10348 # not. But the claim is that it was published as an aid to others who
10349 # might want some more information than was given in the official UCD
10350 # of the time. Many of the properties in it were incorporated into
10351 # the later PropList.txt, but some were not. This program uses this
10352 # early file to generate property tables that are otherwise not
10353 # accessible in the early UCD's, and most were probably not really
10354 # official at that time, so one could argue that it should be ignored,
10355 # and you can easily modify things to skip this. And there are bugs
10356 # in this file in various versions. (For example, the 2.1.9 version
10357 # removes from Alphabetic the CJK range starting at 4E00, and they
10358 # weren't added back in until 3.1.0.) Many of this file's properties
10359 # were later sanctioned, so this code generates tables for those
10360 # properties that aren't otherwise in the UCD of the time but
10361 # eventually did become official, and throws away the rest. Here is a
10362 # list of all the ones that are thrown away:
10363 # Bidi=* duplicates UnicodeData.txt
10364 # Combining never made into official property;
10366 # Composite never made into official property.
10367 # Currency Symbol duplicates UnicodeData.txt: gc=sc
10368 # Decimal Digit duplicates UnicodeData.txt: gc=nd
10369 # Delimiter never made into official property;
10371 # Format Control never made into official property;
10373 # High Surrogate duplicates Blocks.txt
10374 # Ignorable Control never made into official property;
10376 # ISO Control duplicates UnicodeData.txt: gc=cc
10377 # Left of Pair never made into official property;
10378 # Line Separator duplicates UnicodeData.txt: gc=zl
10379 # Low Surrogate duplicates Blocks.txt
10380 # Non-break was actually listed as a property
10381 # in 3.2, but without any code
10382 # points. Unicode denies that this
10383 # was ever an official property
10384 # Non-spacing duplicate UnicodeData.txt: gc=mn
10385 # Numeric duplicates UnicodeData.txt: gc=cc
10386 # Paired Punctuation never made into official property;
10387 # appears to be gc=ps + gc=pe
10388 # Paragraph Separator duplicates UnicodeData.txt: gc=cc
10389 # Private Use duplicates UnicodeData.txt: gc=co
10390 # Private Use High Surrogate duplicates Blocks.txt
10391 # Punctuation duplicates UnicodeData.txt: gc=p
10392 # Space different definition than eventual
10394 # Titlecase duplicates UnicodeData.txt: gc=lt
10395 # Unassigned Code Value duplicates UnicodeData.txt: gc=cc
10396 # Zero-width never made into offical property;
10398 # Most of the properties have the same names in this file as in later
10399 # versions, but a couple do not.
10401 # This subroutine filters $_, converting it from the old style into
10402 # the new style. Here's a sample of the old-style
10404 # *******************************************
10406 # Property dump for: 0x100000A0 (Join Control)
10408 # 200C..200D (2 chars)
10410 # In the example, the property is "Join Control". It is kept in this
10411 # closure between calls to the subroutine. The numbers beginning with
10412 # 0x were internal to Ken's program that generated this file.
10414 # If this line contains the property name, extract it.
10415 if (/^Property dump for: [^(]*\((.*)\)/) {
10418 # Convert white space to underscores.
10421 # Convert the few properties that don't have the same name as
10422 # their modern counterparts
10423 s/Identifier_Part/ID_Continue/
10424 or s/Not_a_Character/NChar/;
10426 # If the name matches an existing property, use it.
10427 if (defined property_ref($_)) {
10428 trace "new property=", $_ if main::DEBUG && $to_trace;
10429 $current_property = $_;
10431 else { # Otherwise discard it
10432 trace "rejected property=", $_ if main::DEBUG && $to_trace;
10433 undef $current_property;
10435 $_ = ""; # The property is saved for the next lines of the
10436 # file, but this defining line is of no further use,
10437 # so clear it so that the caller won't process it
10440 elsif (! defined $current_property || $_ !~ /^$code_point_re/) {
10442 # Here, the input line isn't a header defining a property for the
10443 # following section, and either we aren't in such a section, or
10444 # the line doesn't look like one that defines the code points in
10445 # such a section. Ignore this line.
10450 # Here, we have a line defining the code points for the current
10451 # stashed property. Anything starting with the first blank is
10452 # extraneous. Otherwise, it should look like a normal range to
10453 # the caller. Append the property name so that it looks just like
10454 # a modern PropList entry.
10457 $_ .= "; $current_property";
10459 trace $_ if main::DEBUG && $to_trace;
10462 } # End closure for old style proplist
10464 sub filter_old_style_normalization_lines {
10465 # For early releases of Unicode, the lines were like:
10466 # 74..2A76 ; NFKD_NO
10467 # For later releases this became:
10468 # 74..2A76 ; NFKD_QC; N
10469 # Filter $_ to look like those in later releases.
10470 # Similarly for MAYBEs
10472 s/ _NO \b /_QC; N/x || s/ _MAYBE \b /_QC; M/x;
10474 # Also, the property FC_NFKC was abbreviated to FNC
10479 sub finish_Unicode() {
10480 # This routine should be called after all the Unicode files have been read
10482 # 1) Adds the mappings for code points missing from the files which have
10483 # defaults specified for them.
10484 # 2) At this this point all mappings are known, so it computes the type of
10485 # each property whose type hasn't been determined yet.
10486 # 3) Calculates all the regular expression match tables based on the
10488 # 3) Calculates and adds the tables which are defined by Unicode, but
10489 # which aren't derived by them
10491 # For each property, fill in any missing mappings, and calculate the re
10492 # match tables. If a property has more than one missing mapping, the
10493 # default is a reference to a data structure, and requires data from other
10494 # properties to resolve. The sort is used to cause these to be processed
10495 # last, after all the other properties have been calculated.
10496 # (Fortunately, the missing properties so far don't depend on each other.)
10497 foreach my $property
10498 (sort { (defined $a->default_map && ref $a->default_map) ? 1 : -1 }
10501 # $perl has been defined, but isn't one of the Unicode properties that
10502 # need to be finished up.
10503 next if $property == $perl;
10505 # Handle the properties that have more than one possible default
10506 if (ref $property->default_map) {
10507 my $default_map = $property->default_map;
10509 # These properties have stored in the default_map:
10511 # 1) A default map which applies to all code points in a
10513 # 2) an expression which will evaluate to the list of code
10514 # points in that class
10516 # 3) the default map which applies to every other missing code
10519 # Go through each list.
10520 while (my ($default, $eval) = $default_map->get_next_defaults) {
10522 # Get the class list, and intersect it with all the so-far
10523 # unspecified code points yielding all the code points
10524 # in the class that haven't been specified.
10525 my $list = eval $eval;
10527 Carp::my_carp("Can't set some defaults for missing code points for $property because eval '$eval' failed with '$@'");
10531 # Narrow down the list to just those code points we don't have
10533 $list = $list & $property->inverse_list;
10535 # Add mappings to the property for each code point in the list
10536 foreach my $range ($list->ranges) {
10537 $property->add_map($range->start, $range->end, $default);
10541 # All remaining code points have the other mapping. Set that up
10542 # so the normal single-default mapping code will work on them
10543 $property->set_default_map($default_map->other_default);
10545 # And fall through to do that
10548 # We should have enough data now to compute the type of the property.
10549 $property->compute_type;
10550 my $property_type = $property->type;
10552 next if ! $property->to_create_match_tables;
10554 # Here want to create match tables for this property
10556 # The Unicode db always (so far, and they claim into the future) have
10557 # the default for missing entries in binary properties be 'N' (unless
10558 # there is a '@missing' line that specifies otherwise)
10559 if ($property_type == $BINARY && ! defined $property->default_map) {
10560 $property->set_default_map('N');
10563 # Add any remaining code points to the mapping, using the default for
10564 # missing code points
10565 if (defined (my $default_map = $property->default_map)) {
10566 foreach my $range ($property->inverse_list->ranges) {
10567 $property->add_map($range->start, $range->end, $default_map);
10570 # Make sure there is a match table for the default
10571 if (! defined $property->table($default_map)) {
10572 $property->add_match_table($default_map);
10576 # Have all we need to populate the match tables.
10577 my $property_name = $property->name;
10578 foreach my $range ($property->ranges) {
10579 my $map = $range->value;
10580 my $table = property_ref($property_name)->table($map);
10581 if (! defined $table) {
10583 # Integral and rational property values are not necessarily
10584 # defined in PropValueAliases, but all other ones should be,
10586 if ($v_version ge v5.1.0
10587 && $map !~ /^ -? \d+ ( \/ \d+ )? $/x)
10589 Carp::my_carp("Table '$property_name=$map' should have been defined. Defining it now.")
10591 $table = property_ref($property_name)->add_match_table($map);
10594 $table->add_range($range->start, $range->end);
10597 # And add the Is_ prefix synonyms for Perl 5.6 compatibility, in which
10598 # all properties have this optional prefix. These do not get a
10599 # separate entry in the pod file, because are covered by a wild-card
10601 foreach my $alias ($property->aliases) {
10602 my $Is_name = 'Is_' . $alias->name;
10603 if (! defined (my $pre_existing = property_ref($Is_name))) {
10604 $property->add_alias($Is_name,
10606 Status => $alias->status,
10607 Externally_Ok => 0);
10611 # It seemed too much work to add in these warnings when it
10612 # appears that Unicode has made a decision never to begin a
10613 # property name with 'Is_', so this shouldn't happen, but just
10614 # in case, it is a warning.
10615 Carp::my_carp(<<END
10616 There is already an alias named $Is_name (from " . $pre_existing . "), so not
10617 creating this alias for $property. The generated table and pod files do not
10618 warn users of this conflict.
10621 $has_Is_conflicts++;
10623 } # End of loop through aliases for this property
10624 } # End of loop through all Unicode properties.
10626 # Fill in the mappings that Unicode doesn't completely furnish. First the
10627 # single letter major general categories. If Unicode were to start
10628 # delivering the values, this would be redundant, but better that than to
10629 # try to figure out if should skip and not get it right. Ths could happen
10630 # if a new major category were to be introduced, and the hard-coded test
10631 # wouldn't know about it.
10632 # This routine depends on the standard names for the general categories
10633 # being what it thinks they are, like 'Cn'. The major categories are the
10634 # union of all the general category tables which have the same first
10635 # letters. eg. L = Lu + Lt + Ll + Lo + Lm
10636 foreach my $minor_table ($gc->tables) {
10637 my $minor_name = $minor_table->name;
10638 next if length $minor_name == 1;
10639 if (length $minor_name != 2) {
10640 Carp::my_carp_bug("Unexpected general category '$minor_name'. Skipped.");
10644 my $major_name = uc(substr($minor_name, 0, 1));
10645 my $major_table = $gc->table($major_name);
10646 $major_table += $minor_table;
10649 # LC is Ll, Lu, and Lt. (used to be L& or L_, but PropValueAliases.txt
10650 # defines it as LC)
10651 my $LC = $gc->table('LC');
10652 $LC->add_alias('L_', Status => $DISCOURAGED); # For backwards...
10653 $LC->add_alias('L&', Status => $DISCOURAGED); # compatibility.
10656 if ($LC->is_empty) { # Assume if not empty that Unicode has started to
10657 # deliver the correct values in it
10658 $LC->initialize($gc->table('Ll') + $gc->table('Lu'));
10660 # Lt not in release 1.
10661 $LC += $gc->table('Lt') if defined $gc->table('Lt');
10663 $LC->add_description('[\p{Ll}\p{Lu}\p{Lt}]');
10665 my $Cs = $gc->table('Cs');
10667 $Cs->add_note('Mostly not usable in Perl.');
10668 $Cs->add_comment(join_lines(<<END
10669 Surrogates are used exclusively for I/O in UTF-16, and should not appear in
10670 Unicode text, and hence their use will generate (usually fatal) messages
10676 # Folding information was introduced later into Unicode data. To get
10677 # Perl's case ignore (/i) to work at all in releases that don't have
10678 # folding, use the best available alternative, which is lower casing.
10679 my $fold = property_ref('Simple_Case_Folding');
10680 if ($fold->is_empty) {
10681 $fold->initialize(property_ref('Simple_Lowercase_Mapping'));
10682 $fold->add_note(join_lines(<<END
10683 WARNING: This table uses lower case as a substitute for missing fold
10689 # Multiple-character mapping was introduced later into Unicode data. If
10690 # missing, use the single-characters maps as best available alternative
10691 foreach my $map (qw { Uppercase_Mapping
10696 my $full = property_ref($map);
10697 if ($full->is_empty) {
10698 my $simple = property_ref('Simple_' . $map);
10699 $full->initialize($simple);
10700 $full->add_comment($simple->comment) if ($simple->comment);
10701 $full->add_note(join_lines(<<END
10702 WARNING: This table uses simple mapping (single-character only) as a
10703 substitute for missing multiple-character information
10711 sub compile_perl() {
10712 # Create perl-defined tables. Almost all are part of the pseudo-property
10713 # named 'perl' internally to this program. Many of these are recommended
10714 # in UTS#18 "Unicode Regular Expressions", and their derivations are based
10715 # on those found there.
10716 # Almost all of these are equivalent to some Unicode property.
10717 # A number of these properties have equivalents restricted to the ASCII
10718 # range, with their names prefaced by 'Posix', to signify that these match
10719 # what the Posix standard says they should match. A couple are
10720 # effectively this, but the name doesn't have 'Posix' in it because there
10721 # just isn't any Posix equivalent.
10723 # 'Any' is all code points. As an error check, instead of just setting it
10724 # to be that, construct it to be the union of all the major categories
10725 my $Any = $perl->add_match_table('Any',
10726 Description => "[\\x{0000}-\\x{$LAST_UNICODE_CODEPOINT_STRING}]",
10729 foreach my $major_table ($gc->tables) {
10731 # Major categories are the ones with single letter names.
10732 next if length($major_table->name) != 1;
10734 $Any += $major_table;
10737 if ($Any->max != $LAST_UNICODE_CODEPOINT) {
10738 Carp::my_carp_bug("Generated highest code point ("
10739 . sprintf("%X", $Any->max)
10740 . ") doesn't match expected value $LAST_UNICODE_CODEPOINT_STRING.")
10742 if ($Any->range_count != 1 || $Any->min != 0) {
10743 Carp::my_carp_bug("Generated table 'Any' doesn't match all code points.")
10746 $Any->add_alias('All');
10748 # Assigned is the opposite of gc=unassigned
10749 my $Assigned = $perl->add_match_table('Assigned',
10750 Description => "All assigned code points",
10751 Initialize => ~ $gc->table('Unassigned'),
10754 # Our internal-only property should be treated as more than just a
10756 $perl->add_match_table('_CombAbove')
10757 ->set_equivalent_to(property_ref('ccc')->table('Above'),
10760 my $ASCII = $perl->add_match_table('ASCII', Description => '[[:ASCII:]]');
10761 if (defined $block) { # This is equivalent to the block if have it.
10762 my $Unicode_ASCII = $block->table('Basic_Latin');
10763 if (defined $Unicode_ASCII && ! $Unicode_ASCII->is_empty) {
10764 $ASCII->set_equivalent_to($Unicode_ASCII, Related => 1);
10768 # Very early releases didn't have blocks, so initialize ASCII ourselves if
10770 if ($ASCII->is_empty) {
10771 $ASCII->initialize([ 0..127 ]);
10774 # Get the best available case definitions. Early Unicode versions didn't
10775 # have Uppercase and Lowercase defined, so use the general category
10776 # instead for them.
10777 my $Lower = $perl->add_match_table('Lower');
10778 my $Unicode_Lower = property_ref('Lowercase');
10779 if (defined $Unicode_Lower && ! $Unicode_Lower->is_empty) {
10780 $Lower->set_equivalent_to($Unicode_Lower->table('Y'), Related => 1);
10783 $Lower->set_equivalent_to($gc->table('Lowercase_Letter'),
10786 $perl->add_match_table("PosixLower",
10787 Description => "[a-z]",
10788 Initialize => $Lower & $ASCII,
10791 my $Upper = $perl->add_match_table('Upper');
10792 my $Unicode_Upper = property_ref('Uppercase');
10793 if (defined $Unicode_Upper && ! $Unicode_Upper->is_empty) {
10794 $Upper->set_equivalent_to($Unicode_Upper->table('Y'), Related => 1);
10797 $Upper->set_equivalent_to($gc->table('Uppercase_Letter'),
10800 $perl->add_match_table("PosixUpper",
10801 Description => "[A-Z]",
10802 Initialize => $Upper & $ASCII,
10805 # Earliest releases didn't have title case. Initialize it to empty if not
10806 # otherwise present
10807 my $Title = $perl->add_match_table('Title');
10808 my $lt = $gc->table('Lt');
10810 $Title->set_equivalent_to($lt, Related => 1);
10813 # If this Unicode version doesn't have Cased, set up our own. From
10814 # Unicode 5.1: Definition D120: A character C is defined to be cased if
10815 # and only if C has the Lowercase or Uppercase property or has a
10816 # General_Category value of Titlecase_Letter.
10817 unless (defined property_ref('Cased')) {
10818 my $cased = $perl->add_match_table('Cased',
10819 Initialize => $Lower + $Upper + $Title,
10820 Description => 'Uppercase or Lowercase or Titlecase',
10824 # Similarly, set up our own Case_Ignorable property if this Unicode
10825 # version doesn't have it. From Unicode 5.1: Definition D121: A character
10826 # C is defined to be case-ignorable if C has the value MidLetter or the
10827 # value MidNumLet for the Word_Break property or its General_Category is
10828 # one of Nonspacing_Mark (Mn), Enclosing_Mark (Me), Format (Cf),
10829 # Modifier_Letter (Lm), or Modifier_Symbol (Sk).
10831 # Perl has long had an internal-only alias for this property.
10832 my $perl_case_ignorable = $perl->add_match_table('_Case_Ignorable');
10833 my $case_ignorable = property_ref('Case_Ignorable');
10834 if (defined $case_ignorable && ! $case_ignorable->is_empty) {
10835 $perl_case_ignorable->set_equivalent_to($case_ignorable->table('Y'),
10840 $perl_case_ignorable->initialize($gc->table('Mn') + $gc->table('Lm'));
10842 # The following three properties are not in early releases
10843 $perl_case_ignorable += $gc->table('Me') if defined $gc->table('Me');
10844 $perl_case_ignorable += $gc->table('Cf') if defined $gc->table('Cf');
10845 $perl_case_ignorable += $gc->table('Sk') if defined $gc->table('Sk');
10847 # For versions 4.1 - 5.0, there is no MidNumLet property, and
10848 # correspondingly the case-ignorable definition lacks that one. For
10849 # 4.0, it appears that it was meant to be the same definition, but was
10850 # inadvertently omitted from the standard's text, so add it if the
10851 # property actually is there
10852 my $wb = property_ref('Word_Break');
10854 my $midlet = $wb->table('MidLetter');
10855 $perl_case_ignorable += $midlet if defined $midlet;
10856 my $midnumlet = $wb->table('MidNumLet');
10857 $perl_case_ignorable += $midnumlet if defined $midnumlet;
10861 # In earlier versions of the standard, instead of the above two
10862 # properties , just the following characters were used:
10863 $perl_case_ignorable += 0x0027 # APOSTROPHE
10864 + 0x00AD # SOFT HYPHEN (SHY)
10865 + 0x2019; # RIGHT SINGLE QUOTATION MARK
10869 # The remaining perl defined tables are mostly based on Unicode TR 18,
10870 # "Annex C: Compatibility Properties". All of these have two versions,
10871 # one whose name generally begins with Posix that is posix-compliant, and
10872 # one that matches Unicode characters beyond the Posix, ASCII range
10874 my $Alpha = $perl->add_match_table('Alpha');
10876 # Alphabetic was not present in early releases
10877 my $Alphabetic = property_ref('Alphabetic');
10878 if (defined $Alphabetic && ! $Alphabetic->is_empty) {
10879 $Alpha->set_equivalent_to($Alphabetic->table('Y'), Related => 1);
10883 # For early releases, we don't get it exactly right. The below
10884 # includes more than it should, which in 5.2 terms is: L + Nl +
10885 # Other_Alphabetic. Other_Alphabetic contains many characters from
10886 # Mn and Mc. It's better to match more than we should, than less than
10888 $Alpha->initialize($gc->table('Letter')
10890 + $gc->table('Mc'));
10891 $Alpha += $gc->table('Nl') if defined $gc->table('Nl');
10892 $Alpha->add_description('Alphabetic');
10894 $perl->add_match_table("PosixAlpha",
10895 Description => "[A-Za-z]",
10896 Initialize => $Alpha & $ASCII,
10899 my $Alnum = $perl->add_match_table('Alnum',
10900 Description => 'Alphabetic and (Decimal) Numeric',
10901 Initialize => $Alpha + $gc->table('Decimal_Number'),
10903 $perl->add_match_table("PosixAlnum",
10904 Description => "[A-Za-z0-9]",
10905 Initialize => $Alnum & $ASCII,
10908 my $Word = $perl->add_match_table('Word',
10909 Description => '\w, including beyond ASCII',
10910 Initialize => $Alnum + $gc->table('Mark'),
10912 my $Pc = $gc->table('Connector_Punctuation'); # 'Pc' Not in release 1
10913 $Word += $Pc if defined $Pc;
10915 # This is a Perl extension, so the name doesn't begin with Posix.
10916 $perl->add_match_table('PerlWord',
10917 Description => '\w, restricted to ASCII = [A-Za-z0-9_]',
10918 Initialize => $Word & $ASCII,
10921 my $Blank = $perl->add_match_table('Blank',
10922 Description => '\h, Horizontal white space',
10924 # 200B is Zero Width Space which is for line
10925 # break control, and was listed as
10926 # Space_Separator in early releases
10927 Initialize => $gc->table('Space_Separator')
10931 $Blank->add_alias('HorizSpace'); # Another name for it.
10932 $perl->add_match_table("PosixBlank",
10933 Description => "\\t and ' '",
10934 Initialize => $Blank & $ASCII,
10937 my $VertSpace = $perl->add_match_table('VertSpace',
10938 Description => '\v',
10939 Initialize => $gc->table('Line_Separator')
10940 + $gc->table('Paragraph_Separator')
10941 + 0x000A # LINE FEED
10942 + 0x000B # VERTICAL TAB
10943 + 0x000C # FORM FEED
10944 + 0x000D # CARRIAGE RETURN
10947 # No Posix equivalent for vertical space
10949 my $Space = $perl->add_match_table('Space',
10950 Description => '\s including beyond ASCII plus vertical tab',
10951 Initialize => $Blank + $VertSpace,
10953 $perl->add_match_table("PosixSpace",
10954 Description => "\\t, \\n, \\cK, \\f, \\r, and ' '. (\\cK is vertical tab)",
10955 Initialize => $Space & $ASCII,
10958 # Perl's traditional space doesn't include Vertical Tab
10959 my $SpacePerl = $perl->add_match_table('SpacePerl',
10960 Description => '\s, including beyond ASCII',
10961 Initialize => $Space - 0x000B,
10963 $perl->add_match_table('PerlSpace',
10964 Description => '\s, restricted to ASCII',
10965 Initialize => $SpacePerl & $ASCII,
10968 my $Cntrl = $perl->add_match_table('Cntrl',
10969 Description => 'Control characters');
10970 $Cntrl->set_equivalent_to($gc->table('Cc'), Related => 1);
10971 $perl->add_match_table("PosixCntrl",
10972 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",
10973 Initialize => $Cntrl & $ASCII,
10976 # $controls is a temporary used to construct Graph.
10977 my $controls = Range_List->new(Initialize => $gc->table('Unassigned')
10978 + $gc->table('Control'));
10979 # Cs not in release 1
10980 $controls += $gc->table('Surrogate') if defined $gc->table('Surrogate');
10982 # Graph is ~space & ~(Cc|Cs|Cn) = ~(space + $controls)
10983 my $Graph = $perl->add_match_table('Graph',
10984 Description => 'Characters that are graphical',
10985 Initialize => ~ ($Space + $controls),
10987 $perl->add_match_table("PosixGraph",
10989 '[-!"#$%&\'()*+,./:;<>?@[\\\]^_`{|}~0-9A-Za-z]',
10990 Initialize => $Graph & $ASCII,
10993 my $Print = $perl->add_match_table('Print',
10994 Description => 'Characters that are graphical plus space characters (but no controls)',
10995 Initialize => $Blank + $Graph - $gc->table('Control'),
10997 $perl->add_match_table("PosixPrint",
10999 '[- 0-9A-Za-z!"#$%&\'()*+,./:;<>?@[\\\]^_`{|}~]',
11000 Initialize => $Print & $ASCII,
11003 my $Punct = $perl->add_match_table('Punct');
11004 $Punct->set_equivalent_to($gc->table('Punctuation'), Related => 1);
11006 # \p{punct} doesn't include the symbols, which posix does
11007 $perl->add_match_table('PosixPunct',
11008 Description => '[-!"#$%&\'()*+,./:;<>?@[\\\]^_`{|}~]',
11009 Initialize => $ASCII & ($gc->table('Punctuation')
11010 + $gc->table('Symbol')),
11013 my $Digit = $perl->add_match_table('Digit',
11014 Description => '\d, extended beyond just [0-9]');
11015 $Digit->set_equivalent_to($gc->table('Decimal_Number'), Related => 1);
11016 my $PosixDigit = $perl->add_match_table("PosixDigit",
11017 Description => '[0-9]',
11018 Initialize => $Digit & $ASCII,
11021 # Hex_Digit was not present in first release
11022 my $Xdigit = $perl->add_match_table('XDigit');
11023 my $Hex = property_ref('Hex_Digit');
11024 if (defined $Hex && ! $Hex->is_empty) {
11025 $Xdigit->set_equivalent_to($Hex->table('Y'), Related => 1);
11028 # (Have to use hex instead of e.g. '0', because could be running on an
11029 # non-ASCII machine, and we want the Unicode (ASCII) values)
11030 $Xdigit->initialize([ 0x30..0x39, 0x41..0x46, 0x61..0x66,
11031 0xFF10..0xFF19, 0xFF21..0xFF26, 0xFF41..0xFF46]);
11032 $Xdigit->add_description('[0-9A-Fa-f] and corresponding fullwidth versions, like U+FF10: FULLWIDTH DIGIT ZERO');
11035 my $dt = property_ref('Decomposition_Type');
11036 $dt->add_match_table('Non_Canon', Full_Name => 'Non_Canonical',
11037 Initialize => ~ ($dt->table('None') + $dt->table('Canonical')),
11038 Perl_Extension => 1,
11039 Note => 'Union of all non-canonical decompositions',
11042 # _CanonDCIJ is equivalent to Soft_Dotted, but if on a release earlier
11043 # than SD appeared, construct it ourselves, based on the first release SD
11045 my $CanonDCIJ = $perl->add_match_table('_CanonDCIJ');
11046 my $soft_dotted = property_ref('Soft_Dotted');
11047 if (defined $soft_dotted && ! $soft_dotted->is_empty) {
11048 $CanonDCIJ->set_equivalent_to($soft_dotted->table('Y'), Related => 1);
11052 # This list came from 3.2 Soft_Dotted.
11053 $CanonDCIJ->initialize([ 0x0069,
11062 $CanonDCIJ = $CanonDCIJ & $Assigned;
11065 # These are used in Unicode's definition of \X
11066 my $begin = $perl->add_match_table('_X_Begin', Perl_Extension => 1);
11067 my $extend = $perl->add_match_table('_X_Extend', Perl_Extension => 1);
11069 my $gcb = property_ref('Grapheme_Cluster_Break');
11071 # The 'extended' grapheme cluster came in 5.1. The non-extended
11072 # definition differs too much from the traditional Perl one to use.
11073 if (defined $gcb && defined $gcb->table('SpacingMark')) {
11075 # Note that assumes HST is defined; it came in an earlier release than
11076 # GCB. In the line below, two negatives means: yes hangul
11077 $begin += ~ property_ref('Hangul_Syllable_Type')
11078 ->table('Not_Applicable')
11079 + ~ ($gcb->table('Control')
11080 + $gcb->table('CR')
11081 + $gcb->table('LF'));
11082 $begin->add_comment('For use in \X; matches: Hangul_Syllable | ! Control');
11084 $extend += $gcb->table('Extend') + $gcb->table('SpacingMark');
11085 $extend->add_comment('For use in \X; matches: Extend | SpacingMark');
11087 else { # Old definition, used on early releases.
11088 $extend += $gc->table('Mark')
11091 $begin += ~ $extend;
11093 # Here we may have a release that has the regular grapheme cluster
11094 # defined, or a release that doesn't have anything defined.
11095 # We set things up so the Perl core degrades gracefully, possibly with
11096 # placeholders that match nothing.
11098 if (! defined $gcb) {
11099 $gcb = Property->new('GCB', Status => $PLACEHOLDER);
11101 my $hst = property_ref('HST');
11102 if (!defined $hst) {
11103 $hst = Property->new('HST', Status => $PLACEHOLDER);
11104 $hst->add_match_table('Not_Applicable',
11105 Initialize => $Any,
11109 # On some releases, here we may not have the needed tables for the
11110 # perl core, in some releases we may.
11111 foreach my $name (qw{ L LV LVT T V prepend }) {
11112 my $table = $gcb->table($name);
11113 if (! defined $table) {
11114 $table = $gcb->add_match_table($name);
11115 push @tables_that_may_be_empty, $table->complete_name;
11118 # The HST property predates the GCB one, and has identical tables
11119 # for some of them, so use it if we can.
11120 if ($table->is_empty
11122 && defined $hst->table($name))
11124 $table += $hst->table($name);
11129 # More GCB. If we found some hangul syllables, populate a combined
11131 my $lv_lvt_v = $perl->add_match_table('_X_LV_LVT_V');
11132 my $LV = $gcb->table('LV');
11133 if ($LV->is_empty) {
11134 push @tables_that_may_be_empty, $lv_lvt_v->complete_name;
11136 $lv_lvt_v += $LV + $gcb->table('LVT') + $gcb->table('V');
11137 $lv_lvt_v->add_comment('For use in \X; matches: HST=LV | HST=LVT | HST=V');
11140 my $perl_charname = property_ref('Perl_Charnames');
11141 # Was previously constructed to contain both Name and Unicode_1_Name
11142 my @composition = ('Name', 'Unicode_1_Name');
11144 if (@named_sequences) {
11145 push @composition, 'Named_Sequence';
11146 foreach my $sequence (@named_sequences) {
11147 $perl_charname->add_anomalous_entry($sequence);
11151 my $alias_sentence = "";
11152 my $alias = property_ref('Name_Alias');
11153 if (defined $alias) {
11154 push @composition, 'Name_Alias';
11155 $alias->reset_each_range;
11156 while (my ($range) = $alias->each_range) {
11157 next if $range->value eq "";
11158 if ($range->start != $range->end) {
11159 Carp::my_carp("Expecting only one code point in the range $range. Just to keep going, using just the first code point;");
11161 $perl_charname->add_duplicate($range->start, $range->value);
11163 $alias_sentence = <<END;
11164 The Name_Alias property adds duplicate code point entries with a corrected
11165 name. The original (less correct, but still valid) name will be physically
11170 if (@composition <= 2) { # Always at least 2
11171 $comment = join " and ", @composition;
11174 $comment = join ", ", @composition[0 .. scalar @composition - 2];
11175 $comment .= ", and $composition[-1]";
11178 # Wait for charnames to catch up
11179 # foreach my $entry (@more_Names,
11180 # split "\n", <<"END"
11188 #FEFF; BYTE ORDER MARK
11191 # #local $to_trace = 1 if main::DEBUG;
11192 # trace $entry if main::DEBUG && $to_trace;
11193 # my ($code_point, $name) = split /\s*;\s*/, $entry;
11194 # $code_point = hex $code_point;
11195 # trace $code_point, $name if main::DEBUG && $to_trace;
11196 # $perl_charname->add_duplicate($code_point, $name);
11198 # #$perl_charname->add_comment("This file is for charnames.pm. It is the union of the $comment properties, plus certain commonly used but unofficial names, such as 'FF' and 'ZWNJ'. Unicode_1_Name entries are used only for otherwise nameless code points.$alias_sentence");
11199 $perl_charname->add_comment(join_lines( <<END
11200 This file is for charnames.pm. It is the union of the $comment properties.
11201 Unicode_1_Name entries are used only for otherwise nameless code
11207 # The combining class property used by Perl's normalize.pm is not located
11208 # in the normal mapping directory; create a copy for it.
11209 my $ccc = property_ref('Canonical_Combining_Class');
11210 my $perl_ccc = Property->new('Perl_ccc',
11211 Default_Map => $ccc->default_map,
11212 Full_Name => 'Perl_Canonical_Combining_Class',
11213 Internal_Only_Warning => 1,
11214 Perl_Extension => 1,
11217 Initialize => $ccc,
11218 File => 'CombiningClass',
11219 Directory => File::Spec->curdir(),
11221 $perl_ccc->set_to_output_map(1);
11222 $perl_ccc->add_comment(join_lines(<<END
11223 This mapping is for normalize.pm. It is currently identical to the Unicode
11224 Canonical_Combining_Class property.
11228 # This one match table for it is needed for calculations on output
11229 my $default = $perl_ccc->add_match_table($ccc->default_map,
11230 Initialize => $ccc->table($ccc->default_map),
11231 Status => $SUPPRESSED);
11233 # Construct the Present_In property from the Age property.
11234 if (-e 'DAge.txt' && defined (my $age = property_ref('Age'))) {
11235 my $default_map = $age->default_map;
11236 my $in = Property->new('In',
11237 Default_Map => $default_map,
11238 Full_Name => "Present_In",
11239 Internal_Only_Warning => 1,
11240 Perl_Extension => 1,
11242 Initialize => $age,
11244 $in->add_comment(join_lines(<<END
11245 This file should not be used for any purpose. The values in this file are the
11246 same as for $age, and not for what $in really means. This is because anything
11247 defined in a given release should have multiple values: that release and all
11248 higher ones. But only one value per code point can be represented in a table
11253 # The Age tables are named like 1.5, 2.0, 2.1, .... Sort so that the
11254 # lowest numbered (earliest) come first, with the non-numeric one
11256 my ($first_age, @rest_ages) = sort { ($a->name !~ /^[\d.]*$/)
11258 : ($b->name !~ /^[\d.]*$/)
11260 : $a->name <=> $b->name
11263 # The Present_In property is the cumulative age properties. The first
11264 # one hence is identical to the first age one.
11265 my $previous_in = $in->add_match_table($first_age->name);
11266 $previous_in->set_equivalent_to($first_age, Related => 1);
11268 my $description_start = "Code point's usage introduced in version ";
11269 $first_age->add_description($description_start . $first_age->name);
11271 # To construct the accumlated values, for each of the age tables
11272 # starting with the 2nd earliest, merge the earliest with it, to get
11273 # all those code points existing in the 2nd earliest. Repeat merging
11274 # the new 2nd earliest with the 3rd earliest to get all those existing
11275 # in the 3rd earliest, and so on.
11276 foreach my $current_age (@rest_ages) {
11277 next if $current_age->name !~ /^[\d.]*$/; # Skip the non-numeric
11279 my $current_in = $in->add_match_table(
11280 $current_age->name,
11281 Initialize => $current_age + $previous_in,
11282 Description => $description_start
11283 . $current_age->name
11286 $previous_in = $current_in;
11288 # Add clarifying material for the corresponding age file. This is
11289 # in part because of the confusing and contradictory information
11290 # given in the Standard's documentation itself, as of 5.2.
11291 $current_age->add_description(
11292 "Code point's usage was introduced in version "
11293 . $current_age->name);
11294 $current_age->add_note("See also $in");
11298 # And finally the code points whose usages have yet to be decided are
11299 # the same in both properties. Note that permanently unassigned code
11300 # points actually have their usage assigned (as being permanently
11301 # unassigned), so that these tables are not the same as gc=cn.
11302 my $unassigned = $in->add_match_table($default_map);
11303 my $age_default = $age->table($default_map);
11304 $age_default->add_description(<<END
11305 Code point's usage has not been assigned in any Unicode release thus far.
11308 $unassigned->set_equivalent_to($age_default, Related => 1);
11312 # Finished creating all the perl properties. All non-internal non-string
11313 # ones have a synonym of 'Is_' prefixed. (Internal properties begin with
11314 # an underscore.) These do not get a separate entry in the pod file
11315 foreach my $table ($perl->tables) {
11316 foreach my $alias ($table->aliases) {
11317 next if $alias->name =~ /^_/;
11318 $table->add_alias('Is_' . $alias->name,
11320 Status => $alias->status,
11321 Externally_Ok => 0);
11328 sub add_perl_synonyms() {
11329 # A number of Unicode tables have Perl synonyms that are expressed in
11330 # the single-form, \p{name}. These are:
11331 # All the binary property Y tables, so that \p{Name=Y} gets \p{Name} and
11332 # \p{Is_Name} as synonyms
11333 # \p{Script=Value} gets \p{Value}, \p{Is_Value} as synonyms
11334 # \p{General_Category=Value} gets \p{Value}, \p{Is_Value} as synonyms
11335 # \p{Block=Value} gets \p{In_Value} as a synonym, and, if there is no
11336 # conflict, \p{Value} and \p{Is_Value} as well
11338 # This routine generates these synonyms, warning of any unexpected
11341 # Construct the list of tables to get synonyms for. Start with all the
11342 # binary and the General_Category ones.
11343 my @tables = grep { $_->type == $BINARY } property_ref('*');
11344 push @tables, $gc->tables;
11346 # If the version of Unicode includes the Script property, add its tables
11347 if (defined property_ref('Script')) {
11348 push @tables, property_ref('Script')->tables;
11351 # The Block tables are kept separate because they are treated differently.
11352 # And the earliest versions of Unicode didn't include them, so add only if
11355 push @blocks, $block->tables if defined $block;
11357 # Here, have the lists of tables constructed. Process blocks last so that
11358 # if there are name collisions with them, blocks have lowest priority.
11359 # Should there ever be other collisions, manual intervention would be
11360 # required. See the comments at the beginning of the program for a
11361 # possible way to handle those semi-automatically.
11362 foreach my $table (@tables, @blocks) {
11364 # For non-binary properties, the synonym is just the name of the
11365 # table, like Greek, but for binary properties the synonym is the name
11366 # of the property, and means the code points in its 'Y' table.
11367 my $nominal = $table;
11368 my $nominal_property = $nominal->property;
11370 if (! $nominal->isa('Property')) {
11375 # Here is a binary property. Use the 'Y' table. Verify that is
11377 my $yes = $nominal->table('Y');
11378 unless (defined $yes) { # Must be defined, but is permissible to
11380 Carp::my_carp_bug("Undefined $nominal, 'Y'. Skipping.");
11386 foreach my $alias ($nominal->aliases) {
11388 # Attempt to create a table in the perl directory for the
11389 # candidate table, using whatever aliases in it that don't
11390 # conflict. Also add non-conflicting aliases for all these
11391 # prefixed by 'Is_' (and/or 'In_' for Block property tables)
11393 foreach my $prefix ("", 'Is_', 'In_') {
11395 # Only Block properties can have added 'In_' aliases.
11396 next if $prefix eq 'In_' and $nominal_property != $block;
11398 my $proposed_name = $prefix . $alias->name;
11400 # No Is_Is, In_In, nor combinations thereof
11401 trace "$proposed_name is a no-no" if main::DEBUG && $to_trace && $proposed_name =~ /^ I [ns] _I [ns] _/x;
11402 next if $proposed_name =~ /^ I [ns] _I [ns] _/x;
11404 trace "Seeing if can add alias or table: 'perl=$proposed_name' based on $nominal" if main::DEBUG && $to_trace;
11406 # Get a reference to any existing table in the perl
11407 # directory with the desired name.
11408 my $pre_existing = $perl->table($proposed_name);
11410 if (! defined $pre_existing) {
11412 # No name collision, so ok to add the perl synonym.
11414 my $make_pod_entry;
11416 my $status = $actual->status;
11417 if ($nominal_property == $block) {
11419 # For block properties, the 'In' form is preferred for
11420 # external use; the pod file contains wild cards for
11421 # this and the 'Is' form so no entries for those; and
11422 # we don't want people using the name without the
11423 # 'In', so discourage that.
11424 if ($prefix eq "") {
11425 $make_pod_entry = 1;
11426 $status = $status || $DISCOURAGED;
11427 $externally_ok = 0;
11429 elsif ($prefix eq 'In_') {
11430 $make_pod_entry = 0;
11431 $status = $status || $NORMAL;
11432 $externally_ok = 1;
11435 $make_pod_entry = 0;
11436 $status = $status || $DISCOURAGED;
11437 $externally_ok = 0;
11440 elsif ($prefix ne "") {
11442 # The 'Is' prefix is handled in the pod by a wild
11443 # card, and we won't use it for an external name
11444 $make_pod_entry = 0;
11445 $status = $status || $NORMAL;
11446 $externally_ok = 0;
11450 # Here, is an empty prefix, non block. This gets its
11451 # own pod entry and can be used for an external name.
11452 $make_pod_entry = 1;
11453 $status = $status || $NORMAL;
11454 $externally_ok = 1;
11457 # Here, there isn't a perl pre-existing table with the
11458 # name. Look through the list of equivalents of this
11459 # table to see if one is a perl table.
11460 foreach my $equivalent ($actual->leader->equivalents) {
11461 next if $equivalent->property != $perl;
11463 # Here, have found a table for $perl. Add this alias
11464 # to it, and are done with this prefix.
11465 $equivalent->add_alias($proposed_name,
11466 Pod_Entry => $make_pod_entry,
11468 Externally_Ok => $externally_ok);
11469 trace "adding alias perl=$proposed_name to $equivalent" if main::DEBUG && $to_trace;
11473 # Here, $perl doesn't already have a table that is a
11474 # synonym for this property, add one.
11475 my $added_table = $perl->add_match_table($proposed_name,
11476 Pod_Entry => $make_pod_entry,
11478 Externally_Ok => $externally_ok);
11479 # And it will be related to the actual table, since it is
11481 $added_table->set_equivalent_to($actual, Related => 1);
11482 trace "added ", $perl->table($proposed_name) if main::DEBUG && $to_trace;
11484 } # End of no pre-existing.
11486 # Here, there is a pre-existing table that has the proposed
11487 # name. We could be in trouble, but not if this is just a
11488 # synonym for another table that we have already made a child
11489 # of the pre-existing one.
11490 if ($pre_existing->is_equivalent_to($actual)) {
11491 trace "$pre_existing is already equivalent to $actual; adding alias perl=$proposed_name to it" if main::DEBUG && $to_trace;
11492 $pre_existing->add_alias($proposed_name);
11496 # Here, there is a name collision, but it still could be ok if
11497 # the tables match the identical set of code points, in which
11498 # case, we can combine the names. Compare each table's code
11499 # point list to see if they are identical.
11500 trace "Potential name conflict with $pre_existing having ", $pre_existing->count, " code points" if main::DEBUG && $to_trace;
11501 if ($pre_existing->matches_identically_to($actual)) {
11503 # Here, they do match identically. Not a real conflict.
11504 # Make the perl version a child of the Unicode one, except
11505 # in the non-obvious case of where the perl name is
11506 # already a synonym of another Unicode property. (This is
11507 # excluded by the test for it being its own parent.) The
11508 # reason for this exclusion is that then the two Unicode
11509 # properties become related; and we don't really know if
11510 # they are or not. We generate documentation based on
11511 # relatedness, and this would be misleading. Code
11512 # later executed in the process will cause the tables to
11513 # be represented by a single file anyway, without making
11514 # it look in the pod like they are necessarily related.
11515 if ($pre_existing->parent == $pre_existing
11516 && ($pre_existing->property == $perl
11517 || $actual->property == $perl))
11519 trace "Setting $pre_existing equivalent to $actual since one is \$perl, and match identical sets" if main::DEBUG && $to_trace;
11520 $pre_existing->set_equivalent_to($actual, Related => 1);
11522 elsif (main::DEBUG && $to_trace) {
11523 trace "$pre_existing is equivalent to $actual since match identical sets, but not setting them equivalent, to preserve the separateness of the perl aliases";
11524 trace $pre_existing->parent;
11529 # Here they didn't match identically, there is a real conflict
11530 # between our new name and a pre-existing property.
11531 $actual->add_conflicting($proposed_name, 'p', $pre_existing);
11532 $pre_existing->add_conflicting($nominal->full_name,
11536 # Don't output a warning for aliases for the block
11537 # properties (unless they start with 'In_') as it is
11538 # expected that there will be conflicts and the block
11540 if ($verbosity >= $NORMAL_VERBOSITY
11541 && ($actual->property != $block || $prefix eq 'In_'))
11543 print simple_fold(join_lines(<<END
11544 There is already an alias named $proposed_name (from " . $pre_existing . "),
11545 so not creating this alias for " . $actual
11550 # Keep track for documentation purposes.
11551 $has_In_conflicts++ if $prefix eq 'In_';
11552 $has_Is_conflicts++ if $prefix eq 'Is_';
11557 # There are some properties which have No and Yes (and N and Y) as
11558 # property values, but aren't binary, and could possibly be confused with
11559 # binary ones. So create caveats for them. There are tables that are
11560 # named 'No', and tables that are named 'N', but confusion is not likely
11561 # unless they are the same table. For example, N meaning Number or
11562 # Neutral is not likely to cause confusion, so don't add caveats to things
11564 foreach my $property (grep { $_->type != $BINARY } property_ref('*')) {
11565 my $yes = $property->table('Yes');
11566 if (defined $yes) {
11567 my $y = $property->table('Y');
11568 if (defined $y && $yes == $y) {
11569 foreach my $alias ($property->aliases) {
11570 $yes->add_conflicting($alias->name);
11574 my $no = $property->table('No');
11576 my $n = $property->table('N');
11577 if (defined $n && $no == $n) {
11578 foreach my $alias ($property->aliases) {
11579 $no->add_conflicting($alias->name, 'P');
11588 sub register_file_for_name($$$) {
11589 # Given info about a table and a datafile that it should be associated
11590 # with, register that assocation
11593 my $directory_ref = shift; # Array of the directory path for the file
11594 my $file = shift; # The file name in the final directory, [-1].
11595 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
11597 trace "table=$table, file=$file, directory=@$directory_ref" if main::DEBUG && $to_trace;
11599 if ($table->isa('Property')) {
11600 $table->set_file_path(@$directory_ref, $file);
11601 push @map_properties, $table
11602 if $directory_ref->[0] eq $map_directory;
11606 # Do all of the work for all equivalent tables when called with the leader
11607 # table, so skip if isn't the leader.
11608 return if $table->leader != $table;
11610 # Join all the file path components together, using slashes.
11611 my $full_filename = join('/', @$directory_ref, $file);
11613 # All go in the same subdirectory of unicore
11614 if ($directory_ref->[0] ne $matches_directory) {
11615 Carp::my_carp("Unexpected directory in "
11616 . join('/', @{$directory_ref}, $file));
11619 # For this table and all its equivalents ...
11620 foreach my $table ($table, $table->equivalents) {
11622 # Associate it with its file internally. Don't include the
11623 # $matches_directory first component
11624 $table->set_file_path(@$directory_ref, $file);
11625 my $sub_filename = join('/', $directory_ref->[1, -1], $file);
11627 my $property = $table->property;
11628 $property = ($property == $perl)
11629 ? "" # 'perl' is never explicitly stated
11630 : standardize($property->name) . '=';
11632 my $deprecated = ($table->status eq $DEPRECATED)
11633 ? $table->status_info
11636 # And for each of the table's aliases... This inner loop eventually
11637 # goes through all aliases in the UCD that we generate regex match
11639 foreach my $alias ($table->aliases) {
11640 my $name = $alias->name;
11642 # Generate an entry in either the loose or strict hashes, which
11643 # will translate the property and alias names combination into the
11644 # file where the table for them is stored.
11646 if ($alias->loose_match) {
11647 $standard = $property . standardize($alias->name);
11648 if (exists $loose_to_file_of{$standard}) {
11649 Carp::my_carp("Can't change file registered to $loose_to_file_of{$standard} to '$sub_filename'.");
11652 $loose_to_file_of{$standard} = $sub_filename;
11656 $standard = lc ($property . $name);
11657 if (exists $stricter_to_file_of{$standard}) {
11658 Carp::my_carp("Can't change file registered to $stricter_to_file_of{$standard} to '$sub_filename'.");
11661 $stricter_to_file_of{$standard} = $sub_filename;
11663 # Tightly coupled with how utf8_heavy.pl works, for a
11664 # floating point number that is a whole number, get rid of
11665 # the trailing decimal point and 0's, so that utf8_heavy
11666 # will work. Also note that this assumes that such a
11667 # number is matched strictly; so if that were to change,
11668 # this would be wrong.
11669 if ((my $integer_name = $name)
11670 =~ s/^ ( -? \d+ ) \.0+ $ /$1/x)
11672 $stricter_to_file_of{$property . $integer_name}
11678 # Keep a list of the deprecated properties and their filenames
11680 $utf8::why_deprecated{$sub_filename} = $deprecated;
11689 my %base_names; # Names already used for avoiding DOS 8.3 filesystem
11691 my %full_dir_name_of; # Full length names of directories used.
11693 sub construct_filename($$$) {
11694 # Return a file name for a table, based on the table name, but perhaps
11695 # changed to get rid of non-portable characters in it, and to make
11696 # sure that it is unique on a file system that allows the names before
11697 # any period to be at most 8 characters (DOS). While we're at it
11698 # check and complain if there are any directory conflicts.
11700 my $name = shift; # The name to start with
11701 my $mutable = shift; # Boolean: can it be changed? If no, but
11702 # yet it must be to work properly, a warning
11704 my $directories_ref = shift; # A reference to an array containing the
11705 # path to the file, with each element one path
11706 # component. This is used because the same
11707 # name can be used in different directories.
11708 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
11710 my $warn = ! defined wantarray; # If true, then if the name is
11711 # changed, a warning is issued as well.
11713 if (! defined $name) {
11714 Carp::my_carp("Undefined name in directory "
11715 . File::Spec->join(@$directories_ref)
11720 # Make sure that no directory names conflict with each other. Look at
11721 # each directory in the input file's path. If it is already in use,
11722 # assume it is correct, and is merely being re-used, but if we
11723 # truncate it to 8 characters, and find that there are two directories
11724 # that are the same for the first 8 characters, but differ after that,
11725 # then that is a problem.
11726 foreach my $directory (@$directories_ref) {
11727 my $short_dir = substr($directory, 0, 8);
11728 if (defined $full_dir_name_of{$short_dir}) {
11729 next if $full_dir_name_of{$short_dir} eq $directory;
11730 Carp::my_carp("$directory conflicts with $full_dir_name_of{$short_dir}. Bad News. Continuing anyway");
11733 $full_dir_name_of{$short_dir} = $directory;
11737 my $path = join '/', @$directories_ref;
11738 $path .= '/' if $path;
11740 # Remove interior underscores.
11741 (my $filename = $name) =~ s/ (?<=.) _ (?=.) //xg;
11743 # Change any non-word character into an underscore, and truncate to 8.
11744 $filename =~ s/\W+/_/g; # eg., "L&" -> "L_"
11745 substr($filename, 8) = "" if length($filename) > 8;
11747 # Make sure the basename doesn't conflict with something we
11748 # might have already written. If we have, say,
11755 while (my $num = $base_names{$path}{lc $filename}++) {
11756 $num++; # so basenames with numbers start with '2', which
11757 # just looks more natural.
11759 # Want to append $num, but if it'll make the basename longer
11760 # than 8 characters, pre-truncate $filename so that the result
11762 my $delta = length($filename) + length($num) - 8;
11764 substr($filename, -$delta) = $num;
11769 if ($warn && ! $warned) {
11771 Carp::my_carp("'$path$name' conflicts with another name on a filesystem with 8 significant characters (like DOS). Proceeding anyway.");
11775 return $filename if $mutable;
11777 # If not changeable, must return the input name, but warn if needed to
11778 # change it beyond shortening it.
11779 if ($name ne $filename
11780 && substr($name, 0, length($filename)) ne $filename) {
11781 Carp::my_carp("'$path$name' had to be changed into '$filename'. Bad News. Proceeding anyway.");
11787 # The pod file contains a very large table. Many of the lines in that table
11788 # would exceed a typical output window's size, and so need to be wrapped with
11789 # a hanging indent to make them look good. The pod language is really
11790 # insufficient here. There is no general construct to do that in pod, so it
11791 # is done here by beginning each such line with a space to cause the result to
11792 # be output without formatting, and doing all the formatting here. This leads
11793 # to the result that if the eventual display window is too narrow it won't
11794 # look good, and if the window is too wide, no advantage is taken of that
11795 # extra width. A further complication is that the output may be indented by
11796 # the formatter so that there is less space than expected. What I (khw) have
11797 # done is to assume that that indent is a particular number of spaces based on
11798 # what it is in my Linux system; people can always resize their windows if
11799 # necessary, but this is obviously less than desirable, but the best that can
11801 my $automatic_pod_indent = 8;
11803 # Try to format so that uses fewest lines, but few long left column entries
11804 # slide into the right column. An experiment on 5.1 data yielded the
11805 # following percentages that didn't cut into the other side along with the
11806 # associated first-column widths
11808 # 80% not too bad except for a few blocks
11809 # 90% = 33; # , cuts 353/3053 lines from 37 = 12%
11811 my $indent_info_column = 27; # 75% of lines didn't have overlap
11813 my $FILLER = 3; # Length of initial boiler-plate columns in a pod line
11814 # The 3 is because of:
11815 # 1 for the leading space to tell the pod formatter to
11818 # 1 for the space between the flag and the main data
11820 sub format_pod_line ($$$;$$) {
11821 # Take a pod line and return it, formatted properly
11823 my $first_column_width = shift;
11824 my $entry = shift; # Contents of left column
11825 my $info = shift; # Contents of right column
11827 my $status = shift || ""; # Any flag
11829 my $loose_match = shift; # Boolean.
11830 $loose_match = 1 unless defined $loose_match;
11832 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
11835 $flags .= $STRICTER if ! $loose_match;
11837 $flags .= $status if $status;
11839 # There is a blank in the left column to cause the pod formatter to
11840 # output the line as-is.
11841 return sprintf " %-*s%-*s %s\n",
11842 # The first * in the format is replaced by this, the -1 is
11843 # to account for the leading blank. There isn't a
11844 # hard-coded blank after this to separate the flags from
11845 # the rest of the line, so that in the unlikely event that
11846 # multiple flags are shown on the same line, they both
11847 # will get displayed at the expense of that separation,
11848 # but since they are left justified, a blank will be
11849 # inserted in the normal case.
11853 # The other * in the format is replaced by this number to
11854 # cause the first main column to right fill with blanks.
11855 # The -1 is for the guaranteed blank following it.
11856 $first_column_width - $FILLER - 1,
11861 my @zero_match_tables; # List of tables that have no matches in this release
11863 sub make_table_pod_entries($) {
11864 # This generates the entries for the pod file for a given table.
11865 # Also done at this time are any children tables. The output looks like:
11866 # \p{Common} \p{Script=Common} (Short: \p{Zyyy}) (5178)
11868 my $input_table = shift; # Table the entry is for
11869 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
11871 # Generate parent and all its children at the same time.
11872 return if $input_table->parent != $input_table;
11874 my $property = $input_table->property;
11875 my $type = $property->type;
11876 my $full_name = $property->full_name;
11878 my $count = $input_table->count;
11879 my $string_count = clarify_number($count);
11880 my $status = $input_table->status;
11881 my $status_info = $input_table->status_info;
11883 my $entry_for_first_table; # The entry for the first table output.
11884 # Almost certainly, it is the parent.
11886 # For each related table (including itself), we will generate a pod entry
11887 # for each name each table goes by
11888 foreach my $table ($input_table, $input_table->children) {
11890 # utf8_heavy.pl cannot deal with null string property values, so don't
11892 next if $table->name eq "";
11894 # First, gather all the info that applies to this table as a whole.
11896 push @zero_match_tables, $table if $count == 0;
11898 my $table_property = $table->property;
11900 # The short name has all the underscores removed, while the full name
11901 # retains them. Later, we decide whether to output a short synonym
11902 # for the full one, we need to compare apples to apples, so we use the
11903 # short name's length including underscores.
11904 my $table_property_short_name_length;
11905 my $table_property_short_name
11906 = $table_property->short_name(\$table_property_short_name_length);
11907 my $table_property_full_name = $table_property->full_name;
11909 # Get how much savings there is in the short name over the full one
11910 # (delta will always be <= 0)
11911 my $table_property_short_delta = $table_property_short_name_length
11912 - length($table_property_full_name);
11913 my @table_description = $table->description;
11914 my @table_note = $table->note;
11916 # Generate an entry for each alias in this table.
11917 my $entry_for_first_alias; # saves the first one encountered.
11918 foreach my $alias ($table->aliases) {
11920 # Skip if not to go in pod.
11921 next unless $alias->make_pod_entry;
11923 # Start gathering all the components for the entry
11924 my $name = $alias->name;
11926 my $entry; # Holds the left column, may include extras
11927 my $entry_ref; # To refer to the left column's contents from
11928 # another entry; has no extras
11930 # First the left column of the pod entry. Tables for the $perl
11931 # property always use the single form.
11932 if ($table_property == $perl) {
11933 $entry = "\\p{$name}";
11934 $entry_ref = "\\p{$name}";
11936 else { # Compound form.
11938 # Only generate one entry for all the aliases that mean true
11939 # or false in binary properties. Append a '*' to indicate
11940 # some are missing. (The heading comment notes this.)
11941 my $wild_card_mark;
11942 if ($type == $BINARY) {
11943 next if $name ne 'N' && $name ne 'Y';
11944 $wild_card_mark = '*';
11947 $wild_card_mark = "";
11950 # Colon-space is used to give a little more space to be easier
11953 . $table_property_full_name
11954 . ": $name$wild_card_mark}";
11956 # But for the reference to this entry, which will go in the
11957 # right column, where space is at a premium, use equals
11959 $entry_ref = "\\p{" . $table_property_full_name . "=$name}";
11962 # Then the right (info) column. This is stored as components of
11963 # an array for the moment, then joined into a string later. For
11964 # non-internal only properties, begin the info with the entry for
11965 # the first table we encountered (if any), as things are ordered
11966 # so that that one is the most descriptive. This leads to the
11967 # info column of an entry being a more descriptive version of the
11970 if ($name =~ /^_/) {
11972 '(For internal use by Perl, not necessarily stable)';
11974 elsif ($entry_for_first_alias) {
11975 push @info, $entry_for_first_alias;
11978 # If this entry is equivalent to another, add that to the info,
11979 # using the first such table we encountered
11980 if ($entry_for_first_table) {
11982 push @info, "(= $entry_for_first_table)";
11985 push @info, $entry_for_first_table;
11989 # If the name is a large integer, add an equivalent with an
11990 # exponent for better readability
11991 if ($name =~ /^[+-]?[\d]+$/ && $name >= 10_000) {
11992 push @info, sprintf "(= %.1e)", $name
11995 my $parenthesized = "";
11996 if (! $entry_for_first_alias) {
11998 # This is the first alias for the current table. The alias
11999 # array is ordered so that this is the fullest, most
12000 # descriptive alias, so it gets the fullest info. The other
12001 # aliases are mostly merely pointers to this one, using the
12002 # information already added above.
12004 # Display any status message, but only on the parent table
12005 if ($status && ! $entry_for_first_table) {
12006 push @info, $status_info;
12009 # Put out any descriptive info
12010 if (@table_description || @table_note) {
12011 push @info, join "; ", @table_description, @table_note;
12014 # Look to see if there is a shorter name we can point people
12016 my $standard_name = standardize($name);
12018 my $proposed_short = $table->short_name;
12019 if (defined $proposed_short) {
12020 my $standard_short = standardize($proposed_short);
12022 # If the short name is shorter than the standard one, or
12023 # even it it's not, but the combination of it and its
12024 # short property name (as in \p{prop=short} ($perl doesn't
12025 # have this form)) saves at least two characters, then,
12026 # cause it to be listed as a shorter synonym.
12027 if (length $standard_short < length $standard_name
12028 || ($table_property != $perl
12029 && (length($standard_short)
12030 - length($standard_name)
12031 + $table_property_short_delta) # (<= 0)
12034 $short_name = $proposed_short;
12035 if ($table_property != $perl) {
12036 $short_name = $table_property_short_name
12039 $short_name = "\\p{$short_name}";
12043 # And if this is a compound form name, see if there is a
12044 # single form equivalent
12046 if ($table_property != $perl) {
12048 # Special case the binary N tables, so that will print
12049 # \P{single}, but use the Y table values to populate
12050 # 'single', as we haven't populated the N table.
12053 if ($type == $BINARY
12054 && $input_table == $property->table('No'))
12056 $test_table = $property->table('Yes');
12060 $test_table = $input_table;
12064 # Look for a single form amongst all the children.
12065 foreach my $table ($test_table->children) {
12066 next if $table->property != $perl;
12067 my $proposed_name = $table->short_name;
12068 next if ! defined $proposed_name;
12070 # Don't mention internal-only properties as a possible
12071 # single form synonym
12072 next if substr($proposed_name, 0, 1) eq '_';
12074 $proposed_name = "\\$p\{$proposed_name}";
12075 if (! defined $single_form
12076 || length($proposed_name) < length $single_form)
12078 $single_form = $proposed_name;
12080 # The goal here is to find a single form; not the
12081 # shortest possible one. We've already found a
12082 # short name. So, stop at the first single form
12083 # found, which is likely to be closer to the
12090 # Ouput both short and single in the same parenthesized
12091 # expression, but with only one of 'Single', 'Short' if there
12093 if ($short_name || $single_form || $table->conflicting) {
12094 $parenthesized .= '(';
12095 $parenthesized .= "Short: $short_name" if $short_name;
12096 if ($short_name && $single_form) {
12097 $parenthesized .= ', ';
12099 elsif ($single_form) {
12100 $parenthesized .= 'Single: ';
12102 $parenthesized .= $single_form if $single_form;
12107 # Warn if this property isn't the same as one that a
12108 # semi-casual user might expect. The other components of this
12109 # parenthesized structure are calculated only for the first entry
12110 # for this table, but the conflicting is deemed important enough
12111 # to go on every entry.
12112 my $conflicting = join " NOR ", $table->conflicting;
12113 if ($conflicting) {
12114 $parenthesized .= '(' if ! $parenthesized;
12115 $parenthesized .= '; ' if $parenthesized ne '(';
12116 $parenthesized .= "NOT $conflicting";
12118 $parenthesized .= ')' if $parenthesized;
12120 push @info, $parenthesized if $parenthesized;
12122 if ($table_property != $perl && $table->perl_extension) {
12123 push @info, '(Perl extension)';
12125 push @info, "($string_count)" if $output_range_counts;
12127 # Now, we have both the entry and info so add them to the
12128 # list of all the properties.
12129 push @match_properties,
12130 format_pod_line($indent_info_column,
12134 $alias->loose_match);
12136 $entry_for_first_alias = $entry_ref unless $entry_for_first_alias;
12137 } # End of looping through the aliases for this table.
12139 if (! $entry_for_first_table) {
12140 $entry_for_first_table = $entry_for_first_alias;
12142 } # End of looping through all the related tables
12146 sub pod_alphanumeric_sort {
12147 # Sort pod entries alphanumerically.
12149 # The first few character columns are filler, plus the '\p{'; and get rid
12150 # of all the trailing stuff, starting with the trailing '}', so as to sort
12151 # on just 'Name=Value'
12152 (my $a = lc $a) =~ s/^ .*? { //x;
12154 (my $b = lc $b) =~ s/^ .*? { //x;
12157 # Determine if the two operands are both internal only or both not.
12158 # Character 0 should be a '\'; 1 should be a p; 2 should be '{', so 3
12159 # should be the underscore that begins internal only
12160 my $a_is_internal = (substr($a, 0, 1) eq '_');
12161 my $b_is_internal = (substr($b, 0, 1) eq '_');
12163 # Sort so the internals come last in the table instead of first (which the
12164 # leading underscore would otherwise indicate).
12165 if ($a_is_internal != $b_is_internal) {
12166 return 1 if $a_is_internal;
12170 # Determine if the two operands are numeric property values or not.
12171 # A numeric property will look like xyz: 3. But the number
12172 # can begin with an optional minus sign, and may have a
12173 # fraction or rational component, like xyz: 3/2. If either
12174 # isn't numeric, use alphabetic sort.
12175 my ($a_initial, $a_number) =
12176 ($a =~ /^ ( [^:=]+ [:=] \s* ) (-? \d+ (?: [.\/] \d+)? )/ix);
12177 return $a cmp $b unless defined $a_number;
12178 my ($b_initial, $b_number) =
12179 ($b =~ /^ ( [^:=]+ [:=] \s* ) (-? \d+ (?: [.\/] \d+)? )/ix);
12180 return $a cmp $b unless defined $b_number;
12182 # Here they are both numeric, but use alphabetic sort if the
12183 # initial parts don't match
12184 return $a cmp $b if $a_initial ne $b_initial;
12186 # Convert rationals to floating for the comparison.
12187 $a_number = eval $a_number if $a_number =~ qr{/};
12188 $b_number = eval $b_number if $b_number =~ qr{/};
12190 return $a_number <=> $b_number;
12194 # Create the .pod file. This generates the various subsections and then
12195 # combines them in one big HERE document.
12197 return unless defined $pod_directory;
12198 print "Making pod file\n" if $verbosity >= $PROGRESS;
12200 my $exception_message =
12201 '(Any exceptions are individually noted beginning with the word NOT.)';
12203 if (-e 'Blocks.txt') {
12205 # Add the line: '\p{In_*} \p{Block: *}', with the warning message
12206 # if the global $has_In_conflicts indicates we have them.
12207 push @match_properties, format_pod_line($indent_info_column,
12210 . (($has_In_conflicts)
12211 ? " $exception_message"
12213 @block_warning = << "END";
12215 Matches in the Block property have shortcuts that begin with 'In_'. For
12216 example, \\p{Block=Latin1} can be written as \\p{In_Latin1}. For backward
12217 compatibility, if there is no conflict with another shortcut, these may also
12218 be written as \\p{Latin1} or \\p{Is_Latin1}. But, N.B., there are numerous
12219 such conflicting shortcuts. Use of these forms for Block is discouraged, and
12220 are flagged as such, not only because of the potential confusion as to what is
12221 meant, but also because a later release of Unicode may preempt the shortcut,
12222 and your program would no longer be correct. Use the 'In_' form instead to
12223 avoid this, or even more clearly, use the compound form, e.g.,
12224 \\p{blk:latin1}. See L<perlunicode/"Blocks"> for more information about this.
12227 my $text = "If an entry has flag(s) at its beginning, like '$DEPRECATED', the 'Is_' form has the same flag(s)";
12228 $text = "$exception_message $text" if $has_Is_conflicts;
12230 # And the 'Is_ line';
12231 push @match_properties, format_pod_line($indent_info_column,
12235 # Sort the properties array for output. It is sorted alphabetically
12236 # except numerically for numeric properties, and only output unique lines.
12237 @match_properties = sort pod_alphanumeric_sort uniques @match_properties;
12239 my $formatted_properties = simple_fold(\@match_properties,
12241 # indent succeeding lines by two extra
12242 # which looks better
12243 $indent_info_column + 2,
12245 # shorten the line length by how much
12246 # the formatter indents, so the folded
12247 # line will fit in the space
12248 # presumably available
12249 $automatic_pod_indent);
12250 # Add column headings, indented to be a little more centered, but not
12252 $formatted_properties = format_pod_line($indent_info_column,
12256 . $formatted_properties;
12258 # Generate pod documentation lines for the tables that match nothing
12260 if (@zero_match_tables) {
12261 @zero_match_tables = uniques(@zero_match_tables);
12262 $zero_matches = join "\n\n",
12263 map { $_ = '=item \p{' . $_->complete_name . "}" }
12264 sort { $a->complete_name cmp $b->complete_name }
12265 uniques(@zero_match_tables);
12267 $zero_matches = <<END;
12269 =head2 Legal \\p{} and \\P{} constructs that match no characters
12271 Unicode has some property-value pairs that currently don't match anything.
12272 This happens generally either because they are obsolete, or for symmetry with
12273 other forms, but no language has yet been encoded that uses them. In this
12274 version of Unicode, the following match zero code points:
12285 # Generate list of properties that we don't accept, grouped by the reasons
12286 # why. This is so only put out the 'why' once, and then list all the
12287 # properties that have that reason under it.
12289 my %why_list; # The keys are the reasons; the values are lists of
12290 # properties that have the key as their reason
12292 # For each property, add it to the list that are suppressed for its reason
12293 # The sort will cause the alphabetically first properties to be added to
12294 # each list first, so each list will be sorted.
12295 foreach my $property (sort keys %why_suppressed) {
12296 push @{$why_list{$why_suppressed{$property}}}, $property;
12299 # For each reason (sorted by the first property that has that reason)...
12300 my @bad_re_properties;
12301 foreach my $why (sort { $why_list{$a}->[0] cmp $why_list{$b}->[0] }
12304 # Add to the output, all the properties that have that reason. Start
12305 # with an empty line.
12306 push @bad_re_properties, "\n\n";
12308 my $has_item = 0; # Flag if actually output anything.
12309 foreach my $name (@{$why_list{$why}}) {
12311 # Split compound names into $property and $table components
12312 my $property = $name;
12314 if ($property =~ / (.*) = (.*) /x) {
12319 # This release of Unicode may not have a property that is
12320 # suppressed, so don't reference a non-existent one.
12321 $property = property_ref($property);
12322 next if ! defined $property;
12324 # And since this list is only for match tables, don't list the
12325 # ones that don't have match tables.
12326 next if ! $property->to_create_match_tables;
12328 # Find any abbreviation, and turn it into a compound name if this
12329 # is a property=value pair.
12330 my $short_name = $property->name;
12331 $short_name .= '=' . $property->table($table)->name if $table;
12333 # And add the property as an item for the reason.
12334 push @bad_re_properties, "\n=item I<$name> ($short_name)\n";
12338 # And add the reason under the list of properties, if such a list
12339 # actually got generated. Note that the header got added
12340 # unconditionally before. But pod ignores extra blank lines, so no
12342 push @bad_re_properties, "\n$why\n" if $has_item;
12344 } # End of looping through each reason.
12346 # Generate a list of the properties whose map table we output, from the
12347 # global @map_properties.
12348 my @map_tables_actually_output;
12349 my $info_indent = 20; # Left column is narrower than \p{} table.
12350 foreach my $property (@map_properties) {
12352 # Get the path to the file; don't output any not in the standard
12354 my @path = $property->file_path;
12355 next if $path[0] ne $map_directory;
12356 shift @path; # Remove the standard name
12358 my $file = join '/', @path; # In case is in sub directory
12359 my $info = $property->full_name;
12360 my $short_name = $property->name;
12361 if ($info ne $short_name) {
12362 $info .= " ($short_name)";
12364 foreach my $more_info ($property->description,
12366 $property->status_info)
12368 next unless $more_info;
12370 $info .= ". $more_info";
12372 push @map_tables_actually_output, format_pod_line($info_indent,
12375 $property->status);
12378 # Sort alphabetically, and fold for output
12379 @map_tables_actually_output = sort
12380 pod_alphanumeric_sort @map_tables_actually_output;
12381 @map_tables_actually_output
12382 = simple_fold(\@map_tables_actually_output,
12385 $automatic_pod_indent);
12387 # Generate a list of the formats that can appear in the map tables.
12388 my @map_table_formats;
12389 foreach my $format (sort keys %map_table_formats) {
12390 push @map_table_formats, " $format $map_table_formats{$format}\n";
12393 # Everything is ready to assemble.
12394 my @OUT = << "END";
12399 To change this file, edit $0 instead.
12405 $pod_file - Index of Unicode Version $string_version properties in Perl
12409 There are many properties in Unicode, and Perl provides access to almost all of
12410 them, as well as some additional extensions and short-cut synonyms.
12412 And just about all of the few that aren't accessible through the Perl
12413 core are accessible through the modules: Unicode::Normalize and
12414 Unicode::UCD, and for Unihan properties, via the CPAN module Unicode::Unihan.
12416 This document merely lists all available properties and does not attempt to
12417 explain what each property really means. There is a brief description of each
12418 Perl extension. There is some detail about Blocks, Scripts, General_Category,
12419 and Bidi_Class in L<perlunicode>, but to find out about the intricacies of the
12420 Unicode properties, refer to the Unicode standard. A good starting place is
12421 L<$unicode_reference_url>. More information on the Perl extensions is in
12422 L<perlrecharclass>.
12424 Note that you can define your own properties; see
12425 L<perlunicode/"User-Defined Character Properties">.
12427 =head1 Properties accessible through \\p{} and \\P{}
12429 The Perl regular expression \\p{} and \\P{} constructs give access to most of
12430 the Unicode character properties. The table below shows all these constructs,
12431 both single and compound forms.
12433 B<Compound forms> consist of two components, separated by an equals sign or a
12434 colon. The first component is the property name, and the second component is
12435 the particular value of the property to match against, for example,
12436 '\\p{Script: Greek}' or '\\p{Script=Greek}' both mean to match characters
12437 whose Script property is Greek.
12439 B<Single forms>, like '\\p{Greek}', are mostly Perl-defined shortcuts for
12440 their equivalent compound forms. The table shows these equivalences. (In our
12441 example, '\\p{Greek}' is a just a shortcut for '\\p{Script=Greek}'.)
12442 There are also a few Perl-defined single forms that are not shortcuts for a
12443 compound form. One such is \\p{Word}. These are also listed in the table.
12445 In parsing these constructs, Perl always ignores Upper/lower case differences
12446 everywhere within the {braces}. Thus '\\p{Greek}' means the same thing as
12447 '\\p{greek}'. But note that changing the case of the 'p' or 'P' before the
12448 left brace completely changes the meaning of the construct, from "match" (for
12449 '\\p{}') to "doesn't match" (for '\\P{}'). Casing in this document is for
12450 improved legibility.
12452 Also, white space, hyphens, and underscores are also normally ignored
12453 everywhere between the {braces}, and hence can be freely added or removed
12454 even if the C</x> modifier hasn't been specified on the regular expression.
12455 But $a_bold_stricter at the beginning of an entry in the table below
12456 means that tighter (stricter) rules are used for that entry:
12460 =item Single form (\\p{name}) tighter rules:
12462 White space, hyphens, and underscores ARE significant
12467 =item * white space adjacent to a non-word character
12469 =item * underscores separating digits in numbers
12473 That means, for example, that you can freely add or remove white space
12474 adjacent to (but within) the braces without affecting the meaning.
12476 =item Compound form (\\p{name=value} or \\p{name:value}) tighter rules:
12478 The tighter rules given above for the single form apply to everything to the
12479 right of the colon or equals; the looser rules still apply to everything to
12482 That means, for example, that you can freely add or remove white space
12483 adjacent to (but within) the braces and the colon or equal sign.
12487 Some properties are considered obsolete, but still available. There are
12488 several varieties of obsolesence:
12494 Properties marked with $a_bold_obsolete in the table are considered
12495 obsolete. At the time of this writing (Unicode version 5.2) there is no
12496 information in the Unicode standard about the implications of a property being
12501 Obsolete properties may be stabilized. This means that they are not actively
12502 maintained by Unicode, and will not be extended as new characters are added to
12503 the standard. Such properties are marked with $a_bold_stabilized in the
12504 table. At the time of this writing (Unicode version 5.2) there is no further
12505 information in the Unicode standard about the implications of a property being
12510 Obsolete properties may be deprecated. This means that their use is strongly
12511 discouraged, so much so that a warning will be issued if used, unless the
12512 regular expression is in the scope of a C<S<no warnings 'deprecated'>>
12513 statement. $A_bold_deprecated flags each such entry in the table, and
12514 the entry there for the longest, most descriptive version of the property will
12515 give the reason it is deprecated, and perhaps advice. Perl may issue such a
12516 warning, even for properties that aren't officially deprecated by Unicode,
12517 when there used to be characters or code points that were matched by them, but
12518 no longer. This is to warn you that your program may not work like it did on
12519 earlier Unicode releases.
12521 A deprecated property may be made unavailable in a future Perl version, so it
12522 is best to move away from them.
12526 Some Perl extensions are present for backwards compatibility and are
12527 discouraged from being used, but not obsolete. $A_bold_discouraged
12528 flags each such entry in the table.
12532 The table below has two columns. The left column contains the \\p{}
12533 constructs to look up, possibly preceeded by the flags mentioned above; and
12534 the right column contains information about them, like a description, or
12535 synonyms. It shows both the single and compound forms for each property that
12536 has them. If the left column is a short name for a property, the right column
12537 will give its longer, more descriptive name; and if the left column is the
12538 longest name, the right column will show any equivalent shortest name, in both
12539 single and compound forms if applicable.
12541 The right column will also caution you if a property means something different
12542 than what might normally be expected.
12544 All single forms are Perl extensions; a few compound forms are as well, and
12547 Numbers in (parentheses) indicate the total number of code points matched by
12548 the property. For emphasis, those properties that match no code points at all
12549 are listed as well in a separate section following the table.
12551 There is no description given for most non-Perl defined properties (See
12552 $unicode_reference_url for that).
12554 For compactness, 'B<*>' is used as a wildcard instead of showing all possible
12555 combinations. For example, entries like:
12557 \\p{Gc: *} \\p{General_Category: *}
12559 mean that 'Gc' is a synonym for 'General_Category', and anything that is valid
12560 for the latter is also valid for the former. Similarly,
12564 means that if and only if, for example, \\p{Foo} exists, then \\p{Is_Foo} and
12565 \\p{IsFoo} are also valid and all mean the same thing. And similarly,
12566 \\p{Foo=Bar} means the same as \\p{Is_Foo=Bar} and \\p{IsFoo=Bar}. '*' here
12567 is restricted to something not beginning with an underscore.
12569 Also, in binary properties, 'Yes', 'T', and 'True' are all synonyms for 'Y'.
12570 And 'No', 'F', and 'False' are all synonyms for 'N'. The table shows 'Y*' and
12571 'N*' to indicate this, and doesn't have separate entries for the other
12572 possibilities. Note that not all properties which have values 'Yes' and 'No'
12573 are binary, and they have all their values spelled out without using this wild
12574 card, and a C<NOT> clause in their description that highlights their not being
12575 binary. These also require the compound form to match them, whereas true
12576 binary properties have both single and compound forms available.
12578 Note that all non-essential underscores are removed in the display of the
12585 =item B<*> is a wild-card
12587 =item B<(\\d+)> in the info column gives the number of code points matched by
12590 =item B<$DEPRECATED> means this is deprecated.
12592 =item B<$OBSOLETE> means this is obsolete.
12594 =item B<$STABILIZED> means this is stabilized.
12596 =item B<$STRICTER> means tighter (stricter) name matching applies.
12598 =item B<$DISCOURAGED> means use of this form is discouraged.
12602 $formatted_properties
12606 =head1 Properties not accessible through \\p{} and \\P{}
12608 A few properties are accessible in Perl via various function calls only.
12610 Lowercase_Mapping lc() and lcfirst()
12611 Titlecase_Mapping ucfirst()
12612 Uppercase_Mapping uc()
12614 Case_Folding is accessible through the /i modifier in regular expressions.
12616 The Name property is accessible through the \\N{} interpolation in
12617 double-quoted strings and regular expressions, but both usages require a C<use
12618 charnames;> to be specified, which also contains related functions viacode()
12621 =head1 Unicode regular expression properties that are NOT accepted by Perl
12623 Perl will generate an error for a few character properties in Unicode when
12624 used in a regular expression. The non-Unihan ones are listed below, with the
12625 reasons they are not accepted, perhaps with work-arounds. The short names for
12626 the properties are listed enclosed in (parentheses).
12634 An installation can choose to allow any of these to be matched by changing the
12635 controlling lists contained in the program C<\$Config{privlib}>/F<unicore/$0>
12636 and then re-running F<$0>. (C<\%Config> is available from the Config module).
12638 =head1 Files in the I<To> directory (for serious hackers only)
12640 All Unicode properties are really mappings (in the mathematical sense) from
12641 code points to their respective values. As part of its build process,
12642 Perl constructs tables containing these mappings for all properties that it
12643 deals with. But only a few of these are written out into files.
12644 Those written out are in the directory C<\$Config{privlib}>/F<unicore/To/>
12645 (%Config is available from the Config module).
12647 Those ones written are ones needed by Perl internally during execution, or for
12648 which there is some demand, and those for which there is no access through the
12649 Perl core. Generally, properties that can be used in regular expression
12650 matching do not have their map tables written, like Script. Nor are the
12651 simplistic properties that have a better, more complete version, such as
12652 Simple_Uppercase_Mapping (Uppercase_Mapping is written instead).
12654 None of the properties in the I<To> directory are currently directly
12655 accessible through the Perl core, although some may be accessed indirectly.
12656 For example, the uc() function implements the Uppercase_Mapping property and
12657 uses the F<Upper.pl> file found in this directory.
12659 The available files with their properties (short names in parentheses),
12660 and any flags or comments about them, are:
12662 @map_tables_actually_output
12664 An installation can choose to change which files are generated by changing the
12665 controlling lists contained in the program C<\$Config{privlib}>/F<unicore/$0>
12666 and then re-running F<$0>.
12668 Each of these files defines two hash entries to help reading programs decipher
12669 it. One of them looks like this:
12671 \$utf8::SwashInfo{'ToNAME'}{'format'} = 's';
12673 where 'NAME' is a name to indicate the property. For backwards compatibility,
12674 this is not necessarily the property's official Unicode name. (The 'To' is
12675 also for backwards compatibility.) The hash entry gives the format of the
12676 mapping fields of the table, currently one of the following:
12680 This format applies only to the entries in the main body of the table.
12681 Entries defined in hashes or ones that are missing from the list can have a
12684 The value that the missing entries have is given by the other SwashInfo hash
12685 entry line; it looks like this:
12687 \$utf8::SwashInfo{'ToNAME'}{'missing'} = 'NaN';
12689 This example line says that any Unicode code points not explicitly listed in
12690 the file have the value 'NaN' under the property indicated by NAME. If the
12691 value is the special string C<< <code point> >>, it means that the value for
12692 any missing code point is the code point itself. This happens, for example,
12693 in the file for Uppercase_Mapping (To/Upper.pl), in which code points like the
12694 character 'A', are missing because the uppercase of 'A' is itself.
12698 L<$unicode_reference_url>
12707 main::write([ $pod_directory, "$pod_file.pod" ], @OUT);
12711 sub make_Heavy () {
12712 # Create and write Heavy.pl, which passes info about the tables to
12719 # This file is for the use of utf8_heavy.pl
12721 # Maps property names in loose standard form to its standard name
12722 \%utf8::loose_property_name_of = (
12725 push @heavy, simple_dumper (\%loose_property_name_of, ' ' x 4);
12726 push @heavy, <<END;
12729 # Maps property, table to file for those using stricter matching
12730 \%utf8::stricter_to_file_of = (
12732 push @heavy, simple_dumper (\%stricter_to_file_of, ' ' x 4);
12733 push @heavy, <<END;
12736 # Maps property, table to file for those using loose matching
12737 \%utf8::loose_to_file_of = (
12739 push @heavy, simple_dumper (\%loose_to_file_of, ' ' x 4);
12740 push @heavy, <<END;
12743 # Maps floating point to fractional form
12744 \%utf8::nv_floating_to_rational = (
12746 push @heavy, simple_dumper (\%nv_floating_to_rational, ' ' x 4);
12747 push @heavy, <<END;
12750 # If a floating point number doesn't have enough digits in it to get this
12751 # close to a fraction, it isn't considered to be that fraction even if all the
12752 # digits it does have match.
12753 \$utf8::max_floating_slop = $MAX_FLOATING_SLOP;
12755 # Deprecated tables to generate a warning for. The key is the file containing
12756 # the table, so as to avoid duplication, as many property names can map to the
12757 # file, but we only need one entry for all of them.
12758 \%utf8::why_deprecated = (
12761 push @heavy, simple_dumper (\%utf8::why_deprecated, ' ' x 4);
12762 push @heavy, <<END;
12768 main::write("Heavy.pl", @heavy);
12772 sub write_all_tables() {
12773 # Write out all the tables generated by this program to files, as well as
12774 # the supporting data structures, pod file, and .t file.
12776 my @writables; # List of tables that actually get written
12777 my %match_tables_to_write; # Used to collapse identical match tables
12778 # into one file. Each key is a hash function
12779 # result to partition tables into buckets.
12780 # Each value is an array of the tables that
12781 # fit in the bucket.
12783 # For each property ...
12784 # (sort so that if there is an immutable file name, it has precedence, so
12785 # some other property can't come in and take over its file name. If b's
12786 # file name is defined, will return 1, meaning to take it first; don't
12787 # care if both defined, as they had better be different anyway)
12789 foreach my $property (sort { defined $b->file } property_ref('*')) {
12790 my $type = $property->type;
12792 # And for each table for that property, starting with the mapping
12795 foreach my $table($property,
12797 # and all the match tables for it (if any), sorted so
12798 # the ones with the shortest associated file name come
12799 # first. The length sorting prevents problems of a
12800 # longer file taking a name that might have to be used
12801 # by a shorter one. The alphabetic sorting prevents
12802 # differences between releases
12803 sort { my $ext_a = $a->external_name;
12804 return 1 if ! defined $ext_a;
12805 my $ext_b = $b->external_name;
12806 return -1 if ! defined $ext_b;
12807 my $cmp = length $ext_a <=> length $ext_b;
12809 # Return result if lengths not equal
12810 return $cmp if $cmp;
12812 # Alphabetic if lengths equal
12813 return $ext_a cmp $ext_b
12814 } $property->tables
12818 # Here we have a table associated with a property. It could be
12819 # the map table (done first for each property), or one of the
12820 # other tables. Determine which type.
12821 my $is_property = $table->isa('Property');
12823 my $name = $table->name;
12824 my $complete_name = $table->complete_name;
12826 # See if should suppress the table if is empty, but warn if it
12827 # contains something.
12828 my $suppress_if_empty_warn_if_not = grep { $complete_name eq $_ }
12829 keys %why_suppress_if_empty_warn_if_not;
12831 # Calculate if this table should have any code points associated
12833 my $expected_empty =
12835 # $perl should be empty, as well as properties that we just
12836 # don't do anything with
12838 && ($table == $perl
12839 || grep { $complete_name eq $_ }
12840 @unimplemented_properties
12844 # Match tables in properties we skipped populating should be
12846 || (! $is_property && ! $property->to_create_match_tables)
12848 # Tables and properties that are expected to have no code
12849 # points should be empty
12850 || $suppress_if_empty_warn_if_not
12853 # Set a boolean if this table is the complement of an empty binary
12855 my $is_complement_of_empty_binary =
12856 $type == $BINARY &&
12857 (($table == $property->table('Y')
12858 && $property->table('N')->is_empty)
12859 || ($table == $property->table('N')
12860 && $property->table('Y')->is_empty));
12863 # Some tables should match everything
12864 my $expected_full =
12866 ? # All these types of map tables will be full because
12867 # they will have been populated with defaults
12868 ($type == $ENUM || $type == $BINARY)
12870 : # A match table should match everything if its method
12872 ($table->matches_all
12874 # The complement of an empty binary table will match
12876 || $is_complement_of_empty_binary
12880 if ($table->is_empty) {
12883 if ($suppress_if_empty_warn_if_not) {
12884 $table->set_status($SUPPRESSED,
12885 $why_suppress_if_empty_warn_if_not{$complete_name});
12888 # Suppress expected empty tables.
12889 next TABLE if $expected_empty;
12891 # And setup to later output a warning for those that aren't
12892 # known to be allowed to be empty. Don't do the warning if
12893 # this table is a child of another one to avoid duplicating
12894 # the warning that should come from the parent one.
12895 if (($table == $property || $table->parent == $table)
12896 && $table->status ne $SUPPRESSED
12897 && ! grep { $complete_name =~ /^$_$/ }
12898 @tables_that_may_be_empty)
12900 push @unhandled_properties, "$table";
12903 elsif ($expected_empty) {
12905 if ($suppress_if_empty_warn_if_not) {
12906 $because = " because $why_suppress_if_empty_warn_if_not{$complete_name}";
12909 Carp::my_carp("Not expecting property $table$because. Generating file for it anyway.");
12912 my $count = $table->count;
12913 if ($expected_full) {
12914 if ($count != $MAX_UNICODE_CODEPOINTS) {
12915 Carp::my_carp("$table matches only "
12916 . clarify_number($count)
12917 . " Unicode code points but should match "
12918 . clarify_number($MAX_UNICODE_CODEPOINTS)
12920 . clarify_number(abs($MAX_UNICODE_CODEPOINTS - $count))
12921 . "). Proceeding anyway.");
12924 # Here is expected to be full. If it is because it is the
12925 # complement of an (empty) binary table that is to be
12926 # suppressed, then suppress this one as well.
12927 if ($is_complement_of_empty_binary) {
12928 my $opposing_name = ($name eq 'Y') ? 'N' : 'Y';
12929 my $opposing = $property->table($opposing_name);
12930 my $opposing_status = $opposing->status;
12931 if ($opposing_status) {
12932 $table->set_status($opposing_status,
12933 $opposing->status_info);
12937 elsif ($count == $MAX_UNICODE_CODEPOINTS) {
12938 if ($table == $property || $table->leader == $table) {
12939 Carp::my_carp("$table unexpectedly matches all Unicode code points. Proceeding anyway.");
12943 if ($table->status eq $SUPPRESSED) {
12944 if (! $is_property) {
12945 my @children = $table->children;
12946 foreach my $child (@children) {
12947 if ($child->status ne $SUPPRESSED) {
12948 Carp::my_carp_bug("'$table' is suppressed and has a child '$child' which isn't");
12955 if (! $is_property) {
12957 # Several things need to be done just once for each related
12958 # group of match tables. Do them on the parent.
12959 if ($table->parent == $table) {
12961 # Add an entry in the pod file for the table; it also does
12963 make_table_pod_entries($table) if defined $pod_directory;
12965 # See if the the table matches identical code points with
12966 # something that has already been output. In that case,
12967 # no need to have two files with the same code points in
12968 # them. We use the table's hash() method to store these
12969 # in buckets, so that it is quite likely that if two
12970 # tables are in the same bucket they will be identical, so
12971 # don't have to compare tables frequently. The tables
12972 # have to have the same status to share a file, so add
12973 # this to the bucket hash. (The reason for this latter is
12974 # that Heavy.pl associates a status with a file.)
12975 my $hash = $table->hash . ';' . $table->status;
12977 # Look at each table that is in the same bucket as this
12979 foreach my $comparison (@{$match_tables_to_write{$hash}})
12981 if ($table->matches_identically_to($comparison)) {
12982 $table->set_equivalent_to($comparison,
12988 # Here, not equivalent, add this table to the bucket.
12989 push @{$match_tables_to_write{$hash}}, $table;
12994 # Here is the property itself.
12995 # Don't write out or make references to the $perl property
12996 next if $table == $perl;
12998 if ($type != $STRING) {
13000 # There is a mapping stored of the various synonyms to the
13001 # standardized name of the property for utf8_heavy.pl.
13002 # Also, the pod file contains entries of the form:
13003 # \p{alias: *} \p{full: *}
13004 # rather than show every possible combination of things.
13006 my @property_aliases = $property->aliases;
13008 # The full name of this property is stored by convention
13009 # first in the alias array
13010 my $full_property_name =
13011 '\p{' . $property_aliases[0]->name . ': *}';
13012 my $standard_property_name = standardize($table->name);
13014 # For each synonym ...
13015 for my $i (0 .. @property_aliases - 1) {
13016 my $alias = $property_aliases[$i];
13017 my $alias_name = $alias->name;
13018 my $alias_standard = standardize($alias_name);
13020 # Set the mapping for utf8_heavy of the alias to the
13022 if (exists ($loose_property_name_of{$alias_standard}))
13024 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");
13027 $loose_property_name_of{$alias_standard}
13028 = $standard_property_name;
13031 # Now for the pod entry for this alias. Skip if not
13032 # outputting a pod; skip the first one, which is the
13033 # full name so won't have an entry like: '\p{full: *}
13034 # \p{full: *}', and skip if don't want an entry for
13037 || ! defined $pod_directory
13038 || ! $alias->make_pod_entry;
13040 my $rhs = $full_property_name;
13041 if ($property != $perl && $table->perl_extension) {
13042 $rhs .= ' (Perl extension)';
13044 push @match_properties,
13045 format_pod_line($indent_info_column,
13046 '\p{' . $alias->name . ': *}',
13050 } # End of non-string-like property code
13053 # Don't output a mapping file if not desired.
13054 next if ! $property->to_output_map;
13057 # Here, we know we want to write out the table, but don't do it
13058 # yet because there may be other tables that come along and will
13059 # want to share the file, and the file's comments will change to
13060 # mention them. So save for later.
13061 push @writables, $table;
13063 } # End of looping through the property and all its tables.
13064 } # End of looping through all properties.
13066 # Now have all the tables that will have files written for them. Do it.
13067 foreach my $table (@writables) {
13070 my $property = $table->property;
13071 my $is_property = ($table == $property);
13072 if (! $is_property) {
13074 # Match tables for the property go in lib/$subdirectory, which is
13075 # the property's name. Don't use the standard file name for this,
13076 # as may get an unfamiliar alias
13077 @directory = ($matches_directory, $property->external_name);
13081 @directory = $table->directory;
13082 $filename = $table->file;
13085 # Use specified filename if avaliable, or default to property's
13086 # shortest name. We need an 8.3 safe filename (which means "an 8
13087 # safe" filename, since after the dot is only 'pl', which is < 3)
13088 # The 2nd parameter is if the filename shouldn't be changed, and
13089 # it shouldn't iff there is a hard-coded name for this table.
13090 $filename = construct_filename(
13091 $filename || $table->external_name,
13092 ! $filename, # mutable if no filename
13095 register_file_for_name($table, \@directory, $filename);
13097 # Only need to write one file when shared by more than one
13099 next if ! $is_property && $table->leader != $table;
13101 # Construct a nice comment to add to the file
13102 $table->set_final_comment;
13108 # Write out the pod file
13114 make_property_test_script() if $make_test_script;
13118 my @white_space_separators = ( # This used only for making the test script.
13125 sub generate_separator($) {
13126 # This used only for making the test script. It generates the colon or
13127 # equal separator between the property and property value, with random
13128 # white space surrounding the separator
13132 return "" if $lhs eq ""; # No separator if there's only one (the r) side
13134 # Choose space before and after randomly
13135 my $spaces_before =$white_space_separators[rand(@white_space_separators)];
13136 my $spaces_after = $white_space_separators[rand(@white_space_separators)];
13138 # And return the whole complex, half the time using a colon, half the
13140 return $spaces_before
13141 . (rand() < 0.5) ? '=' : ':'
13145 sub generate_tests($$$$$$) {
13146 # This used only for making the test script. It generates test cases that
13147 # are expected to compile successfully in perl. Note that the lhs and
13148 # rhs are assumed to already be as randomized as the caller wants.
13150 my $file_handle = shift; # Where to output the tests
13151 my $lhs = shift; # The property: what's to the left of the colon
13152 # or equals separator
13153 my $rhs = shift; # The property value; what's to the right
13154 my $valid_code = shift; # A code point that's known to be in the
13155 # table given by lhs=rhs; undef if table is
13157 my $invalid_code = shift; # A code point known to not be in the table;
13158 # undef if the table is all code points
13159 my $warning = shift;
13161 # Get the colon or equal
13162 my $separator = generate_separator($lhs);
13164 # The whole 'property=value'
13165 my $name = "$lhs$separator$rhs";
13167 # Create a complete set of tests, with complements.
13168 if (defined $valid_code) {
13169 printf $file_handle
13170 qq/Expect(1, $valid_code, '\\p{$name}', $warning);\n/;
13171 printf $file_handle
13172 qq/Expect(0, $valid_code, '\\p{^$name}', $warning);\n/;
13173 printf $file_handle
13174 qq/Expect(0, $valid_code, '\\P{$name}', $warning);\n/;
13175 printf $file_handle
13176 qq/Expect(1, $valid_code, '\\P{^$name}', $warning);\n/;
13178 if (defined $invalid_code) {
13179 printf $file_handle
13180 qq/Expect(0, $invalid_code, '\\p{$name}', $warning);\n/;
13181 printf $file_handle
13182 qq/Expect(1, $invalid_code, '\\p{^$name}', $warning);\n/;
13183 printf $file_handle
13184 qq/Expect(1, $invalid_code, '\\P{$name}', $warning);\n/;
13185 printf $file_handle
13186 qq/Expect(0, $invalid_code, '\\P{^$name}', $warning);\n/;
13191 sub generate_error($$$$) {
13192 # This used only for making the test script. It generates test cases that
13193 # are expected to not only not match, but to be syntax or similar errors
13195 my $file_handle = shift; # Where to output to.
13196 my $lhs = shift; # The property: what's to the left of the
13197 # colon or equals separator
13198 my $rhs = shift; # The property value; what's to the right
13199 my $already_in_error = shift; # Boolean; if true it's known that the
13200 # unmodified lhs and rhs will cause an error.
13201 # This routine should not force another one
13202 # Get the colon or equal
13203 my $separator = generate_separator($lhs);
13205 # Since this is an error only, don't bother to randomly decide whether to
13206 # put the error on the left or right side; and assume that the rhs is
13207 # loosely matched, again for convenience rather than rigor.
13208 $rhs = randomize_loose_name($rhs, 'ERROR') unless $already_in_error;
13210 my $property = $lhs . $separator . $rhs;
13212 print $file_handle qq/Error('\\p{$property}');\n/;
13213 print $file_handle qq/Error('\\P{$property}');\n/;
13217 # These are used only for making the test script
13218 # XXX Maybe should also have a bad strict seps, which includes underscore.
13220 my @good_loose_seps = (
13227 my @bad_loose_seps = (
13232 sub randomize_stricter_name {
13233 # This used only for making the test script. Take the input name and
13234 # return a randomized, but valid version of it under the stricter matching
13238 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
13240 # If the name looks like a number (integer, floating, or rational), do
13242 if ($name =~ qr{ ^ ( -? ) (\d+ ( ( [./] ) \d+ )? ) $ }x) {
13245 my $separator = $3;
13247 # If there isn't a sign, part of the time add a plus
13248 # Note: Not testing having any denominator having a minus sign
13250 $sign = '+' if rand() <= .3;
13253 # And add 0 or more leading zeros.
13254 $name = $sign . ('0' x int rand(10)) . $number;
13256 if (defined $separator) {
13257 my $extra_zeros = '0' x int rand(10);
13259 if ($separator eq '.') {
13261 # Similarly, add 0 or more trailing zeros after a decimal
13263 $name .= $extra_zeros;
13267 # Or, leading zeros before the denominator
13268 $name =~ s,/,/$extra_zeros,;
13273 # For legibility of the test, only change the case of whole sections at a
13274 # time. To do this, first split into sections. The split returns the
13277 for my $section (split / ( [ - + \s _ . ]+ ) /x, $name) {
13278 trace $section if main::DEBUG && $to_trace;
13280 if (length $section > 1 && $section !~ /\D/) {
13282 # If the section is a sequence of digits, about half the time
13283 # randomly add underscores between some of them.
13286 # Figure out how many underscores to add. max is 1 less than
13287 # the number of digits. (But add 1 at the end to make sure
13288 # result isn't 0, and compensate earlier by subtracting 2
13290 my $num_underscores = int rand(length($section) - 2) + 1;
13292 # And add them evenly throughout, for convenience, not rigor
13294 my $spacing = (length($section) - 1)/ $num_underscores;
13295 my $temp = $section;
13297 for my $i (1 .. $num_underscores) {
13298 $section .= substr($temp, 0, $spacing, "") . '_';
13302 push @sections, $section;
13306 # Here not a sequence of digits. Change the case of the section
13308 my $switch = int rand(4);
13309 if ($switch == 0) {
13310 push @sections, uc $section;
13312 elsif ($switch == 1) {
13313 push @sections, lc $section;
13315 elsif ($switch == 2) {
13316 push @sections, ucfirst $section;
13319 push @sections, $section;
13323 trace "returning", join "", @sections if main::DEBUG && $to_trace;
13324 return join "", @sections;
13327 sub randomize_loose_name($;$) {
13328 # This used only for making the test script
13331 my $want_error = shift; # if true, make an error
13332 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
13334 $name = randomize_stricter_name($name);
13337 push @parts, $good_loose_seps[rand(@good_loose_seps)];
13338 for my $part (split /[-\s_]+/, $name) {
13340 if ($want_error and rand() < 0.3) {
13341 push @parts, $bad_loose_seps[rand(@bad_loose_seps)];
13345 push @parts, $good_loose_seps[rand(@good_loose_seps)];
13348 push @parts, $part;
13350 my $new = join("", @parts);
13351 trace "$name => $new" if main::DEBUG && $to_trace;
13354 if (rand() >= 0.5) {
13355 $new .= $bad_loose_seps[rand(@bad_loose_seps)];
13358 $new = $bad_loose_seps[rand(@bad_loose_seps)] . $new;
13364 # Used to make sure don't generate duplicate test cases.
13365 my %test_generated;
13367 sub make_property_test_script() {
13368 # This used only for making the test script
13369 # this written directly -- it's huge.
13371 print "Making test script\n" if $verbosity >= $PROGRESS;
13373 # This uses randomness to test different possibilities without testing all
13374 # possibilities. To ensure repeatability, set the seed to 0. But if
13375 # tests are added, it will perturb all later ones in the .t file
13378 $t_path = 'TestProp.pl' unless defined $t_path; # the traditional name
13380 force_unlink ($t_path);
13381 push @files_actually_output, $t_path;
13383 if (not open $OUT, "> $t_path") {
13384 Carp::my_carp("Can't open $t_path. Skipping: $!");
13388 # Keep going down an order of magnitude
13389 # until find that adding this quantity to
13390 # 1 remains 1; but put an upper limit on
13391 # this so in case this algorithm doesn't
13392 # work properly on some platform, that we
13393 # won't loop forever.
13395 my $min_floating_slop = 1;
13396 while (1+ $min_floating_slop != 1
13399 my $next = $min_floating_slop / 10;
13400 last if $next == 0; # If underflows,
13402 $min_floating_slop = $next;
13404 print $OUT $HEADER, <DATA>;
13406 foreach my $property (property_ref('*')) {
13407 foreach my $table ($property->tables) {
13409 # Find code points that match, and don't match this table.
13410 my $valid = $table->get_valid_code_point;
13411 my $invalid = $table->get_invalid_code_point;
13412 my $warning = ($table->status eq $DEPRECATED)
13416 # Test each possible combination of the property's aliases with
13417 # the table's. If this gets to be too many, could do what is done
13418 # in the set_final_comment() for Tables
13419 my @table_aliases = $table->aliases;
13420 my @property_aliases = $table->property->aliases;
13421 my $max = max(scalar @table_aliases, scalar @property_aliases);
13422 for my $j (0 .. $max - 1) {
13424 # The current alias for property is the next one on the list,
13425 # or if beyond the end, start over. Similarly for table
13427 = $property_aliases[$j % @property_aliases]->name;
13429 $property_name = "" if $table->property == $perl;
13430 my $table_alias = $table_aliases[$j % @table_aliases];
13431 my $table_name = $table_alias->name;
13432 my $loose_match = $table_alias->loose_match;
13434 # If the table doesn't have a file, any test for it is
13435 # already guaranteed to be in error
13436 my $already_error = ! $table->file_path;
13438 # Generate error cases for this alias.
13439 generate_error($OUT,
13444 # If the table is guaranteed to always generate an error,
13445 # quit now without generating success cases.
13446 next if $already_error;
13448 # Now for the success cases.
13450 if ($loose_match) {
13452 # For loose matching, create an extra test case for the
13454 my $standard = standardize($table_name);
13456 # $test_name should be a unique combination for each test
13457 # case; used just to avoid duplicate tests
13458 my $test_name = "$property_name=$standard";
13460 # Don't output duplicate test cases.
13461 if (! exists $test_generated{$test_name}) {
13462 $test_generated{$test_name} = 1;
13463 generate_tests($OUT,
13471 $random = randomize_loose_name($table_name)
13473 else { # Stricter match
13474 $random = randomize_stricter_name($table_name);
13477 # Now for the main test case for this alias.
13478 my $test_name = "$property_name=$random";
13479 if (! exists $test_generated{$test_name}) {
13480 $test_generated{$test_name} = 1;
13481 generate_tests($OUT,
13489 # If the name is a rational number, add tests for the
13490 # floating point equivalent.
13491 if ($table_name =~ qr{/}) {
13493 # Calculate the float, and find just the fraction.
13494 my $float = eval $table_name;
13495 my ($whole, $fraction)
13496 = $float =~ / (.*) \. (.*) /x;
13498 # Starting with one digit after the decimal point,
13499 # create a test for each possible precision (number of
13500 # digits past the decimal point) until well beyond the
13501 # native number found on this machine. (If we started
13502 # with 0 digits, it would be an integer, which could
13503 # well match an unrelated table)
13505 for my $i (1 .. $min_floating_slop + 3) {
13506 my $table_name = sprintf("%.*f", $i, $float);
13507 if ($i < $MIN_FRACTION_LENGTH) {
13509 # If the test case has fewer digits than the
13510 # minimum acceptable precision, it shouldn't
13511 # succeed, so we expect an error for it.
13512 # E.g., 2/3 = .7 at one decimal point, and we
13513 # shouldn't say it matches .7. We should make
13514 # it be .667 at least before agreeing that the
13515 # intent was to match 2/3. But at the
13516 # less-than- acceptable level of precision, it
13517 # might actually match an unrelated number.
13518 # So don't generate a test case if this
13519 # conflating is possible. In our example, we
13520 # don't want 2/3 matching 7/10, if there is
13521 # a 7/10 code point.
13523 (keys %nv_floating_to_rational)
13526 if abs($table_name - $existing)
13527 < $MAX_FLOATING_SLOP;
13529 generate_error($OUT,
13532 1 # 1 => already an error
13537 # Here the number of digits exceeds the
13538 # minimum we think is needed. So generate a
13539 # success test case for it.
13540 generate_tests($OUT,
13555 foreach my $test (@backslash_X_tests) {
13556 print $OUT "Test_X('$test');\n";
13559 print $OUT "Finished();\n";
13564 # This is a list of the input files and how to handle them. The files are
13565 # processed in their order in this list. Some reordering is possible if
13566 # desired, but the v0 files should be first, and the extracted before the
13567 # others except DAge.txt (as data in an extracted file can be over-ridden by
13568 # the non-extracted. Some other files depend on data derived from an earlier
13569 # file, like UnicodeData requires data from Jamo, and the case changing and
13570 # folding requires data from Unicode. Mostly, it safest to order by first
13571 # version releases in (except the Jamo). DAge.txt is read before the
13572 # extracted ones because of the rarely used feature $compare_versions. In the
13573 # unlikely event that there were ever an extracted file that contained the Age
13574 # property information, it would have to go in front of DAge.
13576 # The version strings allow the program to know whether to expect a file or
13577 # not, but if a file exists in the directory, it will be processed, even if it
13578 # is in a version earlier than expected, so you can copy files from a later
13579 # release into an earlier release's directory.
13580 my @input_file_objects = (
13581 Input_file->new('PropertyAliases.txt', v0,
13582 Handler => \&process_PropertyAliases,
13584 Input_file->new(undef, v0, # No file associated with this
13585 Progress_Message => 'Finishing property setup',
13586 Handler => \&finish_property_setup,
13588 Input_file->new('PropValueAliases.txt', v0,
13589 Handler => \&process_PropValueAliases,
13590 Has_Missings_Defaults => $NOT_IGNORED,
13592 Input_file->new('DAge.txt', v3.2.0,
13593 Has_Missings_Defaults => $NOT_IGNORED,
13596 Input_file->new("${EXTRACTED}DGeneralCategory.txt", v3.1.0,
13597 Property => 'General_Category',
13599 Input_file->new("${EXTRACTED}DCombiningClass.txt", v3.1.0,
13600 Property => 'Canonical_Combining_Class',
13601 Has_Missings_Defaults => $NOT_IGNORED,
13603 Input_file->new("${EXTRACTED}DNumType.txt", v3.1.0,
13604 Property => 'Numeric_Type',
13605 Has_Missings_Defaults => $NOT_IGNORED,
13607 Input_file->new("${EXTRACTED}DEastAsianWidth.txt", v3.1.0,
13608 Property => 'East_Asian_Width',
13609 Has_Missings_Defaults => $NOT_IGNORED,
13611 Input_file->new("${EXTRACTED}DLineBreak.txt", v3.1.0,
13612 Property => 'Line_Break',
13613 Has_Missings_Defaults => $NOT_IGNORED,
13615 Input_file->new("${EXTRACTED}DBidiClass.txt", v3.1.1,
13616 Property => 'Bidi_Class',
13617 Has_Missings_Defaults => $NOT_IGNORED,
13619 Input_file->new("${EXTRACTED}DDecompositionType.txt", v3.1.0,
13620 Property => 'Decomposition_Type',
13621 Has_Missings_Defaults => $NOT_IGNORED,
13623 Input_file->new("${EXTRACTED}DBinaryProperties.txt", v3.1.0),
13624 Input_file->new("${EXTRACTED}DNumValues.txt", v3.1.0,
13625 Property => 'Numeric_Value',
13626 Each_Line_Handler => \&filter_numeric_value_line,
13627 Has_Missings_Defaults => $NOT_IGNORED,
13629 Input_file->new("${EXTRACTED}DJoinGroup.txt", v3.1.0,
13630 Property => 'Joining_Group',
13631 Has_Missings_Defaults => $NOT_IGNORED,
13634 Input_file->new("${EXTRACTED}DJoinType.txt", v3.1.0,
13635 Property => 'Joining_Type',
13636 Has_Missings_Defaults => $NOT_IGNORED,
13638 Input_file->new('Jamo.txt', v2.0.0,
13639 Property => 'Jamo_Short_Name',
13640 Each_Line_Handler => \&filter_jamo_line,
13642 Input_file->new('UnicodeData.txt', v1.1.5,
13644 Pre_Handler => \&setup_UnicodeData,
13646 # We clean up this file for some early versions.
13647 Each_Line_Handler => [ (($v_version lt v2.0.0 )
13649 : ($v_version eq v2.1.5)
13650 ? \&filter_v2_1_5_ucd
13653 # And the main filter
13654 \&filter_UnicodeData_line,
13656 EOF_Handler => \&EOF_UnicodeData,
13658 Input_file->new('ArabicShaping.txt', v2.0.0,
13659 Each_Line_Handler =>
13660 [ ($v_version lt 4.1.0)
13661 ? \&filter_old_style_arabic_shaping
13663 \&filter_arabic_shaping_line,
13665 Has_Missings_Defaults => $NOT_IGNORED,
13667 Input_file->new('Blocks.txt', v2.0.0,
13668 Property => 'Block',
13669 Has_Missings_Defaults => $NOT_IGNORED,
13670 Each_Line_Handler => \&filter_blocks_lines
13672 Input_file->new('PropList.txt', v2.0.0,
13673 Each_Line_Handler => (($v_version lt v3.1.0)
13674 ? \&filter_old_style_proplist
13677 Input_file->new('Unihan.txt', v2.0.0,
13678 Pre_Handler => \&setup_unihan,
13680 Each_Line_Handler => \&filter_unihan_line,
13682 Input_file->new('SpecialCasing.txt', v2.1.8,
13683 Each_Line_Handler => \&filter_special_casing_line,
13684 Pre_Handler => \&setup_special_casing,
13687 'LineBreak.txt', v3.0.0,
13688 Has_Missings_Defaults => $NOT_IGNORED,
13689 Property => 'Line_Break',
13690 # Early versions had problematic syntax
13691 Each_Line_Handler => (($v_version lt v3.1.0)
13692 ? \&filter_early_ea_lb
13695 Input_file->new('EastAsianWidth.txt', v3.0.0,
13696 Property => 'East_Asian_Width',
13697 Has_Missings_Defaults => $NOT_IGNORED,
13698 # Early versions had problematic syntax
13699 Each_Line_Handler => (($v_version lt v3.1.0)
13700 ? \&filter_early_ea_lb
13703 Input_file->new('CompositionExclusions.txt', v3.0.0,
13704 Property => 'Composition_Exclusion',
13706 Input_file->new('BidiMirroring.txt', v3.0.1,
13707 Property => 'Bidi_Mirroring_Glyph',
13709 Input_file->new("NormalizationTest.txt", v3.0.1,
13712 Input_file->new('CaseFolding.txt', v3.0.1,
13713 Pre_Handler => \&setup_case_folding,
13714 Each_Line_Handler =>
13715 [ ($v_version lt v3.1.0)
13716 ? \&filter_old_style_case_folding
13718 \&filter_case_folding_line
13720 Post_Handler => \&post_fold,
13722 Input_file->new('DCoreProperties.txt', v3.1.0,
13723 # 5.2 changed this file
13724 Has_Missings_Defaults => (($v_version ge v5.2.0)
13728 Input_file->new('Scripts.txt', v3.1.0,
13729 Property => 'Script',
13730 Has_Missings_Defaults => $NOT_IGNORED,
13732 Input_file->new('DNormalizationProps.txt', v3.1.0,
13733 Has_Missings_Defaults => $NOT_IGNORED,
13734 Each_Line_Handler => (($v_version lt v4.0.1)
13735 ? \&filter_old_style_normalization_lines
13738 Input_file->new('HangulSyllableType.txt', v4.0.0,
13739 Has_Missings_Defaults => $NOT_IGNORED,
13740 Property => 'Hangul_Syllable_Type'),
13741 Input_file->new("$AUXILIARY/WordBreakProperty.txt", v4.1.0,
13742 Property => 'Word_Break',
13743 Has_Missings_Defaults => $NOT_IGNORED,
13745 Input_file->new("$AUXILIARY/GraphemeBreakProperty.txt", v4.1.0,
13746 Property => 'Grapheme_Cluster_Break',
13747 Has_Missings_Defaults => $NOT_IGNORED,
13749 Input_file->new("$AUXILIARY/GCBTest.txt", v4.1.0,
13750 Handler => \&process_GCB_test,
13752 Input_file->new("$AUXILIARY/LBTest.txt", v4.1.0,
13755 Input_file->new("$AUXILIARY/SBTest.txt", v4.1.0,
13758 Input_file->new("$AUXILIARY/WBTest.txt", v4.1.0,
13761 Input_file->new("$AUXILIARY/SentenceBreakProperty.txt", v4.1.0,
13762 Property => 'Sentence_Break',
13763 Has_Missings_Defaults => $NOT_IGNORED,
13765 Input_file->new('NamedSequences.txt', v4.1.0,
13766 Handler => \&process_NamedSequences
13768 Input_file->new('NameAliases.txt', v5.0.0,
13769 Property => 'Name_Alias',
13771 Input_file->new("BidiTest.txt", v5.2.0,
13774 Input_file->new('UnihanIndicesDictionary.txt', v5.2.0,
13776 Each_Line_Handler => \&filter_unihan_line,
13778 Input_file->new('UnihanDataDictionaryLike.txt', v5.2.0,
13780 Each_Line_Handler => \&filter_unihan_line,
13782 Input_file->new('UnihanIRGSources.txt', v5.2.0,
13784 Pre_Handler => \&setup_unihan,
13785 Each_Line_Handler => \&filter_unihan_line,
13787 Input_file->new('UnihanNumericValues.txt', v5.2.0,
13789 Each_Line_Handler => \&filter_unihan_line,
13791 Input_file->new('UnihanOtherMappings.txt', v5.2.0,
13793 Each_Line_Handler => \&filter_unihan_line,
13795 Input_file->new('UnihanRadicalStrokeCounts.txt', v5.2.0,
13797 Each_Line_Handler => \&filter_unihan_line,
13799 Input_file->new('UnihanReadings.txt', v5.2.0,
13801 Each_Line_Handler => \&filter_unihan_line,
13803 Input_file->new('UnihanVariants.txt', v5.2.0,
13805 Each_Line_Handler => \&filter_unihan_line,
13809 # End of all the preliminaries.
13812 if ($compare_versions) {
13813 Carp::my_carp(<<END
13814 Warning. \$compare_versions is set. Output is not suitable for production
13819 # Put into %potential_files a list of all the files in the directory structure
13820 # that could be inputs to this program, excluding those that we should ignore.
13821 # Use absolute file names because it makes it easier across machine types.
13822 my @ignored_files_full_names = map { File::Spec->rel2abs(
13823 internal_file_to_platform($_))
13824 } keys %ignored_files;
13827 return unless /\.txt$/i; # Some platforms change the name's case
13828 my $full = lc(File::Spec->rel2abs($_));
13829 $potential_files{$full} = 1
13830 if ! grep { $full eq lc($_) } @ignored_files_full_names;
13833 }, File::Spec->curdir());
13835 my @mktables_list_output_files;
13837 if ($write_unchanged_files) {
13838 print "Not checking file list '$file_list'.\n" if $verbosity >= $VERBOSE;
13841 print "Reading file list '$file_list'\n" if $verbosity >= $VERBOSE;
13843 if (! open $file_handle, "<", $file_list) {
13844 Carp::my_carp("Failed to open '$file_list' (this is expected to be missing the first time); turning on -globlist option instead: $!");
13850 # Read and parse mktables.lst, placing the results from the first part
13851 # into @input, and the second part into @mktables_list_output_files
13852 for my $list ( \@input, \@mktables_list_output_files ) {
13853 while (<$file_handle>) {
13854 s/^ \s+ | \s+ $//xg;
13855 next if /^ \s* (?: \# .* )? $/x;
13857 my ( $file ) = split /\t/;
13858 push @$list, $file;
13860 @$list = uniques(@$list);
13864 # Look through all the input files
13865 foreach my $input (@input) {
13866 next if $input eq 'version'; # Already have checked this.
13868 # Ignore if doesn't exist. The checking about whether we care or
13869 # not is done via the Input_file object.
13870 next if ! file_exists($input);
13872 # The paths are stored with relative names, and with '/' as the
13873 # delimiter; convert to absolute on this machine
13874 my $full = lc(File::Spec->rel2abs(internal_file_to_platform($input)));
13875 $potential_files{$full} = 1
13876 if ! grep { lc($full) eq lc($_) } @ignored_files_full_names;
13880 close $file_handle;
13885 # Here wants to process all .txt files in the directory structure.
13886 # Convert them to full path names. They are stored in the platform's
13889 foreach my $object (@input_file_objects) {
13890 my $file = $object->file;
13891 next unless defined $file;
13892 push @known_files, File::Spec->rel2abs($file);
13895 my @unknown_input_files;
13896 foreach my $file (keys %potential_files) {
13897 next if grep { lc($file) eq lc($_) } @known_files;
13899 # Here, the file is unknown to us. Get relative path name
13900 $file = File::Spec->abs2rel($file);
13901 push @unknown_input_files, $file;
13903 # What will happen is we create a data structure for it, and add it to
13904 # the list of input files to process. First get the subdirectories
13906 my (undef, $directories, undef) = File::Spec->splitpath($file);
13907 $directories =~ s;/$;;; # Can have extraneous trailing '/'
13908 my @directories = File::Spec->splitdir($directories);
13910 # If the file isn't extracted (meaning none of the directories is the
13911 # extracted one), just add it to the end of the list of inputs.
13912 if (! grep { $EXTRACTED_DIR eq $_ } @directories) {
13913 push @input_file_objects, Input_file->new($file, v0);
13917 # Here, the file is extracted. It needs to go ahead of most other
13918 # processing. Search for the first input file that isn't a
13919 # special required property (that is, find one whose first_release
13920 # is non-0), and isn't extracted. Also, the Age property file is
13921 # processed before the extracted ones, just in case
13922 # $compare_versions is set.
13923 for (my $i = 0; $i < @input_file_objects; $i++) {
13924 if ($input_file_objects[$i]->first_released ne v0
13925 && lc($input_file_objects[$i]->file) ne 'dage.txt'
13926 && $input_file_objects[$i]->file !~ /$EXTRACTED_DIR/i)
13928 splice @input_file_objects, $i, 0,
13929 Input_file->new($file, v0);
13936 if (@unknown_input_files) {
13937 print STDERR simple_fold(join_lines(<<END
13939 The following files are unknown as to how to handle. Assuming they are
13940 typical property files. You'll know by later error messages if it worked or
13943 ) . " " . join(", ", @unknown_input_files) . "\n\n");
13945 } # End of looking through directory structure for more .txt files.
13947 # Create the list of input files from the objects we have defined, plus
13949 my @input_files = 'version';
13950 foreach my $object (@input_file_objects) {
13951 my $file = $object->file;
13952 next if ! defined $file; # Not all objects have files
13953 next if $object->optional && ! -e $file;
13954 push @input_files, $file;
13957 if ( $verbosity >= $VERBOSE ) {
13958 print "Expecting ".scalar( @input_files )." input files. ",
13959 "Checking ".scalar( @mktables_list_output_files )." output files.\n";
13962 # We set $youngest to be the most recently changed input file, including this
13963 # program itself (done much earlier in this file)
13964 foreach my $in (@input_files) {
13966 next unless defined $age; # Keep going even if missing a file
13967 $youngest = $age if $age < $youngest;
13969 # See that the input files have distinct names, to warn someone if they
13970 # are adding a new one
13972 my ($volume, $directories, $file ) = File::Spec->splitpath($in);
13973 $directories =~ s;/$;;; # Can have extraneous trailing '/'
13974 my @directories = File::Spec->splitdir($directories);
13975 my $base = $file =~ s/\.txt$//;
13976 construct_filename($file, 'mutable', \@directories);
13980 my $ok = ! $write_unchanged_files
13981 && scalar @mktables_list_output_files; # If none known, rebuild
13983 # Now we check to see if any output files are older than youngest, if
13984 # they are, we need to continue on, otherwise we can presumably bail.
13986 foreach my $out (@mktables_list_output_files) {
13987 if ( ! file_exists($out)) {
13988 print "'$out' is missing.\n" if $verbosity >= $VERBOSE;
13992 #local $to_trace = 1 if main::DEBUG;
13993 trace $youngest, -M $out if main::DEBUG && $to_trace;
13994 if ( -M $out > $youngest ) {
13995 #trace "$out: age: ", -M $out, ", youngest: $youngest\n" if main::DEBUG && $to_trace;
13996 print "'$out' is too old.\n" if $verbosity >= $VERBOSE;
14003 print "Files seem to be ok, not bothering to rebuild.\n";
14006 print "Must rebuild tables.\n" if $verbosity >= $VERBOSE;
14008 # Ready to do the major processing. First create the perl pseudo-property.
14009 $perl = Property->new('perl', Type => $NON_STRING, Perl_Extension => 1);
14011 # Process each input file
14012 foreach my $file (@input_file_objects) {
14016 # Finish the table generation.
14018 print "Finishing processing Unicode properties\n" if $verbosity >= $PROGRESS;
14021 print "Compiling Perl properties\n" if $verbosity >= $PROGRESS;
14024 print "Creating Perl synonyms\n" if $verbosity >= $PROGRESS;
14025 add_perl_synonyms();
14027 print "Writing tables\n" if $verbosity >= $PROGRESS;
14028 write_all_tables();
14030 # Write mktables.lst
14031 if ( $file_list and $make_list ) {
14033 print "Updating '$file_list'\n" if $verbosity >= $PROGRESS;
14034 foreach my $file (@input_files, @files_actually_output) {
14035 my (undef, $directories, $file) = File::Spec->splitpath($file);
14036 my @directories = File::Spec->splitdir($directories);
14037 $file = join '/', @directories, $file;
14041 if (! open $ofh,">",$file_list) {
14042 Carp::my_carp("Can't write to '$file_list'. Skipping: $!");
14046 print $ofh <<"END";
14048 # $file_list -- File list for $0.
14050 # Autogenerated on @{[scalar localtime]}
14052 # - First section is input files
14053 # ($0 itself is not listed but is automatically considered an input)
14054 # - Section seperator is /^=+\$/
14055 # - Second section is a list of output files.
14056 # - Lines matching /^\\s*#/ are treated as comments
14057 # which along with blank lines are ignored.
14063 print $ofh "$_\n" for sort(@input_files);
14064 print $ofh "\n=================================\n# Output files:\n\n";
14065 print $ofh "$_\n" for sort @files_actually_output;
14066 print $ofh "\n# ",scalar(@input_files)," input files\n",
14067 "# ",scalar(@files_actually_output)+1," output files\n\n",
14070 or Carp::my_carp("Failed to close $ofh: $!");
14072 print "Filelist has ",scalar(@input_files)," input files and ",
14073 scalar(@files_actually_output)+1," output files\n"
14074 if $verbosity >= $VERBOSE;
14078 # Output these warnings unless -q explicitly specified.
14079 if ($verbosity >= $NORMAL_VERBOSITY) {
14080 if (@unhandled_properties) {
14081 print "\nProperties and tables that unexpectedly have no code points\n";
14082 foreach my $property (sort @unhandled_properties) {
14083 print $property, "\n";
14087 if (%potential_files) {
14088 print "\nInput files that are not considered:\n";
14089 foreach my $file (sort keys %potential_files) {
14090 print File::Spec->abs2rel($file), "\n";
14093 print "\nAll done\n" if $verbosity >= $VERBOSE;
14097 # TRAILING CODE IS USED BY make_property_test_script()
14103 # If run outside the normal test suite on an ASCII platform, you can
14104 # just create a latin1_to_native() function that just returns its
14105 # inputs, because that's the only function used from test.pl
14108 # Test qr/\X/ and the \p{} regular expression constructs. This file is
14109 # constructed by mktables from the tables it generates, so if mktables is
14110 # buggy, this won't necessarily catch those bugs. Tests are generated for all
14111 # feasible properties; a few aren't currently feasible; see
14112 # is_code_point_usable() in mktables for details.
14114 # Standard test packages are not used because this manipulates SIG_WARN. It
14115 # exits 0 if every non-skipped test succeeded; -1 if any failed.
14121 my $expected = shift;
14124 my $warning_type = shift; # Type of warning message, like 'deprecated'
14126 my $line = (caller)[2];
14127 $ord = ord(latin1_to_native(chr($ord)));
14129 # Convert the code point to hex form
14130 my $string = sprintf "\"\\x{%04X}\"", $ord;
14134 # The first time through, use all warnings. If the input should generate
14135 # a warning, add another time through with them turned off
14136 push @tests, "no warnings '$warning_type';" if $warning_type;
14138 foreach my $no_warnings (@tests) {
14140 # Store any warning messages instead of outputting them
14141 local $SIG{__WARN__} = $SIG{__WARN__};
14142 my $warning_message;
14143 $SIG{__WARN__} = sub { $warning_message = $_[0] };
14147 # A string eval is needed because of the 'no warnings'.
14148 # Assumes no parens in the regular expression
14149 my $result = eval "$no_warnings
14150 my \$RegObj = qr($regex);
14151 $string =~ \$RegObj ? 1 : 0";
14152 if (not defined $result) {
14153 print "not ok $Tests - couldn't compile /$regex/; line $line: $@\n";
14156 elsif ($result ^ $expected) {
14157 print "not ok $Tests - expected $expected but got $result for $string =~ qr/$regex/; line $line\n";
14160 elsif ($warning_message) {
14161 if (! $warning_type || ($warning_type && $no_warnings)) {
14162 print "not ok $Tests - for qr/$regex/ did not expect warning message '$warning_message'; line $line\n";
14166 print "ok $Tests - expected and got a warning message for qr/$regex/; line $line\n";
14169 elsif ($warning_type && ! $no_warnings) {
14170 print "not ok $Tests - for qr/$regex/ expected a $warning_type warning message, but got none; line $line\n";
14174 print "ok $Tests - got $result for $string =~ qr/$regex/; line $line\n";
14183 if (eval { 'x' =~ qr/$regex/; 1 }) {
14185 my $line = (caller)[2];
14186 print "not ok $Tests - re compiled ok, but expected error for qr/$regex/; line $line: $@\n";
14189 my $line = (caller)[2];
14190 print "ok $Tests - got and expected error for qr/$regex/; line $line\n";
14195 # GCBTest.txt character that separates grapheme clusters
14196 my $breakable_utf8 = my $breakable = chr(0xF7);
14197 utf8::upgrade($breakable_utf8);
14199 # GCBTest.txt character that indicates that the adjoining code points are part
14200 # of the same grapheme cluster
14201 my $nobreak_utf8 = my $nobreak = chr(0xD7);
14202 utf8::upgrade($nobreak_utf8);
14205 # Test qr/\X/ matches. The input is a line from auxiliary/GCBTest.txt
14206 # Each such line is a sequence of code points given by their hex numbers,
14207 # separated by the two characters defined just before this subroutine that
14208 # indicate that either there can or cannot be a break between the adjacent
14209 # code points. If there isn't a break, that means the sequence forms an
14210 # extended grapheme cluster, which means that \X should match the whole
14211 # thing. If there is a break, \X should stop there. This is all
14212 # converted by this routine into a match:
14213 # $string =~ /(\X)/,
14214 # Each \X should match the next cluster; and that is what is checked.
14216 my $template = shift;
14218 my $line = (caller)[2];
14220 # The line contains characters above the ASCII range, but in Latin1. It
14221 # may or may not be in utf8, and if it is, it may or may not know it. So,
14222 # convert these characters to 8 bits. If knows is in utf8, simply
14224 if (utf8::is_utf8($template)) {
14225 utf8::downgrade($template);
14228 # Otherwise, if it is in utf8, but doesn't know it, the next lines
14229 # convert the two problematic characters to their 8-bit equivalents.
14230 # If it isn't in utf8, they don't harm anything.
14232 $template =~ s/$nobreak_utf8/$nobreak/g;
14233 $template =~ s/$breakable_utf8/$breakable/g;
14236 # Get rid of the leading and trailing breakables
14237 $template =~ s/^ \s* $breakable \s* //x;
14238 $template =~ s/ \s* $breakable \s* $ //x;
14240 # And no-breaks become just a space.
14241 $template =~ s/ \s* $nobreak \s* / /xg;
14243 # Split the input into segments that are breakable between them.
14244 my @segments = split /\s*$breakable\s*/, $template;
14247 my $display_string = "";
14249 my @should_display;
14251 # Convert the code point sequence in each segment into a Perl string of
14253 foreach my $segment (@segments) {
14254 my @code_points = split /\s+/, $segment;
14255 my $this_string = "";
14256 my $this_display = "";
14257 foreach my $code_point (@code_points) {
14258 $this_string .= latin1_to_native(chr(hex $code_point));
14259 $this_display .= "\\x{$code_point}";
14262 # The next cluster should match the string in this segment.
14263 push @should_match, $this_string;
14264 push @should_display, $this_display;
14265 $string .= $this_string;
14266 $display_string .= $this_display;
14269 # If a string can be represented in both non-ut8 and utf8, test both cases
14271 for my $to_upgrade (0 .. 1) {
14275 # If already in utf8, would just be a repeat
14276 next UPGRADE if utf8::is_utf8($string);
14278 utf8::upgrade($string);
14281 # Finally, do the \X match.
14282 my @matches = $string =~ /(\X)/g;
14284 # Look through each matched cluster to verify that it matches what we
14286 my $min = (@matches < @should_match) ? @matches : @should_match;
14287 for my $i (0 .. $min - 1) {
14289 if ($matches[$i] eq $should_match[$i]) {
14290 print "ok $Tests - ";
14292 print "In \"$display_string\" =~ /(\\X)/g, \\X #1";
14294 print "And \\X #", $i + 1,
14296 print " correctly matched $should_display[$i]; line $line\n";
14298 $matches[$i] = join("", map { sprintf "\\x{%04X}", $_ }
14299 unpack("U*", $matches[$i]));
14300 print "not ok $Tests - In \"$display_string\" =~ /(\\X)/g, \\X #",
14302 " should have matched $should_display[$i]",
14303 " but instead matched $matches[$i]",
14304 ". Abandoning rest of line $line\n";
14309 # And the number of matches should equal the number of expected matches.
14311 if (@matches == @should_match) {
14312 print "ok $Tests - Nothing was left over; line $line\n";
14314 print "not ok $Tests - There were ", scalar @should_match, " \\X matches expected, but got ", scalar @matches, " instead; line $line\n";
14322 print "1..$Tests\n";
14323 exit($Fails ? -1 : 0);
14326 Error('\p{Script=InGreek}'); # Bug #69018
14327 Test_X("1100 $nobreak 1161"); # Bug #70940
14328 Expect(0, 0x2028, '\p{Print}', ""); # Bug # 71722
14329 Expect(0, 0x2029, '\p{Print}', ""); # Bug # 71722
14330 Expect(1, 0xFF10, '\p{XDigit}', ""); # Bug # 71726