path: root/support/genfam/genfam

#! /usr/local/bin/perl
# $Id: genfam,v 1.7 1991/07/16 12:50:09 tex Exp tex $
#------------------------------------------------------------
# (c) 1991 by Joachim Schrod <schrod@iti.informatik.th-darmstadt.de>.
#
#	genfam device family
#
# creates a font set for device as specified in Table/<family>.
# This file has the following line structure:
#
#	<family table> :-
#		preambel with arbitrary text
#		<header>
#		<font sets>
#
#	<header> :-
#		'::HEADER::' new_line+
#		<directory>
#		[ <command> ]
#		[ { <environment variables> } ]
#	<directory> :- 'DIR' not_white_space+ new_line+
#	<command> :- 'COMMAND' rest_of_line new_line+
#	<environment variables> :- env_var_name not_white_space+ new_line+
#
#	<font sets> :-
#		'::FONTS::' new_line+
#		{ <font set> }
#	<font set> :- <magnification> file_pattern {new line}+
#	<magnification> :- <mag step> | real_number
#	<mag step> :- 's'real_number
#
# Comments start with `%' and end with the last character on the line.
# Unlike in TeX the new_line does NOT belong to the comment.
# 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 1, 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., 675 Mass Ave, Cambridge, MA 02139, USA.
#
# $Log: genfam,v $
# Revision 1.7  1991/07/16  12:50:09  tex
# New TFM really stored in tfm/, if different from old one.
# Output (stdout and stderr) to nohup.out is unbuffered.
#
# Revision 1.6  1991/04/12  15:25:01  tex
# Don't look up TFM file in directory "." (it would be found anyhow).
# Create tfm directory for new TFM files in base directory.
# Search this tfm directory first so that warnings for different
# TFM files will only be given once in a run.
#
# Revision 1.5  1991/04/08  13:22:36  tex
# included copyright notice for distribution.
#
# Revision 1.4  1991/02/08  20:32:29  tex
# New TFM file that cannot be found is saved in subdirectory tfm.
#
# Revision 1.3  1991/02/08  20:10:06  tex
# Directory with font sources is always included in MFINPUTS path.
# On differences in dpi values our own value is used for the directory
#    name.
# The TFM file is search in the TEXFONTS path and is compared to if
#    a file is found. If the new TFM differs it is not deleted.
#
# Revision 1.2  1991/02/08  12:41:14  tex
# perl is now in /usr/local/bin instead of /software/bin.
# Include dpi in separator of LOG files to distinguish different fonts.
# $#errors is -1 when no errors were found.
# $real_dpi must be computed with round() instead of trunc().
# Check differences between MF dpi values and own computed values.
#
# Revision 1.1  91/02/01  19:33:42  schrod
# Initial revision
# 
# name:	table_line
# pre:	TABLE is open
# ret:	next non-empty line of TABLE, comments are deleted
#       leading and trailing white space is discarded
#	empty line if eof

sub table_line
{
    if ( eof(TABLE) ) {
        return "";
    }
    while ( <TABLE> ) {
        chop;			    # throw away new_line
        s/%.*$//o;                  # discard comments
	s/^\s*(.*)\s*$/$1/o;        # discard leading and trailing white space
	if ( $_ eq "" ) {           # skip blank lines
	    next;
        }
	return $_;                  # We've found a non-empty line!
    }
    return "";                      # end of file reached.
}


# name:	info()
# pre:	TABLE is open and at beginning
# ret:	(dir, command)
#		dir is family directory
#		command is MF command for create_font()
# post:	set env vars if necessary
#	::FONTS:: is already read
# err:	exits if family directory is not given or does not exist

sub info
{
    local ($line);          # next non-empty line
    local ($key, $value);   # (key, value) pair from table header

    while ( ($line=&table_line()) ne "::HEADER::"  &&  $line ne "" ) {}
    if ( $line eq "" ) {
        print "! There is no header in $table.";
	exit 2;
    }

    $line = &table_line();
    ($key, $value) = split(/\s+/o, $line);
    if ( $key eq "DIR" ) {
        $dir = $value;
	if ( ! -d $dir ) {
	    print "! Directory $dir does not exist.";
	    exit 2;
	}
	if ( $ENV{"MFINPUTS"} ne "" ) {
	    $ENV{"MFINPUTS"} .= ":$dir";
	} else {
	    $ENV{"MFINPUTS"} .= "$dir";
	}
    } else {
        print "! Source directory must be specified in $table.";
	exit 2;
    }

    $line = &table_line();
    ($key, $value) = split(/\s+/o, $line, 2);
    if ( $key eq "COMMAND" ) {
        $command = $value;
	$line = &table_line();
    } else {
        $command = "mf";
    }

    while ( $line ne "::FONTS::"  &&  $line ne "" ) {
	($key, $value) = split(/\s+/o, $line);
	if ( $key eq "MFINPUTS" ) {
	    $value .= ":$dir";
        }
	$ENV{$key} = $value;
	$line = &table_line();
    }
}


