[p5sagit/p5-mst-13.2.git] / ext / Unicode / Normalize / mkheader

#!perl
#
# This script generates "unfcan.h", "unfcpt.h", "unfcmb.h",
# "unfcmp.h", and "unfexc.h" 
# from CombiningClass.pl, Decomposition.pl, CompExcl.txt
# in lib/unicore or unicode directory
# for Unicode::Normalize.xs. (cf. Makefile.PL)
#
use 5.006;
use strict;
use warnings;
use Carp;

our $PACKAGE = 'Unicode::Normalize, mkheader';

our $Combin = do "unicore/CombiningClass.pl"
    || do "unicode/CombiningClass.pl"
    || croak "$PACKAGE: CombiningClass.pl not found";

our $Decomp = do "unicore/Decomposition.pl"
    || do "unicode/Decomposition.pl"
    || croak "$PACKAGE: Decomposition.pl not found";

our %Combin; # $codepoint => $number      : combination class
our %Canon;  # $codepoint => $hexstring   : canonical decomp.
our %Compat; # $codepoint => $hexstring   : compat. decomp.
our %Compos; # $string    => $codepoint   : composite
our %Exclus; # $codepoint => 1            : composition exclusions
our %Single; # $codepoint => 1            : singletons
our %NonStD; # $codepoint => 1            : non-starter decompositions

{
    my($f, $fh);
    foreach my $d (@INC) {
	use File::Spec;
	$f = File::Spec->catfile($d, "unicore", "CompositionExclusions.txt");
	last if open($fh, $f);
	$f = File::Spec->catfile($d, "unicode", "CompExcl.txt");
	last if open($fh, $f);
	$f = undef;
    }
	croak "$PACKAGE: CompExcl.txt not found in @INC" unless defined $f;
	while (<$fh>) {
	    next if /^#/ or /^$/;
	    s/#.*//;
	    $Exclus{ hex($1) } =1 if /([0-9A-Fa-f]+)/;
	}
    close $fh;
}

while ($Combin =~ /(.+)/g) {
    my @tab = split /\t/, $1;
    my $ini = hex $tab[0];
    if ($tab[1] eq '') {
	$Combin{ $ini } = $tab[2];
    } else {
	$Combin{ $_ } = $tab[2] foreach $ini .. hex($tab[1]);
    }
}

while ($Decomp =~ /(.+)/g) {
    my @tab = split /\t/, $1;
    my $compat = $tab[2] =~ s/<[^>]+>//;
    my $dec = [ _getHexArray($tab[2]) ]; # decomposition
    my $com = pack('U*', @$dec); # composable sequence
    my $ini = hex($tab[0]); # initial decomposable character
    if ($tab[1] eq '') {
	$Compat{ $ini } = $dec;

	if (! $compat) {
	    $Canon{  $ini } = $dec;

	    if (@$dec > 1) {
		if ($Combin{ $dec->[0] }) {
		    $NonStD{ $ini } = 1;
		} else {
		    $Compos{ $com } = $ini;
		}
	    } else {
		$Single{ $ini } = 1;
	    }
	}
    } else {
	foreach my $u ($ini .. hex($tab[1])){
	    $Compat{ $u } = $dec;
	    if (! $compat) {
		$Canon{  $u }   = $dec;

		if (@$dec > 1) {
		    if ($Combin{ $dec->[0] }) {
			$NonStD{ $u } = 1;
		    } else {
			$Compos{ $com } = $u;
		    }
		} else {
		    $Single{ $u } = 1;
		}
	    }
	}
    }
}

# exhaustive decomposition
foreach my $key (keys %Canon) {
    $Canon{$key}  = [ getCanonList($key) ];
}

# exhaustive decomposition
foreach my $key (keys %Compat) { 
    $Compat{$key} = [ getCompatList($key) ];
}

