view release on metacpan or  search on metacpan

scripts/ttftable  view on Meta::CPAN

# $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, @scripts, $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,
        'script=s' => \@scripts,
        '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;
            s/\baat\b/ mort morx feat /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->{$_}{' ORIGINALOFFSET'} || $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>;