### ====================================================================
###  @Perl-file{
###     author          = "Alan Hoenig",
###     version         = "1.00", 
###     date            = "August 1998", 
###     filename        = "1vfinst",
###     address         = "Department of Mathematics,
###                        John Jay College,
###                        445 West 59 Street,
###                        New York, NY 10019, USA",
###     email           = "ajhjj@cunyvm.cuny.edu",
###     codetable       = "ISO/ASCII",
###     keywords        = "AFM, virtual fonts, fonts, PostScript, TeX",
###     supported       = "yes",
###     abstract        = "This is the first Perl script for the 
###                        vfinst virtual font installation utility.
###                        See accompanying file vfinst.tex for 
###                        additional details.",
###     package         = "vfinst",
###     dependencies    = "1vfinst, vfinst.par, vfinst.lib, 2vfinst, fontinst",
###  }
### ====================================================================

## Introduction and description.  
## =============================

## This script 1vfinst examines all raw font files (afm+pfb), checks that
## each afm file has a matching outline file, creates the sort keys for
## each font (the sort key also encodes the series, weight, and variant
## info of the font), and decides on the Karl Berry font name for
## subsequent renaming. It produces messages in a log file, and one or
## two important files for later processing.  The file fonts.lst contains
## information about the current font and its proposed new Berry name.
## The file typefaces.lst is produced only in TDS systems, and contains
## information linking font families, directory names,a dn supplier
## names.
## 
## The scripts 1vfinst and 2vfinst are unbundled so a user can more
## easily bail out in case things go horribly wrong during the execution
## of the first script.  Also, wizards and wise guys can edit
## (carefully!) fonts.lst if the fontnaming conventions need tweaking.
## (The 2vfinst script reads only these 2 files for font information.)

# SUBROUTINES AND STUFF ...

require("../vfinst.par"); ## system dependent statement!! Beware!
require("..${sep}vfinst.lib");
&getTDSplaces if &isTDS; # construct some TDS parameters
$vfencoding = $vfmapdir unless defined $vfencoding;
$font_place="." unless defined $font_place;
$afm_place="." unless defined $afm_place;

# `CheckInstallation' tries to verify that the installation 
# has been done more-or-less properly.

sub CheckInstallation{# checks that a file list exists 
  local($missing, @missinglist, @presentlist); $missing = $false;
  foreach $i (@_) {
    if (&isfile("..${sep}${i}") == $false) {
      $missing = $true;
      push(@missinglist, $i);
    } else {
      push(@presentlist, $i);
    }
  }
  local($misslist) = join("..",@missinglist);
  local($preslist) = join("\n  ",@presentlist);
  &dwlog("The files ");
  &dwlog("  $preslist");
  &dwlog("are properly located."); 
  die "Can't find \n  $misslist \nfiles...$!\n"
    if $missing; 
}

sub GetEnvironment{# sets up some synonyms...
  $texin = $vfinputs; ## traditional system: input directory;
  $encoding = $vfencoding; # where is file 8r.enc?                      
}

## Sub stripextension takes 2 args---the array containing the file names,
## and the stirng containing the extension.

sub stripextension{
  local(*files,$ext)=@_;
  foreach $elem (@files) {
      $elem =~ s/\.$ext$//;
  }
}

# It's important to be sure that every afm file has a corresponding
# font file, which either has no extension, or is a pfb or a pfa file.
# ('No extension' is treated like a pfa file.)  No args.
# 
# The afm file has a name like `firstname.afm'.  The corresponding font
# file can be `firstname.pfa' (an Ascii font file), `firstname.pfb' (a 
# binary file), or simply `firstname' (equivalent to a pfa file; this 
# convention applies to NeXT systems and others).

## SPECIAL DEBUG OPTION:  When debugging, it's convenient to run
## 1vfinst on large collections of afm files with no matching font
## files in sight.  Normally, this is forbidden, but if the variable
##   $debugging == $true
## then 1vfinst will not check against outline font files.

