/lib/Font/Subsetter.pm

# Copyright (c) 2009 Philip Taylor
#
# Permission is hereby granted, free of charge, to any person
# obtaining a copy of this software and associated documentation
# files (the "Software"), to deal in the Software without
# restriction, including without limitation the rights to use,
# copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the
# Software is furnished to do so, subject to the following
# conditions:
#
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
# OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
# OTHER DEALINGS IN THE SOFTWARE.

package Font::Subsetter;

use strict;
use warnings;

use Carp;
use Unicode::Normalize();
use Digest::SHA qw(sha1_hex);
use Encode;

use Font::TTF;
use Font::TTF::Font;

if ($Font::TTF::VERSION =~ /^0\.([0-3].|4[0-5])$/) {
    die "You are using an old version of Font::TTF ($Font::TTF::VERSION) - you need at least v0.46, and preferably the latest SVN trunk from <http://scripts.sil.org/cms/scripts/page.php?site_id=nrsi&id=fontutils>.";
}

# Tables can be:
#   REQUIRED - will fail if it's not present
#   FORBIDDEN - will fail if it's present
#   OPTIONAL - will be accepted regardless of whether it's there or not
#   IGNORED - like OPTIONAL, but no processing will take place
#   UNFINISHED - will emit a warning if it's present, because the code doesn't handle it properly yet
#   DROP - will be deleted from the font
# The default for unmentioned tables is FORBIDDEN
my %font_tables = (
    'cmap' => ['REQUIRED'],
    'head' => ['REQUIRED'],
    'hhea' => ['REQUIRED'],
    'hmtx' => ['REQUIRED'],
    'maxp' => ['REQUIRED'],
    'name' => ['REQUIRED'],
    'OS/2' => ['REQUIRED'],
    'post' => ['REQUIRED'],
    # TrueType outlines:
    'cvt ' => ['IGNORED'],
    'fpgm' => ['IGNORED'],
    'glyf' => ['IGNORED'],
    'loca' => ['OPTIONAL'],
    'prep' => ['OPTIONAL'],
    # PostScript outlines: (TODO: support these?)
    'CFF ' => ['FORBIDDEN'],
    'VORG' => ['FORBIDDEN'],
    # Bitmap glyphs: (TODO: support these?)
    'EBDT' => ['DROP', 'embedded bitmap glyphs will be lost'],
    'EBLC' => ['DROP', 'embedded bitmap glyphs will be lost'],
    'EBSC' => ['DROP', 'embedded bitmap glyphs will be lost'],
    # Advanced typographic tables:
    'BASE' => ['UNFINISHED'],
    'GDEF' => ['OPTIONAL'],
    'GPOS' => ['OPTIONAL'],
    'GSUB' => ['OPTIONAL'],
    'JSTF' => ['UNFINISHED'],
    # OpenType tables:
    'DSIG' => ['DROP'], # digital signature - don't need it here
    'gasp' => ['IGNORED'],
    'hdmx' => ['OPTIONAL'],
    'kern' => ['OPTIONAL'],
    'LTSH' => ['OPTIONAL'],
    'PCLT' => ['UNFINISHED'],
    'VDMX' => ['IGNORED'],
    'vhea' => ['UNFINISHED'],
    'vmtx' => ['UNFINISHED'],
    # SIL Graphite tables:
    'Feat' => ['DROP'],
    'Silf' => ['DROP'],
    'Sill' => ['DROP'],
    'Silt' => ['DROP'],
    'Glat' => ['DROP'],
    'Gloc' => ['DROP'],
    # FontForge tables:
    'PfEd' => ['DROP'],
    'FFTM' => ['DROP'],
    # Apple Advanced Typography tables:
    # (These get dropped because it's better to use cross-platform features instead)
    'feat' => ['DROP'],
    'morx' => ['DROP'],
    'prop' => ['DROP'],
    # Undocumented(?) extension for some kind of maths stuff
    'MATH' => ['DROP'],
);

sub check_tables {
    my ($self) = @_;
    my $font = $self->{font};

    my @tables = grep /^[^ ]...$/, sort keys %$font;
    for (@tables) {
        my $t = $font_tables{$_};
        if (not $t) {
            die "Uses unrecognised table '$_'\n";
        } else {
            my $status = $t->[0];
            if ($status eq 'FORBIDDEN') {
                die "Uses forbidden table '$_'\n";
            } elsif ($status eq 'UNFINISHED') {
                warn "Uses unhandled table '$_'\n";
            } elsif ($status eq 'DROP') {
                my $note = ($t->[1] ? ' - '.$t->[1] : '');
                warn "Dropping table '$_'$note\n";
                delete $font->{$_};
            } elsif ($status eq 'OPTIONAL') {
            } elsif ($status eq 'IGNORED') {
            } elsif ($status eq 'REQUIRED') {
            } else {
                die "Invalid table status $status";
            }
        }
    }
    # TODO: check required tables are present
    # TODO: check TrueType or PostScript tables are present
}

sub read_tables {
    my ($self) = @_;
    my $font = $self->{font};

    # Read all the tables that will be needed in the future.
    # (In particular, read them before modifying numGlyphs,
    # beacuse they often depend on that value.)
    for (qw(
        cmap hmtx name OS/2 post
        glyf loca
        BASE GDEF GPOS GSUB JSTF
        hdmx kern LTSH
    )) {
        $font->{$_}->read if $font->{$_};
    }
}

sub find_codepoint_glyph_mappings {
    my ($self) = @_;
    my $font = $self->{font};

    # Find the glyph->codepoint mappings

    my %glyphs;
    for my $table (@{$font->{cmap}{Tables}}) {
        for my $cp (keys %{$table->{val}}) {

            my $ucp; # Unicode code point

            if ($table->{Platform} == 0 # Unicode
                or ($table->{Platform} == 3 and # Windows
                    ($table->{Encoding} == 1 or # Unicode BMP
                     $table->{Encoding} == 10)) # Unicode full
            ) {
                $ucp = $cp;
            } elsif ($table->{Platform} == 1 # Mac
                    and $table->{Encoding} == 0) # Roman
            {
                $ucp = ord(decode('MacRoman', pack C => $cp));
            } else {
                # This table might not map directly onto Unicode codepoints,
                # so warn about it
                warn "Unrecognised cmap table type (platform $table->{Platform}, encoding $table->{Encoding}) - ignoring its character/glyph mappings\n";
                next;
            }

            my $g = $table->{val}{$cp}; # glyph id
            $glyphs{$g}{$ucp} = 1;
        }
    }
    $self->{glyphs} = \%glyphs;
}

