#!/usr/athena/bin/perl
# Process the .map files in a TeX installation tree, looking for
# PostScript fonts.  Then, show all of those fonts.
#
use warnings;
use strict;
use File::Find;

# use the standard Athena TeX tree by default
@ARGV = qw( /usr/athena/share/texmf ) unless @ARGV;

### code to process files and directories

our (%map);

sub read_map ( $$ ) {
  my ($map, $mapPath) = @_;
  -f $map or die "$map: not a regular file\n";

  $map =~ /^dvipdfm.*\.map$/ and return;
  my @last;

  open my $MAP, '<', $map or die "open($map): $!";
  while (<$MAP>) {
    /\S/ or next;
    /^\s*%/ and next;

    my ($vname, $psname, $cmds, $loads) =
      /^ ([-\w]+) \s+ (?: ([-\w]+) \s*)? (" [^"]* " \s* )? (?: \d+ \s+ )?
         (?: (< \s* [^<\s]+ (?: \s+ (?: < \s* )? [^<\s]+ )* ) \s* )? $/x
	   or die "$mapPath: parse: $_";
    $psname = '???' unless $psname;

    my @loads = split /\s*</, $loads if $loads;
    my ($pfb, @rest) = grep /\.(pf[ab]|ttf)$/, @loads;
    @rest and warn "$mapPath: multiple fonts: $_";
    my $pfbn = $pfb || '';

    push @{ $map{$vname} }, [ $psname, $pfbn, $cmds ];
  }
}

our (%psfont, %tfm);

sub process () {
  $_ eq 'fontname' and $File::Find::prune = 1, return;

  /\.(?:pf[ab]|ttf)$/i and push @{ $psfont{$_} }, $File::Find::name, return;
  /\.tfm$/i            and push @{ $tfm{$_} }, $File::Find::name, return;

  /\.map$/i and read_map($_, $File::Find::name), return;
}

sub uniq ( @ ) {
  my (%seen, @out);
  $seen{$_}++ or push @out, $_ for @_;
  @out;
}

### actual data munging

# scan the files
warn "Reading map files...\n";
find( { wanted => \&process }, @ARGV );
warn "...done.\n";

sub by_base {
  my ($ar, $an, $ax, $br, $bn, $bx);

  ($ar, $an, $ax) = ($a =~ /^(\w+)(\d+)(.*?)$/)
    or ($ar, $an, $ax) = ($a, 0, '');
  ($br, $bn, $bx) = ($b =~ /^(\w+)(\d+)(.*?)$/)
    or ($br, $bn, $bx) = ($b, 0, '');

  $ar cmp $br or $an <=> $bn or $ax cmp $bx or $a cmp $b;
}

# process collected data
my @test;
warn "Collating...\n";
for my $vname (sort by_base keys %map) {
  exists $tfm{"$vname.tfm"}
    or warn("missing TFM: $vname\n"), next;
  my $options = $map{$vname};
  my @fonts = uniq map $_->[1], @$options;
  #warn "font files for $vname: @{[map qq['$_'], @fonts]}\n" if @fonts != 1;
  my @exist = map !length($_) ? 1 : exists $psfont{$_}, @fonts;
  my $ok = grep $_, @exist;
  #my $ok = !grep !$_, @exist;
  #warn "status for $vname: @{[$ok ? 'OK' : 'not ok']}\n";  
  my $fonts = join '/', grep length($_), @fonts;
  my $fnames = join '/', grep length($_), uniq map $_->[0], @$options;
  $ok and push(@test, [ $vname, $fnames, $fonts ]);
  #$ok or warn("skipping $vname\n");
}
my $nmap  = scalar(keys %map);
my $nskip = $nmap - @test;
warn "(skipping $nskip of $nmap fonts.)\n";
warn "...done.\n";

# generate a TeX file with the results
warn "Generating output...\n";
print <<'EndOfProlog';
\nopagenumbers
\parindent=0pt
%\parskip=0pt plus 10ex

\def\chars{ABCDEFGHabcdefgh0123!``''\#0\&'()*+,-./456789:;<=>?@IJKLMNOPQRSTUVWXYZ[]\^\_`ijklmnopqrstuvwxyz}
\def\tst#1#2#3{\hbox{\hbox to 3in{\hss #2}\hbox{\font\test=#1 {\test #3}}\hss}}
EndOfProlog

for my $t (@test) {
  my ($vname, $fnames, $fonts) = @$t;
  my $info = join ', ', grep length($_), $fnames, $fonts;
  $info = " ($info)" if $info;
  print "\n\\tst{$vname}{$vname$info}{\\chars}\n";
}
print "\n\\end\n";
warn "...done.\n";