$debugging = $false;		# default status
## $debugging = $true;

## Usage: &get_afm_names("/psfonts/afm");
sub get_afm_names{
    local($afm_place)=$_[0];
    opendir(THISDIR, $afm_place);
    @allfiles=readdir(THISDIR); 
    @afmfiles = grep(/\.[Aa][Ff][Mm]$/, @allfiles);
    closedir(THISDIR);
} 

## Usage: &get_font_names("/psfonts");
sub get_font_names{
    local($font_place) = $_[0];
    opendir(THISDIR, $font_place);
    @allfiles=readdir(THISDIR);
    @pfafiles = grep(/\.[Pp][Ff][Aa]$/, @allfiles);
    @pfbfiles = grep(/\.[Pp][Ff][Bb]$/, @allfiles);
    @dotless = grep(!/\./, @allfiles); # files with no dots in name
    @dotless  =grep(-T, @dotless); # accept only text files...
    closedir(THISDIR);
    ## (Of course, @dotless still might contain oddball font lookalikes...)
}

## Another UNDOCUMENTED FEATURE:  If variables $font_place and $afm_place
## are defined (perhaps in vfinst.par...), then the fonts/afms will be taken
## from that pair of locations instead of from the current working directory
## ".".  

sub AllAfmsNeedMates{
  local(@allfiles, @pfafiles, @pfbfiles, @dotless);
  local(@missingfonts, @missingafms);
  &get_afm_names($afm_place);
  &get_font_names($font_place);
  @allfonts=@pfafiles;
  push(@allfonts, @pfbfiles);
  push(@allfonts, @dotless);
  @allfontnames = @allfonts; # save fonts with original extensions
  @oriafmfiles = @afmfiles;	# save afm's with original extensions
  &stripextension(*afmfiles, "[Aa][Ff][Mm]");
  &stripextension(*allfonts, "[Pp][Ff][AaBb]"); # regex OK in stripextension
  if ($debugging == $false) { # not debugging...
    @missingfonts = &listcompare(*afmfiles, *allfonts); 
    @missingafms =  &listcompare(*allfonts, *afmfiles); 
    local($fontgaps) = $false;
    if ($#missingfonts > -1) {## warning---missing font files
      $fontgaps = $true;
      &dwlog("There are some missing afm files.");
      &dwlog("They are >> \n ", join("\n ", @missingfonts));
      &dwlog("You will need to find the missing afm's and re-install.");
    }
    if ($#missingafms > -1) {## warning---missing afm files
      $fontgaps = $true;
      &dwlog("There are some missing font files.");
      &dwlog("They are >> \n ", join("\n ", @missingafms));
      &dwlog("You will need to find the missing fonts and re-install.");
    }
    if ($#afmfiles < 0) {# no afms at all!
      $fontgaps = $true;
      &dwlog("That's funny---I find no afm files at all!");
    } 
    if ($#allfonts < 0) {# no fonts at all!
      $fontgaps = $true;
      &dwlog("That's funny---I find no font files at all!");
    }
    &dwlog("Fonts appear to be all in order!") unless $fontgaps;   
    die "Something is wierd, and I can't go on..." if $fontgaps;  
  } else { # debugging
    &dwlog(" *** Debugging now---not checking font files at all...");
  }
}

## When using &ClassifyEachFont (see below), we need to extract certain
## info from the initial part of the afm file.  If the first arg is found
## in the current line from afm, the info is stored in the second arg.
## Eg.: &getafminfo('FamilyName', $Familyname);

sub getafminfo{
  local($searchstr) = $_[0];
  if (/$searchstr/) {
    ($head, $_[1])=split(/ /, $_, 2);
    $_[1] = $correx{"$currafm$searchstr"} 
      if defined $correx{"$currafm$searchstr"};
    &Canonize($_[1]); # removes white space
  }
}

  $talk = <<"Endtalk";
