#! /usr/bin/perl -w

# mktexpk -- make a new PK file, because one wasn't found.
# 
# This Perl version is based on the original /bin/sh version:
# 
#   te@dbs.uni-hannover.de, kb@mail.tug.org, and infovore@xs4all.nl.
#   Public domain.
#   version='Id: mktexpk,v 1.28 2002/11/11 09:45:40 olaf Exp '
# 
# Perl version:
# $Id: mktexpk,v 1.12 2003/03/05 15:22:52 jdg Exp $
# Copyright 1999, 2003 Julian Gilbey <jdg@debian.org>
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

use File::Basename;
use File::Copy;
use TeX::Mktex qw(:DEFAULT mknam_nomfdrivers $MT_FEATURES $TEMPDIR $KPSE_DOT
		  $DPI $BDPI $MODE $MAG $ps_to_pk);
use TeX::Kpsewhich;
use Cwd;

$progname=basename($0);
$version=strip_quotes(<<'EOV');
:   Perl version: $Id: mktexpk,v 1.12 2003/03/05 15:22:52 jdg Exp $
:   based on /bin/sh version _Id: mktexpk,v 1.25 1999/05/29 20:38:21 olaf Exp _
EOV
$version =~ s/_/\$/g;
$usage=strip_quotes(<<EOU);
:   Usage: $progname [OPTIONS] NAME [REDIRECT]
:     Create a PK font.
:   
:   --dpi DPI           use resolution DPI.
:   --bdpi BDPI         use base resolution BDPI.
:   --mag MAG           use magnificiation MAG.
:   --mfmode MODE       use MODE as the METAFONT mode.
:   --destdir DESTDIR   write fonts in DESTDIR.
:   
:   Try to create a PK file for NAME at resolution DPI, with an assumed
:   device base resolution of BDPI, and a Metafont `mag' of MAG. Use MODE
:   for the METAFONT mode.  Use DESTDIR for the root of where to install
:   into, either the absolute directory name to use (if it starts with a
:   /) or relative to the default DESTDIR (if not). REDIRECT, if supplied,
:   is a string of the form '>&n', where n is the number of the file
:   descriptor which is to receive, instead of stdout, the name of the
:   newly created pk file.
EOU
# `

# We now perform the necessary initialisations.
$mt_max_args=2;
mktex_opt('destdir=s', \$DEST, 'dpi=i', \$opt_dpi, 'bdpi=i', \$opt_bdpi,
	  'mfmode=s', \$opt_mode, 'mag=s', \$opt_mag);

$DPI = $opt_dpi || $DPI;
$BDPI = $opt_bdpi || $BDPI;
$opt_mode ne '/' and $MODE = $opt_mode || $MODE;
$MAG = $opt_mag || $MAG;
$MAG =~ m|^[-+/\d]+$| or die "$progname: invalid mag: $MAG";

if (defined $ARGV[1]) {
    if ($ARGV[1] =~ /^>&(\d+)$/) {
	if ($1 != 1) {
	    open STDOUT, ">&=$1"
		or die "$progname: can't use fd $1 for stdout: $!\n";
	}
    }
    else {
	warn "$progname: argument '$ARGV[1]' ignored - badly formatted.\n" .
	    "(Try $progname --help for more information.)\n";
    }
}


# Where do potential mf driver files go?
":$MT_FEATURES:" =~ /:nomfdrivers:/ && mknam_nomfdrivers();

# All output except for the font location should go to stderr
open SAVEOUT, ">&STDOUT" or die "$progname: can't dup stdout: $!\n";
open STDOUT, ">&STDERR" or die "$progname: can't dup stderr onto stdout: $!\n";

$NAME=(fileparse($ARGV[0], '\.\d*pk'))[0];

