#!/usr/bin/perl

use Font::TTF::Font;
use Font::TTF::Scripts::Name;
use Getopt::Std;
use IO::File;
use Pod::Usage;

use strict;
our $VERSION = 0.1;     #   

our $CHAIN_CALL;
our %opts;
our $f;

unless($CHAIN_CALL)
{
    pod2usage(-verbose => 1) unless (getopts('d:g:hl:n:s:', \%opts) && $#ARGV == 1) || $opts{'h'};
    pod2usage(-verbose => 2, -noperldoc => 1) if $opts{'h'};
    $f = Font::TTF::Font->open($ARGV[0]) || die "Can't open file '$ARGV[0]'";
}

if ($opts{'d'})
{
    # expand magic words.
    $opts{'d'} =~ s/\bgraphite\b/ Silf Feat Gloc Glat Sill Sile /oi; 
    $opts{'d'} =~ s/\bvolt\b/ TSIV TSID TSIP TSIS /oi;
    $opts{'d'} =~ s/\bopentype\b/ GDEF GSUB GPOS /oi;
    # Split generously (spaces, comma, colon, semicolon)
    foreach my $tag (grep {length($_) == 4} split(/[\s,:;]+/, $opts{'d'}))
    {
    	delete $f->{$tag} if exists $f->{$tag};
    }
}

my $cmap = $f->{'cmap'}->read->find_ms;
my $post = $f->{'post'}->read;
my $subsetter = Font::TTF::Scripts::SubSetter->new();
if ($opts{'g'})
{
    my ($fh) = IO::File->new($opts{'g'}, "r") || die "Can't open $opts{'g'} for reading";
    while (<$fh>)
    {
        foreach my $g (split)
        {
            my ($n, $u) = split(/=/, $g);
            if ($n =~ m/^U\+/oi)
            { $n = $cmap->{'val'}{hex($')}; }
            elsif ($n !~ m/^\d/o)
            { $n = $post->{'STRINGS'}{$n}; }
            if ($n)
            {
                $subsetter->add_glyph($n);
                if ($u)
                { $subsetter->remap(hex($u), $n); }
            }
        }
    }
    $fh->close();
}

if ($opts{'l'})
{ $subsetter->langlist(split(' ', $opts{'l'})); }

if ($opts{'s'})
{ $subsetter->scriptlist(split(' ', $opts{'s'})); }

my ($canchangegids) = 1;
my ($numg) = $f->{'maxp'}{'numGlyphs'};
$f->tables_do(sub {$canchangegids |= $_[0]->canchangegids();});
$numg = $subsetter->creategidmap($f) if ($canchangegids);

$f->{'loca'}->subset($subsetter);
$f->tables_do(sub {$_[0]->subset($subsetter);});
$f->{'maxp'}{'numGlyphs'} = $subsetter->{'gcount'};
$f->tables_do(sub {$_[0]->update;});
ttfname($f, "q" => 1, "n" => $opts{'n'}) if ($opts{'n'});
$f->out($ARGV[1]);

package Font::TTF::Scripts::SubSetter;

sub new
{
    my ($class) = @_;
    my ($self) = {};
    $self->{'glyphs'} = '';
    $self->{'remaps'} = {};
    bless $self, $class || ref $class;
    foreach (0..2) { $self->add_glyph($_); }
    return $self;
}

sub add_glyph
{
    my ($self, $n, $private) = @_;
    if (($private && !$self->{'gidmap'}[$n]) || (!$private && !vec($self->{'glyphs'}, $n, 1)))
    {
        vec($self->{'glyphs'}, $n, 1) = 1; # unless ($private);
        $self->{'gidmap'}[$n] = $self->{'gcount'}++ if (defined $self->{'gidmap'});
        return 1;
    }
    else
    { return 0; }
}

sub keep_glyph
{
    my ($self, $n) = @_;
    return vec($self->{'glyphs'}, $n, 1);
}

sub remap
{
    my ($self, $u, $n) = @_;
    $self->{'remaps'}{$u} = $n;
}

sub langlist
{
    my ($self, @dat) = @_;
    $self->{'langs'} = { map {$_=>1} @dat };
}

sub scriptlist
{
    my ($self, @dat) = @_;
    $self->{'scripts'} = { map {$_=>1} @dat };
}

sub creategidmap
{
    my ($self, $font) = @_;
    my ($numg) = $font->{'maxp'}{'numGlyphs'};
    my ($count) = 0;

    $self->{'gidmap'} = [];
    $self->{'gcount'} = 0;
    foreach my $i (0 .. $numg - 1)
    { push (@{$self->{'gidmap'}}, vec($self->{'glyphs'}, $i, 1) ? $self->{'gcount'}++ : 0); }
    return $self->{'gcount'};
}

sub map_glyph
{
    my ($self, $g) = @_;
    # no glyph remapping yet
    if ($self->{'gidmap'})
    { return $self->{'gidmap'}[$g]; }
    else
    { return $g; }
}

package Font::TTF::Table;

sub canchangegids
{ 1; }

sub subset
{
    my ($self, $subsetter) = @_;
    return 0 if ($self->{' subsetdone'});
    $self->{' subsetdone'} = 1;
    $self->read;
    $self->dirty;
    return 1;
}

package Font::TTF::Loca;

sub subset
{
    my ($self, $subsetter) = @_;
    my ($res) = [];
    my ($i, $vec);

    return unless ($self->SUPER::subset($subsetter));
    for ($i = 0; $i < @{$self->{'glyphs'}}; $i++)
    {
        if ($subsetter->keep_glyph($i))
        { $self->outglyph($subsetter, $res, $i); }
    }
    $self->{'glyphs'} = $res;
}

sub outglyph
{
    my ($self, $subsetter, $res, $n) = @_;

    $res->[$subsetter->map_glyph($n)] = $self->{'glyphs'}[$n];
    if (defined $self->{'glyphs'}[$n] && $self->{'glyphs'}[$n]->read()->{'numberOfContours'} < 0)
    {
        my ($g) = $self->{'glyphs'}[$n]->read_dat();
        foreach my $c (@{$g->{'comps'}})
        {
            if ($subsetter->add_glyph($c->{'glyph'}, 1))
            { $self->outglyph($subsetter, $res, $c->{'glyph'}); }
            $c->{'glyph'} = $subsetter->map_glyph($c->{'glyph'});
        }
        $g->{' isDirty'} = 1;
    }
}

package Font::TTF::Ttopen;

sub subset
{
    my ($self, $subsetter) = @_;
    return unless ($self->SUPER::subset($subsetter));

    my ($l, $count, @lmap, @lookups, $lkvec, $res, $nlookup);
    $lkvec = "";
    $nlookup = $#{$self->{'LOOKUP'}};
    # process non-contextual lookups
    foreach $l (0 .. $nlookup)
    {
        my ($type) = $self->{'LOOKUP'}[$l]{'TYPE'};
        next if ($type >= $self->extension() - 2 && $type < $self->extension());
        $res = $self->subset_lookup($self->{'LOOKUP'}[$l]);

        if (!@{$res})
        {
            delete $self->{'LOOKUP'}[$l];
            vec($lkvec, $l, 1) = 0;
        }
        else
        {
            $self->{'LOOKUP'}[$l]{'SUB'} = $res;
            vec($lkvec, $l, 1) = 1;
        }
    }
    # now process contextual lookups knowing whether the other lookup is there
    # also collect the complete lookup list now
    foreach $l (0 .. $nlookup)
    {
        if (defined $self->{'LOOKUP'}[$l])
        {
            my ($type) = $self->{'LOOKUP'}[$l]{'TYPE'};
            if ($type >= $self->extension() - 2 && $type < $self->extension())
            {
                $res = $self->subset_lookup($self->{'LOOKUP'}[$l], $lkvec);
                if (!@{$res})
                {
                    delete $self->{'LOOKUP'}[$l];
                    vec($lkvec, $l, 1) = 0;
                }
                else
                {
                    $self->{'LOOKUP'}[$l]{'SUB'} = $res;
                    vec($lkvec, $l, 1) = 1;
                }
            }
        }
        if (vec($lkvec, $l, 1))
        {
            push (@lookups, $self->{'LOOKUP'}[$l]);
            push (@lmap, $count++);
        }
        else
        { push (@lmap, -1); }
    }
    
    $self->{'LOOKUP'} = \@lookups;
    foreach $l (@lookups)
    { $self->fixcontext($l, \@lmap); }

    foreach my $t (@{$self->{'FEATURES'}{'FEAT_TAGS'}})
    {
        my $f = $self->{'FEATURES'}{$t};
        foreach $l (0 .. $#{$f->{'LOOKUPS'}})
        {
            my ($v) = $lmap[$f->{'LOOKUPS'}[$l]];
            if ($v < 0)
            { delete $f->{'LOOKUPS'}[$l]; }
            else
            { $f->{'LOOKUPS'}[$l] = $v; }
        }
        if (!@{$f->{'LOOKUPS'}})
        { delete $self->{'FEATURES'}{$t}; }
        else
        { $f->{'LOOKUPS'} = [grep {defined $_} @{$f->{'LOOKUPS'}}]; }
    }
    $self->{'FEATURES'}{'FEAT_TAGS'} = [grep {defined $self->{'FEATURES'}{$_}} @{$self->{'FEATURES'}{'FEAT_TAGS'}}];

    my ($isEmpty) = 1;
    foreach my $s (keys %{$self->{'SCRIPTS'}})
    {
        foreach $l (-1 .. $#{$self->{'SCRIPTS'}{$s}{'LANG_TAGS'}})
        {
            my $lang;
            if ($l < 0)
            { $lang = $self->{'SCRIPTS'}{$s}{'DEFAULT'}; }
            else
            { $lang = $self->{'SCRIPTS'}{$s}{$self->{'SCRIPTS'}{$s}{'LANG_TAGS'}[$l]}; }

            if (defined $lang->{'FEATURES'})
            {
                foreach my $i (0 .. @{$lang->{'FEATURES'}})
                {
                    if (!defined $self->{'FEATURES'}{$lang->{'FEATURES'}[$i]})
                    { delete $lang->{'FEATURES'}[$i]; }
                }
                $lang->{'FEATURES'} = [grep {$_} @{$lang->{'FEATURES'}}];
            }
            if (defined $lang->{'DEFAULT'} && $lang->{'DEFAULT'} >= 0)
            {
                my ($found) = 0;
                foreach my $f (@{$self->{'FEATURES'}{'FEAT_TAGS'}})
                {
                    if ($self->{'FEATURES'}{$f}{'INDEX'} == $lang->{'DEFAULT'})
                    {
                        $found = 1;
                        last;
                    }
                }
                if (!$found)
                { $lang->{'DEFAULT'} = -1; }
            }
            if (($l >= 0 && defined $subsetter->{'langs'}
                && !defined $subsetter->{'langs'}{$self->{'SCRIPTS'}{$s}{'LANG_TAGS'}[$l]})
                    || ((!defined $lang->{'FEATURES'} || !@{$lang->{'FEATURES'}})
                        && (!defined $lang->{'DEFAULT'} || $lang->{'DEFAULT'} < 0)))
            {
                if ($l < 0)
                { delete $self->{'SCRIPTS'}{$s}{'DEFAULT'}; }
                else
                {
                    delete $self->{'SCRIPTS'}{$s}{$self->{'SCRIPTS'}{$s}{'LANG_TAGS'}[$l]};
                    delete $self->{'SCRIPTS'}{$s}{'LANG_TAGS'}[$l];
                }
            }
        }
        if ((defined $subsetter->{'scripts'} && !defined $subsetter->{'scripts'}{$s})
                || (!@{$self->{'SCRIPTS'}{$s}{'LANG_TAGS'}} && !defined $self->{'SCRIPTS'}{$s}{'DEFAULT'}))
        {
            delete $self->{'SCRIPTS'}{$s};
            next;
        }
        else
        { $isEmpty = 0; }
    }
    if ($isEmpty)
    {
        my ($k, $v);
        while (($k, $v) = each %{$self->{' PARENT'}})
        {
            if ($v eq $self)
            {
                delete $self->{' PARENT'}{$k};
                last;
            }
        }
    }
}

sub subset_lookup
{
    my ($self, $lookup, $lkvec) = @_;
    my ($s, $l);
    my ($res) = [];

    foreach $s (@{$lookup->{'SUB'}})
    {
        if (!$self->subset_subtable($subsetter, $s, $lookup, $lkvec)
            || !defined $s->{'RULES'} || !@{$s->{'RULES'}})
        { next; }
        $s->{'RULES'} = [grep {$_} @{$s->{'RULES'}}];
        # remove unused coverage indices
        if ($s->{'COVERAGE'})
        {
            my $c = $s->{'COVERAGE'}{'val'};
            my $i = 0;
            foreach my $k (sort {$c->{$a} <=> $c->{$b}} keys %{$c})
            { $c->{$k} = $i++; }
        }
        push (@{$res}, $s);
    }
    return $res;
}


sub subset_class
{
    my ($self, $subsetter, $classdef, $noremap) = @_;
    my ($res) = [];
    my ($count) = 0;
    my ($class) = $classdef->{'val'};

    foreach (sort {$a <=> $b} keys %{$class})
    {
        if (!$subsetter->keep_glyph($_))
        { delete $class->{$_}; }
        else
        {
            my $g = $subsetter->map_glyph($_);
            $class->{$g} = delete $class->{$_};
            $res->[$class->{$g}] = ++$count unless (defined $res->[$class->{$g}])
        }
    }
    # remap the class
    unless ($noremap)
    {
        foreach (keys %{$class})
        { $class->{$_} = $res->[$class->{$_}]; }
    }
    if (@{$res})
    { return $res; }
    else
    { return undef; }
}

sub subset_cover
{
    my ($self, $subsetter, $coverage, $rules) = @_;
    return $coverage if (defined $coverage->{'isremapped'});
    my $isEmpty = 1;
    my $cover = $coverage->{'val'};
    foreach (sort {$a <=> $b} keys %{$cover})
    {
        if (!$subsetter->keep_glyph($_))
        {
            delete $rules->[$cover->{$_}] if $rules;
            delete $cover->{$_};
        }
        else
        {
            $cover->{$subsetter->map_glyph($_)} = delete $cover->{$_};
            $isEmpty = 0;
        }
    }
    if ($isEmpty)
    { return undef; }
    else
    {
        $coverage->{'isremapped'} = 1;
        return $coverage;
    }
}

sub subset_string
{
    my ($self, $subsetter, $string, $fmt, $classvals) = @_;
    my ($test) = 1;

    return 0 if ($fmt == 2 && !$classvals);
    foreach (@{$string})
    {
        if ($fmt == 1 && $subsetter->keep_glyph($_))
        { $_ = $subsetter->map_glyph($_); }
        elsif ($fmt == 2 && defined $classvals->[$_])
        { $_ = $classvals->[$_]; }
        elsif ($fmt == 3 && $self->subset_cover($subsetter, $_, undef))
        { }
        else
        {
            $test = 0;
            last;
        }
    }
    return $test;
}

sub subset_context
{
    my ($self, $subsetter, $sub, $type, $lkvec) = @_;
    my ($fmt) = $sub->{'FORMAT'};
    my ($classvals, $prevals, $postvals, $i, $j, @gids);

    return 0 if (defined $sub->{'COVERAGE'} && !$self->subset_cover($subsetter, $sub->{'COVERAGE'}, $fmt < 2 ? $sub->{'RULES'} : undef));
    while (my ($k, $v) = each %{$sub->{'COVERAGE'}{'val'}})
    { $gids[$v] = $k; }
    return 0 if (defined $sub->{'CLASS'} && !($classvals = $self->subset_class($subsetter, $sub->{'CLASS'})));
    return 0 if (defined $sub->{'PRE_CLASS'} && !($prevals = $self->subset_class($subsetter, $sub->{'PRE_CLASS'})));
    return 0 if (defined $sub->{'POST_CLASS'} && !($postvals = $self->subset_class($subsetter, $sub->{'POST_CLASS'})));
    # tidy up coverage tables that contain glyphs not in the matching class
#    if (defined $sub->{'CLASS'})
#    {
#        foreach $i (0 .. $#gids)
#        {
#            if (defined $gids[$i] && !defined $sub->{'CLASS'}{'val'}{$gids[$i]})
#            {
#                delete $sub->{'COVERAGE'}{'val'}{$gids[$i]};
#                delete $gids[$i];
#            }
#        }
#        @gids = grep {defined $_} @gids;
#    }
#    return 0 unless (@gids);


    foreach $i (0 .. @{$sub->{'RULES'}})
    {
        my ($isEmpty) = 1;
        if ($sub->{'RULES'}[$i])
        {
            foreach $j (0 .. $#{$sub->{'RULES'}[$i]})
            {
                my ($r) = $sub->{'RULES'}[$i][$j];
                my ($test) = 1;
                if ($type == 4)
                {
                    if ($subsetter->keep_glyph($r->{'ACTION'}[0]))
                    { $r->{'ACTION'}[0] = $subsetter->map_glyph($r->{'ACTION'}[0]); }
                    else
                    { $test = 0; }
                }
                else
                {
                    foreach my $k (0 .. $#{$sub->{'RULES'}[$i][$j]{'ACTION'}})
                    {
                        my $a = $sub->{'RULES'}[$i][$j]{'ACTION'}[$k];
                        if (!vec($lkvec, $a->[1], 1))
                        { delete $sub->{'RULES'}[$i][$j]{'ACTION'}[$k]; }
                    }
                    $test = (@{$sub->{'RULES'}[$i][$j]{'ACTION'}} != 0);
                }
                if ($test && $type == 6 && defined $r->{'PRE'})
                { $test = $self->subset_string($subsetter, $r->{'PRE'}, $fmt, $prevals); }
                if ($test && $type == 6 && defined $r->{'POST'})
                { $test = $self->subset_string($subsetter, $r->{'POST'}, $fmt, $postvals); }
                if ($test)
                { $test = $self->subset_string($subsetter, $r->{'MATCH'}, $fmt, $classvals); }
                if (!$test)
                { delete $sub->{'RULES'}[$i][$j]; }
                else
                { $isEmpty = 0; }
            }
            $sub->{'RULES'}[$i] = [grep {$_} @{$sub->{'RULES'}[$i]}];
        }
        if ($isEmpty)
        {
            delete $sub->{'RULES'}[$i];
            delete $sub->{'COVERAGE'}{'val'}{$gids[$i]} if ($fmt < 2);  # already remapped
        }
    }
    return 1;
}

sub fixcontext
{
    my ($self, $l, $lmap) = @_;

    return if ($l->{'TYPE'} < $self->extension() - 2 || $l->{'TYPE'} >= $self->extension());
    foreach my $s (@{$l->{'SUB'}})
    {
        foreach my $r (@{$s->{'RULES'}})
        {
            foreach my $p (@{$r})
            {
                foreach my $b (@{$p->{'ACTION'}})
                { $b->[1] = $lmap->[$b->[1]]; }
            }
        }
    }
}



package Font::TTF::GSUB;

sub subset_subtable
{
    my ($self, $subsetter, $sub, $lookup, $lkvec) = @_;
    my ($type) = $lookup->{'TYPE'};
    my ($fmt) = $sub->{'FORMAT'};
    my ($r, $i, $j, @gids, $k, $v);

    return 0 if ($type < 4 && !$self->subset_cover($subsetter, $sub->{'COVERAGE'}, $sub->{'RULES'}));

    while (($k, $v) = each %{$sub->{'COVERAGE'}{'val'}})
    { $gids[$v] = $k; }

    if (($type == 1 && $fmt > 1) || $type == 2)
    {
        foreach $i (0 .. $#{$sub->{'RULES'}})
        {
            next unless (defined $sub->{'RULES'}[$i]);
            foreach my $k (0 .. $#{$sub->{'RULES'}[$i][0]{'ACTION'}})
            {
                $j = $sub->{'RULES'}[$i][0]{'ACTION'}[$k];
                if (!$subsetter->keep_glyph($j))
                {
                    delete $sub->{'RULES'}[$i];
                    delete $sub->{'COVERAGE'}{'val'}{$gids[$i]}; # already remapped
                    last;
                }
                else
                { $sub->{'RULES'}[$i][0]{'ACTION'}[$k] = $subsetter->map_glyph($j); }
            }
        }
    }
    elsif ($type == 3)
    {
        foreach $i (0 .. $#{$sub->{'RULES'}})
        {
            if (!defined $sub->{'RULES'}[$i])
            {
                delete $sub->{'COVERAGE'}{'val'}{$gids[$i]};
                next;
            }
            my $res = [];
            foreach $j (@{$sub->{'RULES'}[$i][0]{'ACTION'}})
            {
                if ($subsetter->keep_glyph($j))
                { push (@{$res}, $subsetter->map_glyph($j)); }
            }
            if (@{$res})
            { $sub->{'RULES'}[$i][0]{'ACTION'} = $res; }
            else
            {
                delete $sub->{'RULES'}[$i];
                delete $sub->{'COVERAGE'}{'val'}{$gids[$i]};  # already remapped
            }
        }
    }
    elsif ($type >=4 && $type <= 6)
    { return $self->subset_context($subsetter, $sub, $type, $lkvec); }
    return 1;
}

package Font::TTF::GPOS;

sub subset_subtable
{
    my ($self, $subsetter, $sub, $lookup, $lkvec) = @_;
    my ($type) = $lookup->{'TYPE'};
    my ($fmt) = $sub->{'FORMAT'};
    my (@gids) = sort { $a <=> $b} keys %{$sub->{'COVERAGE'}{'val'}};
    my ($i, $j, $k);

    return 0 if ($type <= 6 && !$self->subset_cover($subsetter, $sub->{'COVERAGE'}, $sub->{'RULES'}));
    if ($type == 2 && $fmt == 1)
    {
        foreach $i (0 .. $#{$sub->{'RULES'}})
        {
            foreach $j (0 .. $#{$sub->{'RULES'}[$i]})
            {
                my ($r) = $sub->{'RULES'}[$i][$j];
                if (!$subsetter->keep_glyph($r->{'MATCH'}[0]))
                { delete $sub->{'RULES'}[$i][$j]; }
                else
                { $r->{'MATCH'}[0] = $subsetter->map_glyph($r->{'MATCH'}[0]); }
            }
            if (!@{$sub->{'RULES'}[$i]})
            { delete $sub->{'RULES'}[$i]; }
            else
            { $sub->{'RULES'}[$i] = [grep {$_} @{$sub->{'RULES'}[$i]}]; }
        }
    }
    elsif ($type == 2 && $fmt == 2)
    {
        my ($c1vals) = $self->subset_class($subsetter, $sub->{'CLASS'});
        my ($c2vals) = $self->subset_class($subsetter, $sub->{'MATCH'}[0]);
        my ($nrules) = [];
        
        foreach $i (0 .. $#{$sub->{'RULES'}})
        {
            if (!$c1vals->[$i])
            { delete $sub->{'RULES'}[$i]; }
            else
            {
                my (@nrule);
                foreach $j (0 .. $#{$sub->{'RULES'}[$i]})
                {
                    if (!defined $c2vals->[$j])
                    { delete $sub->{'RULES'}[$i][$j]; }
                    else
                    { $nrule[$c2vals->[$j]] = $sub->{'RULES'}[$i][$j]; }
                }
                if (@nrule)
                { $nrules->[$c1vals->[$i]] = [grep {$_} @nrule]; }
            }
        }
        if (@{$nrules})
        { $sub->{'RULES'} = $nrules; }
        else
        { return 0; }
    }
    elsif ($type >= 4 && $type <= 6)
    { return $self->subset_cover($subsetter, $sub->{'MATCH'}[0], $sub->{'MARKS'}) ? 1 : 0; }
    elsif ($type >=7 && $type <= 8)
    { return $self->subset_context($subsetter, $sub, $type - 2, $lkvec); }
    return 1;
}

package Font::TTF::GDEF;

sub subset
{
    my ($self, $subsetter) = @_;

    return unless ($self->SUPER::subset($subsetter));
    if (defined $self->{'GLYPH'})
    { delete $self->{'GLYPH'} unless (Font::TTF::Ttopen->subset_class($subsetter, $self->{'GLYPH'}, 1)); }
    if (defined $self->{'ATTACH'})
    { delete $self->{'ATTACH'} unless (Font::TTF::Ttopen->subset_cover($subsetter, $self->{'ATTACH'}{'COVERAGE'}, $self->{'ATTACH'}{'POINTS'})); }
    if (defined $self->{'LIG'})
    { delete $self->{'LIG'} unless (Font::TTF::Ttopen->subset_cover($subsetter, $self->{'LIG'}{'COVERAGE'}, $self->{'LIG'}{'POINTS'})); }
    if (defined $self->{'MARKS'})
    { delete $self->{'MARKS'} unless (Font::TTF::Ttopen->subset_cover($subsetter, $self->{'MARKS'}, undef)); }
}

package Font::TTF::Cmap;

sub subset
{
    my ($self, $subsetter) = @_;

    return unless ($self->SUPER::subset($subsetter));
    foreach my $i (0 .. $#{$self->{'Tables'}})
    {
        my ($t) = $self->{'Tables'}[$i]{'val'};
        foreach my $k (keys %{$t})
        {
            if ($subsetter->keep_glyph($t->{$k}))
            { $t->{$k} = $subsetter->map_glyph($t->{$k}); }
            else
            { delete $t->{$k}; }
        }
        if ($self->is_unicode($i))
        {
            foreach my $k (keys %{$subsetter->{'remaps'}})
            { $t->{$k} = $subsetter->map_glyph($subsetter->{'remaps'}{$k}); }
        }
    }
}

package Font::TTF::Post;

sub subset
{
    my ($self, $subsetter) = @_;
    my ($res) = [];

    return unless ($self->SUPER::subset($subsetter));
    # need to rewrite for real glyph remapping
    foreach my $i (0 .. @{$self->{'VAL'}})
    { $res->[$subsetter->map_glyph($i)] = $subsetter->keep_glyph($i) ? $self->{'VAL'}[$i] : ".notdef"; }
    $self->{'VAL'} = $res;
}

package Font::TTF::Hmtx;

sub subset
{
    my ($self, $subsetter) = @_;
    my ($adv) = [];
    my ($lsb) = [];

    return unless ($self->SUPER::subset($subsetter));
    for (my $i = 0; $i < @{$self->{'advance'}}; $i++)
    {
        if ($subsetter->keep_glyph($i))
        {
            my ($g) = $subsetter->map_glyph($i);
            $adv->[$g] = $self->{'advance'}[$i];
            $lsb->[$g] = $self->{'lsb'}[$i];
        }
    }
    $self->{'advance'} = $adv;
    $self->{'lsb'} = $lsb;
}

package Font::TTF::LTSH;

sub subset
{
    my ($self, $subsetter) = @_;
    my ($res) = [];

    return unless ($self->SUPER::subset($subsetter));
    for (my $i = 0; $i < @{$self->{'glyphs'}}; $i++)
    {
        if ($subsetter->keep_glyph($i))
        { $res->[$subsetter->map_glyph($i)] = $self->{'glyphs'}[$i]; }
    }
    $self->{'glyphs'} = $res;
    $self->{'Num'} = $subsetter->{'gcount'};
}


package Font::TTF::Gloc;

sub canchangegids
{ 0; }


__END__

=head1 TITLE

ttfsubset - subset a font

=head1 SYNOPSIS

ttfsubset [options] infont outfont

Opens infont (a .ttf file), subsets it according to the supplied options, then writes the resulting file to outfont.

=head1 OPTIONS

  -h            Get full help
  -d tag[,...]	List of font tables to remove.
  -g listfile	File containing list of glyphs to retain 
  -s tag[,...]	List of OpenType script tags to retain
  -l tag[,...]  List of OpenType language tags to retain
  -n name       Renames the font to the given name (as per ttfname -n)

=head1 DESCRIPTION

ttfsubset removes parts of a font in order to produce a working, smaller, font. Multiple subsetting 
strategies are provided and controlled by options.

The C<-d> option is used to delete whole font tables, e.g., all Graphite tables. A 
list of four-letter table tags identifies the tables to be removed. As in L<ttftable>, 
the following (case insensitive) pseudo tags can also be used:

  graphite  all SIL Graphite tables (Silf Feat Gloc Glat Sill Sile)
  volt      all Microsoft VOLT tables (TSIV TSID TSIP TSIS)
  opentype  all OpenTYpe tables (GDEF GSUB GPOS)

The C<-g> option specifies a file that lists glyphs to be retained in the 
subset font -- ttfsubset will remove all other glyphs and then do what it can to simplify
remaining features.  Glyphs are identified in the file using space-separated indentifiers which
can be decimal numeric glyph IDs, postscript glyph names, or hexidecimal Unicode scalar values in the format
of U+xxxx. Numeric or postscript glyph identifiers can be followed immediately by equals sign and 4 to 6 hex digits to
indicate the glyph should be encoded.

The C<-s> and C<-l> options identify OpenType script and language (respectively) tags
to retain in the font. The Default language is always retained, so specify C<-l ''> to remove all but the default language. 

=head1 BUGS

ttfsubset is an evolving tool and the invitation is given to contribute improvements that will result
in smaller output fonts.

=cut