sub expand_wanted_chars {
    my ($self, $chars) = @_;
    # OS X browsers (via ATSUI?) appear to convert text into
    # NFC before rendering it.
    # So input like "i{combining grave}" is converted to "{i grave}"
    # before it's even passed to the font's substitution tables.
    # So if @chars contains i and {combining grave}, then we have to
    # add {i grave} because that might get used.
    #
    # So... Include all the unchanged characters. Also include the NFC
    # of each character. Then use NormalizationData to add any characters
    # that can result from NFCing a string of the wanted characters.

    if (0) { # change to 1 to disable all this fancy stuff
        my %cs = map { ord $_ => 1 } split '', $chars;
        return %cs;
    }

    my %cs = map { ord $_ => 1, ord Unicode::Normalize::NFC($_) => 1 } split '', $chars;
    require Font::Subsetter::NormalizationData;
    my %new_cs;
    for my $c (@Font::Subsetter::NormalizationData::data) {
        # Skip this if we've already got the composed character
        next if $cs{$c->[0]};
        # Skip this if we don't have all the decomposed characters
        next if grep !$cs{$_}, @{$c}[1..$#$c];
        # Otherwise we want the composed character
        $new_cs{$c->[0]} = 1;
    }
    $cs{$_} = 1 for keys %new_cs;
    return %cs;
}

sub want_feature {
    my ($self, $wanted, $feature) = @_;
    # If no feature list was specified, accept all features
    return 1 if not $wanted;
    # Otherwise find the four-character tag
    $feature =~ /^(\w{4})( _\d+)?$/ or die "Unrecognised feature tag syntax '$feature'";
    return $wanted->{$1} if exists $wanted->{$1};
    return $wanted->{DEFAULT} if exists $wanted->{DEFAULT};
    return 1;
}

sub find_wanted_lookup_ids {
    my ($self, $table) = @_;

    # If we wanted to include all lookups:
    #   return 0..$#{$table->{LOOKUP}};
    # but actually we only want ones used by wanted features

    my %lookups;
    for my $feat_tag (@{$table->{FEATURES}{FEAT_TAGS}}) {
        next if not $self->want_feature($self->{features}, $feat_tag);
        for (@{$table->{FEATURES}{$feat_tag}{LOOKUPS}}) {
            $lookups{$_} = 1;
        }
    }

    # Iteratively add any chained lookups
    my $changed = 1;
    while ($changed) {
        $changed = 0;
        for my $lookup_id (0..$#{$table->{LOOKUP}}) {
            next unless $lookups{$lookup_id};
            my $lookup = $table->{LOOKUP}[$lookup_id];
            for my $sub (@{$lookup->{SUB}}) {
                if ($sub->{ACTION_TYPE} eq 'l') {
                    for my $rule (@{$sub->{RULES}}) {
                        for my $chain (@$rule) {
                            for my $action (@{$chain->{ACTION}}) {
                                for (0..@$action/2-1) {
                                    # action is array of (offset, lookup)
                                    $changed = 1 if not $lookups{$action->[$_*2+1]};
                                    $lookups{$action->[$_*2+1]} = 1;
                                }
                            }
                        }
                    }
                }
            }
        }
    }

    my @keys = sort { $a <=> $b } keys %lookups;
    return @keys;
}

sub find_wanted_glyphs {
    my ($self, $chars) = @_;
    my $font = $self->{font};

    my %wanted_chars = $self->expand_wanted_chars($chars);
    $self->{wanted_glyphs} = {};

    # http://www.microsoft.com/typography/otspec/recom.htm suggests that fonts
    # should include .notdef, .null, CR, space; so include them all here, if they
    # are already defined
    if ($font->{post}{VAL}) {
        for my $gid (0..$#{$font->{loca}{glyphs}}) {
            my $name = $font->{post}{VAL}[$gid];
            if ($name and ($name eq '.notdef' or $name eq '.null' or $name eq 'CR' or $name eq 'space')) {
                $self->{wanted_glyphs}{$gid} = 1;
            }
        }
    } else {
        # If post.FormatType == 3 then we don't have any glyph names
        # so just assume it's the first four
        $self->{wanted_glyphs}{$_} = 1 for 0..3;
    }

    # We want any glyphs used directly by any characters we want
    for my $gid (keys %{$self->{glyphs}}) {
        for my $cp (keys %{$self->{glyphs}{$gid}}) {
            $self->{wanted_glyphs}{$gid} = 1 if $wanted_chars{$cp};
        }
    }

    # Iteratively find new glyphs, until convergence
    my @newly_wanted_glyphs = keys %{$self->{wanted_glyphs}};
    while (@newly_wanted_glyphs) {
        my @new_glyphs;

        if ($font->{GSUB}) {

            # Handle ligatures and similar things
            # (e.g. if we want 'f' and 'i', we want the 'fi' ligature too)
            # (NOTE: a lot of this code is duplicating the form of
            # fix_gsub, so they ought to be kept roughly in sync)
            #
            # TODO: There's probably loads of bugs in here, so it
            # should be checked and tested more

            for my $lookup_id ($self->find_wanted_lookup_ids($font->{GSUB})) {
                my $lookup = $font->{GSUB}{LOOKUP}[$lookup_id];
                for my $sub (@{$lookup->{SUB}}) {

                    # Handle the glyph-delta case
                    if ($sub->{ACTION_TYPE} eq 'o') {
                        my $adj = $sub->{ADJUST};
                        if ($adj >= 32768) { $adj -= 65536 } # fix Font::TTF::Bug (http://rt.cpan.org/Ticket/Display.html?id=42727)
                        my @covs = $self->coverage_array($sub->{COVERAGE});
                        for (@covs) {
                            # If we want the coveraged glyph, we also want
                            # that glyph plus delta
                            if ($self->{wanted_glyphs}{$_}) {
                                my $new = $_ + $adj;
                                next if $self->{wanted_glyphs}{$new};
                                push @new_glyphs, $new;
                                $self->{wanted_glyphs}{$new} = 1;
                            }
                        }
                        next;
                    }

                    # Collect the rules which might match initially something
                    my @rulesets;
                    if ($sub->{RULES}) {
                        if (($lookup->{TYPE} == 5 or $lookup->{TYPE} == 6)
                            and $sub->{FORMAT} == 2) {
                            # RULES corresponds to class values
                            # TODO: ought to filter this by classes that contain wanted glyphs
                            push @rulesets, @{$sub->{RULES}};
                        } elsif (($lookup->{TYPE} == 5 or $lookup->{TYPE} == 6)
                            and $sub->{FORMAT} == 3) {
                            # COVERAGE is empty; accept all the RULEs, and
                            # we'll look inside their MATCHes later
                            push @rulesets, @{$sub->{RULES}};
                        } else {
                            # COVERAGE lists glyphs, and there's a RULE for
                            # each, so extract the RULEs for wanted COVERAGE
                            # values
                            my @covs = $self->coverage_array($sub->{COVERAGE});
                            die unless @{$sub->{RULES}} == @covs;
                            for my $i (0..$#covs) {
                                if ($self->{wanted_glyphs}{$covs[$i]}) {
                                    push @rulesets, $sub->{RULES}[$i];
                                }
                            }
                        }
                    }

                    # Collect the rules whose MATCH matches
                    my @rules;
                    RULE: for my $rule (map @$_, @rulesets) {
                        if (not defined $sub->{MATCH_TYPE}) {
                            # No extra matching other than COVERAGE,
                            # so just accept this rule
                        } elsif ($sub->{MATCH_TYPE} eq 'g') {
                            # RULES->MATCH/PRE/POST are arrays of glyphs that must all match
                            for my $c (qw(MATCH PRE POST)) {
                                next unless $rule->{$c};
                                next RULE if grep { not $self->{wanted_glyphs}{$_} } @{$rule->{$c}};
                            }
                        } elsif ($sub->{MATCH_TYPE} eq 'o') {
                            # RULES->MATCH/PRE/POST are arrays of coverage tables,
                            # and at least one glyph from each table must match
                            die unless @{$sub->{RULES}} == 1;
                            die unless @{$sub->{RULES}[0]} == 1;
                            for my $c (qw(MATCH PRE POST)) {
                                next unless $sub->{RULES}[0][0]{$c};
                                for (@{$sub->{RULES}[0][0]{$c}}) {
                                    my $matched = 0;
                                    for (keys %{$_->{val}}) {
                                        if ($self->{wanted_glyphs}{$_}) {
                                            $matched = 1;
                                            last;
                                        }
                                    }
                                    next RULE if not $matched;
                                }
                            }
                        } elsif ($sub->{MATCH_TYPE} eq 'c') {
                            # TODO: only includes rules using classes that contain
                            # wanted glyphs.
                            # For now, just conservatively accept everything.
                        } else {
                            die "Invalid MATCH_TYPE";
                        }
                        push @rules, $rule;
                    }

                    # Find the glyphs in the relevant actions
                    for my $rule (@rules) {
                        if ($sub->{ACTION_TYPE} eq 'g') {
                            die unless $rule->{ACTION};
                            for my $new (@{$rule->{ACTION}}) {
                                next if $self->{wanted_glyphs}{$new};
                                push @new_glyphs, $new;
                                $self->{wanted_glyphs}{$new} = 1;
#                                warn "adding $new";
                            }
                        } elsif ($sub->{ACTION_TYPE} eq 'l') {
                            # do nothing - this is just a lookup to run some other rules
                        } elsif ($sub->{ACTION_TYPE} eq 'a') {
                            # do nothing - we don't want the alternative glyphs
                        } else {
                            die "Invalid ACTION_TYPE";
                        }
                    }
                }
            }
        }

        @newly_wanted_glyphs = @new_glyphs;
    }

    # Now we want to add glyphs that are used for composite rendering,
    # which don't participate in any GSUB behaviour
    @newly_wanted_glyphs = keys %{$self->{wanted_glyphs}};
    while (@newly_wanted_glyphs) {
        my @new_glyphs;

        if ($font->{loca}) {
            # If we want a composite glyph, we want all of its
            # component glyphs too
            # (e.g. &aacute; is the 'a' glyph plus the acute glyph):
            for my $gid (@newly_wanted_glyphs) {
                my $glyph = $font->{loca}{glyphs}[$gid];
                next unless $glyph;
                $glyph->read;
                next unless $glyph->{numberOfContours} == -1;
                $glyph->read_dat;
                for (@{$glyph->{comps}}) {
                    next if $self->{wanted_glyphs}{$_->{glyph}};
                    push @new_glyphs, $_->{glyph};
                    $self->{wanted_glyphs}{$_->{glyph}} = 1;
                }
                $glyph->update;
            }
        }

        @newly_wanted_glyphs = @new_glyphs;
    }
}

sub update_classdef_table {
    my ($self, $table) = @_;
    die "Expected table" if not $table;
    die "Expected classdef" if $table->{cover};
    my @vals;
    for my $gid (keys %{$table->{val}}) {
        next if not $self->{wanted_glyphs}{$gid};
        my $v = $table->{val}{$gid};
        push @vals, $self->{glyph_id_old_to_new}{$gid}, $v;
    }
    my $ret = new Font::TTF::Coverage(0, @vals);
    # Font::TTF bug (http://rt.cpan.org/Ticket/Display.html?id=42716):
    # 'max' is not set by new(), so do it manually:
    my $max = 0;
    for (values %{$ret->{val}}) { $max = $_ if $_ > $max }
    $ret->{max} = $max;
    return $ret;
}

# Returns a map such that map[old_class_value] = new_class_value
# (or undef if the class is removed)
# This differs from update_classdef_table in that it can
# reorder and optimise the class ids
sub update_mapped_classdef_table {
    my ($self, $table) = @_;
    die "Expected table" if not $table;
    die "Expected classdef" if $table->{cover};
    my @vals;
    my %used_classes;
    $used_classes{0} = 1; # 0 is implicitly in every classdef
    for my $gid (keys %{$table->{val}}) {
        next if not $self->{wanted_glyphs}{$gid};
        my $v = $table->{val}{$gid};
        push @vals, $self->{glyph_id_old_to_new}{$gid}, $v;
        $used_classes{$v} = 1;
    }

    my @map_new_to_old = sort { $a <=> $b } keys %used_classes;
    my @map_old_to_new;
    $map_old_to_new[$map_new_to_old[$_]] = $_ for 0..$#map_new_to_old;

    # Update the class numbers
    for (0..@vals/2-1) {
        $vals[$_*2+1] = $map_old_to_new[$vals[$_*2+1]];
    }

    my $ret = new Font::TTF::Coverage(0, @vals);
    # Font::TTF bug (http://rt.cpan.org/Ticket/Display.html?id=42716):
    # 'max' is not set by new(), so do it manually:
    my $max = 0;
    for (values %{$ret->{val}}) { $max = $_ if $_ > $max }
    $ret->{max} = $max;
    return ($ret, \@map_old_to_new, \@map_new_to_old);
}

# Removes unwanted glyphs from a coverage table, for
# cases where nobody else is referring to indexes in this table
sub update_coverage_table {
    my ($self, $table) = @_;
    die "Expected table" if not $table;
    die "Expected cover" if not $table->{cover};
    my @vals = keys %{$table->{val}};
    @vals = grep $self->{wanted_glyphs}{$_}, @vals;
    @vals = sort { $a <=> $b } @vals;
    @vals = map $self->{glyph_id_old_to_new}{$_}, @vals;
    return new Font::TTF::Coverage(1, @vals);
}

# Returns a map such that map[new_coverage_index] = old_coverage_index
sub update_mapped_coverage_table {
    my ($self, $table) = @_;
    die "Expected table" if not $table;
    die "Expected coverage" if not $table->{cover};

    my @map;
    my @new_vals;
    # Get the covered values (in order)
    my @vals = $self->coverage_array($table);
    for my $i (0..$#vals) {
        # Create a new list of all the wanted values
        if ($self->{wanted_glyphs}{$vals[$i]}) {
            push @new_vals, $self->{glyph_id_old_to_new}{$vals[$i]};
            push @map, $i;
        }
    }
    return (new Font::TTF::Coverage(1, @new_vals), @map);
}

sub coverage_array {
    my ($self, $table) = @_;
    Carp::confess "Expected table" if not $table;
    return sort { $table->{val}{$a} <=> $table->{val}{$b} } keys %{$table->{val}};
}

sub empty_coverage {
    my ($self, $table) = @_;
    Carp::confess "Expected table" if not $table;
    return 1 if not $table->{val};
    return 1 if not keys %{$table->{val}};
    return 0;
}

# Update the loca table to delete unwanted glyphs.
# Must be called before all the other fix_* methods.
sub remove_unwanted_glyphs {
    my ($self) = @_;
    my $font = $self->{font};

    return unless $font->{loca};

    my %glyph_id_old_to_new;
    my %glyph_id_new_to_old;

    my $glyphs = $font->{loca}{glyphs};
    my @new_glyphs;
    for my $i (0..$#$glyphs) {
        if ($self->{wanted_glyphs}{$i}) {
            push @new_glyphs, $glyphs->[$i];
            $glyph_id_old_to_new{$i} = $#new_glyphs;
            $glyph_id_new_to_old{$#new_glyphs} = $i;
        }
    }
    $font->{loca}{glyphs} = \@new_glyphs;
    $font->{maxp}{numGlyphs} = scalar @new_glyphs;

    $self->{glyph_id_old_to_new} = \%glyph_id_old_to_new;
    $self->{glyph_id_new_to_old} = \%glyph_id_new_to_old;
}


# Only the platform=3 encoding=1 cmap is really needed
# (for Windows, OS X, Linux), so save space (and potentially
# enhance cross-platformness) by stripping out all the others.
# (But keep platform=3 encoding=10 too, for UCS-4 characters.)
# (And Opera 10 on OS X wants one with platform=0 too.)
sub strip_cmap {
    my ($self) = @_;
    my $font = $self->{font};

    if (not grep { $_->{Platform} == 3 and $_->{Encoding} == 1 } @{$font->{cmap}{Tables}}) {
        warn "No cmap found with platform=3 encoding=1 - the font is likely to not work on Windows.\n";
        # Stop now, instead of stripping out all of the cmap tables
        return;
    }

    my @matched_tables = grep {
            ($_->{Platform} == 3 and ($_->{Encoding} == 1 || $_->{Encoding} == 10))
            or ($_->{Platform} == 0)
        } @{$font->{cmap}{Tables}};

    $font->{cmap}{Tables} = \@matched_tables;
}

# Only the platform=3 encoding=1 names are really needed
# (for Windows, OS X, Linux), so save space (and potentially
# enhance cross-platformness) by stripping out all the others.
sub strip_name {
    my ($self) = @_;
    my $font = $self->{font};

    for my $id (0..$#{$font->{name}{strings}}) {
        my $str = $font->{name}{strings}[$id];
        next if not $str;
        my $plat = 3;
        my $enc = 1;
        my $langs = $str->[$plat][$enc];
        if (not $langs) {
            warn "No name found with id=$id with platform=3 encoding=1 - the font is likely to not work on Windows.\n"
                unless $id == 18; # warn except for some Mac-specific names
            return;
        }
        $font->{name}{strings}[$id] = [];
        $font->{name}{strings}[$id][$plat][$enc] = $langs;
        # NOTE: this keeps all the languages for each string, which is
        # potentially wasteful if there are lots (but in practice most fonts
        # seem to only have English)
    }
}

sub fix_cmap {
    my ($self) = @_;
    my $font = $self->{font};

    # Delete mappings for unwanted glyphs

    for my $table (@{$font->{cmap}{Tables}}) {
        # (Already warned about unrecognised table types
        # in find_codepoint_glyph_mappings)
        my %new_vals;
        for my $cp (keys %{$table->{val}}) {
            my $gid = $table->{val}{$cp};
            if ($self->{wanted_glyphs}{$gid}) {
                $new_vals{$cp} = $self->{glyph_id_old_to_new}{$gid};
            }
        }
        $table->{val} = \%new_vals;
        if ($table->{Format} == 0) {
            @{$table->{val}}{0..255} = map { defined($_) ? $_ : 0 } @{$table->{val}}{0..255};
        }
    }
}

sub fix_head {
    # TODO: Should think about:
    #   created
    #   modified
    #   xMin (depends on glyph data)
    #   yMin (depends on glyph data)
    #   xMax (depends on glyph data)
    #   yMax (depends on glyph data)
}

sub fix_hhea {
    # TODO: Should think about:
    #   advanceWidthMax (depends on hmtx)
    #   minLeftSideBearing (depends on hmtx)
    #   minRightSideBearing (depends on hmtx)
    #   xMaxExtent (depends on hmtx)
}

sub fix_hmtx {
    my ($self) = @_;
    my $font = $self->{font};

    # Map the advance/lsb arrays from old to new glyph ids
    my @new_advances;
    my @new_lsbs;
    for my $gid (0..$font->{maxp}{numGlyphs}-1) {
        push @new_advances, $font->{hmtx}{advance}[$self->{glyph_id_new_to_old}{$gid}];
        push @new_lsbs, $font->{hmtx}{lsb}[$self->{glyph_id_new_to_old}{$gid}];
    }
    $font->{hmtx}{advance} = \@new_advances;
    $font->{hmtx}{lsb} = \@new_lsbs;
}

sub fix_maxp { # Must come after loca, prep, fpgm
    my ($self) = @_;
    my $font = $self->{font};

    # Update some of the 'max' values that Font::TTF
    # is capable of updating
    $font->{maxp}->update;
}

sub fix_os_2 { # Must come after cmap, hmtx, hhea, GPOS, GSUB
    my ($self) = @_;
    my $font = $self->{font};

    # Update some of the metric values that Font::TTF
    # is capable of updating
    $font->{'OS/2'}->update;

    if ($font->{'OS/2'}{Version} >= 2) {
        # TODO: handle cases where these are non-default
        warn "Unexpected defaultChar $font->{'OS/2'}{defaultChar}\n"
            unless $font->{'OS/2'}{defaultChar} == 0;
        warn "Unexpected breakChar $font->{'OS/2'}{breakChar}\n"
            unless $font->{'OS/2'}{breakChar} == 0x20;
    }
}

sub fix_post {
    my ($self) = @_;
    my $font = $self->{font};

    if ($font->{post}{FormatType} == 0) {
        warn "Invalid 'post' table type. (If you're using the obfuscate-font.pl script, make sure it comes *after* the subsetting.)\n";
    }

    # Update PostScript name mappings for new glyph ids
    if ($font->{post}{VAL}) {
        my @new_vals;
        for my $gid (0..$font->{maxp}{numGlyphs}-1) {
            push @new_vals, $font->{post}{VAL}[$self->{glyph_id_new_to_old}{$gid}];
        }
        $font->{post}{VAL} = \@new_vals;
    }
}




sub fix_loca {
    my ($self) = @_;
    my $font = $self->{font};

    # remove_unwanted_glyphs has already removed some
    # of the glyph data from this table

    # Update references inside composite glyphs
    for my $glyph (@{$font->{loca}{glyphs}}) {
        next unless $glyph;
        $glyph->read;
        next unless $glyph->{numberOfContours} == -1;
        $glyph->read_dat;
        for (@{$glyph->{comps}}) {
            # (find_unwanted_glyphs guarantees that the
            # component glyphs will be present)
            $_->{glyph} = $self->{glyph_id_old_to_new}{$_->{glyph}};
        }
    }
}



sub fix_gdef {
    my ($self) = @_;
    my $font = $self->{font};

    if ($font->{GDEF}{GLYPH}) {
        $font->{GDEF}{GLYPH} = $self->update_classdef_table($font->{GDEF}{GLYPH});
        if ($self->empty_coverage($font->{GDEF}{GLYPH})) {
            delete $font->{GDEF}{GLYPH};
        }
    }

    if ($font->{GDEF}{MARKS}) {
        $font->{GDEF}{MARKS} = $self->update_classdef_table($font->{GDEF}{MARKS});
        if ($self->empty_coverage($font->{GDEF}{MARKS})) {
            delete $font->{GDEF}{MARKS};
        }
    }

    if ($font->{GDEF}{ATTACH}) {
        die "TODO" if $font->{GDEF}{ATTACH}{POINTS};
        $font->{GDEF}{ATTACH}{COVERAGE} = $self->update_coverage_table($font->{GDEF}{ATTACH}{COVERAGE});
        if ($self->empty_coverage($font->{GDEF}{ATTACH}{COVERAGE})) {
            delete $font->{GDEF}{ATTACH};
        }
    }

    if ($font->{GDEF}{LIG}) {

        if ($font->{GDEF}{LIG}{LIGS}) {
            die "GDEF LIG LIGS != COVERAGE" if
                @{$font->{GDEF}{LIG}{LIGS}} != keys %{$font->{GDEF}{LIG}{COVERAGE}{val}};

            my @coverage_map;
            ($font->{GDEF}{LIG}{COVERAGE}, @coverage_map) = $self->update_mapped_coverage_table($font->{GDEF}{LIG}{COVERAGE});
            $font->{GDEF}{LIG}{LIGS} = [ map $font->{GDEF}{LIG}{LIGS}[$_], @coverage_map ];

        } else {
            $font->{GDEF}{LIG}{COVERAGE} = $self->update_coverage_table($font->{GDEF}{LIG}{COVERAGE});
        }

        if ($self->empty_coverage($font->{GDEF}{LIG}{COVERAGE})) {
            delete $font->{GDEF}{LIG};
        }
    }

}

sub fix_ttopen {
    my ($self, $table, $inner) = @_;

    my @lookups;
    my %lookup_map;
    for my $lookup_id ($self->find_wanted_lookup_ids($table)) {
        my $lookup = $table->{LOOKUP}[$lookup_id];
        my @subtables;
        for my $sub (@{$lookup->{SUB}}) {
            if ($inner->($lookup, $sub)) {
                push @subtables, $sub;
            }
        }

        # Only keep lookups that have some subtables
        if (@subtables) {
            $lookup->{SUB} = \@subtables;
            push @lookups, $lookup;
            $lookup_map{$lookup_id} = $#lookups;
        }
    }

    $table->{LOOKUP} = \@lookups;

    # Update lookup references inside actions
    for my $lookup (@{$table->{LOOKUP}}) {
        for my $sub (@{$lookup->{SUB}}) {
            if ($sub->{ACTION_TYPE} eq 'l') {
                for my $rule (@{$sub->{RULES}}) {
                    for my $chain (@$rule) {
                        my @actions;
                        for my $action (@{$chain->{ACTION}}) {
                            my @steps;
                            for (0..@$action/2-1) {
                                # action is array of (offset, lookup)
                                # so just update the lookup
                                if (exists $lookup_map{$action->[$_*2+1]}) {
                                    push @steps, ($action->[$_*2], $lookup_map{$action->[$_*2+1]});
                                }
                            }
                            push @actions, \@steps;
                        }
                        $chain->{ACTION} = \@actions;
                    }
                }
            }
        }
    }
    
    # Remove all features that are not wanted
    # and update all references to those features (in the languages list),
    # and update the features' lookup references

    my @features; # array of [tag, feature]
    my %kept_features;
    for my $feat_tag (@{$table->{FEATURES}{FEAT_TAGS}}) {
        next unless $self->want_feature($self->{features}, $feat_tag); # drop unwanted features
        my $feat = $table->{FEATURES}{$feat_tag};
        $feat->{LOOKUPS} = [ map { exists $lookup_map{$_} ? ($lookup_map{$_}) : () } @{$feat->{LOOKUPS}} ];
        next unless @{$feat->{LOOKUPS}}; # drop empty features to save some space
        push @features, [ $feat_tag, $feat ];
        $kept_features{$feat_tag} = 1;
    }

    $table->{FEATURES} = {
        FEAT_TAGS => [map $_->[0], @features],
        map +($_->[0] => $_->[1]), @features,
    };

    # Remove any references from scripts to features that no longer exist
    for my $script_tag (keys %{$table->{SCRIPTS}}) {
        my $script = $table->{SCRIPTS}{$script_tag};
        for my $tag ('DEFAULT', @{$script->{LANG_TAGS}}) {
            next if $script->{$tag}{' REFTAG'}; # ignore langs that are just copies of another
            $script->{$tag}{FEATURES} = [
                grep $kept_features{$_}, @{$script->{$tag}{FEATURES}}
            ];

        }
    }

    # TODO: it'd be nice to delete languages that have no features

}

sub fix_gpos {
    my ($self) = @_;
    my $font = $self->{font};

    $self->fix_ttopen($font->{GPOS},
        sub {
            my ($lookup, $sub) = @_;

            # There's always a COVERAGE here first.
            # (If it's empty, the client will skip the entire subtable,
            # so we could delete it entirely, but that would involve updating
            # the FEATURES->*->LOOKUPS lists too, so don't do that yet.)
            #
            # The rest depends on Type:
            # 
            # Lookup Type 1 (Single Adjustment Positioning Subtable):
            # Format 1: Just COVERAGE, applies same value to all
            # Format 2: Just COVERAGE, RULES[n] gives value for each
            #
            # Lookup Type 2 (Pair Adjustment Positioning Subtable):
            # Format 1: COVERAGE gives first glyph, RULES[n][m]{MATCH}[0] gives second glyph
            # Format 2: COVERAGE gives first glyph, CLASS gives first glyph class, MATCH[0] gives second glyph class
            #
            # Lookup Type 3 (Cursive Attachment Positioning Subtable):
            # Format 1: Just COVERAGE, RULES[n] gives value for each
            #
            # Lookup Type 4 (MarkToBase Attachment Positioning Subtable):
            # Format 1: MATCH[0] gives mark coverage, COVERAGE gives base coverage, MARKS[n] per mark, RULES[n] per base
            #
            # Lookup Type 5 (MarkToLigature Attachment Positioning Subtable):
            # Format 1: pretty much the same as 4, but s/base/ligature/
            #
            # Lookup Type 6 (MarkToMark Attachment Positioning Subtable):
            # Format 1: pretty much the same as 4, but s/base/mark/
            #
            # Lookup Type 7 (Contextual Positioning Subtables):
            # Format 1: COVERAGE gives first glyph, RULES[n][m]{MATCH}[o] gives next glyphs
            # Format 2: COVERAGE gives first glyph, CLASS gives classes to glyphs, RULES[n] is per class
            # Format 3: COVERAGE absent, RULES[0][0]{MATCH}[o] gives glyph coverages
            #
            # Lookup Type 8 (Chaining Contextual Positioning Subtable):
            # Format 1: COVERAGE gives first glyph, RULES[n][m]{PRE/MATCH/POST} give context glyphs
            # Format 2: COVERAGE gives first glyph, PRE_CLASS/CLASS/POST_CLASS give classes
            # Format 3: COVERAGE absent, RULES[0][0]{PRE/MATCH/POST}[o] give coverages
            #
            # Lookup Type 9 (Extension Positioning):
            # Not supported

            die if $lookup->{TYPE} >= 9;

            # Update the COVERAGE table, and remember some mapping
            # information to update things that refer to the table
            my @coverage_map;
            my $old_coverage_count;
            if ($sub->{COVERAGE}) {
                $old_coverage_count = scalar keys %{$sub->{COVERAGE}{val}};
                ($sub->{COVERAGE}, @coverage_map) = $self->update_mapped_coverage_table($sub->{COVERAGE});

                # If there's no coverage left, then drop this subtable
                return 0 if $self->empty_coverage($sub->{COVERAGE});
            }

            if ($sub->{RULES} and $sub->{COVERAGE} and not
                    # Skip cases where RULES is indexed by CLASS, not COVERAGE
                    (($lookup->{TYPE} == 2 or
                      $lookup->{TYPE} == 7 or
                      $lookup->{TYPE} == 8)
                        and $sub->{FORMAT} == 2)
                ) {
                # There's a RULES array per COVERAGE entry, so
                # shuffle them around to match the new COVERAGE
                if (@{$sub->{RULES}} != $old_coverage_count) {
                    die "Internal error: RULES ($sub->{RULES}) does not match COVERAGE ($sub->{COVERAGE}) -- "
                        . @{$sub->{RULES}} . " vs $old_coverage_count.";
                }
                $sub->{RULES} = [ map $sub->{RULES}[$_], @coverage_map ];
            }

            if (not defined $sub->{MATCH_TYPE} or $sub->{MATCH_TYPE} eq 'g') {
                if ($sub->{MATCH}) {
                    die unless @{$sub->{MATCH}} == 1;
                    die unless $sub->{MARKS};
                    die unless @{$sub->{MARKS}} == keys %{$sub->{MATCH}[0]{val}};
                    my @match_map;
                    ($sub->{MATCH}[0], @match_map) = $self->update_mapped_coverage_table($sub->{MATCH}[0]);

                    # If there's no coverage left, then drop this subtable
                    return 0 if $self->empty_coverage($sub->{MATCH}[0]);

                    # Update MARKS to correspond to the new MATCH coverage
                    $sub->{MARKS} = [ map $sub->{MARKS}[$_], @match_map ];
                }

                # RULES->MATCH is an array of glyphs, so translate them all
                for (@{$sub->{RULES}}) {
                    for (@$_) {
                        $_->{MATCH} = [ map $self->{glyph_id_old_to_new}{$_},
                            grep $self->{wanted_glyphs}{$_}, @{$_->{MATCH}} ];
                    }
                }
            } elsif ($sub->{MATCH_TYPE}) {
                if ($sub->{MATCH_TYPE} eq 'o') {
                    # RULES->MATCH/PRE/POST are arrays of coverage tables, so translate them all
                    die unless @{$sub->{RULES}} == 1;
                    die unless @{$sub->{RULES}[0]} == 1;
                    my $r = $sub->{RULES}[0][0];
                    for my $c (qw(MATCH PRE POST)) {
                        $r->{$c} = [ map $self->update_coverage_table($_), @{$r->{$c}} ] if $r->{$c};
                    }
                } elsif ($sub->{MATCH_TYPE} eq 'c') {
                    die "Didn't expect any rule matches" if grep $_->{MATCH}, map @$_, @{$sub->{RULES}};
                    die unless @{$sub->{MATCH}} == 1;

                    my $class_map;
                    ($sub->{CLASS}, undef, $class_map) = $self->update_mapped_classdef_table($sub->{CLASS});
                    # Special case: If this results in an empty CLASS, it'll
                    # break in FF3.5 on Linux, so assign all the COVERAGE glyphs onto
                    # class 1 and update $class_map appropriately
                    if ($sub->{CLASS}{max} == 0) {
                        $sub->{CLASS} = new Font::TTF::Coverage(0, map +($_ => 1), keys %{$sub->{COVERAGE}{val}});
                        $class_map = [0, 0]; # just duplicate class 0 into class 1 (this is a bit inefficient)
                    }

                    $sub->{RULES} = [ @{$sub->{RULES}}[@$class_map] ];

                    # Update the MATCH classdef table
                    my $match_map;
                    ($sub->{MATCH}[0], undef, $match_map) = $self->update_mapped_classdef_table($sub->{MATCH}[0]);

                    # If the MATCH table is now empty, drop this lookup
                    # (else FF3.5 on Linux drops the GPOS table entirely)
                    return 0 if @$match_map <= 1;

                    # RULES[n] is a list of substitutions per MATCH class, so
                    # update all those lists for the new classdef
                    $sub->{RULES} = [ map { [ @{$_}[@$match_map] ] } @{$sub->{RULES}} ];

                } else {
                    die "Invalid MATCH_TYPE";
                }
            }

            if (($lookup->{TYPE} == 7 or
                 $lookup->{TYPE} == 8)
                    and $sub->{FORMAT} == 2) {
                # Update some class tables
                for my $c (qw(CLASS PRE_CLASS POST_CLASS)) {
                    $sub->{$c} = $self->update_classdef_table($sub->{$c}) if $sub->{$c};
                }
            }

            return 1;
        }
    );
}

sub fix_gsub {
    my ($self) = @_;
    my $font = $self->{font};

    $self->fix_ttopen($font->{GSUB},
        sub {
            my ($lookup, $sub) = @_;

            # There's always a COVERAGE here first.
            # (If it's empty, the client will skip the entire subtable,
            # so we could delete it entirely, but that would involve updating
            # the FEATURES->*->LOOKUPS lists and Contextual subtable indexes
            # too, so don't do that yet.)
            #
            # The rest depends on Type:
            #
            # Lookup Type 1 (Single Substitution Subtable):
            # Format 1: Just COVERAGE, and ADJUST gives glyph id delta
            # Format 2: Just COVERAGE, then RULES[n]{ACTION}[0] gives replacement glyph for each
            #
            # Lookup Type 2 (Multiple Substitution Subtable):
            # Format 1: Just COVERAGE, then RULES[n]{ACTION} gives replacement glyphs (must be at least 1)
            #
            # Lookup Type 3 (Alternate Substitution Subtable):
            # Format 1: Just COVERAGE, then RULES[n]{ACTION} gives alternate glyphs
            # [This can just be deleted since we have no way to use those glyphs]
            #
            # Lookup Type 4 (Ligature Substitution Subtable):
            # Format 1: COVERAGE gives first glyph, RULES[n]{MATCH}[m] gives next glyphs to match, RULES[n]{ACTION}[0] gives replacement glyph
            #
            # Lookup Type 5 (Contextual Substitution Subtable):
            # Format *: like type 7 in GPOS, but ACTION gives indexes into GSUB{LOOKUP}
            #
            # Lookup Type 6 (Chaining Contextual Substitution Subtable):
            # Format *: like type 8 in GPOS, but ACTION gives indexes into GSUB{LOOKUP}
            #
            # Lookup Type 7 (Extension Substitution):
            # Blah

            die if $lookup->{TYPE} >= 7;

            # Update the COVERAGE table, and remember some mapping
            # information to update things that refer to the table
            my @coverage_map;
            my $old_coverage_count;
            if ($sub->{COVERAGE}) {
                $old_coverage_count = scalar keys %{$sub->{COVERAGE}{val}};
                ($sub->{COVERAGE}, @coverage_map) = $self->update_mapped_coverage_table($sub->{COVERAGE});

                # If there's no coverage left, then drop this subtable
                return 0 if $self->empty_coverage($sub->{COVERAGE});
            }

            if ($sub->{ACTION_TYPE} eq 'o') {;
                my $adj = $sub->{ADJUST};
                if ($adj >= 32768) { $adj -= 65536 } # fix Font::TTF::Bug (http://rt.cpan.org/Ticket/Display.html?id=42727)
                my @covs = $self->coverage_array($sub->{COVERAGE});
                if (@covs == 0) {
                    # Nothing's covered, but deleting this whole subtable is
                    # non-trivial so just zero it out
                    $sub->{ADJUST} = 0;
                } elsif (@covs == 1) {
                    my $gid_base = $covs[0];
                    my $old_gid_base = $self->{glyph_id_new_to_old}{$gid_base};
                    my $old_gid = $old_gid_base + $adj;
                    $sub->{ADJUST} = $self->{glyph_id_old_to_new}{$old_gid} - $gid_base;
                } else {
                    # The glyphs are probably all reordered, so we can't just
                    # adjust ADJUST.
                    # So switch this to a format 2 table:
                    $sub->{FORMAT} = 2;
                    $sub->{ACTION_TYPE} = 'g';
                    delete $sub->{ADJUST};
                    my @gids;
                    for (@covs) {
                        push @gids, $self->{glyph_id_old_to_new}{$self->{glyph_id_new_to_old}{$_} + $adj};
                    }
                    $sub->{RULES} = [ map [{ACTION => [$_]}], @gids ];
                }
                # Stop and keep this table, since done everything that's needed
                return 1;
            }
            die if $sub->{ADJUST};

            if ($sub->{RULES} and not
                    # Skip cases where RULES is indexed by CLASS, not COVERAGE,
                    # and cases where there's no COVERAGE at all
                    (($lookup->{TYPE} == 5 or $lookup->{TYPE} == 6)
                        and ($sub->{FORMAT} == 2 or $sub->{FORMAT} == 3))
                ) {
                # There's a RULES array per COVERAGE entry, so
                # shuffle them around to match the new COVERAGE
                die unless @{$sub->{RULES}} == $old_coverage_count;
                $sub->{RULES} = [ map $sub->{RULES}[$_], @coverage_map ];
            }

            # TODO: refactor
            if ($sub->{MATCH_TYPE}) {
                # Fix all the glyph indexes
                if ($sub->{MATCH_TYPE} eq 'g') {
                    # RULES->MATCH/PRE/POST are arrays of glyphs, so translate them all,
                    # and if they rely on any unwanted glyphs then drop the rule entirely
                    for my $i (0..$#{$sub->{RULES}}) {
                        my $ruleset = $sub->{RULES}[$i];
                        my @rules;
                        RULE: for my $rule (@$ruleset) {
                            for my $c (qw(MATCH PRE POST)) {
                                next unless $rule->{$c};
                                next RULE if grep { not $self->{wanted_glyphs}{$_} } @{$rule->{$c}};
                                $rule->{$c} = [ map $self->{glyph_id_old_to_new}{$_}, @{$rule->{$c}} ]
                            }
                            push @rules, $rule;
                        }
                        if (not @rules) {
                            # XXX: This is a really horrid hack.
                            # The proper solution is to delete the ruleset,
                            # and adjust COVERAGE to match.
                            push @rules, { ACTION => [0], MATCH => [-1] };
                        }
                        $sub->{RULES}[$i] = \@rules;
                    }
                } elsif ($sub->{MATCH_TYPE} eq 'o') {
                    # RULES->MATCH/PRE/POST are arrays of coverage tables, so translate them all
                    die unless @{$sub->{RULES}} == 1;
                    die unless @{$sub->{RULES}[0]} == 1;
                    my $r = $sub->{RULES}[0][0];
                    for my $c (qw(MATCH PRE POST)) {
                        $r->{$c} = [ map $self->update_coverage_table($_), @{$r->{$c}} ] if $r->{$c};
                    }
                } elsif ($sub->{MATCH_TYPE} eq 'c') {
                    # RULES refers to class values, which haven't changed at all,
                    # so we don't need to update those values
                } else {
                    die "Invalid MATCH_TYPE";
                }
            }

            my %class_maps;
            for my $c (qw(CLASS PRE_CLASS POST_CLASS)) {
                ($sub->{$c}, $class_maps{$c}) = $self->update_mapped_classdef_table($sub->{$c}) if $sub->{$c};
            }


            if ($sub->{MATCH_TYPE} and $sub->{MATCH_TYPE} eq 'c') {
                # To make things work in Pango, we need to change all the
                # class numbers so there aren't gaps:
                my %classes = (
                    MATCH => 'CLASS',
                    PRE => 'PRE_CLASS',
                    POST => 'POST_CLASS',
                );
                my @rules;
                for my $rule (@{$sub->{RULES}}) {
                    my @chains;
                    CHAIN: for my $chain (@$rule) {
                        for my $c (qw(MATCH PRE POST)) {
                            next unless $chain->{$c};
                            my $map = $class_maps{$classes{$c}} or die "Got a $c but no $classes{$c}";
                            # If any of the values are for a class that no longer has
                            # any entries, we should drop this whole chain because
                            # there's no chance it's going to match
                            next CHAIN if grep { not defined $map->[$_] } @{$chain->{$c}};
                            # Otherwise just update the class numbers
                            $chain->{$c} = [ map $map->[$_], @{$chain->{$c}} ];
                        }
                        push @chains, $chain;
                    }
                    push @rules, \@chains;
                }
                $sub->{RULES} = \@rules;
                # If all the rules are empty, drop this whole subtable (which maybe is
                # needed to avoid https://bugzilla.mozilla.org/show_bug.cgi?id=475242 ?)
                return 0 if not grep @$_, @{$sub->{RULES}};
            }

            if ($sub->{ACTION_TYPE}) {
                if ($sub->{ACTION_TYPE} eq 'g') {
                    for (@{$sub->{RULES}}) {
                        for (@$_) {
                            $_->{ACTION} = [ map $self->{glyph_id_old_to_new}{$_},
                                grep $self->{wanted_glyphs}{$_}, @{$_->{ACTION}} ];
                        }
                    }
                } elsif ($sub->{ACTION_TYPE} eq 'l') {
                    # nothing to change here
                } elsif ($sub->{ACTION_TYPE} eq 'a') {
                    # We don't want to bother with alternate glyphs at all,
                    # so just delete everything.
                    # (We need to have empty rules, and can't just delete them
                    # entirely, else FontTools becomes unhappy.)
                    # (TODO: Maybe we do want alternate glyphs?
                    # If so, be sure to update find_wanted_glyphs too) 
                    for (@{$sub->{RULES}}) {
                        for (@$_) {
                            $_->{ACTION} = [];
                        }
                    }
                } elsif ($sub->{ACTION_TYPE} eq 'o') {
                    die "Should have handled ACTION_TYPE o earlier";
                } else {
                    die "Invalid ACTION_TYPE";
                }
            }

            return 1;
        }
    );
}

# Fold certain GSUB features into the cmap table
sub fold_gsub {
    my ($self, $features) = @_;

    my $font = $self->{font};
    my $table = $font->{GSUB};

    # Find the lookup IDs corresponding to the desired features

    my %wanted = (DEFAULT => 0);
    $wanted{$_} = 1 for @$features;

    my %lookups;
    for my $feat_tag (@{$table->{FEATURES}{FEAT_TAGS}}) {
        next if not $self->want_feature(\%wanted, $feat_tag);
        for (@{$table->{FEATURES}{$feat_tag}{LOOKUPS}}) {
            $lookups{$_} = $feat_tag;
        }
    }

    # Find the glyph mapping from those lookups

    my %glyph_map; # (old glyph id => new glyph id)

    for my $lookup_id (0..$#{$table->{LOOKUP}}) {
        next unless exists $lookups{$lookup_id};
        my $lookup = $table->{LOOKUP}[$lookup_id];
        if ($lookup->{TYPE} != 1) {
            warn "GSUB lookup $lookup_id (from feature '$lookups{$lookup_id}') is not a 'single' type lookup (type=$lookup->{TYPE}), and cannot be applied.\n";
            next;
        }

        # For each glyph, only the first substitution per lookup is applied,
        # so we build a map of the firsts for this lookup (then fold it into
        # the global map later)
        my %lookup_glyph_map;

        for my $sub (@{$lookup->{SUB}}) {
            my @covs = $self->coverage_array($sub->{COVERAGE});
            if ($sub->{ACTION_TYPE} eq 'o') {
                my $adj = $sub->{ADJUST};
                if ($adj >= 32768) { $adj -= 65536 } # fix Font::TTF::Bug (http://rt.cpan.org/Ticket/Display.html?id=42727)
                for my $i (0..$#covs) {
                    my $old = $covs[$i];
                    my $new = $old + $adj;
                    $lookup_glyph_map{$old} = $new if not exists $lookup_glyph_map{$old};
                }
            } elsif ($sub->{ACTION_TYPE} eq 'g') {
                next if @covs == 0 and not $sub->{RULES};
                die unless @{$sub->{RULES}} == @covs;
                for my $i (0..$#covs) {
                    my $old = $covs[$i];
                    die unless @{$sub->{RULES}[$i]} == 1;
                    die unless @{$sub->{RULES}[$i][0]{ACTION}} == 1;
                    my $new = $sub->{RULES}[$i][0]{ACTION}[0];
                    $lookup_glyph_map{$old} = $new;
                }
            } else {
                die "Invalid ACTION_TYPE $sub->{ACTION_TYPE}";
            }
        }

        # Fold the lookup's glyph map into the global glyph map
        for my $gid (keys %lookup_glyph_map) {
            # Add any new substitutions
            $glyph_map{$gid} = $lookup_glyph_map{$gid} if not exists $glyph_map{$gid};
        }
        for my $gid (keys %glyph_map) {
            # Handle chained substitutions
            $glyph_map{$gid} = $lookup_glyph_map{$glyph_map{$gid}} if exists $lookup_glyph_map{$glyph_map{$gid}};
        }
    }

    # Apply the glyph mapping to cmap

    for my $table (@{$font->{cmap}{Tables}}) {
        for my $cp (keys %{$table->{val}}) {
            my $gid = $table->{val}{$cp};
            $table->{val}{$cp} = $glyph_map{$gid} if exists $glyph_map{$gid};
        }
    }
}

sub fix_hdmx {
    my ($self) = @_;
    my $font = $self->{font};

    for my $ppem (grep /^\d+$/, keys %{$font->{hdmx}}) {
        my @new_widths;
        for my $gid (0..$font->{maxp}{numGlyphs}-1) {
            push @new_widths, $font->{hdmx}{$ppem}[$self->{glyph_id_new_to_old}{$gid}];
        }
        $font->{hdmx}{$ppem} = \@new_widths;
    }
}

sub fix_kern {
    my ($self) = @_;
    my $font = $self->{font};

    # We don't handle version 1 kern tables yet, so just drop them entirely.
    # http://developer.apple.com/textfonts/TTRefMan/RM06/Chap6kern.html
    # https://bugzilla.mozilla.org/show_bug.cgi?id=487549
    if ($font->{kern}{Version} != 0) {
        warn "Unhandled kern table version $font->{kern}{Version} - deleting all kerning data\n";
        delete $font->{kern};
        return;
    }

    for my $table (@{$font->{kern}{tables}}) {
        if ($table->{type} == 0) {
            my %kern;
            for my $l (keys %{$table->{kern}}) {
                next unless $self->{wanted_glyphs}{$l};
                for my $r (keys %{$table->{kern}{$l}}) {
                    next unless $self->{wanted_glyphs}{$r};
                    $kern{$self->{glyph_id_old_to_new}{$l}}{$self->{glyph_id_old_to_new}{$r}} = $table->{kern}{$l}{$r};
                }
            }
            $table->{kern} = \%kern;
        } elsif ($table->{type} == 2) {
            die "kern table type 2 not supported yet";
        } else {
            die "Invalid kern table type";
        }
    }
}

sub fix_ltsh {
    my ($self) = @_;
    my $font = $self->{font};

    my @glyphs;
    for my $gid (0..$font->{maxp}{numGlyphs}-1) {
        push @glyphs, $font->{LTSH}{glyphs}[$self->{glyph_id_new_to_old}{$gid}];
    }
    $font->{LTSH}{glyphs} = \@glyphs;
}

sub delete_copyright {
    my ($self) = @_;
    my $font = $self->{font};
    # XXX - shouldn't be deleting copyright text
    $font->{name}{strings}[0] = undef;
    $font->{name}{strings}[10] = undef;
    $font->{name}{strings}[13] = undef;
}

sub change_name {
    my ($self, $uid) = @_;
    my $font = $self->{font};

    for (1,3,4,6) {
        my $str = $font->{name}{strings}[$_];
        for my $plat (0..$#$str) {
            next unless $str->[$plat];
            for my $enc (0..$#{$str->[$plat]}) {
                next unless $str->[$plat][$enc];
                for my $lang (keys %{$str->[$plat][$enc]}) {
                    next unless exists $str->[$plat][$enc]{$lang};
                    $str->[$plat][$enc]{$lang} = "$uid - subset of " . $str->[$plat][$enc]{$lang};
                }
            }
        }
    }
}

sub license_desc_subst {
    my ($self, $new) = @_;
    my $font = $self->{font};

    my $str = $font->{name}{strings}[13];
    for my $plat (0..$#$str) {
        next unless $str->[$plat];
        for my $enc (0..$#{$str->[$plat]}) {
            next unless $str->[$plat][$enc];
            for my $lang (keys %{$str->[$plat][$enc]}) {
                next unless exists $str->[$plat][$enc]{$lang};
                $str->[$plat][$enc]{$lang} =~ s/\$\{LICENSESUBST\}/$new/g;
            }
        }
    }
}

# IE silently rejects non-CFF fonts if the Font Family Name is not a prefix of
# the Full Font Name. This can occur when automatically converting CFF fonts
# to non-CFF fonts, so it's useful to check and fix it here.
sub fix_full_font_name {
    my ($self, $new) = @_;
    my $font = $self->{font};

    my $str1 = $font->{name}{strings}[1];
    for my $plat (0..$#$str1) {
        next unless $str1->[$plat];
        for my $enc (0..$#{$str1->[$plat]}) {
            next unless $str1->[$plat][$enc];
            for my $lang (keys %{$str1->[$plat][$enc]}) {
                next unless exists $str1->[$plat][$enc]{$lang};
                my $name = $str1->[$plat][$enc]{$lang};
                my $fullname = $font->{name}{strings}[4][$plat][$enc]{$lang};
                if (substr($fullname, 0, length $name) ne $name) {
                    warn "Full Name ('$fullname') does not start with Family Name ('$name') and will break in IE - fixing automatically\n";
                    $font->{name}{strings}[4][$plat][$enc]{$lang} = $name;
                }
            }
        }
    }
}

sub new {
    my $class = shift;
    my $self = {};
    bless $self, $class;
    return $self;
}

sub preload {
    my ($self, $filename) = @_;
    my $font = Font::TTF::Font->open($filename) or die "Failed to open $filename: $!";
    $self->{font} = $font;
    $self->read_tables;
}

sub subset {
    my ($self, $filename, $chars, $options) = @_;

    $self->{features} = $options->{features};

    my $uid = substr(sha1_hex("$filename $chars"), 0, 16);

    if (not $self->{font}) {
        $self->preload($filename);
    }

    my $font = $self->{font};

    $self->check_tables;

    $self->{num_glyphs_old} = $font->{maxp}{numGlyphs};

    $self->fold_gsub($options->{fold_features})
        if $options->{fold_features};

    my $fsType = $font->{'OS/2'}{fsType};
    warn "fsType is $fsType - subsetting and embedding might not be permitted by the license\n" if $fsType != 0;

    $self->strip_cmap;
    $self->strip_name;

    $self->find_codepoint_glyph_mappings;
    $self->find_wanted_glyphs($chars);
    $self->remove_unwanted_glyphs;

    $self->fix_cmap;
    $self->fix_head;
    $self->fix_hhea;
    $self->fix_hmtx;
    # name: nothing to fix (though maybe could be optimised?)
    $self->fix_post;

    # cvt_: nothing to fix
    # fpgm: nothing to fix
    # glyf: just a stub, in Font::TTF
    $self->fix_loca;
    # prep: nothing to fix

    # BASE: TODO
    $self->fix_gdef if $font->{GDEF};
    $self->fix_gpos if $font->{GPOS};
    $self->fix_gsub if $font->{GSUB};
    # JSTF: TODO

    $self->fix_hdmx if $font->{hdmx};
    $self->fix_kern if $font->{kern};
    $self->fix_ltsh if $font->{LTSH};

    $self->fix_maxp; # Must come after loca, prep, fpgm
    $self->fix_os_2; # Must come after cmap, hmtx, hhea, GPOS, GSUB

    $self->fix_full_font_name;

    $self->change_name($uid);

    $self->license_desc_subst($options->{license_desc_subst})
        if defined $options->{license_desc_subst};

    $self->{num_glyphs_new} = $font->{maxp}{numGlyphs};
}

sub num_glyphs_old {
    my ($self) = @_;
    return $self->{num_glyphs_old};
}

sub num_glyphs_new {
    my ($self) = @_;
    return $self->{num_glyphs_new};
}

sub glyph_names {
    my ($self) = @_;
    my $font = $self->{font};
    if (@{$font->{post}{VAL}}) {
        return @{$font->{post}{VAL}};
    }
    my $n = $#{$font->{loca}{glyphs}};
    return join ' ', map { chr($_) =~ /[a-zA-Z0-9- \|]/ ? "'".chr($_)."'" : sprintf 'U+%04x', $_ } map { keys %{$self->{glyphs}{$_}} }
        map $self->{glyph_id_new_to_old}{$_}, 0..$n;
}

sub feature_status {
    my ($self) = @_;
    my $font = $self->{font};
    my %feats;
    my @feats;
    for my $table (grep defined, $font->{GPOS}, $font->{GSUB}) {
        for my $feature (@{$table->{FEATURES}{FEAT_TAGS}}) {
            $feature =~ /^(\w{4})( _\d+)?$/ or die "Unrecognised feature tag syntax '$feature'";
            my $tag = $1;
            next if $feats{$tag}++;
            push @feats, $tag;
        }
    }
    return @feats;
}

sub write {
    my ($self, $fh) = @_;
    my $font = $self->{font};
    $font->out($fh) or die $!;
}

sub release {
    my ($self) = @_;
    my $font = $self->{font};
    $font->release;
}

1;