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