breakttc を Perl で書いてみた

TTC ファイルを分割するためには BREAKTTC.EXE という Microsoft 製のソフトウェアがあるのですが，今は公開されてないようですし，いちいち Windows を立ち上げるのも面倒です。TTC の構造については仕様が公開されているので Perl で書いてみました。

non seekable なストリームから読み込みできるようにするために汚いコードになってしまってます。

分割するだけなら楽なんですよね。結合するのは，各テーブルの内容を比較しないといけないので面倒。まして non seekable stream だと事実上無理じゃないかなぁ。

#!/usr/bin/perl

use strict;
use warnings;
use Getopt::Long;
use POSIX qw( ceil );
use File::Spec::Functions qw( :ALL );

my %OPTION;
GetOptions(
'help|h|?' => \$OPTION{help},
'verbose|v' => \$OPTION{verbose},
'quiet|q' => \$OPTION{quiet},
'template|t' => \$OPTION{template},
'index|i' => \$OPTION{index},
) or die 'Bad options';

if (! $OPTION{template}) {
if (@ARGV) {
my (undef, undef, $filename) = splitpath($ARGV[0]);
$filename =~ s{ [.] .*? \z }{}xmso;
$OPTION{template} = "${filename}_%02d.ttf";
}
else {
$OPTION{template} = 'font_%02d.ttf';
}
}

my $handle;
if (@ARGV) {
open $handle, '<', $ARGV[0]
or die $!;
binmode $handle;
}
else {
$handle = \*STDIN;
}
binmode $handle;

my $ttc_header = read_ttc_header($handle);
my $numFonts = $ttc_header->{numFonts};

my $src_headers = [];
for my $i (0 .. $numFonts - 1) {
my $offset = tell $handle;
my $table_offset = $ttc_header->{OffsetTable}->[$i];

# seek $handle, $table_offset - $offset, 1 or die $!;
skip_handle($handle, $table_offset - $offset);

$src_headers->[$i] = read_header($handle);
}

my $tables = merge_tables($src_headers);

my $dst_headers = [];
for my $i (0 .. $numFonts - 1) {
$dst_headers->[$i] = trans_header($src_headers->[$i]);
}

my $dst_handles = [];
for my $i (0 .. $numFonts - 1) {
my $filename = sprintf $OPTION{template}, $i + 1;

open my $h, '>', $filename
or die "open: $!";
binmode $h;

$dst_handles->[$i] = $h;

write_header($dst_handles->[$i], $dst_headers->[$i]);
}

copy_bodies_for_fonts($dst_handles, $handle, $tables);

for my $i (0 .. $numFonts - 1) {
close $dst_handles->[$i];
}

close $handle;

exit;

sub read_ttc_header {
my ($src) = @_;
my $header = {};
my $buf;

read $src, $buf, 4
or die "read: $!";
$header->{TTCTag} = $buf;

die "not TTC file"
unless $header->{TTCTag} eq 'ttcf';

read $src, $buf, 4
or die "read: $!";
($header->{versionLow},
$header->{versionHigh})
= unpack 'nn', $buf;
$header->{Version} = $header->{versionLow} . '.' . $header->{versionHigh};

die "unknown version: " . $header->{Version}
if $header->{Version} != 1.0
&& $header->{Version} != 2.0;

print {*STDERR} "TTC Version: ", $header->{Version}, "\n"
if $OPTION{verbose};

read $src, $buf, 4
or die "read: $!";
$header->{numFonts} = unpack 'N', $buf;

print {*STDERR} "TTC numFonts: ", $header->{numFonts}, "\n"
if $OPTION{verbose};

for my $i (0 .. $header->{numFonts} - 1) {
read $src, $buf, 4
or die "read: $!";
$header->{OffsetTable}->[$i] = unpack 'N', $buf;
}

$header->{OffsetTable} = [ sort @{ $header->{OffsetTable} } ];

if ($header->{Version} >= 2.0) {
read $src, $buf, 4+4+4
or die "read: $!";
}

return $header;
}

