#!/usr/bin/perl
use strict;
use Font::Fret;
use Font::TTF::Useall;

fret('Attach', @ARGV);

package Attach;

use XML::Parser::Expat;
use Getopt::Std;
use Pod::Usage;

our (@ISA, $VERSION);

BEGIN {
    @ISA = qw(Font::Fret::Default);
    $VERSION = "1.000";
      }

my ($opts, $apRE);

my ($gid, @xml_dat, $fontname, $fontupem, @rev, @macrev, $usort, $psort);

sub make_cids
{
    my ($class, $font) = @_;
    my (@map, @res, $m, $pname);
    my ($c) = $font->{'cmap'}->read->find_ms;

    if ($opts->{'a'} || defined $ARGV[2])
    {
        my ($xml) = XML::Parser::Expat->new();
        $xml->setHandlers('Start' => sub {
            my ($xml, $tag, %attrs) = @_;

            if ($tag eq 'glyph')
            {
                $gid = $attrs{'GID'} || $c->{'val'}{hex($attrs{'UID'})}
                    || $font->{'post'}{'STRINGS'}{$attrs{'PSName'}};
                if ($gid == 0 && ($attrs{'PSName'} || $attrs{'UID'}))
                { return $xml->xpcarp("No glyph called: $attrs{'PSName'}, Unicode: $attrs{'UID'}"); }
                $xml_dat[$gid]{'ps'} = $attrs{'PSName'};
                $xml_dat[$gid]{'UID'} = $attrs{'UID'};
            } elsif ($tag eq 'point')
            {
                $pname = $attrs{'type'} =~ /$apRE/oi ? $attrs{'type'} : undef;;
            } elsif ($tag eq 'contour')
            {
                $xml_dat[$gid]{'points'}{$pname}{'cont'} = $attrs{'num'} if $pname;
            } elsif ($tag eq 'location')
            {
                $xml_dat[$gid]{'points'}{$pname}{'loc'} = [$attrs{'x'}, $attrs{'y'}] if $pname;
            } elsif ($tag eq 'font')
            {
                $fontname = $attrs{'name'};
                $fontupem = $attrs{'upem'};
            } elsif ($tag eq 'compound')
            {
                push (@{$xml_dat[$gid]{'compounds'}}, {%attrs});
            } elsif ($tag eq 'break')
            {
                $xml_dat[$gid]{'break'} = $attrs{'weight'};
            }
        });

        $xml->parsefile($opts->{'a'} || $ARGV[2]) || die "Can't parse " . ($opts->{'a'} || $ARGV[2]);
    }

    @rev = $font->{'cmap'}->read->reverse('array' => 1);
    @map = $font->{'cmap'}->read->reverse;
    $map[$font->{'maxp'}{'numGlyphs'}] = 0;
    foreach $m (@map) { $m = 65536 if $m == 0; }
    @res = (sort {($usort && $map[$a] <=> $map[$b]) || ($psort && $font->{'post'}{'VAL'}[$a] cmp $font->{'post'}{'VAL'}[$b]) || $a <=> $b}
            (0 .. $font->{'maxp'}{'numGlyphs'} - 1));

    return ("Glyph ID", @res);
}

sub boxhdr
{
    return ("Advance", "PSName", "GID", "Unicode");
}

sub lowdat
{
    my ($class, $cid, $gid, $glyph, $uid, $font) = @_;

    return ($font->{'hmtx'}{'advance'}[$gid], "r|$font->{'post'}{'VAL'}[$gid]");
}

sub topdat
{
    my ($class, $cid, $gid, $glyph, $uid, $font) = @_;

    return ($gid, "r,r|" . join(',', map {sprintf("|U+%04X", $_)} sort {$a <=> $b} (defined $rev[$gid] ? @{$rev[$gid]} : ())));
}

sub row1hdr
{
    my ($class, $font) = @_;
    my ($i);

    for ($i = 0; $i < $font->{'cmap'}{'Num'}; $i++)
    {
        if ($font->{'cmap'}{'Tables'}[$i]{'Platform'} == 1)
        { @macrev = $font->{'cmap'}->reverse('tnum' => $i); last; }
    }

    return ('PSName', 'GID', 'UID', 'Macid',
            'r,b|adv', 'r,i|xmax', 'r,i|xmin', 'r,i|ymax', 'r,i|ymin');
}

