better_afm2tfm.pl

better_afm2tfm.pl

#! /bin/sh
eval '(exit $?0)' && eval 'PERL_BADLANG=x;export PERL_BADLANG;: \
;exec perl -x -S -- "$0" ${1+"$@"};#'if 0;
eval 'setenv PERL_BADLANG x;exec perl -x -S -- "$0" $argv:q;#'.q+
#!perl -w
package Htex::better_afm2tfm;  $0=~/(.*)/s;unshift@INC,'.';do($1);die$@if$@;__END__+if !1;
# This Perl script was generated by JustLib2 at Sun Nov  9 21:48:57 2003.
# Don't touch/remove any lines above; http://www.inf.bme.hu/~pts/justlib
package just; BEGIN{$INC{'just.pm'}='just.pm'}
BEGIN{ $just::VERSION=2 }
sub end(){1}
sub main(){}

BEGIN{$ INC{'integer.pm'}='integer.pm'} {
package integer;
use just;
# by pts@fazekas.hu at Wed Jan 10 12:42:08 CET 2001
sub import   { $^H |= 1 }
sub unimport { $^H &= ~1 }
just::end}

BEGIN{$ INC{'strict.pm'}='strict.pm'} {
package strict;
use just;
# by pts@fazekas.hu at Wed Jan 10 12:42:08 CET 2001
require 5.002;
sub bits {
  (grep{'refs'eq$_}@_ && 2)|
  (grep{'subs'eq$_}@_ && 0x200)|
  (grep{'vars'eq$_}@_ && 0x400)|
  ($@ || 0x602)
}
sub import { shift; $^H |= bits @_ }
sub unimport { shift; $^H &= ~ bits @_ }
just::end}

BEGIN{$ INC{'Pts/Tempname.pm'}='Pts/Tempname.pm'} {
package Pts::Tempname;
use just;

my $tmp_prefix='_ba2t_';
my $tmp_n=1;
%Pts::Tempname::tmp_h=();
my %tmp_fn=();

END { # close and unlink tempfiles, even after die()
  for my $H (keys%tmp_h) { close $tmp_h{$H} } # multiple close is OK
  unlink keys %tmp_fn;
  42;
}

# Usage: new Pts::Tempname(['.ext'])
sub new($;$) {
  my $END_FN=defined($_[1])?$_[1]:'';
  # Imp: respect $ENV{TMPDIR} (and others)
  my $FN="/tmp/$tmp_prefix$$\_$tmp_n$END_FN";
  $tmp_n++;
  $tmp_fn{$FN}=1;
  $FN
}

just::end}

BEGIN{$ INC{'Pts/Xystem.pm'}='Pts/Xystem.pm'} {
package Pts::Xystem;
use just;

sub xxec {
  # no real exec, because we need to preserve _tempfile()s
  my $oldsel=select(STDOUT); $|=1; select(STDERR); $|=1; select($oldsel);
  my $ret=system(@_);
  die "$0: system $_[0] failed: $!\n" if $ret==0xff00;
  exit $ret>>8;
}

sub xystem {
  my $oldsel=select(STDOUT); $|=1; select(STDERR); $|=1; select($oldsel);
  my $ret=system(@_);
  die "$0: system $_[0] failed: $!\n" if $ret==0xff00;
  die "$0: system $_[0] exited with ".($ret>>8).".\n" if $ret>>8;
}

sub xystem_redir {
  die unless @_;
  my $ofn=shift;
  my $oldsel=select(STDOUT); $|=1; select(STDERR); $|=1; select($oldsel);
  die unless open SAVEOUT, ">&STDOUT";
  die "$0: > $ofn: $_\n" unless open STDOUT, "> $ofn";
  my $ret=system(@_);
  die unless open STDOUT, ">&SAVEOUT";
  die unless close SAVEOUT;
  die "$0: system $_[0] failed: $!\n" if $ret==0xff00;
  die "$0: system $_[0] exited with ".($ret>>8).".\n" if $ret>>8;
}

sub xystem_capture { # similar to `...command...`
  # no real exec, because we need to preserve _tempfile()s
  die unless @_;
  my $oldsel=select(STDOUT); $|=1; select(STDERR); $|=1; select($oldsel);
  die unless open SAVEOUT, ">&STDOUT";
  my $TN=new Pts::Tempname(".cap");
  die "$0: > $TN: $_\n" unless open STDOUT, "> $TN";
  my $ret=system(@_);
  die unless open STDOUT, ">&SAVEOUT";
  die unless close SAVEOUT;
  die "$0: < $TN: $!\n" unless open SAVEOUT, "< $TN";
  my $S=''; 1 while 0<sysread SAVEOUT, $S, 4096, length $S;
  die unless close SAVEOUT;
  if ($ret>>8) {
    print STDERR $S;
    die "$0: pipe $_[0] failed: $!\n" if $ret==0xff00;
    die "$0: pipe $_[0] exited with ".($ret>>8).".\n" if $ret>>8;
  }
  $S
}

just::end}