sub read_header {
my ($src) = @_;
my $header = {};
my $buf;

read $src, $buf, 4 or die $!;
$header->{version} = $buf;

read $src, $buf, 2+2+2+2 or die $!;
($header->{numTables},
$header->{searchRange},
$header->{entrySelector},
$header->{rangeShift})
= unpack 'nnnn', $buf;

my $numTables = $header->{numTables};

$header->{table} = {};
$header->{tags} = [];

while ($numTables -- > 0) {
read $src, $buf, 4+4+4+4 or die $!;
my $tag = substr $buf, 0, 4, '';
my ($checkSum, $offset, $length)
= unpack 'NNN', $buf;

$header->{table}->{$tag}
= {
tag => $tag,
checkSum => $checkSum,
offset => $offset,
length => $length,
};

push @{ $header->{tags} }, $tag;
}

return $header;
}

sub trans_header {
my $header = clone_header($_[0]);

$header->{entrySelector}
= ceil(log $header->{numTables} / log 2);

$header->{searchRange}
= (1 << $header->{entrySelector}) * 16;

$header->{rangeShift}
= $header->{numTables} * 16
- $header->{searchRange};

$header->{tags}
= [
sort {
$header->{table}->{$a}->{offset}
<=>
$header->{table}->{$b}->{offset}
}
@{ $header->{tags} }
];

my $length
= 4+2+2+2+2 + (4+4+4+4) * $header->{numTables};
$header->{length} = ceil($length / 4) * 4;
$header->{trail} = $header->{length} - $length;

my $offset = $header->{length};
foreach my $tag (@{ $header->{tags} }) {
my $table = $header->{table}->{$tag};

$table->{offset} = $offset;

$offset += $table->{length};
$offset += 3 - ($offset + 3) % 4;
}

return $header;
}

sub clone_header {
my ($src) = @_;
# use Storable qw( dclone );
# return dclone($_[0]);

my $dst = { %$src };

$dst->{tags} = [ @{ $src->{tags} } ];

$dst->{table} = {};
while (my ($tag, $table) = each %{ $src->{table} }) {
$dst->{table}->{$tag} = { %$table };
}

return $dst;
}

sub write_header {
my ($dst, $header) = @_;

print {$dst} $header->{version};

print {$dst}
pack 'nnnn', $header->{numTables},
$header->{searchRange},
$header->{entrySelector},
$header->{rangeShift};

foreach my $tag (@{ $header->{tags} }) {
my $table = $header->{table}->{$tag};

print {$dst} $tag;
print {$dst}
pack 'NNN', $table->{checkSum},
$table->{offset},
$table->{length};
}

print {$dst} "\x00" x $header->{trail};
}

sub merge_tables {
my ($headers) = @_;

my $table_by_ofs = {};
my $i = 0;
foreach my $header (@$headers) {
foreach my $tag (@{ $header->{tags} }) {
my $table = $header->{table}->{$tag};
$table_by_ofs->{$table->{offset}}->{table} = $table;
push @{ $table_by_ofs->{$table->{offset}}->{id} }, $i;
}
$i ++;
}

my @tables = map {
{
%{ $table_by_ofs->{$_}->{table} },
id => $table_by_ofs->{$_}->{id},
}
}
sort { $a <=> $b }
keys %$table_by_ofs;

return \@tables;
}

sub copy_bodies_for_fonts {
my ($dst_handles, $src_handle, $tables) = @_;

my $offset = tell $src_handle;

foreach my $table (@$tables) {
# seek $src_handle, $table->{offset} - $offset, 1 or die $!;
skip_handle($src_handle, $table->{offset} - $offset);
$offset = $table->{offset};

my $data = read_handle($src_handle, $table->{length});
$offset += $table->{length};

my $trail = 3 - ($table->{length} + 3) % 4;
$trail = "\x00" x $trail;

foreach my $i (@{ $table->{id} }) {
my $dst_handle = $dst_handles->[$i];

print {$dst_handle} $data, $trail;
}
}
}

sub skip_handle {
my ($src, $length) = @_;
my $buf;
my $unit = 4096;

die "cannot seek backward: $length"
if $length < 0;

while ($length > 0) {
$unit = $length if $length < $unit;

read $src, $buf, $unit or die $!;

$length -= $unit;
}
}

sub read_handle {
my ($src, $length) = @_;
my $data;
my $buf;
my $unit = 4096;

while ($length > 0) {
$unit = $length if $length < $unit;

read $src, $buf, $unit or die $!;
$data .= $buf;

$length -= $unit;
}

return $data;
}