X-Git-Url: https://git.mdrn.pl/librarian.git/blobdiff_plain/ef7911fba9c330552599bc6eb9dc22606246dd7e..68b03397a0872d10d3627cea2b92ae36bd59183c:/font-optimizer/Font/Subsetter.pm diff --git a/font-optimizer/Font/Subsetter.pm b/font-optimizer/Font/Subsetter.pm new file mode 100644 index 0000000..cd1c40c --- /dev/null +++ b/font-optimizer/Font/Subsetter.pm @@ -0,0 +1,1606 @@ +# 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 ."; +} + +# 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("$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;