#!/usr/bin/perl
getopts('hr:');
unless ($ARGV[0] || $opt_h)
{
pod2usage(1);
exit;
}
if ($opt_h)
{
pod2usage(-verbose => 2, -noperldoc => 1);
exit;
}
%parser = (
'Encoding' => sub {
my ($str, $currchar) = @_;
my (@vals) = split(' ', $str);
$currchar->{'gnum'} = $vals[2];
return undef;
});
$base = Font::TTF::Scripts::SFD->new(%parser);
$local = Font::TTF::Scripts::SFD->new(%parser);
$other = Font::TTF::Scripts::SFD->new(%parser);
$base->parse_file($ARGV[0], $base);
$local->parse_file($ARGV[1], $local);
$other->parse_file($ARGV[2], $other);
@basechars = order_glyphs($base->{'glyphs'});
@localchars = order_glyphs($local->{'glyphs'});
@otherchars = order_glyphs($other->{'glyphs'});
merge_items($base, $local, $other);
for ($i = 0; $i < @basechars; $i++)
{ merge_items($basechars[$i], $localchars[$i], $otherchars[$i]); }
$maxnum = scalar @basechars;
push(@basechars, @localchars[$maxnum .. $#localchars]);
push(@basechars, @otherchars[$maxnum .. $#otherchars]);
for ($i = 0; $i < @basechars; $i++)
{
$g = $basechars[$i];
$g->{'gnum'} = $i;
$g->{'lines'}[$g->{'commands'}{'Encoding'}[0]] =~ s/^(.*?)(\d+)/$1 . $i/oe;
}
$base->{'glyphs'} = \@basechars;
$ofh = IO::File->new("> $ARGV[3]") || die "Can't open $ARGV[3] for writing";
$base->print_font($base, $ofh);
$ofh->close();
sub add_char
{
my ($base, $char) = @_;
my ($newind) = scalar @{$base->{'glyphs'}};
push (@{$base->{'glyphs'}}, $char);
$char->{'lines'}[$char->{'commands'}{'Encoding'}[0]] =~ s/\s(\d+)$/ $newind/o;
}
sub merge_items
{
my ($base, $local, $other) = @_;
my ($c);
foreach $c (@{$base->{'commindex'}})
{
my ($cb) = $base->{'commands'}{$c->[0]}[$c->[1]];
my ($cl) = $local && $local->{'commands'}{$c->[0]}[$c->[1]];
my ($co) = $other && $other->{'commands'}{$c->[0]}[$c->[1]];
my ($lb) = $cb && $base->{'lines'}[$cb];
my ($ll) = $cl && $local->{'lines'}[$cl];
my ($lo) = $co && $other->{'lines'}[$co];
if ($lb eq $ll)
{ $base->{'lines'}[$cb] = $lo if ($lb ne $lo); }
elsif ($lb ne $lo)
{ $base->{'lines'}[$cb] = ($opt_r eq 'o' or !defined($ll)) ? $lo : (($opt_r eq 'l' and defined ($ll)) ? $ll : $lb); }
else
{ $base->{'lines'}[$cb] = $ll; }
}
if ($local)
{
foreach $c (@{$local->{'commindex'}})
{
next if (defined $base->{'commands'}{$c->[0]} && scalar @{$base->{'commands'}{$c->[0]}} > $c->[1]);
insert_line($base, $local, $other, $c, $cold);
}
continue { $cold = $c; }
}
if ($other)
{
foreach $c (@{$other->{'commindex'}})
{
next if (defined $base->{'commands'}{$c->[0]} && scalar @{$base->{'commands'}{$c->[0]}} > $c->[1]);
insert_line($base, $local, $other, $c, $cold);
}
continue { $cold = $c; }
}
}
sub insert_line
{
my ($base, $local, $other, $c, $cold) = @_;
my $cl = $local->{'commands'}{$c->[0]}[$c->[1]];
my $cb = $base->{'commands'}{$cold->[0]}[-1];
my $co = $other->{'commands'}{$c->[0]}[$c->[1]];
my $ll = $cl && $local->{'lines'}[$cl];
my $lo = $co && $other->{'lines'}[$co];
if ($ll ne $lo and defined ($lo))
{ $base->{'lines'}[$cb] .= $opt_r eq 'o' ? $lo : $ll; }
else
{ $base->{'lines'}[$cb] .= $ll; }
push (@{$base->{'commands'}{$c->[0]}}, $cb);
}
sub order_glyphs
{
my ($glyphs) = @_;
my (@res, $g);
my ($max) = scalar(@{$glyphs});
foreach $g (@{$glyphs})
{
if (defined $res[$g->{'gnum'}])
{ $res[$max++] = $g }
else
{ $res[$g->{'gnum'}] = $g; }
}
return @res
}
sub new
{
my ($class, %info) = @_;
my ($self) = {%info};
return bless $self, ref $class || $class;
}
sub parse_file
{
my ($self, $fname, $base) = @_;
my ($fh);
my ($command, $text);
my %modes = (
'TtTable' => 'EndTTInstrs',
'TtInstrs' => 'EndTTInstrs',
'Image' => 'EndImage',
'TtfInstrs' => 'EndTtf',
'ChainSub2' => 'EndFPST',
'ChainPos2' => 'EndFPST',
'ContextSub2' => 'EndFPST',
'ContextPos2' => 'EndFPST',
'ReverseChain2' => 'EndFPST',
'ShortTable' => 'EndShort',
'SplineSet' => 'EndSplineSet'
);
my %singles = map {$_ => 1 } qw(Fore Back);
if (ref $fname)
{ $fh = $fname; }
else
{ $fh = IO::File->new("< $fname") || die "Can't open $fname for reading"; }
while (<$fh>)
{
my ($res);
if ($_ =~ m/^[\s\d"]/o || $mode)
{
$text .= $_;
if ($_ =~ m/^$mode/)
{ $mode = ''; }
next;
}
elsif (defined $self->{$command})
{
my ($t) = $text;
$t =~ s/^\s*//o;
$res = &{$self->{$command}}($t, $base);
$base = $res if ($res);
}
if ($command)
{
my ($commstr) = $command;
if ($text =~ m/^\s*$/o || $command eq 'SplineSet')
{ }
elsif ($modes{$command})
{ $commstr .= ":"; }
elsif ($text =~ m/\n.+\n/o)
{ }
else
{ $commstr .= ":"; }
if ($command eq 'StartChar')
{
$text =~ s/\s*$//o;
$text =~ s/^\s*//o;
my $nbase = {'post' => $text, 'PSName' => $text, 'parent' => $base};
push (@{$base->{'glyphs'}}, $nbase);
$base = $nbase;
$text = " $text\n";
}
elsif ($command eq 'EndChars')
{
$base->{'final'} = {'base' => $base};
$base = $base->{'final'};
}
push (@{$base->{'lines'}}, "$commstr$text");
push (@{$base->{'commands'}{$command}}, scalar @{$base->{'lines'}} - 1);
push (@{$base->{'commindex'}}, [$command, scalar @{$base->{'commands'}{$command}} - 1]);
if ($command eq 'EndChar')
{ $base = $base->{'parent'} if defined ($base->{'parent'}); }
elsif ($command eq 'SplineSet')
{
my ($line) = pop(@{$base->{'lines'}});
$base->{'lines'}[-1] .= $line;
pop (@{$base->{'commindex'}});
pop (@{$base->{'commands'}{$command}});
}
$command = '';
$text = '';
}
if (s/^([^\s:]+)://o or $singles{$_})
{
$command = $1 || $_;
$text = $_ || "\n";
$mode = $modes{$command};
}
else
{
$command = $_;
$command =~ s/(\s*)$//o;
$mode = $modes{$command};
$text = $1;
}
}
if (defined $self->{$command})
{ &{$self->{$command}}($text); }
push (@{$base->{'lines'}}, "$command$text");
push (@{$base->{'commands'}{$command}}, scalar @{$base->{'lines'}});
}
sub print_font
{
my ($self, $font, $fh) = @_;
my ($g, $l);
foreach $l (@{$font->{'lines'}})
{ $fh->print($l); }
foreach $g (@{$font->{'glyphs'}})
{
foreach $l (@{$g->{'lines'}})
{ $fh->print($l); }
}
if (defined $font->{'final'})
{
foreach $l (@{$font->{'final'}{'lines'}})
{ $fh->print($l); }
}
}