#!perl -w use 5.015; use strict; use warnings; use Unicode::UCD qw(prop_aliases prop_values prop_value_aliases prop_invlist prop_invmap search_invlist charprop num charblock ); require './regen/regen_lib.pl'; require './regen/charset_translations.pl'; require './lib/unicore/Heavy.pl'; use re "/aa"; # This program outputs charclass_invlists.h, which contains various inversion # lists in the form of C arrays that are to be used as-is for inversion lists. # Thus, the lists it contains are essentially pre-compiled, and need only a # light-weight fast wrapper to make them usable at run-time. # As such, this code knows about the internal structure of these lists, and # any change made to that has to be done here as well. A random number stored # in the headers is used to minimize the possibility of things getting # out-of-sync, or the wrong data structure being passed. Currently that # random number is: my $VERSION_DATA_STRUCTURE_TYPE = 148565664; # charclass_invlists.h now also contains inversion maps and enum definitions # for those maps that have a finite number of possible values # integer or float (no exponent) my $integer_or_float_re = qr/ ^ -? \d+ (:? \. \d+ )? $ /x; # Also includes rationals my $numeric_re = qr! $integer_or_float_re | ^ -? \d+ / \d+ $ !x; # More than one code point may have the same code point as their fold. This # gives the maximum number in the current Unicode release. (The folded-to # code point is not included in this count.) Most folds are pairs of code # points, like 'B' and 'b', so this number is at least one. my $max_fold_froms = 1; my %keywords; my $table_name_prefix = "UNI_"; # Matches valid C language enum names: begins with ASCII alphabetic, then any # ASCII \w my $enum_name_re = qr / ^ [[:alpha:]] \w* $ /ax; my $out_fh = open_new('charclass_invlists.h', '>', {style => '*', by => 'regen/mk_invlists.pl', from => "Unicode::UCD"}); my $in_file_pound_if = ""; my $max_hdr_len = 3; # In headings, how wide a name is allowed? print $out_fh "/* See the generating file for comments */\n\n"; # enums that should be made public my %public_enums = ( _Perl_SCX => 1 ); # The symbols generated by this program are all currently defined only in a # single dot c each. The code knows where most of them go, but this hash # gives overrides for the exceptions to the typical place my %exceptions_to_where_to_define = ( #_Perl_IVCF => 'PERL_IN_REGCOMP_C', ); my %where_to_define_enums = (); my $applies_to_all_charsets_text = "all charsets"; my %gcb_enums; my @gcb_short_enums; my %gcb_abbreviations; my %lb_enums; my @lb_short_enums; my %lb_abbreviations; my %wb_enums; my @wb_short_enums; my %wb_abbreviations; my @a2n; my %prop_name_aliases; # Invert this hash so that for each canonical name, we get a list of things # that map to it (excluding itself) foreach my $name (sort keys %utf8::loose_property_name_of) { my $canonical = $utf8::loose_property_name_of{$name}; push @{$prop_name_aliases{$canonical}}, $name if $canonical ne $name; } # Output these tables in the same vicinity as each other, so that will get # paged in at about the same time. These are also assumed to be the exact # same list as those properties used internally by perl. my %keep_together = ( assigned => 1, ascii => 1, upper => 1, lower => 1, title => 1, cased => 1, uppercaseletter => 1, lowercaseletter => 1, titlecaseletter => 1, casedletter => 1, vertspace => 1, xposixalnum => 1, xposixalpha => 1, xposixblank => 1, xposixcntrl => 1, xposixdigit => 1, xposixgraph => 1, xposixlower => 1, xposixprint => 1, xposixpunct => 1, xposixspace => 1, xposixupper => 1, xposixword => 1, xposixxdigit => 1, posixalnum => 1, posixalpha => 1, posixblank => 1, posixcntrl => 1, posixdigit => 1, posixgraph => 1, posixlower => 1, posixprint => 1, posixpunct => 1, posixspace => 1, posixupper => 1, posixword => 1, posixxdigit => 1, _perl_any_folds => 1, _perl_folds_to_multi_char => 1, _perl_is_in_multi_char_fold => 1, _perl_non_final_folds => 1, _perl_idstart => 1, _perl_idcont => 1, _perl_charname_begin => 1, _perl_charname_continue => 1, _perl_problematic_locale_foldeds_start => 1, _perl_problematic_locale_folds => 1, _perl_quotemeta => 1, ); my %perl_tags; # So can find synonyms of the above properties my $unused_table_hdr = 'u'; # Heading for row or column for unused values sub uniques { # Returns non-duplicated input values. From "Perl Best Practices: # Encapsulated Cleverness". p. 455 in first edition. my %seen; return grep { ! $seen{$_}++ } @_; } sub a2n($) { my $cp = shift; # Returns the input Unicode code point translated to native. return $cp if $cp !~ $integer_or_float_re || $cp > 255; return $a2n[$cp]; } sub end_file_pound_if { if ($in_file_pound_if) { print $out_fh "\n#endif\t/* $in_file_pound_if */\n"; $in_file_pound_if = ""; } } sub end_charset_pound_if { print $out_fh "\n" . get_conditional_compile_line_end(); } sub switch_pound_if ($$;$) { my $name = shift; my $new_pound_if = shift; my $charset = shift; my @new_pound_if = ref ($new_pound_if) ? sort @$new_pound_if : $new_pound_if; # Switch to new #if given by the 2nd argument. If there is an override # for this, it instead switches to that. The 1st argument is the # static's name, used only to check if there is an override for this # # The 'charset' parmameter, if present, is used to first end the charset # #if if we actually do a switch, and then restart it afterwards. This # code, then assumes that the charset #if's are enclosed in the file ones. if (exists $exceptions_to_where_to_define{$name}) { @new_pound_if = $exceptions_to_where_to_define{$name}; } foreach my $element (@new_pound_if) { # regcomp.c is arranged so that the tables are not compiled in # re_comp.c */ my $no_xsub = 1 if $element =~ / PERL_IN_ (?: REGCOMP ) _C /x; $element = "defined($element)"; $element = "($element && ! defined(PERL_IN_XSUB_RE))" if $no_xsub; } $new_pound_if = join " || ", @new_pound_if; # Change to the new one if different from old if ($in_file_pound_if ne $new_pound_if) { end_charset_pound_if() if defined $charset; # Exit any current #if if ($in_file_pound_if) { end_file_pound_if; } $in_file_pound_if = $new_pound_if; print $out_fh "\n#if $in_file_pound_if\n"; start_charset_pound_if ($charset, 1) if defined $charset; } } sub start_charset_pound_if ($;$) { print $out_fh "\n" . get_conditional_compile_line_start(shift, shift); } { # Closure my $fh; my $in_doinit = 0; sub output_table_header($$$;$@) { # Output to $fh the heading for a table given by the other inputs $fh = shift; my ($type, # typedef of table, like UV, UV* $name, # name of table $comment, # Optional comment to put on header line @sizes # Optional sizes of each array index. If omitted, # there is a single index whose size is computed by # the C compiler. ) = @_; $type =~ s/ \s+ $ //x; # If a the typedef is a ptr, add in an extra const $type .= " const" if $type =~ / \* $ /x; $comment = "" unless defined $comment; $comment = " /* $comment */" if $comment; my $array_declaration; if (@sizes) { $array_declaration = ""; $array_declaration .= "[$_]" for @sizes; } else { $array_declaration = '[]'; } my $declaration = "$type ${name}$array_declaration"; # Things not matching this are static. Otherwise, it is an external # constant, initialized only under DOINIT. # # (Currently everything is static) if ($in_file_pound_if !~ / PERL_IN_ (?: ) _C /x) { $in_doinit = 0; print $fh "\nstatic const $declaration = {$comment\n"; } else { $in_doinit = 1; print $fh <[0] != 0) { unshift @$invlist, 0; $zero_or_one = 1; } $charset = "for $charset" if $charset; output_table_header($out_fh, "UV", "${name}_invlist", $charset); my $count = @$invlist; print $out_fh <[$i]; print $out_fh "," if $i < @$invlist - 1; print $out_fh "\n"; } output_table_trailer(); } sub output_invmap ($$$$$$$) { my $name = shift; my $invmap = shift; # Reference to inversion map array my $prop_name = shift; my $input_format = shift; # The inversion map's format my $default = shift; # The property value for code points who # otherwise don't have a value specified. my $extra_enums = shift; # comma-separated list of our additions to the # property's standard possible values my $charset = shift // ""; # name of character set for comment # Output the inversion map $invmap for property $prop_name, but use $name # as the actual data structure's name. my $count = @$invmap; my $output_format; my $invmap_declaration_type; my $enum_declaration_type; my $aux_declaration_type; my %enums; my $name_prefix; if ($input_format =~ / ^ [as] l? $ /x) { $prop_name = (prop_aliases($prop_name))[1] // $prop_name =~ s/^_Perl_//r; # Get full name my $short_name = (prop_aliases($prop_name))[0] // $prop_name; my @input_enums; # Find all the possible input values. These become the enum names # that comprise the inversion map. For inputs that don't have sub # lists, we can just get the unique values. Otherwise, we have to # expand the sublists first. if ($input_format !~ / ^ a /x) { if ($input_format ne 'sl') { @input_enums = sort(uniques(@$invmap)); } else { foreach my $element (@$invmap) { if (ref $element) { push @input_enums, @$element; } else { push @input_enums, $element; } } @input_enums = sort(uniques(@input_enums)); } } # The internal enums come last, and in the order specified. # # The internal one named EDGE is also used a marker. Any ones that # come after it are used in the algorithms below, and so must be # defined, even if the release of Unicode this is being compiled for # doesn't use them. But since no code points are assigned to them in # such a release, those values will never be accessed. We collapse # all of them into a single placholder row and a column. The # algorithms below will fill in those cells with essentially garbage, # but they are never read, so it doesn't matter. This allows the # algorithm to remain the same from release to release. # # In one case, regexec.c also uses a placeholder which must be defined # here, and we put it in the unused row and column as its value is # never read. # my @enums = @input_enums; my @extras; my @unused_enums; my $unused_enum_value = @enums; if ($extra_enums ne "") { @extras = split /,/, $extra_enums; my $seen_EDGE = 0; # Don't add if already there. foreach my $this_extra (@extras) { next if grep { $_ eq $this_extra } @enums; if ($this_extra eq 'EDGE') { push @enums, $this_extra; $seen_EDGE = 1; } elsif ($seen_EDGE) { push @unused_enums, $this_extra; } else { push @enums, $this_extra; } } @unused_enums = sort @unused_enums; $unused_enum_value = @enums; # All unused have the same value, # one beyond the final used one } # Assign a value to each element of the enum type we are creating. # The default value always gets 0; the others are arbitrarily # assigned. my $enum_val = 0; my $canonical_default = prop_value_aliases($prop_name, $default); $default = $canonical_default if defined $canonical_default; $enums{$default} = $enum_val++; for my $enum (@enums) { $enums{$enum} = $enum_val++ unless exists $enums{$enum}; } # Calculate the data for the special tables output for these properties. if ($name =~ / ^ _Perl_ (?: GCB | LB | WB ) $ /x) { # The data includes the hashes %gcb_enums, %lb_enums, etc. # Similarly we calculate column headings for the tables. # # We use string evals to allow the same code to work on # all the tables my $type = lc $prop_name; # Skip if we've already done this code, which populated # this hash if (eval "! \%${type}_enums") { # For each enum in the type ... foreach my $enum (sort keys %enums) { my $value = $enums{$enum}; my $short; my $abbreviated_from; # Special case this wb property value to make the # name more clear if ($enum eq 'Perl_Tailored_HSpace') { $short = 'hs'; $abbreviated_from = $enum; } else { # Use the official short name, if found. ($short) = prop_value_aliases($type, $enum); if (! defined $short) { # But if there is no official name, use the name # that came from the data (if any). Otherwise, # the name had to come from the extras list. # There are two types of values in that list. # # First are those enums that are not part of the # property, but are defined by this code. By # convention these have all-caps names. We use # the lowercased name for these. # # Second are enums that are needed to get the # algorithms below to work and/or to get regexec.c # to compile, but don't exist in all Unicode # releases. These are handled outside this loop # as 'unused_enums' if (grep { $_ eq $enum } @input_enums) { $short = $enum } else { $short = lc $enum; } } } # If our short name is too long, or we already # know that the name is an abbreviation, truncate # to make sure it's short enough, and remember # that we did this so we can later add a comment in the # generated file if ( $abbreviated_from || length $short > $max_hdr_len) { $short = substr($short, 0, $max_hdr_len); $abbreviated_from = $enum unless $abbreviated_from; # If the name we are to display conflicts, try # another. while (eval "exists \$${type}_abbreviations{$short}") { die $@ if $@; # The increment operator on strings doesn't work # on those containing an '_', so just use the # final portion. my @short = split '_', $short; $short[-1]++; $short = join "_", @short; } eval "\$${type}_abbreviations{$short} = '$enum'"; die $@ if $@; } # Remember the mapping from the property value # (enum) name to its value. eval "\$${type}_enums{$enum} = $value"; die $@ if $@; # Remember the inverse mapping to the short name # so that we can properly label the generated # table's rows and columns eval "\$${type}_short_enums[$value] = '$short'"; die $@ if $@; } # Each unused enum has the same value. They all are collapsed # into one row and one column, named $unused_table_hdr. if (@unused_enums) { eval "\$${type}_short_enums['$unused_enum_value'] = '$unused_table_hdr'"; die $@ if $@; foreach my $enum (@unused_enums) { eval "\$${type}_enums{$enum} = $unused_enum_value"; die $@ if $@; } } } } # The short names tend to be two lower case letters, but it looks # better for those if they are upper. XXX $short_name = uc($short_name) if length($short_name) < 3 || substr($short_name, 0, 1) =~ /[[:lower:]]/; $name_prefix = "${short_name}_"; # Start the enum definition for this map my @enum_definition; my @enum_list; foreach my $enum (keys %enums) { $enum_list[$enums{$enum}] = $enum; } foreach my $i (0 .. @enum_list - 1) { push @enum_definition, ",\n" if $i > 0; my $name = $enum_list[$i]; push @enum_definition, "\t${name_prefix}$name = $i"; } if (@unused_enums) { foreach my $unused (@unused_enums) { push @enum_definition, ",\n\t${name_prefix}$unused = $unused_enum_value"; } } # For an 'l' property, we need extra enums, because some of the # elements are lists. Each such distinct list is placed in its own # auxiliary map table. Here, we go through the inversion map, and for # each distinct list found, create an enum value for it, numbered -1, # -2, .... my %multiples; my $aux_table_prefix = "AUX_TABLE_"; if ($input_format =~ /l/) { foreach my $element (@$invmap) { # A regular scalar is not one of the lists we're looking for # at this stage. next unless ref $element; my $joined; if ($input_format =~ /a/) { # These are already ordered $joined = join ",", @$element; } else { $joined = join ",", sort @$element; } my $already_found = exists $multiples{$joined}; my $i; if ($already_found) { # Use any existing one $i = $multiples{$joined}; } else { # Otherwise increment to get a new table number $i = keys(%multiples) + 1; $multiples{$joined} = $i; } # This changes the inversion map for this entry to not be the # list $element = "use_$aux_table_prefix$i"; # And add to the enum values if (! $already_found) { push @enum_definition, ",\n\t${name_prefix}$element = -$i"; } } } $enum_declaration_type = "${name_prefix}enum"; # Finished with the enum definition. Inversion map stuff is used only # by regexec or utf-8 (if it is for code points) , unless it is in the # enum exception list my $where = (exists $where_to_define_enums{$name}) ? $where_to_define_enums{$name} : ($input_format =~ /a/) ? 'PERL_IN_UTF8_C' : 'PERL_IN_REGEXEC_C'; if (! exists $public_enums{$name}) { switch_pound_if($name, $where, $charset); } else { end_charset_pound_if; end_file_pound_if; start_charset_pound_if($charset, 1); } # If the enum only contains one element, that is a dummy, default one if (scalar @enum_definition > 1) { # Currently unneeded #print $out_fh "\n#define ${name_prefix}ENUM_COUNT ", # ..scalar keys %enums, "\n"; if ($input_format =~ /l/) { print $out_fh "\n", "/* Negative enum values indicate the need to use an", " auxiliary table\n", " * consisting of the list of enums this one expands to.", " The absolute\n", " * values of the negative enums are indices into a table", " of the auxiliary\n", " * tables' addresses */"; } print $out_fh "\ntypedef enum {\n"; print $out_fh join "", @enum_definition; print $out_fh "\n"; print $out_fh "} $enum_declaration_type;\n"; } switch_pound_if($name, $where, $charset); $invmap_declaration_type = ($input_format =~ /s/) ? $enum_declaration_type : "int"; $aux_declaration_type = ($input_format =~ /s/) ? $enum_declaration_type : "unsigned int"; $output_format = "${name_prefix}%s"; # If there are auxiliary tables, output them. if (%multiples) { print $out_fh "\n#define HAS_${name_prefix}AUX_TABLES\n"; # Invert keys and values my %inverted_mults; while (my ($key, $value) = each %multiples) { $inverted_mults{$value} = $key; } # Output them in sorted order my @sorted_table_list = sort { $a <=> $b } keys %inverted_mults; # Keep track of how big each aux table is my @aux_counts; # Output each aux table. foreach my $table_number (@sorted_table_list) { my $table = $inverted_mults{$table_number}; output_table_header($out_fh, $aux_declaration_type, "$name_prefix$aux_table_prefix$table_number"); # Earlier, we joined the elements of this table together with a comma my @elements = split ",", $table; $aux_counts[$table_number] = scalar @elements; for my $i (0 .. @elements - 1) { print $out_fh ",\n" if $i > 0; if ($input_format =~ /a/) { printf $out_fh "\t0x%X", $elements[$i]; } else { print $out_fh "\t${name_prefix}$elements[$i]"; } } print $out_fh "\n"; output_table_trailer(); } # Output the table that is indexed by the absolute value of the # aux table enum and contains pointers to the tables output just # above output_table_header($out_fh, "$aux_declaration_type *", "${name_prefix}${aux_table_prefix}ptrs"); print $out_fh "\tNULL,\t/* Placeholder */\n"; for my $i (1 .. @sorted_table_list) { print $out_fh ",\n" if $i > 1; print $out_fh "\t$name_prefix$aux_table_prefix$i"; } print $out_fh "\n"; output_table_trailer(); print $out_fh "\n/* Parallel table to the above, giving the number of elements" . " in each table\n * pointed to */\n"; output_table_header($out_fh, "U8", "${name_prefix}${aux_table_prefix}lengths"); print $out_fh "\t0,\t/* Placeholder */\n"; for my $i (1 .. @sorted_table_list) { print $out_fh ",\n" if $i > 1; print $out_fh "\t$aux_counts[$i]\t/* $name_prefix$aux_table_prefix$i */"; } print $out_fh "\n"; output_table_trailer(); } # End of outputting the auxiliary and associated tables # The scx property used in regexec.c needs a specialized table which # is most convenient to output here, while the data structures set up # above are still extant. This table contains the code point that is # the zero digit of each script, indexed by script enum value. if (lc $short_name eq 'scx') { my @decimals_invlist = prop_invlist("Numeric_Type=Decimal"); my %script_zeros; # Find all the decimal digits. The 0 of each range is always the # 0th element, except in some early Unicode releases, so check for # that. for (my $i = 0; $i < @decimals_invlist; $i += 2) { my $code_point = $decimals_invlist[$i]; next if num(chr($code_point)) ne '0'; # Turn the scripts this zero is in into a list. my @scripts = split ",", charprop($code_point, "_Perl_SCX", '_perl_core_internal_ok'); $code_point = sprintf("0x%x", $code_point); foreach my $script (@scripts) { if (! exists $script_zeros{$script}) { $script_zeros{$script} = $code_point; } elsif (ref $script_zeros{$script}) { push $script_zeros{$script}->@*, $code_point; } else { # Turn into a list if this is the 2nd zero of the # script my $existing = $script_zeros{$script}; undef $script_zeros{$script}; push $script_zeros{$script}->@*, $existing, $code_point; } } } # @script_zeros contains the zero, sorted by the script's enum # value my @script_zeros; foreach my $script (keys %script_zeros) { my $enum_value = $enums{$script}; $script_zeros[$enum_value] = $script_zeros{$script}; } print $out_fh "\n/* This table, indexed by the script enum, gives the zero" . " code point for that\n * script; 0 if the script has multiple" . " digit sequences. Scripts without a\n * digit sequence use" . " ASCII [0-9], hence are marked '0' */\n"; output_table_header($out_fh, "UV", "script_zeros"); for my $i (0 .. @script_zeros - 1) { my $code_point = $script_zeros[$i]; if (defined $code_point) { $code_point = " 0" if ref $code_point; print $out_fh "\t$code_point"; } elsif (lc $enum_list[$i] eq 'inherited') { print $out_fh "\t 0"; } else { # The only digits a script without its own set accepts # is [0-9] print $out_fh "\t'0'"; } print $out_fh "," if $i < @script_zeros - 1; print $out_fh "\t/* $enum_list[$i] */"; print $out_fh "\n"; } output_table_trailer(); } # End of special handling of scx } else { die "'$input_format' invmap() format for '$prop_name' unimplemented"; } die "No inversion map for $prop_name" unless defined $invmap && ref $invmap eq 'ARRAY' && $count; # Now output the inversion map proper $charset = "for $charset" if $charset; output_table_header($out_fh, $invmap_declaration_type, "${name}_invmap", $charset); # The main body are the scalars passed in to this routine. for my $i (0 .. $count - 1) { my $element = $invmap->[$i]; my $full_element_name = prop_value_aliases($prop_name, $element); if ($input_format =~ /a/ && $element !~ /\D/) { $element = ($element == 0) ? 0 : sprintf("0x%X", $element); } else { $element = $full_element_name if defined $full_element_name; $element = $name_prefix . $element; } print $out_fh "\t$element"; print $out_fh "," if $i < $count - 1; print $out_fh "\n"; } output_table_trailer(); } sub mk_invlist_from_sorted_cp_list { # Returns an inversion list constructed from the sorted input array of # code points my $list_ref = shift; return unless @$list_ref; # Initialize to just the first element my @invlist = ( $list_ref->[0], $list_ref->[0] + 1); # For each succeeding element, if it extends the previous range, adjust # up, otherwise add it. for my $i (1 .. @$list_ref - 1) { if ($invlist[-1] == $list_ref->[$i]) { $invlist[-1]++; } else { push @invlist, $list_ref->[$i], $list_ref->[$i] + 1; } } return @invlist; } # Read in the Case Folding rules, and construct arrays of code points for the # properties we need. my ($cp_ref, $folds_ref, $format, $default) = prop_invmap("Case_Folding"); die "Could not find inversion map for Case_Folding" unless defined $format; die "Incorrect format '$format' for Case_Folding inversion map" unless $format eq 'al' || $format eq 'a'; sub _Perl_IVCF { # This creates a map of the inversion of case folding. i.e., given a # character, it gives all the other characters that fold to it. # # Inversion maps function kind of like a hash, with the inversion list # specifying the buckets (keys) and the inversion maps specifying the # contents of the corresponding bucket. Effectively this function just # swaps the keys and values of the case fold hash. But there are # complications. Most importantly, More than one character can each have # the same fold. This is solved by having a list of characters that fold # to a given one. my %new; # Go through the inversion list. for (my $i = 0; $i < @$cp_ref; $i++) { # Skip if nothing folds to this next if $folds_ref->[$i] == 0; # This entry which is valid from here to up (but not including) the # next entry is for the next $count characters, so that, for example, # A-Z is represented by one entry. my $cur_list = $cp_ref->[$i]; my $count = $cp_ref->[$i+1] - $cur_list; # The fold of [$i] can be not just a single character, but a sequence # of multiple ones. We deal with those here by just creating a string # consisting of them. Otherwise, we use the single code point [$i] # folds to. my $cur_map = (ref $folds_ref->[$i]) ? join "", map { chr } $folds_ref->[$i]->@* : $folds_ref->[$i]; # Expand out this range while ($count > 0) { push @{$new{$cur_map}}, $cur_list; # A multiple-character fold is a string, and shouldn't need # incrementing anyway if (ref $folds_ref->[$i]) { die sprintf("Case fold for %x is multiple chars; should have" . " a count of 1, but instead it was $count", $count) unless $count == 1; } else { $cur_map++; $cur_list++; } $count--; } } # Now go through and make some adjustments. We add synthetic entries for # two cases. # 1) Two or more code points can fold to the same multiple character, # sequence, as U+FB05 and U+FB06 both fold to 'st'. This code is only # for single character folds, but FB05 and FB06 are single characters # that are equivalent folded, so we add entries so that they are # considered to fold to each other # 2) If two or more above-Latin1 code points fold to the same Latin1 range # one, we also add entries so that they are considered to fold to each # other. This is so that under /aa or /l matching, where folding to # their Latin1 range code point is illegal, they still can fold to each # other. This situation happens in Unicode 3.0.1, but probably no # other version. foreach my $fold (keys %new) { my $folds_to_string = $fold =~ /\D/; # If the bucket contains only one element, convert from an array to a # scalar if (scalar $new{$fold}->@* == 1) { $new{$fold} = $new{$fold}[0]; } else { # Otherwise, sort numerically. This places the highest code point # in the list at the tail end. This is because Unicode keeps the # lowercase code points as higher ordinals than the uppercase, at # least for the ones that matter so far. These are synthetic # entries, and we want to predictably have the lowercase (which is # more likely to be what gets folded to) in the same corresponding # position, so that other code can rely on that. If some new # version of Unicode came along that violated this, we might have # to change so that the sort is based on upper vs lower instead. # (The lower-comes-after isn't true of native EBCDIC, but here we # are dealing strictly with Unicode values). @{$new{$fold}} = sort { $a <=> $b } $new{$fold}->@* unless $folds_to_string; # We will be working with a copy of this sorted entry. my @source_list = $new{$fold}->@*; if (! $folds_to_string) { # This handles situation 2) listed above, which only arises if # what is being folded-to (the fold) is in the Latin1 range. if ($fold > 255 ) { undef @source_list; } else { # And it only arises if there are two or more folders that # fold to it above Latin1. We look at just those. @source_list = grep { $_ > 255 } @source_list; undef @source_list if @source_list == 1; } } # Here, we've found the items we want to set up synthetic folds # for. Add entries so that each folds to each other. foreach my $cp (@source_list) { my @rest = grep { $cp != $_ } @source_list; if (@rest == 1) { $new{$cp} = $rest[0]; } else { push @{$new{$cp}}, @rest; } } } # We don't otherwise deal with multiple-character folds delete $new{$fold} if $folds_to_string; } # Now we have a hash that is the inversion of the case fold property. # First find the maximum number of code points that fold to the same one. foreach my $fold_to (keys %new) { if (ref $new{$fold_to}) { my $folders_count = scalar @{$new{$fold_to}}; $max_fold_froms = $folders_count if $folders_count > $max_fold_froms; } } # Then convert the hash to an inversion map. my @sorted_folds = sort { $a <=> $b } keys %new; my (@invlist, @invmap); # We know that nothing folds to the controls (whose ordinals start at 0). # And the first real entries are the lowest in the hash. push @invlist, 0, $sorted_folds[0]; push @invmap, 0, $new{$sorted_folds[0]}; # Go through the remainder of the hash keys (which are the folded code # points) for (my $i = 1; $i < @sorted_folds; $i++) { # Get the current one, and the one prior to it. my $fold = $sorted_folds[$i]; my $prev_fold = $sorted_folds[$i-1]; # If the current one is not just 1 away from the prior one, we close # out the range containing the previous fold, and know that the gap # doesn't have anything that folds. if ($fold - 1 != $prev_fold) { push @invlist, $prev_fold + 1; push @invmap, 0; # And start a new range push @invlist, $fold; push @invmap, $new{$fold}; } elsif ($new{$fold} - 1 != $new{$prev_fold}) { # Here the current fold is just 1 greater than the previous, but # the new map isn't correspondingly 1 greater than the previous, # the old range is ended, but since there is no gap, we don't have # to insert anything else. push @invlist, $fold; push @invmap, $new{$fold}; } # else { Otherwise, this new entry just extends the previous } die "In IVCF: $invlist[-1] <= $invlist[-2]" if $invlist[-1] <= $invlist[-2]; } # And add an entry that indicates that everything above this, to infinity, # does not have a case fold. push @invlist, $sorted_folds[-1] + 1; push @invmap, 0; # All Unicode versions have some places where multiple code points map to # the same one, so the format always has an 'l' return \@invlist, \@invmap, 'al', $default; } sub prop_name_for_cmp ($) { # Sort helper my $name = shift; # Returns the input lowercased, with non-alphas removed, as well as # everything starting with a comma $name =~ s/,.*//; $name =~ s/[[:^alpha:]]//g; return lc $name; } sub UpperLatin1 { my @return = mk_invlist_from_sorted_cp_list([ 128 .. 255 ]); return \@return; } sub _Perl_CCC_non0_non230 { # Create an inversion list of code points with non-zero canonical # combining class that also don't have 230 as the class number. This is # part of a Unicode Standard rule my @nonzeros = prop_invlist("ccc=0"); shift @nonzeros; # Invert so is "ccc != 0" my @return; # Expand into list of code points, while excluding those with ccc == 230 for (my $i = 0; $i < @nonzeros; $i += 2) { my $upper = ($i + 1) < @nonzeros ? $nonzeros[$i+1] - 1 # In range : $Unicode::UCD::MAX_CP; # To infinity. for my $j ($nonzeros[$i] .. $upper) { my @ccc_names = prop_value_aliases("ccc", charprop($j, "ccc")); # Final element in @ccc_names will be all numeric push @return, $j if $ccc_names[-1] != 230; } } @return = sort { $a <=> $b } @return; @return = mk_invlist_from_sorted_cp_list(\@return); return \@return; } sub output_table_common { # Common subroutine to actually output the generated rules table. my ($property, $table_value_defines_ref, $table_ref, $names_ref, $abbreviations_ref) = @_; my $size = @$table_ref; # Output the #define list, sorted by numeric value if ($table_value_defines_ref) { my $max_name_length = 0; my @defines; # Put in order, and at the same time find the longest name while (my ($enum, $value) = each %$table_value_defines_ref) { $defines[$value] = $enum; my $length = length $enum; $max_name_length = $length if $length > $max_name_length; } print $out_fh "\n"; # Output, so that the values are vertically aligned in a column after # the longest name foreach my $i (0 .. @defines - 1) { next unless defined $defines[$i]; printf $out_fh "#define %-*s %2d\n", $max_name_length, $defines[$i], $i; } } my $column_width = 2; # We currently allow 2 digits for the number # Being above a U8 is not currently handled my $table_type = 'U8'; # If a name is longer than the width set aside for a column, its column # needs to have increased spacing so that the name doesn't get truncated # nor run into an adjacent column my @spacers; # Is there a row and column for unused values in this release? my $has_unused = $names_ref->[$size-1] eq $unused_table_hdr; for my $i (0 .. $size - 1) { no warnings 'numeric'; $spacers[$i] = " " x (length($names_ref->[$i]) - $column_width); } output_table_header($out_fh, $table_type, "${property}_table", undef, $size, $size); # Calculate the column heading line my $header_line = "/* " . (" " x $max_hdr_len) # We let the row heading meld to # the '*/' for those that are at # the max . " " x 3; # Space for '*/ ' # Now each column for my $i (0 .. $size - 1) { $header_line .= sprintf "%s%*s", $spacers[$i], $column_width + 1, # 1 for the ',' $names_ref->[$i]; } $header_line .= " */\n"; # If we have annotations, output it now. if ($has_unused || scalar %$abbreviations_ref) { my $text = ""; foreach my $abbr (sort keys %$abbreviations_ref) { $text .= "; " if $text; $text .= "'$abbr' stands for '$abbreviations_ref->{$abbr}'"; } if ($has_unused) { $text .= "; $unused_table_hdr stands for 'unused in this Unicode" . " release (and the data in the row or column are garbage)" } my $indent = " " x 3; $text = $indent . "/* $text */"; # Wrap the text so that it is no wider than the table, which the # header line gives. my $output_width = length $header_line; while (length $text > $output_width) { my $cur_line = substr($text, 0, $output_width); # Find the first blank back from the right end to wrap at. for (my $i = $output_width -1; $i > 0; $i--) { if (substr($text, $i, 1) eq " ") { print $out_fh substr($text, 0, $i), "\n"; # Set so will look at just the remaining tail (which will # be indented and have a '*' after the indent $text = $indent . " * " . substr($text, $i + 1); last; } } } # And any remaining print $out_fh $text, "\n" if $text; } # We calculated the header line earlier just to get its width so that we # could make sure the annotations fit into that. print $out_fh $header_line; # Now output the bulk of the table. for my $i (0 .. $size - 1) { # First the row heading. printf $out_fh "/* %-*s*/ ", $max_hdr_len, $names_ref->[$i]; print $out_fh "{"; # Then the brace for this row # Then each column for my $j (0 .. $size -1) { print $out_fh $spacers[$j]; printf $out_fh "%*d", $column_width, $table_ref->[$i][$j]; print $out_fh "," if $j < $size - 1; } print $out_fh " }"; print $out_fh "," if $i < $size - 1; print $out_fh "\n"; } output_table_trailer(); } sub output_GCB_table() { # Create and output the pair table for use in determining Grapheme Cluster # Breaks, given in http://www.unicode.org/reports/tr29/. my %gcb_actions = ( GCB_NOBREAK => 0, GCB_BREAKABLE => 1, GCB_RI_then_RI => 2, # Rules 12 and 13 GCB_EX_then_EM => 3, # Rule 10 GCB_Maybe_Emoji_NonBreak => 4, ); # The table is constructed in reverse order of the rules, to make the # lower-numbered, higher priority ones override the later ones, as the # algorithm stops at the earliest matching rule my @gcb_table; my $table_size = @gcb_short_enums; # Otherwise, break everywhere. # GB99 Any ÷ Any for my $i (0 .. $table_size - 1) { for my $j (0 .. $table_size - 1) { $gcb_table[$i][$j] = 1; } } # Do not break within emoji flag sequences. That is, do not break between # regional indicator (RI) symbols if there is an odd number of RI # characters before the break point. Must be resolved in runtime code. # # GB12 sot (RI RI)* RI × RI # GB13 [^RI] (RI RI)* RI × RI $gcb_table[$gcb_enums{'Regional_Indicator'}] [$gcb_enums{'Regional_Indicator'}] = $gcb_actions{GCB_RI_then_RI}; # Post 11.0: GB11 \p{Extended_Pictographic} Extend* ZWJ # × \p{Extended_Pictographic} $gcb_table[$gcb_enums{'ZWJ'}][$gcb_enums{'XPG_XX'}] = $gcb_actions{GCB_Maybe_Emoji_NonBreak}; # This and the rule GB10 obsolete starting with Unicode 11.0, can be left # in as there are no code points that match, so the code won't ever get # executed. # Do not break within emoji modifier sequences or emoji zwj sequences. # Pre 11.0: GB11 ZWJ × ( Glue_After_Zwj | E_Base_GAZ ) $gcb_table[$gcb_enums{'ZWJ'}][$gcb_enums{'Glue_After_Zwj'}] = 0; $gcb_table[$gcb_enums{'ZWJ'}][$gcb_enums{'E_Base_GAZ'}] = 0; # GB10 ( E_Base | E_Base_GAZ ) Extend* × E_Modifier $gcb_table[$gcb_enums{'Extend'}][$gcb_enums{'E_Modifier'}] = $gcb_actions{GCB_EX_then_EM}; $gcb_table[$gcb_enums{'E_Base'}][$gcb_enums{'E_Modifier'}] = 0; $gcb_table[$gcb_enums{'E_Base_GAZ'}][$gcb_enums{'E_Modifier'}] = 0; # Do not break before extending characters or ZWJ. # Do not break before SpacingMarks, or after Prepend characters. # GB9b Prepend × # GB9a × SpacingMark # GB9 × ( Extend | ZWJ ) for my $i (0 .. @gcb_table - 1) { $gcb_table[$gcb_enums{'Prepend'}][$i] = 0; $gcb_table[$i][$gcb_enums{'SpacingMark'}] = 0; $gcb_table[$i][$gcb_enums{'Extend'}] = 0; $gcb_table[$i][$gcb_enums{'ZWJ'}] = 0; } # Do not break Hangul syllable sequences. # GB8 ( LVT | T) × T $gcb_table[$gcb_enums{'LVT'}][$gcb_enums{'T'}] = 0; $gcb_table[$gcb_enums{'T'}][$gcb_enums{'T'}] = 0; # GB7 ( LV | V ) × ( V | T ) $gcb_table[$gcb_enums{'LV'}][$gcb_enums{'V'}] = 0; $gcb_table[$gcb_enums{'LV'}][$gcb_enums{'T'}] = 0; $gcb_table[$gcb_enums{'V'}][$gcb_enums{'V'}] = 0; $gcb_table[$gcb_enums{'V'}][$gcb_enums{'T'}] = 0; # GB6 L × ( L | V | LV | LVT ) $gcb_table[$gcb_enums{'L'}][$gcb_enums{'L'}] = 0; $gcb_table[$gcb_enums{'L'}][$gcb_enums{'V'}] = 0; $gcb_table[$gcb_enums{'L'}][$gcb_enums{'LV'}] = 0; $gcb_table[$gcb_enums{'L'}][$gcb_enums{'LVT'}] = 0; # Do not break between a CR and LF. Otherwise, break before and after # controls. # GB5 ÷ ( Control | CR | LF ) # GB4 ( Control | CR | LF ) ÷ for my $i (0 .. @gcb_table - 1) { $gcb_table[$i][$gcb_enums{'Control'}] = 1; $gcb_table[$i][$gcb_enums{'CR'}] = 1; $gcb_table[$i][$gcb_enums{'LF'}] = 1; $gcb_table[$gcb_enums{'Control'}][$i] = 1; $gcb_table[$gcb_enums{'CR'}][$i] = 1; $gcb_table[$gcb_enums{'LF'}][$i] = 1; } # GB3 CR × LF $gcb_table[$gcb_enums{'CR'}][$gcb_enums{'LF'}] = 0; # Break at the start and end of text, unless the text is empty # GB1 sot ÷ # GB2 ÷ eot for my $i (0 .. @gcb_table - 1) { $gcb_table[$i][$gcb_enums{'EDGE'}] = 1; $gcb_table[$gcb_enums{'EDGE'}][$i] = 1; } $gcb_table[$gcb_enums{'EDGE'}][$gcb_enums{'EDGE'}] = 0; output_table_common('GCB', \%gcb_actions, \@gcb_table, \@gcb_short_enums, \%gcb_abbreviations); } sub output_LB_table() { # Create and output the enums, #defines, and pair table for use in # determining Line Breaks. This uses the default line break algorithm, # given in http://www.unicode.org/reports/tr14/, but tailored by example 7 # in that page, as the Unicode-furnished tests assume that tailoring. # The result is really just true or false. But we follow along with tr14, # creating a rule which is false for something like X SP* X. That gets # encoding 2. The rest of the actions are synthetic ones that indicate # some context handling is required. These each are added to the # underlying 0, 1, or 2, instead of replacing them, so that the underlying # value can be retrieved. Actually only rules from 7 through 18 (which # are the ones where space matter) are possible to have 2 added to them. # The others below add just 0 or 1. It might be possible for one # synthetic rule to be added to another, yielding a larger value. This # doesn't happen in the Unicode 8.0 rule set, and as you can see from the # names of the middle grouping below, it is impossible for that to occur # for them because they all start with mutually exclusive classes. That # the final rule can't be added to any of the others isn't obvious from # its name, so it is assigned a power of 2 higher than the others can get # to so any addition would preserve all data. (And the code will reach an # assert(0) on debugging builds should this happen.) my %lb_actions = ( LB_NOBREAK => 0, LB_BREAKABLE => 1, LB_NOBREAK_EVEN_WITH_SP_BETWEEN => 2, LB_CM_ZWJ_foo => 3, # Rule 9 LB_SP_foo => 6, # Rule 18 LB_PR_or_PO_then_OP_or_HY => 9, # Rule 25 LB_SY_or_IS_then_various => 11, # Rule 25 LB_HY_or_BA_then_foo => 13, # Rule 21 LB_RI_then_RI => 15, # Rule 30a LB_various_then_PO_or_PR => (1<<5), # Rule 25 ); # Construct the LB pair table. This is based on the rules in # http://www.unicode.org/reports/tr14/, but modified as those rules are # designed for someone taking a string of text and sequentially going # through it to find the break opportunities, whereas, Perl requires # determining if a given random spot is a break opportunity, without # knowing all the entire string before it. # # The table is constructed in reverse order of the rules, to make the # lower-numbered, higher priority ones override the later ones, as the # algorithm stops at the earliest matching rule my @lb_table; my $table_size = @lb_short_enums; # LB31. Break everywhere else for my $i (0 .. $table_size - 1) { for my $j (0 .. $table_size - 1) { $lb_table[$i][$j] = $lb_actions{'LB_BREAKABLE'}; } } # LB30b Do not break between an emoji base and an emoji modifier. # EB × EM $lb_table[$lb_enums{'E_Base'}][$lb_enums{'E_Modifier'}] = $lb_actions{'LB_NOBREAK'}; # LB30a Break between two regional indicator symbols if and only if there # are an even number of regional indicators preceding the position of the # break. # sot (RI RI)* RI × RI # [^RI] (RI RI)* RI × RI $lb_table[$lb_enums{'Regional_Indicator'}] [$lb_enums{'Regional_Indicator'}] = $lb_actions{'LB_RI_then_RI'}; # LB30 Do not break between letters, numbers, or ordinary symbols and # opening or closing parentheses. # (AL | HL | NU) × OP $lb_table[$lb_enums{'Alphabetic'}][$lb_enums{'Open_Punctuation'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Hebrew_Letter'}][$lb_enums{'Open_Punctuation'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Numeric'}][$lb_enums{'Open_Punctuation'}] = $lb_actions{'LB_NOBREAK'}; # CP × (AL | HL | NU) $lb_table[$lb_enums{'Close_Parenthesis'}][$lb_enums{'Alphabetic'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Close_Parenthesis'}][$lb_enums{'Hebrew_Letter'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Close_Parenthesis'}][$lb_enums{'Numeric'}] = $lb_actions{'LB_NOBREAK'}; # LB29 Do not break between numeric punctuation and alphabetics (“e.g.”). # IS × (AL | HL) $lb_table[$lb_enums{'Infix_Numeric'}][$lb_enums{'Alphabetic'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Infix_Numeric'}][$lb_enums{'Hebrew_Letter'}] = $lb_actions{'LB_NOBREAK'}; # LB28 Do not break between alphabetics (“at”). # (AL | HL) × (AL | HL) $lb_table[$lb_enums{'Alphabetic'}][$lb_enums{'Alphabetic'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Hebrew_Letter'}][$lb_enums{'Alphabetic'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Alphabetic'}][$lb_enums{'Hebrew_Letter'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Hebrew_Letter'}][$lb_enums{'Hebrew_Letter'}] = $lb_actions{'LB_NOBREAK'}; # LB27 Treat a Korean Syllable Block the same as ID. # (JL | JV | JT | H2 | H3) × IN $lb_table[$lb_enums{'JL'}][$lb_enums{'Inseparable'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'JV'}][$lb_enums{'Inseparable'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'JT'}][$lb_enums{'Inseparable'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'H2'}][$lb_enums{'Inseparable'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'H3'}][$lb_enums{'Inseparable'}] = $lb_actions{'LB_NOBREAK'}; # (JL | JV | JT | H2 | H3) × PO $lb_table[$lb_enums{'JL'}][$lb_enums{'Postfix_Numeric'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'JV'}][$lb_enums{'Postfix_Numeric'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'JT'}][$lb_enums{'Postfix_Numeric'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'H2'}][$lb_enums{'Postfix_Numeric'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'H3'}][$lb_enums{'Postfix_Numeric'}] = $lb_actions{'LB_NOBREAK'}; # PR × (JL | JV | JT | H2 | H3) $lb_table[$lb_enums{'Prefix_Numeric'}][$lb_enums{'JL'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Prefix_Numeric'}][$lb_enums{'JV'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Prefix_Numeric'}][$lb_enums{'JT'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Prefix_Numeric'}][$lb_enums{'H2'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Prefix_Numeric'}][$lb_enums{'H3'}] = $lb_actions{'LB_NOBREAK'}; # LB26 Do not break a Korean syllable. # JL × (JL | JV | H2 | H3) $lb_table[$lb_enums{'JL'}][$lb_enums{'JL'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'JL'}][$lb_enums{'JV'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'JL'}][$lb_enums{'H2'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'JL'}][$lb_enums{'H3'}] = $lb_actions{'LB_NOBREAK'}; # (JV | H2) × (JV | JT) $lb_table[$lb_enums{'JV'}][$lb_enums{'JV'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'H2'}][$lb_enums{'JV'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'JV'}][$lb_enums{'JT'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'H2'}][$lb_enums{'JT'}] = $lb_actions{'LB_NOBREAK'}; # (JT | H3) × JT $lb_table[$lb_enums{'JT'}][$lb_enums{'JT'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'H3'}][$lb_enums{'JT'}] = $lb_actions{'LB_NOBREAK'}; # LB25 Do not break between the following pairs of classes relevant to # numbers, as tailored by example 7 in # http://www.unicode.org/reports/tr14/#Examples # We follow that tailoring because Unicode's test cases expect it # (PR | PO) × ( OP | HY )? NU $lb_table[$lb_enums{'Prefix_Numeric'}][$lb_enums{'Numeric'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Postfix_Numeric'}][$lb_enums{'Numeric'}] = $lb_actions{'LB_NOBREAK'}; # Given that (OP | HY )? is optional, we have to test for it in code. # We add in the action (instead of overriding) for this, so that in # the code we can recover the underlying break value. $lb_table[$lb_enums{'Prefix_Numeric'}][$lb_enums{'Open_Punctuation'}] += $lb_actions{'LB_PR_or_PO_then_OP_or_HY'}; $lb_table[$lb_enums{'Postfix_Numeric'}][$lb_enums{'Open_Punctuation'}] += $lb_actions{'LB_PR_or_PO_then_OP_or_HY'}; $lb_table[$lb_enums{'Prefix_Numeric'}][$lb_enums{'Hyphen'}] += $lb_actions{'LB_PR_or_PO_then_OP_or_HY'}; $lb_table[$lb_enums{'Postfix_Numeric'}][$lb_enums{'Hyphen'}] += $lb_actions{'LB_PR_or_PO_then_OP_or_HY'}; # ( OP | HY ) × NU $lb_table[$lb_enums{'Open_Punctuation'}][$lb_enums{'Numeric'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Hyphen'}][$lb_enums{'Numeric'}] = $lb_actions{'LB_NOBREAK'}; # NU (NU | SY | IS)* × (NU | SY | IS | CL | CP ) # which can be rewritten as: # NU (SY | IS)* × (NU | SY | IS | CL | CP ) $lb_table[$lb_enums{'Numeric'}][$lb_enums{'Numeric'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Numeric'}][$lb_enums{'Break_Symbols'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Numeric'}][$lb_enums{'Infix_Numeric'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Numeric'}][$lb_enums{'Close_Punctuation'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Numeric'}][$lb_enums{'Close_Parenthesis'}] = $lb_actions{'LB_NOBREAK'}; # Like earlier where we have to test in code, we add in the action so # that we can recover the underlying values. This is done in rules # below, as well. The code assumes that we haven't added 2 actions. # Shoul a later Unicode release break that assumption, then tests # should start failing. $lb_table[$lb_enums{'Break_Symbols'}][$lb_enums{'Numeric'}] += $lb_actions{'LB_SY_or_IS_then_various'}; $lb_table[$lb_enums{'Break_Symbols'}][$lb_enums{'Break_Symbols'}] += $lb_actions{'LB_SY_or_IS_then_various'}; $lb_table[$lb_enums{'Break_Symbols'}][$lb_enums{'Infix_Numeric'}] += $lb_actions{'LB_SY_or_IS_then_various'}; $lb_table[$lb_enums{'Break_Symbols'}][$lb_enums{'Close_Punctuation'}] += $lb_actions{'LB_SY_or_IS_then_various'}; $lb_table[$lb_enums{'Break_Symbols'}][$lb_enums{'Close_Parenthesis'}] += $lb_actions{'LB_SY_or_IS_then_various'}; $lb_table[$lb_enums{'Infix_Numeric'}][$lb_enums{'Numeric'}] += $lb_actions{'LB_SY_or_IS_then_various'}; $lb_table[$lb_enums{'Infix_Numeric'}][$lb_enums{'Break_Symbols'}] += $lb_actions{'LB_SY_or_IS_then_various'}; $lb_table[$lb_enums{'Infix_Numeric'}][$lb_enums{'Infix_Numeric'}] += $lb_actions{'LB_SY_or_IS_then_various'}; $lb_table[$lb_enums{'Infix_Numeric'}][$lb_enums{'Close_Punctuation'}] += $lb_actions{'LB_SY_or_IS_then_various'}; $lb_table[$lb_enums{'Infix_Numeric'}][$lb_enums{'Close_Parenthesis'}] += $lb_actions{'LB_SY_or_IS_then_various'}; # NU (NU | SY | IS)* (CL | CP)? × (PO | PR) # which can be rewritten as: # NU (SY | IS)* (CL | CP)? × (PO | PR) $lb_table[$lb_enums{'Numeric'}][$lb_enums{'Postfix_Numeric'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Numeric'}][$lb_enums{'Prefix_Numeric'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Close_Parenthesis'}][$lb_enums{'Postfix_Numeric'}] += $lb_actions{'LB_various_then_PO_or_PR'}; $lb_table[$lb_enums{'Close_Punctuation'}][$lb_enums{'Postfix_Numeric'}] += $lb_actions{'LB_various_then_PO_or_PR'}; $lb_table[$lb_enums{'Infix_Numeric'}][$lb_enums{'Postfix_Numeric'}] += $lb_actions{'LB_various_then_PO_or_PR'}; $lb_table[$lb_enums{'Break_Symbols'}][$lb_enums{'Postfix_Numeric'}] += $lb_actions{'LB_various_then_PO_or_PR'}; $lb_table[$lb_enums{'Close_Parenthesis'}][$lb_enums{'Prefix_Numeric'}] += $lb_actions{'LB_various_then_PO_or_PR'}; $lb_table[$lb_enums{'Close_Punctuation'}][$lb_enums{'Prefix_Numeric'}] += $lb_actions{'LB_various_then_PO_or_PR'}; $lb_table[$lb_enums{'Infix_Numeric'}][$lb_enums{'Prefix_Numeric'}] += $lb_actions{'LB_various_then_PO_or_PR'}; $lb_table[$lb_enums{'Break_Symbols'}][$lb_enums{'Prefix_Numeric'}] += $lb_actions{'LB_various_then_PO_or_PR'}; # LB24 Do not break between numeric prefix/postfix and letters, or between # letters and prefix/postfix. # (PR | PO) × (AL | HL) $lb_table[$lb_enums{'Prefix_Numeric'}][$lb_enums{'Alphabetic'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Prefix_Numeric'}][$lb_enums{'Hebrew_Letter'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Postfix_Numeric'}][$lb_enums{'Alphabetic'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Postfix_Numeric'}][$lb_enums{'Hebrew_Letter'}] = $lb_actions{'LB_NOBREAK'}; # (AL | HL) × (PR | PO) $lb_table[$lb_enums{'Alphabetic'}][$lb_enums{'Prefix_Numeric'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Hebrew_Letter'}][$lb_enums{'Prefix_Numeric'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Alphabetic'}][$lb_enums{'Postfix_Numeric'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Hebrew_Letter'}][$lb_enums{'Postfix_Numeric'}] = $lb_actions{'LB_NOBREAK'}; # LB23a Do not break between numeric prefixes and ideographs, or between # ideographs and numeric postfixes. # PR × (ID | EB | EM) $lb_table[$lb_enums{'Prefix_Numeric'}][$lb_enums{'Ideographic'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Prefix_Numeric'}][$lb_enums{'E_Base'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Prefix_Numeric'}][$lb_enums{'E_Modifier'}] = $lb_actions{'LB_NOBREAK'}; # (ID | EB | EM) × PO $lb_table[$lb_enums{'Ideographic'}][$lb_enums{'Postfix_Numeric'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'E_Base'}][$lb_enums{'Postfix_Numeric'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'E_Modifier'}][$lb_enums{'Postfix_Numeric'}] = $lb_actions{'LB_NOBREAK'}; # LB23 Do not break between digits and letters # (AL | HL) × NU $lb_table[$lb_enums{'Alphabetic'}][$lb_enums{'Numeric'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Hebrew_Letter'}][$lb_enums{'Numeric'}] = $lb_actions{'LB_NOBREAK'}; # NU × (AL | HL) $lb_table[$lb_enums{'Numeric'}][$lb_enums{'Alphabetic'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Numeric'}][$lb_enums{'Hebrew_Letter'}] = $lb_actions{'LB_NOBREAK'}; # LB22 Do not break between two ellipses, or between letters, numbers or # exclamations and ellipsis. # (AL | HL) × IN $lb_table[$lb_enums{'Alphabetic'}][$lb_enums{'Inseparable'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Hebrew_Letter'}][$lb_enums{'Inseparable'}] = $lb_actions{'LB_NOBREAK'}; # Exclamation × IN $lb_table[$lb_enums{'Exclamation'}][$lb_enums{'Inseparable'}] = $lb_actions{'LB_NOBREAK'}; # (ID | EB | EM) × IN $lb_table[$lb_enums{'Ideographic'}][$lb_enums{'Inseparable'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'E_Base'}][$lb_enums{'Inseparable'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'E_Modifier'}][$lb_enums{'Inseparable'}] = $lb_actions{'LB_NOBREAK'}; # IN × IN $lb_table[$lb_enums{'Inseparable'}][$lb_enums{'Inseparable'}] = $lb_actions{'LB_NOBREAK'}; # NU × IN $lb_table[$lb_enums{'Numeric'}][$lb_enums{'Inseparable'}] = $lb_actions{'LB_NOBREAK'}; # LB21b Don’t break between Solidus and Hebrew letters. # SY × HL $lb_table[$lb_enums{'Break_Symbols'}][$lb_enums{'Hebrew_Letter'}] = $lb_actions{'LB_NOBREAK'}; # LB21a Don't break after Hebrew + Hyphen. # HL (HY | BA) × for my $i (0 .. @lb_table - 1) { $lb_table[$lb_enums{'Hyphen'}][$i] += $lb_actions{'LB_HY_or_BA_then_foo'}; $lb_table[$lb_enums{'Break_After'}][$i] += $lb_actions{'LB_HY_or_BA_then_foo'}; } # LB21 Do not break before hyphen-minus, other hyphens, fixed-width # spaces, small kana, and other non-starters, or after acute accents. # × BA # × HY # × NS # BB × for my $i (0 .. @lb_table - 1) { $lb_table[$i][$lb_enums{'Break_After'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$i][$lb_enums{'Hyphen'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$i][$lb_enums{'Nonstarter'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Break_Before'}][$i] = $lb_actions{'LB_NOBREAK'}; } # LB20 Break before and after unresolved CB. # ÷ CB # CB ÷ # Conditional breaks should be resolved external to the line breaking # rules. However, the default action is to treat unresolved CB as breaking # before and after. for my $i (0 .. @lb_table - 1) { $lb_table[$i][$lb_enums{'Contingent_Break'}] = $lb_actions{'LB_BREAKABLE'}; $lb_table[$lb_enums{'Contingent_Break'}][$i] = $lb_actions{'LB_BREAKABLE'}; } # LB19 Do not break before or after quotation marks, such as ‘ ” ’. # × QU # QU × for my $i (0 .. @lb_table - 1) { $lb_table[$i][$lb_enums{'Quotation'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$lb_enums{'Quotation'}][$i] = $lb_actions{'LB_NOBREAK'}; } # LB18 Break after spaces # SP ÷ for my $i (0 .. @lb_table - 1) { $lb_table[$lb_enums{'Space'}][$i] = $lb_actions{'LB_BREAKABLE'}; } # LB17 Do not break within ‘——’, even with intervening spaces. # B2 SP* × B2 $lb_table[$lb_enums{'Break_Both'}][$lb_enums{'Break_Both'}] = $lb_actions{'LB_NOBREAK_EVEN_WITH_SP_BETWEEN'}; # LB16 Do not break between closing punctuation and a nonstarter even with # intervening spaces. # (CL | CP) SP* × NS $lb_table[$lb_enums{'Close_Punctuation'}][$lb_enums{'Nonstarter'}] = $lb_actions{'LB_NOBREAK_EVEN_WITH_SP_BETWEEN'}; $lb_table[$lb_enums{'Close_Parenthesis'}][$lb_enums{'Nonstarter'}] = $lb_actions{'LB_NOBREAK_EVEN_WITH_SP_BETWEEN'}; # LB15 Do not break within ‘”[’, even with intervening spaces. # QU SP* × OP $lb_table[$lb_enums{'Quotation'}][$lb_enums{'Open_Punctuation'}] = $lb_actions{'LB_NOBREAK_EVEN_WITH_SP_BETWEEN'}; # LB14 Do not break after ‘[’, even after spaces. # OP SP* × for my $i (0 .. @lb_table - 1) { $lb_table[$lb_enums{'Open_Punctuation'}][$i] = $lb_actions{'LB_NOBREAK_EVEN_WITH_SP_BETWEEN'}; } # LB13 Do not break before ‘]’ or ‘!’ or ‘;’ or ‘/’, even after spaces, as # tailored by example 7 in http://www.unicode.org/reports/tr14/#Examples # [^NU] × CL # [^NU] × CP # × EX # [^NU] × IS # [^NU] × SY for my $i (0 .. @lb_table - 1) { $lb_table[$i][$lb_enums{'Exclamation'}] = $lb_actions{'LB_NOBREAK_EVEN_WITH_SP_BETWEEN'}; next if $i == $lb_enums{'Numeric'}; $lb_table[$i][$lb_enums{'Close_Punctuation'}] = $lb_actions{'LB_NOBREAK_EVEN_WITH_SP_BETWEEN'}; $lb_table[$i][$lb_enums{'Close_Parenthesis'}] = $lb_actions{'LB_NOBREAK_EVEN_WITH_SP_BETWEEN'}; $lb_table[$i][$lb_enums{'Infix_Numeric'}] = $lb_actions{'LB_NOBREAK_EVEN_WITH_SP_BETWEEN'}; $lb_table[$i][$lb_enums{'Break_Symbols'}] = $lb_actions{'LB_NOBREAK_EVEN_WITH_SP_BETWEEN'}; } # LB12a Do not break before NBSP and related characters, except after # spaces and hyphens. # [^SP BA HY] × GL for my $i (0 .. @lb_table - 1) { next if $i == $lb_enums{'Space'} || $i == $lb_enums{'Break_After'} || $i == $lb_enums{'Hyphen'}; # We don't break, but if a property above has said don't break even # with space between, don't override that (also in the next few rules) next if $lb_table[$i][$lb_enums{'Glue'}] == $lb_actions{'LB_NOBREAK_EVEN_WITH_SP_BETWEEN'}; $lb_table[$i][$lb_enums{'Glue'}] = $lb_actions{'LB_NOBREAK'}; } # LB12 Do not break after NBSP and related characters. # GL × for my $i (0 .. @lb_table - 1) { next if $lb_table[$lb_enums{'Glue'}][$i] == $lb_actions{'LB_NOBREAK_EVEN_WITH_SP_BETWEEN'}; $lb_table[$lb_enums{'Glue'}][$i] = $lb_actions{'LB_NOBREAK'}; } # LB11 Do not break before or after Word joiner and related characters. # × WJ # WJ × for my $i (0 .. @lb_table - 1) { if ($lb_table[$i][$lb_enums{'Word_Joiner'}] != $lb_actions{'LB_NOBREAK_EVEN_WITH_SP_BETWEEN'}) { $lb_table[$i][$lb_enums{'Word_Joiner'}] = $lb_actions{'LB_NOBREAK'}; } if ($lb_table[$lb_enums{'Word_Joiner'}][$i] != $lb_actions{'LB_NOBREAK_EVEN_WITH_SP_BETWEEN'}) { $lb_table[$lb_enums{'Word_Joiner'}][$i] = $lb_actions{'LB_NOBREAK'}; } } # Special case this here to avoid having to do a special case in the code, # by making this the same as other things with a SP in front of them that # don't break, we avoid an extra test $lb_table[$lb_enums{'Space'}][$lb_enums{'Word_Joiner'}] = $lb_actions{'LB_NOBREAK_EVEN_WITH_SP_BETWEEN'}; # LB9 and LB10 are done in the same loop # # LB9 Do not break a combining character sequence; treat it as if it has # the line breaking class of the base character in all of the # higher-numbered rules. Treat ZWJ as if it were CM # Treat X (CM|ZWJ)* as if it were X. # where X is any line break class except BK, CR, LF, NL, SP, or ZW. # LB10 Treat any remaining combining mark or ZWJ as AL. This catches the # case where a CM or ZWJ is the first character on the line or follows SP, # BK, CR, LF, NL, or ZW. for my $i (0 .. @lb_table - 1) { # When the CM or ZWJ is the first in the pair, we don't know without # looking behind whether the CM or ZWJ is going to attach to an # earlier character, or not. So have to figure this out at runtime in # the code $lb_table[$lb_enums{'Combining_Mark'}][$i] = $lb_actions{'LB_CM_ZWJ_foo'}; $lb_table[$lb_enums{'ZWJ'}][$i] = $lb_actions{'LB_CM_ZWJ_foo'}; if ( $i == $lb_enums{'Mandatory_Break'} || $i == $lb_enums{'EDGE'} || $i == $lb_enums{'Carriage_Return'} || $i == $lb_enums{'Line_Feed'} || $i == $lb_enums{'Next_Line'} || $i == $lb_enums{'Space'} || $i == $lb_enums{'ZWSpace'}) { # For these classes, a following CM doesn't combine, and should do # whatever 'Alphabetic' would do. $lb_table[$i][$lb_enums{'Combining_Mark'}] = $lb_table[$i][$lb_enums{'Alphabetic'}]; $lb_table[$i][$lb_enums{'ZWJ'}] = $lb_table[$i][$lb_enums{'Alphabetic'}]; } else { # For these classes, the CM or ZWJ combines, so doesn't break, # inheriting the type of nobreak from the master character. if ($lb_table[$i][$lb_enums{'Combining_Mark'}] != $lb_actions{'LB_NOBREAK_EVEN_WITH_SP_BETWEEN'}) { $lb_table[$i][$lb_enums{'Combining_Mark'}] = $lb_actions{'LB_NOBREAK'}; } if ($lb_table[$i][$lb_enums{'ZWJ'}] != $lb_actions{'LB_NOBREAK_EVEN_WITH_SP_BETWEEN'}) { $lb_table[$i][$lb_enums{'ZWJ'}] = $lb_actions{'LB_NOBREAK'}; } } } # LB8a Do not break after a zero width joiner # ZWJ × for my $i (0 .. @lb_table - 1) { $lb_table[$lb_enums{'ZWJ'}][$i] = $lb_actions{'LB_NOBREAK'}; } # LB8 Break before any character following a zero-width space, even if one # or more spaces intervene. # ZW SP* ÷ for my $i (0 .. @lb_table - 1) { $lb_table[$lb_enums{'ZWSpace'}][$i] = $lb_actions{'LB_BREAKABLE'}; } # Because of LB8-10, we need to look at context for "SP x", and this must # be done in the code. So override the existing rules for that, by adding # a constant to get new rules that tell the code it needs to look at # context. By adding this action instead of replacing the existing one, # we can get back to the original rule if necessary. for my $i (0 .. @lb_table - 1) { $lb_table[$lb_enums{'Space'}][$i] += $lb_actions{'LB_SP_foo'}; } # LB7 Do not break before spaces or zero width space. # × SP # × ZW for my $i (0 .. @lb_table - 1) { $lb_table[$i][$lb_enums{'Space'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$i][$lb_enums{'ZWSpace'}] = $lb_actions{'LB_NOBREAK'}; } # LB6 Do not break before hard line breaks. # × ( BK | CR | LF | NL ) for my $i (0 .. @lb_table - 1) { $lb_table[$i][$lb_enums{'Mandatory_Break'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$i][$lb_enums{'Carriage_Return'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$i][$lb_enums{'Line_Feed'}] = $lb_actions{'LB_NOBREAK'}; $lb_table[$i][$lb_enums{'Next_Line'}] = $lb_actions{'LB_NOBREAK'}; } # LB5 Treat CR followed by LF, as well as CR, LF, and NL as hard line breaks. # CR × LF # CR ! # LF ! # NL ! for my $i (0 .. @lb_table - 1) { $lb_table[$lb_enums{'Carriage_Return'}][$i] = $lb_actions{'LB_BREAKABLE'}; $lb_table[$lb_enums{'Line_Feed'}][$i] = $lb_actions{'LB_BREAKABLE'}; $lb_table[$lb_enums{'Next_Line'}][$i] = $lb_actions{'LB_BREAKABLE'}; } $lb_table[$lb_enums{'Carriage_Return'}][$lb_enums{'Line_Feed'}] = $lb_actions{'LB_NOBREAK'}; # LB4 Always break after hard line breaks. # BK ! for my $i (0 .. @lb_table - 1) { $lb_table[$lb_enums{'Mandatory_Break'}][$i] = $lb_actions{'LB_BREAKABLE'}; } # LB3 Always break at the end of text. # ! eot # LB2 Never break at the start of text. # sot × for my $i (0 .. @lb_table - 1) { $lb_table[$i][$lb_enums{'EDGE'}] = $lb_actions{'LB_BREAKABLE'}; $lb_table[$lb_enums{'EDGE'}][$i] = $lb_actions{'LB_NOBREAK'}; } # LB1 Assign a line breaking class to each code point of the input. # Resolve AI, CB, CJ, SA, SG, and XX into other line breaking classes # depending on criteria outside the scope of this algorithm. # # In the absence of such criteria all characters with a specific # combination of original class and General_Category property value are # resolved as follows: # Original Resolved General_Category # AI, SG, XX AL Any # SA CM Only Mn or Mc # SA AL Any except Mn and Mc # CJ NS Any # # This is done in mktables, so we never see any of the remapped-from # classes. output_table_common('LB', \%lb_actions, \@lb_table, \@lb_short_enums, \%lb_abbreviations); } sub output_WB_table() { # Create and output the enums, #defines, and pair table for use in # determining Word Breaks, given in http://www.unicode.org/reports/tr29/. # This uses the same mechanism in the other bounds tables generated by # this file. The actions that could override a 0 or 1 are added to those # numbers; the actions that clearly don't depend on the underlying rule # simply overwrite my %wb_actions = ( WB_NOBREAK => 0, WB_BREAKABLE => 1, WB_hs_then_hs => 2, WB_Ex_or_FO_or_ZWJ_then_foo => 3, WB_DQ_then_HL => 4, WB_HL_then_DQ => 6, WB_LE_or_HL_then_MB_or_ML_or_SQ => 8, WB_MB_or_ML_or_SQ_then_LE_or_HL => 10, WB_MB_or_MN_or_SQ_then_NU => 12, WB_NU_then_MB_or_MN_or_SQ => 14, WB_RI_then_RI => 16, ); # Construct the WB pair table. # The table is constructed in reverse order of the rules, to make the # lower-numbered, higher priority ones override the later ones, as the # algorithm stops at the earliest matching rule my @wb_table; my $table_size = @wb_short_enums; # Otherwise, break everywhere (including around ideographs). # WB99 Any ÷ Any for my $i (0 .. $table_size - 1) { for my $j (0 .. $table_size - 1) { $wb_table[$i][$j] = $wb_actions{'WB_BREAKABLE'}; } } # Do not break within emoji flag sequences. That is, do not break between # regional indicator (RI) symbols if there is an odd number of RI # characters before the break point. # WB16 [^RI] (RI RI)* RI × RI # WB15 sot (RI RI)* RI × RI $wb_table[$wb_enums{'Regional_Indicator'}] [$wb_enums{'Regional_Indicator'}] = $wb_actions{'WB_RI_then_RI'}; # Do not break within emoji modifier sequences. # WB14 ( E_Base | EBG ) × E_Modifier $wb_table[$wb_enums{'E_Base'}][$wb_enums{'E_Modifier'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'E_Base_GAZ'}][$wb_enums{'E_Modifier'}] = $wb_actions{'WB_NOBREAK'}; # Do not break from extenders. # WB13b ExtendNumLet × (ALetter | Hebrew_Letter | Numeric | Katakana) $wb_table[$wb_enums{'ExtendNumLet'}][$wb_enums{'ALetter'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'ExtendNumLet'}][$wb_enums{'XPG_LE'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'ExtendNumLet'}][$wb_enums{'Hebrew_Letter'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'ExtendNumLet'}][$wb_enums{'Numeric'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'ExtendNumLet'}][$wb_enums{'Katakana'}] = $wb_actions{'WB_NOBREAK'}; # WB13a (ALetter | Hebrew_Letter | Numeric | Katakana | ExtendNumLet) # × ExtendNumLet $wb_table[$wb_enums{'ALetter'}][$wb_enums{'ExtendNumLet'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'XPG_LE'}][$wb_enums{'ExtendNumLet'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'Hebrew_Letter'}][$wb_enums{'ExtendNumLet'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'Numeric'}][$wb_enums{'ExtendNumLet'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'Katakana'}][$wb_enums{'ExtendNumLet'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'ExtendNumLet'}][$wb_enums{'ExtendNumLet'}] = $wb_actions{'WB_NOBREAK'}; # Do not break between Katakana. # WB13 Katakana × Katakana $wb_table[$wb_enums{'Katakana'}][$wb_enums{'Katakana'}] = $wb_actions{'WB_NOBREAK'}; # Do not break within sequences, such as “3.2” or “3,456.789”. # WB12 Numeric × (MidNum | MidNumLet | Single_Quote) Numeric $wb_table[$wb_enums{'Numeric'}][$wb_enums{'MidNumLet'}] += $wb_actions{'WB_NU_then_MB_or_MN_or_SQ'}; $wb_table[$wb_enums{'Numeric'}][$wb_enums{'MidNum'}] += $wb_actions{'WB_NU_then_MB_or_MN_or_SQ'}; $wb_table[$wb_enums{'Numeric'}][$wb_enums{'Single_Quote'}] += $wb_actions{'WB_NU_then_MB_or_MN_or_SQ'}; # WB11 Numeric (MidNum | (MidNumLet | Single_Quote)) × Numeric $wb_table[$wb_enums{'MidNumLet'}][$wb_enums{'Numeric'}] += $wb_actions{'WB_MB_or_MN_or_SQ_then_NU'}; $wb_table[$wb_enums{'MidNum'}][$wb_enums{'Numeric'}] += $wb_actions{'WB_MB_or_MN_or_SQ_then_NU'}; $wb_table[$wb_enums{'Single_Quote'}][$wb_enums{'Numeric'}] += $wb_actions{'WB_MB_or_MN_or_SQ_then_NU'}; # Do not break within sequences of digits, or digits adjacent to letters # (“3a”, or “A3”). # WB10 Numeric × (ALetter | Hebrew_Letter) $wb_table[$wb_enums{'Numeric'}][$wb_enums{'ALetter'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'Numeric'}][$wb_enums{'XPG_LE'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'Numeric'}][$wb_enums{'Hebrew_Letter'}] = $wb_actions{'WB_NOBREAK'}; # WB9 (ALetter | Hebrew_Letter) × Numeric $wb_table[$wb_enums{'ALetter'}][$wb_enums{'Numeric'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'XPG_LE'}][$wb_enums{'Numeric'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'Hebrew_Letter'}][$wb_enums{'Numeric'}] = $wb_actions{'WB_NOBREAK'}; # WB8 Numeric × Numeric $wb_table[$wb_enums{'Numeric'}][$wb_enums{'Numeric'}] = $wb_actions{'WB_NOBREAK'}; # Do not break letters across certain punctuation. # WB7c Hebrew_Letter Double_Quote × Hebrew_Letter $wb_table[$wb_enums{'Double_Quote'}][$wb_enums{'Hebrew_Letter'}] += $wb_actions{'WB_DQ_then_HL'}; # WB7b Hebrew_Letter × Double_Quote Hebrew_Letter $wb_table[$wb_enums{'Hebrew_Letter'}][$wb_enums{'Double_Quote'}] += $wb_actions{'WB_HL_then_DQ'}; # WB7a Hebrew_Letter × Single_Quote $wb_table[$wb_enums{'Hebrew_Letter'}][$wb_enums{'Single_Quote'}] = $wb_actions{'WB_NOBREAK'}; # WB7 (ALetter | Hebrew_Letter) (MidLetter | MidNumLet | Single_Quote) # × (ALetter | Hebrew_Letter) $wb_table[$wb_enums{'MidNumLet'}][$wb_enums{'ALetter'}] += $wb_actions{'WB_MB_or_ML_or_SQ_then_LE_or_HL'}; $wb_table[$wb_enums{'MidNumLet'}][$wb_enums{'XPG_LE'}] += $wb_actions{'WB_MB_or_ML_or_SQ_then_LE_or_HL'}; $wb_table[$wb_enums{'MidNumLet'}][$wb_enums{'Hebrew_Letter'}] += $wb_actions{'WB_MB_or_ML_or_SQ_then_LE_or_HL'}; $wb_table[$wb_enums{'MidLetter'}][$wb_enums{'ALetter'}] += $wb_actions{'WB_MB_or_ML_or_SQ_then_LE_or_HL'}; $wb_table[$wb_enums{'MidLetter'}][$wb_enums{'XPG_LE'}] += $wb_actions{'WB_MB_or_ML_or_SQ_then_LE_or_HL'}; $wb_table[$wb_enums{'MidLetter'}][$wb_enums{'Hebrew_Letter'}] += $wb_actions{'WB_MB_or_ML_or_SQ_then_LE_or_HL'}; $wb_table[$wb_enums{'Single_Quote'}][$wb_enums{'ALetter'}] += $wb_actions{'WB_MB_or_ML_or_SQ_then_LE_or_HL'}; $wb_table[$wb_enums{'Single_Quote'}][$wb_enums{'XPG_LE'}] += $wb_actions{'WB_MB_or_ML_or_SQ_then_LE_or_HL'}; $wb_table[$wb_enums{'Single_Quote'}][$wb_enums{'Hebrew_Letter'}] += $wb_actions{'WB_MB_or_ML_or_SQ_then_LE_or_HL'}; # WB6 (ALetter | Hebrew_Letter) × (MidLetter | MidNumLet # | Single_Quote) (ALetter | Hebrew_Letter) $wb_table[$wb_enums{'ALetter'}][$wb_enums{'MidNumLet'}] += $wb_actions{'WB_LE_or_HL_then_MB_or_ML_or_SQ'}; $wb_table[$wb_enums{'XPG_LE'}][$wb_enums{'MidNumLet'}] += $wb_actions{'WB_LE_or_HL_then_MB_or_ML_or_SQ'}; $wb_table[$wb_enums{'Hebrew_Letter'}][$wb_enums{'MidNumLet'}] += $wb_actions{'WB_LE_or_HL_then_MB_or_ML_or_SQ'}; $wb_table[$wb_enums{'ALetter'}][$wb_enums{'MidLetter'}] += $wb_actions{'WB_LE_or_HL_then_MB_or_ML_or_SQ'}; $wb_table[$wb_enums{'XPG_LE'}][$wb_enums{'MidLetter'}] += $wb_actions{'WB_LE_or_HL_then_MB_or_ML_or_SQ'}; $wb_table[$wb_enums{'Hebrew_Letter'}][$wb_enums{'MidLetter'}] += $wb_actions{'WB_LE_or_HL_then_MB_or_ML_or_SQ'}; $wb_table[$wb_enums{'ALetter'}][$wb_enums{'Single_Quote'}] += $wb_actions{'WB_LE_or_HL_then_MB_or_ML_or_SQ'}; $wb_table[$wb_enums{'XPG_LE'}][$wb_enums{'Single_Quote'}] += $wb_actions{'WB_LE_or_HL_then_MB_or_ML_or_SQ'}; $wb_table[$wb_enums{'Hebrew_Letter'}][$wb_enums{'Single_Quote'}] += $wb_actions{'WB_LE_or_HL_then_MB_or_ML_or_SQ'}; # Do not break between most letters. # WB5 (ALetter | Hebrew_Letter) × (ALetter | Hebrew_Letter) $wb_table[$wb_enums{'ALetter'}][$wb_enums{'ALetter'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'XPG_LE'}][$wb_enums{'ALetter'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'ALetter'}][$wb_enums{'Hebrew_Letter'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'XPG_LE'}][$wb_enums{'Hebrew_Letter'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'Hebrew_Letter'}][$wb_enums{'ALetter'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'Hebrew_Letter'}][$wb_enums{'XPG_LE'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'Hebrew_Letter'}][$wb_enums{'Hebrew_Letter'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'XPG_LE'}][$wb_enums{'XPG_LE'}] = $wb_actions{'WB_NOBREAK'}; # Ignore Format and Extend characters, except after sot, CR, LF, and # Newline. This also has the effect of: Any × (Format | Extend | ZWJ) # WB4 X (Extend | Format | ZWJ)* → X for my $i (0 .. @wb_table - 1) { $wb_table[$wb_enums{'Extend'}][$i] = $wb_actions{'WB_Ex_or_FO_or_ZWJ_then_foo'}; $wb_table[$wb_enums{'Format'}][$i] = $wb_actions{'WB_Ex_or_FO_or_ZWJ_then_foo'}; $wb_table[$wb_enums{'ZWJ'}][$i] = $wb_actions{'WB_Ex_or_FO_or_ZWJ_then_foo'}; } for my $i (0 .. @wb_table - 1) { $wb_table[$i][$wb_enums{'Extend'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$i][$wb_enums{'Format'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$i][$wb_enums{'ZWJ'}] = $wb_actions{'WB_NOBREAK'}; } # Implied is that these attach to the character before them, except for # the characters that mark the end of a region of text. The rules below # override the ones set up here, for all the characters that need # overriding. for my $i (0 .. @wb_table - 1) { $wb_table[$i][$wb_enums{'Extend'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$i][$wb_enums{'Format'}] = $wb_actions{'WB_NOBREAK'}; } # Keep horizontal whitespace together # Use perl's tailoring instead # WB3d WSegSpace × WSegSpace #$wb_table[$wb_enums{'WSegSpace'}][$wb_enums{'WSegSpace'}] # = $wb_actions{'WB_NOBREAK'}; # Do not break within emoji zwj sequences. # WB3c ZWJ × ( Glue_After_Zwj | EBG ) $wb_table[$wb_enums{'ZWJ'}][$wb_enums{'Glue_After_Zwj'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'ZWJ'}][$wb_enums{'E_Base_GAZ'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'ZWJ'}][$wb_enums{'XPG_XX'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'ZWJ'}][$wb_enums{'XPG_LE'}] = $wb_actions{'WB_NOBREAK'}; # Break before and after newlines # WB3b ÷ (Newline | CR | LF) # WB3a (Newline | CR | LF) ÷ # et. al. for my $i ('CR', 'LF', 'Newline', 'Perl_Tailored_HSpace') { for my $j (0 .. @wb_table - 1) { $wb_table[$j][$wb_enums{$i}] = $wb_actions{'WB_BREAKABLE'}; $wb_table[$wb_enums{$i}][$j] = $wb_actions{'WB_BREAKABLE'}; } } # But do not break within white space. # WB3 CR × LF # et.al. for my $i ('CR', 'LF', 'Newline', 'Perl_Tailored_HSpace') { for my $j ('CR', 'LF', 'Newline', 'Perl_Tailored_HSpace') { $wb_table[$wb_enums{$i}][$wb_enums{$j}] = $wb_actions{'WB_NOBREAK'}; } } # And do not break horizontal space followed by Extend or Format or ZWJ $wb_table[$wb_enums{'Perl_Tailored_HSpace'}][$wb_enums{'Extend'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'Perl_Tailored_HSpace'}][$wb_enums{'Format'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'Perl_Tailored_HSpace'}][$wb_enums{'ZWJ'}] = $wb_actions{'WB_NOBREAK'}; $wb_table[$wb_enums{'Perl_Tailored_HSpace'}] [$wb_enums{'Perl_Tailored_HSpace'}] = $wb_actions{'WB_hs_then_hs'}; # Break at the start and end of text, unless the text is empty # WB2 Any ÷ eot # WB1 sot ÷ Any for my $i (0 .. @wb_table - 1) { $wb_table[$i][$wb_enums{'EDGE'}] = $wb_actions{'WB_BREAKABLE'}; $wb_table[$wb_enums{'EDGE'}][$i] = $wb_actions{'WB_BREAKABLE'}; } $wb_table[$wb_enums{'EDGE'}][$wb_enums{'EDGE'}] = 0; output_table_common('WB', \%wb_actions, \@wb_table, \@wb_short_enums, \%wb_abbreviations); } sub sanitize_name ($) { # Change the non-word characters in the input string to standardized word # equivalents # my $sanitized = shift; $sanitized =~ s/=/__/; $sanitized =~ s/&/_AMP_/; $sanitized =~ s/\./_DOT_/; $sanitized =~ s/-/_MINUS_/; $sanitized =~ s!/!_SLASH_!; return $sanitized; } switch_pound_if ('ALL', 'PERL_IN_REGCOMP_C'); output_invlist("Latin1", [ 0, 256 ]); output_invlist("AboveLatin1", [ 256 ]); end_file_pound_if; # We construct lists for all the POSIX and backslash sequence character # classes in two forms: # 1) ones which match only in the ASCII range # 2) ones which match either in the Latin1 range, or the entire Unicode range # # These get compiled in, and hence affect the memory footprint of every Perl # program, even those not using Unicode. To minimize the size, currently # the Latin1 version is generated for the beyond ASCII range except for those # lists that are quite small for the entire range, such as for \s, which is 22 # UVs long plus 4 UVs (currently) for the header. # # To save even more memory, the ASCII versions could be derived from the # larger ones at runtime, saving some memory (minus the expense of the machine # instructions to do so), but these are all small anyway, so their total is # about 100 UVs. # # In the list of properties below that get generated, the L1 prefix is a fake # property that means just the Latin1 range of the full property (whose name # has an X prefix instead of L1). # # An initial & means to use the subroutine from this file instead of an # official inversion list. # Below is the list of property names to generate. '&' means to use the # subroutine to generate the inversion list instead of the generic code # below. Some properties have a comma-separated list after the name, # These are extra enums to add to those found in the Unicode tables. no warnings 'qw'; # Ignore non-alpha in sort my @props; push @props, sort { prop_name_for_cmp($a) cmp prop_name_for_cmp($b) } qw( &UpperLatin1 _Perl_GCB,EDGE,E_Base,E_Base_GAZ,E_Modifier,Glue_After_Zwj,LV,Prepend,Regional_Indicator,SpacingMark,ZWJ,XPG_XX _Perl_LB,EDGE,Close_Parenthesis,Hebrew_Letter,Next_Line,Regional_Indicator,ZWJ,Contingent_Break,E_Base,E_Modifier,H2,H3,JL,JT,JV,Word_Joiner _Perl_SB,EDGE,SContinue,CR,Extend,LF _Perl_WB,Perl_Tailored_HSpace,EDGE,UNKNOWN,CR,Double_Quote,E_Base,E_Base_GAZ,E_Modifier,Extend,Glue_After_Zwj,Hebrew_Letter,LF,MidNumLet,Newline,Regional_Indicator,Single_Quote,ZWJ,XPG_XX,XPG_LE _Perl_SCX,Latin,Inherited,Unknown,Kore,Jpan,Hanb,INVALID Lowercase_Mapping Titlecase_Mapping Uppercase_Mapping Simple_Case_Folding Case_Folding &_Perl_IVCF &_Perl_CCC_non0_non230 ); # NOTE that the convention is that extra enum values come # after the property name, separated by commas, with the enums # that aren't ever defined by Unicode coming last, at least 4 # all-uppercase characters. The others are enum names that # are needed by perl, but aren't in all Unicode releases. my @bin_props; my @perl_prop_synonyms; my %enums; my @deprecated_messages = ""; # Element [0] is a placeholder my %deprecated_tags; my $float_e_format = qr/ ^ -? \d \. \d+ e [-+] \d+ $ /x; # Create another hash that maps floating point x.yyEzz representation to what # %stricter_to_file_of does for the equivalent rational. A typical entry in # the latter hash is # # 'nv=1/2' => 'Nv/1_2', # # From that, this loop creates an entry # # 'nv=5.00e-01' => 'Nv/1_2', # # %stricter_to_file_of contains far more than just the rationals. Instead we # use %utf8::nv_floating_to_rational which should have an entry for each # nv in the former hash. my %floating_to_file_of; foreach my $key (keys %utf8::nv_floating_to_rational) { my $value = $utf8::nv_floating_to_rational{$key}; $floating_to_file_of{$key} = $utf8::stricter_to_file_of{"nv=$value"}; } # Properties that are specified with a prop=value syntax my @equals_properties; # Collect all the binary properties from data in lib/unicore # Sort so that complements come after the main table, and the shortest # names first, finally alphabetically. Also, sort together the tables we want # to be kept together, and prefer those with 'posix' in their names, which is # what the C code is expecting their names to be. foreach my $property (sort { exists $keep_together{lc $b} <=> exists $keep_together{lc $a} or $b =~ /posix/i <=> $a =~ /posix/i or $b =~ /perl/i <=> $a =~ /perl/i or $a =~ $float_e_format <=> $b =~ $float_e_format or $a =~ /!/ <=> $b =~ /!/ or length $a <=> length $b or $a cmp $b } keys %utf8::loose_to_file_of, keys %utf8::stricter_to_file_of, keys %floating_to_file_of ) { # These two hashes map properties to values that can be considered to # be checksums. If two properties have the same checksum, they have # identical entries. Otherwise they differ in some way. my $tag = $utf8::loose_to_file_of{$property}; $tag = $utf8::stricter_to_file_of{$property} unless defined $tag; $tag = $floating_to_file_of{$property} unless defined $tag; # The tag may contain an '!' meaning it is identical to the one formed # by removing the !, except that it is inverted. my $inverted = $tag =~ s/!//; # This hash is lacking the property name $property = "nv=$property" if $property =~ $float_e_format; # The list of 'prop=value' entries that this single entry expands to my @this_entries; # Split 'property=value' on the equals sign, with $lhs being the whole # thing if there is no '=' my ($lhs, $rhs) = $property =~ / ( [^=]* ) ( =? .*) /x; # $lhs then becomes the property name. my $prop_value = $rhs =~ s/ ^ = //rx; push @equals_properties, $lhs if $prop_value ne ""; # See if there are any synonyms for this property. if (exists $prop_name_aliases{$lhs}) { # If so, do the combinatorics so that a new entry is added for # each legal property combined with the property value (which is # $rhs) foreach my $alias (@{$prop_name_aliases{$lhs}}) { # But, there are some ambiguities, like 'script' is a synonym # for 'sc', and 'sc' can stand alone, meaning something # entirely different than 'script'. 'script' cannot stand # alone. Don't add if the potential new lhs is in the hash of # stand-alone properties. no warnings 'once'; next if $rhs eq "" && grep { $alias eq $_ } keys %utf8::loose_property_to_file_of; my $new_entry = $alias . $rhs; push @this_entries, $new_entry; } } # Above, we added the synonyms for the base entry we're now # processing. But we haven't dealt with it yet. If we already have a # property with the identical characteristics, this becomes just a # synonym for it. if (exists $enums{$tag}) { push @this_entries, $property; } else { # Otherwise, create a new entry. # Add to the list of properties to generate inversion lists for. push @bin_props, uc $property; # Create a rule for the parser if (! exists $keywords{$property}) { $keywords{$property} = token_name($property); } # And create an enum for it. $enums{$tag} = $table_name_prefix . uc sanitize_name($property); $perl_tags{$tag} = 1 if exists $keep_together{lc $property}; # Some properties are deprecated. This hash tells us so, and the # warning message to raise if they are used. if (exists $utf8::why_deprecated{$tag}) { $deprecated_tags{$enums{$tag}} = scalar @deprecated_messages; push @deprecated_messages, $utf8::why_deprecated{$tag}; } # Our sort above should have made sure that we see the # non-inverted version first, but this makes sure. warn "$property is inverted!!!" if $inverted; } # Everything else is #defined to be the base enum, inversion is # indicated by negating the value. my $defined_to = ""; $defined_to .= "-" if $inverted; $defined_to .= $enums{$tag}; # Go through the entries that evaluate to this. @this_entries = uniques @this_entries; foreach my $define (@this_entries) { # There is a rule for the parser for each. $keywords{$define} = $defined_to; # And a #define for all simple names equivalent to a perl property, # except those that begin with 'is' or 'in'; if (exists $perl_tags{$tag} && $property !~ / ^ i[ns] | = /x) { push @perl_prop_synonyms, "#define " . $table_name_prefix . uc(sanitize_name($define)) . " $defined_to"; } } } @bin_props = sort { exists $keep_together{lc $b} <=> exists $keep_together{lc $a} or $a cmp $b } @bin_props; @perl_prop_synonyms = sort(uniques(@perl_prop_synonyms)); push @props, @bin_props; foreach my $prop (@props) { # For the Latin1 properties, we change to use the eXtended version of the # base property, then go through the result and get rid of everything not # in Latin1 (above 255). Actually, we retain the element for the range # that crosses the 255/256 boundary if it is one that matches the # property. For example, in the Word property, there is a range of code # points that start at U+00F8 and goes through U+02C1. Instead of # artificially cutting that off at 256 because 256 is the first code point # above Latin1, we let the range go to its natural ending. That gives us # extra information with no added space taken. But if the range that # crosses the boundary is one that doesn't match the property, we don't # start a new range above 255, as that could be construed as going to # infinity. For example, the Upper property doesn't include the character # at 255, but does include the one at 256. We don't include the 256 one. my $prop_name = $prop; my $is_local_sub = $prop_name =~ s/^&//; my $extra_enums = ""; $extra_enums = $1 if $prop_name =~ s/, ( .* ) //x; my $lookup_prop = $prop_name; $prop_name = sanitize_name($prop_name); $prop_name = $table_name_prefix . $prop_name if grep { lc $lookup_prop eq lc $_ } @bin_props; my $l1_only = ($lookup_prop =~ s/^L1Posix/XPosix/ or $lookup_prop =~ s/^L1//); my $nonl1_only = 0; $nonl1_only = $lookup_prop =~ s/^NonL1// unless $l1_only; ($lookup_prop, my $has_suffixes) = $lookup_prop =~ / (.*) ( , .* )? /x; for my $charset (get_supported_code_pages()) { @a2n = @{get_a2n($charset)}; my @invlist; my @invmap; my $map_format; my $map_default; my $maps_to_code_point; my $to_adjust; my $same_in_all_code_pages; if ($is_local_sub) { my @return = eval $lookup_prop; die $@ if $@; my $invlist_ref = shift @return; @invlist = @$invlist_ref; if (@return) { # If has other values returned , must be an # inversion map my $invmap_ref = shift @return; @invmap = @$invmap_ref; $map_format = shift @return; $map_default = shift @return; } } else { @invlist = prop_invlist($lookup_prop, '_perl_core_internal_ok'); if (! @invlist) { # If couldn't find a non-empty inversion list, see if it is # instead an inversion map my ($list_ref, $map_ref, $format, $default) = prop_invmap($lookup_prop, '_perl_core_internal_ok'); if (! $list_ref) { # An empty return here could mean an unknown property, or # merely that the original inversion list is empty. Call # in scalar context to differentiate my $count = prop_invlist($lookup_prop, '_perl_core_internal_ok'); if (defined $count) { # Short-circuit an empty inversion list. output_invlist($prop_name, \@invlist, $charset); last; } die "Could not find inversion list for '$lookup_prop'" } else { @invlist = @$list_ref; @invmap = @$map_ref; $map_format = $format; $map_default = $default; $maps_to_code_point = $map_format =~ / a ($ | [^r] ) /x; $to_adjust = $map_format =~ /a/; } } } # Re-order the Unicode code points to native ones for this platform. # This is only needed for code points below 256, because native code # points are only in that range. For inversion maps of properties # where the mappings are adjusted (format =~ /a/), this reordering # could mess up the adjustment pattern that was in the input, so that # has to be dealt with. # # And inversion maps that map to code points need to eventually have # all those code points remapped to native, and it's better to do that # here, going through the whole list not just those below 256. This # is because some inversion maps have adjustments (format =~ /a/) # which may be affected by the reordering. This code needs to be done # both for when we are translating the inversion lists for < 256, and # for the inversion maps for everything. By doing both in this loop, # we can share that code. # # So, we go through everything for an inversion map to code points; # otherwise, we can skip any remapping at all if we are going to # output only the above-Latin1 values, or if the range spans the whole # of 0..256, as the remap will also include all of 0..256 (256 not # 255 because a re-ordering could cause 256 to need to be in the same # range as 255.) if ( (@invmap && $maps_to_code_point) || ( @invlist && $invlist[0] < 256 && ( $invlist[0] != 0 || (scalar @invlist != 1 && $invlist[1] < 256)))) { $same_in_all_code_pages = 0; if (! @invmap) { # Straight inversion list # Look at all the ranges that start before 257. my @latin1_list; while (@invlist) { last if $invlist[0] > 256; my $upper = @invlist > 1 ? $invlist[1] - 1 # In range # To infinity. You may want to stop much much # earlier; going this high may expose perl # deficiencies with very large numbers. : 256; for my $j ($invlist[0] .. $upper) { push @latin1_list, a2n($j); } shift @invlist; # Shift off the range that's in the list shift @invlist; # Shift off the range not in the list } # Here @invlist contains all the ranges in the original that # start at code points above 256, and @latin1_list contains # all the native code points for ranges that start with a # Unicode code point below 257. We sort the latter and # convert it to inversion list format. Then simply prepend it # to the list of the higher code points. @latin1_list = sort { $a <=> $b } @latin1_list; @latin1_list = mk_invlist_from_sorted_cp_list(\@latin1_list); unshift @invlist, @latin1_list; } else { # Is an inversion map # This is a similar procedure as plain inversion list, but has # multiple buckets. A plain inversion list just has two # buckets, 1) 'in' the list; and 2) 'not' in the list, and we # pretty much can ignore the 2nd bucket, as it is completely # defined by the 1st. But here, what we do is create buckets # which contain the code points that map to each, translated # to native and turned into an inversion list. Thus each # bucket is an inversion list of native code points that map # to it or don't map to it. We use these to create an # inversion map for the whole property. # As mentioned earlier, we use this procedure to not just # remap the inversion list to native values, but also the maps # of code points to native ones. In the latter case we have # to look at the whole of the inversion map (or at least to # above Unicode; as the maps of code points above that should # all be to the default). my $upper_limit = (! $maps_to_code_point) ? 256 : (Unicode::UCD::UnicodeVersion() eq '1.1.5') ? 0xFFFF : 0x10FFFF; my %mapped_lists; # A hash whose keys are the buckets. while (@invlist) { last if $invlist[0] > $upper_limit; # This shouldn't actually happen, as prop_invmap() returns # an extra element at the end that is beyond $upper_limit die "inversion map (for $prop_name) that extends to infinity is unimplemented" unless @invlist > 1; my $bucket; # A hash key can't be a ref (we are only expecting arrays # of scalars here), so convert any such to a string that # will be converted back later (using a vertical tab as # the separator). if (ref $invmap[0]) { $bucket = join "\cK", map { a2n($_) } @{$invmap[0]}; } elsif ( $maps_to_code_point && $invmap[0] =~ $integer_or_float_re) { # Do convert to native for maps to single code points. # There are some properties that have a few outlier # maps that aren't code points, so the above test # skips those. $bucket = a2n($invmap[0]); } else { $bucket = $invmap[0]; } # We now have the bucket that all code points in the range # map to, though possibly they need to be adjusted. Go # through the range and put each translated code point in # it into its bucket. my $base_map = $invmap[0]; for my $j ($invlist[0] .. $invlist[1] - 1) { if ($to_adjust # The 1st code point doesn't need adjusting && $j > $invlist[0] # Skip any non-numeric maps: these are outliers # that aren't code points. && $base_map =~ $integer_or_float_re # 'ne' because the default can be a string && $base_map ne $map_default) { # We adjust, by incrementing each the bucket and # the map. For code point maps, translate to # native $base_map++; $bucket = ($maps_to_code_point) ? a2n($base_map) : $base_map; } # Add the native code point to the bucket for the # current map push @{$mapped_lists{$bucket}}, a2n($j); } # End of loop through all code points in the range # Get ready for the next range shift @invlist; shift @invmap; } # End of loop through all ranges in the map. # Here, @invlist and @invmap retain all the ranges from the # originals that start with code points above $upper_limit. # Each bucket in %mapped_lists contains all the code points # that map to that bucket. If the bucket is for a map to a # single code point, the bucket has been converted to native. # If something else (including multiple code points), no # conversion is done. # # Now we recreate the inversion map into %xlated, but this # time for the native character set. my %xlated; foreach my $bucket (keys %mapped_lists) { # Sort and convert this bucket to an inversion list. The # result will be that ranges that start with even-numbered # indexes will be for code points that map to this bucket; # odd ones map to some other bucket, and are discarded # below. @{$mapped_lists{$bucket}} = sort{ $a <=> $b} @{$mapped_lists{$bucket}}; @{$mapped_lists{$bucket}} = mk_invlist_from_sorted_cp_list(\@{$mapped_lists{$bucket}}); # Add each even-numbered range in the bucket to %xlated; # so that the keys of %xlated become the range start code # points, and the values are their corresponding maps. while (@{$mapped_lists{$bucket}}) { my $range_start = $mapped_lists{$bucket}->[0]; if ($bucket =~ /\cK/) { @{$xlated{$range_start}} = split /\cK/, $bucket; } else { # If adjusting, and there is more than one thing # that maps to the same thing, they must be split # so that later the adjusting doesn't think the # subsequent items can go away because of the # adjusting. my $range_end = ($to_adjust && $bucket != $map_default) ? $mapped_lists{$bucket}->[1] - 1 : $range_start; for my $i ($range_start .. $range_end) { $xlated{$i} = $bucket; } } shift @{$mapped_lists{$bucket}}; # Discard odd ranges shift @{$mapped_lists{$bucket}}; # Get ready for next # iteration } } # End of loop through all the buckets. # Here %xlated's keys are the range starts of all the code # points in the inversion map. Construct an inversion list # from them. my @new_invlist = sort { $a <=> $b } keys %xlated; # If the list is adjusted, we want to munge this list so that # we only have one entry for where consecutive code points map # to consecutive values. We just skip the subsequent entries # where this is the case. if ($to_adjust) { my @temp; for my $i (0 .. @new_invlist - 1) { next if $i > 0 && $new_invlist[$i-1] + 1 == $new_invlist[$i] && $xlated{$new_invlist[$i-1]} =~ $integer_or_float_re && $xlated{$new_invlist[$i]} =~ $integer_or_float_re && $xlated{$new_invlist[$i-1]} + 1 == $xlated{$new_invlist[$i]}; push @temp, $new_invlist[$i]; } @new_invlist = @temp; } # The inversion map comes from %xlated's values. We can # unshift each onto the front of the untouched portion, in # reverse order of the portion we did process. foreach my $start (reverse @new_invlist) { unshift @invmap, $xlated{$start}; } # Finally prepend the inversion list we have just constructed to the # one that contains anything we didn't process. unshift @invlist, @new_invlist; } } elsif (@invmap) { # inversion maps can't cope with this variable # being true, even if it could be true $same_in_all_code_pages = 0; } else { $same_in_all_code_pages = 1; } # prop_invmap() returns an extra final entry, which we can now # discard. if (@invmap) { pop @invlist; pop @invmap; } if ($l1_only) { die "Unimplemented to do a Latin-1 only inversion map" if @invmap; for my $i (0 .. @invlist - 1 - 1) { if ($invlist[$i] > 255) { # In an inversion list, even-numbered elements give the code # points that begin ranges that match the property; # odd-numbered give ones that begin ranges that don't match. # If $i is odd, we are at the first code point above 255 that # doesn't match, which means the range it is ending does # match, and crosses the 255/256 boundary. We want to include # this ending point, so increment $i, so the splice below # includes it. Conversely, if $i is even, it is the first # code point above 255 that matches, which means there was no # matching range that crossed the boundary, and we don't want # to include this code point, so splice before it. $i++ if $i % 2 != 0; # Remove everything past this. splice @invlist, $i; splice @invmap, $i if @invmap; last; } } } elsif ($nonl1_only) { my $found_nonl1 = 0; for my $i (0 .. @invlist - 1 - 1) { next if $invlist[$i] < 256; # Here, we have the first element in the array that indicates an # element above Latin1. Get rid of all previous ones. splice @invlist, 0, $i; splice @invmap, 0, $i if @invmap; # If this one's index is not divisible by 2, it means that this # element is inverting away from being in the list, which means # all code points from 256 to this one are in this list (or # map to the default for inversion maps) if ($i % 2 != 0) { unshift @invlist, 256; unshift @invmap, $map_default if @invmap; } $found_nonl1 = 1; last; } if (! $found_nonl1) { warn "No non-Latin1 code points in $prop_name"; output_invlist($prop_name, []); last; } } switch_pound_if ($prop_name, 'PERL_IN_REGCOMP_C'); start_charset_pound_if($charset, 1) unless $same_in_all_code_pages; output_invlist($prop_name, \@invlist, ($same_in_all_code_pages) ? $applies_to_all_charsets_text : $charset); if (@invmap) { output_invmap($prop_name, \@invmap, $lookup_prop, $map_format, $map_default, $extra_enums, $charset); } last if $same_in_all_code_pages; end_charset_pound_if; } } switch_pound_if ('binary_property_tables', 'PERL_IN_REGCOMP_C'); print $out_fh "\nconst char * const deprecated_property_msgs[] = {\n\t"; print $out_fh join ",\n\t", map { "\"$_\"" } @deprecated_messages; print $out_fh "\n};\n"; my @enums = sort values %enums; # Save a copy of these before modification my @invlist_names = map { "${_}_invlist" } @enums; # Post-process the enums for deprecated properties. if (scalar keys %deprecated_tags) { my $seen_deprecated = 0; foreach my $enum (@enums) { if (grep { $_ eq $enum } keys %deprecated_tags) { # Change the enum name for this deprecated property to a # munged one to act as a placeholder in the typedef. Then # make the real name be a #define whose value is such that # its modulus with the number of enums yields the index into # the table occupied by the placeholder. And so that dividing # the #define value by the table length gives an index into # the table of deprecation messages for the corresponding # warning. my $revised_enum = "${enum}_perl_aux"; if (! $seen_deprecated) { $seen_deprecated = 1; print $out_fh "\n"; } print $out_fh "#define $enum ($revised_enum + (MAX_UNI_KEYWORD_INDEX * $deprecated_tags{$enum}))\n"; $enum = $revised_enum; } } } print $out_fh "\ntypedef enum {\n\tPERL_BIN_PLACEHOLDER = 0, /* So no real value is zero */\n\t"; print $out_fh join ",\n\t", @enums; print $out_fh "\n"; print $out_fh "} binary_invlist_enum;\n"; print $out_fh "\n#define MAX_UNI_KEYWORD_INDEX $enums[-1]\n"; output_table_header($out_fh, "UV *", "uni_prop_ptrs"); print $out_fh "\tNULL,\t/* Placeholder */\n"; print $out_fh "\t"; print $out_fh join ",\n\t", @invlist_names; print $out_fh "\n"; output_table_trailer(); print $out_fh join "\n", "\n", #'# ifdef DOINIT', #"\n", "/* Synonyms for perl properties */", @perl_prop_synonyms, #"\n", #"# endif /* DOINIT */", "\n"; switch_pound_if ('Valid property_values', 'PERL_IN_REGCOMP_C'); # Each entry is a pointer to a table of property values for some property. # (Other properties may share this table. The next two data structures allow # this sharing to be implemented.) my @values_tables = "NULL /* Placeholder so zero index is an error */"; # Keys are all the values of a property, strung together. The value of each # key is its index in @values_tables. This is because many properties have # the same values, and this allows the data to appear just once. my %joined_values; # #defines for indices into @values_tables, so can have synonyms resolved by # the C compiler. my @values_indices; # Go through each property which is specifiable by \p{prop=value}, and create # a hash with the keys being the canonicalized short property names, and the # values for each property being all possible values that it can take on. # Both the full value and its short, canonicalized into lc, sans punctuation # version are included. my %all_values; for my $property (sort { prop_name_for_cmp($a) cmp prop_name_for_cmp($b) } uniques @equals_properties) { # Get and canonicalize the short name for this property. my ($short_name) = prop_aliases($property); $short_name = lc $short_name; $short_name =~ s/[ _-]//g; # Now look at each value this property can take on foreach my $value (prop_values($short_name)) { # And for each value, look at each synonym for it foreach my $alias (prop_value_aliases($short_name, $value)) { # Add each synonym push @{$all_values{$short_name}}, $alias; # As well as its canonicalized name. khw made the decision to not # support the grandfathered L_ Gc property value $alias = lc $alias; $alias =~ s/[ _-]//g unless $alias =~ $numeric_re; push @{$all_values{$short_name}}, $alias; } } } # Also include the old style block names, using the recipe given in # Unicode::UCD foreach my $block (prop_values('block')) { push @{$all_values{'blk'}}, charblock((prop_invlist("block=$block"))[0]); } # Now create output tables for each property in @equals_properties (the keys # in %all_values) each containing that property's possible values as computed # just above. PROPERTY: for my $property (sort { prop_name_for_cmp($a) cmp prop_name_for_cmp($b) or $a cmp $b } keys %all_values) { @{$all_values{$property}} = uniques(@{$all_values{$property}}); # String together the values for this property, sorted. This string forms # a list definition, with each value as an entry in it, indented on a new # line. The sorting is used to find properties that take on the exact # same values to share this string. my $joined = "\t\""; $joined .= join "\",\n\t\"", sort { ($a =~ $numeric_re && $b =~ $numeric_re) ? eval $a <=> eval $b : prop_name_for_cmp($a) cmp prop_name_for_cmp($b) or $a cmp $b } @{$all_values{$property}}; # And add a trailing marker $joined .= "\",\n\tNULL\n"; my $table_name = $table_name_prefix . $property . "_values"; my $index_name = "${table_name}_index"; # Add a rule for the parser that is just an empty value. It will need to # know to look up empty things in the prop_value_ptrs[] table. $keywords{"$property="} = $index_name; if (exists $prop_name_aliases{$property}) { foreach my $alias (@{$prop_name_aliases{$property}}) { $keywords{"$alias="} = $index_name; } } # Also create rules for the synonyms of this property to point to the same # thing # If this property's values are the same as one we've already computed, # use that instead of creating a duplicate. But we add a #define to point # to the proper one. if (exists $joined_values{$joined}) { push @values_indices, "#define $index_name $joined_values{$joined}\n"; next PROPERTY; } # And this property, now known to have unique values from any other seen # so far is about to be pushed onto @values_tables. Its index is the # current count. push @values_indices, "#define $index_name " . scalar @values_tables . "\n"; $joined_values{$joined} = $index_name; push @values_tables, $table_name; # Create the table for this set of values. output_table_header($out_fh, "char *", $table_name); print $out_fh $joined; output_table_trailer(); } # End of loop through the properties, and their values # We have completely determined the table of the unique property values output_table_header($out_fh, "char * const *", "${table_name_prefix}prop_value_ptrs"); print $out_fh join ",\n", @values_tables; print $out_fh "\n"; output_table_trailer(); # And the #defines for the indices in it print $out_fh "\n\n", join "", @values_indices; switch_pound_if('Boundary_pair_tables', 'PERL_IN_REGEXEC_C'); output_GCB_table(); output_LB_table(); output_WB_table(); end_file_pound_if; print $out_fh <<"EOF"; /* More than one code point may have the same code point as their fold. This * gives the maximum number in the current Unicode release. (The folded-to * code point is not included in this count.) For example, both 'S' and * \\x{17F} fold to 's', so the number for that fold is 2. Another way to * look at it is the maximum length of all the IVCF_AUX_TABLE's */ #define MAX_FOLD_FROMS $max_fold_froms EOF my $sources_list = "lib/unicore/mktables.lst"; my @sources = qw(regen/mk_invlists.pl lib/unicore/mktables lib/Unicode/UCD.pm regen/charset_translations.pl regen/mk_PL_charclass.pl ); { # Depend on mktables’ own sources. It’s a shorter list of files than # those that Unicode::UCD uses. if (! open my $mktables_list, '<', $sources_list) { # This should force a rebuild once $sources_list exists push @sources, $sources_list; } else { while(<$mktables_list>) { last if /===/; chomp; push @sources, "lib/unicore/$_" if /^[^#]/; } } } read_only_bottom_close_and_rename($out_fh, \@sources); my %name_to_index; for my $i (0 .. @enums - 1) { my $loose_name = $enums[$i] =~ s/^$table_name_prefix//r; $loose_name = lc $loose_name; $loose_name =~ s/__/=/; $loose_name =~ s/_dot_/./; $loose_name =~ s/_slash_/\//g; $name_to_index{$loose_name} = $i + 1; } # unsanitize, exclude &, maybe add these before sanitize for my $i (0 .. @perl_prop_synonyms - 1) { my $loose_name_pair = $perl_prop_synonyms[$i] =~ s/#\s*define\s*//r; $loose_name_pair =~ s/\b$table_name_prefix//g; $loose_name_pair = lc $loose_name_pair; $loose_name_pair =~ s/__/=/g; $loose_name_pair =~ s/_dot_/./g; $loose_name_pair =~ s/_slash_/\//g; my ($synonym, $primary) = split / +/, $loose_name_pair; $name_to_index{$synonym} = $name_to_index{$primary}; } my $uni_pl = open_new('lib/unicore/uni_keywords.pl', '>', {style => '*', by => 'regen/mk_invlists.pl', from => "Unicode::UCD"}); { print $uni_pl "\%utf8::uni_prop_ptrs_indices = (\n"; for my $name (sort keys %name_to_index) { print $uni_pl " '$name' => $name_to_index{$name},\n"; } print $uni_pl ");\n\n1;\n"; } read_only_bottom_close_and_rename($uni_pl, \@sources); require './regen/mph.pl'; sub token_name { my $name = sanitize_name(shift); warn "$name contains non-word" if $name =~ /\W/; return "$table_name_prefix\U$name" } my $keywords_fh = open_new('uni_keywords.h', '>', {style => '*', by => 'regen/mk_invlists.pl', from => "mph.pl"}); no warnings 'once'; print $keywords_fh <<"EOF"; /* The precision to use in "%.*e" formats */ #define PL_E_FORMAT_PRECISION $utf8::e_precision EOF my ($second_level, $seed1, $length_all_keys, $smart_blob, $rows) = MinimalPerfectHash::make_mph_from_hash(\%keywords); print $keywords_fh MinimalPerfectHash::make_algo($second_level, $seed1, $length_all_keys, $smart_blob, $rows, undef, undef, undef, 'match_uniprop' ); push @sources, 'regen/mph.pl'; read_only_bottom_close_and_rename($keywords_fh, \@sources);