Skip to content

Instantly share code, notes, and snippets.

@pts

pts/better_afm2tfm.pl

Last active August 30, 2017 12:26
Show Gist options
  • Save pts/6ecadf19e8556cc4e0b4fa498c01e410 to your computer and use it in GitHub Desktop.
Save pts/6ecadf19e8556cc4e0b4fa498c01e410 to your computer and use it in GitHub Desktop.
Download ZIP
better_afm2tfm.pl
Raw
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 [email protected] 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 [email protected] 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 [email protected] 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 [email protected] 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 [email protected] 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<[email protected]>>
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.
Raw
tex256.app
%
% tex256.app -- additions to afm2tfm(1) .enc files, for better_afm2tfm.pl
% by [email protected] 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 [email protected] 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 [email protected] 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 ;
Raw
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 [email protected] 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__
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment