src/librarian/font-optimizer/Font/Subsetter.pm

   1 # Copyright (c) 2009 Philip Taylor
   2 #
   3 # Permission is hereby granted, free of charge, to any person
   4 # obtaining a copy of this software and associated documentation
   5 # files (the "Software"), to deal in the Software without
   6 # restriction, including without limitation the rights to use,
   7 # copy, modify, merge, publish, distribute, sublicense, and/or sell
   8 # copies of the Software, and to permit persons to whom the
   9 # Software is furnished to do so, subject to the following
  10 # conditions:
  11 #
  12 # The above copyright notice and this permission notice shall be
  13 # included in all copies or substantial portions of the Software.
  14 #
  15 # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  16 # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
  17 # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  18 # NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  19 # HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  20 # WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  21 # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  22 # OTHER DEALINGS IN THE SOFTWARE.
  23
  24 package Font::Subsetter;
  25
  26 use strict;
  27 use warnings;
  28
  29 use Carp;
  30 use Unicode::Normalize();
  31 use Digest::SHA qw(sha1_hex);
  32 use Encode;
  33
  34 use Font::TTF;
  35 use Font::TTF::Font;
  36
  37 if ($Font::TTF::VERSION =~ /^0\.([0-3].|4[0-5])$/) {
  38     die "You are using an old version of Font::TTF ($Font::TTF::VERSION) - you need at least v0.46, and preferably the latest SVN trunk from <http://scripts.sil.org/cms/scripts/page.php?site_id=nrsi&id=fontutils>.";
  39 }
  40
  41 # Tables can be:
  42 #   REQUIRED - will fail if it's not present
  43 #   FORBIDDEN - will fail if it's present
  44 #   OPTIONAL - will be accepted regardless of whether it's there or not
  45 #   IGNORED - like OPTIONAL, but no processing will take place
  46 #   UNFINISHED - will emit a warning if it's present, because the code doesn't handle it properly yet
  47 #   DROP - will be deleted from the font
  48 # The default for unmentioned tables is FORBIDDEN
  49 my %font_tables = (
  50     'cmap' => ['REQUIRED'],
  51     'head' => ['REQUIRED'],
  52     'hhea' => ['REQUIRED'],
  53     'hmtx' => ['REQUIRED'],
  54     'maxp' => ['REQUIRED'],
  55     'name' => ['REQUIRED'],
  56     'OS/2' => ['REQUIRED'],
  57     'post' => ['REQUIRED'],
  58     # TrueType outlines:
  59     'cvt ' => ['IGNORED'],
  60     'fpgm' => ['IGNORED'],
  61     'glyf' => ['IGNORED'],
  62     'loca' => ['OPTIONAL'],
  63     'prep' => ['OPTIONAL'],
  64     # PostScript outlines: (TODO: support these?)
  65     'CFF ' => ['FORBIDDEN'],
  66     'VORG' => ['FORBIDDEN'],
  67     # Bitmap glyphs: (TODO: support these?)
  68     'EBDT' => ['DROP', 'embedded bitmap glyphs will be lost'],
  69     'EBLC' => ['DROP', 'embedded bitmap glyphs will be lost'],
  70     'EBSC' => ['DROP', 'embedded bitmap glyphs will be lost'],
  71     # Advanced typographic tables:
  72     'BASE' => ['UNFINISHED'],
  73     'GDEF' => ['OPTIONAL'],
  74     'GPOS' => ['OPTIONAL'],
  75     'GSUB' => ['OPTIONAL'],
  76     'JSTF' => ['UNFINISHED'],
  77     # OpenType tables:
  78     'DSIG' => ['DROP'], # digital signature - don't need it here
  79     'gasp' => ['IGNORED'],
  80     'hdmx' => ['OPTIONAL'],
  81     'kern' => ['OPTIONAL'],
  82     'LTSH' => ['OPTIONAL'],
  83     'PCLT' => ['UNFINISHED'],
  84     'VDMX' => ['IGNORED'],
  85     'vhea' => ['UNFINISHED'],
  86     'vmtx' => ['UNFINISHED'],
  87     # SIL Graphite tables:
  88     'Feat' => ['DROP'],
  89     'Silf' => ['DROP'],
  90     'Sill' => ['DROP'],
  91     'Silt' => ['DROP'],
  92     'Glat' => ['DROP'],
  93     'Gloc' => ['DROP'],
  94     # FontForge tables:
  95     'PfEd' => ['DROP'],
  96     'FFTM' => ['DROP'],
  97     # Apple Advanced Typography tables:
  98     # (These get dropped because it's better to use cross-platform features instead)
  99     'feat' => ['DROP'],
 100     'morx' => ['DROP'],
 101     'prop' => ['DROP'],
 102     # Undocumented(?) extension for some kind of maths stuff
 103     'MATH' => ['DROP'],
 104 );
 105
 106 sub check_tables {
 107     my ($self) = @_;
 108     my $font = $self->{font};
 109
 110     my @tables = grep /^[^ ]...$/, sort keys %$font;
 111     for (@tables) {
 112         my $t = $font_tables{$_};
 113         if (not $t) {
 114             die "Uses unrecognised table '$_'\n";
 115         } else {
 116             my $status = $t->[0];
 117             if ($status eq 'FORBIDDEN') {
 118                 die "Uses forbidden table '$_'\n";
 119             } elsif ($status eq 'UNFINISHED') {
 120                 warn "Uses unhandled table '$_'\n";
 121             } elsif ($status eq 'DROP') {
 122                 my $note = ($t->[1] ? ' - '.$t->[1] : '');
 123                 warn "Dropping table '$_'$note\n";
 124                 delete $font->{$_};
 125             } elsif ($status eq 'OPTIONAL') {
 126             } elsif ($status eq 'IGNORED') {
 127             } elsif ($status eq 'REQUIRED') {
 128             } else {
 129                 die "Invalid table status $status";
 130             }
 131         }
 132     }
 133     # TODO: check required tables are present
 134     # TODO: check TrueType or PostScript tables are present
 135 }
 136
 137 sub read_tables {
 138     my ($self) = @_;
 139     my $font = $self->{font};
 140
 141     # Read all the tables that will be needed in the future.
 142     # (In particular, read them before modifying numGlyphs,
 143     # beacuse they often depend on that value.)
 144     for (qw(
 145         cmap hmtx name OS/2 post
 146         glyf loca
 147         BASE GDEF GPOS GSUB JSTF
 148         hdmx kern LTSH
 149     )) {
 150         $font->{$_}->read if $font->{$_};
 151     }
 152 }
 153
 154 sub find_codepoint_glyph_mappings {
 155     my ($self) = @_;
 156     my $font = $self->{font};
 157
 158     # Find the glyph->codepoint mappings
 159
 160     my %glyphs;
 161     for my $table (@{$font->{cmap}{Tables}}) {
 162         for my $cp (keys %{$table->{val}}) {
 163
 164             my $ucp; # Unicode code point
 165
 166             if ($table->{Platform} == 0 # Unicode
 167                 or ($table->{Platform} == 3 and # Windows
 168                     ($table->{Encoding} == 1 or # Unicode BMP
 169                      $table->{Encoding} == 10)) # Unicode full
 170             ) {
 171                 $ucp = $cp;
 172             } elsif ($table->{Platform} == 1 # Mac
 173                     and $table->{Encoding} == 0) # Roman
 174             {
 175                 $ucp = ord(decode('MacRoman', pack C => $cp));
 176             } else {
 177                 # This table might not map directly onto Unicode codepoints,
 178                 # so warn about it
 179                 warn "Unrecognised cmap table type (platform $table->{Platform}, encoding $table->{Encoding}) - ignoring its character/glyph mappings\n";
 180                 next;
 181             }
 182
 183             my $g = $table->{val}{$cp}; # glyph id
 184             $glyphs{$g}{$ucp} = 1;
 185         }
 186     }
 187     $self->{glyphs} = \%glyphs;
 188 }
 189
 190 sub expand_wanted_chars {
 191     my ($self, $chars) = @_;
 192     # OS X browsers (via ATSUI?) appear to convert text into
 193     # NFC before rendering it.
 194     # So input like "i{combining grave}" is converted to "{i grave}"
 195     # before it's even passed to the font's substitution tables.
 196     # So if @chars contains i and {combining grave}, then we have to
 197     # add {i grave} because that might get used.
 198     #
 199     # So... Include all the unchanged characters. Also include the NFC
 200     # of each character. Then use NormalizationData to add any characters
 201     # that can result from NFCing a string of the wanted characters.
 202
 203     if (0) { # change to 1 to disable all this fancy stuff
 204         my %cs = map { ord $_ => 1 } split '', $chars;
 205         return %cs;
 206     }
 207
 208     my %cs = map { ord $_ => 1, ord Unicode::Normalize::NFC($_) => 1 } split '', $chars;
 209     require Font::Subsetter::NormalizationData;
 210     my %new_cs;
 211     for my $c (@Font::Subsetter::NormalizationData::data) {
 212         # Skip this if we've already got the composed character
 213         next if $cs{$c->[0]};
 214         # Skip this if we don't have all the decomposed characters
 215         next if grep !$cs{$_}, @{$c}[1..$#$c];
 216         # Otherwise we want the composed character
 217         $new_cs{$c->[0]} = 1;
 218     }
 219     $cs{$_} = 1 for keys %new_cs;
 220     return %cs;
 221 }
 222
 223 sub want_feature {
 224     my ($self, $wanted, $feature) = @_;
 225     # If no feature list was specified, accept all features
 226     return 1 if not $wanted;
 227     # Otherwise find the four-character tag
 228     $feature =~ /^(\w{4})( _\d+)?$/ or die "Unrecognised feature tag syntax '$feature'";
 229     return $wanted->{$1} if exists $wanted->{$1};
 230     return $wanted->{DEFAULT} if exists $wanted->{DEFAULT};
 231     return 1;
 232 }
 233
 234 sub find_wanted_lookup_ids {
 235     my ($self, $table) = @_;
 236
 237     # If we wanted to include all lookups:
 238     #   return 0..$#{$table->{LOOKUP}};
 239     # but actually we only want ones used by wanted features
 240
 241     my %lookups;
 242     for my $feat_tag (@{$table->{FEATURES}{FEAT_TAGS}}) {
 243         next if not $self->want_feature($self->{features}, $feat_tag);
 244         for (@{$table->{FEATURES}{$feat_tag}{LOOKUPS}}) {
 245             $lookups{$_} = 1;
 246         }
 247     }
 248
 249     # Iteratively add any chained lookups
 250     my $changed = 1;
 251     while ($changed) {
 252         $changed = 0;
 253         for my $lookup_id (0..$#{$table->{LOOKUP}}) {
 254             next unless $lookups{$lookup_id};
 255             my $lookup = $table->{LOOKUP}[$lookup_id];
 256             for my $sub (@{$lookup->{SUB}}) {
 257                 if ($sub->{ACTION_TYPE} eq 'l') {
 258                     for my $rule (@{$sub->{RULES}}) {
 259                         for my $chain (@$rule) {
 260                             for my $action (@{$chain->{ACTION}}) {
 261                                 for (0..@$action/2-1) {
 262                                     # action is array of (offset, lookup)
 263                                     $changed = 1 if not $lookups{$action->[$_*2+1]};
 264                                     $lookups{$action->[$_*2+1]} = 1;
 265                                 }
 266                             }
 267                         }
 268                     }
 269                 }
 270             }
 271         }
 272     }
 273
 274     my @keys = sort { $a <=> $b } keys %lookups;
 275     return @keys;
 276 }
 277
 278 sub find_wanted_glyphs {
 279     my ($self, $chars) = @_;
 280     my $font = $self->{font};
 281
 282     my %wanted_chars = $self->expand_wanted_chars($chars);
 283     $self->{wanted_glyphs} = {};
 284
 285     # http://www.microsoft.com/typography/otspec/recom.htm suggests that fonts
 286     # should include .notdef, .null, CR, space; so include them all here, if they
 287     # are already defined
 288     if ($font->{post}{VAL}) {
 289         for my $gid (0..$#{$font->{loca}{glyphs}}) {
 290             my $name = $font->{post}{VAL}[$gid];
 291             if ($name and ($name eq '.notdef' or $name eq '.null' or $name eq 'CR' or $name eq 'space')) {
 292                 $self->{wanted_glyphs}{$gid} = 1;
 293             }
 294         }
 295     } else {
 296         # If post.FormatType == 3 then we don't have any glyph names
 297         # so just assume it's the first four
 298         $self->{wanted_glyphs}{$_} = 1 for 0..3;
 299     }
 300
 301     # We want any glyphs used directly by any characters we want
 302     for my $gid (keys %{$self->{glyphs}}) {
 303         for my $cp (keys %{$self->{glyphs}{$gid}}) {
 304             $self->{wanted_glyphs}{$gid} = 1 if $wanted_chars{$cp};
 305         }
 306     }
 307
 308     # Iteratively find new glyphs, until convergence
 309     my @newly_wanted_glyphs = keys %{$self->{wanted_glyphs}};
 310     while (@newly_wanted_glyphs) {
 311         my @new_glyphs;
 312
 313         if ($font->{GSUB}) {
 314
 315             # Handle ligatures and similar things
 316             # (e.g. if we want 'f' and 'i', we want the 'fi' ligature too)
 317             # (NOTE: a lot of this code is duplicating the form of
 318             # fix_gsub, so they ought to be kept roughly in sync)
 319             #
 320             # TODO: There's probably loads of bugs in here, so it
 321             # should be checked and tested more
 322
 323             for my $lookup_id ($self->find_wanted_lookup_ids($font->{GSUB})) {
 324                 my $lookup = $font->{GSUB}{LOOKUP}[$lookup_id];
 325                 for my $sub (@{$lookup->{SUB}}) {
 326
 327                     # Handle the glyph-delta case
 328                     if ($sub->{ACTION_TYPE} eq 'o') {
 329                         my $adj = $sub->{ADJUST};
 330                         if ($adj >= 32768) { $adj -= 65536 } # fix Font::TTF::Bug (http://rt.cpan.org/Ticket/Display.html?id=42727)
 331                         my @covs = $self->coverage_array($sub->{COVERAGE});
 332                         for (@covs) {
 333                             # If we want the coveraged glyph, we also want
 334                             # that glyph plus delta
 335                             if ($self->{wanted_glyphs}{$_}) {
 336                                 my $new = $_ + $adj;
 337                                 next if $self->{wanted_glyphs}{$new};
 338                                 push @new_glyphs, $new;
 339                                 $self->{wanted_glyphs}{$new} = 1;
 340                             }
 341                         }
 342                         next;
 343                     }
 344
 345                     # Collect the rules which might match initially something
 346                     my @rulesets;
 347                     if ($sub->{RULES}) {
 348                         if (($lookup->{TYPE} == 5 or $lookup->{TYPE} == 6)
 349                             and $sub->{FORMAT} == 2) {
 350                             # RULES corresponds to class values
 351                             # TODO: ought to filter this by classes that contain wanted glyphs
 352                             push @rulesets, @{$sub->{RULES}};
 353                         } elsif (($lookup->{TYPE} == 5 or $lookup->{TYPE} == 6)
 354                             and $sub->{FORMAT} == 3) {
 355                             # COVERAGE is empty; accept all the RULEs, and
 356                             # we'll look inside their MATCHes later
 357                             push @rulesets, @{$sub->{RULES}};
 358                         } else {
 359                             # COVERAGE lists glyphs, and there's a RULE for
 360                             # each, so extract the RULEs for wanted COVERAGE
 361                             # values
 362                             my @covs = $self->coverage_array($sub->{COVERAGE});
 363                             die unless @{$sub->{RULES}} == @covs;
 364                             for my $i (0..$#covs) {
 365                                 if ($self->{wanted_glyphs}{$covs[$i]}) {
 366                                     push @rulesets, $sub->{RULES}[$i];
 367                                 }
 368                             }
 369                         }
 370                     }
 371
 372                     # Collect the rules whose MATCH matches
 373                     my @rules;
 374                     RULE: for my $rule (map @$_, @rulesets) {
 375                         if (not defined $sub->{MATCH_TYPE}) {
 376                             # No extra matching other than COVERAGE,
 377                             # so just accept this rule
 378                         } elsif ($sub->{MATCH_TYPE} eq 'g') {
 379                             # RULES->MATCH/PRE/POST are arrays of glyphs that must all match
 380                             for my $c (qw(MATCH PRE POST)) {
 381                                 next unless $rule->{$c};
 382                                 next RULE if grep { not $self->{wanted_glyphs}{$_} } @{$rule->{$c}};
 383                             }
 384                         } elsif ($sub->{MATCH_TYPE} eq 'o') {
 385                             # RULES->MATCH/PRE/POST are arrays of coverage tables,
 386                             # and at least one glyph from each table must match
 387                             die unless @{$sub->{RULES}} == 1;
 388                             die unless @{$sub->{RULES}[0]} == 1;
 389                             for my $c (qw(MATCH PRE POST)) {
 390                                 next unless $sub->{RULES}[0][0]{$c};
 391                                 for (@{$sub->{RULES}[0][0]{$c}}) {
 392                                     my $matched = 0;
 393                                     for (keys %{$_->{val}}) {
 394                                         if ($self->{wanted_glyphs}{$_}) {
 395                                             $matched = 1;
 396                                             last;
 397                                         }
 398                                     }
 399                                     next RULE if not $matched;
 400                                 }
 401                             }
 402                         } elsif ($sub->{MATCH_TYPE} eq 'c') {
 403                             # TODO: only includes rules using classes that contain
 404                             # wanted glyphs.
 405                             # For now, just conservatively accept everything.
 406                         } else {
 407                             die "Invalid MATCH_TYPE";
 408                         }
 409                         push @rules, $rule;
 410                     }
 411
 412                     # Find the glyphs in the relevant actions
 413                     for my $rule (@rules) {
 414                         if ($sub->{ACTION_TYPE} eq 'g') {
 415                             die unless $rule->{ACTION};
 416                             for my $new (@{$rule->{ACTION}}) {
 417                                 next if $self->{wanted_glyphs}{$new};
 418                                 push @new_glyphs, $new;
 419                                 $self->{wanted_glyphs}{$new} = 1;
 420 #                                warn "adding $new";
 421                             }
 422                         } elsif ($sub->{ACTION_TYPE} eq 'l') {
 423                             # do nothing - this is just a lookup to run some other rules
 424                         } elsif ($sub->{ACTION_TYPE} eq 'a') {
 425                             # do nothing - we don't want the alternative glyphs
 426                         } else {
 427                             die "Invalid ACTION_TYPE";
 428                         }
 429                     }
 430                 }
 431             }
 432         }
 433
 434         @newly_wanted_glyphs = @new_glyphs;
 435     }
 436
 437     # Now we want to add glyphs that are used for composite rendering,
 438     # which don't participate in any GSUB behaviour
 439     @newly_wanted_glyphs = keys %{$self->{wanted_glyphs}};
 440     while (@newly_wanted_glyphs) {
 441         my @new_glyphs;
 442
 443         if ($font->{loca}) {
 444             # If we want a composite glyph, we want all of its
 445             # component glyphs too
 446             # (e.g. &aacute; is the 'a' glyph plus the acute glyph):
 447             for my $gid (@newly_wanted_glyphs) {
 448                 my $glyph = $font->{loca}{glyphs}[$gid];
 449                 next unless $glyph;
 450                 $glyph->read;
 451                 next unless $glyph->{numberOfContours} == -1;
 452                 $glyph->read_dat;
 453                 for (@{$glyph->{comps}}) {
 454                     next if $self->{wanted_glyphs}{$_->{glyph}};
 455                     push @new_glyphs, $_->{glyph};
 456                     $self->{wanted_glyphs}{$_->{glyph}} = 1;
 457                 }
 458                 $glyph->update;
 459             }
 460         }
 461
 462         @newly_wanted_glyphs = @new_glyphs;
 463     }
 464 }
 465
 466 sub update_classdef_table {
 467     my ($self, $table) = @_;
 468     die "Expected table" if not $table;
 469     die "Expected classdef" if $table->{cover};
 470     my @vals;
 471     for my $gid (keys %{$table->{val}}) {
 472         next if not $self->{wanted_glyphs}{$gid};
 473         my $v = $table->{val}{$gid};
 474         push @vals, $self->{glyph_id_old_to_new}{$gid}, $v;
 475     }
 476     my $ret = new Font::TTF::Coverage(0, @vals);
 477     # Font::TTF bug (http://rt.cpan.org/Ticket/Display.html?id=42716):
 478     # 'max' is not set by new(), so do it manually:
 479     my $max = 0;
 480     for (values %{$ret->{val}}) { $max = $_ if $_ > $max }
 481     $ret->{max} = $max;
 482     return $ret;
 483 }
 484
 485 # Returns a map such that map[old_class_value] = new_class_value
 486 # (or undef if the class is removed)
 487 # This differs from update_classdef_table in that it can
 488 # reorder and optimise the class ids
 489 sub update_mapped_classdef_table {
 490     my ($self, $table) = @_;
 491     die "Expected table" if not $table;
 492     die "Expected classdef" if $table->{cover};
 493     my @vals;
 494     my %used_classes;
 495     $used_classes{0} = 1; # 0 is implicitly in every classdef
 496     for my $gid (keys %{$table->{val}}) {
 497         next if not $self->{wanted_glyphs}{$gid};
 498         my $v = $table->{val}{$gid};
 499         push @vals, $self->{glyph_id_old_to_new}{$gid}, $v;
 500         $used_classes{$v} = 1;
 501     }
 502
 503     my @map_new_to_old = sort { $a <=> $b } keys %used_classes;
 504     my @map_old_to_new;
 505     $map_old_to_new[$map_new_to_old[$_]] = $_ for 0..$#map_new_to_old;
 506
 507     # Update the class numbers
 508     for (0..@vals/2-1) {
 509         $vals[$_*2+1] = $map_old_to_new[$vals[$_*2+1]];
 510     }
 511
 512     my $ret = new Font::TTF::Coverage(0, @vals);
 513     # Font::TTF bug (http://rt.cpan.org/Ticket/Display.html?id=42716):
 514     # 'max' is not set by new(), so do it manually:
 515     my $max = 0;
 516     for (values %{$ret->{val}}) { $max = $_ if $_ > $max }
 517     $ret->{max} = $max;
 518     return ($ret, \@map_old_to_new, \@map_new_to_old);
 519 }
 520
 521 # Removes unwanted glyphs from a coverage table, for
 522 # cases where nobody else is referring to indexes in this table
 523 sub update_coverage_table {
 524     my ($self, $table) = @_;
 525     die "Expected table" if not $table;
 526     die "Expected cover" if not $table->{cover};
 527     my @vals = keys %{$table->{val}};
 528     @vals = grep $self->{wanted_glyphs}{$_}, @vals;
 529     @vals = sort { $a <=> $b } @vals;
 530     @vals = map $self->{glyph_id_old_to_new}{$_}, @vals;
 531     return new Font::TTF::Coverage(1, @vals);
 532 }
 533
 534 # Returns a map such that map[new_coverage_index] = old_coverage_index
 535 sub update_mapped_coverage_table {
 536     my ($self, $table) = @_;
 537     die "Expected table" if not $table;
 538     die "Expected coverage" if not $table->{cover};
 539
 540     my @map;
 541     my @new_vals;
 542     # Get the covered values (in order)
 543     my @vals = $self->coverage_array($table);
 544     for my $i (0..$#vals) {
 545         # Create a new list of all the wanted values
 546         if ($self->{wanted_glyphs}{$vals[$i]}) {
 547             push @new_vals, $self->{glyph_id_old_to_new}{$vals[$i]};
 548             push @map, $i;
 549         }
 550     }
 551     return (new Font::TTF::Coverage(1, @new_vals), @map);
 552 }
 553
 554 sub coverage_array {
 555     my ($self, $table) = @_;
 556     Carp::confess "Expected table" if not $table;
 557     return sort { $table->{val}{$a} <=> $table->{val}{$b} } keys %{$table->{val}};
 558 }
 559
 560 sub empty_coverage {
 561     my ($self, $table) = @_;
 562     Carp::confess "Expected table" if not $table;
 563     return 1 if not $table->{val};
 564     return 1 if not keys %{$table->{val}};
 565     return 0;
 566 }
 567
 568 # Update the loca table to delete unwanted glyphs.
 569 # Must be called before all the other fix_* methods.
 570 sub remove_unwanted_glyphs {
 571     my ($self) = @_;
 572     my $font = $self->{font};
 573
 574     return unless $font->{loca};
 575
 576     my %glyph_id_old_to_new;
 577     my %glyph_id_new_to_old;
 578
 579     my $glyphs = $font->{loca}{glyphs};
 580     my @new_glyphs;
 581     for my $i (0..$#$glyphs) {
 582         if ($self->{wanted_glyphs}{$i}) {
 583             push @new_glyphs, $glyphs->[$i];
 584             $glyph_id_old_to_new{$i} = $#new_glyphs;
 585             $glyph_id_new_to_old{$#new_glyphs} = $i;
 586         }
 587     }
 588     $font->{loca}{glyphs} = \@new_glyphs;
 589     $font->{maxp}{numGlyphs} = scalar @new_glyphs;
 590
 591     $self->{glyph_id_old_to_new} = \%glyph_id_old_to_new;
 592     $self->{glyph_id_new_to_old} = \%glyph_id_new_to_old;
 593 }
 594
 595
 596 # Only the platform=3 encoding=1 cmap is really needed
 597 # (for Windows, OS X, Linux), so save space (and potentially
 598 # enhance cross-platformness) by stripping out all the others.
 599 # (But keep platform=3 encoding=10 too, for UCS-4 characters.)
 600 # (And Opera 10 on OS X wants one with platform=0 too.)
 601 sub strip_cmap {
 602     my ($self) = @_;
 603     my $font = $self->{font};
 604
 605     if (not grep { $_->{Platform} == 3 and $_->{Encoding} == 1 } @{$font->{cmap}{Tables}}) {
 606         warn "No cmap found with platform=3 encoding=1 - the font is likely to not work on Windows.\n";
 607         # Stop now, instead of stripping out all of the cmap tables
 608         return;
 609     }
 610
 611     my @matched_tables = grep {
 612             ($_->{Platform} == 3 and ($_->{Encoding} == 1 || $_->{Encoding} == 10))
 613             or ($_->{Platform} == 0)
 614         } @{$font->{cmap}{Tables}};
 615
 616     $font->{cmap}{Tables} = \@matched_tables;
 617 }
 618
 619 # Only the platform=3 encoding=1 names are really needed
 620 # (for Windows, OS X, Linux), so save space (and potentially
 621 # enhance cross-platformness) by stripping out all the others.
 622 sub strip_name {
 623     my ($self) = @_;
 624     my $font = $self->{font};
 625
 626     for my $id (0..$#{$font->{name}{strings}}) {
 627         my $str = $font->{name}{strings}[$id];
 628         next if not $str;
 629         my $plat = 3;
 630         my $enc = 1;
 631         my $langs = $str->[$plat][$enc];
 632         if (not $langs) {
 633             warn "No name found with id=$id with platform=3 encoding=1 - the font is likely to not work on Windows.\n"
 634                 unless $id == 18; # warn except for some Mac-specific names
 635             return;
 636         }
 637         $font->{name}{strings}[$id] = [];
 638         $font->{name}{strings}[$id][$plat][$enc] = $langs;
 639         # NOTE: this keeps all the languages for each string, which is
 640         # potentially wasteful if there are lots (but in practice most fonts
 641         # seem to only have English)
 642     }
 643 }
 644
 645 sub fix_cmap {
 646     my ($self) = @_;
 647     my $font = $self->{font};
 648
 649     # Delete mappings for unwanted glyphs
 650
 651     for my $table (@{$font->{cmap}{Tables}}) {
 652         # (Already warned about unrecognised table types
 653         # in find_codepoint_glyph_mappings)
 654         my %new_vals;
 655         for my $cp (keys %{$table->{val}}) {
 656             my $gid = $table->{val}{$cp};
 657             if ($self->{wanted_glyphs}{$gid}) {
 658                 $new_vals{$cp} = $self->{glyph_id_old_to_new}{$gid};
 659             }
 660         }
 661         $table->{val} = \%new_vals;
 662         if ($table->{Format} == 0) {
 663             @{$table->{val}}{0..255} = map { defined($_) ? $_ : 0 } @{$table->{val}}{0..255};
 664         }
 665     }
 666 }
 667
 668 sub fix_head {
 669     # TODO: Should think about:
 670     #   created
 671     #   modified
 672     #   xMin (depends on glyph data)
 673     #   yMin (depends on glyph data)
 674     #   xMax (depends on glyph data)
 675     #   yMax (depends on glyph data)
 676 }
 677
 678 sub fix_hhea {
 679     # TODO: Should think about:
 680     #   advanceWidthMax (depends on hmtx)
 681     #   minLeftSideBearing (depends on hmtx)
 682     #   minRightSideBearing (depends on hmtx)
 683     #   xMaxExtent (depends on hmtx)
 684 }
 685
 686 sub fix_hmtx {
 687     my ($self) = @_;
 688     my $font = $self->{font};
 689
 690     # Map the advance/lsb arrays from old to new glyph ids
 691     my @new_advances;
 692     my @new_lsbs;
 693     for my $gid (0..$font->{maxp}{numGlyphs}-1) {
 694         push @new_advances, $font->{hmtx}{advance}[$self->{glyph_id_new_to_old}{$gid}];
 695         push @new_lsbs, $font->{hmtx}{lsb}[$self->{glyph_id_new_to_old}{$gid}];
 696     }
 697     $font->{hmtx}{advance} = \@new_advances;
 698     $font->{hmtx}{lsb} = \@new_lsbs;
 699 }
 700
 701 sub fix_maxp { # Must come after loca, prep, fpgm
 702     my ($self) = @_;
 703     my $font = $self->{font};
 704
 705     # Update some of the 'max' values that Font::TTF
 706     # is capable of updating
 707     $font->{maxp}->update;
 708 }
 709
 710 sub fix_os_2 { # Must come after cmap, hmtx, hhea, GPOS, GSUB
 711     my ($self) = @_;
 712     my $font = $self->{font};
 713
 714     # Update some of the metric values that Font::TTF
 715     # is capable of updating
 716     $font->{'OS/2'}->update;
 717
 718     if ($font->{'OS/2'}{Version} >= 2) {
 719         # TODO: handle cases where these are non-default
 720         warn "Unexpected defaultChar $font->{'OS/2'}{defaultChar}\n"
 721             unless $font->{'OS/2'}{defaultChar} == 0;
 722         warn "Unexpected breakChar $font->{'OS/2'}{breakChar}\n"
 723             unless $font->{'OS/2'}{breakChar} == 0x20;
 724     }
 725 }
 726
 727 sub fix_post {
 728     my ($self) = @_;
 729     my $font = $self->{font};
 730
 731     if ($font->{post}{FormatType} == 0) {
 732         warn "Invalid 'post' table type. (If you're using the obfuscate-font.pl script, make sure it comes *after* the subsetting.)\n";
 733     }
 734
 735     # Update PostScript name mappings for new glyph ids
 736     if ($font->{post}{VAL}) {
 737         my @new_vals;
 738         for my $gid (0..$font->{maxp}{numGlyphs}-1) {
 739             push @new_vals, $font->{post}{VAL}[$self->{glyph_id_new_to_old}{$gid}];
 740         }
 741         $font->{post}{VAL} = \@new_vals;
 742     }
 743 }
 744
 745
 746
 747
 748 sub fix_loca {
 749     my ($self) = @_;
 750     my $font = $self->{font};
 751
 752     # remove_unwanted_glyphs has already removed some
 753     # of the glyph data from this table
 754
 755     # Update references inside composite glyphs
 756     for my $glyph (@{$font->{loca}{glyphs}}) {
 757         next unless $glyph;
 758         $glyph->read;
 759         next unless $glyph->{numberOfContours} == -1;
 760         $glyph->read_dat;
 761         for (@{$glyph->{comps}}) {
 762             # (find_unwanted_glyphs guarantees that the
 763             # component glyphs will be present)
 764             $_->{glyph} = $self->{glyph_id_old_to_new}{$_->{glyph}};
 765         }
 766     }
 767 }
 768
 769
 770
 771 sub fix_gdef {
 772     my ($self) = @_;
 773     my $font = $self->{font};
 774
 775     if ($font->{GDEF}{GLYPH}) {
 776         $font->{GDEF}{GLYPH} = $self->update_classdef_table($font->{GDEF}{GLYPH});
 777         if ($self->empty_coverage($font->{GDEF}{GLYPH})) {
 778             delete $font->{GDEF}{GLYPH};
 779         }
 780     }
 781
 782     if ($font->{GDEF}{MARKS}) {
 783         $font->{GDEF}{MARKS} = $self->update_classdef_table($font->{GDEF}{MARKS});
 784         if ($self->empty_coverage($font->{GDEF}{MARKS})) {
 785             delete $font->{GDEF}{MARKS};
 786         }
 787     }
 788
 789     if ($font->{GDEF}{ATTACH}) {
 790         die "TODO" if $font->{GDEF}{ATTACH}{POINTS};
 791         $font->{GDEF}{ATTACH}{COVERAGE} = $self->update_coverage_table($font->{GDEF}{ATTACH}{COVERAGE});
 792         if ($self->empty_coverage($font->{GDEF}{ATTACH}{COVERAGE})) {
 793             delete $font->{GDEF}{ATTACH};
 794         }
 795     }
 796
 797     if ($font->{GDEF}{LIG}) {
 798
 799         if ($font->{GDEF}{LIG}{LIGS}) {
 800             die "GDEF LIG LIGS != COVERAGE" if
 801                 @{$font->{GDEF}{LIG}{LIGS}} != keys %{$font->{GDEF}{LIG}{COVERAGE}{val}};
 802
 803             my @coverage_map;
 804             ($font->{GDEF}{LIG}{COVERAGE}, @coverage_map) = $self->update_mapped_coverage_table($font->{GDEF}{LIG}{COVERAGE});
 805             $font->{GDEF}{LIG}{LIGS} = [ map $font->{GDEF}{LIG}{LIGS}[$_], @coverage_map ];
 806
 807         } else {
 808             $font->{GDEF}{LIG}{COVERAGE} = $self->update_coverage_table($font->{GDEF}{LIG}{COVERAGE});
 809         }
 810
 811         if ($self->empty_coverage($font->{GDEF}{LIG}{COVERAGE})) {
 812             delete $font->{GDEF}{LIG};
 813         }
 814     }
 815
 816 }
 817
 818 sub fix_ttopen {
 819     my ($self, $table, $inner) = @_;
 820
 821     my @lookups;
 822     my %lookup_map;
 823     for my $lookup_id ($self->find_wanted_lookup_ids($table)) {
 824         my $lookup = $table->{LOOKUP}[$lookup_id];
 825         my @subtables;
 826         for my $sub (@{$lookup->{SUB}}) {
 827             if ($inner->($lookup, $sub)) {
 828                 push @subtables, $sub;
 829             }
 830         }
 831
 832         # Only keep lookups that have some subtables
 833         if (@subtables) {
 834             $lookup->{SUB} = \@subtables;
 835             push @lookups, $lookup;
 836             $lookup_map{$lookup_id} = $#lookups;
 837         }
 838     }
 839
 840     $table->{LOOKUP} = \@lookups;
 841
 842     # Update lookup references inside actions
 843     for my $lookup (@{$table->{LOOKUP}}) {
 844         for my $sub (@{$lookup->{SUB}}) {
 845             if ($sub->{ACTION_TYPE} eq 'l') {
 846                 for my $rule (@{$sub->{RULES}}) {
 847                     for my $chain (@$rule) {
 848                         my @actions;
 849                         for my $action (@{$chain->{ACTION}}) {
 850                             my @steps;
 851                             for (0..@$action/2-1) {
 852                                 # action is array of (offset, lookup)
 853                                 # so just update the lookup
 854                                 if (exists $lookup_map{$action->[$_*2+1]}) {
 855                                     push @steps, ($action->[$_*2], $lookup_map{$action->[$_*2+1]});
 856                                 }
 857                             }
 858                             push @actions, \@steps;
 859                         }
 860                         $chain->{ACTION} = \@actions;
 861                     }
 862                 }
 863             }
 864         }
 865     }
 866
 867     # Remove all features that are not wanted
 868     # and update all references to those features (in the languages list),
 869     # and update the features' lookup references
 870
 871     my @features; # array of [tag, feature]
 872     my %kept_features;
 873     for my $feat_tag (@{$table->{FEATURES}{FEAT_TAGS}}) {
 874         next unless $self->want_feature($self->{features}, $feat_tag); # drop unwanted features
 875         my $feat = $table->{FEATURES}{$feat_tag};
 876         $feat->{LOOKUPS} = [ map { exists $lookup_map{$_} ? ($lookup_map{$_}) : () } @{$feat->{LOOKUPS}} ];
 877         next unless @{$feat->{LOOKUPS}}; # drop empty features to save some space
 878         push @features, [ $feat_tag, $feat ];
 879         $kept_features{$feat_tag} = 1;
 880     }
 881
 882     $table->{FEATURES} = {
 883         FEAT_TAGS => [map $_->[0], @features],
 884         map +($_->[0] => $_->[1]), @features,
 885     };
 886
 887     # Remove any references from scripts to features that no longer exist
 888     for my $script_tag (keys %{$table->{SCRIPTS}}) {
 889         my $script = $table->{SCRIPTS}{$script_tag};
 890         for my $tag ('DEFAULT', @{$script->{LANG_TAGS}}) {
 891             next if $script->{$tag}{' REFTAG'}; # ignore langs that are just copies of another
 892             $script->{$tag}{FEATURES} = [
 893                 grep $kept_features{$_}, @{$script->{$tag}{FEATURES}}
 894             ];
 895
 896         }
 897     }
 898
 899     # TODO: it'd be nice to delete languages that have no features
 900
 901 }
 902
 903 sub fix_gpos {
 904     my ($self) = @_;
 905     my $font = $self->{font};
 906
 907     $self->fix_ttopen($font->{GPOS},
 908         sub {
 909             my ($lookup, $sub) = @_;
 910
 911             # There's always a COVERAGE here first.
 912             # (If it's empty, the client will skip the entire subtable,
 913             # so we could delete it entirely, but that would involve updating
 914             # the FEATURES->*->LOOKUPS lists too, so don't do that yet.)
 915             #
 916             # The rest depends on Type:
 917             #
 918             # Lookup Type 1 (Single Adjustment Positioning Subtable):
 919             # Format 1: Just COVERAGE, applies same value to all
 920             # Format 2: Just COVERAGE, RULES[n] gives value for each
 921             #
 922             # Lookup Type 2 (Pair Adjustment Positioning Subtable):
 923             # Format 1: COVERAGE gives first glyph, RULES[n][m]{MATCH}[0] gives second glyph
 924             # Format 2: COVERAGE gives first glyph, CLASS gives first glyph class, MATCH[0] gives second glyph class
 925             #
 926             # Lookup Type 3 (Cursive Attachment Positioning Subtable):
 927             # Format 1: Just COVERAGE, RULES[n] gives value for each
 928             #
 929             # Lookup Type 4 (MarkToBase Attachment Positioning Subtable):
 930             # Format 1: MATCH[0] gives mark coverage, COVERAGE gives base coverage, MARKS[n] per mark, RULES[n] per base
 931             #
 932             # Lookup Type 5 (MarkToLigature Attachment Positioning Subtable):
 933             # Format 1: pretty much the same as 4, but s/base/ligature/
 934             #
 935             # Lookup Type 6 (MarkToMark Attachment Positioning Subtable):
 936             # Format 1: pretty much the same as 4, but s/base/mark/
 937             #
 938             # Lookup Type 7 (Contextual Positioning Subtables):
 939             # Format 1: COVERAGE gives first glyph, RULES[n][m]{MATCH}[o] gives next glyphs
 940             # Format 2: COVERAGE gives first glyph, CLASS gives classes to glyphs, RULES[n] is per class
 941             # Format 3: COVERAGE absent, RULES[0][0]{MATCH}[o] gives glyph coverages
 942             #
 943             # Lookup Type 8 (Chaining Contextual Positioning Subtable):
 944             # Format 1: COVERAGE gives first glyph, RULES[n][m]{PRE/MATCH/POST} give context glyphs
 945             # Format 2: COVERAGE gives first glyph, PRE_CLASS/CLASS/POST_CLASS give classes
 946             # Format 3: COVERAGE absent, RULES[0][0]{PRE/MATCH/POST}[o] give coverages
 947             #
 948             # Lookup Type 9 (Extension Positioning):
 949             # Not supported
 950
 951             die if $lookup->{TYPE} >= 9;
 952
 953             # Update the COVERAGE table, and remember some mapping
 954             # information to update things that refer to the table
 955             my @coverage_map;
 956             my $old_coverage_count;
 957             if ($sub->{COVERAGE}) {
 958                 $old_coverage_count = scalar keys %{$sub->{COVERAGE}{val}};
 959                 ($sub->{COVERAGE}, @coverage_map) = $self->update_mapped_coverage_table($sub->{COVERAGE});
 960
 961                 # If there's no coverage left, then drop this subtable
 962                 return 0 if $self->empty_coverage($sub->{COVERAGE});
 963             }
 964
 965             if ($sub->{RULES} and $sub->{COVERAGE} and not
 966                     # Skip cases where RULES is indexed by CLASS, not COVERAGE
 967                     (($lookup->{TYPE} == 2 or
 968                       $lookup->{TYPE} == 7 or
 969                       $lookup->{TYPE} == 8)
 970                         and $sub->{FORMAT} == 2)
 971                 ) {
 972                 # There's a RULES array per COVERAGE entry, so
 973                 # shuffle them around to match the new COVERAGE
 974                 if (@{$sub->{RULES}} != $old_coverage_count) {
 975                     die "Internal error: RULES ($sub->{RULES}) does not match COVERAGE ($sub->{COVERAGE}) -- "
 976                         . @{$sub->{RULES}} . " vs $old_coverage_count.";
 977                 }
 978                 $sub->{RULES} = [ map $sub->{RULES}[$_], @coverage_map ];
 979             }
 980
 981             if (not defined $sub->{MATCH_TYPE} or $sub->{MATCH_TYPE} eq 'g') {
 982                 if ($sub->{MATCH}) {
 983                     die unless @{$sub->{MATCH}} == 1;
 984                     die unless $sub->{MARKS};
 985                     die unless @{$sub->{MARKS}} == keys %{$sub->{MATCH}[0]{val}};
 986                     my @match_map;
 987                     ($sub->{MATCH}[0], @match_map) = $self->update_mapped_coverage_table($sub->{MATCH}[0]);
 988
 989                     # If there's no coverage left, then drop this subtable
 990                     return 0 if $self->empty_coverage($sub->{MATCH}[0]);
 991
 992                     # Update MARKS to correspond to the new MATCH coverage
 993                     $sub->{MARKS} = [ map $sub->{MARKS}[$_], @match_map ];
 994                 }
 995
 996                 # RULES->MATCH is an array of glyphs, so translate them all
 997                 for (@{$sub->{RULES}}) {
 998                     for (@$_) {
 999                         $_->{MATCH} = [ map $self->{glyph_id_old_to_new}{$_},
1000                             grep $self->{wanted_glyphs}{$_}, @{$_->{MATCH}} ];
1001                     }
1002                 }
1003             } elsif ($sub->{MATCH_TYPE}) {
1004                 if ($sub->{MATCH_TYPE} eq 'o') {
1005                     # RULES->MATCH/PRE/POST are arrays of coverage tables, so translate them all
1006                     die unless @{$sub->{RULES}} == 1;
1007                     die unless @{$sub->{RULES}[0]} == 1;
1008                     my $r = $sub->{RULES}[0][0];
1009                     for my $c (qw(MATCH PRE POST)) {
1010                         $r->{$c} = [ map $self->update_coverage_table($_), @{$r->{$c}} ] if $r->{$c};
1011                     }
1012                 } elsif ($sub->{MATCH_TYPE} eq 'c') {
1013                     die "Didn't expect any rule matches" if grep $_->{MATCH}, map @$_, @{$sub->{RULES}};
1014                     die unless @{$sub->{MATCH}} == 1;
1015
1016                     my $class_map;
1017                     ($sub->{CLASS}, undef, $class_map) = $self->update_mapped_classdef_table($sub->{CLASS});
1018                     # Special case: If this results in an empty CLASS, it'll
1019                     # break in FF3.5 on Linux, so assign all the COVERAGE glyphs onto
1020                     # class 1 and update $class_map appropriately
1021                     if ($sub->{CLASS}{max} == 0) {
1022                         $sub->{CLASS} = new Font::TTF::Coverage(0, map +($_ => 1), keys %{$sub->{COVERAGE}{val}});
1023                         $class_map = [0, 0]; # just duplicate class 0 into class 1 (this is a bit inefficient)
1024                     }
1025
1026                     $sub->{RULES} = [ @{$sub->{RULES}}[@$class_map] ];
1027
1028                     # Update the MATCH classdef table
1029                     my $match_map;
1030                     ($sub->{MATCH}[0], undef, $match_map) = $self->update_mapped_classdef_table($sub->{MATCH}[0]);
1031
1032                     # If the MATCH table is now empty, drop this lookup
1033                     # (else FF3.5 on Linux drops the GPOS table entirely)
1034                     return 0 if @$match_map <= 1;
1035
1036                     # RULES[n] is a list of substitutions per MATCH class, so
1037                     # update all those lists for the new classdef
1038                     $sub->{RULES} = [ map { [ @{$_}[@$match_map] ] } @{$sub->{RULES}} ];
1039
1040                 } else {
1041                     die "Invalid MATCH_TYPE";
1042                 }
1043             }
1044
1045             if (($lookup->{TYPE} == 7 or
1046                  $lookup->{TYPE} == 8)
1047                     and $sub->{FORMAT} == 2) {
1048                 # Update some class tables
1049                 for my $c (qw(CLASS PRE_CLASS POST_CLASS)) {
1050                     $sub->{$c} = $self->update_classdef_table($sub->{$c}) if $sub->{$c};
1051                 }
1052             }
1053
1054             return 1;
1055         }
1056     );
1057 }
1058
1059 sub fix_gsub {
1060     my ($self) = @_;
1061     my $font = $self->{font};
1062
1063     $self->fix_ttopen($font->{GSUB},
1064         sub {
1065             my ($lookup, $sub) = @_;
1066
1067             # There's always a COVERAGE here first.
1068             # (If it's empty, the client will skip the entire subtable,
1069             # so we could delete it entirely, but that would involve updating
1070             # the FEATURES->*->LOOKUPS lists and Contextual subtable indexes
1071             # too, so don't do that yet.)
1072             #
1073             # The rest depends on Type:
1074             #
1075             # Lookup Type 1 (Single Substitution Subtable):
1076             # Format 1: Just COVERAGE, and ADJUST gives glyph id delta
1077             # Format 2: Just COVERAGE, then RULES[n]{ACTION}[0] gives replacement glyph for each
1078             #
1079             # Lookup Type 2 (Multiple Substitution Subtable):
1080             # Format 1: Just COVERAGE, then RULES[n]{ACTION} gives replacement glyphs (must be at least 1)
1081             #
1082             # Lookup Type 3 (Alternate Substitution Subtable):
1083             # Format 1: Just COVERAGE, then RULES[n]{ACTION} gives alternate glyphs
1084             # [This can just be deleted since we have no way to use those glyphs]
1085             #
1086             # Lookup Type 4 (Ligature Substitution Subtable):
1087             # Format 1: COVERAGE gives first glyph, RULES[n]{MATCH}[m] gives next glyphs to match, RULES[n]{ACTION}[0] gives replacement glyph
1088             #
1089             # Lookup Type 5 (Contextual Substitution Subtable):
1090             # Format *: like type 7 in GPOS, but ACTION gives indexes into GSUB{LOOKUP}
1091             #
1092             # Lookup Type 6 (Chaining Contextual Substitution Subtable):
1093             # Format *: like type 8 in GPOS, but ACTION gives indexes into GSUB{LOOKUP}
1094             #
1095             # Lookup Type 7 (Extension Substitution):
1096             # Blah
1097
1098             die if $lookup->{TYPE} >= 7;
1099
1100             # Update the COVERAGE table, and remember some mapping
1101             # information to update things that refer to the table
1102             my @coverage_map;
1103             my $old_coverage_count;
1104             if ($sub->{COVERAGE}) {
1105                 $old_coverage_count = scalar keys %{$sub->{COVERAGE}{val}};
1106                 ($sub->{COVERAGE}, @coverage_map) = $self->update_mapped_coverage_table($sub->{COVERAGE});
1107
1108                 # If there's no coverage left, then drop this subtable
1109                 return 0 if $self->empty_coverage($sub->{COVERAGE});
1110             }
1111
1112             if ($sub->{ACTION_TYPE} eq 'o') {;
1113                 my $adj = $sub->{ADJUST};
1114                 if ($adj >= 32768) { $adj -= 65536 } # fix Font::TTF::Bug (http://rt.cpan.org/Ticket/Display.html?id=42727)
1115                 my @covs = $self->coverage_array($sub->{COVERAGE});
1116                 if (@covs == 0) {
1117                     # Nothing's covered, but deleting this whole subtable is
1118                     # non-trivial so just zero it out
1119                     $sub->{ADJUST} = 0;
1120                 } elsif (@covs == 1) {
1121                     my $gid_base = $covs[0];
1122                     my $old_gid_base = $self->{glyph_id_new_to_old}{$gid_base};
1123                     my $old_gid = $old_gid_base + $adj;
1124                     $sub->{ADJUST} = $self->{glyph_id_old_to_new}{$old_gid} - $gid_base;
1125                 } else {
1126                     # The glyphs are probably all reordered, so we can't just
1127                     # adjust ADJUST.
1128                     # So switch this to a format 2 table:
1129                     $sub->{FORMAT} = 2;
1130                     $sub->{ACTION_TYPE} = 'g';
1131                     delete $sub->{ADJUST};
1132                     my @gids;
1133                     for (@covs) {
1134                         push @gids, $self->{glyph_id_old_to_new}{$self->{glyph_id_new_to_old}{$_} + $adj};
1135                     }
1136                     $sub->{RULES} = [ map [{ACTION => [$_]}], @gids ];
1137                 }
1138                 # Stop and keep this table, since done everything that's needed
1139                 return 1;
1140             }
1141             die if $sub->{ADJUST};
1142
1143             if ($sub->{RULES} and not
1144                     # Skip cases where RULES is indexed by CLASS, not COVERAGE,
1145                     # and cases where there's no COVERAGE at all
1146                     (($lookup->{TYPE} == 5 or $lookup->{TYPE} == 6)
1147                         and ($sub->{FORMAT} == 2 or $sub->{FORMAT} == 3))
1148                 ) {
1149                 # There's a RULES array per COVERAGE entry, so
1150                 # shuffle them around to match the new COVERAGE
1151                 die unless @{$sub->{RULES}} == $old_coverage_count;
1152                 $sub->{RULES} = [ map $sub->{RULES}[$_], @coverage_map ];
1153             }
1154
1155             # TODO: refactor
1156             if ($sub->{MATCH_TYPE}) {
1157                 # Fix all the glyph indexes
1158                 if ($sub->{MATCH_TYPE} eq 'g') {
1159                     # RULES->MATCH/PRE/POST are arrays of glyphs, so translate them all,
1160                     # and if they rely on any unwanted glyphs then drop the rule entirely
1161                     for my $i (0..$#{$sub->{RULES}}) {
1162                         my $ruleset = $sub->{RULES}[$i];
1163                         my @rules;
1164                         RULE: for my $rule (@$ruleset) {
1165                             for my $c (qw(MATCH PRE POST)) {
1166                                 next unless $rule->{$c};
1167                                 next RULE if grep { not $self->{wanted_glyphs}{$_} } @{$rule->{$c}};
1168                                 $rule->{$c} = [ map $self->{glyph_id_old_to_new}{$_}, @{$rule->{$c}} ]
1169                             }
1170                             push @rules, $rule;
1171                         }
1172                         if (not @rules) {
1173                             # XXX: This is a really horrid hack.
1174                             # The proper solution is to delete the ruleset,
1175                             # and adjust COVERAGE to match.
1176                             push @rules, { ACTION => [0], MATCH => [-1] };
1177                         }
1178                         $sub->{RULES}[$i] = \@rules;
1179                     }
1180                 } elsif ($sub->{MATCH_TYPE} eq 'o') {
1181                     # RULES->MATCH/PRE/POST are arrays of coverage tables, so translate them all
1182                     die unless @{$sub->{RULES}} == 1;
1183                     die unless @{$sub->{RULES}[0]} == 1;
1184                     my $r = $sub->{RULES}[0][0];
1185                     for my $c (qw(MATCH PRE POST)) {
1186                         $r->{$c} = [ map $self->update_coverage_table($_), @{$r->{$c}} ] if $r->{$c};
1187                     }
1188                 } elsif ($sub->{MATCH_TYPE} eq 'c') {
1189                     # RULES refers to class values, which haven't changed at all,
1190                     # so we don't need to update those values
1191                 } else {
1192                     die "Invalid MATCH_TYPE";
1193                 }
1194             }
1195
1196             my %class_maps;
1197             for my $c (qw(CLASS PRE_CLASS POST_CLASS)) {
1198                 ($sub->{$c}, $class_maps{$c}) = $self->update_mapped_classdef_table($sub->{$c}) if $sub->{$c};
1199             }
1200
1201
1202             if ($sub->{MATCH_TYPE} and $sub->{MATCH_TYPE} eq 'c') {
1203                 # To make things work in Pango, we need to change all the
1204                 # class numbers so there aren't gaps:
1205                 my %classes = (
1206                     MATCH => 'CLASS',
1207                     PRE => 'PRE_CLASS',
1208                     POST => 'POST_CLASS',
1209                 );
1210                 my @rules;
1211                 for my $rule (@{$sub->{RULES}}) {
1212                     my @chains;
1213                     CHAIN: for my $chain (@$rule) {
1214                         for my $c (qw(MATCH PRE POST)) {
1215                             next unless $chain->{$c};
1216                             my $map = $class_maps{$classes{$c}} or die "Got a $c but no $classes{$c}";
1217                             # If any of the values are for a class that no longer has
1218                             # any entries, we should drop this whole chain because
1219                             # there's no chance it's going to match
1220                             next CHAIN if grep { not defined $map->[$_] } @{$chain->{$c}};
1221                             # Otherwise just update the class numbers
1222                             $chain->{$c} = [ map $map->[$_], @{$chain->{$c}} ];
1223                         }
1224                         push @chains, $chain;
1225                     }
1226                     push @rules, \@chains;
1227                 }
1228                 $sub->{RULES} = \@rules;
1229                 # If all the rules are empty, drop this whole subtable (which maybe is
1230                 # needed to avoid https://bugzilla.mozilla.org/show_bug.cgi?id=475242 ?)
1231                 return 0 if not grep @$_, @{$sub->{RULES}};
1232             }
1233
1234             if ($sub->{ACTION_TYPE}) {
1235                 if ($sub->{ACTION_TYPE} eq 'g') {
1236                     for (@{$sub->{RULES}}) {
1237                         for (@$_) {
1238                             $_->{ACTION} = [ map $self->{glyph_id_old_to_new}{$_},
1239                                 grep $self->{wanted_glyphs}{$_}, @{$_->{ACTION}} ];
1240                         }
1241                     }
1242                 } elsif ($sub->{ACTION_TYPE} eq 'l') {
1243                     # nothing to change here
1244                 } elsif ($sub->{ACTION_TYPE} eq 'a') {
1245                     # We don't want to bother with alternate glyphs at all,
1246                     # so just delete everything.
1247                     # (We need to have empty rules, and can't just delete them
1248                     # entirely, else FontTools becomes unhappy.)
1249                     # (TODO: Maybe we do want alternate glyphs?
1250                     # If so, be sure to update find_wanted_glyphs too)
1251                     for (@{$sub->{RULES}}) {
1252                         for (@$_) {
1253                             $_->{ACTION} = [];
1254                         }
1255                     }
1256                 } elsif ($sub->{ACTION_TYPE} eq 'o') {
1257                     die "Should have handled ACTION_TYPE o earlier";
1258                 } else {
1259                     die "Invalid ACTION_TYPE";
1260                 }
1261             }
1262
1263             return 1;
1264         }
1265     );
1266 }
1267
1268 # Fold certain GSUB features into the cmap table
1269 sub fold_gsub {
1270     my ($self, $features) = @_;
1271
1272     my $font = $self->{font};
1273     my $table = $font->{GSUB};
1274
1275     # Find the lookup IDs corresponding to the desired features
1276
1277     my %wanted = (DEFAULT => 0);
1278     $wanted{$_} = 1 for @$features;
1279
1280     my %lookups;
1281     for my $feat_tag (@{$table->{FEATURES}{FEAT_TAGS}}) {
1282         next if not $self->want_feature(\%wanted, $feat_tag);
1283         for (@{$table->{FEATURES}{$feat_tag}{LOOKUPS}}) {
1284             $lookups{$_} = $feat_tag;
1285         }
1286     }
1287
1288     # Find the glyph mapping from those lookups
1289
1290     my %glyph_map; # (old glyph id => new glyph id)
1291
1292     for my $lookup_id (0..$#{$table->{LOOKUP}}) {
1293         next unless exists $lookups{$lookup_id};
1294         my $lookup = $table->{LOOKUP}[$lookup_id];
1295         if ($lookup->{TYPE} != 1) {
1296             warn "GSUB lookup $lookup_id (from feature '$lookups{$lookup_id}') is not a 'single' type lookup (type=$lookup->{TYPE}), and cannot be applied.\n";
1297             next;
1298         }
1299
1300         # For each glyph, only the first substitution per lookup is applied,
1301         # so we build a map of the firsts for this lookup (then fold it into
1302         # the global map later)
1303         my %lookup_glyph_map;
1304
1305         for my $sub (@{$lookup->{SUB}}) {
1306             my @covs = $self->coverage_array($sub->{COVERAGE});
1307             if ($sub->{ACTION_TYPE} eq 'o') {
1308                 my $adj = $sub->{ADJUST};
1309                 if ($adj >= 32768) { $adj -= 65536 } # fix Font::TTF::Bug (http://rt.cpan.org/Ticket/Display.html?id=42727)
1310                 for my $i (0..$#covs) {
1311                     my $old = $covs[$i];
1312                     my $new = $old + $adj;
1313                     $lookup_glyph_map{$old} = $new if not exists $lookup_glyph_map{$old};
1314                 }
1315             } elsif ($sub->{ACTION_TYPE} eq 'g') {
1316                 next if @covs == 0 and not $sub->{RULES};
1317                 die unless @{$sub->{RULES}} == @covs;
1318                 for my $i (0..$#covs) {
1319                     my $old = $covs[$i];
1320                     die unless @{$sub->{RULES}[$i]} == 1;
1321                     die unless @{$sub->{RULES}[$i][0]{ACTION}} == 1;
1322                     my $new = $sub->{RULES}[$i][0]{ACTION}[0];
1323                     $lookup_glyph_map{$old} = $new;
1324                 }
1325             } else {
1326                 die "Invalid ACTION_TYPE $sub->{ACTION_TYPE}";
1327             }
1328         }
1329
1330         # Fold the lookup's glyph map into the global glyph map
1331         for my $gid (keys %lookup_glyph_map) {
1332             # Add any new substitutions
1333             $glyph_map{$gid} = $lookup_glyph_map{$gid} if not exists $glyph_map{$gid};
1334         }
1335         for my $gid (keys %glyph_map) {
1336             # Handle chained substitutions
1337             $glyph_map{$gid} = $lookup_glyph_map{$glyph_map{$gid}} if exists $lookup_glyph_map{$glyph_map{$gid}};
1338         }
1339     }
1340
1341     # Apply the glyph mapping to cmap
1342
1343     for my $table (@{$font->{cmap}{Tables}}) {
1344         for my $cp (keys %{$table->{val}}) {
1345             my $gid = $table->{val}{$cp};
1346             $table->{val}{$cp} = $glyph_map{$gid} if exists $glyph_map{$gid};
1347         }
1348     }
1349 }
1350
1351 sub fix_hdmx {
1352     my ($self) = @_;
1353     my $font = $self->{font};
1354
1355     for my $ppem (grep /^\d+$/, keys %{$font->{hdmx}}) {
1356         my @new_widths;
1357         for my $gid (0..$font->{maxp}{numGlyphs}-1) {
1358             push @new_widths, $font->{hdmx}{$ppem}[$self->{glyph_id_new_to_old}{$gid}];
1359         }
1360         $font->{hdmx}{$ppem} = \@new_widths;
1361     }
1362 }
1363
1364 sub fix_kern {
1365     my ($self) = @_;
1366     my $font = $self->{font};
1367
1368     # We don't handle version 1 kern tables yet, so just drop them entirely.
1369     # http://developer.apple.com/textfonts/TTRefMan/RM06/Chap6kern.html
1370     # https://bugzilla.mozilla.org/show_bug.cgi?id=487549
1371     if ($font->{kern}{Version} != 0) {
1372         warn "Unhandled kern table version $font->{kern}{Version} - deleting all kerning data\n";
1373         delete $font->{kern};
1374         return;
1375     }
1376
1377     for my $table (@{$font->{kern}{tables}}) {
1378         if ($table->{type} == 0) {
1379             my %kern;
1380             for my $l (keys %{$table->{kern}}) {
1381                 next unless $self->{wanted_glyphs}{$l};
1382                 for my $r (keys %{$table->{kern}{$l}}) {
1383                     next unless $self->{wanted_glyphs}{$r};
1384                     $kern{$self->{glyph_id_old_to_new}{$l}}{$self->{glyph_id_old_to_new}{$r}} = $table->{kern}{$l}{$r};
1385                 }
1386             }
1387             $table->{kern} = \%kern;
1388         } elsif ($table->{type} == 2) {
1389             die "kern table type 2 not supported yet";
1390         } else {
1391             die "Invalid kern table type";
1392         }
1393     }
1394 }
1395
1396 sub fix_ltsh {
1397     my ($self) = @_;
1398     my $font = $self->{font};
1399
1400     my @glyphs;
1401     for my $gid (0..$font->{maxp}{numGlyphs}-1) {
1402         push @glyphs, $font->{LTSH}{glyphs}[$self->{glyph_id_new_to_old}{$gid}];
1403     }
1404     $font->{LTSH}{glyphs} = \@glyphs;
1405 }
1406
1407 sub delete_copyright {
1408     my ($self) = @_;
1409     my $font = $self->{font};
1410     # XXX - shouldn't be deleting copyright text
1411     $font->{name}{strings}[0] = undef;
1412     $font->{name}{strings}[10] = undef;
1413     $font->{name}{strings}[13] = undef;
1414 }
1415
1416 sub change_name {
1417     my ($self, $uid) = @_;
1418     my $font = $self->{font};
1419
1420     for (1,3,4,6) {
1421         my $str = $font->{name}{strings}[$_];
1422         for my $plat (0..$#$str) {
1423             next unless $str->[$plat];
1424             for my $enc (0..$#{$str->[$plat]}) {
1425                 next unless $str->[$plat][$enc];
1426                 for my $lang (keys %{$str->[$plat][$enc]}) {
1427                     next unless exists $str->[$plat][$enc]{$lang};
1428                     $str->[$plat][$enc]{$lang} = "$uid - subset of " . $str->[$plat][$enc]{$lang};
1429                 }
1430             }
1431         }
1432     }
1433 }
1434
1435 sub license_desc_subst {
1436     my ($self, $new) = @_;
1437     my $font = $self->{font};
1438
1439     my $str = $font->{name}{strings}[13];
1440     for my $plat (0..$#$str) {
1441         next unless $str->[$plat];
1442         for my $enc (0..$#{$str->[$plat]}) {
1443             next unless $str->[$plat][$enc];
1444             for my $lang (keys %{$str->[$plat][$enc]}) {
1445                 next unless exists $str->[$plat][$enc]{$lang};
1446                 $str->[$plat][$enc]{$lang} =~ s/\$\{LICENSESUBST\}/$new/g;
1447             }
1448         }
1449     }
1450 }
1451
1452 # IE silently rejects non-CFF fonts if the Font Family Name is not a prefix of
1453 # the Full Font Name. This can occur when automatically converting CFF fonts
1454 # to non-CFF fonts, so it's useful to check and fix it here.
1455 sub fix_full_font_name {
1456     my ($self, $new) = @_;
1457     my $font = $self->{font};
1458
1459     my $str1 = $font->{name}{strings}[1];
1460     for my $plat (0..$#$str1) {
1461         next unless $str1->[$plat];
1462         for my $enc (0..$#{$str1->[$plat]}) {
1463             next unless $str1->[$plat][$enc];
1464             for my $lang (keys %{$str1->[$plat][$enc]}) {
1465                 next unless exists $str1->[$plat][$enc]{$lang};
1466                 my $name = $str1->[$plat][$enc]{$lang};
1467                 my $fullname = $font->{name}{strings}[4][$plat][$enc]{$lang};
1468                 if (substr($fullname, 0, length $name) ne $name) {
1469                     warn "Full Name ('$fullname') does not start with Family Name ('$name') and will break in IE - fixing automatically\n";
1470                     $font->{name}{strings}[4][$plat][$enc]{$lang} = $name;
1471                 }
1472             }
1473         }
1474     }
1475 }
1476
1477 sub new {
1478     my $class = shift;
1479     my $self = {};
1480     bless $self, $class;
1481     return $self;
1482 }
1483
1484 sub preload {
1485     my ($self, $filename) = @_;
1486     my $font = Font::TTF::Font->open($filename) or die "Failed to open $filename: $!";
1487     $self->{font} = $font;
1488     $self->read_tables;
1489 }
1490
1491 sub subset {
1492     my ($self, $filename, $chars, $options) = @_;
1493
1494     $self->{features} = $options->{features};
1495
1496     my $uid = substr(sha1_hex(encode_utf8("$filename $chars")), 0, 16);
1497
1498     if (not $self->{font}) {
1499         $self->preload($filename);
1500     }
1501
1502     my $font = $self->{font};
1503
1504     $self->check_tables;
1505
1506     $self->{num_glyphs_old} = $font->{maxp}{numGlyphs};
1507
1508     $self->fold_gsub($options->{fold_features})
1509         if $options->{fold_features};
1510
1511     my $fsType = $font->{'OS/2'}{fsType};
1512     warn "fsType is $fsType - subsetting and embedding might not be permitted by the license\n" if $fsType != 0;
1513
1514     $self->strip_cmap;
1515     $self->strip_name;
1516
1517     $self->find_codepoint_glyph_mappings;
1518     $self->find_wanted_glyphs($chars);
1519     $self->remove_unwanted_glyphs;
1520
1521     $self->fix_cmap;
1522     $self->fix_head;
1523     $self->fix_hhea;
1524     $self->fix_hmtx;
1525     # name: nothing to fix (though maybe could be optimised?)
1526     $self->fix_post;
1527
1528     # cvt_: nothing to fix
1529     # fpgm: nothing to fix
1530     # glyf: just a stub, in Font::TTF
1531     $self->fix_loca;
1532     # prep: nothing to fix
1533
1534     # BASE: TODO
1535     $self->fix_gdef if $font->{GDEF};
1536     $self->fix_gpos if $font->{GPOS};
1537     $self->fix_gsub if $font->{GSUB};
1538     # JSTF: TODO
1539
1540     $self->fix_hdmx if $font->{hdmx};
1541     $self->fix_kern if $font->{kern};
1542     $self->fix_ltsh if $font->{LTSH};
1543
1544     $self->fix_maxp; # Must come after loca, prep, fpgm
1545     $self->fix_os_2; # Must come after cmap, hmtx, hhea, GPOS, GSUB
1546
1547     $self->fix_full_font_name;
1548
1549     $self->change_name($uid);
1550
1551     $self->license_desc_subst($options->{license_desc_subst})
1552         if defined $options->{license_desc_subst};
1553
1554     $self->{num_glyphs_new} = $font->{maxp}{numGlyphs};
1555 }
1556
1557 sub num_glyphs_old {
1558     my ($self) = @_;
1559     return $self->{num_glyphs_old};
1560 }
1561
1562 sub num_glyphs_new {
1563     my ($self) = @_;
1564     return $self->{num_glyphs_new};
1565 }
1566
1567 sub glyph_names {
1568     my ($self) = @_;
1569     my $font = $self->{font};
1570     if (@{$font->{post}{VAL}}) {
1571         return @{$font->{post}{VAL}};
1572     }
1573     my $n = $#{$font->{loca}{glyphs}};
1574     return join ' ', map { chr($_) =~ /[a-zA-Z0-9- \|]/ ? "'".chr($_)."'" : sprintf 'U+%04x', $_ } map { keys %{$self->{glyphs}{$_}} }
1575         map $self->{glyph_id_new_to_old}{$_}, 0..$n;
1576 }
1577
1578 sub feature_status {
1579     my ($self) = @_;
1580     my $font = $self->{font};
1581     my %feats;
1582     my @feats;
1583     for my $table (grep defined, $font->{GPOS}, $font->{GSUB}) {
1584         for my $feature (@{$table->{FEATURES}{FEAT_TAGS}}) {
1585             $feature =~ /^(\w{4})( _\d+)?$/ or die "Unrecognised feature tag syntax '$feature'";
1586             my $tag = $1;
1587             next if $feats{$tag}++;
1588             push @feats, $tag;
1589         }
1590     }
1591     return @feats;
1592 }
1593
1594 sub write {
1595     my ($self, $fh) = @_;
1596     my $font = $self->{font};
1597     $font->out($fh) or die $!;
1598 }
1599
1600 sub release {
1601     my ($self) = @_;
1602     my $font = $self->{font};
1603     $font->release;
1604 }
1605
1606 1;