#!/usr/bin/perl -w
use strict;
use warnings;

# see http://russia.shaps.hawaii.edu/software/magick.awk
# tested on:
#  - Darwin 8.11.0 .. Power Macintosh powerpc

my $verbose = 0;
my $usage = "locate '*.ttf' '*.afm' | $0 > ~/.magick/type.xml";
my $ttf2afm = '/sw/bin/ttf2afm';
my @required = ('name', 'fullname', 'family', 'foundry', 'weight', 'style', 'stretch', 'format', 'glyphs');

die "Usage: $usage\n" if -t STDIN;

my %font = (); # name_weight_style => { name => .., full name => , ... }

my $err = '';
while (<>) {

    /^(.*\.(ttf|afm))$/ or die " *** $.: not a afm or ttf file\n";

    my ($typ, $path) = ($2, $1);

    next unless -r $path;

    my $xml = $typ eq 'ttf' ? read_ttf($path) : read_afm($path);

    unless ($xml) { warn " * $path failed ($err)\n" if $err; $err = ''; next }

    my $key = sprintf '%s_%s_%s', $xml->{name}, $xml->{weight}, $xml->{style};

    if ( exists $font{ $key } ) {

        warn sprintf " * $path ignored: %s exists (%s)\n", $key, $font{ $key }->{glyphs} if $verbose;

    } else {
        $font{ $key } = $xml;
    }
}

print '<?xml version="1.0" encoding="UTF-8"?>', "\n",
      join("\n", grep { defined $_ } map { xml2str($_) } values %font), "\n";

###############################################################################

sub xml2str
{
    my $xml = shift;
    my $str = "<type\n";
    foreach my $attr (@required) {
        unless (exists $xml->{$attr}) {
            $err = " ** missing attribute '$attr'\n";
            return;
        }
        $str .= sprintf '  %s="%s"', $attr, $xml->{$attr};
        $str .= "\n";
    }
    return $str . '  />';
}

###############################################################################

sub read_ttf
{
    my $path = shift;
    open my $fh, "$ttf2afm '$path' 2>/dev/null |" or die " *** cannot exec $ttf2afm $path: $!\n";
    my $xml = afm2xml($fh);

    my @discard = <$fh>;
    unless (close $fh) {
        $err = " ** $ttf2afm $path";
        return;
    }

    $xml->{glyphs} = $path;
    return $xml;
}

###############################################################################

sub read_afm
{
    my $path = shift;
    (my $pfb = $path) =~ s/\.afm$/.pfb/;
    unless ( -e $pfb ) {
        $err = " ** $pfb missing" if $verbose;
        return;
    }
    if (open my $fh, $path) {
        my $xml = afm2xml($fh);
        $xml->{glyphs} = $pfb;
        return $xml;
    } else {
        $err = " *** cannot read $path: $!";
        return
    }
}

###############################################################################

sub afm2xml
{
    my $afm = shift;
    my %afm = ();
    while (my $line = <$afm>) {
        last if $line =~ /^StartCharMetrics/;
        next unless $line =~ /^(\S+)\s+(.*\S)\s*$/;
        $afm{$1} = $2;
    }

    my %xml = ();
    $xml{name} = $afm{FontName} or return;
    $xml{fullname} = $afm{FullName} or return;
    $xml{family} = $afm{FamilyName} or return;
    $xml{foundry} = '';
    $xml{weight} = get_weight($afm{Weight}) or return;
    $xml{style} = get_style($xml{fullname}) or return;
    $xml{stretch} = get_stretch($xml{name}) or return;
    $xml{format} = 'type1';
    return \%xml;
}

sub get_weight
{
    my $w = shift;
    return 200 unless $w;
    return 400 if $w =~ /regular/i;
    return 400 if $w =~ /normal/i;
    return 400 if $w =~ /roman/i;
    return 900 if $w =~ /black/i;
    return 300 if $w =~ /book/i;
    return 600 if $w =~ /demibold/i;
    return 600 if $w =~ /demi/i;
    return 800 if $w =~ /extrabold/i;
    return 950 if $w =~ /ultrabold/i;
    return 700 if $w =~ /bold/i;
    return 950 if $w =~ /heavy/i;
    return 500 if $w =~ /medium/i;
    return 100 if $w =~ /ultralight/i;
    return 100 if $w =~ /extralight/i;
    return 200 if $w =~ /light/i;
    warn " ** unknown weight '$w'\n";
    return 200;
}

sub get_style
{
    my $fn = shift;
    return 'normal' unless $fn;
    return 'italic' if $fn =~ /italic/i;
    return 'oblique' if $fn =~ /oblique/i;
    return 'outline' if $fn =~ /outline/i;
    return 'script' if $fn =~ /script/i;
    return 'normal';
}

sub get_stretch
{
    my $fn = shift;
    unless ($fn) { warn " ** no fullname\n"; return 'normal' }
    return 'extra-condensed' if $fn =~ /extracondensed/i;
    return 'condensed' if $fn =~ /condensed/i;
    return 'extended' if $fn =~ /extended/i;
    return 'expanded' if $fn =~ /expanded/i;
    return 'ultra-compressed' if $fn =~ /ultracompress/i;
    return 'compressed' if $fn =~ /compress/i;
    return 'normal';
}