if ($kpse_plain->find("$NAME.mf") ||
    (system("mktexmf $NAME >/dev/null 2>&1") >> 8 == 0)) {
    # determine the progname of metafont to use; prefer mf-nowin.
    if (system("(mf-nowin --version) >/dev/null 2>&1") >> 8 == 0) {
	$MF="mf-nowin -progname=mf";
    } else {
	$MF="mf";
    }

    # Check that $BDPI and $MODE are consistent; if not, ignore the mode and
    # hope we can correctly guess it from bdpi.  (People like to specify the
    # resolution on the command line, not the mode so much.)
    if (length $MODE) {
	open MF, "$MF '\\mode:=$MODE; mode_setup; " .
	    "message\"BDPI=\"&decimal round pixels_per_inch; end.' </dev/null |"
	    or die "$progname: Cannot run METAFONT BDPI test: $!\n";
	while (<MF>) {
	    /BDPI=(\d+)/ and $mf_bdpi=$1, last;
	}
	close MF or die "$progname: Problem running METAFONT BDPI test: $!\n";
	if ($mf_bdpi != $BDPI) {
	    warn "$progname: Mismatched mode $MODE and resolution $BDPI; " .
		"ignoring mode.\n";
	    $MODE='';
	}
    }

    # If an explicit mode is not supplied, try to guess. You can get a
    # list of extant modes from ftp://ftp.tug.org/tex/modes.mf.
    if (! length $MODE or $MODE eq 'default') {
	%default_modes=(
			85 => 'sun',
			100 => 'nextscrn',
			180 => 'toshiba',
			300 => 'cx',
			360 => 'epstylus',
			400 => 'nexthi',
			600 => 'ljfour',
			720 => 'epscszz',
			1270 => 'linoone',
			);
	if (exists $default_modes{$BDPI}) {
	    $MODE=$default_modes{$BDPI};
	}
	else {
	    die "$progname: Can't guess mode for $BDPI dpi devices.\n" .
		"$progname: Use a config file, or update me.\n";
	}
    }

    # Run Metafont. Always use plain Metafont, since reading cmbase.mf
    # does not noticeably slow things down.
    $cmd = "$MF '\\mode:=$MODE; mag:=$MAG; nonstopmode; input $NAME'";
} else {
    $MODE = 'modeless';

    # ps_to_pk is set in mktex.opt
    if ($ps_to_pk eq 'gsftopk') {
	if (system("gsftopk -t $NAME </dev/null") >> 8 == 0) {
	    $cmd="gsftopk $NAME $DPI";
	}
    }
    elsif ($ps_to_pk eq 'ps2pk') {
	# grep for the font in $PSMAPFILE.  These are base font names, such as
	# rpplr (the original) or pplr0 (an interim step) or pplr8r (current).
	@ARGV = $kpse_plain->find({'format' => 'dvips config'},
				  'psfonts.map', 'ps2pk.map');
	$psline='';
	while (<>) {
	    /^$NAME($|[ \t])/o && $psline=$_;
	}
	if ($psline) {
	    $psline =~ tr /<"[//d;  # " <- for sake of emacs users!
	    @fields=split ' ', $psline;
	    shift @fields; shift @fields; shift @fields;
	    while ($_ = shift @fields) {
		/\.enc$/ and $encoding = "-e $_", next;
		/\.pf[ab]$/ and $psname = $_, next;
		/SlantFont$/ and $slant = "-S $lastopt", next;
		/ExtendFont$/ and $extend = "-E $lastopt", next;
	    }
	    continue {
		$lastopt = $_;
	    }
	}

	# Guessing the name of the type1 font file as fallback:
	($ANAME=$NAME) =~ s/8r$/8a/;
    OUTER: foreach $base ($NAME, $ANAME) {
	    foreach $suffix (qw(pfa pfb)) {
		$kpse_plain->find("$base.$suffix") and
		    $psname="$base.$suffix", last OUTER;
	    }
	}

	if ($psname) {
	    $cmd = "ps2pk -v -X$DPI -R$BDPI $slant $extend $encoding $psname $NAME.${DPI}pk";
	} else {
	    if (system('gsftopk', '-t', $NAME) >> 8 == 0) {
		warn "$progname: cannot find $NAME.pfa or $NAME.pfb. Trying gsftopk.\n";
		$cmd = "gsftopk $NAME $DPI";
	    }
	}
    }

    # unsupported by $ps_to_pk, try other conversions:
    if (! $cmd) {
	if (system("(ttf2pk -t -q $NAME) >/dev/null 2>&1") >> 8 == 0) {
	    $cmd = "ttf2pk -q $NAME $DPI";
	}
	elsif (system("(hbf2gf -t -q $NAME) >/dev/null 2>&1") >> 8 == 0) {
	    $cmd = "hbf2gf -q $NAME $DPI";
	}
	else {
	    die "$progname: don't know how to create bitmap font for $NAME.";
	}
    }
}