sub row1
{
    my ($class, $cid, $gid, $glyph, $uid, $font) = @_;
    my ($aw) = $font->{'hmtx'}{'advance'}[$gid];
    my ($rsb) = $aw - $glyph->{'xMax'};

    return ($font->{'post'}{'VAL'}[$gid], $gid, 
            join(',', map {sprintf("|U+%04X", $_)} sort {$a <=> $b} (defined $rev[$gid] ? @{$rev[$gid]} : ())), $macrev[$gid],
            "r,b|$aw", "r,i|$glyph->{'xMax'}",
            "r,i|$glyph->{'xMin'}", "r,i|$glyph->{'yMax'}",
            "r,i|$glyph->{'yMin'}");
}

sub row2hdr
{
    my ($class, $font) = @_;

    return ("Attach1", "Attach2", "Attach3", "Attach4");
}

sub row2
{
    my ($class, $cid, $gid, $glyph, $uid, $font) = @_;
    my ($ptext);
    my ($p, $pc, @res);

    if (!defined $xml_dat[$gid]{'points'})
    { return (@res); }
    
    $glyph->get_points if defined $glyph;
    foreach $p (sort keys %{$xml_dat[$gid]{'points'}})
    {
    	my $res;
        $pc = $xml_dat[$gid]{'points'}{$p};
        if (exists $pc->{'cont'})
        {
	        my $pnum = $glyph->{'endPoints'}[$pc->{'cont'}];
	        $res = "$p($pc->{'cont'}:";
#	        $res = "$p($pc->{'cont'},$pnum)($pc->{'loc'}[0],$pc->{'loc'}[1])";
	        $res .= "$glyph->{'x'}[$pnum],$glyph->{'y'}[$pnum])";
#	        $res = "$p($pc->{'cont'},$pnum)";
		}
		elsif (exists $pc->{'loc'})
		{
			$res = "$p($pc->{'loc'}[0],$pc->{'loc'}[1])";
		}
        push (@res, $res);
    }
    return (@res);
}

sub process_argv
{
	my ($self);
	($self, $opts) = @_;
	getopts("a:d:fgh:i:m:o:p:qrs:?", $opts);
	
	if ($opts->{'?'})
    {
        pod2usage( -verbose => 2, -noperldoc => 1);
    }
    unless ($ARGV[0])
    {
		pod2usage (1);
	}
	if ($opts->{'i'})
	{
		$apRE = qr/$opts->{'i'}/;
	}
	$opts->{'o'} ||= 'up';
	$usort = 1 if $opts->{'o'} =~ /u/;  # enable Unicode sort
	$psort = 1 if $opts->{'o'} =~ /p/;  # enable Postname sort
			# gid sort is always last resort
}

sub extra_points
{
    my ($class, $font, $gid, $glyph) = @_;
    my (@res);

    while (my ($k, $p) = each %{$xml_dat[$gid]{'points'}})
    {
        next unless (defined $p->{'loc'});
        push (@res, [$p->{'loc'}[0], $p->{'loc'}[1], $k]);
    }
    return [@res];
}
	
__END__

=head1 TITLE

fret - Font REporting Tool

=head1 SYNOPSIS

  fret [-p package] [-a ap.xml] [-f] [-g] [-i re] [-r] [-s size] [-q] font_file [out_file]
Generates a report on a font according to a particular package. In some
contexts the package may be over-ridden. Paper size may also be specified.

=head1 OPTIONS

If no out_file is given then out_file becomes font_file.pdf (removing .ttf
if present)

  -a ap.xml     Attachment point database file
  -f            Don't try to save memory on large fonts (>1000 glyphs)
  -g            Add one glyph per page report following summary report
  -h            Mode for glyph per page output. Bitfield:
                1 = bit 0       don't output curve point positions
                2 = bit 0       don't output attachment point positions
  -i re         Regular expression that identifies what attachment points
                to include in the report
  -m points     Sets glyph size in the box regardless of what is calculated
                Regardless of the consequences for clashes
  -o sort       Define sort order. Can be combinations of u (Unicode),
                p (postname), or i (glyph index). When supplied, priority
                is u, then p, then i. Default upi.
  -p package    Perl package specification to use for report information
                (must be first option)
  -q            quiet mode
  -r            Don't output report lines, fill the page with glyph boxes
  -s size       paper size: a4, ltr, legal
  -?            longer help

=head1 DESCRIPTION

FRET creates a PDF report from a TrueType font containing information about
every glyph in the font. It sorts the glyphs by Unicode identifier and then
for those glyphs with no Unicode identifier it sorts them by glyph name and
then by glyph number.

In addition it is possible to get a report including a page per glyph with
a large outline of each glyph perhaps with the drawn points.

If the optional ap.xml file is specified on the command line then attachment
point information is included in the report. See ttfbuilder for details of
the ap.xml file format. Only attachment points that match the regular
expression supplied via the -i option will be included.

If supplied, -p must be the first option.

=head1 SEE ALSO

ttfbuilder

=cut