I need a 3-character designation for each font family
you've given me.  If I have heard of the family, I'll 
suggest the abbreviation to you (simply press ENTER to
accept).  If the family is new to me, I'll make a naive
suggestion; again, press ENTER to accept, or enter an 
abbreviation of your own.  

Endtalk

sub validatefamilydata{
  $myfamily = &stdin;
  for (;;) {
    $l = length($myfamily);
    if ( ($l == 3) || ($l == 0) ) {last;}
    print "Stop trying to confuse me---I need EXACTLY \n";
    print "three (3) characters.  Please try again (or just push ENTER). >> ";
    $myfamily = &stdin;
  }
}

## The lines of map.sup have lines like
##   a autologi Autologic
##   b bitstrea Bitstream
## It's a small table, so we load it right away.
## (The `sup' stands for `supplier'.)

sub loadsupplierinfo{
    open (SUPP, "..${sep}map.sup") || "I'm missing file map.sup.";
    while (<SUPP>) {
	next if /^\#/;		# discard comments
	chop;
	local($s, $supdirectory, $suppliername) = split(/\s+/, $_, 3);
	$supp2sabb{$suppliername} = $s;
	$sabb2supdir{$s} = $supdirectory;
    }
    $defaults = "9";
    $defaultsuppliername = "unknown";
}
&loadsupplierinfo;		# just do it!


## The entries in map.n2a look like this:
##   ACaslon ac
##   AGaramond ad
## (This file maps family names (n) to fontname abbrevs (a).)

sub loadfontfamilyinfo{
  open (DICT, "..${sep}map.n2a") || 
      die "Can't seem to open file `map.n2a'. Help, please";
  while (<DICT>) {
      next if /^\#/;		# ignore comments
      ($knownfamily, $abb) = split(/\s+/, $_);
      $family2abb{$knownfamily} = $abb;
  }
  close DICT;
}
&loadfontfamilyinfo;

## Lines in the map.a2d file look like this:
##   ac acaslon
##   ad agaramon
## (This file maps fontname abbreviations (a) to TDS directory
## names (d).)

sub loadfamdirectoryinfo{
    open (DICT, "..${sep}map.a2d") ||
	die "Can't open `map.a2d'.  Mayday...";
    while (<DICT>) {
	next if /^\#/;		# ignore comments
	($ab, $abbdir) = split(/\s+/, $_);
	$abb2dir{$ab} = $abbdir;
    }
}

## If a font family appears to be unknown, it may still be 
## possible to make an educated guess.  A known family may actually
## be embedded in the current family, as `AGaramond' is in 
## the family `AGaramondExp-Regular'.  We'll cycle through all the 
## hash keys to see if this is so.  We've previously prepared a file 
## `famnames' which contains the sorted family names (sorted by
## length of family name, that is), and we'd better read it into
## the array @famnames.

## sub bynamelength{
##     $aa = length($a); $bb = length($b);
##     $n2l{$a} = $aa; $n2l{$b} = $bb;
##     $n2l{$b} <=> $n2l{$a};
## }
## @famnames = sort bynamelength keys %family2abb;
## undef %n2l;

sub loadsortedfamnames{
    open(FAMNAMES, "..${sep}famnames") ||
	die "Where is my list of family names `famnames'?";
    while (<FAMNAMES>) {
	chop;
	push(@famnames, $_);
    }
    close FAMNAMES;
}
&loadsortedfamnames;		# loads the @famnames array

sub guessfontfamily{
    local($found) = false;
    foreach $fname (@famnames) {
	next if length($Familyname) < length($fname);
	$fname_ = $fname; 
	last if $Familyname =~ /$fname_/;
    }
    $found = $true if $Familyname =~ /$fname_/;
    $tentativefamily = "unknown"; # the default
    $tentativefamily = $family2abb{$fname_} if $found == $true;
    $tentativefamily = "$thisabb$tentativefamily";
}

