X-Git-Url: https://git.mdrn.pl/librarian.git/blobdiff_plain/e316fc14bef26f958937aec0e6854b61f71a3b34..09dded3d8606e8e4406fffcf477ceb4a1c97fee2:/font-optimizer/Font/Subsetter.pm?ds=inline diff --git a/font-optimizer/Font/Subsetter.pm b/font-optimizer/Font/Subsetter.pm deleted file mode 100644 index cd1c40c..0000000 --- a/font-optimizer/Font/Subsetter.pm +++ /dev/null @@ -1,1606 +0,0 @@ -# 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;