#!/usr/bin/perl -w
#
(my $prog = $0) =~ s/^.*\///;
sub Usage {
  die @_, &herefile( qq{
    | Usage: $prog > ~/.magick/type.xml
    |
    | Generate an ImageMagick font list "type.xml" file for ALL fonts (both
    | true type fonts (ttf) and Ghostscript fonts (afm))  currently on the
    | local linux system.  The fonts are found using the linux "locate"
    | command, and the output informs IM of their location, font type, name
    | and family.
    |
    | When the file has been generated you can then see a list of the
    | fonts found with...
    |    convert -list type
    | And use the fonts, by name, with commands like...
    |    convert -font Candice -pointsize 72 label:Anthony  x:
    | Instead of specifying the specific TTF font file
    |    convert -font ~/lib/font/truetype/favoriate/candice.ttf \
    |            -pointsize 72 label:Anthony  x:
    |
    | NOTE before IM v6.1.2-3  the font list file was called "type.mgk" and
    | not "type.xml".
    |
    | Note: IM version 5.5.7 installed as a system program (such as from a
    | linux RPM) will NOT read this file from the home directory location
    | above automatically.  To fix this you may need to add a line to the
    | systems "type.mgk" file such as...
    |    <include file="../../../../../../../home/anthony/.magick/type.mgk"/>
    | Note that the path must be a relative path, thus the numerious ".."
    | in the above line, you can specify more ".." than you really need.
    |
    |  Anthony Thyssen  May 2003
  });
}
# Internal working notes...
#
# This script requires the linux "locate" command to find the fonts,
# and optionally the Abiword  "ttftool"  program, to extract font names.
#
# The original version of this hack script was found on
#   http://studio.imagemagick.org/pipermail/magick-users/2003-March/001703.html
# by  raptor <raptor@unacs.bg>, presumaibly around  March 2002
#
# Re-Write by Anthony Thyssen <anthony@cit.gu.edu.au>, August 2002
# Update with TTF family names   May 2003
#
use strict;

# The abiword TTF font tool (redhat 7.3, 8.0, 9.0)
chop( my $ttftool = `which ttftool` );

# ======================================================================
# Subroutines...
# ======================================================================
#
# True Type fonts Handling
#
my $ttf_template = herefile( q{
  |   <type
  |      format="ttf"
  |      name="%s"
  |      glyphs="%s"
  |      />
  });
my $ttf_template_full = herefile( q{
  |   <type
  |      format="ttf"
  |      name="%s"
  |      fullname="%s"
  |      family="%s"
  |      glyphs="%s"
  |      />
  });

warn("$prog: Unable to locate abiword's ttftool - proceeding without it\n")
                                                          unless -f $ttftool;

sub ttf_name {
  my $file = shift;
  if ( -f $ttftool ) {

    # Use the abiword TTF tool to extract the ttf font names.
    my( $name, $fullname, $family ) = ('','','');
    open( TTF, "-|" ) or exec($ttftool, '-f', $file, '-p', '/dev/fd/1');
    while( <TTF> ) {
      last if /^end/;
      $fullname = $1  if /^\/FullName \((.*)\)/;
      $family   = $1  if /^\/FamilyName \((.*)\)/;
    }
    #print "$file ==> $family -- $name\n";   # debuging
    close TTF;

    $family   =~ s/\s*(MS|MT|UI|FB|ITC)$//;  # font factory ititials
    $family   =~ s/\\050/(/g;
    $family   =~ s/\\051/)/g;
    $family   =~ s/\(Unregistered\)//g;

    $fullname =~ s/\b(MS|MT|UI|FB|ITC)\b//;
    $fullname =~ s/\\050/(/g;
    $fullname =~ s/\\051/)/g;
    $fullname =~ s/\(Unregistered\)//g;

    $name = $fullname;
    $name =~ s/\bRegular\b//;            # Junk/abbr decriptive strings
    $name =~ s/\bDemi\s*[Bb]old\b/Db/g;
    $name =~ s/\bBold\b/B/g;
    $name =~ s/\bItalic\b/I/g;
    $name =~ s/\bExtra[Bb]old\b/Xb/g;
    $name =~ s/\bBlack\b/Bk/g;
    $name =~ s/\bHeavy\b/H/g;
    $name =~ s/\bLight\b/L/g;
    $name =~ s/\bOblique\b/Ob/g;

    $name =~ s/[-\s]+/ /g;
    $fullname =~ s/\s+/ /g;
    $fullname =~ s/\s$//g;
    $fullname =~ s/^\s//g;

    #$name   =~ s/$family//;      # remove family to leave font styles
    #$family =~ s/[-\s]+//g;     # remove spaces/hyphens

    # re-add family with hyphen (if nessary)
    #$name   =  ($name =~ /[ace-jl-z]/) ? "$family-$name" : "$family$name";

    return ($name, $fullname, $family) if $name;  # return the name if found!
    # If no name was found -- fall through.
  }

  # Failed to extract a TTF font name -- just filename -- YUCK
  return( ( $file =~ m/^.*\/(.*?).ttf$/i )[0] );
}