# name: resolution(MF_command, mode_def)
# pre:	MF is callable with MF_command
#	mode_def exists with the used base
# ret:	resolution in dpi

sub resolution
{
    local ($command, $mode_def) = @_;
    local (@log, $out_markup, $dpi);

    # First build a MF call:
    #   MF shall not ask the (non-existent) user if an error has occured,
    #   it shall switch to the mode definition,
    #   and shall output the respective resolution.
    #   stdin is /dev/null
    #       -- this will cause an emergency stop if all else fails.
    $command .= " '\\scrollmode;".
                "mode=$mode_def;$mode_def"."_;".
		"show pixels_per_inch;end;' ".
		"</dev/null";

    # Then we execute this call and catch the output in @log.
    # If the command failed we did not have any output.
    @log = `$command`;
    if ( $#log == -1 ) {
        print "! I've had problems in calling METAFONT.";
	exit 2;
    }

    # We look for a line with a show output (starting with `>>')
    # in the MF output. The respective
    # line is stored in $out_markup. If no such line is found, $out_markup
    # is "! Error message", simulating a MF error in this way.
    $out_markup = "! Error message";
    foreach ( @log ) {
        $line_no += 1;
        if ( /^>>/o ) {
	    $out_markup = $_;
	    last;
        }
    }

    # We split the found line. Then $out_mark is hopefully ">>", otherwise
    # it's an error.
    ($out_markup, $dpi) = split(/\s+/, $out_markup);
    if ( $out_markup eq "!"  ||  grep(/^!/, @log) > 0 ) {
        print "! There was an error while calling METAFONT.";
	print "  Perhaps the device is no valid mode definition?";
	print "  Let's have a look at the MF output:";
	print "-" x 70;
	print @log;
	unlink "mfput.log";
	exit 2;
    }

    # Of course the output should be a real number.
    if ( $dpi !~ /\d+(\.\d*)?/o ) {
        print "! METAFONT did not tell me a resolution for this device.";
	print "  I'm stymied. Perhaps you should take a look at the MF output:";
	print "-" x 70;
	print @log;
	unlink "mfput.log";
	exit 2;
    }

    # MF produced mfput.log and mfput.tfm, we will delete them before returning.
    unlink <mfput.*>;
    return($dpi);
}


# name:	create_dir(dir)
# pre:	---
# post:	directory dir exists

sub create_dir
{
    local ($dir) = @_;
    if ( -e $dir ) {
	if ( -d _ ) {
	    return;
	}
	print "! File $dir exists but is no directory.";
	do finish();
    }
    mkdir($dir, 0777)  ||  die "$0: mkdir $dir: $!.\n";
}


# name:	base_dir(mode_def)
# pre:	---
# ret:	full path name of base directory (i.e. new current directory)
# post:	base directory for mode_def is created if necessary
#	is now current directory

sub base_dir
{
    local ($mode_def) = @_;
    do create_dir($mode_def);
    chdir($mode_def);
    chop( $mode_def=`pwd` );
    return $mode_def;
}


# name:	lookup(file, path)
# pre:	$file is a name of a regular file
#	@path is an array with directory names
# ret:	full path name of $file if found in one directory
#	"" if not found

sub lookup
{
    local ($file, @path) = @_;
    local ($dir);

    foreach $dir ( @path ) {
        next if $dir eq "";
        if ( -f "$dir/$file" ) {
	    return "$dir/$file";
	}
    }
    return "";
}


# name:	create_font(mag, file)
# pre:	mag holds the mag string for MF call
#	file is a MF program and is found by $MFINPUTS
#	$command holds the MF call
#	$device holds the mode definition
#	$real_dpi is the dpi value we have computed
#	LOGerror is open for writing
#	LOGwarning is open for writing
# post:	PK file is created in subdir dpi<dpi>/.
#	LOG file is analyzed,
#		errors are appended to LOGerror,
#		warnings are appended to LOGwarning,
#		whole LOG is appended to LOGall.
#	no GF file exists.
#	@font_count[0..1] is incremented;