$talked=$false;
sub getfontfamily{
  print $talk if $talked == $false; $talked = $true;
  if (defined($family2abb{$Familyname})) { # known font family
      ($tentativefamily, $tmp) = split(/ /, $family2abb{$Familyname});
      $tentativefamily =~ tr/A-Z/a-z/;
      $tentativefamily = "$thisabb$tentativefamily";
      print "Here's what I can suggest for a family name for \n";
      print ">>  $Familyname.\nPress ENTER to accept, or type your own:\n";
      print "  >>  $tentativefamily\n";
  } else {			# unknown font family
      &guessfontfamily;
      $bruteforceguess=substr($fontname, 0, 2);
      $bruteforceguess=~tr/A-Z/a-z/;
      $bruteforceguess = "$thisabb$bruteforceguess";
      $tentativefamily = $bruteforceguess 
	  if $tentativefamily =~ "unknown";
      print "I've not heard of the font family containing\n";
      print "$fontname in file $currafm.  May I suggest\n";
      print ">>  $tentativefamily\nas a font family name?  ";
      print "(Press ENTER to accept, or give a 3-letter name.) \n";
  }
  &validatefamilydata; # must be exactly 3 chars or a null string
  if ($myfamily eq "") {$myfamily=$tentativefamily;}
  $family{$Familyname}=$myfamily; # eg. $family{'AGaramond'}='pad'
}

## computes tangent from ItalicAngle
## eg. $mytan = &Tan($italicangle);

sub tan{
  local($angle) = @_;
  local($radangle) = $angle * $piover180;
  $mytan = sin($radangle)/cos($radangle);
  if ($mytan < 0) { 
     $mytan = -1*$mytan;
  }
  $mytan;
}

## FindArrayElementContaining finds the element of $_[0] which contains $_[1].
## eg. $currfont = &FindArrayElementContaining(*allfontnames, $currafm);
## We use this array to use the first name of an afm file to read into
## an array containing full names of font files to get the actual font
## name.

sub FindArrayElementContaining{
  local(*source, $strng)=@_;
  foreach $elem (@source) {
    $found = $elem;
    last if $elem =~ /\b$strng\b|\b$strng\./;
  }
  $found;
}

sub getfontcharacteristics{
  @afmtop = ();
  for (;;) {
      $_=<CURRAFM>; chop $_; # get rid of CR-LF
      push (@afmtop, $_) unless /EncodingScheme/; # store the top
      last if /StartCharMetrics/;
      &getafminfo("FontName", $fontname); 
      &getafminfo("FullName", $fullname);
      &getafminfo("FamilyName", $Formalfamilyname); 
      &getafminfo("Weight", $weight); $weight =~ tr/A-Z/a-z/;
      &getafminfo("EncodingScheme", $encoding);
      &getafminfo("ItalicAngle", $italicangle);
      &getafminfo("IsFixedPitch", $monowidth);
  }
  $topofafmfile = join ("", @afmtop);
  foreach $supplier (keys %supp2sabb) {
      $supplierfound = $true;
      $thissupplier = $supplier;
      $thisabb = $supp2sabb{$supplier};
      last if $topofafmfile =~ /$supplier/;
      $supplierfound = $false;
  }
  if ($supplierfound == $false) {
    $thissupplier = "unknown";	# use defaults
    $thisabb = "9";
  }
}

sub getfontangle{
  $angle{$myfamily} = 0 unless defined $angle{$myfamily}; # default
  if ($italicangle != 0) {# non-upright font
    $mytan = &tan($italicangle);
    $angle{$myfamily} = int(1000 * $mytan);
    ## Because of coordinate system differences, the angle is almost
    ## always negative, so the tan will be negative.  We make it positive.
    ## Incidentally, Perl4 forgot to make the tangent negative, so we 
    ## deal with it here.
    $angle{$myfamily} *= -1 if $angle{$myfamily}<0;
  } else {
    $angle{$myfamily} = "000";
  }
}

&loadweightinfo;

