fontools (7aug13)

git-svn-id: svn://tug.org/texlive/trunk@31378 c570f23f-e606-0410-a88d-b1316a301751

2 files changed, 194 insertions, 153 deletions

diff --git a/Master/texmf-dist/scripts/fontools/afm2afm b/Master/texmf-dist/scripts/fontools/afm2afm
index 87d6ef1bbb4..997e195d7f4 100755
--- a/Master/texmf-dist/scripts/fontools/afm2afm
+++ b/Master/texmf-dist/scripts/fontools/afm2afm
@@ -4,7 +4,7 @@
 
 ----------------------------------------------------------------------------
 
-    Copyright (C) 2005-2012 Marc Penninga.
+    Copyright (C) 2005-2013 Marc Penninga.
 
     This program is free software; you can redistribute it and/or
     modify it under the terms of the GNU General Public License
@@ -37,11 +37,17 @@ use File::Basename;
 use Getopt::Long;
 use Pod::Usage;
 
-use v5.10;
-
 parse_commandline();
 
 my $afm = read_afm($ARGV[0]);
+$afm->{kernpairs} = read_kpx($ARGV{kpx}, $afm->{kernpairs}) if $ARGV{kpx};
+
+if ($ARGV{output}) {
+    $ARGV{output} .= '.afm' unless $ARGV{output} =~ m/[.]afm\z/xms;
+    open my $output, '>', $ARGV{output}
+        or die "[ERROR] can't open '$ARGV{output}': $!";
+    select $output;
+}
 
 # If user specified encoding, use that; else, use encoding from .afm file
 my $enc = $ARGV{encoding} ? read_enc($ARGV{encoding})
@@ -62,30 +68,24 @@ print_mapentry($afm->{fontinfo}, , $enc->{scheme})
     if $ARGV{encoding} && $ARGV{output};
 
 #-----------------------------------------------------------------------
-#
+# Read the command-line options
 #-----------------------------------------------------------------------
 sub parse_commandline {
     Getopt::Long::GetOptions(
         'help|?'     => sub { pod2usage(-verbose => 1) },
         'encoding=s' => \$ARGV{encoding},
+        'kpx=s'      => \$ARGV{kpx},
         'output=s'   => \$ARGV{output},
     )
     or pod2usage(-verbose => 0);
 
     pod2usage(-verbose => 0) if @ARGV != 1;
 
-    if ($ARGV{output}) {
-        $ARGV{output} .= '.afm' unless $ARGV{output} =~ m/[.]afm\z/xms;
-        open my $output, '>', $ARGV{output}
-            or die "[ERROR] can't open '$ARGV{output}': $!";
-        select $output;
-    }
-
     return;
 }
 
 #-----------------------------------------------------------------------