sub getCanonList {
    my @src = @_;
    my @dec = map $Canon{$_} ? @{ $Canon{$_} } : $_, @src;
    return join(" ",@src) eq join(" ",@dec) ? @dec : getCanonList(@dec);
    # condition @src == @dec is not ok.
}

sub getCompatList {
    my @src = @_;
    my @dec = map $Compat{$_} ? @{ $Compat{$_} } : $_, @src;
    return join(" ",@src) eq join(" ",@dec) ? @dec : getCompatList(@dec);
    # condition @src == @dec is not ok.
}

sub _getHexArray { map hex, $_[0] =~ /([0-9A-Fa-f]+)/g }

sub _U_stringify {
    sprintf '"%s"', join '',
	map sprintf("\\x%02x", $_), unpack 'C*', pack 'U*', @_;
}

foreach my $hash (\%Canon, \%Compat) {
    foreach my $key (keys %$hash) {
	$hash->{$key} = _U_stringify( @{ $hash->{$key} } );
    }
}

my $prefix = "UNF_";
my $structname = "${prefix}complist";

our (%Comp1st, %Comp2nd, %CompList);

foreach (sort keys %Compos) {
    my @a = unpack('U*', $_);
    my $val = $Compos{$_};
    my $name = sprintf "${structname}_%06x", $a[0];
    $Comp1st{$a[0]} = $name;
    $Comp2nd{$a[1]} = 1 if ! $Exclus{$Compos{$_}} && ! $Combin{$a[0]};
    $CompList{$name}{$a[1]} = $val;
}

# modern HANGUL JUNGSEONG and HANGUL JONGSEONG jamo
foreach (0x1161..0x1175, 0x11A8..0x11C2) {
    $Comp2nd{$_} = 1;
}

my $compinit =
    "typedef struct { UV nextchar; UV composite; } $structname;\n\n";

foreach my $i (sort keys %CompList) {
    $compinit .= "$structname $i [] = {\n";
    $compinit .= join ",\n",
	map sprintf("\t{ %d, %d }", $_, $CompList{$i}{$_}),
	    sort {$a <=> $b } keys %{ $CompList{$i} };
    $compinit .= ",\n{0,0}\n};\n\n"; # with sentinel
}

####################################

my @boolfunc = (
    {
	name => "Exclusion",
	type => "bool",
	hash => \%Exclus,
    },
    {
	name => "Singleton",
	type => "bool",
	hash => \%Single,
    },
    {
	name => "NonStDecomp",
	type => "bool",
	hash => \%NonStD,
    },
    {
	name => "Comp2nd",
	type => "bool",
	hash => \%Comp2nd,
    },
);

my $file = "unfexc.h";
open FH, ">$file" or croak "$PACKAGE: $file can't be made";
binmode FH; select FH;

    print << 'EOF';
/*
 * This file is auto-generated by mkheader.
 * Any changes here will be lost!
 */
EOF

foreach my $tbl (@boolfunc) {
    my @temp = sort {$a <=> $b} keys %{$tbl->{hash}};
    my $type = $tbl->{type};
    my $name = $tbl->{name};
    print "$type is$name (UV uv)\n{\nreturn\n\t";

    while (@temp) {
	my $cur = shift @temp;
	if (@temp && $cur + 1 == $temp[0]) {
	    print "($cur <= uv && uv <= ";
	    while (@temp && $cur + 1 == $temp[0]) {
		$cur = shift @temp;
	    }
	    print "$cur)";
	    print "\n\t|| " if @temp;
	} else {
	    print "uv == $cur";
	    print "\n\t|| " if @temp;
	}
    }
    print "\n\t? TRUE : FALSE;\n}\n\n";
}

close FH;


####################################

my @tripletable = (
    {
	file => "unfcmb",
	name => "combin",
	type => "STDCHAR",
	hash => \%Combin,
	null =>  0,
    },
    {
	file => "unfcan",
	name => "canon",
	type => "char*",
	hash => \%Canon,
	null => "NULL",
    },
    {
	file => "unfcpt",
	name => "compat",
	type => "char*",
	hash => \%Compat,
	null => "NULL",
    },
    {
	file => "unfcmp",
	name => "compos",
	type => "$structname *",
	hash => \%Comp1st,
	null => "NULL",
	init => $compinit,
    },
);

