lib/unicore/mktables

   1 #!/usr/bin/perl -w
   2 use strict;
   3 use Carp;
   4 ##
   5 ## mktables -- create the runtime Perl Unicode files (lib/unicore/**/*.pl)
   6 ## from the Unicode database files (lib/unicore/*.txt).
   7 ##
   8
   9 mkdir("In", 0755);
  10 mkdir("Is", 0755);
  11 mkdir("To", 0755);
  12
  13 ##
  14 ## Process any args.
  15 ##
  16 my $Verbose = 0;
  17
  18 while (@ARGV)
  19 {
  20     my $arg = shift @ARGV;
  21     if ($arg eq '-v') {
  22         $Verbose = 1;
  23     } elsif ($arg eq '-q') {
  24         $Verbose = 0;
  25     } else {
  26         die "usage: $0 [-v|-q]";
  27     }
  28 }
  29
  30 my $LastUnicodeCodepoint = 0x10FFFF; # As of Unicode 3.1.1.
  31
  32 my $now = localtime;
  33 my $HEADER=<<"EOF";
  34 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
  35 # This file is built by $0 from e.g. Unicode.txt.
  36 # Any changes made here will be lost!
  37
  38 EOF
  39
  40 ##
  41 ## The main datastructure (a "Table") represents a set of code points that
  42 ## are part of a particular quality (that are part of \pL, \p{InGreek},
  43 ## etc.). They are kept as ranges of code points (starting and ending of
  44 ## each range).
  45 ##
  46 ## For example, a range ASCII LETTERS would be represented as:
  47 ##   [ [ 0x41 => 0x5A, 'UPPER' ],
  48 ##     [ 0x61 => 0x7A, 'LOWER, ] ]
  49 ##
  50 sub RANGE_START() { 0 } ## index into range element
  51 sub RANGE_END()   { 1 } ## index into range element
  52 sub RANGE_NAME()  { 2 } ## index into range element
  53
  54 my %TableInfo;
  55 my %FuzzyNames;
  56 my %AliasInfo;
  57
  58 ##
  59 ## Associates a property ("Greek", "Lu", "Assigned",...) with a Table.
  60 ##
  61 ## Called like:
  62 ##       New_Prop(In => 'Greek', $Table, AllowFuzzy => 1);
  63 ##
  64 ## Normally, these parameters are set when the Table is created (when the
  65 ## Table->New constructor is called), but there are times when it needs to
  66 ## be done after-the-fact...)
  67 ##
  68 sub New_Prop($$$@)
  69 {
  70     my $Type = shift; ## "Is" or "In";
  71     my $Name = shift;
  72     my $Table = shift;
  73
  74     ## remaining args are optional key/val
  75     my %Args = @_;
  76
  77     my $AllowFuzzy = delete $Args{AllowFuzzy};
  78
  79     ## sanity check a few args
  80     if (%Args or ($Type ne 'Is' and $Type ne 'In') or not ref $Table) {
  81         confess "$0: bad args to New_Prop"
  82     }
  83
  84     if (not $TableInfo{$Type}->{$Name})
  85     {
  86         $TableInfo{$Type}->{$Name} = $Table;
  87         if ($AllowFuzzy) {
  88             $FuzzyNames{$Type}->{$Name} = $Name;
  89         }
  90     }
  91 }
  92
  93
  94 ##
  95 ## Creates a new Table object.
  96 ##
  97 ## Args are key/value pairs:
  98 ##    In => Name              -- Name of "In" property to be associated with
  99 ##    Is => Name              -- Name of "Is" property to be associated with
 100 ##    AllowFuzzy => Boolean   -- True if name can be accessed "fuzzily"
 101 ##
 102 ## No args are required.
 103 ##
 104 sub Table::New
 105 {
 106     my $class = shift;
 107     my %Args = @_;
 108
 109     my $Table = bless [], $class;
 110
 111     my $AllowFuzzy = delete $Args{AllowFuzzy};
 112
 113     for my $Type ('Is', 'In')
 114     {
 115         if (my $Name = delete $Args{$Type}) {
 116             New_Prop($Type => $Name, $Table, AllowFuzzy => $AllowFuzzy);
 117         }
 118     }
 119
 120     ## shouldn't have any left over
 121     if (%Args) {
 122         confess "$0: bad args to Table->New"
 123     }
 124
 125     return $Table;
 126 }
 127
 128 ##
 129 ## Returns true if the Table has no code points
 130 ##
 131 sub Table::IsEmpty
 132 {
 133     my $Table = shift; #self
 134     return not @$Table;
 135 }
 136
 137 ##
 138 ## Returns true if the Table has code points
 139 ##
 140 sub Table::NotEmpty
 141 {
 142     my $Table = shift; #self
 143     return @$Table;
 144 }
 145
 146 ##
 147 ## Returns the maximum code point currently in the table.
 148 ##
 149 sub Table::Max
 150 {
 151     my $Table = shift; #self
 152     confess "oops" if $Table->IsEmpty; ## must have code points to have a max
 153     return $Table->[-1]->[RANGE_END];
 154 }
 155
 156 ##
 157 ## Replaces the codepoints in the Table with those in the Table given
 158 ## as an arg. (NOTE: this is not a "deep copy").
 159 ##
 160 sub Table::Replace($$)
 161 {
 162     my $Table = shift; #self
 163     my $New   = shift;
 164
 165     @$Table = @$New;
 166 }
 167
 168 ##
 169 ## Given a new code point, make the last range of the Table extend to
 170 ## include the new (and all intervening) code points.
 171 ##
 172 sub Table::Extend
 173 {
 174     my $Table = shift; #self
 175     my $codepoint = shift;
 176
 177     my $PrevMax = $Table->Max;
 178
 179     confess "oops ($codepoint <= $PrevMax)" if $codepoint <= $PrevMax;
 180
 181     $Table->[-1]->[RANGE_END] = $codepoint;
 182 }
 183
 184 ##
 185 ## Given a code point range start and end (and optional name), blindly
 186 ## append them to the list of ranges for the Table.
 187 ##
 188 ## NOTE: Code points must be added in strictly ascending numeric order.
 189 ##
 190 sub Table::RawAppendRange
 191 {
 192     my $Table = shift; #self
 193     my $start = shift;
 194     my $end   = shift;
 195     my $name  = shift;
 196     $name = "" if not defined $name; ## warning: $name can be "0"
 197
 198     push @$Table, [ $start,    # RANGE_START
 199                     $end,      # RANGE_END
 200                     $name   ]; # RANGE_NAME
 201 }
 202
 203 ##
 204 ## Given a code point (and optional name), add it to the Table.
 205 ##
 206 ## NOTE: Code points must be added in strictly ascending numeric order.
 207 ##
 208 sub Table::Append
 209 {
 210     my $Table     = shift; #self
 211     my $codepoint = shift;
 212     my $name      = shift;
 213     $name = "" if not defined $name; ## warning: $name can be "0"
 214
 215     ##
 216     ## If we've already got a range working, and this code point is the next
 217     ## one in line, and if the name is the same, just extend the current range.
 218     ##
 219     if ($Table->NotEmpty
 220         and
 221         $Table->Max == $codepoint - 1
 222         and
 223         $Table->[-1]->[RANGE_NAME] eq $name)
 224     {
 225         $Table->Extend($codepoint);
 226     }
 227     else
 228     {
 229         $Table->RawAppendRange($codepoint, $codepoint, $name);
 230     }
 231 }
 232
 233 ##
 234 ## Given a code point range starting value and ending value (and name),
 235 ## Add the range to teh Table.
 236 ##
 237 ## NOTE: Code points must be added in strictly ascending numeric order.
 238 ##
 239 sub Table::AppendRange
 240 {
 241     my $Table = shift; #self
 242     my $start = shift;
 243     my $end   = shift;
 244     my $name  = shift;
 245     $name = "" if not defined $name; ## warning: $name can be "0"
 246
 247     $Table->Append($start, $name);
 248     $Table->Extend($end) if $end > $start;
 249 }
 250
 251 ##
 252 ## Return a new Table that represents all code points not in the Table.
 253 ##
 254 sub Table::Invert
 255 {
 256     my $Table = shift; #self
 257
 258     my $New = Table->New();
 259     my $max = -1;
 260     for my $range (@$Table)
 261     {
 262         my $start = $range->[RANGE_START];
 263         my $end   = $range->[RANGE_END];
 264         if ($start-1 >= $max+1) {
 265             $New->AppendRange($max+1, $start-1, "");
 266         }
 267         $max = $end;
 268     }
 269     if ($max+1 < $LastUnicodeCodepoint) {
 270         $New->AppendRange($max+1, $LastUnicodeCodepoint);
 271     }
 272     return $New;
 273 }
 274
 275 ##
 276 ## Merges any number of other tables with $self, returning the new table.
 277 ## (existing tables are not modified)
 278 ##
 279 ##
 280 ## Args may be Tables, or individual code points (as integers).
 281 ##
 282 ## Can be called as either a constructor or a method.
 283 ##
 284 sub Table::Merge
 285 {
 286     shift(@_) if not ref $_[0]; ## if called as a constructor, lose the class
 287     my @Tables = @_;
 288
 289     ## Accumulate all records from all tables
 290     my @Records;
 291     for my $Arg (@Tables)
 292     {
 293         if (ref $Arg) {
 294             ## arg is a table -- get its ranges
 295             push @Records, @$Arg;
 296         } else {
 297             ## arg is a codepoint, make a range
 298             push @Records, [ $Arg, $Arg ]
 299         }
 300     }
 301
 302     ## sort by range start, with longer ranges coming first.
 303     my ($first, @Rest) = sort {
 304         ($a->[RANGE_START] <=> $b->[RANGE_START])
 305           or
 306         ($b->[RANGE_END]   <=> $b->[RANGE_END])
 307     } @Records;
 308
 309     my $New = Table->New();
 310
 311     ## Ensuring the first range is there makes the subsequent loop easier
 312     $New->AppendRange($first->[RANGE_START],
 313                       $first->[RANGE_END]);
 314
 315     ## Fold in records so long as they add new information.
 316     for my $set (@Rest)
 317     {
 318         my $start = $set->[RANGE_START];
 319         my $end   = $set->[RANGE_END];
 320         if ($start > $New->Max) {
 321             $New->AppendRange($start, $end);
 322         } elsif ($end > $New->Max) {
 323             $New->Extend($end);
 324         }
 325     }
 326
 327     return $New;
 328 }
 329
 330 ##
 331 ## Given a filename, write a representation of the Table to a file.
 332 ##
 333 sub Table::Write
 334 {
 335     my $Table = shift; #self
 336     my $filename = shift;
 337
 338     print "$filename\n" if $Verbose;
 339
 340     if (not open(OUT, ">$filename")) {
 341         die "$0: can't write $filename: $!\n";
 342     }
 343
 344     print OUT $HEADER;
 345     print OUT "return <<'END';\n";
 346
 347     for my $set (@$Table)
 348     {
 349         my $start = $set->[RANGE_START];
 350         my $end   = $set->[RANGE_END];
 351         my $name  = $set->[RANGE_NAME];
 352
 353         if ($start == $end) {
 354             printf OUT "%04X\t\t%s\n", $start, $name;
 355         } else {
 356             printf OUT "%04X\t%04X\t%s\n", $start, $end, $name;
 357         }
 358     }
 359
 360     print OUT "END\n";
 361     close OUT;
 362 }
 363
 364 ###########################################################################
 365 ###########################################################################
 366 ###########################################################################
 367
 368
 369 ##
 370 ## Called like:
 371 ##     New_Alias(Is => 'All', SameAs => 'Any', AllowFuzzy => 1);
 372 ##
 373 ## The args must be in that order, although the AllowFuzzy pair may be omitted.
 374 ##
 375 ## This creates 'IsAll' as an alias for 'IsAny'
 376 ##
 377 sub New_Alias($$$@)
 378 {
 379     my $Type   = shift; ## "Is" or "In"
 380     my $Alias  = shift;
 381     my $SameAs = shift;
 382     my $Name   = shift;
 383
 384     ## remaining args are optional key/val
 385     my %Args = @_;
 386
 387     my $AllowFuzzy = delete $Args{AllowFuzzy};
 388
 389     ## sanity check a few args
 390     if (%Args or ($Type ne 'Is' and $Type ne 'In') or $SameAs ne 'SameAs') {
 391         confess "$0: bad args to New_Alias"
 392     }
 393
 394     if (not $TableInfo{$Type}->{$Name}) {
 395         confess "$0: don't have orignial $Type => $Name to make alias"
 396     }
 397     if ($TableInfo{$Alias}) {
 398         confess "$0: already have original $Type => $Alias; can't make alias";
 399     }
 400     $AliasInfo{$Type}->{$Name} = $Alias;
 401     if ($AllowFuzzy) {
 402         $FuzzyNames{$Type}->{$Alias} = $Name;
 403     }
 404
 405 }
 406
 407 ##
 408 ## Turn something like
 409 ##    OLD-ITALIC
 410 ## to
 411 ##    Old_Italic
 412 ##
 413 sub CanonicalName($)
 414 {
 415     my $name = lc shift;
 416     $name =~ s/\W+/_/;
 417     $name =~ s/(?<![a-z])(\w)/\u$1/g;
 418     return $name;
 419 }
 420
 421
 422 ## All assigned code points
 423 my $Assigned = Table->New(Is => 'Assigned', AllowFuzzy => 1);
 424
 425 my $Name     = Table->New(); ## all characters, individually by name
 426 my $General  = Table->New(); ## all characters, grouped by category
 427 my %General;
 428 my %Cat;
 429
 430 ##
 431 ## Process Unicode.txt (Categories, etc.)
 432 ##
 433 sub Unicode_Txt()
 434 {
 435     my $Bidi     = Table->New();
 436     my $Deco     = Table->New();
 437     my $Comb     = Table->New();
 438     my $Number   = Table->New();
 439     my $Mirrored = Table->New(Is => 'Mirrored', AllowFuzzy => 0);
 440
 441     my %DC;
 442     my %Bidi;
 443     my %Deco;
 444     $Deco{Canon}   = Table->New(Is => 'Canon',  AllowFuzzy => 0);
 445     $Deco{Compat}  = Table->New(Is => 'Compat', AllowFuzzy => 0);
 446
 447     ## Initialize Perl-generated categories
 448     $Cat{Alnum}     = Table->New(Is => 'Alnum',     AllowFuzzy => 0);
 449     $Cat{Alpha}     = Table->New(Is => 'Alpha',     AllowFuzzy => 0);
 450     $Cat{ASCII}     = Table->New(Is => 'ASCII',     AllowFuzzy => 0);
 451     $Cat{Blank}     = Table->New(Is => 'Blank',     AllowFuzzy => 0);
 452     $Cat{Cntrl}     = Table->New(Is => 'Cntrl',     AllowFuzzy => 0);
 453     $Cat{Digit}     = Table->New(Is => 'Digit',     AllowFuzzy => 0);
 454     $Cat{Graph}     = Table->New(Is => 'Graph',     AllowFuzzy => 0);
 455     $Cat{Lower}     = Table->New(Is => 'Lower',     AllowFuzzy => 0);
 456     $Cat{Print}     = Table->New(Is => 'Print',     AllowFuzzy => 0);
 457     $Cat{Punct}     = Table->New(Is => 'Punct',     AllowFuzzy => 0);
 458     $Cat{SpacePerl} = Table->New(Is => 'SpacePerl', AllowFuzzy => 0);
 459     $Cat{Space}     = Table->New(Is => 'Space',     AllowFuzzy => 0);
 460     $Cat{Title}     = Table->New(Is => 'Title',     AllowFuzzy => 0);
 461     $Cat{Upper}     = Table->New(Is => 'Upper',     AllowFuzzy => 0);
 462     $Cat{Word}      = Table->New(Is => 'Word' ,     AllowFuzzy => 0);
 463     $Cat{XDigit}    = Table->New(Is => 'XDigit',    AllowFuzzy => 0);
 464     ## Categories from Unicode.txt are auto-initialized in gencat()
 465
 466     my %To;
 467     $To{Upper} = Table->New();
 468     $To{Lower} = Table->New();
 469     $To{Title} = Table->New();
 470     $To{Digit} = Table->New();
 471
 472     sub gencat($$$$)
 473     {
 474         my ($name, ## Name ("LATIN CAPITAL LETTER A")
 475             $cat,  ## Category ("Lu", "Zp", "Nd", etc.)
 476             $code, ## Code point (as an integer)
 477             $op) = @_;
 478
 479         my $MajorCat = substr($cat, 0, 1); ## L, M, Z, S, etc
 480
 481         $Assigned->$op($code);
 482         $Name->$op($code, $name);
 483         $General->$op($code, $cat);
 484
 485         ## add to the sub category (e.g. "Lu", "Nd", "Cf", ..)
 486         $Cat{$cat}      ||= Table->New(Is => $cat, AllowFuzzy => 0);
 487         $Cat{$cat}->$op($code);
 488
 489         ## add to the major category (e.g. "L", "N", "C", ...)
 490         $Cat{$MajorCat} ||= Table->New(Is => $MajorCat, AllowFuzzy => 0);
 491         $Cat{$MajorCat}->$op($code);
 492
 493         ($General{$name} ||= Table->New)->$op($code, $name);
 494
 495         # 005F: SPACING UNDERSCORE
 496         $Cat{Word}->$op($code)  if $cat =~ /^[LMN]/ || $code == 0x005F;
 497         $Cat{Alnum}->$op($code) if $cat =~ /^[LMN]/;
 498         $Cat{Alpha}->$op($code) if $cat =~ /^[LM]/;
 499
 500
 501
 502         $Cat{Space}->$op($code) if $cat  =~ /^Z/
 503                                 || $code == 0x0009  # 0009: HORIZONTAL TAB
 504                                 || $code == 0x000A  # 000A: LINE FEED
 505                                 || $code == 0x000B  # 000B: VERTICAL TAB
 506                                 || $code == 0x000C  # 000C: FORM FEED
 507                                 || $code == 0x000D; # 000D: CARRIAGE RETURN
 508
 509
 510         $Cat{SpacePerl}->$op($code) if $cat =~ /^Z/
 511                                     || $code == 0x0009 # 0009: HORIZONTAL TAB
 512                                     || $code == 0x000A # 000A: LINE FEED
 513                                     || $code == 0x000C # 000C: FORM FEED
 514                                     || $code == 0x000D # 000D: CARRIAGE RETURN
 515                                     || $code == 0x0085 # 0085: <NEXT LINE>
 516                                     || $code == 0x2028 # 2028: LINE SEPARATOR
 517                                     || $code == 0x2029;# 2029: PARAGRAPH SEP.
 518
 519         $Cat{Blank}->$op($code) if $cat  =~ /^Z[^lp]$/
 520                                 || $code == 0x0009  # 0009: HORIZONTAL TAB
 521                                 || $code == 0x0020; # 0020: SPACE
 522
 523         $Cat{Digit}->$op($code) if $cat eq "Nd";
 524         $Cat{Upper}->$op($code) if $cat eq "Lu";
 525         $Cat{Lower}->$op($code) if $cat eq "Ll";
 526         $Cat{Title}->$op($code) if $cat eq "Lt";
 527         $Cat{ASCII}->$op($code) if $code <= 0x007F;
 528         $Cat{Cntrl}->$op($code) if $cat =~ /^C/;
 529         $Cat{Graph}->$op($code) if $cat =~ /^([LMNPS]|Co)/;
 530         $Cat{Print}->$op($code) if $cat =~ /^([LMNPS]|Co|Zs)/;
 531         $Cat{Punct}->$op($code) if $cat =~ /^P/;
 532
 533         $Cat{XDigit}->$op($code) if ($code >= 0x30 && $code <= 0x39)  ## 0..9
 534                                  || ($code >= 0x41 && $code <= 0x46)  ## A..F
 535                                  || ($code >= 0x61 && $code <= 0x66); ## a..f
 536     }
 537
 538     ## open ane read file.....
 539     if (not open IN, "Unicode.txt") {
 540         die "$0: Unicode.txt: $!\n";
 541     }
 542
 543     ##
 544     ## For building \p{_CombAbove} and \p{_CanonDCIJ}
 545     ##
 546     my %_Above_HexCodes; ## Hexcodes for chars with $comb == 230 ("ABOVE")
 547
 548     my %CodeToDeco;      ## Maps code to decomp. list for chars with first
 549                          ## decomp. char an "i" or "j" (for \p{_CanonDCIJ})
 550
 551     ## This is filled in as we go....
 552     my $CombAbove = Table->New(Is => '_CombAbove', AllowFuzzy => 0);
 553
 554     while (<IN>)
 555     {
 556         next unless /^[0-9A-Fa-f]+;/;
 557         s/\s+$//;
 558
 559         my ($hexcode,   ## code point in hex (e.g. "0041")
 560             $name,      ## character name (e.g. "LATIN CAPITAL LETTER A")
 561             $cat,       ## category (e.g. "Lu")
 562             $comb,      ## Canonical combining class (e.t. "230")
 563             $bidi,      ## directional category (e.g. "L")
 564             $deco,      ## decomposition mapping
 565             $decimal,   ## decimal digit value
 566             $digit,     ## digit value
 567             $number,    ## numeric value
 568             $mirrored,  ## mirrored
 569             $unicode10, ## name in Unicode 1.0
 570             $comment,   ## comment field
 571             $upper,     ## uppercase mapping
 572             $lower,     ## lowercase mapping
 573             $title,     ## titlecase mapping
 574               ) = split(/\s*;\s*/);
 575
 576         my $code = hex($hexcode);
 577
 578         if ($comb and $comb == 230) {
 579             $CombAbove->Append($code);
 580             $_Above_HexCodes{$hexcode} = 1;
 581         }
 582
 583         ## Used in building \p{_CanonDCIJ}
 584         if ($deco and $deco =~ m/^006[9A]\b/) {
 585             $CodeToDeco{$code} = $deco;
 586         }
 587
 588         ##
 589         ## There are a few pairs of lines like:
 590         ##   AC00;<Hangul Syllable, First>;Lo;0;L;;;;;N;;;;;
 591         ##   D7A3;<Hangul Syllable, Last>;Lo;0;L;;;;;N;;;;;
 592         ## that define ranges.
 593         ##
 594         if ($name =~ /^<(.+), (First|Last)>$/)
 595         {
 596             $name = $1;
 597             gencat($name, $cat, $code, $2 eq 'First' ? 'Append' : 'Extend');
 598             #New_Prop(In => $name, $General{$name}, AllowFuzzy => 1);
 599         }
 600         else
 601         {
 602             ## normal (single-character) lines
 603             gencat($name, $cat, $code, 'Append');
 604
 605             # No Append() here since since several codes may map into one.
 606             $To{Upper}->RawAppendRange($code, $code, $upper) if $upper;
 607             $To{Lower}->RawAppendRange($code, $code, $lower) if $lower;
 608             $To{Title}->RawAppendRange($code, $code, $title) if $title;
 609             $To{Digit}->Append($code, $decimal) if length $decimal;
 610
 611             $Bidi->Append($code, $bidi);
 612             $Comb->Append($code, $comb) if $comb;
 613             $Number->Append($code, $number) if length $number;
 614
 615             $Mirrored->Append($code) if $mirrored eq "Y";
 616
 617             $Bidi{$bidi} ||= Table->New(Is => "Bidi$bidi", AllowFuzzy => 0);
 618             $Bidi{$bidi}->Append($code);
 619
 620             if ($deco)
 621             {
 622                 $Deco->Append($code, $deco);
 623                 if ($deco =~/^<(\w+)>/)
 624                 {
 625                     $Deco{Compat}->Append($code);
 626
 627                     $DC{$1} ||= Table->New(Is => "DC$1", AllowFuzzy => 0);
 628                     $DC{$1}->Append($code);
 629                 }
 630                 else
 631                 {
 632                     $Deco{Canon}->Append($code);
 633                 }
 634             }
 635         }
 636     }
 637     close IN;
 638
 639     ##
 640     ## Tidy up a few special cases....
 641     ##
 642
 643     $Cat{Cn} = $Assigned->Invert; ## Cn is everything that doesn't exist
 644     New_Prop(Is => 'Cn', $Cat{Cn}, AllowFuzzy => 0);
 645
 646     ## Unassigned is the same as 'Cn'
 647     New_Alias(Is => 'Unassigned', SameAs => 'Cn', AllowFuzzy => 1);
 648
 649     $Cat{C}->Replace($Cat{C}->Merge($Cat{Cn}));  ## Now merge in Cn into C
 650
 651
 652     # L& is Ll, Lu, and Lt.
 653     New_Prop(Is => 'L&',
 654              Table->Merge(@Cat{qw[Ll Lu Lt]}),
 655              AllowFuzzy => 0);
 656
 657     ## Any and All are all code points.
 658     my $Any = Table->New(Is => 'Any', AllowFuzzy => 1);
 659     $Any->RawAppendRange(0, $LastUnicodeCodepoint);
 660
 661     New_Alias(Is => 'All', SameAs => 'Any', AllowFuzzy => 1);
 662
 663     ##
 664     ## Build special properties for Perl's internal case-folding needs:
 665     ##    \p{_CaseIgnorable}
 666     ##    \p{_CanonDCIJ}
 667     ##    \p{_CombAbove}
 668     ## _CombAbove was built above. Others are built here....
 669     ##
 670
 671     ## \p{_CaseIgnorable} is [\p{Mn}\0x00AD\x2010]
 672     New_Prop(Is => '_CaseIgnorable',
 673              Table->Merge($Cat{Mn},
 674                           0x00AD,    #SOFT HYPHEN
 675                           0x2010),   #HYPHEN
 676              AllowFuzzy => 0);
 677
 678
 679     ## \p{_CanonDCIJ} is fairly complex...
 680     my $CanonCDIJ = Table->New(Is => '_CanonDCIJ', AllowFuzzy => 0);
 681     ## It contains the ASCII 'i' and 'j'....
 682     $CanonCDIJ->Append(0x0069); # ASCII ord("i")
 683     $CanonCDIJ->Append(0x006A); # ASCII ord("j")
 684     ## ...and any character with a decomposition that starts with either of
 685     ## those code points, but only if the decomposition does not have any
 686     ## combining character with the "ABOVE" canonical combining class.
 687     for my $code (sort { $a <=> $b} keys %CodeToDeco)
 688     {
 689         ## Need to ensure that all decomposition characters do not have
 690         ## a %HexCodeToComb in %AboveCombClasses.
 691         my $want = 1;
 692         for my $deco_hexcode (split / /, $CodeToDeco{$code})
 693         {
 694             if (exists $_Above_HexCodes{$deco_hexcode}) {
 695                 ## one of the decmposition chars has an ABOVE combination
 696                 ## class, so we're not interested in this one
 697                 $want = 0;
 698                 last;
 699             }
 700         }
 701         if ($want) {
 702             $CanonCDIJ->Append($code);
 703         }
 704     }
 705
 706
 707
 708     ##
 709     ## Now dump the files.
 710     ##
 711     $Name->Write("Name.pl");
 712     $Bidi->Write("Bidirectional.pl");
 713     $Comb->Write("CombiningClass.pl");
 714     $Deco->Write("Decomposition.pl");
 715     $Number->Write("Number.pl");
 716     $General->Write("Category.pl");
 717
 718     for my $to (sort keys %To) {
 719         $To{$to}->Write("To/$to.pl");
 720     }
 721 }
 722
 723 ##
 724 ## Process LineBrk.txt
 725 ##
 726 sub LineBrk_Txt()
 727 {
 728     if (not open IN, "LineBrk.txt") {
 729         die "$0: LineBrk.txt: $!\n";
 730     }
 731
 732     my $Lbrk = Table->New();
 733     my %Lbrk;
 734
 735     while (<IN>)
 736     {
 737         next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s*;\s*(\w+)/;
 738
 739         my ($first, $last, $lbrk) = (hex($1), hex($2||""), $3);
 740
 741         $Lbrk->Append($first, $lbrk);
 742
 743         $Lbrk{$lbrk} ||= Table->New(Is => "Lbrk$lbrk", AllowFuzzy => 0);
 744         $Lbrk{$lbrk}->Append($first);
 745
 746         if ($last) {
 747             $Lbrk->Extend($last);
 748             $Lbrk{$lbrk}->Extend($last);
 749         }
 750     }
 751     close IN;
 752
 753     $Lbrk->Write("Lbrk.pl");
 754 }
 755
 756 ##
 757 ## Process ArabShap.txt.
 758 ##
 759 sub ArabShap_txt()
 760 {
 761     if (not open IN, "ArabShap.txt") {
 762         die "$0: ArabShap.txt: $!\n";
 763     }
 764
 765     my $ArabLink      = Table->New();
 766     my $ArabLinkGroup = Table->New();
 767
 768     while (<IN>)
 769     {
 770         next unless /^[0-9A-Fa-f]+;/;
 771         s/\s+$//;
 772
 773         my ($hexcode, $name, $link, $linkgroup) = split(/\s*;\s*/);
 774         my $code = hex($hexcode);
 775         $ArabLink->Append($code, $link);
 776         $ArabLinkGroup->Append($code, $linkgroup);
 777     }
 778     close IN;
 779
 780     $ArabLink->Write("ArabLink.pl");
 781     $ArabLinkGroup->Write("ArabLnkGrp.pl");
 782 }
 783
 784 ##
 785 ## Process Jamo.txt.
 786 ##
 787 sub Jamo_txt()
 788 {
 789     if (not open IN, "Jamo.txt") {
 790         die "$0: Jamo.txt: $!\n";
 791     }
 792     my $Short = Table->New();
 793
 794     while (<IN>)
 795     {
 796         next unless /^([0-9A-Fa-f]+)\s*;\s*(\w*)/;
 797         my ($code, $short) = (hex($1), $2);
 798
 799         $Short->Append($code, $short);
 800     }
 801     close IN;
 802     $Short->Write("JamoShort.pl");
 803 }
 804
 805 ##
 806 ## Process Scripts.txt.
 807 ##
 808 sub Scripts_txt()
 809 {
 810     my @ScriptInfo;
 811
 812     if (not open(IN, "Scripts.txt")) {
 813         die "$0: Scripts.txt: $!\n";
 814     }
 815     while (<IN>) {
 816         next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s*;\s*(.+?)\s*\#/;
 817
 818         # Wait until all the scripts have been read since
 819         # they are not listed in numeric order.
 820         push @ScriptInfo, [ hex($1), hex($2||""), $3 ];
 821     }
 822     close IN;
 823
 824     # Now append the scripts properties in their code point order.
 825
 826     my %Script;
 827     my $Scripts = Table->New();
 828
 829     for my $script (sort { $a->[0] <=> $b->[0] } @ScriptInfo)
 830     {
 831         my ($first, $last, $name) = @$script;
 832         $Scripts->Append($first, $name);
 833
 834         $Script{$name} ||= Table->New(Is => CanonicalName($name),
 835                                       AllowFuzzy => 1);
 836         $Script{$name}->Append($first, $name);
 837
 838         if ($last) {
 839             $Scripts->Extend($last);
 840             $Script{$name}->Extend($last);
 841         }
 842     }
 843
 844     $Scripts->Write("Scripts.pl");
 845
 846     ## Common is everything not explicitly assigned to a Script
 847     ##
 848     ##    ***shouldn't this be intersected with \p{Assigned}? ******
 849     ##
 850     New_Prop(Is => 'Common', $Scripts->Invert, AllowFuzzy => 1);
 851 }
 852
 853 ##
 854 ## Given a name like "Close Punctuation", return a regex (that when applied
 855 ## with /i) matches any valid form of that name (e.g. "ClosePunctuation",
 856 ## "Close-Punctuation", etc.)
 857 ##
 858 ## Accept any space, dash, or underbar where in the official name there is
 859 ## space or a dash (or underbar, but there never is).
 860 ##
 861 ##
 862 sub NameToRegex($)
 863 {
 864     my $Name = shift;
 865     $Name =~ s/[- _]/(?:[-_]|\\s+)?/g;
 866     return $Name;
 867 }
 868
 869 ##
 870 ## Process Blocks.txt.
 871 ##
 872 sub Blocks_txt()
 873 {
 874     my $Blocks = Table->New();
 875     my %Blocks;
 876
 877     if (not open IN, "Blocks.txt") {
 878         die "$0: Blocks.txt: $!\n";
 879     }
 880
 881     while (<IN>)
 882     {
 883         #next if not /Private Use$/;
 884         next if not /^([0-9A-Fa-f]+)\.\.([0-9A-Fa-f]+)\s*;\s*(.+?)\s*$/;
 885
 886         my ($first, $last, $name) = (hex($1), hex($2), $3);
 887
 888         $Blocks->Append($first, $name);
 889
 890         $Blocks{$name} ||= Table->New(In=>CanonicalName($name), AllowFuzzy=>1);
 891         $Blocks{$name}->Append($first, $name);
 892
 893         if ($last and $last != $first) {
 894             $Blocks->Extend($last);
 895             $Blocks{$name}->Extend($last);
 896         }
 897     }
 898     close IN;
 899
 900     $Blocks->Write("Blocks.pl");
 901 }
 902
 903 ##
 904 ## Read in the PropList.txt.  It contains extended properties not
 905 ## listed in the Unicode.txt, such as 'Other_Alphabetic':
 906 ## alphabetic but not of the general category L; many modifiers
 907 ## belong to this extended property category: while they are not
 908 ## alphabets, they are alphabetic in nature.
 909 ##
 910 sub PropList_txt()
 911 {
 912     my @PropInfo;
 913
 914     if (not open IN, "PropList.txt") {
 915         die "$0: PropList.txt: $!\n";
 916     }
 917
 918     while (<IN>)
 919     {
 920         next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s*;\s*(.+?)\s*\#/;
 921
 922         # Wait until all the extended properties have been read since
 923         # they are not listed in numeric order.
 924         push @PropInfo, [ hex($1), hex($2||""), $3 ];
 925     }
 926     close IN;
 927
 928     # Now append the extended properties in their code point order.
 929     my $Props = Table->New();
 930     my %Prop;
 931
 932     for my $prop (sort { $a->[0] <=> $b->[0] } @PropInfo)
 933     {
 934         my ($first, $last, $name) = @$prop;
 935         $Props->Append($first, $name);
 936
 937         $Prop{$name} ||= Table->New(Is => $name, AllowFuzzy => 1);
 938         $Prop{$name}->Append($first, $name);
 939
 940         if ($last) {
 941             $Props->Extend($last);
 942             $Prop{$name}->Extend($last);
 943         }
 944     }
 945
 946     # Alphabetic is L and Other_Alphabetic.
 947     New_Prop(Is => 'Alphabetic',
 948              Table->Merge($Cat{L}, $Prop{Other_Alphabetic}),
 949              AllowFuzzy => 1);
 950
 951     # Lowercase is Ll and Other_Lowercase.
 952     New_Prop(Is => 'Lowercase',
 953              Table->Merge($Cat{Ll}, $Prop{Other_Lowercase}),
 954              AllowFuzzy => 1);
 955
 956     # Uppercase is Lu and Other_Uppercase.
 957     New_Prop(Is => 'Uppercase',
 958              Table->Merge($Cat{Lu}, $Prop{Other_Uppercase}),
 959              AllowFuzzy => 1);
 960
 961     # Math is Sm and Other_Math.
 962     New_Prop(Is => 'Math',
 963              Table->Merge($Cat{Sm}, $Prop{Other_Math}),
 964              AllowFuzzy => 1);
 965
 966     # ID_Start is Ll, Lu, Lt, Lm, Lo, and Nl.
 967     New_Prop(Is => 'ID_Start',
 968              Table->Merge(@Cat{qw[Ll Lu Lt Lm Lo Nl]}),
 969              AllowFuzzy => 1);
 970
 971     # ID_Continue is ID_Start, Mn, Mc, Nd, and Pc.
 972     New_Prop(Is => 'ID_Continue',
 973              Table->Merge(@Cat{qw[Ll Lu Lt Lm Lo Nl Mn Mc Nd Pc ]}),
 974              AllowFuzzy => 1);
 975 }
 976
 977 sub Make_GC_Aliases()
 978 {
 979     ##
 980     ## The mapping from General Category long forms to short forms is
 981     ## currently hardwired here since no simple data file in the UCD
 982     ## seems to do that.  Unicode 3.2 will assumedly correct this.
 983     ##
 984     my %Is = (
 985         'Letter'                        =>      'L',
 986         'Uppercase_Letter'              =>      'Lu',
 987         'Lowercase_Letter'              =>      'Ll',
 988         'Titlecase_Letter'              =>      'Lt',
 989         'Modifier_Letter'               =>      'Lm',
 990         'Other_Letter'                  =>      'Lo',
 991
 992         'Mark'                          =>      'M',
 993         'Non_Spacing_Mark'              =>      'Mn',
 994         'Spacing_Mark'                  =>      'Mc',
 995         'Enclosing_Mark'                =>      'Me',
 996
 997         'Separator'                     =>      'Z',
 998         'Space_Separator'               =>      'Zs',
 999         'Line_Separator'                =>      'Zl',
1000         'Paragraph_Separator'           =>      'Zp',
1001
1002         'Number'                        =>      'N',
1003         'Decimal_Number'                =>      'Nd',
1004         'Letter_Number'                 =>      'Nl',
1005         'Other_Number'                  =>      'No',
1006
1007         'Punctuation'                   =>      'P',
1008         'Connector_Punctuation'         =>      'Pc',
1009         'Dash_Punctuation'              =>      'Pd',
1010         'Open_Punctuation'              =>      'Ps',
1011         'Close_Punctuation'             =>      'Pe',
1012         'Initial_Punctuation'           =>      'Pi',
1013         'Final_Punctuation'             =>      'Pf',
1014         'Other_Punctuation'             =>      'Po',
1015
1016         'Symbol'                        =>      'S',
1017         'Math_Symbol'                   =>      'Sm',
1018         'Currency_Symbol'               =>      'Sc',
1019         'Modifier_Symbol'               =>      'Sk',
1020         'Other_Symbol'                  =>      'So',
1021
1022         'Other'                         =>      'C',
1023         'Control'                       =>      'Cc',
1024         'Format'                        =>      'Cf',
1025         'Surrogate'                     =>      'Cs',
1026         'Private Use'                   =>      'Co',
1027         'Unassigned'                    =>      'Cn',
1028     );
1029
1030     ## make the aliases....
1031     while (my ($Alias, $Name) = each %Is) {
1032         New_Alias(Is => $Alias, SameAs => $Name, AllowFuzzy => 1);
1033     }
1034 }
1035
1036 ##
1037 ## Writes the info accumulated in
1038 ##
1039 ##       %TableInfo;
1040 ##       %FuzzyNames;
1041 ##       %AliasInfo;
1042 ##
1043 ##
1044 sub WriteAllMappings()
1045 {
1046     for my $Type ('In', 'Is')
1047     {
1048         my %Filenames;
1049         my %NameToFile;
1050
1051         my %Exact; ## will become %utf8::Is    or %utf8::In
1052         my %Pat;   ## will become %utf8::IsPat or %utf8::InPat
1053
1054         ##
1055         ## First write all the files to the $Type/ directory
1056         ##
1057         while (my ($Name, $Table) = each %{$TableInfo{$Type}})
1058         {
1059             ## Need an 8.3 safe filename.
1060             my $filename = $Name;
1061             $filename =~ s/[_\W]+(\w*)/\u$1/g;
1062             substr($filename, 8) = '' if length($filename) > 8;
1063
1064             ##
1065             ## Make sure the filename doesn't conflict with something we
1066             ## might have already written. If we have, say,
1067             ##     Greek_Extended1
1068             ##     Greek_Extended2
1069             ## they become
1070             ##     Greek_Ex
1071             ##     Greek_E2
1072             ##
1073             while (my $num = $Filenames{lc $filename}++)
1074             {
1075                 $num++; ## so filenames with numbers start with '2', which
1076                         ## just looks more natural.
1077                 substr($filename, -length($num)) = $num;
1078             }
1079
1080             ##
1081             ## Okay, write the file...
1082             ##
1083             $Exact{$Name} = $filename;
1084             $Table->Write("$Type/$filename.pl");
1085         }
1086
1087         ##
1088         ## Build %Pat
1089         ##
1090         while (my ($Fuzzy, $Real) = each %{$FuzzyNames{$Type}})
1091         {
1092             my $File = $Exact{$Real};
1093
1094             if (not $File) {
1095                 die "$0: oops [$Real]";
1096             }
1097
1098             ## The prefix length of 2 is enough spread,
1099             ## and besides, we have 'Yi' as an In category.
1100             my $Prefix = lc(substr($Fuzzy, 0, 2));
1101             my $Regex = NameToRegex($Fuzzy);
1102
1103             if ($Pat{$Prefix}->{$Regex}) {
1104                 warn "WHOA, conflict with /$Regex/: $Pat{$Prefix}->{$Regex} vs $File\n";
1105             }
1106
1107             $Pat{$Prefix}->{$Regex} = $File;
1108         }
1109
1110         ##
1111         ## Since the fuzzy method will provide for a way to match $Fuzzy,
1112         ## there's no need for $Fuzzy to be in %Exact as well.
1113         ## This can't be done in the loop above because there could be
1114         ## multiple $Fuzzys pointing at the same $Real, and we don't want
1115         ## the first to delete the exact mapping out from under the second.
1116         ##
1117         for my $Fuzzy (keys %{$FuzzyNames{$Type}})
1118         {
1119             delete $Exact{$Fuzzy};
1120         }
1121
1122
1123
1124         ##
1125         ## Now write In.pl / Is.pl
1126         ##
1127         if (not open OUT, ">$Type.pl") {
1128             die "$0: $Type.pl: $!\n";
1129         }
1130         print OUT $HEADER;
1131         print OUT "##\n";
1132         print OUT "## Data in this file used by ../utf8_heavy.pl\n";
1133         print OUT "##\n";
1134         print OUT "\n";
1135         print OUT "## Mapping from name to filename in ./$Type\n";
1136         print OUT "%utf8::$Type = (\n";
1137         for my $Name (sort keys %Exact)
1138         {
1139             my $File = $Exact{$Name};
1140             printf OUT "  %-41s => %s,\n", "'$Name'", "'$File'";
1141         }
1142         print OUT ");\n\n";
1143
1144         print OUT "## Mappings from regex to filename in ./$Type/\n";
1145         print OUT "%utf8::${Type}Pat = (\n";
1146         for my $Prefix (sort keys %Pat)
1147         {
1148             print OUT " '$Prefix' => {\n";
1149             while (my ($Regex, $File) = each %{ $Pat{$Prefix} }) {
1150                 print OUT "\t'$Regex' => '$File',\n";
1151             }
1152             print OUT " },\n";
1153         }
1154         print OUT ");\n";
1155
1156         close(OUT);
1157     }
1158 }
1159
1160 sub SpecCase_txt()
1161 {
1162     #
1163     # Read in the special cases.
1164     #
1165
1166     my %CaseInfo;
1167
1168     if (not open IN, "SpecCase.txt") {
1169         die "$0: SpecCase.txt: $!\n";
1170     }
1171     while (<IN>) {
1172         next unless /^[0-9A-Fa-f]+;/;
1173         s/\#.*//;
1174         s/\s+$//;
1175
1176         my ($code, $lower, $title, $upper, $condition) = split(/\s*;\s*/);
1177
1178         if ($condition) { # not implemented yet
1179             print "# SKIPPING $_\n" if $Verbose;
1180             next;
1181         }
1182
1183         # Wait until all the special cases have been read since
1184         # they are not listed in numeric order.
1185         my $ix = hex($code);
1186         push @{$CaseInfo{Lower}}, [ $ix, $code, $lower ];
1187         push @{$CaseInfo{Title}}, [ $ix, $code, $title ];
1188         push @{$CaseInfo{Upper}}, [ $ix, $code, $upper ];
1189     }
1190     close IN;
1191
1192     # Now write out the special cases properties in their code point order.
1193     # Prepend them to the To/{Upper,Lower,Title}.pl.
1194
1195     for my $case (qw(Lower Title Upper))
1196     {
1197         my $NormalCase = do "To/$case.pl" || die "$0: $@\n";
1198         if (not open OUT, ">To/$case.pl") {
1199             die "$0: To/$case.txt: $!";
1200         }
1201
1202         print OUT $HEADER, "\n";
1203         print OUT "%utf8::ToSpec$case =\n(\n";
1204
1205         for my $prop (sort { $a->[0] <=> $b->[0] } @{$CaseInfo{$case}}) {
1206             my ($ix, $code, $to) = @$prop;
1207             my $tostr =
1208               join "", map { sprintf "\\x{%s}", $_ } split ' ', $to;
1209             printf OUT qq['%04X' => "$tostr",\n], $ix;
1210         }
1211         print OUT ");\n\n";
1212         print OUT "return <<'END';\n";
1213         print OUT $NormalCase;
1214         print OUT "END\n";
1215         close OUT;
1216     }
1217 }
1218
1219 #
1220 # Read in the case foldings.
1221 #
1222 # We will do full case folding, C + F + I (see CaseFold.txt).
1223 #
1224 sub CaseFold_txt()
1225 {
1226     if (not open IN, "CaseFold.txt") {
1227         die "$0: To/Fold.pl: $!\n";
1228     }
1229
1230     my $Fold = Table->New();
1231     my %Fold;
1232
1233     while (<IN>) {
1234         # Skip status 'S', simple case folding
1235         next unless /^([0-9A-Fa-f]+)\s*;\s*([CFI])\s*;\s*([0-9A-Fa-f]+(?: [0-9A-Fa-f]+)*)\s*;/;
1236
1237         my ($code, $status, $fold) = (hex($1), $2, $3);
1238
1239         if ($status eq 'C') { # Common: one-to-one folding
1240             # No append() since several codes may fold into one.
1241             $Fold->RawAppendRange($code, $code, $fold);
1242         } else { # F: full, or I: dotted uppercase I -> dotless lowercase I
1243             $Fold{$code} = $fold;
1244         }
1245     }
1246     close IN;
1247
1248     $Fold->Write("To/Fold.pl");
1249
1250     #
1251     # Prepend the special foldings to the common foldings.
1252     #
1253
1254     my $CommonFold = do "To/Fold.pl" || die "$0: To/Fold.pl: $!\n";
1255     if (not open OUT, ">To/Fold.pl") {
1256         die "$0: To/Fold.pl: $!\n";
1257     }
1258     print OUT $HEADER, "\n";
1259     print OUT "%utf8::ToSpecFold =\n(\n";
1260     for my $code (sort { $a <=> $b } keys %Fold) {
1261         my $foldstr =
1262           join "", map { sprintf "\\x{%s}", $_ } split ' ', $Fold{$code};
1263         printf OUT qq['%04X' => "$foldstr",\n], $code;
1264     }
1265     print OUT ");\n\n";
1266     print OUT "return <<'END';\n";
1267     print OUT $CommonFold;
1268     print OUT "END\n";
1269     close OUT;
1270 }
1271
1272 ## Do it....
1273
1274 Unicode_Txt();
1275 Make_GC_Aliases();
1276 PropList_txt();
1277
1278 Scripts_txt();
1279 Blocks_txt();
1280
1281 LineBrk_Txt();
1282 ArabShap_txt();
1283 Jamo_txt();
1284 SpecCase_txt();
1285
1286 WriteAllMappings();
1287
1288 CaseFold_txt();
1289
1290 # That's all, folks!
1291
1292 __END__