7aa60dc80d8afa3ec7f7449ee09ce09bae5903cc
[librarian.git] / 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;