foreach my $tbl (@tripletable) {
    my $file = "$tbl->{file}.h";
    my $head = "${prefix}$tbl->{name}";
    my $type = $tbl->{type};
    my $hash = $tbl->{hash};
    my $null = $tbl->{null};
    my $init = $tbl->{init};

    open FH, ">$file" or croak "$PACKAGE: $file can't be made";
    binmode FH; select FH;
    my %val;

    print FH << 'EOF';
/*
 * This file is auto-generated by mkheader.
 * Any changes here will be lost!
 */
EOF

    print $init if defined $init;

    foreach my $uv (keys %$hash) {
	my @c = unpack 'CCCC', pack 'N', $uv;
	$val{ $c[1] }{ $c[2] }{ $c[3] } = $hash->{$uv};
    }

    foreach my $p (sort { $a <=> $b } keys %val) {
	next if ! $val{ $p };
	for (my $r = 0; $r < 256; $r++) {
	    next if ! $val{ $p }{ $r };
	    printf "$type ${head}_%02x_%02x [256] = {\n", $p, $r;
	    for (my $c = 0; $c < 256; $c++) {
		print "\t", defined $val{$p}{$r}{$c}
		    ? "($type)".$val{$p}{$r}{$c}
		    : $null;
		print ','  if $c != 255;
		print "\n" if $c % 8 == 7;
	    }
	    print "};\n\n";
	}
    }
    foreach my $p (sort { $a <=> $b } keys %val) {
	next if ! $val{ $p };
	printf "$type* ${head}_%02x [256] = {\n", $p;
	for (my $r = 0; $r < 256; $r++) {
	    print $val{ $p }{ $r }
		? sprintf("${head}_%02x_%02x", $p, $r)
		: "NULL";
	    print ','  if $r != 255;
	    print "\n" if $val{ $p }{ $r } || ($r+1) % 8 == 0;
	}
	print "};\n\n";
    }
    print "$type** $head [] = {\n";
    for (my $p = 0; $p <= 0x10; $p++) {
	print $val{ $p } ? sprintf("${head}_%02x", $p) : "NULL";
	print ','  if $p != 0x10;
	print "\n";
    }
    print "};\n\n";
    close FH;
}

__END__
Commit	Line	Data
ac5ea531	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, CompExcl.txt
	6	# in lib/unicore or unicode directory
	7	# for Unicode::Normalize.xs. (cf. Makefile.PL)
	8	#
	9	use 5.006;
	10	use strict;
	11	use warnings;
	12	use Carp;
	13
	14	our $PACKAGE = 'Unicode::Normalize, mkheader';
	15
	16	our $Combin = do "unicore/CombiningClass.pl"
d6b7ef86	17	\|\| do "unicode/CombiningClass.pl"
d6b7ef86	18	\|\| croak "$PACKAGE: CombiningClass.pl not found";
ac5ea531	19
ac5ea531	20	our $Decomp = do "unicore/Decomposition.pl"
d6b7ef86	21	\|\| do "unicode/Decomposition.pl"
d6b7ef86	22	\|\| croak "$PACKAGE: Decomposition.pl not found";
ac5ea531	23
	24	our %Combin; # $codepoint => $number : combination class
	25	our %Canon; # $codepoint => $hexstring : canonical decomp.
	26	our %Compat; # $codepoint => $hexstring : compat. decomp.
	27	our %Compos; # $string => $codepoint : composite