$PKDEST = (mktex_names($NAME, $DPI, $MODE, $DEST))[0];

($PKNAME, $PKDESTDIR) = fileparse($PKDEST);
$GFNAME="$NAME.${DPI}gf";

if (-r $PKDEST) {
    print "$progname: $PKDEST already exists.\n";
    print SAVEOUT "$PKDEST\n";
    mktex_upd($PKDESTDIR, $PKNAME);
    exit 0;
}

# Try to create the destdir first. Do not create fonts, if this fails.
mktex_dir($PKDESTDIR);
die "$progname: mktex_dir $PKDESTDIR failed!\n" if ! -d $PKDESTDIR;

print "$progname: Running $cmd\n";
if (system("$cmd </dev/null") >> 8 != 0) {
    die "$progname: `$cmd' failed\n" unless -f "$NAME.log";
    # Don't abort if only "Strange path" or "bad pos" errors occurr.
    open LOG, "<$NAME.log"
	or die "$progname: Can't open $NAME.log file: $!\n";
    $strange=$badpos=0;
    while (<LOG>) {
	if (/^! Strange path/) {
	    $strange++;
	}
	elsif (/^! bad pos./) {
	    $badpos++;
	}
	elsif (/^! /) {
	    -s "$NAME.log" && move("$NAME.log", $KPSE_DOT);
	    die "$progname: `$cmd' failed.  (Log in $KPSE_DOT)\n";
	}
    }
    close LOG
	or die "$progname: problem reading $NAME.log: $!\n";
    $strange || $badpos and
	warn "$progname: warning: `$cmd' caused" .
	($strange ?
	 (" $strange strange path error" . ($strange>1 ? "s" : "")) : "") .
	 ($strange && $badpos ? " and" : "") .
	 ($badpos ?
	  (" $badpos bad pos error" . ($badpos>1 ? "s" : "")) : "") .
	  ".\n";
}

if (-r $GFNAME) {
    system("gftopk ./$GFNAME $PKNAME </dev/null") >> 8 == 0
	or die "$progname: gftopk ./$GFNAME $PKNAME failed: $!\n";
}

if (! -f $PKNAME and -f "$NAME.${DPI}pk") {
    move ("$NAME.${DPI}pk", $PKNAME)
	or die "$progname: couldn't move $NAME.${DPI}pk to $PKNAME: $!\n";
}

-s $PKNAME or die "$progname: `$cmd' failed to make $PKNAME.\n";

# Install the PK file carefully, since others may be working simultaneously.
push @cleanfiles, "$PKDESTDIR/pk$$.tmp";
unless (move($PKNAME, "$PKDESTDIR/pk$$.tmp")) {
    my $err="$!";
    unlink "$PKDESTDIR/pk$$.tmp";
    die "$progname: move of pk file to destination directory failed: $err\n";
}

unless (chdir $PKDESTDIR) {
    my $err="$!";
    unlink "$PKDESTDIR/pk$$.tmp";
    die "$progname: chdir $PKDESTDIR failed: $err\n";
}

unless (chmod +(stat cwd())[2] & 0644, "pk$$.tmp") {
    my $err="$!";
    unlink "pk$$.tmp";
    die "$progname: chmod pk$$.tmp failed: $err\n";
}

if (! -r $PKNAME) {
    unless(move("pk$$.tmp", $PKNAME)) {
	my $err="$!";
	unlink "pk$$.tmp", $PKNAME;
	die "$progname: move pk$$.tmp $PKNAME failed: $err\n";
    }
    -r $PKNAME
	or die "$progname: couldn't install $PKNAME and don't know why not!\n";
}

# OK, success with the TFM.
mktex_upd($PKDESTDIR, $PKNAME);
print SAVEOUT "$PKDEST\n";
print "$progname: $PKDEST: successfully generated.\n";

exit 0;