BEGIN{$ INC{'Pts/T1glyphs.pm'}='Pts/T1glyphs.pm'} {
#
# Pts/T1glyphs.pm -- list glyphs of a Type1 (PFA/PFB) font
# by pts@fazekas.hu at Sat Nov  8 11:55:24 CET 2003
#
package Pts::T1glyphs;
use just;
use integer;
use strict;

sub eexec_decrypt($) {
  # param: a string in either hex on binary (autodetected)
  # Dat: this is sloow (because we're doing a lot of low level numerical computation)
  my $S=$_[0];
  my $q;
  die if length($S)<8;
  # ^^^ Imp: in CharStrings, may be smaller, but we don't need it
  $S=~s/\A[\f\r\t\n\013\000 ]+//;
  if ($S=~/\A[0-9a-fA-F]{8}/) { $S=~y/a-fA-F0-9//cd; $S=pack"H*", $S }
  # ^^^ convert hexdump to binary
  my $eexec_r=55665; # normal PostScriptt `eexec' operator uses this
  for (my $I=0;$I<length $S;$I++) {
    my $q=vec($S,$I,8);
    vec($S,$I,8)=($eexec_r>>8)^$q; # Dat: &0xFFFF not needed
    $eexec_r=0xFFFF&(($q+$eexec_r)*52845+22719);
  }
  substr($S,4)
}

#** @param $_[0] contents of a Type1 PFA/PFB font file, in a string
sub list_t1glyphs($) {
  my $S=$_[0];
  if ($S=~/\A\x80\x01/) { # PFB
    if ($S=~s@\A.*\beexec[\f\r\t\n\013\000 ]*\x80\x01....@@s) { # encrypted hex
      $S=~y/a-fA-F0-9//cd; $S=pack"H*", $S
    } elsif ($S=~s@\A.*\beexec[\f\r\t\n\013\000 ]*\x80\x02....@@s) {
    } else {
      die "$0: missing eexec from PFB";
    }
  } else { # PFA
    if ($S!~s@\A.*\beexec[\f\r\t\n\013\000 ]*@@s) { die "$0: missing eexec from PFA" }
    $S=~y/a-fA-F0-9//cd; $S=pack"H*", $S
  }
  $S=eexec_decrypt($S);

  { # Remove binary CharString and Subrs data
    my $T=$S; $S="";
    my $lastpos=0;
    while ($T=~/[\f\r\t\n\013\000 ]((\d+)[\f\r\t\n\013\000 ]+(?:RD|[-][|])[\f\r\t\n\013\000 ])/g) {
      $S.=substr($T,$lastpos,pos($T)-length($1)-$lastpos);
      $lastpos=pos($T)+$2;
    }
    $S.=substr($T,$lastpos);
  }

  $S=~s@\bdefinefont\b.*@@s;
  $S=~s@\bmark\b.*@@s;

  die "$0: missing /CharStrings" if $S!~s@\A.*?/CharStrings\b@@s;
  $S=~s@[\f\r\t\n\013\000 ]end.*@@s; # end of /CharStrings

  my @L;
  push @L, $1 while $S=~m@/([^\f\r\t\n\013\000 ]+)@g;
  @L
}

just::end}

BEGIN{$  INC{'Htex/better_afm2tfm.pm'}='Htex/better_afm2tfm.pm'}

package Htex::better_afm2tfm;
# better_afm2tfm.pl
# invoke `afm2tfm' (of dvips(k) >=5.82) with some annying glitches fixed
# by pts@fazekas.hu at Tue Jan  2 16:02:19 CET 2001
# -- Tue Jan  2 18:26:44 CET 2001
# -- Tue Jan  2 22:23:50 CET 2001
# -- justlib2 at Fri Jan 17 10:09:53 CET 2003
# -- list_t1glyphs, KPX-EQ-R, docs at Sat Nov  8 12:37:05 CET 2003
#
# Imp: switch do disable psfonts.map
# Imp: use kpsewhich to find .afm and .enc files.
# Imp: oct2dec $X... O's
# Dat: -P ($OPTS{P}) is used by have_glyph() and .map generation
#
use just +1;
use integer;
use strict;
use Pts::Tempname;
use Pts::Xystem;
use Pts::T1glyphs;

BEGIN { $Htex::better_afm2tfm::VERSION=0.41 }

# --- general subs

sub de($){defined$_[0]?$_[0]:""}

sub print_list($) {
  print join('  ',@{$_[0]}), "\n";
  $_[0]
}

sub min_size($$) {
  my($FN,$MINSIZE)=@_;
  die "$0: $FN: no such file\n" if !-f $FN;
  die "$0: $FN: file size <$MINSIZE\n" if $MINSIZE>-s $FN;
}

sub add_ext($$) { # modify $_[0] in place
  return if! defined $_[0];
  # print "..$_[0]\n";
  $_[0].=$_[1] if $_[0]!~m@[^/\\]*\.[^/\\\.]*\Z(?!\n)@s;
  # print "..$_[0]\n";
}
sub del_ext($) { # modity $_[0] in place
  $_[0]=~s@([^/\\]*)\.[^/\\\.]*\Z(?!\n)@$1@s;
}
sub add_exts {
  my $S=$_[0];
  return if !defined $S;
  my $T;
  for (my $I=1;$I<=$#_;$I++) {
    $T=$S; add_ext $T, $_[1];
    if (-f $T) { $_[0]=$T; return }
  }
}

sub unlink_file($) {
  if (defined $_[0]) {
    print "rm -f  $_[0]\n" if -f $_[0];
    unlink $_[0];
    die "$0: unlink failed: $_[0]\n" if lstat $_[0];
  }
}

sub unlink_all($) {
  my $S=$_[0];
  return if !defined $S;
  del_ext $S;
  my $D=$S; $D=~s@[/\\]*([^/\\]+)\Z(?!\n)@@; $D='.' if!length $D;
  my @L=();
  # print ",,$D\n";
  if (opendir D, $D) {
    my $X;
    while (defined($X=readdir D)) { push @L, "$D/$X" if $X=~/\.(\d*)pk\Z(?!\n)/ }
    closedir D;
    # print "@L..\n";
  }
  for my $FN ("$S.vpl", "$S.pl", "$S.tfm", "$S.vf", @L) { unlink_file $FN }
}

sub in_place($$;$) { # similar to `perl -pi'
  # no tempfile here, because we cannot `rename'
  my($FN,$SUB,$SUB2)=@_;
  die "$0: < $FN: $!\n" unless open F, "< $FN";
  die "$0: > $FN.bak: $!\n" unless open B, "> $FN.bak";
  while (<F>) { $SUB->(); print B; }
  print B $SUB2->() if defined $SUB2;
  close F;
  close B;
  unlink $FN;
  die "$0: rename $FN: $!\n" unless rename "$FN.bak", $FN;
}

sub oct2bin() {
  1 while s/( C )([oOdDrRcC])([( )\n])/" D ".ord($2).$3/ge;
  1 while s/( O )([0-7]+)([( )\n])/" D ".oct($2).$3/ge;
}

# ---

my $cmd_afm2tfm='afm2tfm';
my $cmd_vptovf='vptovf';
my $cmd_tftopl='tftopl';
my %ARGSW=qw(-c 1 -e 1 -p 1 -s 1 -t 1 -T 1 -v 1 -V 1 -L 1 -P 1 --update-map 1
  --set-space 1);

#** @return kpsewhich-pathname, never undef
sub find_kpsewhich($) {
  my $fn=$_[0];
  if (!-f $fn) {
    $fn=~y@'@@d;
    # my $S=qx(kpsewhich -must-exist -- '$fn' 2>/dev/null);
    ## system "kpsewhich -- 'zapfa.enc'; echo grr";
    my $S=qx(kpsewhich -- '$fn' 2>/dev/null);
    chomp $S;
    return $S if -f $S;
  }
  $fn
}

sub fix_enc($$$$) {
  my($o,$opts,$ccf,$optL)=@_;
  if (defined $opts->{$o}) {
    die "$0: fix_enc $opts->{$o}: $!\n" if !open PF, "< ".find_kpsewhich($opts->{$o});
    $opts->{"o$o"}=$opts->{$o};
    $opts->{$o}=new Pts::Tempname('.enc');
    die unless open PH, "> $opts->{$o}";
    for my $FN (@$optL) {
      die "$0: opt open $FN: $!\n" unless open LF, "< $FN";
      print PH $_ while 0<sysread LF, $_, 4096;
      close LF;
    }
    while (<PF>) {
      s/%.*// if !/%\s*LIGKERN/;
      s@(/([A-Za-z0-9_\.\-]+))@defined($ccf->{$2})?"/.notdef":$1@ge
        if'p'eq$o;
      # print;
      print PH $_;
    }
    close PH;
    close PF;
  }
}

sub fix_opts($$) {
  my($opts,$optsl)=@_;
  if (!defined $opts->{"-O"}) {
    $opts->{"-O"}=1;
    push @$optsl, '-O';
  }
  $opts->{"-t"}=$opts->{t};
  $opts->{"-p"}=$opts->{p};
  $opts->{"-v"}=$opts->{v};
  $opts->{"-V"}=$opts->{V};
  delete $opts->{"-T"};
  push @$optsl, '-p' if defined $opts->{p} and !grep {'-p'eq$_} @$optsl;
  push @$optsl, '-t' if defined $opts->{t} and !grep {'-t'eq$_} @$optsl;
  return undef if !wantarray;
  # integrated passed_cmdline():
  my @L=($cmd_afm2tfm, $opts->{afmn});
  for my $K (@$optsl) {
    next if $K=~/\A-[LHMP]\Z/ # don't pass -L -H -M -P to afm2tfm(1)
         or $K eq '--keep-pl' or $K eq '--fixsh-vf' or $K eq '--fixsh-tfm'
	 or $K eq '--update-map' or $K eq '--set-space';
    # print "OPT $K.\n";
    if (defined $ARGSW{$K}) { push @L, $K, $opts->{$K} if defined $opts->{$K} }
                       else { push @L, $K }
  }
  push @L, $opts->{tfmn};
  @L
}

my $if_missing_mode_p=0;
my $unknown_glyphs_p=1;
my %glyph_names;
my %OPTS;

#** @param $_[0] e.g 'Acircumflex', without a slash
sub have_glyph($) {
  if ($unknown_glyphs_p) {
    # die "$0: glyph file (-P) missing\n" if !defined $OPTS{P};
    if (defined $OPTS{P}) {
      die "$0: open $OPTS{P}: $!\n" if !open F, "< $OPTS{P}";
      my $S=""; 1 while 0<sysread F, $S, 4096, length($S);
      die unless close F;
      for my $g (Pts::T1glyphs::list_t1glyphs($S)) { $glyph_names{$g}=1 }
    }
    $unknown_glyphs_p=0;
  }
  return exists $glyph_names{$_[0]};
}

sub make_less($$) { no integer; $_[0]=$_[1] if $_[0]>$_[1] }
sub make_more($$) { no integer; $_[0]=$_[1] if $_[0]<$_[1] }

sub fix_unenc_cc($$$) {
  # big improvements at Sat Nov  8 14:10:13 CET 2003
  my($opts,$ccf,$optL)=@_;
  my @lines_C;
  my @lines_KPX;
  my @lines_CC;
  my @lines_head;
  # my @out_CC;
  my %extra_C; # $extra_C{"foo"}="; PCC A 0 0 ; PCC circumflex 222 168 ;";
  my %offset_cc_target_C; # similar to $extra_C, but more chars
  my %width_C; # $width_C{"exclam"}="389";
  my %bbox_C;  # $bbox_C{"exclam"}="139 0 251 698";
  my %r_KPX; # r_KPX{"e"}{"T"}="-74" for `KPX T e -74'
  my %link_KPX; # link_KPX{"eacute"}="e" for `KPX-EQ-R e ; eacute'
  my %is_total_CC; # $is_total_cc{"SS"}=1;
  my $S;
  my @extrafiles=reverse@$optL;
  my $in_ligencfile_p=0;
  %$ccf=();
  while (1) {
    while (<AF>) {
      if ($in_ligencfile_p) { next if !s@^\%\s*AFM\s+@@ }
      s@^\s+@@; y@\r\032@@d; s@\Z.*@\n@s; next if /^[;!#\%]/ or !/\S/;
      if (/^C\s+/) {
        push @lines_C, $_;
	if (/\bN\s*([^\s;]+)/) {
	  my $Cname=$1;
	  if (/\bWX\s+([^\s;]+)/) { $width_C{$Cname}=$1 } # Dat: early, for OFFSET-CC
	}
      } elsif (/^(?:TOTAL-|)CC\s+/) {
        next unless /^(TOTAL-|)CC\s+([^\s;]+)/; # Dat: ignore syntax error
        my $CCname=$2;
	$is_total_CC{$CCname}=1 if 0!=length($1); # Dat: for glyph /SS
	s@^TOTAL-@@;
	my $PCCname=""; # Dat: very first component: need for width
	if (/\bPCC\s+([^\s;]+)/) { $PCCname=$1 }
	else { print STDERR "$0: warning: missing PCC for CC: $CCname\n" }
        $offset_cc_target_C{$CCname}=$1 if /(;\s*.*)/;
        if (s@;\s*(FORCE)\s*;@;@) {
        } elsif (s@;\s*IF-MISSING\s*;@;@) {
	  # print "IM $CCname\n";
          next if have_glyph($CCname);
        } elsif ($if_missing_mode_p) {
          next if have_glyph($CCname);
        }

        # Dat: CC entry for target of OFFSET-CC must be defined earlier
        s`\bWIDTH-OF\s+([^\s;]+)`
	  if (exists $width_C{$1}) {
	    "$width_C{$1}"
	  } else {
            print STDERR "$0: warning: missing char $1 for WIDTH-OF, assuming 0\n";
            "0"
	  }
        `ge;
        s`\bOFFSET-CC\s+([^\s;]+)\s+([^\s;]+)`
          if (exists $offset_cc_target_C{$1}) {
            my $T;
            $S=$offset_cc_target_C{$1}; my $subchar=$2;
            while ($S=~m@;\s*PCC\s+([^\s;]+)\s+([-.\d]+)\s+([-.\d]+)@g) {
              $T="$2 $3" if $1 eq $subchar
            }
            if (!defined $T) {
              print STDERR "$0: warning: missing subchar $subchar from CC of ...\n";
              $T="0 0";
            }
            $T
          } elsif (exists $width_C{$2} and exists $width_C{$PCCname}) {
	    my $dif=($width_C{$PCCname}-$width_C{$2})>>1; # Dat: horizontal centring for cedilla, but no raise for acute
            print STDERR "$0: warning: missing char $1 for OFFSET-CC, calculated $dif 0: $CCname\n";
            "$dif 0"
          } else {
            print STDERR "$0: warning: missing char $1 for OFFSET-CC, assuming 0,0: $CCname\n";
            "0 0"
          }
        `ge;

	$glyph_names{$CCname}=1; # we already have this composite glyph
        $ccf->{$2}=1 if /^CC(\s+)([^\s;]+)/ and 2!=length$1;
        $extra_C{$CCname}=$1 if /(;\s*.*)/;
        push @lines_CC, $_;
      } elsif (/^KPX\s+/) {
        push @lines_KPX, $_
      } elsif (/^KPX-EQ-R\s+/) {
        my @L=split' ',$_;
        my $Cname=$L[1];
        $link_KPX{$Cname}=undef if !exists $link_KPX{$Cname};
        if (@L>=4 and $L[0] eq 'KPX-EQ-R' and $L[2] eq ';') {
          splice @L, 0, 3;
          for $S (@L) {
            print STDERR "$0: warning: overriding KPX-EQ-R: $S to $Cname\n" if exists $link_KPX{$S};
            $link_KPX{$S}=$Cname
          }
        } else {
          print STDERR "$0: warning: invalid KPX-EQ-R line for $Cname";
        }
      } elsif (/^(?:(?:Start|End)(?:CharMetrics|KernData|KernPairs|Composites)|EndFontMetrics)\s/) {
      } else {
        push @lines_head, $_
      }
    }
    die unless close AF;
    last if !defined($S=pop@extrafiles);
    die "$0: LIGENCFILE not found: $S: $!\n" unless open AF, "< $S";
    $in_ligencfile_p=1;
  }

  %offset_cc_target_C=();
  $opts->{afmn}=new Pts::Tempname('.afm'); # override
  die unless open ATH, "> $opts->{afmn}";
  print ATH @lines_head;
  my @out_C;
  for $S (@lines_C) {
    next unless $S=~/\bN\s*([^\s;]+)/;
    my $Cname=$1;
    delete $extra_C{$Cname};
    if ($S=~/\bWX\s+([^\s;]+)/) { $width_C{$Cname}=$1 }
    else { print STDERR "$0: warning: missing width for char $Cname"; $width_C{$Cname}=100; }
    if ($S=~/\bB\s+([^;]+)/) { $bbox_C{$Cname}=$1 }
    else { print STDERR "$0: warning: missing bbox for char $Cname"; $bbox_C{$Cname}="0 0 0 0"; }
    $S=~s/^\s*C[^;]*/C -1 / if defined $ccf->{$Cname};
    push @out_C, $S;
  }
  while (my($Cname,$PCCs)=each%extra_C) { # emit a `C -1' entry for missing composite chars
    ## print "$Cname--$PCCs\n";
    no integer;
    my $wd=undef; # Dat: `width(composite) := width(firstchar)' for CC (but not TOTAL-CC)
    my @bb=(0,0,0,0);
    my @bbp;
    my $is_tot=$is_total_CC{$Cname};
    while ($PCCs=~m@;\s*PCC\s+([^\s;]+)\s+([-.\d]+)\s+([-.\d]+)@g) {
      ## print "  $1;$2;$3;\n";
      if (!exists $width_C{$1}) {
        print STDERR "$0: warning: composite $Cname is based on missing char $1\n";
	# !! emit less warning if $Cname is missing from the .enc file
	# print STDERR "($PCCs)\n";
      } elsif (defined $wd) {
        @bbp=split' ',$bbox_C{$1};
        make_less $bb[0], $bbp[0]+$2;
        make_less $bb[1], $bbp[1]+$3;
        make_more $bb[2], $bbp[2]+$2;
        make_more $bb[3], $bbp[3]+$3;
	make_more $wd, $width_C{$1}+$2 if $is_tot;
      } else {
        $wd=$width_C{$1};
        @bb=split' ',$bbox_C{$1};
        $bb[0]+=$2; $bb[1]+=$3; $bb[2]+=$2; $bb[3]+=$3;
      }
    }
    if (!defined $wd) {
      print STDERR "$0: warning: cannot guess width of composite, assuming 0: $Cname\n";
      $wd=0;
    }
    push @out_C, "C   -1 ; WX $wd ; N $Cname ; B $bb[0] $bb[1] $bb[2] $bb[3] ;\n";
  }
  print ATH "StartCharMetrics ".scalar(@out_C)."\n";
  print ATH @out_C, "EndCharMetrics\n";
  @out_C=();
  if (%link_KPX) {
    my %r_KPX; # r_KPX{"e"}{"T"}="-74" for `KPX T e -74'
    for $S (@lines_KPX) {
      $r_KPX{$2}{$1}=$3 if $S=~/^KPX\s+(\S+)\s+(\S+)\s+(\S+)/ and exists $link_KPX{$2};
      # ^^^ Imp: warning for overrides
    }
    push @lines_KPX, "\n";
    while (my($to,$from)=each%link_KPX) {
      next if !defined $from; # sources are added with value `undef'
      while (my($Cleft,$KPXval)=each%{$r_KPX{$from}}) {
        push @lines_KPX, "KPX  $Cleft $to $KPXval\n" if !exists $r_KPX{$to}{$Cleft};
      }      
    }
    %link_KPX=();
  }
  if (@lines_KPX) {
    print ATH "StartKernData\nStartKernPairs ".scalar(@lines_KPX)."\n";
    print ATH @lines_KPX, "EndKernPairs\nEndKernData\n";
  }
  if (@lines_CC) {
    print ATH "StartComposites ".scalar(@lines_CC)."\n";
    print ATH @lines_CC, "EndComposites\n";
  }
  print ATH "EndFontMetrics\n";
  die unless close ATH;
  ## print "joe $opts->{afmn}\n"; system "bash";
}

sub fix_run_afm2tfm($$) { # Dat: may create .vpl file
  my($opts,$optsl)=@_;
  my $RETS=Pts::Xystem::xystem_capture @{print_list([fix_opts $opts, $optsl])};
  #system "bash"; ## just after afm2tfm(1) has been run
  min_size $opts->{tfmn}, 512;
  min_size $opts->{v}, 512 if defined $opts->{v};
  min_size $opts->{V}, 512 if defined $opts->{V};
  if ($RETS!~/\A(\S+) [0-9A-Za-z\.\-_]+(?: .*)?\Z/) {
    print STDERR $RETS;
    die "$0: afm2tfm returned error??\n";
  }
  $RETS
}

my %altered_fontnames;
sub add_tex_fontname($) {
  # print "($_[0])\n";
  $altered_fontnames{[$_[0]=~/\A(\S+)/]->[0]}=1;
}
sub update_psfonts_map($$) {
  my $RETS=$_[0];
  my $MAPFN=$_[1];
  if (!defined $MAPFN) {
  } elsif (open F, "< $MAPFN") {
    print "# updating $MAPFN\n";
    close F;
    # print "[$RETS]\n";
    in_place $MAPFN, sub {
      if (/^(\S+) / and defined $altered_fontnames{$1}) {
        if ($altered_fontnames{$1}) { $altered_fontnames{$1}=0; $_="$1$RETS\n" }
                  else { $_="" }
      }
    }, sub {
      my $S='';
      for my $K (keys%altered_fontnames) { $S.="$K$RETS\n" if $altered_fontnames{$K} }
      $S;
    };
    # print %altered_fontnames;
  } else { print STDERR "$0: warning: missing map: $MAPFN: $!\n" }
}

sub get_extra_lig($$$$$$) {
  my($opts,$optsl,$optL,$ccf,$xligtable,$xcorrect)=@_;
  return unless (defined $opts->{v} or defined $opts->{V}) and defined $opts->{t} and not defined $opts->{p};
  # do it with -p := -t, get the extra LIGTABLE (KRN, LIG) and CHARACTER
  # CHARWD, CHARHT, CHARDP info which is normally excluded from the generated
  # .vpl file due to quirks in afm2tfm.
  my $VFN=defined $opts->{v}?$opts->{v}:$opts->{V}; # Imp: both??
  fix_opts($opts, $optsl); # add -O...
  $opts->{p}=$opts->{t}; push @$optsl, '-p';
  fix_enc 'p', $opts, $ccf, $optL; # Dat: important (why?)
  # my $T=pop @CL; push @CL, "-p", $opts->{p}, $T;
  print "# vvv extra LIGTABLE, CHARACTER CHARWD, CHARHT, CHARDP\n";
  # Imp: sanity check for line-subsets (somewhere later)
  # splice @CL, -1, 0, '-O'; # force charcodes to octal
  # Pts::Xystem::xystem @CL;
  fix_run_afm2tfm($opts, $optsl);
  #die $VFN; # not run
  die unless open F, "< $VFN";
  my $V=''; 1 while sysread F, $V, 4096, length $V;
  die unless close F;
  die unless $V=~s/\n(\(LIGTABLE\n.*?\n   \)\n)/\n/si;
  $$xligtable=$1;
  my $XNC=0;
  $V=~s/^(\(CHARACTER (.) (\S+)(.*?)\n   \)\n)/ # \n instead of ^ is bad...
    die "$0: not -O octal!\n" unless 'O'eq$2;
    $XNC++; $xcorrect->{oct$3}=$1; ""
  /gsmei;
  print STDERR "$0: $opts->{afmn}: unexpectedly few chars: $XNC\n" if $XNC<32;
  # vvv undo opts modification
  delete $opts->{p}; delete $opts->{op};
}

sub update_extra_lig($$$) {
  my ($opts,$xligtable,$xcorrect)=@_;
  return if !defined $$xligtable;
  my $VFN=defined $opts->{v}?$opts->{v}:$opts->{V}; # Imp: both??
  die unless open F, "< $VFN";
  my $V=''; 1 while sysread F, $V, 4096, length $V;
  die unless close F;
  die unless $V=~s/\n(\(LIGTABLE\n.*?\n   \)\n)/\n$$xligtable/si;
  my $H;
  my %CP=%$xcorrect;
  $V=~s/^(\(CHARACTER (.) (\S+)(.*?)\n   \)\n)/ # \n instead of ^ is bad...
    die "$0: not -O octal!\n" unless 'O'eq$2;
    print STDERR "$0: $opts->{afmn}: unexpected extra CHARACTER O $3\n" if !exists$xcorrect->{$H=oct$3};
    # ^^^ Dat: appears many times
    delete $CP{$H};
    $1 # do not change
  /gsmei;
  # die "$0: unexpectedly few chars: $NC\n" if $NC<32;
  print "# ".(scalar keys%CP)." of ".scalar(keys%$xcorrect)." chars will be totally white\n";
  for $H (keys %CP) {
    my $S=$xcorrect->{$H};
    die unless $S=~s/(\n   \)\n)\Z(?!\n)/\n   (MAP\n      (MOVERIGHT R 0)\n      )$1/;
    $V.=$S;
  }
  die unless open F, "> $VFN";
  die unless print F $V;
  die unless close F;
}

sub SPACE(){2}
sub SPACE_STRETCH(){3}
sub SPACE_SHRINK(){4}
sub MIN_NPARS(){5}
#** fix_tfm_space.pl, simplified
#** @param $_[0] TFM file name
sub fix_tfm_space($) {
  my $do_fix_space=0;
  my $do_fix_space_stretch=1;
  my $do_fix_space_shrink=1;
  my $fn=$_[0];
  if (!open TFF, "+< $fn") {
    die "$0: cannot open $fn: $!\n"
  }
  my $s; read TFF, $s, 24+8;
  my($lf,$lh,$bc,$ec,$nw,$nh,$nd,$ni,$nl,$nk,$ne,$np,$checksum,$design_size)=
    unpack"nnnnnnnnnnnnNN",$s;
  if (!(length($s)==24+8 and defined $np and $np>=MIN_NPARS and
    $lf<32768 and $lh<32768 and $bc<32768 and $ec<256   and
    $nw<32768 and $nh<32768 and $nd<32768 and $ni<32768 and
    $nl<32768 and $nk<32768 and $ne<=256  and $np<32768 and
    $lf==6+$lh+$ec-$bc+1+$nw+$nh+$nd+$ni+$nl+$nk+$ne+$np
  )) {
    die "$0: doesn't seem to be TFM: $fn\n"
  }
  my $param_delta=-2+$lh+$ec-$bc+1+$nw+$nh+$nd+$ni+$nl+$nk+$ne;
  die unless $param_delta*4==read TFF, $s, $param_delta*4;
  die unless $np*4==read TFF, $s, $np*4;
  no integer;
  my @params=(0,unpack"N*", $s);
  my @oldpar=@params;
  # ^^^ Dat: fix-word: 1 bit sign, 11 integer, 20 bit fraction
  # ^^^ negation is 2's complement of entire word
  #print "* $fn\n";
  #print "- design_size=".fix2s($design_size)."pt "
  #    . "space=".fix2ss($design_size,$params[SPACE])."pt "
  #    . "plus ".fix2ssf($design_size,$params[SPACE_STRETCH])."pt "
  #    . "minus ".fix2ssf($design_size,$params[SPACE_SHRINK])."pt.\n";
  if ($do_fix_space) { $params[SPACE]=349525 } # 1/3*design_size, as in cmr10.tfm
  if ($do_fix_space_stretch) { $params[SPACE_STRETCH]=$params[SPACE]/2 } # as in cmr10.tfm
  if ($do_fix_space_shrink) { $params[SPACE_SHRINK]=($params[SPACE]+1)/3 } # as in cmr10.tfm
  my $changed=0;  
  for my $idx (SPACE, SPACE_STRETCH, SPACE_SHRINK) {
    if (abs($params[$idx]-$oldpar[$idx])<10) {
      $params[$idx]=$oldpar[$idx]
    } else { $changed=1 }
  }
  if ($changed) {
    #print "+ design_size=".fix2s($design_size)."pt "
    #	. "space=".fix2ss($design_size,$params[SPACE])."pt "
    #	. "plus ".fix2ssf($design_size,$params[SPACE_STRETCH])."pt "
    #	. "minus ".fix2ssf($design_size,$params[SPACE_SHRINK])."pt.\n";
    die unless seek TFF, -($np*4), 1;
    die unless print TFF substr(pack("N*",@params),4);
  }
  die unless close TFF;
}

my $_SS;
sub oct2bin_ss() {
  no integer;
  # by pts@fazekas.hu at Fri Jan 19 22:36:41 CET 2001
  # afm2tfm always produces 200/100 for stretch/shrink
  #   voutln2("(STRETCH D %d)", transform(200,0)) ;                             
  #   voutln2("(SHRINK D %d)", transform(100,0)) ;
  # in ecrm1000.tfm,        SPACE/STRETCH/SHRINK is 6/3/2
  # in minion with afm2tfm, SPACE/STRETCH/SHRINK is 23/20/10
  # we'll make 6/3/2
  ##print STDERR "($_)\n";
  if ($OPTS{'-fixsh-vf'}) {
    if (defined $OPTS{'-set-space'}) { # Dat: e.g --set-space 333
      s@^   \(SPACE D (\d+)\)$@   (SPACE D $OPTS{'-set-space'})@;
    }
    $_SS=$1 if /\(SPACE D (\d+)\)/; # Dat: usually 227 or 333
    if (defined $_SS) {
      s@\(STRETCH D \d+\)@
	die if! defined $_SS;
	"(STRETCH D ".int($_SS/2).")"
      @e;
      s@\(SHRINK D \d+\)@
	die if! defined $_SS;
	"(SHRINK D ".int($_SS/3).")"
      @e;
    }
  }
  1 while s/( C )([oOdDrRcC])([( )\n])/" D ".ord($2).$3/ge;
  1 while s/( O )([0-7]+)([( )\n])/" D ".oct($2).$3/ge;
}

sub vpl_fn2_tfm($) {
  my $FNT=$_[0]; del_ext $FNT; add_ext $FNT, '.tfm';
  $FNT=~s@/vf/@/tfm/@ or $FNT=~s@\Avf/@tfm/@;
  $FNT
}

sub vptovf($$) {
  my($optsH,$FN)=@_;
  return if !defined $FN;
  $_SS=undef;
  in_place $FN, \&oct2bin_ss if defined $optsH;
  my $FNT=vpl_fn2_tfm($FN);
  my $FNV=$FN; del_ext $FNV; add_ext $FNV, '.vf';
  # ^^^ we need these in case $FN contains a slash
  Pts::Xystem::xystem @{print_list([$cmd_vptovf, $FN, $FNV, $FNT])};
  min_size $FNT, 180;
  min_size $FNV, 180;
}
sub tftopl($$;$) {
  my($optsH,$FN)=@_;
  my $DONT=de $_[2];
  return if !defined $FN;
  $FN=~s/\.vpl\Z(?!\n)/.tfm/;
  my $FNP=$FN; del_ext $FNP;
  # vvv doesn't add anything new most of the time
  add_tex_fontname $FNP if !$DONT and $FNP!~/[\/\\]/;
  return if !defined $optsH;
  add_ext $FNP, ".pl";
  Pts::Xystem::xystem_redir $FNP, @{print_list([$cmd_tftopl, $FN])};
  in_place $FNP, \&oct2bin;
  min_size $FNP, 1024;
}

sub error_usage() {
  print "This is better_afm2tfm.pa $Htex::better_afm2tfm::VERSION\n",
    "Run this to read docs: $0 --man\n",
    "Extra options: -P -H -L -M\n\n";
  Pts::Xystem::xxec $cmd_afm2tfm, "--help";
  # Imp: give our own help screen
}

# ---

#my %OPTS;
my @OPTS;
my @OPTL;
#** Parse args, opts, options (similar to getopt)
sub parse_argv() {
  error_usage() if! @ARGV;
  if ($ARGV[0] eq '--man') {
    $ENV{__FILE__}=__FILE__;
    die "$0: exec failed: $!\n" unless exec "pod2man \"\$__FILE__\" | man -l -";
  }
  $OPTS{afmn}=shift @ARGV;
  $OPTS{tfmn}=undef;
  # ^^^ opts having argument
  my $I;
  for ($I=0;$I<=$#ARGV;$I++) {
    if ($ARGV[$I]=~/\A-/) {
      push @OPTS, $ARGV[$I];
      if (defined$ARGSW{$ARGV[$I]}) {
        error_usage() if $I==$#ARGV;
        if ($ARGV[$I]eq'-L') { push @OPTL, $ARGV[++$I] }
                        else { $OPTS{substr$ARGV[$I],1}=$OPTS{$ARGV[$I]}=$ARGV[$I+1]; $I++ }
      } else {
        $OPTS{substr$ARGV[$I],1}=1
      }
    } else {
      error_usage() if defined $OPTS{tfmn};
      $OPTS{tfmn}=$ARGV[$I];
    }
  } # all args
  if (!defined $OPTS{tfmn}) {
    $OPTS{tfmn}=$OPTS{afmn};
    $OPTS{tfmn}=$OPTS{v} if defined $OPTS{v};
    $OPTS{tfmn}=~s@/vf/@/tfm/@ or $OPTS{tfmn}=~s@\Avf/@tfm/@;
    error_usage() if !defined $OPTS{tfmn};
  }
  if (defined $OPTS{T}) {
    die "$0: please no both -T and -p/-t\n" if
      defined $OPTS{p} or defined $OPTS{t};
    $OPTS{t}=$OPTS{p}=$OPTS{T};
    delete $OPTS{T};
  }
}

just::main;

# --- main()

parse_argv();
$if_missing_mode_p=$OPTS{M};

add_ext $OPTS{afmn}, '.afm';
add_ext $OPTS{tfmn}, '.tfm';
add_ext $OPTS{t}, '.enc';
add_ext $OPTS{p}, '.enc';
add_ext $OPTS{v}, '.vpl';
add_ext $OPTS{V}, '.vpl';
add_exts$OPTS{P}, '.pfb', '.pfa';

die "$0: AFM not found: $OPTS{afmn}\n" unless open AF, "< $OPTS{afmn}";

unlink_all $OPTS{t};
unlink_all $OPTS{p};
unlink_all $OPTS{v};
unlink_all $OPTS{V};
unlink_all $OPTS{afmn};
unlink_all $OPTS{tfmn};

my %CCF;
fix_unenc_cc \%OPTS, \%CCF, \@OPTL;
fix_enc 'p', \%OPTS, \%CCF, \@OPTL;
fix_enc 't', \%OPTS, \%CCF, \@OPTL;

my $XLIGTABLE;
my %XCORRECT; # Imp: with Omega (Unicoded TeX) we may run out of mem??
# vvv overwrites the .vpl file, so we call it early
get_extra_lig \%OPTS, \@OPTS, \@OPTL, \%CCF, \$XLIGTABLE, \%XCORRECT;

my $RETS=fix_run_afm2tfm(\%OPTS, \@OPTS);
add_tex_fontname($RETS);

# Now we have the the .vpl file. We apply $XLIGTABLE and @XCORRECT to add
# metrics, kerning and ligature information afm2tfm forgot.
update_extra_lig \%OPTS, \$XLIGTABLE, \%XCORRECT;

vptovf $OPTS{H}, $OPTS{v}; # creates .tfm
vptovf $OPTS{H}, $OPTS{V}; # creates .tfm

if ($OPTS{'-fixsh-tfm'}) {
  for my $FN ($OPTS{v}, $OPTS{V}, $OPTS{tfmn}) {
    next if !defined $FN;
    my $FNT=vpl_fn2_tfm($FN);
    print "Fixing stretch/shrink in $FNT\n";
    fix_tfm_space $FNT;
  }
}
if ($OPTS{'-keep-pl'}) {
  tftopl $OPTS{H}, $OPTS{v}, 1;
  tftopl $OPTS{H}, $OPTS{V}, 1;
  tftopl $OPTS{H}, $OPTS{tfmn};
} else {
  unlink_file $OPTS{v};
  unlink_file $OPTS{V};
}

$RETS=~s/ <\Q$OPTS{p}\E/ <$OPTS{op}/ if defined $OPTS{p};
chomp $RETS;
if (defined $OPTS{P}) { # append PF[AB]NAME without directory
  my $S=$OPTS{P}; $S=~s@^.*/@@s;
  $RETS.=" <$S";
}
$RETS=~s/\A(\S+)\s*/ /;
## die $OPTS{'-update-map'};
update_psfonts_map($RETS,$OPTS{'-update-map'});

just::end __END__

=begin man

.ds pts-dev \*[.T]
.do if '\*[.T]'ascii'  .ds pts-dev tty
.do if '\*[.T]'ascii8' .ds pts-dev tty
.do if '\*[.T]'latin1' .ds pts-dev tty
.do if '\*[.T]'nippon' .ds pts-dev tty
.do if '\*[.T]'utf8'   .ds pts-dev tty
.do if '\*[.T]'cp1047' .ds pts-dev tty
.do if '\*[pts-dev]'tty' \{\
.ll 79
.pl 33333v
.nr IN 2n
.\}
.ad n

