#!/usr/bin/perl
#{([

use strict;
use Font::TTF::Font;
use Pod::Usage;
use Getopt::Long;
use IO::String;

our $VERSION = 0.05;	# BH      2011-08-18
#   Refine parameter handling to make it more flexible
# $VERSION = 0.04;		# BH      2011-05-25
#   Permit export and update to use the magic words like "graphite"
# $VERSION = 0.03;		# BH      2009-02-02
#   Added -update option (to force update of one or more tables)
#       Had to change inport code to use memory files so update could work)
# $VERSION = 0.02;		# BH      2008-06-27     
#       Added -list option (outputs a list of tables from input font).
# $VERSION = 0.01;		# BH      2007-11-04     First release


# Regarding $CHAIN_CALL
#
# I've got some code to handle chaining, but it won't work yet so don't try it. Several things need to be fixed:
# - When processing an export, the incoming font must first be updated. Then realize that the the desired 
#   table may have been modified by previous program in the chain, which means the ' dat' isn't valid. 
#   To obtain a valid ' dat', the table's out() function  must be called (perhaps using IO::String). 
# - When processing an import, need to figure out a way that programs subsequent to us use the
#   replaced ' dat' value rather than read from the font. Perhaps we go ahead and read() the table using
#   IO::String

our $CHAIN_CALL;

our (@exports, @imports, @deletes, @updates, $textmode, $list, $verbose);

my $f;

unless ($CHAIN_CALL)
{
    my $help;
    
    GetOptions (
        'export|xport=s' =>  \@exports,
        'import=s' =>  \@imports,
        'delete|remove=s' => \@deletes,
        'update=s' =>   \@updates,
        'text'  =>      \$textmode,
        'list'  =>      \$list,
        'verbose'  =>   \$verbose,
        'help|?'   =>   \$help) or pod2usage(2);
        
    pod2usage( -verbose => 2, -noperldoc => 1) if $help;

    pod2usage(-msg => "missing infile.ttf parameter\n", -verbose => 1) unless defined $ARGV[0];

    $f = Font::TTF::Font->open($ARGV[0]) || die "Can't read font '$ARGV[0]'";

}

