#!/usr/bin/perl
#{([
use strict;
use File::Basename;
use Getopt::Std;
use Data::Dumper;
use Font::TTF::Font;
use Font::TTF::OTTags qw( %ttnames readtagsfile);
our ($opt_a, $opt_d, $opt_g, $opt_l, $opt_r, $opt_s, $opt_t, $opt_v, $VERSION);
$VERSION = '0.53';
my $progname = basename ($0);
$progname =~ s/\.[^.]+$//;
getopts('ad:g:l:rst:v:');
die <<"EOT" unless $#ARGV >= 0 and $#ARGV <= 1;;
$progname -- create VOLT project from existing OpenType font file
syntax: $progname [options] infontfile [outfontfile]
Attempts to create a VOLT project from an existing OpenType font by reading and
interpreting the existing GDEF, GPOS, and GSUB tables. Not every OpenType
rule can be mimiced in VOLT; warnings are issued when $progname cannot
handle something.
In normal usage, specify either outfontfile (to create a font
ready to be opened by VOLT) and/or the -v option (to create a
VOLT project source that can be imported into the font).
options:
-a allow non-adobe glyph names
-g n group creation threshold
-l file emit log messages to named file
-r retain GPOS, GSUB, and GDEF tables in output font
-s do not send warnings to stdout (will still go to log)
-t file name of replacement VOLT tags file if needed.
-v file Volt project source (.vtp) file to create
The group creation threshold option sets the minimum number of glyphs
that $progname will put into a group for the purposes of building
a lookup.
Lookups currently supported (type[.format]):
GSUB: 1 2 3 4 6.3
GPOS 1 2 3 4 5 8.3
Version $VERSION
EOT
my $font; # Font structure
my ($cmap, $post, $gsub, $gpos, $gdef); # Various tables in font
my $g; # Glyph structure
# MAJOR TO-DO: Someday this should all be rewritten to generate the internal datastructure used by Volt.pm. Then this
# would become a library module and command-line option for make_volt. Some day.
# Glyph data are stored in structures (anonymous hashes) containing the following elements (all optional):
# ID glyph ID
# NAME glyph name, derived from postname
# @UNICODES an array of Unicode values
# COMPONENTS a count of ligature components
# TYPE one of BASE, MARK, LIGATURE, COMPONENT (from GDEF if present)
# ANCHORS a hash of attachment points, indexed by attachment point name, value is a pointer to an Font::TTF::Anchor
# Gyph structures can be located from glyph ID, PS name or, for encoded glyphs, USV:
my (%GlyphFromID, %GlyphFromName, %GlyphFromCmapUnicode);
my ($gid, $gname, $u); # Glyph ID, Glyph name, and Unicode
my ($SLFText, $LookupText); # generated VOLT source texts: Script/Lang/Feature, Lookups
my ($warningCount, $genericCount);
# Open log file
open(LOG, ">$opt_l") if $opt_l;
# Sub to print warning messages to console and log. 1st parm is the message.
# 2nd param, if supplied, is a line number.
sub MyWarn {
my ($msg, $line) = @_;
$warningCount++;
if (defined $line) {
print LOG "line $line: " . $msg;
warn "line $line: " . $msg unless $opt_s;
} else {
print LOG $msg;
warn $msg unless $opt_s;
}
}
##########################
# Open the font and verify presence of needed tables
$font = Font::TTF::Font->open($ARGV[0]) or die "Could not open font '$ARGV[0]'\n";
exists $font->{'post'} or die "Could not locate Postscript name info in font '$ARGV[0]\n" ;
$post = $font->{'post'}->read;
$cmap = $font->{'cmap'}->find_ms or die("Unable to locate Windows cmap in font '$ARGV[0]'\n");
$gdef = $font->{'GDEF'}->read if exists $font->{'GDEF'};
$gsub = $font->{'GSUB'}->read if exists $font->{'GSUB'};
$gpos = $font->{'GPOS'}->read if exists $font->{'GPOS'};
die "None of GDEF, GSUB, GPOS tables found in font '$ARGV[0]' \n -- you probably don't need to use $progname\n" unless $gdef || $gsub || $gpos;
# $font->out_xml($opt_d, 'GSUB') if defined $opt_d;
if ($opt_d)
{
open (DUMP, ">$opt_d") or die "Couldn't open '$opt_d' for writing.";
my $res;
if (0)
{
# I wish this could work! But sometimes Perl abends
my $d = Data::Dumper->new([$gsub, $gpos, $gdef], [ qw(gsub gpos gdef)]);
sub myfilter
{
my ($hash) = @_;
my @a = grep {$_ ne ' PARENT'} (keys %{$hash}) ;
return [ @a ];
}
$d->Sortkeys(\&myfilter);
$d->Indent(3); # I want array indicies
$res = $d->Dump;
$d->DESTROY;
}
else
{
$Data::Dumper::Indent = 3;
$res = Dumper($font);
}
$res =~ s/ / /g;
print DUMP $res;
close DUMP;
}
##########################
# Build Glyph structure based on postscript names and cmap values.
# Note: This algorithm has to match that in VoltFixup.pl if the source
# generated by this program is going to be spliced into a modified font.
# In fact, this code is adapted from VoltFixup.pl!
# loop through all glyphs, setting up glyph structure.
GLYPH: for $gid (0 .. $font->{'maxp'}{'numGlyphs'}-1)
{
$gname = $post->{'VAL'}[$gid];
# $gname = "glyph$gid" unless defined $gname;
($gname eq '.notdef') && do {
# no PS name
next GLYPH;
};
($gname !~ /^[a-zA-Z][a-zA-Z0-9_.]*$/) && do {
MyWarn "Glyph $gid has non-standard psname '$gname'\n";
next GLYPH unless $opt_a;
};
# Only letters, digits, '.' and '_' are allowed in VOLT names
$gname =~ s/[^\w.]/_/og;
(exists $GlyphFromName{$gname}) && do {
MyWarn "Glyph name '$gname' is used more than once in font (e.g., glyphs $GlyphFromName{$gname}{'ID'} and $gid) -- second ignored\n";
next GLYPH;
};
# Ah, here is a name worth keeping!
$g = $GlyphFromID{$gid} = $GlyphFromName{$gname} = { ID => $gid, NAME => $gname};
if (defined $gdef)
{
# Look up type in GDEF table
my $type = $gdef->{'GLYPH'}{'val'}{$gid};
$g->{'TYPE'} = (qw(BASE LIGATURE MARK COMPONENT))[$type-1] if $type > 0;
}
}
#Initialize groups from gdef marks classes...
InitGroups();
# Some things not yet handled from GDEF:
if (defined $gdef)
{
foreach (qw (ATTACH LIG))
{
MyWarn "GDEF $_ information not implemented\n" if exists $gdef->{$_} && $gdef->{$_}{'COVERAGE'}{'count'} > 0;
}
}
# loop through the MS cmap and adding in Unicode info to %Glyph
CMAP: while (($u, $gid) = each %{$cmap->{'val'}})
{
if (exists $GlyphFromCmapUnicode{$u}) {
MyWarn sprintf ("Corrupt cmap: Unicode value U+%04X occurs more than once\n", $u);
next CMAP;
}
if (exists $GlyphFromID{$gid}) {
# Glyph with this id already present:
$g = $GlyphFromID{$gid};
} else {
# Glyph with this id not yet present (must not have had a usable PS name), so create it:
$g = $GlyphFromID{$gid} = { ID => $gid};
}
$g->{'@UNICODES'} = [] if not exists $g->{'@UNICODES'}; # Create array to hold Unicode values
push @{$g->{'@UNICODES'}}, $u; # Add to array of Unicode values
$GlyphFromCmapUnicode{$u} = $g; # Be able to find glyph via cmap from Unicode
}
# Try to locate and read VOLT tags.txt file to find names for Scripts, Languages, and Features:
if (defined $opt_t)
{
MyWarn "Cannot open VOLT tags file '$opt_t'\n" unless readtagsfile($opt_t);
}
##########################
# InitGroups()
# CacheGroup()
# GetGroup()
# GetGroupNames()
#
# Routines to create and manage glyph groups from lists of GIDs.
# Groups are numbered from 0. Groups 0 through $maxMarkClass are actually the
# mark classes defined in GDEF and, therefore, are named "Class0", "Class1", etc.
# Beyond that, groups are created as needed for any specific list of GIDs.
# Such groups are named, simply, "Group3", "Group4", etc.
#
# InitGroups()
# Set first n groups based on GDEF MARKs class definition
#
# CacheGroup()
# Accept a list of GIDs
# Return the name of a group.
# If the group already exists, return its name. Else create the group
#
# GetGroup()
# Accept a group name
# Return a list of GIDs
#
# GetGroupNames()
# returns a list of the names of defined groups.
#
# Current implementation:
# Groups are maintained in an array. The name of the group is implied by its index, e.g. "Group001"
# Each array element is simply the GID's join'd together by ":"
#
my @Groups; # Array of groups. See CacheGroup()
my $maxMarkClass; # Highest Groups index that represents a MARK class
sub InitGroups()
{
# initialize groups list from GDEF class...
return unless defined $gdef && exists $gdef->{'MARKS'};
die "Unexpected call to InitGroups\n" if $#Groups != -1 || $maxMarkClass > 0;
my @classlist = ClassToLists ($gdef->{'MARKS'});
$maxMarkClass = $#classlist;
for my $class (0 .. $maxMarkClass)
{
$Groups[$class] = join (":", @{$classlist[$class]}) if defined $classlist[$class];
}
}
sub CacheGroup(@)
{
my ($i, $tmp);
$tmp = join (":", sort {$a <=> $b} @_);
for $i (0 .. $#Groups)
{
return GetGroupName($i) if $tmp eq $Groups[$i];
}
# Not in the cache, so add it:
push @Groups, $tmp;
return GetGroupName($#Groups);
}
sub GetGroup($)
{
my $i = shift;
$i =~ s/^\D*//; # strip leading non-digits
die "Invalid Group index $i." if $i < 0 or $i > $#Groups;
return (split(":", $Groups[$i]));
}
sub GetGroupNames()
{
return (map {GetGroupName($_) } (0 .. $#Groups));
}
sub GetGroupName($)
{
my $i = shift;
die "Invalid Group index $i." if $i < 0 or $i > $#Groups;
return $i <= $maxMarkClass ? "Class$i" : "Group$i";
}
##########################
# GetGroupRange()
#
# This is one of the more complicated subs. It is used to partition the rules for a given lookup
# into collections of rules that can be written with a group notation.
#
# Note: This routine is written using the notation of "lhs" and "rhs" as if the lookup were GPOS type 2. That
# is the lhs of each rule is a single glyph, the rhs is a sequence of glyphs. However, the routine is
# equally usable for type 4 lookups by reversing the sense of the parameters. From a notational standpoint
# it is easier just to think of lhs & rhs
#
# The input can be thought of as column of single GIDs, each element [or row] representing the lhs of a type 2
# lookup (or the rhs of a type 4 lookup), and a 2-D matrix of GIDs each row representing the rhs
# of type 2 lookup (or the lhs of a type 4 lookup). The first of these ($lhs) is passed as a
# reference to an array,the second ($rhs) as a reference to an array of references to arrays (an "LOL")
#
# The only other parameter is a starting row index ($start). The routine looks at the consecutive rows
# in the input data to determine how many can be collected together into one rule. One of the return
# parameters is the ending row of the collection, which can then be incremented and passed back in
# as the start value to look for another group.
#
# More specifically, the return value is a list containing:
#
# $last index of the last row of the data is part of the collection; may be same as $start
# $col column index in $rhs indicating which of the items in the sequences of the group varies
# (will be -1, if $end == $start)
# $lhsGroup name of a group representing the lhs glyphs, e.g., @{$lhs}[$start .. $last]; may be undef
# $rhsGroup name of a group representing the glyphs in $rhs column, i.e., @{$rhs}[$start .. $last][$col]; may be undef
sub GetGroupRange(\@\@$) # @lhs, @rhs, $start
{
my ($lhs, $rhs, $start) = @_;
my ($last, $col, $lhsGroup, $rhsGroup); # Return values
my ($lastcol, $i);
$lastcol = $#{$rhs->[$start]}; # last column index in sequence at row $start
ROWLOOP:
for ($last = $start + 1; $last <= $#{$lhs}; $last++) # For loop used so $last retains value on exit of loop
{
# Verify lhs GID is strictly ascending order (must be so for a valid group)
last if $lhs->[$last] <= $lhs->[$last-1];
# Verify that the length of this row's rhs sequence is the same as $start's:
last if $#{$rhs->[$last]} != $lastcol;
# Locate the varying column (there can be only one!)
for $i (0 .. $lastcol)
{
# If glyph is same as on $start row, then try next column
next if $rhs->[$start][$i] == $rhs->[$last][$i];
# If we already know the column, and this isn't it, then this
# row cannot be part of the collection. Also, if the GID isn't
# strictly ascending then this row cannot be part of the collection:
last ROWLOOP if ((defined $col) && ($i != $col)) || ($rhs->[$last][$i] <= $rhs->[$last-1][$i]);
# Remember the target column:
$col = $i if not defined $col;
}
}
if (!defined $col || ($last - $start + 1) < $opt_g)
{
# Cannot build a group:
$last = $start;
}
else
{
# At this point, $last is one greater than the last row that can be part
# of the group, so adjust it:
$last -=1;
}
if ($last > $start)
{
# Construct groups
$lhsGroup = CacheGroup (@{$lhs}[$start .. $last]);
$rhsGroup = CacheGroup (map { $rhs->[$_][$col]} ($start .. $last));
}
else
{
# Make sure $col won't match any column:
$col = -1;
}
# Done!
return ($last, $col, $lhsGroup, $rhsGroup);
}
##########################
# ClassToLists()
#
# Given a Class table, return an array (indexed by class value) of arrays of GIDS (in ascending order)
sub ClassToLists($) # reference to Font::TTF coverage table structure
{
my $c = shift;
# Make sure this is a class table and not a cover definition:
die "ClassToList() not given a class table." if $c->{'cover'} == 1;
my @res;
foreach my $gid (sort {$a <=> $b} keys %{$c->{'val'}})
{
my $classvalue = $c->{'val'}{$gid};
$res[$classvalue] = [] unless defined $res[$classvalue];
push @{$res[$classvalue]}, $gid;
}
return @res;
}
##########################
# CoverToList()
#
# Given a Coverage table, return an array of GIDS in correct order
sub CoverToList($) # reference to Font::TTF coverage table structure
{
my $c = shift;
# Make sure this is a coverage table and not a class definition:
die "CoverToList() not given a coverage table." if $c->{'cover'} != 1;
return (sort {$c->{'val'}{$a} <=> $c->{'val'}{$b}} keys %{$c->{'val'}});
}
##########################
# NameFromID()
#
# Routine to get glyph name from ID,
#
# if postscript name not defined in font, make one up but issue warning
sub NameFromID($) # GID
{
my $gid = shift;
if (!exists $GlyphFromID{$gid}->{'NAME'})
{
my $uname;
$uname = sprintf (" (U+%04X)", $GlyphFromID{$gid}->{'@UNICODES'}[0]) if exists $GlyphFromID{$gid}->{'@UNICODES'};
MyWarn ("Glyph $gid$uname is used but doesn't have a name -- making one up.\n");
$GlyphFromID{$gid}->{'NAME'} = "glyph$gid";
$genericCount++;
}
return $GlyphFromID{$gid}->{'NAME'};
}
##########################
# GlyphOrGroup
#
# Many lookups allow either GROUP or GLYPH depending on whether one or many glyphs are included.
# This function takes a list of GIDS and creates the appropriate GROUP or GLYPH needed.
#
sub GlyphOrGroup
{
if (scalar(@_) > 1)
{
return "GROUP \"" . CacheGroup(@_) . "\"";
}
else
{
return "GLYPH \"" . NameFromID($_[0]) . "\"";
}
}
##########################
# WriteLookupHeader()
#
# Routine to generic lookup header to $LookupText
#
sub WriteLookupHeader ($$) # lookup structure reference, name to be used in lookup
{
my ($l, $name) = @_;
$LookupText .= "DEF_LOOKUP \"$name\"";
# At one time I thought VOLT might be sensitive to the order these were written in, but now I don't think so.
# In any case, this seems to be the order VOLT itself writes:
# set SKIP_BASE only if *both* IgnoreBaseGlyphs and IgnoreLigatures bits set:
$LookupText .= ($l->{'FLAG'} & 0x0006) == 0x0006 ? " SKIP_BASE" : " PROCESS_BASE";
$LookupText .= ($l->{'FLAG'} & 0x0008) ? " SKIP_MARKS" : " PROCESS_MARKS " . ($l->{'FLAG'} & 0xFF00 ? GetGroupName($l->{'FLAG'}>>8) : "ALL");
$LookupText .= " DIRECTION " . ($l->{'FLAG'} & 0x0001 ? "RTL" : "LTR");
MyWarn (sprintf "Lookup $name has unhandled lookup flag bits 0x%04X\n", $l->{'FLAG'} & 0xF0) if $l->{'FLAG'} & 0xF0;
$LookupText .= "\n";
}
##########################
# GetContext()
#
# Return a string representing the context
sub GetContext($$) # subtable and either 'PRE' or 'POST'
{
my ($sub, $which) = @_;
my $res;
foreach my $ctx ($which eq 'PRE' ? reverse (@{$sub->{'RULES'}[0][0]{$which}}) : @{$sub->{'RULES'}[0][0]{$which}} )
{
$res .= $which eq 'PRE' ? ' LEFT ' : ' RIGHT ';
if ($sub->{'MATCH_TYPE'} eq 'o')
{
# Cover-based context -- but if just one glyph in the cover let's do it as a glyph
$res .= GlyphOrGroup (keys %{$ctx->{'val'}}) . "\n";
}
else
{
MyWarn "MATCH_TYPE is '$sub->{'MATCH_TYPE'}' rather than expected 'o' in GetContext.\n";
}
}
return $res;
}
##########################
# CoalesceChainContextSubtables()
#
# Chaining Context Lookups (GSUB 6, GPOS 8) need some preprocessing to coalesce adjacent subtables a into single VOLT lookup.
# While this step isn't actually needed for some situations, it is required as part of the support for "EXCEPT_CONTEXT".
# The way EXCEPT_CONTEXT works is to split the single VOLT lookup into multiple subtables where the first has zero actions but
# does have all the context, the second has no context but does have all the action. Since there is no way to express this
# in VOLT as two separate lookups (can't have zero actions), we have to coalesce these subtables.
#
# VOLT also uses separate subtables for normal "IN_CONTEXT" rules when there are multiple contexts of differing lengths.
# These wouldn't have to be coalesced into a single VOLT lookup, but since we have to handle the EXCEPT_CONTEXT we may as well
# do it all.
#
# So the following routine preprocesses the subtables of a lookup to coalesce such subtables and generate the context strings.
#
sub CoalesceChainContextSubtables ($$)
{
my $l = shift; # ref to chaining context lookup structure
my $parent = shift; # ref to GSUB or GPOS table
my $name = $l->{'-name'};
# Loop through the subtables.
# Loop is constructed this way because I may be deleting subtables as I go through
my $subtbl;
for ($subtbl = 0; $subtbl < scalar (@{$l->{'SUB'}}); )
{
my $sub = $l->{'SUB'}[$subtbl];
if ($sub->{'FORMAT'} != 3)
{ MyWarn "Lookup '$name' has unhandled subtable format $sub->{'FORMAT'} -- ignoring subtable.\n"; splice (@{$l->{'SUB'}}, $subtbl,1); next;}
# I don't think it is possible to have more than one RULES entry, but if a font shows
# up with this I want to know about it...
if ($#{$sub->{'RULES'}} > 0)
{ MyWarn "Font has more than one RULES entry for lookup '$name' (type $l->{'TYPE'} format $sub->{'FORMAT'}) -- ignoring subtable\n"; splice (@{$l->{'SUB'}}, $subtbl,1); next;}
# Don't ask me why Martin has another array in the structure at this point, but he does:
if ($#{$sub->{'RULES'}[0]} > 0)
{ MyWarn "Font has more than one RULES[0] entry for lookup '$name' (type $l->{'TYPE'} format $sub->{'FORMAT'}) -- ignoring subtable\n"; splice (@{$l->{'SUB'}}, $subtbl,1); next;}
# For now, cannot handle more than one ACTION item
if ($#{$sub->{'RULES'}[0][0]{'ACTION'}} > 0)
{ MyWarn "Font has more than one ACTION entry for lookup '$name' (type $l->{'TYPE'} format $sub->{'FORMAT'}) -- ignoring subtable\n"; splice (@{$l->{'SUB'}}, $subtbl,1); next;}
# In order to coalesce two subtables, the MATCH of the two subtables must be equivalent, and if both subtables have an Action, then that must match
# So we'll calculate $matchID and $lookupID, two values that we can compare with previous and next lookups.
# While we're at it we'll format the context strings
my ($lookupID, $context, $matchID);
# Start by building $lookupID from the ACTION.
if (defined $sub->{'RULES'}[0][0]{'ACTION'}[0])
{
# This has a rule, so it isn't an EXCEPT_CONTEXT subtable.
my ($offset, $ti) = @{$sub->{'RULES'}[0][0]{'ACTION'}[0]};
unless (defined $ti)
{ MyWarn "OOPS: ACTION not defined in lookup '$name' (type $l->{'TYPE'} format $sub->{'FORMAT'}) -- ignoring subtable\n"; splice (@{$l->{'SUB'}}, $subtbl,1); next;}
# For now, offset must be 0 and target rule must not be anything complex
if ($offset != 0)
{ MyWarn "Font has nonzero ACTION offset for lookup '$name' (type $l->{'TYPE'} format $sub->{'FORMAT'}) -- ignoring subtable\n"; splice (@{$l->{'SUB'}}, $subtbl,1); next;}
if ($parent->{'LOOKUP'}[$ti]{'TYPE'} > (ref ($parent) eq 'Font::TTF::GSUB' ? 4 : 6))
{ MyWarn "Font has complex lookup in ACTION entry for lookup '$name' (type $l->{'TYPE'} format $sub->{'FORMAT'}) -- ignoring subtable\n"; splice (@{$l->{'SUB'}}, $subtbl,1); next;}
if ($#{$parent->{'LOOKUP'}[$ti]{'SUB'}} > 0)
{ MyWarn "Font has multi-subtable lookup in ACTION entry for lookup '$name' (type $l->{'TYPE'} format $sub->{'FORMAT'}) -- ignoring subtable\n"; splice (@{$l->{'SUB'}}, $subtbl,1); next;}
$lookupID = $ti;
$context = "IN_CONTEXT\n";
}
else
{
# This has no rule, so it is an EXCEPT_CONTEXT subtable.
$context = "EXCEPT_CONTEXT\n";
}
# Finish constructing the context string:
$context .= GetContext ($sub, 'PRE') if exists $sub->{'RULES'}[0][0]{'PRE'};
$context .= GetContext ($sub, 'POST') if exists $sub->{'RULES'}[0][0]{'POST'};
$context .= "END_CONTEXT\n";
# Now, calculate a string which uniquely describes this subtable's match sequence:
my $matchID = '|';
foreach my $ctx (@{$sub->{'RULES'}[0][0]{'MATCH'}})
{
if ($sub->{'MATCH_TYPE'} eq 'o')
{
$matchID .= join(',', sort {$a <=> $b} keys %{$ctx->{'val'}}) . '|';
}
else
{
MyWarn "MATCH_TYPE is '$sub->{'MATCH_TYPE'}' rather than expected 'o' in CoalesceChainContextSubtables.\n";
}
}
# See if we can coalesce this subtable with the previous one:
if ($subtbl > 0 &&
$l->{'SUB'}[$subtbl-1]{'-matchID'} eq $matchID &&
(!defined $l->{'SUB'}[$subtbl-1]{'-lookupID'} || ($l->{'SUB'}[$subtbl-1]{'-lookupID'} eq $lookupID)))
{
# Whoo hoo! we can coalesce them:
# First, concatinate its context with ours
$context = $l->{'SUB'}[$subtbl-1]{'-context'} . $context;
# Now blow it away!
splice (@{$l->{'SUB'}}, $subtbl-1, 1) ;
}
else
{
# Couldn't coalesce, so be sure to bump loop variable for next pass:
$subtbl++;
}
# Finally, store my private data into this subtable:
$sub->{'-matchID'} = $matchID;
$sub->{'-context'} = $context;
$sub->{'-lookupID'} = $lookupID;
}
}
##########################
# WriteSimpleGSUBLookup()
#
# Routine to append a simple GSUB lookup (types 1 - 4) subtable to $LookupText
#
sub WriteSimpleGSUBLookup ($$$) # lookup structure reference, name to be used in lookup, subtable index
{
my ($l, $name, $stbl) = @_;
my ($lhs, $rhs, $start, $last, $col, $lhsGroup, $rhsGroup);
my ($cover, $i, $subrule);
my $sub = $l->{'SUB'}[$stbl];
if ($l->{'TYPE'} == 1)
{
# 1-1 (simple) substitution
MyWarn ("Unexpected ACTION_TYPE '$sub->{'ACTION_TYPE'}' for lookup '$name'.\n") if $sub->{'ACTION_TYPE'} !~ /[og]/;
if ($sub->{'FORMAT'} == 1 || $sub->{'FORMAT'} == 2)
{
# Build $lhs and $rhs arrays:
$lhs = [ CoverToList ($l->{'SUB'}[$stbl]{'COVERAGE'}) ];
$rhs = ($sub->{'FORMAT'} == 1) ?
[ map { [ $lhs->[$_] + $sub->{'ADJUST'} ] } (0 .. $#{$lhs}) ]: # Format 1
[ map { $sub->{'RULES'}[$_][0]{'ACTION'} } (0 .. $#{$lhs}) ]; # Format 2
# Write out the substitution rules:
$start = 0;
while ($start <= $#{$lhs})
{
($last, $col, $lhsGroup, $rhsGroup) = GetGroupRange(@{$lhs}, @{$rhs}, $start);
if ($last > $start)
{
# Write rule with groups:
$LookupText .= "SUB GROUP \"$lhsGroup\"\n";
$LookupText .= "WITH GROUP \"$rhsGroup\"\n";
}
else
{
# Write rule with glyphs:
$LookupText .= "SUB GLYPH \"" . NameFromID($lhs->[$start]) . "\"\n";
$LookupText .= "WITH GLYPH \"" . NameFromID($rhs->[$start][0]) . "\"\n";
}
$LookupText .= "END_SUB\n";
$start = $last+1;
}
}
else
{
MyWarn "GSUB '$name' has unrecognized format $sub->{'FORMAT'}.\n";
}
}
elsif ($l->{'TYPE'} == 2)
{
# 1-n (multiple) substitution
MyWarn ("Unexpected ACTION_TYPE '$sub->{'ACTION_TYPE'}' for lookup '$name'.\n") if $sub->{'ACTION_TYPE'} ne 'g';
if ($sub->{'FORMAT'} == 1)
{
# Build $lhs and $rhs arrays:
$lhs = [ CoverToList ($sub->{'COVERAGE'}) ];
$rhs = [ map { $sub->{'RULES'}[$_][0]{'ACTION'} } (0 .. $#{$lhs}) ];
# Write out the substitution rules:
$start = 0;
while ($start <= $#{$lhs})
{
($last, $col, $lhsGroup, $rhsGroup) = GetGroupRange(@{$lhs}, @{$rhs}, $start);
$LookupText .= "SUB " . ($last > $start ? "GROUP \"" . $lhsGroup : "GLYPH \"" . NameFromID($lhs->[$start])) . "\"\n";
$LookupText .= "WITH " . join(" ", map {$_ == $col ? "GROUP \"$rhsGroup\"" : "GLYPH \"" . NameFromID($rhs->[$start][$_]) . "\"" } (0 .. $#{$rhs->[$start]}) ) . "\n";
$LookupText .= "END_SUB\n";
$start = $last+1;
}
}
else
{
MyWarn "GSUB '$name' has unrecognized format $sub->{'FORMAT'}.\n" ;
}
}
elsif ($l->{'TYPE'} == 3)
{
# 1-n (alternate) substitution
MyWarn ("Unexpected ACTION_TYPE '$sub->{'ACTION_TYPE'}' for lookup '$name'.\n") if $sub->{'ACTION_TYPE'} ne 'a';
if ($sub->{'FORMAT'} == 1)
{
$lhs = [ CoverToList ($sub->{'COVERAGE'}) ] ;
$rhs = [ map { $sub->{'RULES'}[$_][0]{'ACTION'} } (0 .. $#{$lhs}) ];
# Write out the alternate substitution rules
for $start (0 .. $#{$lhs})
{
for (0 .. $#{$rhs->[$start]})
{
$LookupText .= "SUB GLYPH \"" . NameFromID($lhs->[$start]) . "\"\nWITH GLYPH \"" . NameFromID($rhs->[$start][$_]) . "\"\nEND_SUB\n";
}
}
}
else
{
MyWarn "GSUB '$name' has unrecognized format $sub->{'FORMAT'}.\n" ;
}
}
elsif ($l->{'TYPE'} == 4)
{
# n-1 (ligature) substitution
MyWarn ("Unexpected ACTION_TYPE '$sub->{'ACTION_TYPE'}' for lookup '$name'.\n") if $sub->{'ACTION_TYPE'} ne 'g';
if ($sub->{'FORMAT'} == 1)
{
# First pick up the coverage list:
$cover = [ CoverToList ($sub->{'COVERAGE'}) ];
# Now build $lhs & $rhs:
$lhs = [];
$rhs = [];
for $i (0 .. $#{$cover})
{
# For each first glyph in the coverage, there can be multiple match strings, each corresponding to a ligature:
foreach $subrule (@{$sub->{'RULES'}[$i]})
{
# Make sure this is really a n-1 mapping:
die "GSUB '$name' has invalid ligature mapping" if $#{$subrule->{'ACTION'}} > 0;
push @{$lhs}, [ $cover->[$i], @{$subrule->{'MATCH'}} ];
push @{$rhs}, ($gid = $subrule->{'ACTION'}[0]);
$g = $GlyphFromID{$gid};
# Set the number of components for the ligature in the glyph definition:
# $g->{'COMPONENTS'} = 1 + ($#{$subrule->{'MATCH'}} + 1) if $g->{'TYPE'} == "LIGATURE";
}
}
# Write out the substitution rules:
# (very similar to type 2, except $rhs and $lhs are reversed)
$start = 0;
while ($start <= $#{$rhs})
{
($last, $col, $rhsGroup, $lhsGroup) = GetGroupRange(@{$rhs}, @{$lhs}, $start);
$LookupText .= "SUB " . join(" ", map {$_ == $col ? "GROUP \"$lhsGroup\"" : "GLYPH \"" . NameFromID($lhs->[$start][$_]). "\"" } (0 .. $#{$lhs->[$start]}) ) . "\n";
$LookupText .= "WITH " . ($last > $start ? "GROUP \"" . $rhsGroup : "GLYPH \"" . NameFromID($rhs->[$start])) . "\"\n";
$LookupText .= "END_SUB\n";
$start = $last+1;
}
}
else
{
MyWarn "GSUB '$name' has unrecognized format $sub->{'FORMAT'}.\n" ;
}
}
}
##########################
#
# Process GSUB lookup
#
# Appends one or more lookup definitions to $LookupText
sub ProcessGSUBLookup ($) # GSUB lookup index to process
{
my $lid = shift; # lookup index
my $l= $gsub->{'LOOKUP'}[$lid]; # lookup structure
my $nsubs = scalar (@{$l->{'SUB'}}); # Number of subtables
foreach my $subtbl (0 .. $nsubs-1)
{
my $name = $l->{'-name'};
$name .= "\\$subtbl" if $nsubs > 1;
my $sub = $l->{'SUB'}[$subtbl];
if ($l->{'TYPE'} <= 4)
{
WriteLookupHeader ($l, $name);
$LookupText .= "IN_CONTEXT\nEND_CONTEXT\nAS_SUBSTITUTION\n";
WriteSimpleGSUBLookup ($l, $name, $subtbl);
$LookupText .= "END_SUBSTITUTION\n";
}
elsif ($l->{'TYPE'} == 6) # Chaining context
{
MyWarn ("Unexpected ACTION_TYPE '$sub->{'ACTION_TYPE'}' for lookup '$name'.\n") if $sub->{'ACTION_TYPE'} ne 'l';
# For now, just handling format 3:
if ($sub->{'FORMAT'} == 3)
{
# All the gruntwork has been done by CoalesceChainContextSubtables()
# TODO: It is possible that the type 6 lookup we are processing has a coverage (MATCH) that is smaller than that
# specified by the target lookup. I don't think VOLT would construct such a thing, but some other tool might.
# We really should pick up the MATCH string and pass it to WriteSimpleGSUBLookup to do some
# error checking of some sort.
# OK, now we can emit the lookup
WriteLookupHeader ($l, $name);
$LookupText .= $sub->{'-context'};
$LookupText .= "AS_SUBSTITUTION\n";
if (defined $sub->{'-lookupID'})
{
WriteSimpleGSUBLookup ($gsub->{'LOOKUP'}[$sub->{'-lookupID'}], $name, 0);
}
else
{
MyWarn "Undefined target lookup in GSUB lookup '$name'\n";
}
$LookupText .= "END_SUBSTITUTION\n";
}
else
{
MyWarn "GSUB '$name' has unhandled format $sub->{'FORMAT'}.\n" ;
}
}
else
{
MyWarn ("Unhandled GSUB lookup $name (type $l->{'TYPE'}) ignored for now.\n");
}
}
}
##########################
# CacheAP
#
# take a list of base glyphs with anchors, and marks with anchors, and
# determine an attachment point name. Cache the data in case it is re-used
#
my @APs; # Array of cached AP info. Each item in array is a hash containing:
#
# 'bases' a hash, indexed by glyphID, returning array, indexed by component, returning ref to anchor.
# 'marks' a hash, indexed by glyphID, returning ref to anchor
sub CacheAP(\%\%)
{
my ($bases, $marks) = @_;
my ($i, $gid, $apname);
my $found = -1;
for $i (0 .. $#APs)
{
$found = $i; # Assume this one will work
# See if this AP is acceptable by comparing our bases and marks with the ones in this AP
# Check bases first
foreach $gid (keys %{$bases})
{
# If this gid isn't in the AP, then we're OK so far
next unless exists $APs[$i]->{'bases'}{$gid};
# This gid is in the AP -- verify the x & y matches:
# In order to pass the test, base must have the same number of components and each component's AP must match
my $APbase = $APs[$i]->{'bases'}{$gid};
my $base = $bases->{$gid};
if ($#{$APbase} != $#{$base})
{
# Not the same number of components
$found = -1;
}
else
{
# Verify each component's ap matches
foreach (0 .. $#{$base})
{
next if $APbase->[$_]{'x'} == $base->[$_]{'x'} && $APbase->[$_]{'y'} == $base->[$_]{'y'};
$found = -1;
last; # No need to keep looking at other components in this base
}
}
last if $found == -1; # No need to keep looking at other gids in this AP
}
next if $found == -1; # This AP no good -- try the next one
# Now check marks
foreach $gid (keys %{$marks})
{
# If this gid isn't in the AP, then we're OK so far
next unless exists $APs[$i]->{'marks'}{$gid};
# This gid is in the AP -- verify the x & y matches:
next if $APs[$i]->{'marks'}{$gid}{'x'} == $marks->{$gid}{'x'} && $APs[$i]->{'marks'}{$gid}{'y'} == $marks->{$gid}{'y'};
$found = -1;
last;
}
# At this point, if $found is still undef, the we've found a usable AP.
# However, if it is -1 then we need to keep looking
next if $found == -1; # This AP no good -- try the next one
# All the bases and marks are either absent or they match the ones in this AP -- therefore ths AP can be used!
last;
}
unless ($found >= 0)
{
# Create new, empty, AP cache entry
push @APs, { 'bases' => {}, 'marks' => {} };
$found = $#APs;
}
$apname = "attach$found";
# Add any missing glyphs to the cache:
# Record info both in the APCache and in the glyph structure (for building Anchor definitions)
foreach $gid (keys %{$bases})
{
next if exists $APs[$found]->{'bases'}{$gid};
$APs[$found]->{'bases'}{$gid} = $GlyphFromID{$gid}{'ANCHORS'}{$apname} = $bases->{$gid} ;
}
foreach $gid (keys %{$marks})
{
next if exists $APs[$found]->{'marks'}{$gid};
$APs[$found]->{'marks'}{$gid} = $GlyphFromID{$gid}{'ANCHORS'}{"MARK_$apname"} = $marks->{$gid};
}
return $apname;
}
##########################
# ValueRecord
#
# Return a VOLT source string for a Font::TTF::GPOS value record
#
my %vrKeys = ( XAdvance => 'ADV', YPlacement => 'DY', XPlacement => 'DX');
my @vrUnprocessed = ( qw( YAdvance XPlaDevice YPlaDevice XAdvDevice YAdvDevice XIdPlacement YIdPlacement));
sub ValueRecord(\%)
{
my $rec = shift;
my $res = "POS";
for (sort keys %vrKeys)
{
$res .= " $vrKeys{$_} $rec->{$_}" if exists $rec->{$_} && $rec->{$_} != 0;
}
$res .= " END_POS";
foreach (@vrUnprocessed)
{
if (defined $rec->{$_})
{
MyWarn ("Unhandled ValueRecord data '$_'\n");
}
}
$res;
}
##########################
# PairKern
#
# Returns a VOLT source string for the adjustment between two glyphs in a GPOS pairadjust (type 2) lookup of format 1
#
sub PairKern($$$)
{
my ($sub, $first, $second) = @_; # ref to sub table, first GID, second GID
# Return it if already computed
return $sub->{'PKcache'}{"$first.$second"} if exists $sub->{'PKcache'}{"$first.$second"};
my $res;
# Find the rule, if it exists:
if (exists $sub->{'COVERAGE'}{'val'}{$first})
{
my $rule = $sub->{'RULES'}[$sub->{'COVERAGE'}{'val'}{$first}];
foreach my $subrule (@{$rule})
{
next unless $subrule->{'MATCH'}[0] == $second;
# Found it!
$res = ValueRecord(%{$subrule->{'ACTION'}[0]}) . ' ' . ValueRecord(%{$subrule->{'ACTION'}[1]});
last;
}
}
$res = undef if $res eq 'POS END_POS POS END_POS'; # All zero -- make as if this wasn't even present.
$sub->{'PKcache'}{"$first.$second"} = $res;
}
##########################
# WriteSimplePOSLookup()
#
# Routine to append a simple GPOS lookup (types 1 - 6) subtable to $LookupText
#
sub WriteSimpleGPOSLookup ($$$) # lookup structure reference, name to be used in lookup, subtable index
{
my ($l, $name, $stbl) = @_;
my ($lhs, $rhs, $start, $last, $col, $lhsGroup, $rhsGroup);
my (@cover, $gid, $i, $subrule);
my $sub = $l->{'SUB'}[$stbl];
if ($l->{'TYPE'} == 1)
{
# Single adjustment
MyWarn ("Unexpected ACTION_TYPE '$sub->{'ACTION_TYPE'}' for lookup '$name'.\n") if $sub->{'ACTION_TYPE'} !~ /[ov]/;
@cover = CoverToList ($sub->{'COVERAGE'}) ;
if ($sub->{'FORMAT'} == 1)
{
# Format 1 -- a single value record for entire group.
$LookupText .= "ADJUST_SINGLE " . GlyphOrGroup(@cover) . " BY " . ValueRecord(%{$sub->{'ADJUST'}}) . "\nEND_ADJUST\n";
}
elsif ($sub->{'FORMAT'} == 2)
{
# Format 2 -- value record for each covered glyph.
$LookupText .= "ADJUST_SINGLE\n";
foreach (0 .. $#cover)
{
$LookupText .= " GLYPH \"" . NameFromID($cover[$_]) . "\" BY " . ValueRecord(%{$sub->{'RULES'}[$_][0]{'ACTION'}[0]}) . "\n";
}
$LookupText .= "END_ADJUST\n";
}
else
{
MyWarn "GPOS '$name' has unrecognized format $sub->{'FORMAT'}.\n";
}
}
elsif ($l->{'TYPE'} == 2)
{
# Pair adjustment
MyWarn ("Unexpected ACTION_TYPE '$sub->{'ACTION_TYPE'}' for lookup '$name'.\n") if $sub->{'ACTION_TYPE'} != 'p';
$LookupText .= "ADJUST_PAIR\n";
if ($sub->{'FORMAT'} == 1)
{
# Format 1 -- glyph-pair value records.
# This is a complicated one because I want to coalesce glyphs into groups. I do this by examining every
# pair of first glyphs and checking their adjustment with all 2nd glyphs -- if these adjustments are
# all the same then the two first glyphs can be grouped together. Similarly for every pair of 2nd
# glyphs (examine the adjustment with all possible first glyphs).
my ($i, $j, $k);
# First step is to get a complete list of 1st and 2nd glyphs:
my @first = CoverToList($sub->{'COVERAGE'});
my %second;
foreach $i (@{$sub->{'RULES'}})
{
foreach $j (@{$i})
{
$second{$j->{'MATCH'}[0]} = 1;
}
}
my @second = sort {$a <=> $b} keys %second;
# OK, the fun begins
my (@g1, @g2); # record of the results. These arrays parallel @first and @second, and contain:
# undef -- this glyph hasn't matched anything yet.
# scalar -- index of a (prior) glyph with which this one can be grouped
# array -- list of indicies of (subsequent) glyphs which are grouped with this one.
# First examine every pair of 1st glyphs to see if they can coalesce
for $i (0 .. $#first)
{
next if defined $g1[$i];
# Initialize array in case we get any that can coalesce with it
$g1[$i] = [ $i ];
for $j ($i+1 .. $#first)
{
next if defined $g1[$j];
# for first glyphs at $i1 and $j1, compare adjustment with all 2nd glyphs
my $match = 1; # assume they all match
for $k (0 .. $#second)
{
if (PairKern($sub, $first[$i], $second[$k]) ne PairKern($sub, $first[$j], $second[$k]))
{
$match = 0; #fail
last;
}
}
next unless $match;
# Found a match! We can coalesce First glyphs indexed by $i and $j
push @{$g1[$i]}, $j;
$g1[$j] = $i;
}
}
# Make sure groups are big enough to use:
if (defined $opt_g)
{
for $i (0 .. $#first)
{
next unless ref($g1[$i]) eq 'ARRAY';
next if scalar(@{$g1[$i]}) >= $opt_g; # This is a keeper
next if scalar(@{$g1[$i]}) == 1; # This is already a singleton -- leave it.
# Group is too small -- destroy it:
foreach $j (@{$g1[$i]})
{
$g1[$j] = [ $j ];
}
}
}
# Now repeat the logic on the every pair of 2nd glyphs
for $i (0 .. $#second)
{
next if defined $g2[$i];
# Initialize array in case we get any that can coalesce with it
$g2[$i] = [ $i ];
for $j ($i+1 .. $#second)
{
next if defined $g2[$j];
# for second glyphs at $i1 and $j1, compare adjustment with all first glyphs
my $match = 1; # assume they all match
for $k (0 .. $#first)
{
if (PairKern($sub, $first[$k], $second[$i]) ne PairKern($sub, $first[$k], $second[$j]))
{
$match = 0; #fail
last;
}
}
next unless $match;
# Found a match! We can coalesce Second glyphs indexed by $i and $j
push @{$g2[$i]}, $j;
$g2[$j] = $i;
}
}
# Make sure groups are big enough to use:
if (defined $opt_g)
{
for $i (0 .. $#second)
{
next unless ref($g2[$i]) eq 'ARRAY';
next if scalar(@{$g2[$i]}) >= $opt_g; # This is a keeper
next if scalar(@{$g2[$i]}) == 1; # This is already a singleton -- leave it.
# Group is too small -- destroy it:
foreach $j (@{$g2[$i]})
{
$g2[$j] = [ $j ];
}
}
}
# Whew! Now build the lookup
map { $LookupText .= ' FIRST ' . GlyphOrGroup(@first[@{$_}]); } grep {ref($_) eq 'ARRAY'} @g1;
$LookupText .= "\n";
map { $LookupText .= ' SECOND ' . GlyphOrGroup(@second[@{$_}]); } grep {ref($_) eq 'ARRAY'} @g2;
$LookupText .= "\n";
$i = 1;
for my $f (0 .. $#first)
{
next unless ref($g1[$f]) eq 'ARRAY';
$j = 1;
for my $s (0 .. $#second)
{
next unless ref($g2[$s]) eq 'ARRAY';
my $res = PairKern($sub, $first[$g1[$f][0]], $second[$g2[$s][0]]);
$LookupText .= " $i $j BY $res\n" if defined $res;
$j++;
}
$i++;
}
}
elsif ($sub->{'FORMAT'} == 2)
{
# Format 2 -- class-based value records
my @first = map { $#{$_} >= 0 ? ' FIRST ' . GlyphOrGroup(@{$_}) : undef } ClassToLists ($sub->{'CLASS'});
my @second = map { $#{$_} >= 0 ? ' SECOND ' . GlyphOrGroup(@{$_}) : undef } ClassToLists ($sub->{'MATCH'}[0]);
$LookupText .= join('', @first) . "\n";
$LookupText .= join('', @second) . "\n";
my $i = 1;
foreach my $f (0 .. $#first)
{
next unless defined $first[$f];
my $j = 1;
foreach my $s (0 .. $#second)
{
next unless defined $second[$s];
$LookupText .= " $i $j BY " . ValueRecord(%{$sub->{'RULES'}[$f][$s]{'ACTION'}[0]}) . ' ' . ValueRecord(%{$sub->{'RULES'}[$f][$s]{'ACTION'}[1]}) . "\n";
$j++;
}
$i++;
}
}
else
{
MyWarn "GPOS '$name' has unrecognized format $sub->{'FORMAT'}.\n";
}
$LookupText .= "\nEND_ADJUST\n";
}
elsif ($l->{'TYPE'} == 3)
{
# Cursive Attachment
MyWarn ("Unexpected ACTION_TYPE '$sub->{'ACTION_TYPE'}' for lookup '$name'.\n") if $sub->{'ACTION_TYPE'} ne 'e';
if ($sub->{'FORMAT'} == 1)
{
# First pick up the coverage list:
@cover = CoverToList ($sub->{'COVERAGE'}) ;
# Initialize hashes to keep track of GIDs with entry/exit points
$lhsGroup = {};
$rhsGroup = {};
# Pick out anchor definitions, building left-hand and right-hand lists of glyphs
foreach my $gid (@cover)
{
my $action = $sub->{'RULES'}[$sub->{'COVERAGE'}{'val'}{$gid}][0]{'ACTION'};
for $i (0 .. 1)
{
next unless $action->[$i];
# Entry or exit defined:
my $which = (qw(entry exit))[$i];
$GlyphFromID{$gid}->{'ANCHORS'}{$which} = $action->[$i]; # ref to anchor -- we'll parse this apart later
($i == 0 ? $rhsGroup : $lhsGroup)->{$gid} = 1; # Build lhs & rhs groups
}
}
$LookupText .= "ATTACH_CURSIVE\n";
$LookupText .= "EXIT " . GlyphOrGroup(keys %{$lhsGroup}) . "\n";
$LookupText .= "ENTER " . GlyphOrGroup(keys %{$rhsGroup}) . "\n";
$LookupText .= "END_ATTACH\n";
}
else
{
MyWarn "GPOS '$name' has unrecognized format $sub->{'FORMAT'}.\n";
}
}
elsif ($l->{'TYPE'} == 4 || $l->{'TYPE'} == 5 || $l->{'TYPE'} == 6)
{
# Mark-to-Base and Mark-to-Mark (identical in structure)
my (@marks, @bases); # Indexed by markclass
my ($class, $anchor, $rules, $component);
MyWarn ("Unexpected ACTION_TYPE '$sub->{'ACTION_TYPE'}' for lookup '$name'.\n") if $sub->{'ACTION_TYPE'} ne 'a';
if ($sub->{'FORMAT'} == 1)
{
foreach $gid (keys %{$sub->{'MATCH'}[0]{'val'}})
{
($class, $anchor) = @{$sub->{'MARKS'}[$sub->{'MATCH'}[0]{'val'}{$gid}]};
$marks[$class]{$gid} = $anchor;
}
# Programmer note: indexing scheme for RULES is:
# $sub->{'RULES'}[Base_char_index][Ligature_component]{'ACTION'}[Mark_class]
foreach $gid (keys %{$sub->{'COVERAGE'}{'val'}})
{
my $rules = $sub->{'RULES'}[ $sub->{'COVERAGE'}{'val'}{$gid} ];
if ($#{$rules} > 0)
{
# Real ligature -- let's make sure glyph data knows how many components
MyWarn "Lookup $name defines different number of components for ligature glyph $gid.\n"
if exists $GlyphFromID{$gid}->{'COMPONENTS'} and $GlyphFromID{$gid}->{'COMPONENTS'} != $#{$rules} + 1;
$GlyphFromID{$gid}->{'COMPONENTS'} = $#{$rules} + 1 ;
}
foreach $component (0 .. $#{$rules})
{
$class = 0;
foreach $anchor (@{$sub->{'RULES'}[ $sub->{'COVERAGE'}{'val'}{$gid} ][$component]{'ACTION'}})
{
$bases[$class]{$gid}[$component] = $anchor if defined $anchor;
$class++;
}
}
}
$LookupText .= "ATTACH " . GlyphOrGroup(keys %{$sub->{'COVERAGE'}{'val'}}) . "\nTO";
for $class (0 .. $#marks)
{
next unless scalar(keys %{$marks[$class]}); # ignore any mark classes that have no elements
my $APname = CacheAP(%{$bases[$class]}, %{$marks[$class]});
$LookupText .= " " . GlyphOrGroup(keys %{$marks[$class]}) . " AT ANCHOR \"$APname\"";
}
$LookupText .= "\nEND_ATTACH\n";
}
else
{
MyWarn "GPOS '$name' has unrecognized format $sub->{'FORMAT'}.\n";
}
}
else
{
MyWarn ("Unhandled GPOS lookup $name (type $l->{'TYPE'}) ignored for now.\n");
}
}
##########################
#
# Process GPOS lookup
#
# Appends one or more lookup definitions to $LookupText
sub ProcessGPOSLookup ($) # GPOS lookup index to process
{
my $lid = shift; # lookup index
my $l= $gpos->{'LOOKUP'}[$lid]; # lookup structure
my $nsubs = scalar (@{$l->{'SUB'}}); # Number of subtables
foreach my $subtbl (0 .. $nsubs-1)
{
my $name = $l->{'-name'};
$name .= "\\$subtbl" if $nsubs > 1;
if ($l->{'TYPE'} <= 6)
{
WriteLookupHeader ($l, $name);
$LookupText .= "IN_CONTEXT\nEND_CONTEXT\nAS_POSITION\n";
WriteSimpleGPOSLookup ($l, $name, $subtbl);
$LookupText .= "END_POSITION\n";
}
elsif ($l->{'TYPE'} == 8) # Chaining context
{
my $sub = $l->{'SUB'}[$subtbl];
# This is just like GSUB:
if ($sub->{'FORMAT'} == 3)
{
# All the gruntwork has been done by CoalesceChainContextSubtables()
# TODO: It is possible that the type 6 lookup we are processing has a coverage (MATCH) that is smaller than that
# specified by the target lookup. I don't think VOLT would construct such a thing, but some other tool might.
# We really should pick up the MATCH string and pass it to WriteSimpleLookup to do some
# error checking of some sort.
# OK, now we can emit the lookup
WriteLookupHeader ($l, $name);
$LookupText .= $sub->{'-context'};
$LookupText .= "AS_POSITION\n";
if (defined $sub->{'-lookupID'})
{
WriteSimpleGPOSLookup ($gpos->{'LOOKUP'}[$sub->{'-lookupID'}], $name, 0);
}
else
{
MyWarn "Undefined target lookup in GSUB lookup '$name'\n";
}
$LookupText .= "END_POSITION\n";
}
else
{
MyWarn "GPOS '$name' has unhandled format $sub->{'FORMAT'}.\n";
}
}
else
{
MyWarn ("Unhandled GPOS Lookup $name (type $l->{'TYPE'}) ignored for now.\n");
}
}
}
##########################
#
# Generate the script, lang, and feature source.
# This also tells us which lookups need to be directly processed.
#
my ($s, $l, $f); # Script, Lang, and Feature
# Record which lookups needed within gsub and gpos
$gsub->{'-LookupsNeeded'} = [];
$gpos->{'-LookupsNeeded'} = [];
# Note: VOLT co-mingles script/lang/feature trees from GPOS and GDEF.
# This code attempts to keep script, lang, and feature lists sorted by tag, though this isn't essential for VOLT
# Compile a list of scripts, then iterate over them
my %scripts;
map {$scripts{$_} = 1} (keys %{$gsub->{'SCRIPTS'}}) if $gsub;
map {$scripts{$_} = 1} (keys %{$gpos->{'SCRIPTS'}}) if $gpos;
foreach $s (sort keys %scripts)
{
$SLFText .= "DEF_SCRIPT ";
$SLFText .= "NAME \"$ttnames{'SCRIPT'}{$s}\" " if defined $ttnames{'SCRIPT'}{$s};
$SLFText .= "TAG \"$s\"\n\n";
# For this script, compile list of languages and then iterate over them
my %langs;
map {$langs{$_} = 1} (@{$gsub->{'SCRIPTS'}{$s}{'LANG_TAGS'}}) if $gsub;
map {$langs{$_} = 1} (@{$gpos->{'SCRIPTS'}{$s}{'LANG_TAGS'}}) if $gpos;
foreach $l ('DEFAULT', sort keys %langs)
{
# Some fonts, e.g., Doulos, have a default language *and* have a 'dflt' language, one referring to the other. Skip one if so:
next if ($l eq 'DEFAULT' || $l eq 'dflt') && (exists $gsub->{'SCRIPTS'}{$s}{$l}{' REFTAG'} || exists $gpos->{'SCRIPTS'}{$s}{$l}{' REFTAG'});
$SLFText .= "DEF_LANGSYS ";
if ($l eq 'DEFAULT')
{
$SLFText .= "NAME \"Default\" TAG \"dflt\"\n\n";
}
else
{
$SLFText .= "NAME \"$ttnames{'LANGUAGE'}{$l}\" " if defined $ttnames{'LANGUAGE'}{$l};
$SLFText .= "TAG \"$l\"\n\n";
}
MyWarn ("VOLT doesn't understand default GSUB feature; setting ignored ($s/$l).\n") if ($gsub && $gsub->{'SCRIPTS'}{$s}{$l}{'DEFAULT'} != 65535);
MyWarn ("VOLT doesn't understand default GPOS feature; setting ignored ($s/$l).\n") if ($gpos && $gpos->{'SCRIPTS'}{$s}{$l}{'DEFAULT'} != 65535);
# For this script and language, compile list of features and iterate over them
# Note: there can be multiple instances of any given feature (e.g., "ccmp" then "ccmp _1", etc.)
# because the same feature tag can be (probably is) present under each language. However, VOLT
# knows them all as simply the 4 character tag (e.g., "ccmp")
my %feats;
# It is possible, but not likely, that we'll have a feature implemented by both gsub and gpos lookups.
# Therefore we use a slightly different technique than above to record what features are needed:
map {$feats{substr($_,0,4)} .= "|S$_" } (@{$gsub->{'SCRIPTS'}{$s}{$l}{'FEATURES'}} ) if $gsub;
map {$feats{substr($_,0,4)} .= "|P$_"} (@{$gpos->{'SCRIPTS'}{$s}{$l}{'FEATURES'}} ) if $gpos;
foreach $f (sort keys %feats)
{
$SLFText .= "DEF_FEATURE ";
$SLFText .= "NAME \"$ttnames{'FEATURE'}{$f}\" " if defined $ttnames{'FEATURE'}{$f};
$SLFText .= "TAG \"$f\"\n";
foreach ( $feats{$f} =~ /\|([^|]+)/g)
{
my ($which, $actualfeat) = ($_ =~ /^(.)(.*)$/);
# At this point $which is either 'S' or 'P' (for gsub or gpos), and
# $actualfeat is the full feature name, e.g., "ccmp _1".
my $tbl = ($which eq 'S' ? $gsub : $gpos);
foreach my $lid (@{$tbl->{'FEATURES'}{$actualfeat}{'LOOKUPS'}})
{
unless ($tbl->{'-LookupsNeeded'}[$lid])
{
# One time processing for this lookup:
# Make sure we remember to include this one in DEF_LOOKUPs:
$tbl->{'-LookupsNeeded'}[$lid] = 1;
# Give it a name:
$tbl->{'LOOKUP'}[$lid]{'-name'} = "$f" . "_$which$lid";
# If this is a chaining context lookup, we need to coalesce subtables.
CoalesceChainContextSubtables ($tbl->{'LOOKUP'}[$lid],$tbl) if $tbl->{'LOOKUP'}[$lid]{'TYPE'} == ($which eq 'S' ? 6 : 8);
}
my $nsubs = scalar (@{$tbl->{'LOOKUP'}[$lid]{'SUB'}}); # Number of subtables
my $lname = $tbl->{'LOOKUP'}[$lid]{'-name'};
foreach (0 .. $nsubs-1)
{
$SLFText .= " LOOKUP \"$lname" . ($nsubs > 1 ? "\\$_" : '') . "\"";
}
}
}
$SLFText .= "\nEND_FEATURE\n";
}
$SLFText .= "END_LANGSYS\n";
}
$SLFText .= "END_SCRIPT\n";
}
# Now we know what lookups we need to process, let's do it:
foreach my $i (0 .. $#{$gsub->{'-LookupsNeeded'}})
{
ProcessGSUBLookup $i if $gsub->{'-LookupsNeeded'}[$i];
}
foreach my $i (0 .. $#{$gpos->{'-LookupsNeeded'}})
{
ProcessGPOSLookup $i if $gpos->{'-LookupsNeeded'}[$i];
}
# OK, now we can collect everything together
my $vtp;
# print GLYPH definitions:
foreach $gid (sort {$a <=> $b} keys %GlyphFromID)
{
$g = $GlyphFromID{$gid};
$vtp .= "DEF_GLYPH \"" . NameFromID($gid) . "\" ID $gid";
if (exists $g->{'@UNICODES'}) {
# If array contains exactly one value, output UNICODE in gdef, else must output UNICODEVALUES
if (scalar (@{$g->{'@UNICODES'}}) == 1) {
$vtp .= sprintf (" UNICODE %d", $g->{'@UNICODES'}[0]);
} else {
$vtp .= sprintf (" UNICODEVALUES \"%s\"", join (",", map {sprintf "U+%04X", $_} @{$g->{'@UNICODES'}}));
}
}
$vtp .= " TYPE " . (exists $g->{'TYPE'} ? $g->{'TYPE'} : "BASE");
if ($g->{'TYPE'} eq "LIGATURE")
{
if (exists $g->{'COMPONENTS'})
{
$vtp .= " COMPONENTS $g->{'COMPONENTS'}" ;
}
else
{
MyWarn ("Glyph $gid is a ligature, but I don't know how many components it has.\n");
}
}
$vtp .= " END_GLYPH\n";
}
# print Script/Language/Features:
$vtp .= $SLFText;
# print GROUP definitions:
foreach $g (GetGroupNames)
{
$vtp .= "DEF_GROUP \"$g\"\n ENUM";
map {$vtp .= " GLYPH \"$GlyphFromID{$_}->{'NAME'}\"" } GetGroup($g);
$vtp .= " END_ENUM\nEND_GROUP\n";
}
# print lookups:
$vtp .= $LookupText;
# print anchors
foreach $gid (sort {$a <=> $b} keys %GlyphFromID)
{
my $g = $GlyphFromID{$gid};
foreach my $apname (sort keys %{$g->{'ANCHORS'}})
{
my ($anchors, $component);
if (ref $g->{'ANCHORS'}{$apname} eq 'ARRAY')
{ $anchors = $g->{'ANCHORS'}{$apname}; }
else
{ $anchors = [ $g->{'ANCHORS'}{$apname} ];}
for $component (1 .. $#{$anchors}+1)
{
my $anchor = $anchors->[$component-1];
for (qw(xid yid p xdev ydev))
{
MyWarn "Glyph anchor field '$_' not implemented -- being ignored.\n" if exists $anchor->{$_};
}
$vtp .= "DEF_ANCHOR \"$apname\" ON $gid GLYPH ". NameFromID($gid) . " COMPONENT $component LOCKED AT POS DX $anchor->{'x'} DY $anchor->{'y'} END_POS END_ANCHOR\n";
}
}
}
# print PPM text:
$vtp .= "GRID_PPEM 20\nPRESENTATION_PPEM 72\nPPOSITIONING_PPEM 144";
# print cmap info:
foreach (sort { $a->{'Platform'} <=> $b->{'Platform'} } @{$font->{'cmap'}{'Tables'}})
{
$vtp .= "\nCMAP_FORMAT $_->{'Platform'} $_->{'Encoding'} $_->{'Format'} ";
}
$vtp .= "END\n";
# Write out results
if (defined $ARGV[1])
{
# Write out new font:
# Insert the replacement source into the font
# Create, if it doesn't exist, the VOLT source table we are going to insert
$font->{'TSIV'} = Font::TTF::Table->new (PARENT => $font, NAME => 'TSIV') unless exists $font->{'TSIV'};
# Replace source:
$font->{'TSIV'}->{' dat'} = $vtp;
# Remove other VOLT tables if they exist:
for (qw( TSID TSIP TSIS )) { delete $font->{$_} };
unless ($opt_r)
{
# Remove compiled tables if they exist:
for (qw( GDEF GPOS GSUB)) { delete $font->{$_} };
}
$font->out($ARGV[1]);
}
if (defined $opt_v)
{
# Open output source file:
open (OUT, ">$opt_v") or die "Couldn't open '$opt_v' for writing.";
print OUT $vtp;
close OUT;
}
my $xx;
$xx = "\nFINISHED. ";
$xx .= ($warningCount > 0 ? $warningCount : "No") . " warning" . ($warningCount == 1 ? '' : 's') . " issued. ";
$xx .= ($genericCount > 0 ? $genericCount : "No") . " unnamed glyph" . ($genericCount == 1 ? '' : 's') . " used. \n\n";
if ($opt_l)
{
print LOG $xx;
close LOG;
}
print STDERR $xx;
#])}