-#
+# Read the input afm file
 #-----------------------------------------------------------------------
 sub read_afm {
     my $filename = shift;
@@ -105,10 +105,10 @@ sub read_afm {
     }
 
     for (<$afmfile>) {
-        when (m/\A\s* C         \s/xms) { push @{$afm{metrics}},    $_ }
-        when (m/\A\s* KPX       \s/xms) { push @{$afm{kernpairs}},  $_ }
-        when (m/\A\s* TrackKern \s/xms) { push @{$afm{trackkerns}}, $_ }
-        when (m/\A\s* CC        \s/xms) { push @{$afm{composites}}, $_ }
+        if (m/\A\s* C         \s/xms) { push @{$afm{metrics}},    $_; next }
+        if (m/\A\s* KPX       \s/xms) { push @{$afm{kernpairs}},  $_; next }
+        if (m/\A\s* TrackKern \s/xms) { push @{$afm{trackkerns}}, $_; next }
+        if (m/\A\s* CC        \s/xms) { push @{$afm{composites}}, $_; next }
     }
 
     close $afmfile;
@@ -117,6 +117,24 @@ sub read_afm {
 }
 
 #-----------------------------------------------------------------------
+# Read additional kerning pairs from the kpx file
+#-----------------------------------------------------------------------
+sub read_kpx {
+    my ($filename, $kpx) = @_;
+    open my $kpxfile, '<', $filename
+        or die "[ERROR] can't open '$filename': $!";
+        
+    my %seen = map { ($_ => 1) } @$kpx;
+    for (<$kpxfile>) {
+        if (m/\A\s* KPX \s/xms) { push @$kpx, $_ unless $seen{$_}++ }
+    }
+    
+    close $kpxfile;
+    
+    return $kpx;
+}
+
+#-----------------------------------------------------------------------
 # Get encoding name and vector from the specified .enc file
 #-----------------------------------------------------------------------
 sub read_enc {
@@ -161,7 +179,7 @@ sub get_enc {
 }
 
 #-----------------------------------------------------------------------
-#
+# Print the 'fontinfo' part of the output afm file
 #-----------------------------------------------------------------------
 sub print_fontinfo {
     my ($fontinfo, $scheme) = @_;
@@ -253,7 +271,7 @@ sub print_composites {
 }
 
 #-----------------------------------------------------------------------
-#
+# Print a mapfile entry for this re-encoded font
 #-----------------------------------------------------------------------
 sub print_mapentry {
     my ($fontinfo, $scheme) = @_;
@@ -300,6 +318,7 @@ afm2afm - reencode an F<afm> file
 
 [B<-help>]
 [B<-encoding> I<encodingfile>]
+[B<-kpx> I<kpxfile>]
 [B<-output> I<outputfile>]
 B<afmfile>
 
@@ -312,10 +331,12 @@ B<afm2afm> re-encodes an F<afm> file.
 
 Metrics (including kerning data) for characters not present in the
 chosen encoding are excluded from the output, which resuls in
-much smaller files.
+(potentially much) smaller files.
 
-Note that if you don't specify an encoding file, the F<afm> file
-isn't re-encoded, but the unused data is still pruned.
+Additional kerning pairs can be added to the output file.
+If you don't specify an encoding file, 
+the F<afm> file isn't re-encoded; 
+however, all unused (unencoded) data is still pruned.
 
 The program also generates an entry for a F<dvips>-style map file,
 but only if the F<afm> file has been re-encoded and
@@ -335,6 +356,19 @@ Print a short description of the syntax
 
 Re-encode to the enconding in I<encodingfile>
 
+=item B<-kpx> I<kpxfile>
+
+Read additional kerning pairs from I<kpxfile> and add these to the output.
+This option cannot be used to override values from the input F<afm> file, 
+since B<afm2afm> will write both old and new values to the output!
+
+The I<kpxfile> should contain kerning data in standard F<afm> format,
+i.e. for each kerning pair there should be a line
+
+    KPX <left_glyph> <right_glyph> <amount>
+    
+All other lines in the I<kpxfile> are ignored.
+
 =item B<-output> I<outputfile>
 
 Write the result to I<outputfile> instead of C<stdout>.
@@ -345,7 +379,8 @@ The F<afm> file to be re-encoded.
 
 =back
 
-Option names may be shortened to a unique prefix.
+You may use either one or two dashes before options,
+and option names may be shortened to a unique prefix.
 
 
 =head1 AUTHOR
@@ -355,7 +390,7 @@ Marc Penninga <marcpenninga@gmail.com>
 
 =head1 COPYRIGHT
 
-Copyright (C) 2005-2012 Marc Penninga.
+Copyright (C) 2005-2013 Marc Penninga.
 
 
 =head1 LICENSE
@@ -364,7 +399,7 @@ This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published
 by the Free Software Foundation, either version 2 of the License,
 or (at your option) any later version.
-A copy of the GNU General Public License is included with B<autoinst>;
+A copy of the GNU General Public License is included with B<afm2afm>;
 see the file F<GPLv2.txt>.
 
 
@@ -382,6 +417,12 @@ See the GNU General Public License for more details.
 
 =over 12
 
+=item I<2013-08-07>
+
+Added the I<-kpx> command-line option.
+Replaced all C<given/when> constructions in the source code by C<if>'s,
+to avoid warnings about experimental features in Perl 5.18 and later.
+
 =item I<2012-02-01>
 
 Refactored the code; added the "no re-encoding, only pruning"
diff --git a/Master/texmf-dist/scripts/fontools/ot2kpx b/Master/texmf-dist/scripts/fontools/ot2kpx
index 60c2a99b418..707f9b6bd22 100755
--- a/Master/texmf-dist/scripts/fontools/ot2kpx
+++ b/Master/texmf-dist/scripts/fontools/ot2kpx
@@ -4,7 +4,7 @@
 
 ----------------------------------------------------------------------------
 
-    Copyright (C) 2005-2012 Marc Penninga.
+    Copyright (C) 2005-2013 Marc Penninga.
 
     This program is free software; you can redistribute it and/or
     modify it under the terms of the GNU General Public License
@@ -37,8 +37,6 @@ use integer;
 use List::Util @List::Util::EXPORT_OK;
 use Pod::Usage;
 
-use v5.10;
-
 our ($NUM_GLYPHS, $UNITS_PER_EM, %KPX);
 
 sub main {
@@ -67,12 +65,14 @@ sub main {
 
         for my $subtable (@subtables) {
             my $pos_format = unpack 'n', $subtable;
-            given ($pos_format) {
-                when (1) { OTF::GPOS::parse_pos_format_1($subtable) }
-                when (2) { OTF::GPOS::parse_pos_format_2($subtable) }
-                default {
-                    warn "[ERROR] invalid PosFormat $pos_format ignored";
-                }
+            if ($pos_format == 1) { 
+                OTF::GPOS::parse_pos_format_1($subtable);
+            }
+            elsif ($pos_format == 2) {
+                OTF::GPOS::parse_pos_format_2($subtable);
+            }
+            else {
+                warn "[ERROR] invalid PosFormat $pos_format ignored";
             }
         }
     }
@@ -278,37 +278,35 @@ sub get_glyph_names {
 
     my $charset = substr $CFF, $top_dict{15};
     my $format = unpack 'C', $charset;
-    given ($format) {
-        when (0) {
-            my @codes = unpack "\@1n@{[ $NUM_GLYPHS - 1 ]}", $charset;
-            @$glyph_name = @strings[0, @codes];
-        }
-        when (1) {
-            my $i = 0;
-            $glyph_name->[$i++] = $strings[0];
-            for (my $j = 0; $i < $NUM_GLYPHS; $j++) {
-                my ($first, $n_left)
-                    = unpack "\@@{[ 1 + 3*$j ]}nC", $charset;
-                $glyph_name->[$i + $_] = $strings[$first + $_]
-                    for 0 .. $n_left;
-                $i += 1 + $n_left;
-            }
-        }
-        when (2) {
-            my $i = 0;
-            $glyph_name->[$i++] = $strings[0];
-            for (my $j = 0; $i < $NUM_GLYPHS; $j++) {
-                my ($first, $n_left)
-                    = unpack "\@@{[ 1 + 4*$j ]}nn", $charset;
-                $glyph_name->[$i + $_] = $strings[$first + $_]
-                    for 0 .. $n_left;
-                $i += 1 + $n_left;
-            }
+    if ($format == 0) {
+        my @codes = unpack "\@1n@{[ $NUM_GLYPHS - 1 ]}", $charset;
+        @$glyph_name = @strings[0, @codes];
+    }
+    elsif ($format == 1) {
+        my $i = 0;
+        $glyph_name->[$i++] = $strings[0];
+        for (my $j = 0; $i < $NUM_GLYPHS; $j++) {
+            my ($first, $n_left)
+                = unpack "\@@{[ 1 + 3*$j ]}nC", $charset;
+            $glyph_name->[$i + $_] = $strings[$first + $_]
+                for 0 .. $n_left;
+            $i += 1 + $n_left;
         }
-        default {
-            warn "[ERROR] invalid CharsetFormat '$format' ignored";
+    }
+    elsif ($format == 2) {
+        my $i = 0;
+        $glyph_name->[$i++] = $strings[0];
+        for (my $j = 0; $i < $NUM_GLYPHS; $j++) {
+            my ($first, $n_left)
+                = unpack "\@@{[ 1 + 4*$j ]}nn", $charset;
+            $glyph_name->[$i + $_] = $strings[$first + $_]
+                for 0 .. $n_left;
+            $i += 1 + $n_left;
         }
     }
+    else {
+        warn "[ERROR] invalid CharsetFormat '$format' ignored";
+    }
 
     return;
 }
@@ -321,20 +319,18 @@ sub _parse_index {
 
     my ($count, $off_size) = unpack 'nC', $index;
     my @offsets = unpack "\@3(a$off_size)@{[ $count + 1 ]}", $index;
-    given ($off_size) {
-        when (1) { $_ = unpack 'C', $_ for @offsets }
-        when (2) { $_ = unpack 'n', $_ for @offsets }
-        when (4) { $_ = unpack 'N', $_ for @offsets }
-        when (3) {
-            for my $offset (@offsets) {
-                my @bytes = map 'C3', $offset;
-                $offset = ($bytes[0] << 16) + ($bytes[1] << 8) + $bytes[2];
-            }
-        }
-        default {
-            warn "[ERROR] invalid OffSize $off_size ignored";
+    if    ($off_size == 1) { $_ = unpack 'C', $_ for @offsets }
+    elsif ($off_size == 2) { $_ = unpack 'n', $_ for @offsets }
+    elsif ($off_size == 4) { $_ = unpack 'N', $_ for @offsets }
+    elsif ($off_size == 3) {
+        for my $offset (@offsets) {
+            my @bytes = map 'C3', $offset;
+            $offset = ($bytes[0] << 16) + ($bytes[1] << 8) + $bytes[2];
         }
     }
+    else {
+        warn "[ERROR] invalid OffSize $off_size ignored";
+    }
     $_ += 2 + $off_size * ($count + 1) for @offsets;
 
     my @data;
@@ -355,24 +351,28 @@ sub _parse_dict {
     my @bytes = unpack 'C*', $dict;
     my (@operands, %dict);
     while (@bytes) {
-        given ($bytes[0]) {
-            when ([0 .. 11, 13 .. 22]) {
-                my $operator = shift @bytes;
-                ($dict{$operator} = join q{ }, @operands) =~ s/^\s+//xms;
-                @operands = ();
-            }
-            when (12) {
-                my $operator = join q{ }, splice @bytes, 0, 2;
-                ($dict{$operator} = join q{ }, @operands) =~ s/^\s+//xms;
-                @operands = ();
-            }
-            when ([28, 29, 30, 32 .. 254]) {
-                push @operands, _get_number(\@bytes);
-            }
-            default {
-                warn "[ERROR] invalid byte $bytes[0] in DICT ignored";
-                shift @bytes;
-            }
+        if (( 0 <= $bytes[0] && $bytes[0] <= 11)
+         || (13 <= $bytes[0] && $bytes[0] <= 22))
+        {
+            my $operator = shift @bytes;
+            ($dict{$operator} = join q{ }, @operands) =~ s/^\s+//xms;
+            @operands = ();
+        }
+        elsif ($bytes[0] == 12) {
+            my $operator = join q{ }, splice @bytes, 0, 2;
+            ($dict{$operator} = join q{ }, @operands) =~ s/^\s+//xms;
+            @operands = ();
+        }
+        elsif ($bytes[0] == 28
+           ||  $bytes[0] == 29
+           ||  $bytes[0] == 30
+           || (32 <= $bytes[0] && $bytes[0] <= 254))
+        {
+            push @operands, _get_number(\@bytes);
+        }
+        else {
+            warn "[ERROR] invalid byte $bytes[0] in DICT ignored";
+            shift @bytes;
         }
     }
 
@@ -385,33 +385,32 @@ sub _parse_dict {
 sub _get_number {
     my $bytes = shift;
 
-    given (my $b0 = shift @$bytes) {
-        when (28) {
-            my ($b1, $b2) = splice @$bytes, 0, 2;
-            return ($b1 << 8) | $b2;
-        }
-        when (29) {
-            my ($b1, $b2, $b3, $b4) = splice @$bytes, 0, 4;
-            return ((((($b1 << 8) + $b2) << 8) + $b3) << 8) + $b4;
-        }
-        when (30) {
-            # Reals not implemented; just dump appropriate number of bytes
-            until (($b0 & 0xf0) == 0xf0 || ($b0 & 0xf) == 0xf) {
-                $b0 = shift @$bytes;
-            }
-        }
-        when ([ 32 .. 246]) {
-            return $b0 - 139;
-        }
-        when ([247 .. 250]) {
-            my $b1 = shift @$bytes;
-            return 256 * ($b0 - 247) + $b1 + 108;
-        }
-        when ([251 .. 254]) {
-            my $b1 = shift @$bytes;
-            return -256 * ($b0 - 251) - $b1 - 108;
+    my $b0 = shift @$bytes;
+    if ($b0 == 28) {
+        my ($b1, $b2) = splice @$bytes, 0, 2;
+        return ($b1 << 8) | $b2;
+    }
+    elsif ($b0 == 29) {
+        my ($b1, $b2, $b3, $b4) = splice @$bytes, 0, 4;
+        return ((((($b1 << 8) + $b2) << 8) + $b3) << 8) + $b4;
+    }
+    elsif ($b0 == 30) {
+        # Reals not implemented; just dump appropriate number of bytes
+        until (($b0 & 0xf0) == 0xf0 || ($b0 & 0xf) == 0xf) {
+            $b0 = shift @$bytes;
         }
     }
+    elsif (32 <= $b0 && $b0 <= 246) {
+        return $b0 - 139;
+    }
+    elsif (247 <= $b0 && $b0 <= 250) {
+        my $b1 = shift @$bytes;
+        return 256 * ($b0 - 247) + $b1 + 108;
+    }
+    elsif (251 <= $b0 && $b0 <= 254) {
+        my $b1 = shift @$bytes;
+        return -256 * ($b0 - 251) - $b1 - 108;
+    }
 }
 
 
@@ -559,24 +558,22 @@ sub _get_class {
     my @class = (0) x $NUM_GLYPHS;
 
     my $class_format = unpack 'n', $class;
-    given ($class_format) {
-        when (1) {
-            my ($start_glyph, @class_value) = unpack '@2nn/n', $class;
-            @class[$start_glyph .. $start_glyph + $#class_value]
-                = @class_value;
-        }
-        when (2) {
-            my @class_ranges = unpack '@2n/(a6)', $class;
-            for my $class_range (@class_ranges) {
-                my ($start, $end, $class) = unpack 'nnn', $class_range;
-                @class[$start .. $end] = ($class) x ($end - $start + 1);
-            }
-        }
-        default {
-            warn "[ERROR] invalid ClassFormat '$class_format' ignored";
-            return;
+    if ($class_format == 1) {
+        my ($start_glyph, @class_value) = unpack '@2nn/n', $class;
+        @class[$start_glyph .. $start_glyph + $#class_value]
+            = @class_value;
+    }
+    elsif ($class_format == 2) {
+        my @class_ranges = unpack '@2n/(a6)', $class;
+        for my $class_range (@class_ranges) {
+            my ($start, $end, $class) = unpack 'nnn', $class_range;
+            @class[$start .. $end] = ($class) x ($end - $start + 1);
         }
     }
+    else {
+        warn "[ERROR] invalid ClassFormat '$class_format' ignored";
+        return;
+    }
 
     return @class;
 }
@@ -611,21 +608,19 @@ sub _get_coverage {
     my $coverage = shift;
 
     my $coverage_format = unpack 'n', $coverage;
-    given ($coverage_format) {
-        when (1) {
-            return unpack '@2n/n', $coverage;
-        }
-        when (2) {
-            my @range_records = unpack '@2n/(a6)', $coverage;
+    if ($coverage_format == 1) {
+        return unpack '@2n/n', $coverage;
+    }
+    elsif ($coverage_format == 2) {
+        my @range_records = unpack '@2n/(a6)', $coverage;
 
-            return map { my ($start, $end) = unpack 'nn', $_;
-                         $start .. $end;
-                       }
-                       @range_records;
-        }
-        default {
-            warn "[WARNING] unknown CoverageFormat $coverage_format ignored";
-        }
+        return map { my ($start, $end) = unpack 'nn', $_;
+                     $start .. $end;
+                   }
+                   @range_records;
+    }
+    else {
+        warn "[WARNING] unknown CoverageFormat $coverage_format ignored";
     }
 }
 
@@ -731,12 +726,12 @@ multiple fonts, LookupTables with LookupTypes other than 2,
 "kern" tables with format other than 0 and ValueRecords with
 other types of data than just XAdvance data.
 
-Most of these limitations don't really matter, since the missing features
+Most of these limitations won't matter, since the missing features
 are rare (the only fonts I know of that use them are the non-western fonts
-that come with Adobe Reader). Furthermore, some of these features concern
-(according to the OpenType specification) I<"define subtle, device-dependent
-adjustments at specific font sizes or device resolutions">.
-Since there's no way to express such adjustments in F<afm> format,
+that come with Adobe Reader). Furthermore, many of these features define
+(according to the OpenType specification) I<"subtle, device-dependent
+adjustments at specific font sizes or device resolutions">;
+since there's no way to express such adjustments in F<afm> format,
 ignoring them seems to be the only option anyway.
 
 =item B<->
@@ -776,7 +771,7 @@ Marc Penninga <marcpenninga@gmail.com>
 
 =head1 COPYRIGHT
 
-Copyright (C) 2005-2012 Marc Penninga.
+Copyright (C) 2005-2013 Marc Penninga.
 
 
 =head1 LICENSE
@@ -785,7 +780,7 @@ This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published
 by the Free Software Foundation, either version 2 of the License,
 or (at your option) any later version.
-A copy of the GNU General Public License is included with B<autoinst>;
+A copy of the GNU General Public License is included with B<ot2kpx>;
 see the file F<GPLv2.txt>.
 
 
@@ -803,6 +798,11 @@ See the GNU General Public License for more details.
 
 =over 12
 
+=item I<2013-08-07>
+
+Replaced all C<given/when> constructions in the source code by C<if>'s,
+to avoid warnings about experimental features in Perl 5.18 and later.
+
 =item I<2012-02-01>
 
 Refactored the code, and fixed a number of bugs in the process.