ac5ea531	28	our %Exclus; # $codepoint => 1 : composition exclusions
d6b7ef86	29	our %Single; # $codepoint => 1 : singletons
d6b7ef86	30	our %NonStD; # $codepoint => 1 : non-starter decompositions
ac5ea531	31
ac5ea531	32	{
d6b7ef86	33	my($f, $fh);
	34	foreach my $d (@INC) {
	35	use File::Spec;
	36	$f = File::Spec->catfile($d, "unicore", "CompositionExclusions.txt");
	37	last if open($fh, $f);
	38	$f = File::Spec->catfile($d, "unicode", "CompExcl.txt");
	39	last if open($fh, $f);
	40	$f = undef;
	41	}
	42	croak "$PACKAGE: CompExcl.txt not found in @INC" unless defined $f;
	43	while (<$fh>) {
	44	next if /^#/ or /^$/;
	45	s/#.*//;
	46	$Exclus{ hex($1) } =1 if /([0-9A-Fa-f]+)/;
	47	}
	48	close $fh;
ac5ea531	49	}
ac5ea531	50
d6b7ef86	51	while ($Combin =~ /(.+)/g) {
	52	my @tab = split /\t/, $1;
	53	my $ini = hex $tab[0];
	54	if ($tab[1] eq '') {
	55	$Combin{ $ini } = $tab[2];
	56	} else {
	57	$Combin{ $_ } = $tab[2] foreach $ini .. hex($tab[1]);
	58	}
ac5ea531	59	}
ac5ea531	60
d6b7ef86	61	while ($Decomp =~ /(.+)/g) {
	62	my @tab = split /\t/, $1;
	63	my $compat = $tab[2] =~ s/<[^>]+>//;
	64	my $dec = [ _getHexArray($tab[2]) ]; # decomposition
	65	my $com = pack('U*', @$dec); # composable sequence
	66	my $ini = hex($tab[0]); # initial decomposable character
	67	if ($tab[1] eq '') {
	68	$Compat{ $ini } = $dec;
	69
	70	if (! $compat) {
	71	$Canon{ $ini } = $dec;
	72
	73	if (@$dec > 1) {
	74	if ($Combin{ $dec->[0] }) {
	75	$NonStD{ $ini } = 1;
	76	} else {
	77	$Compos{ $com } = $ini;
	78	}
	79	} else {
	80	$Single{ $ini } = 1;
	81	}
	82	}
	83	} else {
	84	foreach my $u ($ini .. hex($tab[1])){
	85	$Compat{ $u } = $dec;
	86	if (! $compat) {
	87	$Canon{ $u } = $dec;
	88
	89	if (@$dec > 1) {
	90	if ($Combin{ $dec->[0] }) {
	91	$NonStD{ $u } = 1;
	92	} else {
	93	$Compos{ $com } = $u;
	94	}
	95	} else {
	96	$Single{ $u } = 1;
	97	}
	98	}
	99	}
ac5ea531	100	}
ac5ea531	101	}
	102
	103	# exhaustive decomposition
	104	foreach my $key (keys %Canon) {
d6b7ef86	105	$Canon{$key} = [ getCanonList($key) ];
ac5ea531	106	}
	107
	108	# exhaustive decomposition
	109	foreach my $key (keys %Compat) {
d6b7ef86	110	$Compat{$key} = [ getCompatList($key) ];
ac5ea531	111	}
	112
	113	sub getCanonList {
d6b7ef86	114	my @src = @_;
	115	my @dec = map $Canon{$_} ? @{ $Canon{$_} } : $_, @src;
	116	return join(" ",@src) eq join(" ",@dec) ? @dec : getCanonList(@dec);
	117	# condition @src == @dec is not ok.
ac5ea531	118	}
	119
	120	sub getCompatList {
d6b7ef86	121	my @src = @_;
	122	my @dec = map $Compat{$_} ? @{ $Compat{$_} } : $_, @src;
	123	return join(" ",@src) eq join(" ",@dec) ? @dec : getCompatList(@dec);
	124	# condition @src == @dec is not ok.
ac5ea531	125	}
ac5ea531	126
d6b7ef86	127	sub _getHexArray { map hex, $_[0] =~ /([0-9A-Fa-f]+)/g }
ac5ea531	128
ac5ea531	129	sub _U_stringify {
d6b7ef86	130	sprintf '"%s"', join '',
d6b7ef86	131	map sprintf("\\x%02x", $_), unpack 'C', pack 'U', @_;
ac5ea531	132	}
	133
	134	foreach my $hash (\%Canon, \%Compat) {
d6b7ef86	135	foreach my $key (keys %$hash) {
	136	$hash->{$key} = _U_stringify( @{ $hash->{$key} } );
	137	}
ac5ea531	138	}
ac5ea531	139
ac5ea531	140	my $prefix = "UNF_";
ac5ea531	141	my $structname = "${prefix}complist";
ac5ea531	142
d6b7ef86	143	our (%Comp1st, %Comp2nd, %CompList);
ac5ea531	144
d6b7ef86	145	foreach (sort keys %Compos) {
	146	my @a = unpack('U*', $_);
	147	my $val = $Compos{$_};
	148	my $name = sprintf "${structname}_%06x", $a[0];
	149	$Comp1st{$a[0]} = $name;
	150	$Comp2nd{$a[1]} = 1 if ! $Exclus{$Compos{$_}} && ! $Combin{$a[0]};
	151	$CompList{$name}{$a[1]} = $val;
	152	}
	153
	154	# modern HANGUL JUNGSEONG and HANGUL JONGSEONG jamo
	155	foreach (0x1161..0x1175, 0x11A8..0x11C2) {
	156	$Comp2nd{$_} = 1;
ac5ea531	157	}
	158
	159	my $compinit =
