#!/usr/bin/env perl
# magick-typegen - Creates a font database for ImageMagick.
# License:  Public domain
# Revision: 070415

#---------------------------------------------------------------------
#                            module setup
#---------------------------------------------------------------------

require 5.8.1;
use strict;
use Carp;
use warnings;

#---------------------------------------------------------------------
#                              overview
#---------------------------------------------------------------------

# 1. License issues.

# This script is descended from a  script  posted  to the  ImageMagick
# "magick-users" discussion list in 2002 or 2003.  [There's some  con-
# fusion related to the year.  The original posting  says March  2003.
# However,  as of mid-2007,  "archive.org" indicates that it was March
# 2002.]

# The original poster's  name  [or pseudonym]  was  "raptor",  and the
# original URL was:
#
#     http://studio.imagemagick.org/pipermail/magick-users/\
# 2003-March/001703.html

# The  original script was apparently revised by Anthony Thyssen,  who
# posted his version to:
#
#     http://www.cit.gu.edu.au/~anthony/software/imagick_type_gen.pl

# As of mid-2007, both URLs are broken.

# This script  is a  modified copy of  Mr. Thyssen's version of  "rap-
# tor's" original code.

# "raptor" didn't include an explicit license in the original posting,
# and  Mr. Thyssen didn't add one.  However, based on the contents and
# context of the original posting,  this code is believed to be in the
# public domain.

#---------------------------------------------------------------------

# 2. Technical issues:

# The most  important differences between  this script  and  Mr. Thys-
# sen's version are as follows:
#
#     (a) This script doesn't assume that a  "locate" database exists.
#         It uses  "find"  instead of "locate".  This is  slower,  but
#         safer for our purposes.
#
#     (b) One feature has been added to mitigate the slowdown mention-
#         ed previously.  By default,  this script searches the entire
#         "/usr" tree for fonts.  To speed  things up,  the  user  can
#         specify  an alternate set of directory trees [e.g., just the
#         locations where fonts are likely to be].
#
#         To specify a set of directory trees, before running the pro-
#         gram,  set the  environment variable  MAGICKTYPEGENDIRS to a
#         list of  one or more directories,  separated  by colons.  If
#         you're running "sh" or "bash", remember to "export" the var-
#         iable.
#
#         Note:  Entries should be absolute paths.  Relative paths and
#         non-existent directories are ignored.

#---------------------------------------------------------------------

my $TYPEGENDIRS;
my @TYPEGENDIRS;

$TYPEGENDIRS =  $ENV {MAGICKTYPEGENDIRS};
$TYPEGENDIRS =  "" if !defined $TYPEGENDIRS;
$TYPEGENDIRS =~ s@\s*:+\s*@:@g;
$TYPEGENDIRS =~ s@:+@:@g;
$TYPEGENDIRS =~ s@^:@@;
$TYPEGENDIRS =~ s@:\z@@;
$TYPEGENDIRS =  '/usr' if !length $TYPEGENDIRS;

@TYPEGENDIRS = split (/\s*:+\s*/, $TYPEGENDIRS);
undef $TYPEGENDIRS;

#---------------------------------------------------------------------

(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 "find"
    | command, not "locate" as in the standard version of this utility.
    | "find" is slower, but safer for our purposes.
    | The output informs IM of font location, type, name
    | and family.
    |
    | When the file has been generated you can 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  "ttftool"  [originally from the  Abiword pack-
# age]. "ttftool" is used 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

# The abiword TTF font tool
my $ttftool = `which ttftool 2>/dev/null`;
$ttftool =  "" if !defined $ttftool;
$ttftool =~ s@\s+\z@@s;
$ttftool =  '/no-such-file' if !length $ttftool;
$ttftool =  '/no-such-file' if !-x $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$/ )[0] );
}

sub do_ttf_fonts
{
    my $str;
    my @lines = ();

    for my $tree (sort @TYPEGENDIRS)
    {
        next if $tree !~ m@^/@;
        next if !-d $tree;

        $str   =  `find "$tree" -name \*.ttf 2>/dev/null`;
        $str   =  "" if !defined $str;
        $str   =~ s@\s+\z@@s;
        push (@lines, split (/\s*\n\s*/, $str));
    }

    for my $file (sort @lines)
    {
        my (@ttf) = ttf_name($file);
        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;
  my $str;
  my @lines;

# locate Adobe font files

    for my $tree (sort @TYPEGENDIRS)
    {
        next if $tree !~ m@^/@;
        next if !-d $tree;

        $str   =  `find $tree -name \*.pfb 2>/dev/null`;
        $str   =  "" if !defined $str;
        $str   =~ s@\s+\z@@s;
        @lines =  split (/\s*\n\s*/, $str);
        map { my ($k) = m/^(.*?)\.pfb\z/; $atf{$k}{pfb} = $_ } @lines;

        $str   =  `find $tree -name \*.afm 2>/dev/null`;
        $str   =  "" if !defined $str;
        $str   =~ s@\s+\z@@s;
        @lines =  split (/\s*\n\s*/, $str);
        map { my ($k) = m/^(.*?)\.afm\z/; $atf{$k}{afm} = $_ } @lines;
    }

  # 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 STDERR join( ' - ', @afm), "\n";
    printf $afm_template_full, @afm, $atf{$key}{pfb}, $atf{$key}{afm};
  }
}

# -----------------------------
#
#  Miscellanous functions
#

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 << 'END';
<?xml version="1.0"?>
<!DOCTYPE typemap [
  <!ELEMENT typemap (type+)>
  <!ELEMENT type (#PCDATA)>
  <!ELEMENT include (#PCDATA)>
  <!ATTLIST type name CDATA #REQUIRED>
  <!ATTLIST type fullname CDATA #IMPLIED>
  <!ATTLIST type family CDATA #IMPLIED>
  <!ATTLIST type foundry CDATA #IMPLIED>
  <!ATTLIST type weight CDATA #IMPLIED>
  <!ATTLIST type style CDATA #IMPLIED>
  <!ATTLIST type stretch CDATA #IMPLIED>
  <!ATTLIST type format CDATA #IMPLIED>
  <!ATTLIST type metrics CDATA #IMPLIED>
  <!ATTLIST type glyphs CDATA #REQUIRED>
  <!ATTLIST type version CDATA #IMPLIED>
  <!ATTLIST include file CDATA #REQUIRED>
]>
<typemap>
END

do_ttf_fonts();
do_afm_fonts();

print "</typemap>\n";
exit 0;