ext/Unicode/Normalize/mkheader

   1 #!perl
   2 #
   3 # This script generates "unfcan.h", "unfcpt.h", "unfcmb.h",
   4 # "unfcmp.h", and "unfexc.h"
   5 # from CombiningClass.pl, Decomposition.pl, CompositionExclusions.txt
   6 # in lib/unicore or unicode directory
   7 # for Unicode::Normalize.xs. (cf. Makefile.PL)
   8 #
   9 #  Usage: <perl mkheader> in command line
  10 #      or <do 'mkheader'> in perl
  11 #
  12 use 5.006;
  13 use strict;
  14 use warnings;
  15 use Carp;
  16 use File::Spec;
  17
  18 BEGIN {
  19     unless ("A" eq pack('U', 0x41) || "A" eq pack('U', ord("A"))) {
  20         die "Unicode::Normalize cannot stringify a Unicode code point\n";
  21     }
  22 }
  23
  24 our $PACKAGE = 'Unicode::Normalize, mkheader';
  25
  26 our $Combin = do "unicore/CombiningClass.pl"
  27     || do "unicode/CombiningClass.pl"
  28     || croak "$PACKAGE: CombiningClass.pl not found";
  29
  30 our $Decomp = do "unicore/Decomposition.pl"
  31     || do "unicode/Decomposition.pl"
  32     || croak "$PACKAGE: Decomposition.pl not found";
  33
  34 our %Combin;    # $codepoint => $number    : combination class
  35 our %Canon;     # $codepoint => \@codepoints : canonical decomp.
  36 our %Compat;    # $codepoint => \@codepoints : compat. decomp.
  37 # after _U_stringify(), ($codepoint => $hexstring) for %Canon and %Compat
  38 our %Exclus;    # $codepoint => 1          : composition exclusions
  39 our %Single;    # $codepoint => 1          : singletons
  40 our %NonStD;    # $codepoint => 1          : non-starter decompositions
  41
  42 our %Comp1st;   # $codepoint => $listname  : may be composed with a next char.
  43 our %Comp2nd;   # $codepoint => 1          : may be composed with a prev char.
  44 our %CompList;  # $listname,$2nd  => $codepoint : composite
  45
  46 our $prefix = "UNF_";
  47 our $structname = "${prefix}complist";
  48
  49 ########## definition of Hangul constants ##########
  50 use constant SBase  => 0xAC00;
  51 use constant SFinal => 0xD7A3; # SBase -1 + SCount
  52 use constant SCount =>  11172; # LCount * NCount
  53 use constant NCount =>    588; # VCount * TCount
  54 use constant LBase  => 0x1100;
  55 use constant LFinal => 0x1112;
  56 use constant LCount =>     19;
  57 use constant VBase  => 0x1161;
  58 use constant VFinal => 0x1175;
  59 use constant VCount =>     21;
  60 use constant TBase  => 0x11A7;
  61 use constant TFinal => 0x11C2;
  62 use constant TCount =>     28;
  63
  64 sub decomposeHangul {
  65     my $SIndex = $_[0] - SBase;
  66     my $LIndex = int( $SIndex / NCount);
  67     my $VIndex = int(($SIndex % NCount) / TCount);
  68     my $TIndex =      $SIndex % TCount;
  69     my @ret = (
  70        LBase + $LIndex,
  71        VBase + $VIndex,
  72       $TIndex ? (TBase + $TIndex) : (),
  73     );
  74     wantarray ? @ret : pack('U*', @ret);
  75      # any element in @ret greater than 0xFF, so no need of u2n conversion.
  76 }
  77
  78 ########## getting full decomposion ##########
  79 {
  80     my($f, $fh);
  81     foreach my $d (@INC) {
  82         $f = File::Spec->catfile($d, "unicore", "CompositionExclusions.txt");
  83         last if open($fh, $f);
  84         $f = File::Spec->catfile($d, "unicode", "CompExcl.txt");
  85         last if open($fh, $f);
  86         $f = undef;
  87     }
  88     croak "$PACKAGE: neither unicore/CompositionExclusions.txt "
  89         . "nor unicode/CompExcl.txt is found in @INC" unless defined $f;
  90
  91     while (<$fh>) {
  92         next if /^#/ or /^$/;
  93         s/#.*//;
  94         $Exclus{ hex($1) } = 1 if /([0-9A-Fa-f]+)/;
  95     }
  96     close $fh;
  97 }
  98
  99 ##
 100 ## converts string "hhhh hhhh hhhh" to a numeric list
 101 ##
 102 sub _getHexArray { map hex, $_[0] =~ /([0-9A-Fa-f]+)/g }
 103
 104 while ($Combin =~ /(.+)/g) {
 105     my @tab = split /\t/, $1;
 106     my $ini = hex $tab[0];
 107     if ($tab[1] eq '') {
 108         $Combin{ $ini } = $tab[2];
 109     } else {
 110         $Combin{ $_ } = $tab[2] foreach $ini .. hex($tab[1]);
 111     }
 112 }
 113
 114 while ($Decomp =~ /(.+)/g) {
 115     my @tab = split /\t/, $1;
 116     my $compat = $tab[2] =~ s/<[^>]+>//;
 117     my $dec = [ _getHexArray($tab[2]) ]; # decomposition
 118     my $ini = hex($tab[0]); # initial decomposable character
 119
 120     my $listname =
 121         @$dec == 2 ? sprintf("${structname}_%06x", $dec->[0]) : 'USELESS';
 122                 # %04x is bad since it'd place _3046 after _1d157.
 123
 124     if ($tab[1] eq '') {
 125         $Compat{ $ini } = $dec;
 126
 127         if (! $compat) {
 128             $Canon{ $ini } = $dec;
 129
 130             if (@$dec == 2) {
 131                 if ($Combin{ $dec->[0] }) {
 132                     $NonStD{ $ini } = 1;
 133                 } else {
 134                     $CompList{ $listname }{ $dec->[1] } = $ini;
 135                     $Comp1st{ $dec->[0] } = $listname;
 136                     $Comp2nd{ $dec->[1] } = 1 if ! $Exclus{$ini};
 137                 }
 138             } elsif (@$dec == 1) {
 139                 $Single{ $ini } = 1;
 140             } else {
 141                 croak("Weird Canonical Decomposition of U+$tab[0]");
 142             }
 143         }
 144     } else {
 145         foreach my $u ($ini .. hex($tab[1])) {
 146             $Compat{ $u } = $dec;
 147
 148             if (! $compat) {
 149                 $Canon{ $u } = $dec;
 150
 151                 if (@$dec == 2) {
 152                     if ($Combin{ $dec->[0] }) {
 153                         $NonStD{ $u } = 1;
 154                     } else {
 155                         $CompList{ $listname }{ $dec->[1] } = $u;
 156                         $Comp1st{ $dec->[0] } = $listname;
 157                         $Comp2nd{ $dec->[1] } = 1 if ! $Exclus{$u};
 158                     }
 159                 } elsif (@$dec == 1) {
 160                     $Single{ $u } = 1;
 161                 } else {
 162                     croak("Weird Canonical Decomposition of U+$tab[0]");
 163                 }
 164             }
 165         }
 166     }
 167 }
 168
 169 # modern HANGUL JUNGSEONG and HANGUL JONGSEONG jamo
 170 foreach my $j (0x1161..0x1175, 0x11A8..0x11C2) {
 171     $Comp2nd{$j} = 1;
 172 }
 173
 174 sub getCanonList {
 175     my @src = @_;
 176     my @dec = map {
 177         (SBase <= $_ && $_ <= SFinal) ? decomposeHangul($_)
 178             : $Canon{$_} ? @{ $Canon{$_} } : $_
 179                 } @src;
 180     return join(" ",@src) eq join(" ",@dec) ? @dec : getCanonList(@dec);
 181     # condition @src == @dec is not ok.
 182 }
 183
 184 sub getCompatList {
 185     my @src = @_;
 186     my @dec = map {
 187         (SBase <= $_ && $_ <= SFinal) ? decomposeHangul($_)
 188             : $Compat{$_} ? @{ $Compat{$_} } : $_
 189                 } @src;
 190     return join(" ",@src) eq join(" ",@dec) ? @dec : getCompatList(@dec);
 191     # condition @src == @dec is not ok.
 192 }
 193
 194 # exhaustive decomposition
 195 foreach my $key (keys %Canon) {
 196     $Canon{$key}  = [ getCanonList($key) ];
 197 }
 198
 199 # exhaustive decomposition
 200 foreach my $key (keys %Compat) {
 201     $Compat{$key} = [ getCompatList($key) ];
 202 }
 203
 204 sub _pack_U {
 205     return "A" eq pack('U', 0x41)
 206         ? pack('U*', @_)
 207         : "A" eq pack('U', ord("A"))
 208             ? pack('U*', map utf8::unicode_to_native($_), @_)
 209             : die "$PACKAGE, a Unicode code point cannot be stringified.\n";
 210 }
 211
 212 sub _U_stringify {
 213     sprintf '"%s"', join '',
 214         map sprintf("\\x%02x", $_), unpack 'C*', _pack_U(@_);
 215 }
 216
 217 foreach my $hash (\%Canon, \%Compat) {
 218     foreach my $key (keys %$hash) {
 219         $hash->{$key} = _U_stringify( @{ $hash->{$key} } );
 220     }
 221 }
 222
 223 ########## writing header files ##########
 224
 225 my @boolfunc = (
 226     {
 227         name => "Exclusion",
 228         type => "bool",
 229         hash => \%Exclus,
 230     },
 231     {
 232         name => "Singleton",
 233         type => "bool",
 234         hash => \%Single,
 235     },
 236     {
 237         name => "NonStDecomp",
 238         type => "bool",
 239         hash => \%NonStD,
 240     },
 241     {
 242         name => "Comp2nd",
 243         type => "bool",
 244         hash => \%Comp2nd,
 245     },
 246 );
 247
 248 my $file = "unfexc.h";
 249 open FH, ">$file" or croak "$PACKAGE: $file can't be made";
 250 binmode FH; select FH;
 251
 252     print << 'EOF';
 253 /*
 254  * This file is auto-generated by mkheader.
 255  * Any changes here will be lost!
 256  */
 257 EOF
 258
 259 foreach my $tbl (@boolfunc) {
 260     my @temp = sort {$a <=> $b} keys %{$tbl->{hash}};
 261     my $type = $tbl->{type};
 262     my $name = $tbl->{name};
 263     print "$type is$name (UV uv)\n{\nreturn\n\t";
 264
 265     while (@temp) {
 266         my $cur = shift @temp;
 267         if (@temp && $cur + 1 == $temp[0]) {
 268             print "($cur <= uv && uv <= ";
 269             while (@temp && $cur + 1 == $temp[0]) {
 270                 $cur = shift @temp;
 271             }
 272             print "$cur)";
 273             print "\n\t|| " if @temp;
 274         } else {
 275             print "uv == $cur";
 276             print "\n\t|| " if @temp;
 277         }
 278     }
 279     print "\n\t? TRUE : FALSE;\n}\n\n";
 280 }
 281
 282 close FH;
 283
 284 ####################################
 285
 286 my $compinit =
 287     "typedef struct { UV nextchar; UV composite; } $structname;\n\n";
 288
 289 foreach my $i (sort keys %CompList) {
 290     $compinit .= "$structname $i [] = {\n";
 291     $compinit .= join ",\n",
 292         map sprintf("\t{ %d, %d }", $_, $CompList{$i}{$_}),
 293             sort {$a <=> $b } keys %{ $CompList{$i} };
 294     $compinit .= ",\n{0,0}\n};\n\n"; # with sentinel
 295 }
 296
 297 my @tripletable = (
 298     {
 299         file => "unfcmb",
 300         name => "combin",
 301         type => "STDCHAR",
 302         hash => \%Combin,
 303         null =>  0,
 304     },
 305     {
 306         file => "unfcan",
 307         name => "canon",
 308         type => "char*",
 309         hash => \%Canon,
 310         null => "NULL",
 311     },
 312     {
 313         file => "unfcpt",
 314         name => "compat",
 315         type => "char*",
 316         hash => \%Compat,
 317         null => "NULL",
 318     },
 319     {
 320         file => "unfcmp",
 321         name => "compos",
 322         type => "$structname *",
 323         hash => \%Comp1st,
 324         null => "NULL",
 325         init => $compinit,
 326     },
 327 );
 328
 329 foreach my $tbl (@tripletable) {
 330     my $file = "$tbl->{file}.h";
 331     my $head = "${prefix}$tbl->{name}";
 332     my $type = $tbl->{type};
 333     my $hash = $tbl->{hash};
 334     my $null = $tbl->{null};
 335     my $init = $tbl->{init};
 336
 337     open FH, ">$file" or croak "$PACKAGE: $file can't be made";
 338     binmode FH; select FH;
 339     my %val;
 340
 341     print FH << 'EOF';
 342 /*
 343  * This file is auto-generated by mkheader.
 344  * Any changes here will be lost!
 345  */
 346 EOF
 347
 348     print $init if defined $init;
 349
 350     foreach my $uv (keys %$hash) {
 351         croak sprintf("a Unicode code point 0x%04X over 0x10FFFF.", $uv)
 352             unless $uv <= 0x10FFFF;
 353         my @c = unpack 'CCCC', pack 'N', $uv;
 354         $val{ $c[1] }{ $c[2] }{ $c[3] } = $hash->{$uv};
 355     }
 356
 357     foreach my $p (sort { $a <=> $b } keys %val) {
 358         next if ! $val{ $p };
 359         for (my $r = 0; $r < 256; $r++) {
 360             next if ! $val{ $p }{ $r };
 361             printf "$type ${head}_%02x_%02x [256] = {\n", $p, $r;
 362             for (my $c = 0; $c < 256; $c++) {
 363                 print "\t", defined $val{$p}{$r}{$c}
 364                     ? "($type)".$val{$p}{$r}{$c}
 365                     : $null;
 366                 print ','  if $c != 255;
 367                 print "\n" if $c % 8 == 7;
 368             }
 369             print "};\n\n";
 370         }
 371     }
 372     foreach my $p (sort { $a <=> $b } keys %val) {
 373         next if ! $val{ $p };
 374         printf "$type* ${head}_%02x [256] = {\n", $p;
 375         for (my $r = 0; $r < 256; $r++) {
 376             print $val{ $p }{ $r }
 377                 ? sprintf("${head}_%02x_%02x", $p, $r)
 378                 : "NULL";
 379             print ','  if $r != 255;
 380             print "\n" if $val{ $p }{ $r } || ($r+1) % 8 == 0;
 381         }
 382         print "};\n\n";
 383     }
 384     print "$type** $head [] = {\n";
 385     for (my $p = 0; $p <= 0x10; $p++) {
 386         print $val{ $p } ? sprintf("${head}_%02x", $p) : "NULL";
 387         print ','  if $p != 0x10;
 388         print "\n";
 389     }
 390     print "};\n\n";
 391     close FH;
 392 }
 393
 394 __END__