#!@@PERL@@

# mkpkfontdir: a simple tool for manipulation of TeX pk fonts directories.
#
# This utility can create various kind of pk fonts directories
# structures: fully TDS-conformant, organized by supplier and type or
# just by supplier, or not organized at all, as one wants...
#   The only assumption made by this program is that every pk file has
# a corresponding tfm file somewhere, and that the tfm files are correctly
# installed (i.e. if they are Not installed in a TDS-conformant structure,
# you will not be able to obtain a TDS-conformant pk tree).
#
# To get usage, just 'mkpkfontdir --help'.
#
# Copyright (C) 1995, Yves Arrouye <Yves.Arrouye@imag.fr>
#
# (By the way, I don't write Perl usually, so please don't flame me
# for bad use of it.)

# Customize what follows if needed (or do it in the Makefile, it's better)

# Known MetaFont modes that are not in modes.mf

$knownmodes{'gsftopk'} = 'gsftopk';
$knownmodes{'ps2pk'} = 'ps2pk';

$TEXMF = $ENV{"TEXMF"};
$TEXMF || ($TEXMF = '@@TEXMF@@');

$VARTEXMF = $ENV{"VARTEXMF"};
$VARTEXMF || ($VARTEXMF = $TEXMF);

$dft_fontdir = "@@FONTDIR@@";
$dft_destdir = "@@DESTDIR@@";

$dpi_regexp = "s/^/dpi/";	# How to generate the dpi directory name.

$loc_tfmdir = "@@LOC_TFMDIR@@";		# Location of tfm files under $opt_fontdir
$loc_tfmdirname = &basename($loc_tfmdir);

$loc_pkdir = "@@LOC_PKDIR@@";		# Location of pk directory under
				# $opt_fontdir. We assume that this
				# directory will contain only
				# directories corresponding to modes.

$loc_unknowndir = "@@LOC_UNKNOWNDIR@@";
$loc_unknownmode = "@@LOC_UNKNOWNMODE@@";

$loc_modesmf = "@@LOC_MODESMF@@"; # Where is modes.mf

$use_kpsewhich = "@@USE_KPSEWHICH@@";

$tds_default = @@TDS_DEFAULT@@;
$tds_always = @@USE_TDSNAMES@@;

$test_longnames = @@TEST_LONGNAMES@@;

# Do not touch what is here!

# normalname(filename)
#
#   Return the name of a file without double slashs

sub normalname {
    local($file) = @_;

    $file =~ s,/+,/,g;

    return $file;
}

# basename(filename)
# basename(filename, extregexp)
#
#   Return the base name of a file.

sub basename {
    local($fullname, $ext) = @_;
    local($basename) = $fullname;

    $basename =~ s,(.*/)?([^/]+),$2,;
    $ext && $basename =~ s,$ext$,,;

    $basename;
}

# dirname(filename)
#
#   Return the directory part of a file, with no trailing slash.
#