sub getfontweight{
    if (defined($weightsortkey{$weight})) {
	$wsk = $weightsortkey{$weight};	# weight sort key
	$wind = $weightindicator{$weight}; # weight indicator
    } else {			# screwy weight somehow
	print "The weight `$weight' for $fontname is a new one for me.\n";
	print "I use defaults for normal-type weights.\n";
	$weight = "normal";
	$wsk = $weightsortkey{$weight}; # use normal as default
	$wind = $weightindicator{$weight}; # ditto; alert user
    }
}

&loadshapeinfo;

sub getfontshape{
    $shapekey = "roman";	# default values follow...
    $shsk = 0;
    $shind = "r";
    foreach $key (keys %shapesortkey) {
	if ($fullname=~/$key/i) {
	    $shsk = $shapesortkey{$key};
	    $shind = $shapeindicator{$key};
	    $shapekey = $key;
	}
    }
}

&loadvariantinfo;

## It's possible that raw fonts can have more than one non-shape
## variant.  Such fonts will rarely be suitable for constructing
## virtual fonts for prose typesetting, so I wil give them the highest
## sort key to get them out of the way.  NB:  All sort key synonyms
## are case insensitive EXCEPT for those containing an uppercase
## character in the @variants array.  This necessitates the special
## treatment in the foreach loop below...

sub getfontvariant{
    $variant = 0;		# default
    undef @foundvariants;
    $varsk = -1;		# default for sork key
    foreach $key (keys %variantsortkey) {
        if ($key =~ /[A-Z]/) {# UC indicates case sensitivity
	  if ($fontname =~ /$key/) {
	      push(@foundvariants, $key);
	      $test = $variantsortkey{$key};
	      $varsk = $test if $test>$varsk; # get largest of sort keys
	  }    
	} else {
	  if ($fontname =~ /$key/i) {
	      push(@foundvariants, $key);
	      $test = $variantsortkey{$key};
	      $varsk = $test if $test>$varsk; # get largest of sort keys
	  }    
        }
    }
    if (! defined(@foundvariants)) {
	push(@foundvariants, "regular");
	$varsk = 0;
    }
}

