--- /dev/null
+# 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. á 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(encode_utf8("$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;
fnp / librarian.git / blobdiff