d6b7ef86	160	"typedef struct { UV nextchar; UV composite; } $structname;\n\n";
ac5ea531	161
ac5ea531	162	foreach my $i (sort keys %CompList) {
d6b7ef86	163	$compinit .= "$structname $i [] = {\n";
	164	$compinit .= join ",\n",
	165	map sprintf("\t{ %d, %d }", $_, $CompList{$i}{$_}),
	166	sort {$a <=> $b } keys %{ $CompList{$i} };
	167	$compinit .= ",\n{0,0}\n};\n\n"; # with sentinel
ac5ea531	168	}
	169
	170	####################################
	171
d6b7ef86	172	my @boolfunc = (
	173	{
	174	name => "Exclusion",
	175	type => "bool",
	176	hash => \%Exclus,
	177	},
	178	{
	179	name => "Singleton",
	180	type => "bool",
	181	hash => \%Single,
	182	},
	183	{
	184	name => "NonStDecomp",
	185	type => "bool",
	186	hash => \%NonStD,
	187	},
	188	{
	189	name => "Comp2nd",
	190	type => "bool",
	191	hash => \%Comp2nd,
	192	},
	193	);
ac5ea531	194
	195	my $file = "unfexc.h";
	196	open FH, ">$file" or croak "$PACKAGE: $file can't be made";
	197	binmode FH; select FH;
	198
d6b7ef86	199	print << 'EOF';
	200	/*
	201	* This file is auto-generated by mkheader.
	202	* Any changes here will be lost!
	203	*/
	204	EOF
