#!/usr/bin/perl

use XML::Parser;
use Pod::Usage;
use Getopt::Std;
use Font::TTF::PSNames;

getopts('c:hp');

unless ($ARGV[0] || $opt_h)
{
    pod2usage(1);
    exit;
}

if ($opt_h)
{
    pod2usage(-verbose => 2, -noperldoc => 1);
    exit;
}

my ($indent, $currclass, $text, %classes, %properties, $isempty);
my ($classlist, $propdict);

my ($xml) = XML::Parser->new(Handlers => {
    Start => sub {
        my ($xp, $tag, %attrs) = @_;

        if ($tag eq 'class')
        {
            $currclass = [$attrs{'exts'}];
            $classes{$attrs{'name'}} = $currclass;
        }
        elsif ($tag eq 'property')
        {
            $currclass = [$attrs{'value'}, $attrs{'exts'}];
            $pname = $attrs{'name'};
            push (@{$properties{$pname}}, $currclass);
        }
        $text = '';
    },
    End => sub {
        my ($xp, $tag) = @_;

        if ($tag eq 'class')
        { push (@{$currclass}, [split(' ', $text)]); }
        elsif ($tag eq 'property')
        {
            push (@{$currclass}, [split(' ', $text)]);
            if ($opt_p)
            { $classes{"${pname}_$currclass->[0]"} = [split(' ', $text)]; }
        }
    },
    Char => sub {
        my ($xp, $str) = @_;
        $text .= $str;
    }});

$xml->parsefile($opt_c);
$text = '';

my ($xml) = XML::Parser->new(Handlers => {
    Init => sub {
        print "<?xml version='1.0' encoding='UTF-8'?>\n";
    },
    Start => sub {
        my ($xp, $tag, %attrs) = @_;
        $isempty = dotext($text, $isempty);
        print ">" if ($isempty);
        start($xp, \$tag, \%attrs);
        print "\n" . (" " x $indent) . "<$tag";
        foreach $k (sort keys %attrs)
        { print " $k='$attrs{$k}'"; }
        $isempty = 1;
        $indent += 4;
        $text = '';
    },
    End => sub {
        my ($xp, $tag) = @_;
        $isempty = dotext($text, $isempty);
        $isempty = end($xp, \$tag, $isempty);
        $indent -= 4;
        if ($isempty)
        {
            print "/>";
            $isempty = 0;
        }
        else
        { print "\n" . (" " x $indent) . "</$tag>"; }
        $text = '';
    },
    Char => sub {
        my ($xp, $str) = @_;
        $text .= $str;
    }});

if ($ARGV[1])
{
    open(OFH, "> $ARGV[1]") || die "Can't open $ARGV[1] for writing";
    select OFH;
}    
$xml->parsefile($ARGV[0]);

sub dotext
{
    my ($str, $isempty) = @_;
    $str =~ s/^\s+//o;
    $str =~ s/\s+$//o;
    if ($str)
    {
        print ">" if ($isempty);
        print $str;
        $isempty = 0;
    }
    return $isempty;
}


sub start
{
    my ($xp, $tagr, $attrs) = @_;

    if ($$tagr eq 'glyph')
    {
        $classlist = get_classes(\%classes, $attrs->{'PSName'}, $attrs->{'UID'});
        $propdict = get_properties(\%properties, $attrs->{'PSName'}, $attrs->{'UID'});
    }
    elsif ($$tagr eq 'property' && $attrs->{'name'} eq 'classes')
    {
        my ($val) = merge_classes($classlist, $attrs->{'value'});
        $attrs->{'value'} = $val;
        $classlist = undef;
    }
    elsif ($$tagr eq 'property' && defined $propdict->{$attrs->{'name'}})
    { $attrs->{'value'} = delete $propdict->{$attrs->{'name'}}; }
}

sub end
{
    my ($xp, $tagr, $isempty) = @_;
    my ($p);

    if ($$tagr eq 'glyph')
    {
        print ">" if ($isempty);
        if ($classlist)
        { print "\n" . (" " x $indent) . "<property name='classes' value='$classlist'/>"; }
        foreach $p (sort keys %{$propdict})
        { print "\n" . (" " x $indent) . "<property name='$p' value='$propdict->{$p}'/>"; }
        return 0;
    }
    return $isempty;
}

sub get_classes
{
    my ($classes, $psname, $uid) = @_;
    my ($c, $res);

    foreach $c (keys %$classes)
    {
        my ($g, $e);
        foreach $e (split(' ', $classes->{$c}[0]), '')
        {
            foreach $g (@{$classes->{$c}[1]})
            {
                if (match_glyph("$g$e", $psname, $uid))
                {
                    $res .= "$c ";
                    last;
                }
            }
        }
    }
    $res =~ s/\s+$//o;
    return $res;
}

sub merge_classes
{
    my ($list, $base) = @_;
    my (%list) = map {$_ => 1} split(' ', $list);
    my (%base) = map {$_ => 1} split(' ', $base);
    my (%res) = (%base, %list);
    my ($res) = join(" ", sort keys %res);
    return $res;
}

sub get_properties
{
    my ($properties, $psname, $uid) = @_;
    my ($res, $p, $q, $g, $e);

    foreach $p (keys %{$properties})
    {
        foreach $q (@{$properties->{$p}})
        {
            foreach $e (split(' ', $q->[1]), '')
            {
                foreach $g (@{$q->[2]})
                {
                    if (match_glyph("$g$e", $psname, $uid))
                    { $res->{$p} = $q->[0]; }
                }
            }
        }
    }
    return $res;
}

# %name_cache to cache results of slow Font::TTF::PSName::parse(). Significant speed up.
%name_cache = ();
sub match_glyph
{
    my ($name, $psname, $uid) = @_;
    my ($cname, $cpsname);

    return 1 if ($psname eq $name);

    $name_cache{$name} = canon($name) if (!defined $name_cache{$name});
    $cname = $name_cache{$name};

    return 1 if ($cname eq $uid);

    $name_cache{$psname} = canon($psname) if (!defined $name_cache{$psname});
    $cpsname = $name_cache{$psname};

    return 1 if ($cname eq $cpsname);
}

sub canon
{
    my ($name) = @_;

    my ($uids, $exts) = Font::TTF::PSNames::parse($name);
    return $name unless scalar(@{$uids});
    my ($res) = join("_", map {sprintf("%04X", $_)} @{$uids});
    $res .= "." . join(".", @$exts) if (scalar @$exts);
    $res;
}

__END__

=head1 TITLE

add_classes - add class information to an attachment point database

=head1 SYNOPSIS

  add_classes -c classes.xml infile.xml

For each glyph in the infile.xml attachment point database, find all the
classes in classes.xml containing names that match the glyph. Ensure that
the classes property contains a list of those classes that match. Print
the results to stdout.

=head1 OPTIONS

  -c classes.xml    List of classes and their contents
  -h                print manpage
  -p                Create classes for each property value
                    called property_value

=head1 DESCRIPTION

Inserting a classes property in an attachment point database allows one to
create context classes in the generated GDL or VOLT.

The DTD for the classes file is:

    <!ELEMENT classes (class, property)*>

    <!ELEMENT class (#PCDATA)>
    <!ATTLIST class
        name    CDATA #REQUIRED
        exts    CDATA #IMPLIED>

    <!ELEMENT property (#PCDATA)>
    <!ATTLIST property
        name    CDATA #REQUIRED
        value   CDATA #REQUIRED
        exts    CDATA #IMPLIED>

=head1 SEE ALSO