diff options
Diffstat (limited to 'Build/source/texk/windvi/t1mapper')
-rw-r--r-- | Build/source/texk/windvi/t1mapper | 424 |
1 files changed, 0 insertions, 424 deletions
diff --git a/Build/source/texk/windvi/t1mapper b/Build/source/texk/windvi/t1mapper deleted file mode 100644 index bf2aea5f4d9..00000000000 --- a/Build/source/texk/windvi/t1mapper +++ /dev/null @@ -1,424 +0,0 @@ -#!/usr/bin/env perl -# -# This program maps full PS font names to abreviated TeX style names -# and puts font files or links to font files in a file hierarchy -# suitable for texk. -# -# Mapping example: Times-Roman.{gsf,pfa,pfb} becomes ptmr.{pfa,pfb} -# - -use File::Path; - -# These are the fontname map files to read - -# This is for the fontname distribution in teTeX 0.4: -# @fonts=qw(adobe apple bitstrea dtc linotype monotype skey1250 skey1555 -# softkey urw); - -# This is for fontname 2.2, get it from ftp.tug.org:/tex/fontname-2.2 -# The linotype map in teTeX 1.0 is terebly corrupted. Removed from the list. - -@fonts=qw(adobe apple bitstrea dtc monotype softkey-1250 - softkey-1555 urw wolfram yandy); - -$logname="t1map.log"; - -# How much to read from font files to figure out the font name -$fontdatalen=1024*10; - -# HERE BE DRAGONS - -usage() if $#ARGV==0; - -# By default copy files -$method=1; - -while ($_=shift(@ARGV)) { - /^-cp$/ && do { $method=1; next; }; - /^-ln$/ && do { $method=2; next; }; - /^-lns$/ && do { $method=3; next; }; - /^-lnlns$/ && do { $method=4; next; }; - /^-lncp$/ && do { $method=5; next; }; - /^-gs$/ && do { - $gsmap = shift(@ARGV) or usage(); - $gsdir = shift(@ARGV) or usage(); - next; - }; - unshift(@ARGV,$_); - last; -} - -$texdir = shift(@ARGV) or usage(); - -if (! -d $texdir) { - print "Making directory $texdir\n"; - mkpath($texdir) or die "Could not make directory: $texdir: $!\n"; -} - -if (!open(LOG,">$logname")) { - $logname="/tmp/$logname"; - open(LOG,">$logname") || - die "Could not open file t1map.err for writing: $!\n"; -} - -# What major mode of operation? - -# Establish fonts based on ghostscript map? -if ($gsmap) { - process_gsfonts(); - print "Log in $logname\n"; - exit 0; -} - -# Ok, loop examine fonts to figure out the font name and copy/link to $texdir - -process_fontname_maps(); -process_fonts(); -print "Log in $logname\n"; - -exit 0; - -# ############################### MOVE_FONT ################################ - -sub move_font { - # Move font to destination directory, according to specified $method - my($from)=shift; - my($to)=shift; - my($relok)=shift; - - my($other); # Same font, other format - my($type); # Other type - - die "I need absolute paths please\n" - if !$relok && substr($from,0,1) ne '/'; - - logmsg("$from -> $to\n"); - - # Remove the old font to replace with this - unlink($to) if -f $to; - - # Also remove the old font in the other format: - $other=$to; - $type='.pfb' if substr($to,-4) eq '.pfa'; - $type='.pfa' if !$type && substr($to,-4) eq '.pfb'; - substr($other,-4)=$type; - - unlink($other) if -f $other; - - if ($method==1) { - # cp - system "cp $from $to 2>/dev/null" and # Shell exit value - warn "Copying $from to $to failed\n"; - } elsif ($method==2) { - # ln - link($from,$to) or - warn "Linking of $to to $from failed: $!\n"; - } elsif ($method==3) { - # lns - symlink($from,$to) or - warn "Symlinking $to to $from failed: $!\n"; - } elsif ($method==4) { - # lnlns - link($from,$to) || - symlink($from,$to) || - warn "Both linking and symlinking $to to $from failed: $!\n"; - } elsif ($method==5) { - # lncp. Let cp give the error-message - link($from,$to) || system "cp $from $to"; - } else { - die "Internal error: Unknown font copy/link method\n"; - } -} - -# ############################# PROCESS_FONTS ############################## - -sub process_fonts { - # Loop over ARGV, examine each (font?) file to see if it is a - # type1 font, binary or text format, and figure out it's name - my($type,$font); - - foreach $filename (@ARGV) { - ($type,$font)=examine_font($filename); - - next if !defined($font); - - if (!exists($file{$font})) { - logmsg("TeX name of $font ($filename) unknown\n"); - next; - } - - $file=$file{$font}; - move_font($filename,"$texdir/$file$type",0); - } -} - -# ############################## EXAMINE_FONT ############################## - -sub examine_font { - # Examine font to determine name and type - # - # The method for finding the font name is based on an awk script - # written years ago by Kjetil T. Homme and me (mostly him). - # - my($filename)=shift; - my($type); - - my($size)=-s $filename; - - if ($size==0) { - logmsg("Zero size file skipped: $filename\n"); - return (undef,undef); - } - - if (!open(FONT,"< $filename")) { - logmsg("Unable to open $filename for reading: $!\n"); - return (undef,undef); - } - - sysread FONT, $fontdata, $fontdatalen, 0; - - # Determine type based on magic number - $type='.pfa' if substr($fontdata,0,16) eq '%!PS-AdobeFont-1'; - $type='.pfa' if !$type && substr($fontdata,0,13) eq '%!FontType1-1'; - $type='.pfb' if !$type && substr($fontdata,6,16) eq '%!PS-AdobeFont-1'; - - if (!$type) { - # This is where we end up if the file does not match the magic - # numbers. The file is most probably not a type1 file. - - if ((index($fontdata,'%!PS-AdobeFont-1')==-1) && - (index($fontdata,'%!FontType1-1')==-1)) { - # If the string '%!PS-AdobeFont-1.0' or '%!FontType1-1.0' - # does not appear at all this is NOT a type1 font of any - # kind. - logmsg("$filename is not a type1 file\n"); - return (undef,undef); - } - - logmsg("Odd magic in $filename\n"); - - # Try to determine type based on filename extention - $type='.pfa' if substr($filename,-4) eq '.pfa'; - $type='.pfb' if !$type && substr($filename,-4) eq '.pfb'; - - if (!$type) { - # No extention? Fall back to perls -T (text) test operator. - $type='.pfb'; - $type='.pfa' if -T $filename; - } - } - - # The font type has now been determined. I wonder what the font's - # name is. - - # What we look for is lines like this: - # - # %!PS-AdobeFont-1.0: URWGothicL-Demi 001.005 - # - # or this: - # - # /FontName /URWGothicL-Demi def - - $fontname=''; - - if ($fontdata =~ m~/FontName /([\S]+) def~) { - # The /FontName line is the most reliable source - $fontname = $1; - } elsif ($fontdata =~ m/%\!PS-AdobeFont-1.0: ([\S]+)/) { - # The magic line is not always fully formed and can only be - # used as fallback --- in case the /FontName entry is not in - # the file. True, this would be a rather dubious font. - $fontname = $1; - } elsif ($fontdata =~ m/%\!FontType1-1.0: ([\S]+)/) { - # The magic line is not always fully (or correctly) formed and - # can only be used as fallback --- in case the /FontName entry - # is not in the file. True, this would be a rather dubious - # font (actually, a lot of type1 versions of tex fonts fall - # into this category). - $fontname = $1; - } - - return ($type,$fontname); -} - -# ######################### PROCESS_FONTNAME_MAPS ########################## - -sub process_fontname_maps { - # Read the fontname maps - - while ($foundry=shift(@fonts)) { - $map=findfile($foundry.".map"); - next unless $map; - print "Reading (fontname/$foundry) $map\n"; - open(FILE,"<$map") || die "Could not open $map: $!\n"; - while (<FILE>) { - chomp; - s/@.*//; - next if $_ eq ''; - ($file,$font,undef)=split(/\s+/,$_,3); - # Remove known encoding codes: - $file =~ s/(8a|8r|8t)$//; - # 8a = StandardEncoding 8a.enc - # 8r = TeXBase1Encoding 8r.enc - # 8t = CorkEncoding cork.enc - # Any filenames with numbers left are 'unknown encodings' - if ($file =~ /\d/) { - # print "Unknown encoding: $file - $font\n"; - next; - } - $file{$font}=$file; - } - close(FILE); - } -} - -# ########################### PROCESS_GSFONTS ############################# - -sub read_gsmap { - # Read gs map file to obtain Font-Name -> filename mappings, and - # aliases so we can use GS' Times-Roman replacement as Times-Roman - # ourselves. Not everyone has oodles of type1 fonts on disk. - - my($gsmap)=shift; - - open(FILE,"<$gsmap") or die "Could not open $gsmap: $!\n"; - - print "Reading (gsmap) $gsmap\n"; - - %gsalias=(); - %gsfile=(); - - while (<FILE>) { - chomp; - s/%.*//; - s/\s+$//; - next if $_ eq ''; - - ($font,$file,undef)=split(/\s+/,$_,3); - - $font =~ s~^/~~; - - if (!exists($file{$font})) { - logmsg("TeX name of $font unknown\n"); - next; - } - - if ($file =~ m~\((.*)\)~) { - $file = $1; - $gsfile{$font}=$file; - } else { - $file =~ s~^/~~; - # The aliases(sp?) cannot be resolved until the whole file is - # read - $gsalias{$font}=$file; - } - - } - - close(FILE); -} - - -sub process_gsfonts { - # Do the Work based on a ghostscript map file. - - process_fontname_maps(); - read_gsmap($gsmap); - - chdir($gsdir) or die "Could not chdir to $gsdir: $!\n"; - - print "Moving fonts\n"; - - foreach $font (keys %gsfile) { - $gsfile=$gsfile{$font}; - # GSF files are not propper t1 fonts I understand, so ignore them - next if $gsfile =~ /\.gsf$/; - $file=$file{$font}; - $type=''; - - if (-f $gsfile) { - - # Crude font type guessing. First based on existing extention: - $type='pfa' if substr($gsfile,-4) eq '.pfa'; - $type='pfb' if !$type && substr($gsfile,-4) eq '.pfb'; - - # If existing extention fails use perls -T (text) test - if (!$type) { - # print "Fallback typing: $gsfile\n"; - $type='pfb'; - $type='pfa' if -T $gsfile; - } - - # Use for alias resolving - $texname{$font}="$file.$type"; - - if (substr($gsfile,0,1) eq '/') { - move_font("$gsfile","$texdir/".$texname{$font},0); - } else { - move_font("$gsdir/$gsfile","$texdir/".$texname{$font},0); - } - - } else { - logmsg("$file not found\n"); - } - } - - chdir($texdir) or die "Could not chdir to $texdir\n"; - - foreach $font (keys %gsalias) { - $alias = $gsalias{$font}; - $falias = $texname{$alias}; - - $type='pfa' if substr($gsfile,-4) eq '.pfa'; - $type='pfb' if !$type && substr($gsfile,-4) eq '.pfb'; - - $file=$file{$font}; - - # Symlink the aliases - logmsg("$falias -> $file.$type\n"); - $method=3; - move_font($falias,"$file.$type",1); - } -} - - -# ############################ JUNK PROCEDURES ########################### - -sub findfile { - # Find file, use kpsewhich to access texmf database and search rules - - my($file)=shift; - $fileloc=`kpsewhich $file`; - - # Check errors - return undef if ($? != 0); - chomp($fileloc); - return undef if $fileloc eq ''; - - # It worked - return $fileloc; -} - -sub usage { - # Abuse the user - print -"Usage: t1mapper [-cp|-ln|-lns|-lnlns|-lncp] \\ - -gs /path/to/gs/Fontmap /path/to/gs/fonts \\ - /path/to/target/tex/directory - - t1mapper [-cp|-ln|-lns|-lnlns|-lncp] \\ - /path/to/target/tex/directory \\ - <font-file-list> - -See XDVIFONTS for documentation - -"; - exit 1; -} - -sub logmsg { - my($string)=shift; - - print STDERR "$string"; - print LOG "$string"; -} |