sub do_ttf_fonts {
  for my $file ( locate('.ttf') ) {
    chop $file;
    my (@ttf) = ttf_name($file);
    print $file."\t".$ttf[0]."\n";
    #print STDERR join( ' - ', @ttf), "\n";
    #printf $ttf_template, @ttf, $file       if @ttf == 1;
    #printf $ttf_template_full, @ttf, $file  if @ttf == 3;
  }
}


#---------------------------
#
# Adobe Type fonts
#
# Get font name from the AFM file
my $afm_template_full = herefile( q{
  |   <type
  |      format="type1"
  |      name="%s"
  |      fullname="%s"
  |      family="%s"
  |      glyphs="%s"
  |      metrics="%s"
  |      />
  });

sub afm_name {
  my( $name, $fullname, $family ) = ('','','');
  open AFM, shift;
  while( <AFM> ) {
    chop; last if /^StartCharMetrics/;
    #$name     = $1  if /^FontName (.*)/;
    $fullname = $1  if /^FullName (.*)/;
    $family   = $1  if /^FamilyName (.*)/;
  }
  close AFM;

    $family =~ s/\s*L$//;    # just the stupid 'L'
    $fullname =~ s/\bL\b//;

    $name = $fullname;

    $name =~ s/\bRegular\b//;            # Junk/abbr decriptive strings
    $name =~ s/\bDemi\s*[Bb]old\b/Db/g;
    $name =~ s/\bBold\b/B/g;
    $name =~ s/\bItalic\b/I/g;
    $name =~ s/\bExtra[Bb]old\b/Xb/g;
    $name =~ s/\bBlack\b/Bk/g;
    $name =~ s/\bHeavy\b/H/g;
    $name =~ s/\bLight\b/L/g;

    $name =~ s/[-\s]+//g;
    $fullname =~ s/\s+/ /g;
    $fullname =~ s/\s$//g;
    $fullname =~ s/^\s//g;

  return ($name, $fullname, $family );
}

sub do_afm_fonts {
  my %atf;
  # locate abode font files
  map { chop; my ($k) = m/^(.*?).pfb*$/; $atf{$k}{pfb} = $_ } locate('.pfb');
  map { chop; my ($k) = m/^(.*?).afm*$/; $atf{$k}{afm} = $_ } locate('.afm');

  # for each Abode font where BOTH files were found.
  for my $key (keys %atf) {
    next unless $atf{$key}{pfb} && $atf{$key}{afm};
    my (@afm) = afm_name($atf{$key}{afm});
    print $atf{$key}{pfb}."\t".$afm[1]."\n";
    #print STDERR join( ' - ', @afm), "\n";
    #printf $afm_template_full, @afm, $atf{$key}{pfb}, $atf{$key}{afm};
  }
}

# -----------------------------
#
#  Miscellanous functions
#
sub locate {
  #return `locate -r $_[0]\$`;
  return `locate -i $_[0] | grep $_[0] | grep -v ports | grep "/usr/local/www/data/dev/lib/fonts/ttf/" `;
}

sub herefile {  # Handle a multi-line quoted indented string
  my $string = shift;
  $string =~ s/^\s*//;        # remove start spaces
  $string =~ s/^\s*\| ?//gm;  # remove line starts
  $string =~ s/\s*$/\n/g;     # remove end spaces
  return $string;
}

# ======================================================================
# Main Function
# ======================================================================


# HACK -- extract font names for the given TTF font file.
if ( @ARGV ) {
  Usage     unless $ARGV[0] =~ /\.ttf$/;
  for my $file ( @ARGV ) {
    print join( ' - ', ttf_name($file) ), "\n";
  }
  exit 0;
}

# Generate the "type.xml" file.

# Do the job...
#print herefile( q{
#  | <?xml version="1.0"?>
#  | <typemap>
#});

do_ttf_fonts();
do_afm_fonts();

#print "</typemap>\n";