ac5ea531	205
d6b7ef86	206	foreach my $tbl (@boolfunc) {
	207	my @temp = sort {$a <=> $b} keys %{$tbl->{hash}};
	208	my $type = $tbl->{type};
	209	my $name = $tbl->{name};
	210	print "$type is$name (UV uv)\n{\nreturn\n\t";
	211
	212	while (@temp) {
	213	my $cur = shift @temp;
	214	if (@temp && $cur + 1 == $temp[0]) {
	215	print "($cur <= uv && uv <= ";
	216	while (@temp && $cur + 1 == $temp[0]) {
	217	$cur = shift @temp;
	218	}
	219	print "$cur)";
	220	print "\n\t\|\| " if @temp;
	221	} else {
	222	print "uv == $cur";
	223	print "\n\t\|\| " if @temp;
	224	}
ac5ea531	225	}
d6b7ef86	226	print "\n\t? TRUE : FALSE;\n}\n\n";
ac5ea531	227	}
ac5ea531	228
ac5ea531	229	close FH;
ac5ea531	230
d6b7ef86	231
ac5ea531	232	####################################
	233
	234	my @tripletable = (
d6b7ef86	235	{
	236	file => "unfcmb",
	237	name => "combin",
	238	type => "STDCHAR",
	239	hash => \%Combin,
	240	null => 0,
	241	},
	242	{
	243	file => "unfcan",
	244	name => "canon",
	245	type => "char*",
	246	hash => \%Canon,
	247	null => "NULL",
	248	},
	249	{
	250	file => "unfcpt",
	251	name => "compat",
	252	type => "char*",
	253	hash => \%Compat,
	254	null => "NULL",
	255	},
	256	{
	257	file => "unfcmp",
	258	name => "compos",
	259	type => "$structname *",
	260	hash => \%Comp1st,
	261	null => "NULL",
	262	init => $compinit,
	263	},
ac5ea531	264	);
	265
	266	foreach my $tbl (@tripletable) {
d6b7ef86	267	my $file = "$tbl->{file}.h";
	268	my $head = "${prefix}$tbl->{name}";
	269	my $type = $tbl->{type};
	270	my $hash = $tbl->{hash};
	271	my $null = $tbl->{null};
	272	my $init = $tbl->{init};
	273
	274	open FH, ">$file" or croak "$PACKAGE: $file can't be made";
	275	binmode FH; select FH;
	276	my %val;
	277
	278	print FH << 'EOF';
ac5ea531	279	/*
	280	* This file is auto-generated by mkheader.
	281	* Any changes here will be lost!
	282	*/
	283	EOF
	284
d6b7ef86	285	print $init if defined $init;
	286
	287	foreach my $uv (keys %$hash) {
	288	my @c = unpack 'CCCC', pack 'N', $uv;
	289	$val{ $c[1] }{ $c[2] }{ $c[3] } = $hash->{$uv};
	290	}
	291
	292	foreach my $p (sort { $a <=> $b } keys %val) {
	293	next if ! $val{ $p };
	294	for (my $r = 0; $r < 256; $r++) {
	295	next if ! $val{ $p }{ $r };
	296	printf "$type ${head}_%02x_%02x [256] = {\n", $p, $r;
	297	for (my $c = 0; $c < 256; $c++) {
	298	print "\t", defined $val{$p}{$r}{$c}
	299	? "($type)".$val{$p}{$r}{$c}
	300	: $null;
	301	print ',' if $c != 255;
	302	print "\n" if $c % 8 == 7;
	303	}
	304	print "};\n\n";
	305	}
	306	}
	307	foreach my $p (sort { $a <=> $b } keys %val) {
	308	next if ! $val{ $p };
	309	printf "$type* ${head}_%02x [256] = {\n", $p;
	310	for (my $r = 0; $r < 256; $r++) {
	311	print $val{ $p }{ $r }
	312	? sprintf("${head}_%02x_%02x", $p, $r)
	313	: "NULL";
	314	print ',' if $r != 255;
	315	print "\n" if $val{ $p }{ $r } \|\| ($r+1) % 8 == 0;
	316	}
	317	print "};\n\n";
ac5ea531	318	}
d6b7ef86	319	print "$type** $head [] = {\n";
	320	for (my $p = 0; $p <= 0x10; $p++) {
	321	print $val{ $p } ? sprintf("${head}_%02x", $p) : "NULL";
	322	print ',' if $p != 0x10;
	323	print "\n";
ac5ea531	324	}
ac5ea531	325	print "};\n\n";
d6b7ef86	326	close FH;
ac5ea531	327	}
	328
	329	__END__