#!/usr/bin/perl

#	perl/encoding.pl </usr/lib/tcl8.3/encoding/cp850.enc 
#	for x in /usr/lib/tcl8.3/encoding/*; do perl/encoding.pl <$x; done >encodings
#
# read a Tcl encoding file (see man Tcl_GetEncoding)
#	spit out a perl translator

$enc = 'unknown';
$_ = <STDIN>;
if ( /^#/ ) {
	($enc) = /: ([^,]+),/;
	$_ = <STDIN>;
}
/^S/ || die "not a single byte encoding: got '$_'";
$_ = <STDIN>;
($fallback,$symbol,$pages) = split /\s+/;
1 == $pages || die "not a single byte encoding: got $fallback,$symbol,$pages";
$fallback = hex $fallback;
$fbchr = 31<$fallback && $fallback<127
	? chr($fallback) : sprintf('\x%02x', $fallback);
print STDERR "fallback character is $fallback ($fbchr)\n";

# read page
$_ = <STDIN>;
hex && die "base is not 00 but '$_'";
for $n (0..7) { # check for ASCII
	@v = unpack( 'n*', pack( 'H64', scalar(<STDIN>) ) );
	15 == $#v || die "length is ".$#v;
	# print STDERR join(',',@v), "\n";
	for (0..15) {
		$v[$_] == 16*$n + $_ || die "bad val $v[$_] at row $n pos $_";
	}
}
$#rv = 127;
for (0..127) { $rv[$_] = $fbchr; }
for $n (8..15) {
	@v = unpack( 'n*', pack( 'H64', scalar(<STDIN>) ) );
	15 == $#v || die "length is ".$#v;
	print STDERR join(',',@v), "\n";
	for (0..15) {
		if ( 255 < $v[$_] ) {
			$tr .= '?';
		} else {
			$tr .= sprintf('\x%02x',$v[$_]);
			$rv[$v[$_]-128] = sprintf('\x%02x',16*$n + $_) if 127 < $v[$_];
		}
	}
}
print "# convert $enc to Latin1\n";
print 'y/\x80-\xff/',$tr,"/;\n";
$rv = join('',@rv);
print "# convert Latin1 to $enc\n";
print 'y/\x80-\xff/',$rv,"/;\n";

# Latin1 roundtrip test
$_ = $test = pack( 'C*', (160..255) );
eval 'y/\x80-\xff/'.$rv.'/';
print STDERR "Latin1 160..255 in encoding $enc\n";
for $n (0..5) {
	print STDERR 160+16*$n,': ',join(',',unpack('C*',substr($_,16*$n,16))), "\n";
}
print STDERR 'test: ',$test,"\n";
eval 'y/\x80-\xff/'.$tr.'/';
print STDERR "trip: ",$_,"\n";
print STDERR "Latin1 160..255 after roundtrip through $enc\n";
for $n (0..5) {
	print STDERR 160+16*$n,': ',join(',',unpack('C*',substr($_,16*$n,16))), "\n";
}