sub create_font
{
    local ($mag, $file) = @_;
    local (@log, @errors, $error, $dpi);
    local ($font) = split(/\./, $file);
    local ($font_msg) = $font." at ".$real_dpi." dpi";
    local ($separator)= "=" x 20." ".$font_msg." "."=" x (58-length($font_msg));

    $font_count[0] += 1;    # we try the next font
    @log = `$command '\\scrollmode; mode=$device; mag=$mag; input $file`;

    {
	@errors = grep(/^!/, @log);
	if ( ($error=$#errors) == -1 ) {
	    last;
	}

	@errors = grep(!/^! Strange path/, @errors);
	if ( $#errors != $error ) {
	    print LOGwarning $separator;
	    print LOGwarning $error-$#errors, " strange paths have occured.";
        }
        if ( $#errors == -1 ) {
	    last;
        }

        print LOGerror $separator;
	$error = 0;
        foreach ( @log ) {
	    if ( $error ) {
	        chop;  print LOGerror $_;
		if ( $error == 2 ) {
		    $error = 0;
		} elsif ( /^l.\d+/o ) {
		    $error = 2;
		}
	    } elsif ( /^!/o  &&  ! /^! Strange/o ) {
	        chop;  print LOGerror $_;
		$error = 1;
            }
	}
    }

    system "echo '$separator' >>LOGall";
    system "cat $font.log >>LOGall";

    $dpi = $log[$#log - 1];
    if ( $dpi !~ /^Output/o ) {
        print LOGerror "!" x 20, " No output!";
	return;
    }

    ($dpi) = ( $dpi =~ /$font\.(\d+)gf/ );
    if ( $dpi != $real_dpi ) {
    	print "! Dpi-differences between MF ($dpi dpi) and me ($real_dpi dpi).";
    }
    system "gftopk", "$font.${dpi}gf", "dpi$real_dpi/$font"
        ||  print LOGerror "!" x 20," Problems with gftopk on $font.${dpi}gf";

    $old_tfm = &lookup("$font.tfm", @tfm_path);
    if ( $old_tfm eq "" ) {
        print "! New TFM file: tfm/$font.tfm";
        rename("$font.tfm", "tfm/$font.tfm");
    } elsif ( system("cmp", "-s", "$font.tfm", $old_tfm) ) {
	print "! Different TFMs for type $font, new one stored in tfm/.";
        rename("$font.tfm", "tfm/$font.tfm");
    }

    unlink( grep(!/\.mf/, <$font.*>) );

    $font_count[1] += 1;    # well, we succeeded
}


# name:	create_mag(mag, pattern)
# pre:	mag is the magnification of the font set
#	$dpi is the base resolution of the device
#	$cwd is the current directory, i.e., the base directory
#	$dir is the directory where the MF programs reside
#	pattern are files in $dir which shall be created in mag
#	create_font(file) with file from {pattern} is callable
# post:	for all files create_font() is called

sub create_mag
{
    local ($mag, $pattern) = @_;
    local (@files, $file, $MF_mag, $real_dpi);

    chdir $dir;  @files = <${pattern}>;  chdir $cwd;
    if ( $#files == -1 ) {
        return;
    }

    $MF_mag = $mag;
    if ( $MF_mag =~ s/^s(\d+(\.\d*)?)/$1/o ) {
        $real_dpi = 1.2 ** $MF_mag;
	$MF_mag = "magstep(".$MF_mag.")";
    } else {
        $real_dpi = $MF_mag;
    }
    if ( $real_dpi == 0 ) {
        print "! Hmm, the magnification $mag is not valid.";
	return;
    }

    $real_dpi = int( $real_dpi * $dpi  + 0.5 );     # round does not exist...
    do create_dir("dpi".$real_dpi);

    foreach $file ( @files ) {
        do create_font($MF_mag, $file);
    }
}


# name:	finish()
# pre:	$init_phase is set
# post: no return

sub finish
{
    local ($log_msg);


    if ( $init_phase ) {
        exit 2;
    }


    # We are finished and tell now how long we have run.

    $log_msg = "=" x 79;
    print LOGerror $log_msg;
    print LOGwarning $log_msg;
    print LOGall $log_msg;

    ($user, $system, $cuser, $csystem) = times;
    $total = sprintf("%.2f", $user + $system + $cuser + $csystem);
    $user = sprintf("%.2f", $user);
    $system = sprintf("%.2f", $system);
    $cuser = sprintf("%.2f", $cuser);
    $csystem = sprintf("%.2f", $csystem);
    chop( $time = &ctime(time) );

    $log_msg = <<EOT

Well, now it's $time.

I've started MF $font_count[0] times and created $font_count[1] fonts.
All in all, we have needed (u:$user, s:$system) seconds to control the run,
MF and associated programs needed (u:$cuser, s:$csystem) seconds,
in total that makes $total seconds.
        Howdy!
EOT
    ;
    print LOGerror $log_msg;
    print LOGwarning $log_msg;
    print LOGall $log_msg;


    # Send the starter a mail that we are finished
    open(STDOUT, "| /bin/mail $name");
    print <<EOT
Hello,

You have started a $0 script for the creation of the $family fonts
for device $device. This script is finished.

It's error messages are in $cwd/nohup.out.
You should take a look at LOG* in the same directory (especially at LOGerror).

		Virtually, your MF management
EOT
    ;
    close(STDOUT);

    exit 0;
}


# extract basename from $0
# supply new_line at end of line
# and load needed library functions

    $0 =~ s:^.*/([^/]+):$1:o;
    $\ = "\n";
    require "ctime.pl";


# show that we have not done real work up to now

    $init_phase = 1;


# who is the person which wants to make new fonts?

    if ( ! defined $ENV{"LOGNAME"} ) {
        if ( defined $ENV{"USER"} ) {
	    $ENV{"LOGNAME"} = $ENV{"USER"};
	} else {
	    print "Oops, you do not have a logname!";
	    local ($\) = "";    # just for the following print
	    while {
	        print "Who are you? ";
	        ($name=<STDIN>) eq "";
	    } {}
	    $ENV{"LOGNAME"} = $name;
        }
    }
    $name = $ENV{"LOGNAME"};



# check arguments

    if ( $#ARGV != 1 ) {
        print "usage: ",$0," device family";
        exit 1;
    }

# give them names

    ($device, $family) = @ARGV;

# open table file

    $table = "Table/".$family;
    if ( ! -f $table  ||  ! -r _ ) {
        print "! Cannot read $table.";
	exit 2;
    }
    open(TABLE,"<".$table);

# read table header, compute base resolution and generate base directory

    do info();
    $dpi = &resolution($command, $device);
    $cwd = &base_dir($device);

# Now we are in the base directory.


# Set up a search path for TFM files. Use the environment variable
# $TEXFONTS, and as a default /usr/tex/fonts/tfm and tfm. This search
# path is used to detect if created TFM files exist already, and if
# they match the existing ones.
#   We supply a subdirectory tfm; there must be a place where new TFM
# files may be stored.
#   But: The directory `.' must not be part of the search path. In this
# directory a matching TFM file will always be found: the created one...

    do create_dir("tfm");
    @tfm_path = split(/:/, $ENV{"TEXFONTS"});
    @tfm_path = grep( ! /^\.$/, @tfm_path); # delete entry "."
    unshift(@tfm_path, "tfm");    # new versions should be found first
    push(@tfm_path, "/usr/tex/fonts/tfm");




# All initializations are done, MF ran already, and we may now assume that
# the rest is computer's work. So we fork of a process, disconnect it from
# our main process and start the whole stuff ::::

    print <<EOT

OK, I fork myself and get METAFONT running. This will need a while.
You will find my error messages in $device/nohup.out.
EOT
    ;

    if ( fork != 0 ) {  # parent:
        sleep 2;        # wait for child process to establish SIG handler
	exit 0;
    }

    $init_phase = 0;    # start real work

    $SIG{'HUP'} = "IGNORE";     # child: disconnect from parent
    open(STDIN, "</dev/null");
    open(STDOUT, ">nohup.out");  open(STDERR, ">&STDOUT");
    $| = 1;			# print unbuffered



#   Create files LOGerror and LOGwarning because they will be written
# by this script.
#   But delete LOGall as this will be written by cat. This deletion is not
# done by unlink because this file may be linked to somewhere else due to
# space reasons. So we use an open and a close. But before we write a
# header to the LOG files so that the reader will know what we have done.

    $log_msg = "Started creation of family $family on ".&ctime(time).
                "Skript activated by $name\n";  # two NL's !!

    open(LOGerror, ">LOGerror");
    open(LOGwarning, ">LOGwarning");
    open(LOGall, ">LOGall");
    print LOGerror $log_msg;
    print LOGwarning $log_msg;
    print LOGall $log_msg;
    close(LOGall);


# Read each font set from TABLE, split it, setup mag specification
# string for MF, and call create_mag().

    @font_count = (0, 0);
    while ( ($_ = &table_line()) ne "" ) {
        ($mag, $pattern) = split;
	do create_mag($mag, $pattern);
    }


# cleanup

    do finish();