sub dirname {
    local($fullname) = @_;

    if (!($fullname =~ s,/[^/]+/*$,,)) {
	$fullname = '.' unless $fullname eq '/';
    }

    return $fullname;
}

# mkdirs(path, mode)
#
#   Makes all directories necessary to create path. Returns '' if
#   successful, the partial path otherwise (the last directory being
#   the one that produced the error).
#
# mkdirs2(path, mode)
#
#   Makes all directories necessary to create path. Returns a list of
#   directories created.

sub mkdirs {
    local($path, $mode) = @_;
    local($builded) = ($path =~ s/^\/// ? '' : '.');

    foreach $dir (split('/', $path)) {
	# There's a problem with mkdir returning 0 when there is no error on
	# Linux, so we'll create and test.
	
	mkdir("$builded/$dir", $mode);
	if (! -d "$builded/$dir") {
	    return "$builded/$dir";
	}
	$builded .= "/$dir";
    }

    return '';
}

sub mkdirs2 {
    local($path, $mode) = @_;
    local($builded) = ($path =~ s/^\/// ? '' : '.');

    local(@allpaths);

    foreach $dir (split('/', $path)) {
	# There's a problem with mkdir returning 0 when there is no error on
	# Linux, so we'll create and test.
	
	$builded .= "/$dir";

	if (! -d "$builded") {
	    mkdir("$builded", $mode);
	    if (! -d "$builded") {
		last;
	    }
	    $allpaths[$#allpaths + 1] = $builded;	
	}
    }

    return @allpaths;
}

# rmdirs(path)
#
#  Recursively delete empty directories.

sub rmdirs {
    local($path) = @_;

    while (rmdir($path)) {
	$path = &dirname($path);
    }
}

# mfmode(mode, modesmf)
#
#   Return mode iff mode is present in modesmf, '' otherwise.

sub mfmode {
    local($mode, $modesmf) = @_;

    if (! -r $modesmf) {
	return '';
    }

    if (open(MODESMF, "<$modesmf")) {
	while (<MODESMF>) {
	    if (/^$mode\s+:=/ || /^mode_def\s+$mode\s/) {
	        return $mode;
	    }
	}
    }

    return '';
}

# tfmpath(fontname)
#
#   Return the full path of the .tfm file for a given file (assuming it is a
#   font file, of course).
#     Quick hack: if $use_kpathsea is null, use a find, but the $tfmdir var
#   must be set!

sub tfmpath {
    local($name) = @_;
    local($cmd, $path);

    $name = &basename($name, '\.[^.]*');

    if ($use_kpsewhich) {
	$cmd = "kpsewhich $name.tfm";
    } else {
	if ($tfmdir eq '') {
	    $tfmdir = "$opt_fontdir/$loc_tfmdir";
	}

	# We could use locate first here, but on some systems it's find and
	# the syntax varies, so I don't want to: please use kpsewhich!

	$cmd = "2>/dev/null find $tfmdir -name $name.tfm -print";
    }

    $path=`$cmd`;
    chop($path);

    if ($path eq '') {
	$path = $loc_unknowndir;
    }

    return $path;
}

# fontdirpath(filename)
#
#   Return the path where a font should be installed. For example, on
#   my system the cmr10.tfm file is (logically) installed in public/cm
#   under $TEXMF/fonts/tfm, thus its fontpath is public/cm.

sub fontdirpath {
    local($name) = @_;
    local($path) = &tfmpath($name);

    $path =~ s,^(.*/)?$loc_tfmdirname/,,;
    $path =~ s,/[^/]*$,,;

    $path;
}

# pkfontnameparts(fontname)
#
#   Return the components (base name and dpi) of a fontname:
#
#     /some/path/font.300pk	-> (font, 300)
#     /some/path/dpi329/font.pk	-> (font, 329)

sub pkfontnameparts {
    local($fontname) = @_;
    local($basename);
    local($dpi);

    if ($fontname =~ /dpi(\d+)\/([^\/]*)\.pk$/) {
	$basename = $2;
	$dpi = $1;
    } else {
	$basename = &basename($fontname);
	($dpi = $basename) =~ s,.*\.(\d+)pk,$1,;
	$basename =~ s,\.${dpi}pk,,;
    }

    return ($basename, $dpi);
}

# strippath(path, level)
#
#   Strip a path by removing a certain number of levels in it,
#   starting from the end:
#
#     public/cm/cmbsy10.tfm, 1	-> public/cmbsy10.tfm
#     public/cm/cmbsy10.tfm, 2	-> cmbsy10.tfm
#
# restrictpath(path, level)
#
#   Restrict path to level components.
#
# prunepath(path, level)
#
#   Calls restrictpath if level is positive, strippath otherwise (after
#   making level positive). Note that level is decremented if positive,
#   so that prunepath($path, 1) means restrict to 0 components.

sub strippath {
    local($path, $level) = @_;

    while ($level-- > 0 && $path =~ /\//) {
	$path =~ s,[^/]*/([^/]*)$,$1,;
    }

    $path;
}

sub restrictpath {
    local($path, $level) = @_;
    local($pathcopy) = $path;

    if ($pathcopy !~ m,^/,) {
        $pathcopy = "/$pathcopy";
    }
    $pathcopy =~ s,/+,/,g;
    $pathcopy =~ s,[^/],,g;

    $level = length($pathcopy) - $level - 1;

    while ($level-- > 0) {
        $path =~ s,(.*/)?[^/]+/([^/]*),$1$2,;
    }

    return $path;
}

sub prunepath {
    local($path, $level) = @_;

    if ($level > 0) {
	return &restrictpath($path, $level - 1);
    } else {
	return &strippath($path, -$level);
    }
}

# pkfontpath(fontname, tds, level)
#
#   Return where to install a font in a font tree.
#     The tds argument indicate whether we should generate a
#   TDS-conforming subdirectory level dpi$pkdpi.
#     The level argument is passed to prunepath.

sub pkfontpath {
    local($fontname, $tds, $level) = @_;
    local($fontdirpath) = &prunepath(&fontdirpath($fontname) . "/", $level);
    local($basename, $dpi) = &pkfontnameparts($fontname);
    local($fontpath);

    if ($tds) {
	$dpi =~ $dpi_regexp;
	$fontpath = "$fontdirpath" . "dpi$dpi/$basename.pk";
    } else {
	$fontpath = "$fontdirpath$basename.${dpi}pk";
    }

    return $fontpath;
}

#

sub mkpkfontdir {
    local($dir, $dftmode, $fontdir, $destdir, $replace, $link, $tds, $level,
        $pktype, $usemodesmf, $guess, $writepaths, $verbose, $simulate) = @_;

    local($pk) = &basename($loc_pkdir);

    local($nwarns) = 0;

    # Accept files too, because find is okay with that and we can use the
    # tool in MakeTeXPK.

    $tfmdir = "$fontdir/$loc_tfmdir";

    $destdir = "$destdir/$loc_pkdir";

    # Check for the kind of links we can make

    if ($link eq 'symlink') {
	if (eval 'symlink("","");', $@ ne '') {
	    $link = 'link';
	}
    }

    local($move) = $link ? ($link eq 'link' ? "+>" : "->") : "=>";

    # Now move or link each file

    $dir = &normalname($dir);

    foreach $file (`2>/dev/null find $dir -type f -print`) {
	local($mode, $mfmode);
	local($guessing) = 0;

	chop($file);

	if (!($file =~ /pk$/)) {
	    next;
	}

	if ($verbose) {
	    print "$file\n";
	}

	$mode = $dftmode;

	# Get the mode from pktype is asked to

	if ($pktype) {
	    $mfmode = `2>/dev/null pktype $file | grep "'mode=.*'"`;
	    chop($mfmode);
	    if ($mfmode =~ s/.*'mode=(.*).*'/$1/) {
		$mode = $mfmode;
	    } else {
		print STDERR &basename($0),
		    ": pktype does not know mode for $file",
		    ($guess ? ", guessing " : "");
		$guessing = 1 unless !$guess;
	    }
	}

	# If no mode is specified, try to get it from the file path.
	# Note that if the mode was affected on the command-line, there
	# is no guess.

	if ($mode eq '' && $guess) {
	    $mode = $file;
	    if (!($mode =~ s,(.*/)?$pk/([^/]+)/.*,$2,)) {
		$mode = '';
	    }
	}

	$mfmode = $mode;

	if ($mode && $usemodesmf && !$knownmodes{$mode}) {
	    $mode = &mfmode($mfmode, $loc_modesmf);
	}

	if ($guessing) {
	    print STDERR ($mode ? $mode : $loc_unknownmode), "\n";
	}

	if ($mode eq '') {
	    if ($guessing) {
		print STDERR "\n";
	    }
	    print STDERR &basename($0),
	        ": unknown mode \"$mfmode\" for $file, using $loc_unknownmode\n";
	    $mfmode = $loc_unknownmode;
	}

	local($dest) = "$destdir/$mfmode/" . &pkfontpath($file, $tds, $level);

	$dest = &normalname($dest);

	if ($dest ne $file) {
	    local($built);

	    if ($verbose) {
		print "  $move $dest\n";
	    }

	    if (-f $dest) {
		if (!$replace) {
		    print STDERR &basename($0),
		        ": will not overwrite $dest with $file\n";
		    ++$nwarns;
		    print "$file\n" if $writepaths;
		    next;
		} else {
		    unlink($dest);
		}
	    }

	    if ($dest =~ m,$destdir/$mfmode/$loc_unknowndir/,) {
		print STDERR &basename($0),
		    ": $file has unknown font path (obtained $dest)\n";
	    }

	    if ($simulate) {
		print "$dest\n" if $writepaths;
		next;
	    }

	    if ($built = &mkdirs(&dirname($dest), 0777)) {
		print STDERR &basename($0),
		    ": cannot create $built: $!\n";
		++$nwarns;
		next;
	    }

	    if ($link) {
		if (!(eval "$link(\"$file\", \"$dest\")")) {
		    print STDERR &basename($0),
		        ": cannot $link $file to $dest\n";
		    print "$file\n" if $writepaths;
		    ++$nwarns;
		    next;
		}
	    } else {
		if (system("cp $file $dest") == 0) {
		    unlink($file);
		    &rmdirs(&dirname($file));
		} else {
		    print STDERR &basename($0),
		      ": cannot copy $file to $dest\n";
		    print "$file\n" if $writepaths;
		    ++$nwarns;
		    next;
		}
	    }
		
	} elsif ($verbose) {
	    print "  == $dest\n";
	}

	print "$dest\n" if $writepaths;
    }

    return $nwarns;
}

# Now for the program

@@USE_GETOPTS@@;

# We do not use File'Basename because we supply the routines we want.

sub usage {
    local($code) = @_;
    local($me) = &basename($0);

    if ($code) {
	select STDERR;
    }

    print "usage: $me";
    print " [ --version ]";
    print " [ -h, --help ]";
    print " [ -v, --verbose ]";
    print " [ -w, --write-paths ]";
    print " [ -n, --noaction ]";
    print " [ -m, --mode modespec ]";
    print " [ -M, --use-modesmf [ f ] ]";
    print " [ -P, --use-pktype ]";
    print " [ -g, --guess-mode ]";
    print " [ -f, --fontdir fontdir ]";
    print " [ -d, --destdir destdir ]";
    print " [ -o, --overwrite ]";
    print " [ -l, --link | -s, --symbolic-link ]";
    print " [ -t, --tds-names | -L, --long-names ]";
    print " [ -p, --prune n | -P, -r, --restrict n ]";
    print " directory-or-pkfile ...\n";

    if (!$code) {		# Give description
	print <<DESCRIPTION_END;

options: --version\t\tprint version information
         -h, --help\t\tprint this help message
         -v, --verbose\t\tprint actions as they are realized
	 -w, --write-names\t\tprint full paths of files moved
         -n, --noaction\t\tdo not really act (but print if verbose)
         -m, --mode modespec\tset mode to mode (see man)
	 -M, --use-modesmf f\tforce use of modes.mf, eventually naming it
         -T, --use-pktype\tuse pktype to get the mode
	 -g, --guess-mode\tguess the mode (default except if -T)
         -f, --fontdir fontdir\tspecify where the fonts are installed; tfm
                              \tand pk files are expected to be under this
                              \tdirectory (see man)
         -d, --destdir destdir\tspecify the destination directory (defaults
                              \tto fontdir); pk files will be moved there (see
                              \tman)
	 -o, --overwrite\toverwrite existing files
         -l, --link\t\tdo not move files, but create hard links
         -s, --symbolic-link\tdo not move files, but create symbolic links
                            \tinstead (or hard ones if symbolic ones are
                            \tunavailable)
         -t, --tds-names\tname files as specified by the TDS, i.e. put
                        \tthemin directories organized by resolution
	 -L, --long-names\tuse long file names instead of TDS-like ones
         -p, --prune levels\tsuppress n directories components at the end
                           \tof the fonts paths
         -P, -r, --restrict n\trestrict the number of components in fonts
                           \tpaths to n - 1
DESCRIPTION_END
    }

    exit($code);
}

if (!&GetOptions("version", "help|h", "verbose|v", "fontdir|f=s",
    "destdir|d=s", "link|l", "symbolic-link|s", "tds-names|t", "prune|p=i",
    "restrict|r|P=i", "mode|m=s", "noaction|n", "overwrite|o",
    "use-modesmf|M:s", "use-pktype|T", "guess-mode|g", "long-names|L",
    "write-paths|w")) {
    &usage(1);
}

if (($opt_link && $opt_symlink) || ($opt_prune && $opt_restrict) ||
    ($opt_tds_names && $opt_long_names)) {
    &usage(1);
}

if ($opt_version) {
    print &basename($0),
        " version 1.1, by Yves Arrouye <Yves.Arrouye\@imag.fr>\n";
}

if ($opt_help) {
    &usage(0);
}

if ($opt_long_names) {
    if ($tds_always) {
	print STDERR &basename($0), ": only TDS names are allowed, do not use -L or --long-names\n";
	exit 2;
    }

    if ($test_longnames) {
	local($temp) = $ENV{"TMPDIR"} || $ENV{"TEMP"} || "/tmp";
	local($ok) = 0;
	local($oklong) = 0;

	local(@builded) = mkdirs2($temp, 0777);

	if ($ok = -d $temp) {
	    local($dummy) = "$temp/font.300pk";

	    if ($ok = open(DUMMY, ">$dummy")) {
		close(DUMMY);
		$oklong = -f $dummy;
		unlink($dummy);
	    }
	}

	if ($ok == 0) {
	    print STDERR &basename($0), ": unable to test for long names; please contact your sysadmin\n";
	    for ($i = $#builded; $i >= 0; --$i) {
		rmdir($builded[$i]);
	    }
	    exit(3);
	}

	for ($i = $#builded; $i >= 0; --$i) {
	    rmdir($builded[$i]);
	}

	if ($oklong == 0) {
	print STDERR &basename($0), ": only TDS names are supported, do not use -L or --long-names\n";
	}
    }
} else {
    $opt_tds_names = $tds_default;
}
    
if ($opt_link) {
    $opt_link = ($opt_symbolic ? 'symlink' : 'link');
}

if ($opt_prune) {
    $opt_restrict = -$opt_prune;
}

if (defined($opt_use_modesmf)) {
    if ($opt_use_modesmf) {
	$loc_modesmf = $opt_use_modesmf;
    }

    if (! - e $loc_modesmf) {
	print STDERR &basename($0), ": modes file $loc_modesmf does not exist\n";
	exit(5);
    }

    $opt_use_modesmf = 1;
}

# Treat the modes specification if any

local($default_mode);

if ($opt_mode) {
    foreach $modespec (split(',', $opt_mode)) {
	local($change) = 0;
	local($mode, $alias);

	if ($modespec =~ /(.*)=(.*)/) {
	    $alias = $1;
	    $mode = $2;
	} else {
	    $alias = $mode = $modespec;
	    $change = 1;
	}
	    
	if ($knownmodes{$mode} || grep("^$mode\$", values %knownmodes)
	    || !$opt_use_modesmf || &mfmode($mode, $loc_modesmf)) {
	    $knownmodes{$alias} = $mode;

	    if ($change) {
		$default_mode=$mode;
	    }
	} else {
	    print STDERR &basename($0), ": unknown mode in specification $modespec, ignored\n";
	}
    }
}

# Arrange font and destination directories

if (!$opt_fontdir) {
    $opt_fontdir = $dft_fontdir;
    if (!$opt_destdir) {
        $opt_destdir = $dft_destdir;
    }
} elsif (!$opt_destdir) {
    $opt_destdir = $opt_fontdir;
}

# Should we guess?

if (!$opt_use_pktype) {
    $opt_guess_mode = 1;
}

# Go for each directory

foreach $dir (@ARGV) {
    if (-e $dir) {
	if ($dir !~ m,^/,) {
	    $dir = `cd $dir && pwd`;
	    chop($dir);
	}	
    } else {
        print STDERR &basename($0), ": $dir: no such file or directory, ignored\n";
	next;
    }

    if (&mkpkfontdir($dir, $default_mode, $opt_fontdir, $opt_destdir,
	$opt_overwrite, $opt_link, $opt_tds_names, $opt_restrict,
	$opt_use_pktype, $opt_use_modesmf, $opt_guess_mode,
        $opt_write_paths, $opt_verbose, $opt_noaction)) {
	exit(2);
    }

    exit(0);
}