=end

=head1 NAME

better_afm2tfm.pl -- Install Type1 fonts for LaTeX using afm2tfm

=head1 SYNOPSIS

C<B<better_afm2tfm.pl>>
 S<[ I<inputfile.afm> ]>
 S<[ C<-P> I<PF[AB]FILE> ]>
 S<[ C<-L> I<LIGENCFILE> ]>
 S<[ C<--update-map> I<psfonts.map> ]>
 S<[ C<-H> ]> S<[ C<-M> ]> S<[ C<--keep-pl> ]>
 S<[ C<--fixsh-vf> ]> S<[ C<--fixsh-tfm> ]>
 S<[ C<--set-space> I<width-333> ]>
 S<I<args-to-afm2tfm>>
 S<I<outputfile.tfm>>
 
=head1 DESCRIPTION

better_afm2tfm.pl is a Perl script runs the teTeX standard afm2tfm utility
appropriately to generate TeX TFM and VF font files from an AFM file of a
Type1 PostScript font. better_afm2tfm.pl is tuned for the T1 encoding and
quickly installing Adobe fonts for use with LaTeX.

This documentation is quite incomplete.

 # -- Use `-P PF[AB]FILE' to specify the PFB file.
 # -- The `-H' (human-readable) option.
 # -- The user can specify '-L LIGENCFILE' options.
 # -- The `-M' (font-has-priority-over-cc) option.
 # -- --keep-pl keeps *.pl and *.vpl