# Expand magic words
foreach my $tag (\@deletes, \@updates, \@exports, \@imports)
{
    my @newtag = ();
    foreach (@{$tag})
    {
        if (m/=/)
        {
            # if any filename included (i.e there is an '=') then split only on semicolon or pipe,
            # allowing filename to include space and comma.
            push @newtag, split(/[;|]+/);
        }
        elsif (m/^all$/oi)
        {
        	push @newtag, map {s/ //og; $_} sort grep {length($_) == 4} keys %{$f};
        }
        else
        {
            # Otherwise split more generously (spaces, comma, colon, semicolon, pipe) and 
            # also expand magic words.
            s/\bgraphite\b/ Silf Feat Gloc Glat Sill Sile /oi; 
            s/\bvolt\b/ TSIV TSID TSIP TSIS /oi;
            s/\bopentype\b/ GDEF GSUB GPOS /oi;
            push @newtag, grep {$_} split(/[\s,:;|]+/);
        }
    }
    @{$tag} = (@newtag);
}

# First, print list of tables if desired

if ($list)
{
    foreach (sort grep {length($_) == 4} keys %{$f})
    {
    	if ($verbose)
    	{
    		printf "%4s  csum = %08X  off = %7d  len = %6d", $_, $f->{$_}{' CSUM'}, $f->{$_}{' OFFSET'}, $f->{$_}{' LENGTH'};
    		printf "  zlen = %6d", $f->{$_}{' ZLENGTH'} if defined($f->{$_}{' ZLENGTH'}) and $f->{$_}{' ZLENGTH'} != $f->{$_}{' LENGTH'};
    		print "\n";
    	}
    	else
    	{
    		print "$_\n";
    	}
    }
}

# Next, read data to be imported and save it for later

my %importeddata;

for (@imports)
{
    # Parse the tag=fname value, making up a suitable name if needed.
    
    my ($tag, $fname) = m/^([^=]{1,4})(?:=(.*))?$/o;
    unless (defined ($tag))
    {
        warn "Do not understand \"-import $_\" -- ignoring\n";
        next;
    }
    unless ($fname)
    {
    	$fname = $tag;
    	$fname =~ s/[^a-zA-Z0-9]/_/og;	# In particular this maps OS/2 to OS_2
    	$fname = "$ARGV[0].$fname.dat";
    }
    $fname =~ s/[*?"<>|]//oig;      # "Characters disallowed in filenames
    
    # Pad and trim table tag
    $tag = sprintf('%-4.4s', $tag);
    
    # Slurp in and save the data to go into the font table:
    open (IN, $fname) or die "Cannot open file '$fname' for reading. ";
    local $/ = undef;       # slurp mode for read:
    binmode IN unless $textmode;
    $importeddata{$tag} = <IN>;
    close IN;
}    

# Now that we've read all the input files (which may also be output files!), we can do the export:

for (@exports)
{
    # Parse the tag=fname value, making up a suitable name if needed.
    
    my ($tag, $fname) = m/^([^=]{1,4})(?:=(.*))?$/o;
    unless (defined ($tag))
    {
        warn "Do not understand \"-export $_\" -- ignoring\n";
        next;
    }

    unless ($fname)
    {
    	$fname = $tag;
    	$fname =~ s/[^a-zA-Z0-9]/_/og;	# In particular this maps OS/2 to OS_2
    	$fname = "$ARGV[0].$fname.dat";
    }
    $fname =~ s/[*?"<>|]//oig;      # "Characters disallowed in filenames
    
    # Pad and trim table tag
    $tag = sprintf('%-4.4s', $tag);

    # Check that the table exists
    unless (defined $f->{$tag})
    {
        warn "Tag $tag not defined in input font -- export request ignored\n";
        next;
    }

    # Get the data directly

    # OK, I don't use read_dat() because tables like head and maxp have already
    # been read and thus read_dat() will noop. 
    # If we ever implement CHAIN_CALL this has got to be fixed up, but for 
    # now we can hack it:

    my $dat;
    $f->{$tag}{' INFILE'}->seek($f->{$tag}{' OFFSET'}, 0);
    $f->{$tag}{' INFILE'}->read($dat, $f->{$tag}{' LENGTH'});

    # Export the table
    open(OUT, ">" . $fname) or die "Couldn't open '$fname' for writing. ";
    if ($textmode)
    {
        # Seems there ought to be a better way to do this, but I have no idea
        # what the font table uses for line ending conventions, so i brute force
        # convert anything to \n then let iolayers fix it up
        $dat =~ s/\r\n|\n\r|[\r\n]/\n/g;
    }
    else
    {
        binmode(OUT);
    }
    print OUT $dat;
    close OUT;
}


# Remove tables the user doesn't want:

for (@deletes)
{
    # Pad and trim table tag
    my $tag = sprintf('%-4.4s', $_);
    delete $f->{$tag} if defined $f->{$tag};
}

# Complete import of tables

for my $tag (keys %importeddata)
{
    # Create, if it doesn't exist, the tables we are going to replace
    $f->{$tag} = Font::TTF::Table->new (PARENT => $f, NAME => $tag); # unless exists $f->{$tag};
    
    # Use in-memory file
    my $fh = IO::String->new($importeddata{$tag}) ;
    unless ($fh)
    {
        warn "Couldn't open memory file for $tag ";
        next;
    }
    binmode $fh;
    $f->{$tag}{' INFILE'} = $fh;
    $f->{$tag}{' OFFSET'} = 0;
    $f->{$tag}{' LENGTH'} = bytes::length($importeddata{$tag});
    
    # Now we can set the data
    # $f->{$tag}{' dat'} = $importeddata{$tag};
    # $f->{$tag}{' read'} = 0;    # Make sure ' dat' is written to file. (Fix this up for CHAIN_CALL)
}

# Finally rebuild any tables in the update list

my $needupdate;
for (@updates)
{
    # Pad and trim table tag
    my $tag = sprintf('%-4.4s', $_);
    unless (defined $f->{$tag})
    {
    	warn ("No '$tag' table found -- cannot update\n");
    }
    else
    {
	    if ($tag eq 'loca' or $tag eq 'glyf')
	    {
	    	# loca and glyf tables are interrelated. To update either, we must
	    	# update both. But we only need to do this once.
	    	
	    	# make sure the other table is present:
	    	my $othertag = $tag eq 'loca' ? 'glyf' : 'loca';
	    	unless (defined $f->{$othertag})
	    	{
	    		warn ("No '$othertag' table found -- cannot update '$tag'\n");
	    	}
	    	elsif (!$f->{'loca'}->dirty)	# checks and sets dirty -- we only do this block one time
	    	{
	    		$f->{'glyf'}->read;  # forces reading of loca as well.
	    	
		        # read_dat every glyph
		        $f->{'loca'}->read->glyphs_do ( 
				    sub {
				        my ($g, $gid) = @_;
				        $g->read_dat;
				    }
				);
				# Now dirty 'head' to fix all the bounding boxes
				$f->{'head'}->dirty;
				
				$needupdate=1;
		    }
	    }
	    else
	    {
	    	# other tables are simpler:
	   	    $f->{$tag}->read->dirty(1);
			$needupdate=1;
	   	}

	}
}
$f->update if $needupdate;

unless ($CHAIN_CALL)
{ 
    $f->out($ARGV[1]) || die "Can't write to font file '$ARGV[1]'. Do you have it installed?" if defined $ARGV[1]; 
}


#])}

__END__

=head1 TITLE

ttftable - import, export, or delete TrueType font tables

=head1 SYNOPSIS

ttftable [options] infile.ttf [outfile.ttf]

Opens infile.ttf for reading, optionally imports, exports, and/or deletes tables from the font, 
then writes the modified font to outfile.ttf if provided.

=head1 OPTIONS

  -export tag[,tag...] List of tables to export to default datafiles
  -export "tag=fname"  Name of table to export to named datafile
  -import tag[,tag...] List of tables to import from default datafiles
  -import "tag=fname"  Name of table to import from named datafile
  -delete tag[,tag...] List of tables to remove from font
  -update tag[,tag...] Force a re-build of the named tables 
  -list                Write a list of table tags from infile.ttf to STDOUT
  -verbose             Verbose output
  -text                Use text mode i/o for datafiles
  -xport               alias for -export (thus permitting -x) 
  -help                Help

Option names may be abbreviated as much as you like; -export, -import, -delete and -update options may be repeated.
    
=head1 DESCRIPTION

After opening font file infile.ttf, ttftable can export one or more of the 
truetype tables to separate files, import one or more font tables from 
separate files, and/or delete specified tables from the font. 

Changes are written to outfile.ttf if supplied.

Tables are identified by their four-character tag. The following (case 
insensitive) pseudo tags can also be used:

  graphite  all SIL Graphite tables (Silf Feat Gloc Glat Sill Sile)
  volt      all Microsoft VOLT tables (TSIV TSID TSIP TSIS)
  opentype  all OpenType tables (GDEF GSUB GPOS)
  all       all tables in the font (use with caution!)

The parameter to -export and -import is a table tag optionally followed by
equals sign and a filename. If the filename is not provided, ttftable
makes up a file name by appending ".I<tagname>.dat" to the input
font file name. CAUTION: Windows users should
include quotes around parameters of the form tag=fname.

-update is a debugging tool that forces the named tables to be read in detail, then
"dirties" them, and finally updates the font. This should bring the font into consistent 
state if it wasn't before. Note that, due to their interrelated nature, updating either 
the 'loca' or the 'glyf' table updates both and will cause every 
glyph to be read and parsed and then reconstructed, taking significantly more time.

Font tables such as TSIV that contain text use various conventions for line ending. 
During -export, the -text option will convert any line-endings in the font data to what is needed by 
your platform. During -import, the -text option simply converts your platform line endings
to newline (\n) character, which may not be what you want, so use with caution.

Arrangements of command line options that import and export the same
table and/or the same data file will "do the right thing" except that
external files can contain only one table.

=head1 EXAMPLES

  # list of tables in a font
  ttftable -l myfont.ttf
  
  # list of tables and their details such as offset, size, checksum
  ttftable -l -v myfont.ttf
  
  # extract VOLT source from a font:
  ttftable -e "TSIV=myfont.vtp" -t myfont.ttf
  
  # extract all tables into separate binary files
  ttftable -e all myfont.ttf
  
  # Create a new font by deleting all OpenType tables
  ttftable -d opentype myfont.ttf newfont.ttf
   

=head1 BUGS

Deleting Graphite or OpenType tables does not remove name table strings that are used for feature
names and values. 

The pseudo tags C<graphite>, C<volt>, C<opentype> and C<all> cannot be used in conjunction
with the C<=fname> capability.

=cut