sub sortcurrvar{		# sort the chars in the $currvar string
    local(@chars) = split(//, $currvar);
    @chars = sort @chars;
    $currvar = join('', @chars);
}

sub CreateNewRawFontNames{
    # First, the font abbreviation and weight....
    $berryname = "$myfamily$wind";
    # Now for the issue of variants, which includes shape...
    if ($shsk > 0) {
	$berryname .= $shind;	# append shape if not `normal'
    }
    $currvar = ""; $currdigit = 8; $currenc = "a"; # initialize variants
    # In the absence of other other variants, variants will be given
    # by "$currvar$currdigit$currenc" = "8a".
    foreach $vkey (@foundvariants) {
	$varenctype = $variantenctype{$vkey};
	$varind = $variantindicator{$vkey};
	$varsk = $variantsortkey{$vkey};
        if ($varenctype eq "S") { # a shape-like variant exists for the font
            $currvar .= $varind if $varsk gt "0";
        }
        if (($varsk==4)||($varsk==5)||($varsk==6)||($varsk eq "A")) {
            $currdigit = 7;
        }
        if ($varenctype eq "E") {
            $currenc = $varind;
        }
    }
    # $currvar is a string of letters.  For fun, let's sort them.
    &sortcurrvar;
    $berryname .= "$currvar$currdigit$currenc";
    &dwlog("Uh oh---`$berryname' is more than 8 chars!  Fix me.")
	if length $berryname > 8;
}

sub findmaxlength{		# find longest length of entries in @foo
    local(*foo) = @_;
    $maxl = -1; local($l, $maxl);
    foreach $elem (@foo) { # let's find max length of filename
	$l = length($elem);
	$maxl = $l if $l > $maxl;
    }
    $maxl;
}

## Sometimes, two or more fonts have the same sortkey.  This may occur
## because the font files are somehow present more than once in the 
## working directory, or because VFinst is not capable of distinuishing 
## between two different fonts.  The user should be notified of this
## potential conflict.  Duplicate fonts should be eliminated.
## Then, 1vfinst should be executed again

undef @duplicates;			# initialize array
sub checkforduplicates{
    foreach $line (@fontlist) {
	local($sortkey, $fontstuff) = split / /, $line, 2;
	$scratch{$sortkey} .= $line;
    }
    local($count);
    foreach $key (keys %scratch) {
	chomp $scratch{$key};
	$count = ($scratch{$key} =~ /\n/g); # $count>0 for duplicate entries
	push(@duplicate, $scratch{$key}) if $count > 0;
    }
    undef @scratch;
    $duplicates_found = $true if @duplicate;
}




  $TDStalk = <<"EndTDStalk";
You have indicated this is a TeX Directory Structure (TDS)
system.  That means you'll need to provide me a supplier
(e.g., monotype, adobe, etc) and a typeface name (agaramon,
baskerv, and so on).  I'll do my best to help you, but
you might need to provide me with names.  Here we go...

EndTDStalk

## One special case: in general, medium and normal are two distinct
## weights (series).  People are sloppy about their terminology, however.
## In case there is no actual normal series, medium shall become normal.

$normalweight = $false;
$mediumweight = $false;
sub recalibratefontlist{
    foreach $elem (@fontlist) {
	if (substr($elem, 3, 1) == $mediumwt) {	# we've found medium!
	    substr($elem, 3, 1) = $normalwt; # change sort key
	    substr($elem, 10, 1) = "r";	# change series indicator
	}
    }
}

sub getfontcorrections{
    open (RC, "..${sep}vfinst.rc");
    &dwlog("\nHere are the font corrections in vfinst.rc:");
    while (<RC>) {
	chop if /\n$/;		# get rid of newline if it is present
	next if /^\#/;		# ignore comments
	&dwlog("  $_");
	s/\s+/ /g;		# eliminate extra spaces
	local($fontname, $characteristic, $correction) = 
	    split(/\s+/, $_, 3);
        $afmfile=$file2font{$fontname};
	$correx{"$afmfile$characteristic"} = $correction;
    }
    close RC;
    &dwlog("");			# skip a line
}

## We need to connect the fonts via the FontName with the names
## of the font files before they have been renamed according to the
## Berry scheme.  The next subroutine creates that mapping---a hash
##     so that $font2file{$fontname}=$filename.

sub map_files_to_fonts{
    foreach $afm_ (@oriafmfiles) {
	open(CURRAFM, "$afm_place$sep$afm_") || die "Where is $afm_?";
	local($afmm, $ext)=split(/\./, $afm_);
	$myfontname="XXXXXX";	# default value indicates not found
        for (;;) {
            $_=<CURRAFM>; 
	    $_ =~ s/[\n\r]//g; # get rid of CR-LF
            last if /StartCharMetrics/;
            if (/FontName/) {
		($tmp, $myfontname)=split(/ /, $_, 2);  
	    }
	}
	$file2font{$myfontname}=$afmm;
    }
}

sub ClassifyEachFont{
  @afmfiles = sort @afmfiles;
  &map_files_to_fonts; 
  &getfontcorrections if -e "..${sep}vfinst.rc"; # non-invasive afm correx
  foreach $currafmname (@oriafmfiles) {
    local($currafm, $aext) = split /\./, $currafmname;             
    open(CURRAFM, "$afm_place$sep$currafmname"); 
    &getfontcharacteristics;
    $normalweight = $true 
	if $weightsortkey{$weight} == $weightsortkey{"normal"};
    $mediumweight = $true
	if $weight =~ /medium/i;
    # We'll try to get as much info as possible from the fontname
    ($Familyname, $fontvar) = split(/-/,$fontname);
    close CURRAFM;  
    $familyname = $Familyname; 
    &getfontfamily unless defined $family{$Familyname};     
    $myfamily = $family{$Familyname};
    &getfontangle;
    &getfontweight;
    &getfontshape;
    &getfontvariant;
    $sortkey="$myfamily$wsk$shsk$varsk";
    # Now that we have all the information about the font, we might as 
    # well create the new Berry name for it...
    &CreateNewRawFontNames;
    $currfont = &FindArrayElementContaining(*allfontnames, $currafm);
    local($fontfirst, $fext) = split /\./, $currfont;
    $maxlength = &findmaxlength(*allfontnames);
    $maxlength = 11 if $maxlength<11;
    $currfont = "Unknown" if $debugging;
    $maxlength = length("unknown ") if $debugging;
    &rpad($berryname, 11);
    $fontandafm = "$fontfirst.\{$fext,$aext\}";
    &rpad($fontandafm, $maxlength+6);
    $fontinformation = 
      "$sortkey $berryname$angle{$myfamily} $fontandafm $fontname\n";
    ## Before saving this information, we first...
    push(@fontlist,$fontinformation);
  }
  undef %family2abb; # release memory resources
  if (($normalweight == $false) && ($mediumweight == $true)) {
      # That is, since there is no normal but there is a medium,
      # medium shall become normal.
      $mediumwt = $weightsortkey{"medium"};
      $normalwt = $weightsortkey{"normal"};
      &recalibratefontlist;
  }
  @fontlist = sort @fontlist;
  &checkforduplicates;
  $file = "File"; &rpad($file, $maxlength);
  $name = "Name"; &rpad($name, $maxlength);
  &dwlog("\nHere are the fonts and their proposed new (Berry) names:\n");
  $titles[0] = 
    "$rem Sort New     Slant  $file       Long Digital Foundry ";
  $titles[1] =  
    "$rem Key  Name           $name       Name ... ";
  $titles[2] = "$rem " . "=" x 72; 
  open (FONTS, ">fonts.lst");
  print FONTS "$rem This is list of font information used by VFinst.\n";
  print FONTS "$rem Created by $vfp on $today at $now.\n$rem\n";
  print FONTS join("\n",@titles), "\n";
  print FONTS @fontlist;
  close FONTS;
  &dwlog(join("\n",@titles));
  &dwlog(join("",@fontlist));
  if (&isTDS) {			# get additional info for TDS...
   # At this point, all fonts have been classified and stored within
   # @fontlist.  We'll waltz through that array, using that array to
   # determine the font families we are using and to seek for 
   # appropraite info in the map files that are part of vfinst.
   print $TDStalk;
   open (TYPE, ">typeface.lst");
   &loadfamdirectoryinfo;
   foreach $entry (@fontlist) {
       undef $famdir;
       ($sortkey, $berryname, $slant, $currfont, $fontname) = 
	   split(/\s+/, $entry);
       $s = substr($berryname, 0, 1); # supplier abbreviation
       $fm = substr($berryname, 1, 2); # 2-char family abbrev
       $fm = substr($berryname, 1, 2); # 2-char family abbrev
       $fam = substr($berryname, 0, 3); # 3-char family abbrev
       if (!defined $famdir{$fam}) { # get info only if necessary...
           $currsupdir{$fam} = $sabb2supdir{$s};# supplier first
           print "I will use supplier directory\n  >>$currsupdir{$fam}";
           print "\nfor $berryname and all other fonts with the same\n";
           print "family name.  Press ENTER to accept, or enter another\n";
           print "alternative....  ";
           $alt = &stdin;
           $currsupdir{$fam} = $alt if $alt ne "";
	   $famdir{$fam} = $abb2dir{$fm} if defined $abb2dir{$fm};
           if (!defined $abb2dir{$fm}) {# no lookup info
	       print "Hmm---I have no information for a directory name for\n";
	       print "the $fm family of fonts.  Please enter a lowercase\n";
	       print "directory name for these fonts.  >>";
	       $famdir{$fam} = &stdin;
	   } else {
	       print "I will use font directory name\n  >>$abb2dir{$fm}\n";
	       print "for $berryname and all other fonts within the same\n";
	       print "family.  Press ENTER to accept, or enter another\n";
	       print "directory name now.  >>";
	       $alt = &stdin;
	       $famdir{$fam} = $alt if $alt ne "";
	   }
	   $tdsinfo{$fam} = "$fam $famdir{$fam} $currsupdir{$fam}";
	   print TYPE "$tdsinfo{$fam}\n";
       }
   }
   close TYPE;
   &dwlog("\nHere are the fontfamilies, typeface names, and suppliers");
   &dwlog("for this installation:\n");
   foreach $key (sort keys %tdsinfo) {
  	     &dwlog("$tdsinfo{$key}");
	 }
   &reassure("fonts.lst");
  }
  open(DUPS, ">duplicat.lst") || # prepare for duplicate info...
      die "Can't open duplicates file";
  print DUPS "This file `duplicat.lst' created by $vfp";
  print DUPS " on $today at $now.\n\n";
  if ($duplicates_found) {
      print DUPS "A list of all fonts that appear the same to VFINST...\n";
      print DUPS "=============================================\n";
      &dwlog("Some fonts may be duplicated or may not appear distinct to ");
      &dwlog("VFinst.  Here's the list:\n");
      &dwlog("=============================================");
      foreach $dup (@duplicate) {
	  print DUPS "$dup\n";
	  print DUPS "=============================================\n";
	  &dwlog("$dup\n", "=============================================");
      }
      &dwlog("Make adjustments, and re-run this script `1vfinst'.");
      &dwlog("(Check `Fixing .afm files' in `vfinst.tex' for assistance.)");
      &reassure("duplicat.lst");
      print DUPS "Duplicates should be removed or fixed; check `vfinst.tex'";
      print DUPS " for assistance.  Then _re-run_ the `1vfinst' script...\n";
  } else {
      print DUPS "No duplicate fonts found.\n";
      &dwlog("No duplicate fonts found.");
  }
  close DUPS;
}

################################################################
#
# MAIN ROUTINE.
#
################################################################

## First, we open a text file that gets written again ONLY in cases
## of normal program termination.  This makes it possible for 2vfinst.prl
## to test for proper termination of this program.

print "This is $vfp.\n\n"; # banner

sub DoIt{
  &OpenLog; ## opens the log file
  &GetEnvironment;
  if (&isTDS) {
    print "\nThis is a TDS (TeX Directory Structure) Production!\n\n";
  }
  &CheckInstallation(@VFINSTmanifest);
  &AllAfmsNeedMates;
  &ClassifyEachFont; # get font family, width, shape, and variant, etc.
  &CloseLog;
}

&DoIt; ## YES!!

## Now summarize instructions for the next phase...
open (NOW, ">start.vfi");
print NOW "(This is the file _start.vfi_ produced by VFinst$ver.)\n\n";
print NOW "Here's the list of fonts with some supporting information:\n\n";
print NOW join("\n",@titles),"\n";
print NOW join("",@fontlist);
if ($duplicates_found) {
    print NOW 
	"\nVFinst thinks that some fonts are duplicated.  Here's that list:\n";
    print NOW 
	"==============================================================\n";
    foreach $dup (@duplicate) {
	print NOW "$dup\n";
	print NOW 
	    "==============================================================\n";
    }
}
    $now =<<"EndNow";

     Please inspect this list, and eliminate any fonts (.pfb + .afm)
that may not be appropriate.  (Check `vfinst.tex` for additional info.)
Eliminate any duplicate fonts, if VFinst found any.  In case you do make
any changes to the fonts that are present, please then re-run the script
`1vfinst`.  
     When you are satisfied with your collection of fonts, then
run the script `2vfinst`.
EndNow
print NOW $now;
print $now;
close NOW;
&display("\n(Font information plus instructions for proceeding \n",
	 "appear in the Ascii file `start.vfi'.");