=over 10

=item C<-P>

...

=back

Long drawn out discussion of the program.  It's a good idea to break this
up into subsections using the C<=head2> directives, like

=head2 The following glitches are fixed:

 -- Without $0, `CC' has no effect in AFM if the .enc for -p or -T
    _contains_ the specified glyph. Correction: better_afm2tfm.pl treats
    CC lines specially. (However, for compatibility reasons, lines beginning
    with `CC  ' (exactly two spaces) are left unaltered.) For the special
    lines, a fake .enc is created (in which their position is changed to
    /.notdef), and a fake AFM file is created (where `C ???' is changed to
    `C -1').

 -- $0 allows changing the priority of font glyphs and composites (`CC' in
    AFM). If the `-M' option is specified, a `CC' entry doesn't override a
    glpyh in the PFA/PFB file. Without the `-M' option, a `CC' entry
    overrides the glyph. If the `CC' line ends by `; FORCE ;', it
    overrides, independently of the `-M' option. If the `CC' line ends by
    `; IF-MISSING ;', it never overrides, independently of the `-M' option.
 
 -- $0 allows to user to close a `CC' line with `; IF-MISSING ;'. The effect
    is that this `CC' line will be ignored unless the glyph is missing from
    the /CharStrings dict of the PFA/PFB font file. `; IF-MISSING ;' is
    superfluous most of the time, 

 -- $0 allows to have `CC' line without a matching `C ... N' line for the
    composite glyphs. bbox information is computed from the bboxes of the
    components. The (advance) width of the composite will be equal to the
    with of the first component.

 -- $0 allows to OFFSET-CC construct in `CC' to build composited based on
    other composites. For example:

      ohungarumlaut 2 ; PCC o 0 0 ; PCC hungarumlaut OFFSET-CC otilde tilde ; IF-MISSING;

 -- The user can specify '-L LIGENCFILE' options. These files will be
    (temporarily) appended to the .enc for -p (and -T), so the user has the
    ability to specify additional `% LIGKERN's for a standard .enc file (e.g
    cork.enc), so there is no need for a (nonstandard, maybe
    incompatible) new .enc file. The standard .enc file can be used in
    psfonts.map, because '% LIGKERN's are not needed by that time. LIGENCFILE
    usually has the extension .app.

 -- The `% LIGKERN Oacute <> O ;' instruction in the LIGENCFILE affects all
    KPX pairs starting with Oacute, but doesn't affects those ending with
    Oacute (for TFM file size reasons). That's why $0 provides the
    KPX-EQ-R command in the .afm file. Example:

      KPX-EQ-R o ; oacute odieresis ohungarumlaut

    `% LIGKERN oacute <> o ;' (as defined by afm2tfm(1)) has no effect if
    there is already a `KPX oacute ...'.

    KPX-EQ-R adds, but never overrides KPX pairs. KPX-EQ-R doesn't follow
    multiple levels of indirection.
    
    `% LIGKERN oacute <> o ;' iuses the (LABEL) feature of the TFM files,
    so it generates quite comact code, but KPX-EQ-R cannot optimize this way.

 -- The old .tfm, .pl, .vf, .vpl, .*pk files are automatically removed from
    the current directory to avoid confusion.

 -- If resulting .tfm and .vpl files have size <512, an error message is
    produced (actually all such files in the teTeX distribution are >900
    bytes in length).

 -- If the `-H' (human-readable) option is specified, `vftovp' and `tftopl'
    are called to create the human-readable .vpl and .pl files.
    The octal character codes are converted to decimal in these files.

 -- The line for the .tfm in ./psfonts.map (not the system default!) is
    updated. Use `-P PF[AB]FILE' to specify the PFB file.

 -- Metrics, kerning and ligature information for unencodable characters
    (see docs of DVIPS, section 5.3, for the difference between -t and -p)
    for -t (without -T and -p) are inserted to the .vpl and .vf file, so
    metrics (.tfm) will be the same with -t and -T. You can compare them
    with `cmp': only some human-intended header comments are different.

=head2 The following extra command line options are available:

 -- Use `-P PF[AB]FILE' to specify the PFB file.
 -- The `-H' (human-readable) option.
 -- The user can specify '-L LIGENCFILE' options.
 -- The `-M' (font-has-priority-over-cc) option.

=head1 OPTIONS

Some people make this separate from the description.

=head1 RETURN VALUE

What the program or function returns if successful.

=head1 ERRORS

Exceptions, return codes, exit stati, and errno settings.

=head1 EXAMPLES

Give some example uses of the program.

=head1 ENVIRONMENT

Envariables this program might care about.

=head1 FILES

All files used by the program.  You should probably use the FE<lt>E<gt>
for these.

=head1 SEE ALSO

Other man pages to check out, like man(1), man(7), makewhatis(8), or catman(8).

=head1 NOTES

Miscellaneous commentary.

=head1 CAVEATS

Things to take special care with; sometimes called WARNINGS.

=head1 DIAGNOSTICS

All possible messages the program can print out--and
what they mean.

=head1 BUGS

Things that are broken or just don't work quite right.

=head1 RESTRICTIONS

Bugs you don't plan to fix :-)

=head1 AUTHOR

Szabó Péter <F<pts@fazekas.hu>>

Who wrote it (or AUTHORS if multiple).

=head1 HISTORY

Programs derived from other sources sometimes have this, or
you might keep a modification log here.

tex256.app

%
% tex256.app -- additions to afm2tfm(1) .enc files, for better_afm2tfm.pl 
% by pts@fazekas.hu near Sun Jan 03 22:16:05 CET 2001
% `% AFM' added Sat Nov  8 16:24:57 CET 2003
%
% Dat: LIGKERN + KPX-EQ-R handling of AE,OE,ae,oe are inconsistent; IJ
%      is just right.

% vvv only Hungarian
%% AFM KPX-EQ-R a ; aacute
%% AFM KPX-EQ-R e ; eacute
%% AFM KPX-EQ-R i ; iacute
%% AFM KPX-EQ-R o ; oacute odieresis ohungarumlaut
%% AFM KPX-EQ-R u ; uacute udieresis uhungarumlaut
%% AFM KPX-EQ-R A ; Aacute
%% AFM KPX-EQ-R E ; Eacute
%% AFM KPX-EQ-R I ; Iacute
%% AFM KPX-EQ-R O ; Oacute Odieresis Ohungarumlaut
%% AFM KPX-EQ-R U ; Uacute Udieresis Uhungarumlaut

% vvv useful with Adobe AFM files already having `CC otilde' etc.
% vvv Dat: acute is better than tilde/circumflex for Frutiger
% AFM CC   ohungarumlaut 2 ; PCC o 0 0 ; PCC hungarumlaut OFFSET-CC oacute acute ; IF-MISSING;
% AFM CC   Ohungarumlaut 2 ; PCC O 0 0 ; PCC hungarumlaut OFFSET-CC Oacute acute ; IF-MISSING;
% AFM CC   uhungarumlaut 2 ; PCC u 0 0 ; PCC hungarumlaut OFFSET-CC uacute acute ; IF-MISSING;
% AFM CC   Uhungarumlaut 2 ; PCC U 0 0 ; PCC hungarumlaut OFFSET-CC Uacute acute ; IF-MISSING;
% vvv Dat: Adobe fonts usually have caron [sS]caron [zZ]caron, but not
%     [cC] [dD] [eE] [lL] [nN] [rR] [tT]caron
% vvv Dat: OFFSET-CC usually does very poor horizontal positioning :-(
%          Imp: we'd need OFFSET-MIDALIGN-CC instead
% Dat: too left: Ccaron Dcaron Ncaron ccaron dcaron ecaron ncaron
% Dat: too right: Lcaron Tcaron lcaron tcaron
% Imp: warning if replacement dotlessj is used
% AFM CC   ccaron 2 ; PCC c 0 0 ; PCC caron OFFSET-CC zcaron caron ; IF-MISSING;
% AFM CC   dcaron 2 ; PCC d 0 0 ; PCC caron OFFSET-CC Scaron caron ; IF-MISSING;
% AFM CC   ecaron 2 ; PCC e 0 0 ; PCC caron OFFSET-CC zcaron caron ; IF-MISSING;
% AFM CC   lcaron 2 ; PCC l 0 0 ; PCC caron OFFSET-CC Scaron caron ; IF-MISSING;
% AFM CC   ncaron 2 ; PCC n 0 0 ; PCC caron OFFSET-CC scaron caron ; IF-MISSING;
% AFM CC   tcaron 2 ; PCC t 0 0 ; PCC caron OFFSET-CC Scaron caron ; IF-MISSING;
% AFM CC   rcaron 2 ; PCC r 0 0 ; PCC caron OFFSET-CC scaron caron ; IF-MISSING;
% AFM CC   Ccaron 2 ; PCC C 0 0 ; PCC caron OFFSET-CC Scaron caron ; IF-MISSING;
% AFM CC   Dcaron 2 ; PCC D 0 0 ; PCC caron OFFSET-CC Scaron caron ; IF-MISSING;
% AFM CC   Ecaron 2 ; PCC E 0 0 ; PCC caron OFFSET-CC Scaron caron ; IF-MISSING;
% AFM CC   Lcaron 2 ; PCC L 0 0 ; PCC caron OFFSET-CC Scaron caron ; IF-MISSING;
% AFM CC   Ncaron 2 ; PCC N 0 0 ; PCC caron OFFSET-CC Scaron caron ; IF-MISSING;
% AFM CC   Tcaron 2 ; PCC T 0 0 ; PCC caron OFFSET-CC Scaron caron ; IF-MISSING;
% AFM CC   Rcaron 2 ; PCC R 0 0 ; PCC caron OFFSET-CC Scaron caron ; IF-MISSING;
% AFM CC   sfthyphen 1 ; PCC hyphen 0 0 ; IF-MISSING;
% AFM CC   dotlessj 1 ; PCC j 0 0 ; IF-MISSING;
% AFM TOTAL-CC   SS 2 ; PCC S 0 0 ; PCC S WIDTH-OF S 0 ; IF-MISSING;
% AFM CC   Tcedilla 2 ; PCC T 0 0 ; PCC cedilla OFFSET-CC Ccedilla cedilla ; IF-MISSING;
% AFM CC   tcedilla 2 ; PCC t 0 0 ; PCC cedilla OFFSET-CC ccedilla cedilla ; IF-MISSING;
% A%FM CC   cwm 0 ; IF-MISSING; % Dat: afm2tfm(1) ignores `CC cwm 0 ;' anyway -- and doesn't embed the char to the font
% A%FM CC   ohungarumlaut 2 ; PCC o 0 0 ; PCC hungarumlaut OFFSET-CC otilde tilde ; IF-MISSING;
% A%FM CC   Ohungarumlaut 2 ; PCC O 0 0 ; PCC hungarumlaut OFFSET-CC Otilde tilde ; IF-MISSING;
% A%FM CC   uhungarumlaut 2 ; PCC u 0 0 ; PCC hungarumlaut OFFSET-CC ucircumflex circumflex ; IF-MISSING;
% A%FM CC   Uhungarumlaut 2 ; PCC U 0 0 ; PCC hungarumlaut OFFSET-CC Ucircumflex circumflex ; IF-MISSING;

% vvv contains all accented letters T1 encoding has
%     by pts@fazekas.hu at Sat Nov  8 15:21:49 CET 2003
% AFM KPX-EQ-R E ; AE
% AFM KPX-EQ-R J ; IJ
% AFM KPX-EQ-R E ; OE
% AFM KPX-EQ-R S ; SS
% AFM KPX-EQ-R e ; ae
% AFM KPX-EQ-R j ; ij
% AFM KPX-EQ-R e ; oe
% AFM KPX-EQ-R s ; ss
% AFM KPX-EQ-R A ; Aacute Abreve Acircumflex Adieresis Agrave Aogonek Aring Atilde
% AFM KPX-EQ-R C ; Cacute Ccaron Ccedilla
% AFM KPX-EQ-R D ; Dbar Dcaron Dcroat Dmacron Dquoteright Eth
% AFM KPX-EQ-R E ; Eacute Ecaron Ecircumflex Edieresis Egrave Eogonek
% AFM KPX-EQ-R G ; Gbreve
% AFM KPX-EQ-R I ; Iacute Icircumflex Idieresis Idotaccent Igrave
% AFM KPX-EQ-R L ; Lacute Lcaron Lquoteright Lslash
% AFM KPX-EQ-R N ; Nacute Ncaron Ntilde
% AFM KPX-EQ-R O ; Oacute Ocircumflex Odblacute Odieresis Ograve Ohungarumlaut Oslash Otilde
% AFM KPX-EQ-R R ; Racute Rcaron
% AFM KPX-EQ-R S ; Sacute Scaron Scedilla Scommaaccent
% AFM KPX-EQ-R T ; Tcaron Tcedilla Tcommaaccent Tquoteright
% AFM KPX-EQ-R U ; Uacute Ucircumflex Udblacute Udieresis Ugrave Uhungarumlaut Uring
% AFM KPX-EQ-R Y ; Yacute Ydieresis
% AFM KPX-EQ-R Z ; Zacute Zcaron Zdotaccent
% AFM KPX-EQ-R a ; aacute abreve acircumflex adieresis agrave aogonek aring atilde
% AFM KPX-EQ-R c ; cacute ccaron ccedilla
% AFM KPX-EQ-R d ; dbar dcaron dcroat dmacron dquoteright eth
% AFM KPX-EQ-R e ; eacute ecaron ecircumflex edieresis egrave eogonek
% AFM KPX-EQ-R g ; gbreve
% AFM KPX-EQ-R i ; iacute icircumflex idieresis idotaccent igrave
% AFM KPX-EQ-R l ; lacute lcaron lquoteright lslash
% AFM KPX-EQ-R n ; nacute ncaron ntilde
% AFM KPX-EQ-R o ; oacute ocircumflex odblacute odieresis ograve ohungarumlaut oslash otilde
% AFM KPX-EQ-R r ; racute rcaron
% AFM KPX-EQ-R s ; sacute scaron scedilla scommaaccent
% AFM KPX-EQ-R t ; tcaron tcedilla tcommaaccent tquoteright
% AFM KPX-EQ-R u ; uacute ucircumflex udblacute udieresis ugrave uhungarumlaut uring
% AFM KPX-EQ-R y ; yacute ydieresis
% AFM KPX-EQ-R z ; zacute zcaron zdotaccent

% vvv ripped from the afm2tfm binary itself
% LIGKERN ff l =: ffl ;
% LIGKERN f i =: fi ; f l =: fl ; f f =: ff ; ff i =: ffi ;

% vvv contains all accented letters T1 encoding has
%     by pts@fazekas.hu at Sat Nov  8 15:21:49 CET 2003
% LIGKERN AE <> A ; ae <> a ;
% LIGKERN Aacute <> A ; aacute <> a ;
% LIGKERN Abreve <> A ; abreve <> a ;
% LIGKERN Acircumflex <> A ; acircumflex <> a ;
% LIGKERN Adieresis <> A ; adieresis <> a ;
% LIGKERN Agrave <> A ; agrave <> a ;
% LIGKERN Aogonek <> A ; aogonek <> a ;
% LIGKERN Aring <> A ; aring <> a ;
% LIGKERN Atilde <> A ; atilde <> a ;
% LIGKERN Cacute <> C ; cacute <> c ;
% LIGKERN Ccaron <> C ; ccaron <> c ;
% LIGKERN Ccedilla <> C ; ccedilla <> c ;
% LIGKERN Dbar <> D ; dbar <> d ;
% LIGKERN Dcaron <> D ; dcaron <> d ;
% LIGKERN Dcroat <> D ; dcroat <> d ;
% LIGKERN Dmacron <> D ; dmacron <> d ;
% LIGKERN Dquoteright <> D ; dquoteright <> d ;
% LIGKERN Eacute <> E ; eacute <> e ;
% LIGKERN Ecaron <> E ; ecaron <> e ;
% LIGKERN Ecircumflex <> E ; ecircumflex <> e ;
% LIGKERN Edieresis <> E ; edieresis <> e ;
% LIGKERN Egrave <> E ; egrave <> e ;
% LIGKERN Eogonek <> E ; eogonek <> e ;
% LIGKERN Eth <> D ; eth <> d ;
% LIGKERN Gbreve <> G ; gbreve <> g ;
% LIGKERN IJ <> I ; ij <> i ;
% LIGKERN Iacute <> I ; iacute <> i ;
% LIGKERN Icircumflex <> I ; icircumflex <> i ;
% LIGKERN Idieresis <> I ; idieresis <> i ;
% LIGKERN Idotaccent <> I ; idotaccent <> i ;
% LIGKERN Igrave <> I ; igrave <> i ;
% LIGKERN Lacute <> L ; lacute <> l ;
% LIGKERN Lcaron <> L ; lcaron <> l ;
% LIGKERN Lquoteright <> L ; lquoteright <> l ;
% LIGKERN Lslash <> L ; lslash <> l ;
% LIGKERN Nacute <> N ; nacute <> n ;
% LIGKERN Ncaron <> N ; ncaron <> n ;
% LIGKERN Ntilde <> N ; ntilde <> n ;
% LIGKERN OE <> O ; oe <> o ;
% LIGKERN Oacute <> O ; oacute <> o ;
% LIGKERN Ocircumflex <> O ; ocircumflex <> o ;
% LIGKERN Odblacute <> O ; odblacute <> o ;
% LIGKERN Odieresis <> O ; odieresis <> o ;
% LIGKERN Ograve <> O ; ograve <> o ;
% LIGKERN Ohungarumlaut <> O ; ohungarumlaut <> o ;
% LIGKERN Oslash <> O ; oslash <> o ;
% LIGKERN Otilde <> O ; otilde <> o ;
% LIGKERN Racute <> R ; racute <> r ;
% LIGKERN Rcaron <> R ; rcaron <> r ;
% LIGKERN SS <> S ; ss <> s ;
% LIGKERN Sacute <> S ; sacute <> s ;
% LIGKERN Scaron <> S ; scaron <> s ;
% LIGKERN Scedilla <> S ; scedilla <> s ;
% LIGKERN Scommaaccent <> S ; scommaaccent <> s ;
% LIGKERN Tcaron <> T ; tcaron <> t ;
% LIGKERN Tcedilla <> T ; tcedilla <> t ;
% LIGKERN Tcommaaccent <> T ; tcommaaccent <> t ;
% LIGKERN Tquoteright <> T ; tquoteright <> t ;
% LIGKERN Uacute <> U ; uacute <> u ;
% LIGKERN Ucircumflex <> U ; ucircumflex <> u ;
% LIGKERN Udblacute <> U ; udblacute <> u ;
% LIGKERN Udieresis <> U ; udieresis <> u ;
% LIGKERN Ugrave <> U ; ugrave <> u ;
% LIGKERN Uhungarumlaut <> U ; uhungarumlaut <> u ;
% LIGKERN Uring <> U ; uring <> u ;
% LIGKERN Yacute <> Y ; yacute <> y ;
% LIGKERN Ydieresis <> Y ; ydieresis <> y ;
% LIGKERN Zacute <> Z ; zacute <> z ;
% LIGKERN Zcaron <> Z ; zcaron <> z ;
% LIGKERN Zdotaccent <> Z ; zdotaccent <> z ;
% < /Eng /eng
% < /dcroat /dbar /dmacron
% < /Odblacute /odblacute
% < /Tcommaaccent /tcommaaccent
% < /Scommaaccent /scommaaccent
% < /dquoteright
% < /Lquoteright /lquoteright
% < /Tquoteright /tquoteright
% < Thorn

% LIGKERN nine {} * ; * {} nine ;
% LIGKERN seven {} * ; * {} seven ; eight {} * ; * {} eight ;
% LIGKERN five {} * ; * {} five ; six {} * ; * {} six ;
% LIGKERN three {} * ; * {} three ; four {} * ; * {} four ;
% LIGKERN one {} * ; * {} one ; two {} * ; * {} two ;
% LIGKERN space {} * ; * {} space ; zero {} * ; * {} zero ;
% LIGKERN quoteright quoteright =: quotedblright ;
% LIGKERN quoteleft quoteleft =: quotedblleft ;
% LIGKERN hyphen hyphen =: endash ; endash hyphen =: emdash ;
% LIGKERN exclam quoteleft =: exclamdown ;
% LIGKERN question quoteleft =: questiondown ;
% LIGKERN space l =: lslash ; space L =: Lslash ;

% vvv part of original cork.enc
% LIGKERN space l =: lslash ; space L =: Lslash ;
% LIGKERN question quoteleft =: questiondown ; exclam quoteleft =: exclamdown ;
% LIGKERN hyphen hyphen =: endash ; endash hyphen =: emdash ;
% LIGKERN quoteleft quoteleft =: quotedblleft ;
% LIGKERN quoteright quoteright =: quotedblright ;
% LIGKERN comma comma =: quotedblbase ; less less =: guillemotleft ;
% LIGKERN greater greater =: guillemotright ;
%
%   We blow away kerns to and from spaces (TeX doesn't have a
%   space) and also remove any kerns from the numbers (although
%   the only kern pair that mentions a number in Times-Roman.afm
%   is one one.)
%
% LIGKERN space {} * ; * {} space ; zero {} * ; * {} zero ;
% LIGKERN one {} * ; * {} one ; two {} * ; * {} two ;
% LIGKERN three {} * ; * {} three ; four {} * ; * {} four ;
% LIGKERN five {} * ; * {} five ; six {} * ; * {} six ;
% LIGKERN seven {} * ; * {} seven ; eight {} * ; * {} eight ;
% LIGKERN nine {} * ; * {} nine ;

tfm_ligkernfix.pl

#! /bin/sh
eval '(exit $?0)' && eval 'PERL_BADLANG=x;PATH="$PATH:.";export PERL_BADLANG\
;exec perl -x -S -- "$0" ${1+"$@"};#'if 0;eval 'setenv PERL_BADLANG x\
;setenv PATH "$PATH":.;exec perl -x -S -- "$0" $argv:q;#'.q
#!perl -w
+push@INC,'.';$0=~/(.*)/s;do(index($1,"/")<0?"./$1":$1);die$@if$@__END__+if 0
;#Don't touch/remove lines 1--7: http://www.inf.bme.hu/~pts/Magic.Perl.Header
#
# tfm_ligkernfix.pl -- adds extra kerning pairs
# by pts@fazekas.hu at Mon Feb 23 14:36:31 CET 2004
# -- Mon Feb 23 19:57:10 CET 2004
# doesn't add missing chars at Fri Mar 12 16:20:02 CET 2004
#
# Dat: works at last
# Dat: doesn't work with mf(1) skipto instruction
#
use integer;
use strict;
BEGIN { $main::VERSION=0.08 }

#** @param $_[0] "config.ps", "config" or "pdftex.cfg" etc.
#** @param $_[1] argument of --progname
#** @param $_[2] argument of --format
#** @return the absoulte version of $_[0]
sub get_absname($$$) {
  my $confrel=$_[0]; $confrel=~y@\\@/@;
  my $confabs=$confrel;
  if (substr($confrel,0,1)ne'/') {
    # Dat: need to append $PWD to: 0>index($confrel,'/') and (-f$confrel
    # vvv $confrel and $_[1] are assumed not to contain weird characters
    my $cmd="kpsewhich --must-exist --progname=$_[1] --format=\"$_[2]\" -- \"$confrel\" 2>&1";
    $confabs=qx($cmd);
    chomp $confabs;
  }
  # Dat: $confabs might begin with `./'
  die "$0: file not found: $confrel\n"
    if length($confabs)<length($confrel)-1
    # or substr($confabs,-length($confrel)-1,1) ne "/"
    # or substr($confabs,-length($confrel)) ne $confrel # $confrel may contain `..'
    or !-f $confabs;
  $confabs
}

#** @return $_[0] quoted for /bin/sh
sub shq($) {
  my $S=$_[0];
  return $S if $S!~y@A-Za-z0-9_,:./-@@c and length($S)>0;
  $S=~s@'@'\\''@g;
  return "'$S'"
}

# --- main()

my $install_p=0;
my $keep_p=0;
my @encs=();
{ my $I;
  for ($I=0;$I<@ARGV;$I++) {
       if ($ARGV[$I] eq '-i' or $ARGV[$I] eq '--install') { $install_p=1 }
    elsif ($ARGV[$I] eq '-k' or $ARGV[$I] eq '--keep') { $keep_p=1 }
    elsif ($ARGV[$I] eq '-e' or $ARGV[$I] eq '--encfile') {
      die if $I==$#ARGV;
      push @encs, $ARGV[++$I]
    }      
    elsif ($ARGV[$I] eq '--') { $I++; last }
    elsif (substr($ARGV[$I],0,1)eq'-') { die "$0: unknown option: $ARGV[$I]\n" }
    else { last }
  }
  splice @ARGV, 0, $I
}
die "Usage: $0 [--install] [--keep] [--encfile=<f> ...] FILENAME[.tfm]
A .pl file is created in . as a temporary junk file.
--install installs the new TFM back to its original place
--encfile adds a dvips(1) .enc file with `% LIGKERN' etc.
--keep doesn't add new kerning pairs, but compresses
" if @ARGV!=1;
my $tfmrel=$ARGV[0];
push @encs, qw(tex256.enc tex256.app) if !@encs;

$tfmrel.='.tfm' if $tfmrel!~m@[.][^./\\]+\Z(?!\n)@;
my $tfmabs=get_absname($tfmrel,"tex","tfm");
$install_p=1 if substr($tfmrel,0,1) ne'.' and $tfmabs eq "./$tfmrel";
my $fontname=$tfmrel;
$fontname=~s@\A.*/@@s; # Dat: depends on UNIX
$fontname=~s@[.][^./\\]+\Z(?!\n)@@;
print STDERR "This is tfm_ligkernfix.pl v$main::VERSION, (C) Feb 2003 by pts\@fazekas.hu\n";
print STDERR "Patching font $fontname, file $tfmabs\n";

##** $kpx_eq_l{IJ}='I': IJ is equivalent to `I' when `IJ' is the _1st_ char of
##** a kerning pair.
#my %kpx_eq_l;
#** $kpx_eq_ls{I}=qw(IJ Iacute): IJ and Igrave should get the same
#** kerning as `I' when they are the _1st_ char of a kerning pair
my %kpx_eq_ls;
##** $kpx_eq_r{Aacute}='A': Aacute is equivalent to `A' when `Aacute' is the
##**   _2nd_ char of a kerning pair.
#my %kpx_eq_r;
#** $kpx_eq_rs{A}=qw(Aacute Agrave): Aacute and Agrave should get the same
#** kerning as `A' when they are the _2nd_ char of a kerning pair
my %kpx_eq_rs;
#** $enc[65]='A';
my @enc;
#** $renc{'A'}='65';
my %renc;

my $nright=0;
my $nleft=0;
my $had_open=0;
for my $encrel (@encs) {
  my $encabs=($encrel=~/[.]app\Z(?!\n)/ ? get_absname($encrel,'afm2tfm','afm')
    : get_absname($encrel,'dvips','PostScript header'));
  print STDERR "Loading enc $encabs\n";
  die unless open F, "< $encabs";
  while (<F>) {
    if (/[%]\s*LIGKERN\s+(.*)/) {
      $_=$1;
      while (/([^\s<>;]+)\s*[<][>]\s*([^\s<>;]+)/g) {
        ##print "ligkern $1 $2\n";
	#$kpx_eq_l{$1}=$2 if $1 ne $2 # Dat: override OK
	push @{$kpx_eq_ls{$2}}, $1; # Dat: override not detected
	# ^^^ Dat: brings @{$kpx_eq_ls{$2}} undef -> []
	$nleft++;
      }
    } elsif (/%\s*AFM\s+KPX-EQ-R\s+([^\s<>;]+)\s*;\s*(.*)/) {
      my $rchar=$1; $kpx_eq_rs{$rchar}=[] if !exists $kpx_eq_rs{$rchar};
      $_=$2;
      while (/([^\s<>;]+)/g) {
        ##print "kpx-eq-r $rchare $1\n";
	push @{$kpx_eq_rs{$rchar}}, $1; # Dat: override not detected
	$nright++;
      }
    }
    s@%.*@@; # remove comments
    if (!$had_open) {
      next if !s@\A.*?\[@@;
      $had_open=1;
    }
    while (m@/([^\s<>/;]+)@g) {
      $renc{$1}=scalar@enc; # Dat: override OK
      push @enc, $1;
    }
  }
  die unless close F;
}
print STDERR "Total encoded chars: ". scalar(@enc)."\n";
print STDERR "warning: ^^^ should be 256\n" if @enc!=256;
print STDERR "Total left eqs: $nleft\n";
print STDERR "Total right eqs: $nright\n";

print STDERR   "Running tftopl -charcode-format=octal ".shq($tfmabs)."\n";
die unless open PIPE, "tftopl -charcode-format=octal ".shq($tfmabs)."|";
die "tftopl(1) didn't emit a TFM file\n" unless defined($_=<PIPE>) and /^\(FAMILY [^)]+\)$/;
die "$0: write $fontname.pl: $!\n" unless open PL, "> $fontname.pl";

#** $krnn[65][66]=7.8
my @krnn;
#** $lign[ord"f"][ord"i"]=1
my @lign;
#** $ligsl[ord'f']=("   (LIG O ... ...)\n",...);
my @ligsl;

die if! print PL; # `(FAMILY ...)'
while (<PIPE>) {
  last if $_ eq "(LIGTABLE\n";
  if (substr($_,0,13)eq'(CHARACTER O ') { 
    # Dat: some .tfm files generated by afm2tfm(1) (such as pflb8v.tfm) do not
    #      contain any LIGTABLE
    last
  }
  die if! print PL;
}
die "$0: LIGTABLE and CHARACTER missing\n" if !defined $_;
my $nliglabels=0;
my @actives;
my $tfm_left="";
if ($_ eq"(LIGTABLE\n") {
  while (<PIPE>) {
    last if $_ eq "   )\n";
    if (/^   [(]LABEL O ([0-7]+)[)]$/) {
      push @actives, oct$1;
      $nliglabels++;
      #push @{$ligsl[oct$1]}, $_;
    #} elsif (/^   [(]LABEL BOUNDARYCHAR[)]$/) {
    #  # !! silently ignore
    #  <PIPE>; next
    } elsif ($_ eq "   (STOP)\n") {
      @actives=();
    } elsif (/^   [(]KRN O ([0-7]+) R (-?[.0-9]+)[)]$/) {
      die "$0: missing LABEL ($.)\n" if !@actives;
      for my $left (@actives) { $krnn[$left][oct$1]=$2 }
    } elsif (/^   [(](\S*LIG\S* O ([0-7]+) O [0-7]+)[)]$/) {
      # Dat: maybe store ligature type and ligature destination char (O [0-7]+)
      die "$0: missing LABEL ($.)\n" if !@actives;
      for my $left (@actives) { $lign[$left][oct$2]=$1 }
    } else {
      die "$0: missing LABEL ($.)\n" if !@actives;
      for my $left (@actives) { push @{$ligsl[$left]}, $_  }
    }
  }
  print STDERR "Total ligtable labels: $nliglabels\n";
} else {
  $tfm_left=$_
}

{ my @kilkrn;
  # Dat: kill the kerning pair if a ligature is present (as in MinionPro-Regular.otf)
  for (my $left=0;$left<@lign;$left++) {
    my $ligs=$lign[$left];
    my $krns=$krnn[$left];
    next if !defined $ligs or !defined $krns;
    for (my $right=0;$right<@$ligs;$right++) {
      next if !defined $ligs->[$right];
      if (defined $krns->[$right])  {
        undef $krns->[$right]; # kill the kerning pair
	push @kilkrn, "$left+$right";
      }
    }
  }
  print STDERR "Kerning pairs shadowed by ligatures: @kilkrn\n" if @kilkrn;
}

#die $liglines[$ligstart[ord'Y']]; # 'Y'==0131

#** $had_chars{$charcode}=1;
my %had_chars;
while (<PIPE>) {
  $had_chars{oct$1}=1 if /^\(CHARACTER O ([0-7]+)$/;
  $tfm_left.=$_
}
die "$0: tftopl(1) failed\n" if !close PIPE; # Dat: input not fully read
print STDERR "Total defined chars: ".scalar(keys%had_chars)."\n";

#** Removes duplicates from a sorted list
#** @param $_[0] an arrayref
sub uniq($) {
  my $L=$_[0];
  if (@$L>1) {
    my $I=1;
    my $J=1;
    for (my $I=1;$I<@$L;$I++) { $L->[$J++]=$L->[$I] if $L->[$I] ne $L->[$J-1] }
    splice @$L, $J;
    #die if $J<$I
  }
  $L
}
# my @L=(4,4,5,6,6,6,7); uniq \@L; die "@L;\n";

sub sort_uniq($) {
  $_[0]=[sort@{$_[0]}];
  uniq $_[0]
}

while (my($k,$v)=each%kpx_eq_rs) { sort_uniq $v }
while (my($k,$v)=each%kpx_eq_ls) { sort_uniq $v }
#while (my($k,$v)=each%kpx_eq_rs) { print "R @$v\n" }
#while (my($k,$v)=each%kpx_eq_ls) { print "L @$v\n" }

my $npairs=0;
for (my $left=0;$left<@krnn;$left++) { # add kpx_eq_rs
  my $krns=$krnn[$left];
  next if !defined $krns;
  my $nleft;
  for (my $right=0;$right<@$krns;$right++) {
    next if !defined $krns->[$right];
    if (!exists $had_chars{$left}) {
      print STDERR "warning: missing left char for pair ($left,$right)\n";
      # Dat: pltotf(1) will add an empty char
    }
    if (!exists $had_chars{$right}) {
      print STDERR "warning: missing right char for pair ($left,$right)\n";
      # Dat: pltotf(1) will add an empty char
    }
    $npairs++;
  }
}
print STDERR "Total kerning pairs: $npairs\n";
#delete $krnn[ord'T'][ord'é'];

if (!$keep_p) {
  my $nnoadd=0; # Dat: counts with iteration multiplicity
  my $nadded_l=0;
  my $nadded_r=0;
  my $niter=0;
  my $pre_iter_sum=-1;
  while ($npairs!=0 && $pre_iter_sum!=$nadded_l+$nadded_r) {
    $pre_iter_sum=$nadded_l+$nadded_r;
    $niter++;
    for (my $left=0;$left<@krnn;$left++) { # add kpx_eq_rs
      my $krns=$krnn[$left];
      next if !defined $krns;
      my $nleft;
      for (my $right=0;$right<@$krns;$right++) {
	next if !defined $krns->[$right];
	next if !defined $enc[$right]; # !defined if no --encfile tex256.map
	my $L=$kpx_eq_rs{$enc[$right]};
	next if !defined $L;
	my $rI;
	for my $I (@$L) {
	  my $rI=$renc{$I};
	  if (defined $rI and !defined $krns->[$rI]) {
	    if (!exists $had_chars{$rI} or (defined $lign[$left] and defined $lign[$left][$rI])) {
	      $nnoadd++;
	    } else {
	      $krns->[$rI]=$krns->[$right];
	      $nadded_r++;
	    }
	  }
	}
      }
    }
    for (my $left=0;$left<@krnn;$left++) { # add kpx_eq_ls
      my $krns=$krnn[$left];
      next if !defined $krns;
      next if !defined $enc[$left]; # !defined if no --encfile tex256.map
      my $L=$kpx_eq_ls{$enc[$left]};
      next if !defined $L;
      for (my $right=0;$right<@$krns;$right++) {
	next if !defined $krns->[$right];
	my $rI;
	for my $I (@$L) {
	  my $rI=$renc{$I};
	  if (defined $rI and !defined $krnn[$rI][$right]) {
	    if (!exists $had_chars{$rI} or (defined $lign[$rI] and defined $lign[$rI][$right])) {
	      $nnoadd++;
	    } else {
	      $krnn[$rI][$right]=$krns->[$right];
	      $nadded_l++;
	    }
	  }
	}
      }
    } ## NEXT
  } ## WHILE
  print STDERR "Total iterations: $niter\n";
  print STDERR "Total added kerning pairs (left ): $nadded_l\n";
  print STDERR "Total added kerning pairs (right): $nadded_r\n";
  print STDERR "Total pairs not added: $nnoadd\n";
} ## IF

my @ligsp;
for (my $left=0;$left<@krnn;$left++) {
  #next if !defined $krnn[$left];
  #die if !defined $ligsl[$left];
  my @SL=defined $ligsl[$left] ? @{$ligsl[$left]} : ();
  my $krns=$krnn[$left];
  if (defined $krns) {
    for (my $right=0;$right<@$krns;$right++) {
      next if !defined $krns->[$right];
      push @SL, "   (KRN O ".sprintf("%o",$right)." R $krns->[$right])\n";
      #$ax++;
    }
  }
  my $ligs=$lign[$left];
  if (defined $ligs) {
    for (my $right=0;$right<@$ligs;$right++) {
      next if !defined $ligs->[$right];
      # Dat: BUGFIX at Mon May 10 20:21:49 CEST 2004
      push @SL, "   (".$ligs->[$right].")\n";
      #$ax++;
    }
  }
  push @ligsp, [$left, join("",sort@SL)] if @SL;
}

if (@ligsp) {
  die if !print PL "(LIGTABLE\n";
  my $nelim=0;
  @ligsp=sort { $a->[1] cmp $b->[1] } @ligsp;
  push @ligsp, [ -1, "-" ]; # sentinel
  for (my $I=0;$I<$#ligsp;$I++) {
    die if! print PL "   (LABEL O ".sprintf("%o",$ligsp[$I][0]).")\n";
    if ($ligsp[$I][1] eq $ligsp[$I+1][1]) {
      $nelim++;
    } else {
      die if 0==length($ligsp[$I][1]);
      die if! print PL $ligsp[$I][1], "   (STOP)\n";
    }
  }
  print STDERR "Total eliminated bodies: $nelim\n";
  die if! print PL "   )\n";
}

die if! print PL $tfm_left;
die unless close PL;

my $tfmdest=($install_p ? $tfmabs : "$fontname.tfm");
print STDERR "Running pltotf ".shq("$fontname.pl")." ".shq($tfmdest)."\n";
die "$0: pltotf failed\n" if 0!=system 'pltotf', "$fontname.pl", $tfmdest;
print STDERR "Left junk file: $fontname.pl\n";
if (!$install_p) {
  print STDERR "Done. Install with:  cp ".shq("$fontname.tfm")." ".shq($tfmabs)."\n";
} else {
  print STDERR "Installed TFM: $tfmdest\n";
}  

__END__