libfont-ttf-perl 1.05-1 / usr / share / perl5 / Font / TTF / Ttopen.pm

package Font::TTF::Ttopen;

=head1 NAME

Font::TTF::Ttopen - Opentype superclass for standard Opentype lookup based tables
(GSUB and GPOS)

=head1 DESCRIPTION

Handles all the script, lang, feature, lookup stuff for a
L<Font::TTF::Gsub>/L<Font::TTF::Gpos> table leaving the class specifics to the
subclass

=head1 INSTANCE VARIABLES

The instance variables of an opentype table form a complex sub-module hierarchy.

=over 4

=item Version

This contains the version of the table as a floating point number

=item SCRIPTS

The scripts list is a hash of script tags. Each script tag (of the form
$t->{'SCRIPTS'}{$tag}) has information below it.

=over 8

=item OFFSET

This variable is preceded by a space and gives the offset from the start of the
table (not the table section) to the script table for this script

=item REFTAG

This variable is preceded by a space and gives a corresponding script tag to this
one such that the offsets in the file are the same. When writing, it is up to the
caller to ensure that the REFTAGs are set correctly, since these will be used to
assume that the scripts are identical. Note that REFTAG must refer to a script which
has no REFTAG of its own.

=item DEFAULT

This corresponds to the default language for this script, if there is one, and
contains the same information as an itemised language

=item LANG_TAGS

This contains an array of language tag strings (each 4 bytes) corresponding to
the languages listed by this script

=item $lang

Each language is a hash containing its information:

=over 12

=item OFFSET

This variable is preceded by a a space and gives the offset from the start of
the whole table to the language table for this language

=item REFTAG

This variable is preceded by a space and has the same function as for the script
REFTAG, only for the languages within a script.

=item RE-ORDER

This indicates re-ordering information, and has not been set. The value should
always be 0.

=item DEFAULT

This holds the index of the default feature, if there is one, or -1 otherwise.

=item FEATURES

This is an array of feature tags for all the features enabled for this language

=back

=back

=item FEATURES

The features section of instance variables corresponds to the feature table in
the opentype table.

=over 8

=item FEAT_TAGS

This array gives the ordered list of feature tags for this table. It is used during
reading and writing for converting between feature index and feature tag.

=back

The rest of the FEATURES variable is itself a hash based on the feature tag for
each feature. Each feature has the following structure:

=over 8

=item OFFSET

This attribute is preceded by a space and gives the offset relative to the start of the whole
table of this particular feature.

=item PARMS

If FeatureParams are defined for this feature, this contains a reference to the corresponding FeatureParams object.  Otherwise set to null.

=item LOOKUPS

This is an array containing indices to lookups in the LOOKUP instance variable of the table

=item INDEX

This gives the feature index for this feature and is used during reading and writing for
converting between feature tag and feature index.

=back

=item LOOKUP

This variable is an array of lookups in order and is indexed via the features of a language of a
script. Each lookup contains subtables and other information:

=over 8

=item OFFSET

This name is preceded by a space and contains the offset from the start of the table to this
particular lookup

=item TYPE

This is a subclass specific type for a lookup. It stipulates the type of lookup and hence subtables
within the lookup

=item FLAG

Holds the lookup flag bits

=item FILTER

Holds the MarkFilteringSet (that is, the index into GDEF->MARKSETS) for the lookup.

=item SUB

This holds an array of subtables which are subclass specific. Each subtable must have
an OFFSET. The other variables described here are an abstraction used in both the
GSUB and GPOS tables which are the target subclasses of this class.

=over 12

=item OFFSET

This is preceded by a space and gives the offset relative to the start of the table for this
subtable

=item FORMAT

Gives the sub-table sub format for this GSUB subtable. It is assumed that this
value is correct when it comes time to write the subtable.

=item COVERAGE

Most lookups consist of a coverage table corresponding to the first
glyph to match. The offset of this coverage table is stored here and the coverage
table looked up against the GSUB table proper. There are two lookups
without this initial coverage table which is used to index into the RULES array.
These lookups have one element in the RULES array which is used for the whole
match.

=item RULES

The rules are a complex array. In most cases, each element of the array 
corresponds to an element in the coverage table (governed by the coverage index). 
In a few caess, such as when there is
no coverage table, then there is considered to be only one element in the rules
array. Each element of the array is itself an array corresponding to the
possibly multiple string matches which may follow the initial glyph. Each
element of this array is a hash with fixed keys corresponding to information
needed to match a glyph string or act upon it. Thus the RULES element is an
array of arrays of hashes which contain the following keys:

=over 16

=item MATCH

This contains a sequence of elements held as an array. The elements may be
glyph ids (gid), class ids (cids), or offsets to coverage tables. Each element
corresponds to one glyph in the glyph string. See MATCH_TYPE for details of
how the different element types are marked.

=item PRE

This array holds the sequence of elements preceding the first match element
and has the same form as the MATCH array.

=item POST

This array holds the sequence of elements to be tested for following the match
string and is of the same form as the MATCH array.

=item ACTION

This array holds information regarding what should be done if a match is found.
The array may either hold glyph ids (which are used to replace or insert or
whatever glyphs in the glyph string) or 2 element arrays consisting of:

=over 20

=item OFFSET

Offset from the start of the matched string that the lookup should start at
when processing the substring.

=item LOOKUP_INDEX

The index to a lookup to be acted upon on the match string.

=back

=back

=item CLASS

For those lookups which use class categories rather than glyph ids for matching
this is the offset to the class definition used to categories glyphs in the
match string.

=item PRE_CLASS

This is the offset to the class definition for the before match glyphs

=item POST_CLASS

This is the offset to the class definition for the after match glyphs.

=item ACTION_TYPE

This string holds the type of information held in the ACTION variable of a RULE.
It is subclass specific.

=item MATCH_TYPE

This holds the type of information in the MATCH array of a RULE. This is subclass
specific.

=item ADJUST

This corresponds to a single action for all items in a coverage table. The meaning
is subclass specific.

=item CACHE

This key starts with a space

A hash of other tables (such as coverage tables, classes, anchors, device tables)
based on the offset given in the subtable to that other information.
Note that the documentation is particularly
unhelpful here in that such tables are given as offsets relative to the
beginning of the subtable not the whole GSUB table. This includes those items which
are stored relative to another base within the subtable.

=back

=back

=back

=head1 METHODS

=cut

use Font::TTF::Table;
use Font::TTF::Utils;
use Font::TTF::Coverage;

use strict;
use vars qw(@ISA %FeatParams);

@ISA = qw(Font::TTF::Table);

%FeatParams = (
    'ss' => 'Font::TTF::Features::Sset',
  'cv' => 'Font::TTF::Features::Cvar',
  'si' => 'Font::TTF::Features::Size',
  );

=head2 $t->read

Reads the table passing control to the subclass to handle the subtable specifics

=cut

sub read
{
    my ($self) = @_;
    $self->SUPER::read or return $self;

    my ($dat, $i, $l, $oScript, $oFeat, $oLook, $tag, $nScript, $off, $dLang, $nLang, $lTag);
    my ($nFeat, $oParms, $FType, $nLook, $nSub, $j, $temp, $t);
    my ($fh) = $self->{' INFILE'};
    my ($moff) = $self->{' OFFSET'};

    $fh->read($dat, 10);
    ($self->{'Version'}, $oScript, $oFeat, $oLook) = TTF_Unpack("vSSS", $dat);

# read features first so that in the script/lang hierarchy we can use feature tags

    $fh->seek($moff + $oFeat, 0);
    $fh->read($dat, 2);
    $nFeat = unpack("n", $dat);
    $self->{'FEATURES'} = {};
    $l = $self->{'FEATURES'};
    $fh->read($dat, 6 * $nFeat);
    for ($i = 0; $i < $nFeat; $i++)
    {
        ($tag, $off) = unpack("a4n", substr($dat, $i * 6, 6));
        while (defined $l->{$tag})
        {
            if ($tag =~ m/(.*?)\s_(\d+)$/o)
            { $tag = $1 . " _" . ($2 + 1); }
            else
            { $tag .= " _0"; }
        }
        $l->{$tag}{' OFFSET'} = $off + $oFeat;
        $l->{$tag}{'INDEX'} = $i;
        push (@{$l->{'FEAT_TAGS'}}, $tag);
    }

    foreach $tag (grep {m/^.{4}(?:\s_\d+)?$/o} keys %$l)
    {
        $oFeat=$moff + $l->{$tag}{' OFFSET'};
        $fh->seek($oFeat, 0);
        $fh->read($dat, 4);
        ($oParms, $nLook) = unpack("n2", $dat);
        $fh->read($dat, $nLook * 2);
        $l->{$tag}{'LOOKUPS'} = [unpack("n*", $dat)];
        $l->{$tag}{'PARMS'}="";
        if ($oParms > 0)
        {
            $FType=$FeatParams{substr($tag,0,2)};
            if ($FType)
            {
                $t=$FType;
                if ($^O eq "MacOS")
                    { $t =~ s/^|::/:/oig; }
                else
                    { $t =~ s|::|/|oig; }
                    require "$t.pm";
                $l->{$tag}{'PARMS'} = $FType->new( INFILE  => $fh,
                                                                                     OFFSET => $oFeat+$oParms);
            $l->{$tag}{'PARMS'}->read;
          }
        }               
        
    }

# Now the script/lang hierarchy

    $fh->seek($moff + $oScript, 0);
    $fh->read($dat, 2);
    $nScript = unpack("n", $dat);
    $self->{'SCRIPTS'} = {};
    $l = $self->{'SCRIPTS'};
    $fh->read($dat, 6 * $nScript);
    for ($i = 0; $i < $nScript; $i++)
    {
        ($tag, $off) = unpack("a4n", substr($dat, $i * 6, 6));
        $off += $oScript;
        foreach (keys %$l)
        { $l->{$tag}{' REFTAG'} = $_ if ($l->{$_}{' OFFSET'} == $off
                                        && !defined $l->{$_}{' REFTAG'}); }
        $l->{$tag}{' OFFSET'} = $off;
    }

    foreach $tag (keys %$l)
    {
        next if ($l->{$tag}{' REFTAG'});
        $fh->seek($moff + $l->{$tag}{' OFFSET'}, 0);
        $fh->read($dat, 4);
        ($dLang, $nLang) = unpack("n2", $dat);
        $l->{$tag}{'DEFAULT'}{' OFFSET'} =
                $dLang + $l->{$tag}{' OFFSET'} if $dLang;
        $fh->read($dat, 6 * $nLang);
        for ($i = 0; $i < $nLang; $i++)
        {
            ($lTag, $off) = unpack("a4n", substr($dat, $i * 6, 6));
            $off += $l->{$tag}{' OFFSET'};
            $l->{$tag}{$lTag}{' OFFSET'} = $off;
            foreach (@{$l->{$tag}{'LANG_TAGS'}}, 'DEFAULT')
            { $l->{$tag}{$lTag}{' REFTAG'} = $_ if ($l->{$tag}{$_}{' OFFSET'} == $off
                                                   && !$l->{$tag}{$_}{' REFTAG'}); }
            push (@{$l->{$tag}{'LANG_TAGS'}}, $lTag);
        }
        foreach $lTag (@{$l->{$tag}{'LANG_TAGS'}}, 'DEFAULT')
        {
            next unless defined $l->{$tag}{$lTag};
            next if ($l->{$tag}{$lTag}{' REFTAG'});
            $fh->seek($moff + $l->{$tag}{$lTag}{' OFFSET'}, 0);
            $fh->read($dat, 6);
            ($l->{$tag}{$lTag}{'RE-ORDER'}, $l->{$tag}{$lTag}{'DEFAULT'}, $nFeat) 
              = unpack("n3", $dat);
            $fh->read($dat, $nFeat * 2);
            $l->{$tag}{$lTag}{'FEATURES'} = [map {$self->{'FEATURES'}{'FEAT_TAGS'}[$_]} unpack("n*", $dat)];
        }
        foreach $lTag (@{$l->{$tag}{'LANG_TAGS'}}, 'DEFAULT')
        {
            # Make copies of referenced languages for each reference. 
            next unless $l->{$tag}{$lTag}{' REFTAG'};
            $temp = $l->{$tag}{$lTag}{' REFTAG'};
            $l->{$tag}{$lTag} = &copy($l->{$tag}{$temp});
            $l->{$tag}{$lTag}{' REFTAG'} = $temp;
        }
    }
    foreach $tag (keys %$l)
    {
        next unless $l->{$tag}{' REFTAG'};
        $temp = $l->{$tag}{' REFTAG'};
        $l->{$tag} = &copy($l->{$temp});
        $l->{$tag}{' REFTAG'} = $temp;
    }

# And finally the lookups

    $fh->seek($moff + $oLook, 0);
    $fh->read($dat, 2);
    $nLook = unpack("n", $dat);
    $fh->read($dat, $nLook * 2);
    $i = 0;
    map { $self->{'LOOKUP'}[$i++]{' OFFSET'} = $_; } unpack("n*", $dat);

    for ($i = 0; $i < $nLook; $i++)
    {
        $l = $self->{'LOOKUP'}[$i];
        $fh->seek($l->{' OFFSET'} + $moff + $oLook, 0);
        $fh->read($dat, 6);
        ($l->{'TYPE'}, $l->{'FLAG'}, $nSub) = unpack("n3", $dat);
        $fh->read($dat, $nSub * 2);
        my @offsets = unpack("n*", $dat);
        if ($l->{'FLAG'} & 0x0010)
        {
            $fh->read($dat, 2);
            $l->{'FILTER'} = unpack("n", $dat);
        }
        my $isExtension = ($l->{'TYPE'} == $self->extension());
        for ($j = 0; $j < $nSub; $j++)
        {
            $l->{'SUB'}[$j]{' OFFSET'} = $offsets[$j];
            $fh->seek($moff + $oLook + $l->{' OFFSET'} + $l->{'SUB'}[$j]{' OFFSET'}, 0);
            if ($isExtension)
            {
                $fh->read($dat, 8);
                my $longOff;
                (undef, $l->{'TYPE'}, $longOff) = unpack("nnN", $dat);
                $l->{'SUB'}[$j]{' OFFSET'} += $longOff;
                $fh->seek($moff + $oLook + $l->{' OFFSET'} + $l->{'SUB'}[$j]{' OFFSET'}, 0);
            }
            $self->read_sub($fh, $l, $j);
        }
    }
    return $self;
}

=head2 $t->read_sub($fh, $lookup, $index)

This stub is to allow subclasses to read subtables of lookups in a table specific manner. A
reference to the lookup is passed in along with the subtable index. The file is located at the
start of the subtable to be read

=cut

sub read_sub
{ }


=head2 $t->extension()

Returns the lookup number for the extension table that allows access to 32-bit offsets.

=cut

sub extension
{ }


=head2 $t->out($fh)

Writes this Opentype table to the output calling $t->out_sub for each sub table
at the appropriate point in the output. The assumption is that on entry the
number of scripts, languages, features, lookups, etc. are all resolved and
the relationships fixed. This includes a LANG_TAGS list for a script, and that all
scripts and languages in their respective dictionaries either have a REFTAG or contain
real data.

=cut

sub out
{
    my ($self, $fh) = @_;
    my ($i, $j, $base, $off, $tag, $t, $l, $lTag, $oScript, @script, @tags);
    my ($end, $nTags, @offs, $oFeat, $oFtable, $oParms, $FType, $oLook, $nSub, $nSubs, $big, $out);
    
    return $self->SUPER::out($fh) unless $self->{' read'};

# First sort the features
    $i = 0;
    $self->{'FEATURES'}{'FEAT_TAGS'} = [sort grep {m/^.{4}(?:\s_\d+)?$/o} %{$self->{'FEATURES'}}]
            if (!defined $self->{'FEATURES'}{'FEAT_TAGS'});
    foreach $t (@{$self->{'FEATURES'}{'FEAT_TAGS'}})
    { $self->{'FEATURES'}{$t}{'INDEX'} = $i++; }

    $base = $fh->tell();
    $fh->print(TTF_Pack("v", $self->{'Version'}));
    $fh->print(pack("n3", 10, 0, 0));
    $oScript = $fh->tell() - $base;
    @script = sort grep {length($_) == 4} keys %{$self->{'SCRIPTS'}};
    $fh->print(pack("n", $#script + 1));
    foreach $t (@script)
    { $fh->print(pack("a4n", $t, 0)); }

    $end = $fh->tell();
    foreach $t (@script)
    {
        $fh->seek($end, 0);
        $tag = $self->{'SCRIPTS'}{$t};
        next if ($tag->{' REFTAG'});
        $tag->{' OFFSET'} = tell($fh) - $base - $oScript;
        $fh->print(pack("n2", 0, $#{$tag->{'LANG_TAGS'}} + 1));
        foreach $lTag (sort @{$tag->{'LANG_TAGS'}})
        { $fh->print(pack("a4n", $lTag, 0)); }
        foreach $lTag (@{$tag->{'LANG_TAGS'}}, 'DEFAULT')
        {
            my ($def);
            $l = $tag->{$lTag};
            next if (!defined $l || (defined $l->{' REFTAG'} && $l->{' REFTAG'} ne ''));
            $l->{' OFFSET'} = $fh->tell() - $base - $oScript - $tag->{' OFFSET'};
            if (defined $l->{'DEFAULT'})
#           { $def = $self->{'FEATURES'}{$l->{'FEATURES'}[$l->{'DEFAULT'}]}{'INDEX'}; }
            { $def = $l->{'DEFAULT'}; }
            else
            { $def = -1; }
            $fh->print(pack("n*", $l->{'RE_ORDER'} || 0, $def, $#{$l->{'FEATURES'}} + 1,
                    map {$self->{'FEATURES'}{$_}{'INDEX'} || 0} @{$l->{'FEATURES'}}));
        }
        $end = $fh->tell();
        if ($tag->{'DEFAULT'}{' REFTAG'} || defined $tag->{'DEFAULT'}{'FEATURES'})
        {
            $fh->seek($base + $oScript + $tag->{' OFFSET'}, 0);
            if (defined $tag->{'DEFAULT'}{' REFTAG'})
            {
                my ($ttag);
                for ($ttag = $tag->{'DEFAULT'}{' REFTAG'}; defined $tag->{$ttag}{' REFTAG'}; $ttag = $tag->{$ttag}{' REFTAG'})
                { }
                $off = $tag->{$ttag}{' OFFSET'};
            }
            else
            { $off = $tag->{'DEFAULT'}{' OFFSET'}; }
            $fh->print(pack("n", $off));
        }
        $fh->seek($base + $oScript + $tag->{' OFFSET'} + 4, 0);
        foreach (sort @{$tag->{'LANG_TAGS'}})
        {
            if (defined $tag->{$_}{' REFTAG'})
            {
                my ($ttag);
                for ($ttag = $tag->{$_}{' REFTAG'}; defined $tag->{$ttag}{' REFTAG'}; $ttag = $tag->{$ttag}{' REFTAG'})
                { }
                $off = $tag->{$ttag}{' OFFSET'};
            }
            else
            { $off = $tag->{$_}{' OFFSET'}; }
            $fh->print(pack("a4n", $_, $off));
        }
    }
    $fh->seek($base + $oScript + 2, 0);
    foreach $t (@script)
    {
        $tag = $self->{'SCRIPTS'}{$t};
        $off = $tag->{' REFTAG'} ? $tag->{$tag->{' REFTAG'}}{' OFFSET'} : $tag->{' OFFSET'};
        $fh->print(pack("a4n", $t, $off));
    }

    $fh->seek($end, 0);
    $oFeat = $end - $base;
    $nTags = $#{$self->{'FEATURES'}{'FEAT_TAGS'}} + 1;
    $fh->print(pack("n", $nTags));
    $fh->print(pack("a4n", "    ", 0) x $nTags);
    
    foreach $t (@{$self->{'FEATURES'}{'FEAT_TAGS'}})
    {
        $tag = $self->{'FEATURES'}{$t};
        $oFtable = tell($fh) - $base - $oFeat;
        $tag->{' OFFSET'} = $oFtable;
        $fh->print(pack("n*", 0, $#{$tag->{'LOOKUPS'}} + 1, @{$tag->{'LOOKUPS'}}));
        if ($tag->{'PARMS'})
        {
            $end = $fh->tell();
            $oParms = $end - $oFtable - $base - $oFeat;
            $fh->seek($oFtable + $base + $oFeat,0);
            $fh->print(pack("n",$oParms));
            $fh->seek($end,0);
            $tag->{'PARMS'}->out($fh);
        }
    }
    $end = $fh->tell();
    $fh->seek($oFeat + $base + 2, 0);
    foreach $t (@{$self->{'FEATURES'}{'FEAT_TAGS'}})
    { $fh->print(pack("a4n", $t, $self->{'FEATURES'}{$t}{' OFFSET'})); }

    undef $big;
    $fh->seek($end, 0);
    $oLook = $end - $base;
    
    # LookupListTable (including room for offsets to LookupTables)
    $nTags = $#{$self->{'LOOKUP'}} + 1;
    $fh->print(pack("n", $nTags));
    $fh->print(pack("n", 0) x $nTags);
    $end = $fh->tell();     # end of LookupListTable = start of Lookups
    foreach $tag (@{$self->{'LOOKUP'}})
    { $nSubs += $self->num_sub($tag); }
    for ($i = 0; $i < $nTags; $i++)
    {
        $fh->seek($end, 0);
        $tag = $self->{'LOOKUP'}[$i];
        $off = $end - $base - $oLook;   # BH 2004-03-04
        # Is there room, from the start of this i'th lookup, for this and the remaining
        # lookups to be wrapped in extension lookups?
        if (!defined $big && $off + ($nTags - $i) * 6 + $nSubs * 10 > 65535) # BH 2004-03-04
        {
            # Not enough room -- need to start an extension!            
            my ($k, $ext);
            $ext = $self->extension();
            # Must turn previous lookup into the first extension
            $i--;
            $tag = $self->{'LOOKUP'}[$i];
            $end = $tag->{' OFFSET'} + $base + $oLook;
            $fh->seek($end, 0);
            $big = $i;
            # For this and the remaining lookups, build extensions lookups
            for ($j = $i; $j < $nTags; $j++)
            {
                $tag = $self->{'LOOKUP'}[$j];
                $nSub = $self->num_sub($tag);
                $tag->{' OFFSET'} = $fh->tell() - $base - $oLook; # offset to this extension lookup
                # LookupTable (including actual offsets to subtables)
                $fh->print(pack("nnn", $ext, $tag->{'FLAG'}, $nSub));
                $fh->print(pack("n*", map {6 + $nSub * 2 + $_ * 8 + $tag->{'FLAG'} & 0x0010 ? 2 : 0 } (0 .. $nSub-1)));
                $fh->print(pack("n", $tag->{'FILTER'})) if $tag->{'FLAG'} & 0x0010;
                $tag->{' EXT_OFFSET'} = $fh->tell();    # = first extension lookup subtable
                for ($k = 0; $k < $nSub; $k++)
                { $fh->print(pack('nnN', 1, $tag->{'TYPE'}, 0)); }
            }
            
            $tag = $self->{'LOOKUP'}[$i];
            # Leave file positioned after all the extension lookups -- where the referenced lookups will start.
        }
        $tag->{' OFFSET'} = $off unless defined $big;   # BH 2004-03-04
        $nSub = $self->num_sub($tag);
        if (!defined $big)
        {
            # LookupTable (including room for subtable offsets)
            $fh->print(pack("nnn", $tag->{'TYPE'}, $tag->{'FLAG'}, $nSub));
            $fh->print(pack("n", 0) x $nSub);
            $fh->print(pack("n", $tag->{'FILTER'})) if $tag->{'FLAG'} & 0x0010;
        }
        else
        { $end = $tag->{' EXT_OFFSET'}; } # Extension offsets computed relative to start of first Extension subtable -- corrected later
        my (@offs, $out, @refs);
        for ($j = 0; $j < $nSub; $j++)
        {
            my ($ctables) = {};
            my ($base) = length($out);
            push(@offs, tell($fh) - $end + $base);
            $out .= $self->out_sub($fh, $tag, $j, $ctables, $base);
            push (@refs, [$ctables, $base]);
        }
        out_final($fh, $out, \@refs);
        $end = $fh->tell();
        if (!defined $big)
        {
            $fh->seek($tag->{' OFFSET'} + $base + $oLook + 6, 0);
            $fh->print(pack("n*", @offs));
        }
        else
        {
            $fh->seek($tag->{' EXT_OFFSET'}, 0);
            for ($j = 0; $j < $nSub; $j++)
            { $fh->print(pack('nnN', 1, $tag->{'TYPE'}, $offs[$j] - $j * 8)); }
        }
    }
    $fh->seek($oLook + $base + 2, 0);
    $fh->print(pack("n*", map {$self->{'LOOKUP'}[$_]{' OFFSET'}} (0 .. $nTags - 1)));
    $fh->seek($base + 6, 0);
    $fh->print(pack('n2', $oFeat, $oLook));
    $fh->seek($end, 0);
    $self;
}


=head2 $t->num_sub($lookup)

Asks the subclass to count the number of subtables for a particular lookup and to
return that value. Used in out().

=cut

sub num_sub
{
    my ($self, $lookup) = @_;

    return $#{$lookup->{'SUB'}} + 1;
}


=head2 $t->out_sub($fh, $lookup, $index)

This stub is to allow subclasses to output subtables of lookups in a table specific manner. A
reference to the lookup is passed in along with the subtable index. The file is located at the
start of the subtable to be output

=cut

sub out_sub
{ }

=head2 $t->dirty

Setting GPOS or GSUB dirty means that OS/2 may need updating, so set it dirty.

=cut

sub dirty
{
    my ($self, $val) = @_;
    my $res = $self->SUPER::dirty ($val);
    $self->{' PARENT'}{'OS/2'}->read->dirty($val) if exists $self->{' PARENT'}{'OS/2'};
    $res;
}

=head2 $t->maxContext

Returns the length of the longest opentype rule in this table.

=cut

sub maxContext
{
    my ($self) = @_;
    
    # Make sure table is read
    $self->read;

    # Calculate my contribution to OS/2 usMaxContext
    
    my ($maxcontext, $l, $s, $r, $m);
   
    for $l (@{$self->{'LOOKUP'}})        # Examine each lookup
    {
        for $s (@{$l->{'SUB'}})         # Multiple possible subtables for this lookup
        {
            for $r (@{$s->{'RULES'}})   # One ruleset for each covered glyph
            {
                for $m (@{$r})          # Multiple possible matches for this covered glyph 
                {
                    my $lgt;
                    $lgt++ if exists $s->{'COVERAGE'};  # Count 1 for the coverage table if it exists
                    for (qw(MATCH POST))                # only Input and Lookahead sequences count (Lookbehind doesn't) -- see OT spec.
                    {
                        $lgt += @{$m->{$_}} if exists $m->{$_};
                    }
                    $maxcontext = $lgt if $lgt > $maxcontext;
                }
            }
            
        }
    }
    
    $maxcontext;    
}    


=head2 $t->update

Perform various housekeeping items:

For all lookups, set/clear 0x0010 bit of flag words based on 'FILTER' value.

Sort COVERAGE table and RULES for all lookups.

Unless $t->{' PARENT'}{' noharmony'} is true, update will make sure that GPOS and GSUB include 
the same scripts and languages. Any added scripts and languages will have empty feature sets.

=cut

# Assumes we are called on both GSUB and GPOS. So simply ADDS scripts and languages to $self that it finds
# in the other table.

sub update
{
    my ($self) = @_;
    
    return undef unless ($self->SUPER::update);
    
    if (defined ($self->{'LOOKUP'}))
    {
            
        # make flag word agree with mark filter setting:
        for my $l (@{$self->{'LOOKUP'}})
        {
            if (defined $l->{'FILTER'})
            { $l->{'FLAG'} |= 0x0010; }
            else
            { $l->{'FLAG'} &= ~0x0010; }
        }
        
        unless ($Font::TTF::Coverage::dontsort)
        {
            # Sort coverage tables and rules of all lookups by glyphID
            # The lookup types that need to be sorted are:
            #    GSUB: 1.2 2 3 4 5.1 6.1 8    (However GSUB type 8 lookups are not yet supported by Font::TTF)
            #    GPOS: 1.2 2.1 3 4 5 6 7.1 8.1
            
            for my $l (@{$self->{'LOOKUP'}})
            {
                next unless defined $l->{'SUB'};
                for my $sub (@{$l->{'SUB'}})
                {
                    if (defined $sub->{'COVERAGE'} and $sub->{'COVERAGE'}{'cover'} and !$sub->{'COVERAGE'}{'dontsort'})
                    {
                        # OK! Found a lookup with coverage table:
                        my @map = $sub->{'COVERAGE'}->sort();
                        if (defined $sub->{'RULES'} and ($sub->{'MATCH_TYPE'} =~ /g/ or $sub->{'ACTION_TYPE'} =~ /[gvea]/))
                        {
                            # And also a RULES table which now needs to be re-sorted
                            my $newrules = [];
                            foreach (0 .. $#map)
                            { push @{$newrules}, $sub->{'RULES'}[$map[$_]]; }
                            $sub->{'RULES'} = $newrules;
                        }
                    }
                        
                    # Special case for Mark positioning -- need to also sort the MarkArray
                    if (exists($sub->{'MARKS'}) and ref($sub->{'MATCH'}[0]) =~ /Cover/ and $sub->{'MATCH'}[0]{'cover'} and !$sub->{'MATCH'}[0]{'dontsort'})
                    {
                        my @map = $sub->{'MATCH'}[0]->sort();
                        my $newmarks = [];
                        foreach (0 .. $#map)
                        { push @{$newmarks}, $sub->{'MARKS'}[$map[$_]]; }
                        $sub->{'MARKS'} = $newmarks;
                    }
                }
            }
        }
    }

    # Enforce script/lang congruence unless asked not to:
    return $self if $self->{' PARENT'}{' noharmony'};

    # Find my sibling (GSUB or GPOS, depending on which I am)
    my $sibling = ref($self) eq 'Font::TTF::GSUB' ? 'GPOS' : ref($self) eq 'Font::TTF::GPOS' ? 'GSUB' : undef;
    return $self unless $sibling && defined $self->{' PARENT'}{$sibling};
    $sibling = $self->{' PARENT'}{$sibling};
    
    # Look through scripts defined in sibling:
    for my $sTag (grep {length($_) == 4} keys %{$sibling->{'SCRIPTS'}})
    {
        my $sibScript = $sibling->{'SCRIPTS'}{$sTag};
        $sibScript = $sibling->{$sibScript->{' REFTAG'}} if exists $sibScript->{' REFTAG'} && $sibScript->{' REFTAG'} ne '';
        
        $self->{'SCRIPTS'}{$sTag} = {} unless defined $self->{'SCRIPTS'}{$sTag}; # Create script if not present in $self
        
        my $myScript = $self->{'SCRIPTS'}{$sTag};
        $myScript = $self->{$myScript->{' REFTAG'}} if exists $myScript->{' REFTAG'} && $myScript->{' REFTAG'} ne '';
                
        foreach my $lTag (@{$sibScript->{'LANG_TAGS'}})
        {
            # Ok, found a script/lang that is in our sibling.
            next if exists $myScript->{$lTag};  # Already in $self
            
            # Need to create this lang:
            push @{$myScript->{'LANG_TAGS'}}, $lTag;
            $myScript->{$lTag} = { 'FEATURES' => [] };
        }

        if (defined $sibScript->{'DEFAULT'} && !defined $myScript->{'DEFAULT'})
        {
            # Create default lang for this script.
            $myScript->{'DEFAULT'} = { 'FEATURES' => [] };
        }
    }
    $self;
}

=head1 Internal Functions & Methods

Most of these methods are used by subclasses for handling such things as coverage
tables.

=head2 copy($ref)

Internal function to copy the top level of a dictionary to create a new dictionary.
Only the top level is copied.

=cut

sub copy
{
    my ($ref) = @_;
    my ($res) = {};

    foreach (keys %$ref)
    { $res->{$_} = $ref->{$_}; }
    $res;
}


=head2 $t->read_cover($cover_offset, $lookup_loc, $lookup, $fh, $is_cover)

Reads a coverage table and stores the results in $lookup->{' CACHE'}, that is, if
it has not been read already.

=cut

sub read_cover
{
    my ($self, $offset, $base, $lookup, $fh, $is_cover) = @_;
    my ($loc) = $fh->tell();
    my ($cover, $str);

    return undef unless $offset;
    $str = sprintf("%X", $base + $offset);
    return $lookup->{' CACHE'}{$str} if defined $lookup->{' CACHE'}{$str};
    $fh->seek($base + $offset, 0);
    $cover = Font::TTF::Coverage->new($is_cover)->read($fh);
    $fh->seek($loc, 0);
    $lookup->{' CACHE'}{$str} = $cover;
    return $cover;
}


=head2 ref_cache($obj, $cache, $offset [, $template])

Internal function to keep track of the local positioning of subobjects such as
coverage and class definition tables, and their offsets.
What happens is that the cache is a hash of
sub objects indexed by the reference (using a string mashing of the
reference name which is valid for the duration of the reference) and holds a
list of locations in the output string which should be filled in with the
offset to the sub object when the final string is output in out_final.

Uses tricks for Tie::Refhash

=cut

sub ref_cache
{
    my ($obj, $cache, $offset, $template) = @_;

    return 0 unless defined $obj;
    $template ||= 'n';
    unless (defined $cache->{"$obj"})
    { push (@{$cache->{''}}, $obj); }
    push (@{$cache->{"$obj"}}, [$offset, $template]);
    return 0;
}


=head2 out_final($fh, $out, $cache_list, $state)

Internal function to actually output everything to the file handle given that
now we know the offset to the first sub object to be output and which sub objects
are to be output and what locations need to be updated, we can now
generate everything. $cache_list is an array of two element arrays. The first element
is a cache object, the second is an offset to be subtracted from each reference
to that object made in the cache.

If $state is 1, then the output is not sent to the filehandle and the return value
is the string to be output. If $state is absent or 0 then output is not limited
by storing in a string first and the return value is "";

=cut

sub out_final
{
    my ($fh, $out, $cache_list, $state) = @_;
    my ($len) = length($out || '');
    my ($base_loc) = $state ? 0 : $fh->tell();
    my ($loc, $t, $r, $s, $master_cache, $offs, $str, %vecs);

    $fh->print($out || '') unless $state;       # first output the current attempt
    foreach $r (@$cache_list)
    {
        $offs = $r->[1];
        foreach $t (@{$r->[0]{''}})
        {
            $str = "$t";
            if (!defined $master_cache->{$str})
            {
                my ($vec) = $t->signature();
                if ($vecs{$vec})
                { $master_cache->{$str} = $master_cache->{$vecs{$vec}}; }
                else
                {
                    $vecs{$vec} = $str;
                    $master_cache->{$str} = ($state ? length($out) : $fh->tell())
                                                                       - $base_loc;
                    if ($state)
                    { $out .= $t->out($fh, 1); }
                    else
                    { $t->out($fh, 0); }
                }
            }
            foreach (@{$r->[0]{$str}})
            {
                $s = pack($_->[1], $master_cache->{$str} - $offs);
                substr($out, $_->[0], length($s)) = $s;
            }
        }
    }
    if ($state)
    { return $out; }
    else
    {
        $loc = $fh->tell();
        $fh->seek($base_loc, 0);
        $fh->print($out || '');       # the corrected version
        $fh->seek($loc, 0);
    }
}


=head2 $self->read_context($lookup, $fh, $type, $fmt, $cover, $count, $loc)

Internal method to read context (simple and chaining context) lookup subtables for
the GSUB and GPOS table types. The assumed values for $type correspond to those
for GSUB, so GPOS should adjust the values upon calling.

=cut

sub read_context
{
    my ($self, $lookup, $fh, $type, $fmt, $cover, $count, $loc) = @_;
    my ($dat, $i, $s, $t, @subst, @srec, $mcount, $scount);
    
    if ($type == 5 && $fmt < 3)
    {
        if ($fmt == 2)
        {
            $fh->read($dat, 2);
            $lookup->{'CLASS'} = $self->read_cover($count, $loc, $lookup, $fh, 0);
            $count = TTF_Unpack('S', $dat);
        }
        $fh->read($dat, $count << 1);
        foreach $s (TTF_Unpack('S*', $dat))
        {
            if ($s == 0)
            {
                push (@{$lookup->{'RULES'}}, []);
                next;
            }
            @subst = ();
            $fh->seek($loc + $s, 0);
            $fh->read($dat, 2);
            $t = TTF_Unpack('S', $dat);
            $fh->read($dat, $t << 1);
            foreach $t (TTF_Unpack('S*', $dat))
            {
                $fh->seek($loc + $s + $t, 0);
                @srec = ();
                $fh->read($dat, 4);
                ($mcount, $scount) = TTF_Unpack('S2', $dat);
                $mcount--;
                $fh->read($dat, ($mcount << 1) + ($scount << 2));
                for ($i = 0; $i < $scount; $i++)
                { push (@srec, [TTF_Unpack('S2', substr($dat,
                    ($mcount << 1) + ($i << 2), 4))]); }
                push (@subst, {'ACTION' => [@srec],
                               'MATCH' => [TTF_Unpack('S*',
                                    substr($dat, 0, $mcount << 1))]});
            }
            push (@{$lookup->{'RULES'}}, [@subst]);
        }
        $lookup->{'ACTION_TYPE'} = 'l';
        $lookup->{'MATCH_TYPE'} = ($fmt == 2 ? 'c' : 'g');
    } elsif ($type == 5 && $fmt == 3)
    {
        $fh->read($dat, ($cover << 1) + ($count << 2));
        @subst = (); @srec = ();
        for ($i = 0; $i < $cover; $i++)
        { push (@subst, $self->read_cover(TTF_Unpack('S', substr($dat, $i << 1, 2)),
                                $loc, $lookup, $fh, 1)); }
        for ($i = 0; $i < $count; $i++)
        { push (@srec, [TTF_Unpack('S2', substr($dat, ($count << 1) + ($i << 2), 4))]); }
        $lookup->{'RULES'} = [[{'ACTION' => [@srec], 'MATCH' => [@subst]}]];
        $lookup->{'ACTION_TYPE'} = 'l';
        $lookup->{'MATCH_TYPE'} = 'o';
    } elsif ($type == 6 && $fmt < 3)
    {
        if ($fmt == 2)
        {
            $fh->read($dat, 6);
            $lookup->{'PRE_CLASS'} = $self->read_cover($count, $loc, $lookup, $fh, 0) if $count;
            ($i, $mcount, $count) = TTF_Unpack('S3', $dat);     # messy: 2 classes & count
            $lookup->{'CLASS'} = $self->read_cover($i, $loc, $lookup, $fh, 0) if $i;
            $lookup->{'POST_CLASS'} = $self->read_cover($mcount, $loc, $lookup, $fh, 0) if $mcount;
        }
        $fh->read($dat, $count << 1);
        foreach $s (TTF_Unpack('S*', $dat))
        {
            if ($s == 0)
            {
                push (@{$lookup->{'RULES'}}, []);
                next;
            }
            @subst = ();
            $fh->seek($loc + $s, 0);
            $fh->read($dat, 2);
            $t = TTF_Unpack('S', $dat);
            $fh->read($dat, $t << 1);
            foreach $i (TTF_Unpack('S*', $dat))
            {
                $fh->seek($loc + $s + $i, 0);
                @srec = ();
                $t = {};
                $fh->read($dat, 2);
                $mcount = TTF_Unpack('S', $dat);
                if ($mcount > 0)
                {
                    $fh->read($dat, $mcount << 1);
                    $t->{'PRE'} = [TTF_Unpack('S*', $dat)];
                }
                $fh->read($dat, 2);
                $mcount = TTF_Unpack('S', $dat);
                if ($mcount > 1)
                {
                    $fh->read($dat, ($mcount - 1) << 1);
                    $t->{'MATCH'} = [TTF_Unpack('S*', $dat)];
                }
                $fh->read($dat, 2);
                $mcount = TTF_Unpack('S', $dat);
                if ($mcount > 0)
                {
                    $fh->read($dat, $mcount << 1);
                    $t->{'POST'} = [TTF_Unpack('S*', $dat)];
                }
                $fh->read($dat, 2);
                $scount = TTF_Unpack('S', $dat);
                $fh->read($dat, $scount << 2);
                for ($i = 0; $i < $scount; $i++)
                { push (@srec, [TTF_Unpack('S2', substr($dat, $i << 2))]); }
                $t->{'ACTION'} = [@srec];
                push (@subst, $t);
            }
            push (@{$lookup->{'RULES'}}, [@subst]);
        }
        $lookup->{'ACTION_TYPE'} = 'l';
        $lookup->{'MATCH_TYPE'} = ($fmt == 2 ? 'c' : 'g');
    } elsif ($type == 6 && $fmt == 3)
    {
        $t = {};
        unless ($cover == 0)
        {
            @subst = ();
            $fh->read($dat, $cover << 1);
            foreach $s (TTF_Unpack('S*', $dat))
            { push(@subst, $self->read_cover($s, $loc, $lookup, $fh, 1)); }
            $t->{'PRE'} = [@subst];
        }
        $fh->read($dat, 2);
        $count = TTF_Unpack('S', $dat);
        unless ($count == 0)
        {
            @subst = ();
            $fh->read($dat, $count << 1);
            foreach $s (TTF_Unpack('S*', $dat))
            { push(@subst, $self->read_cover($s, $loc, $lookup, $fh, 1)); }
            $t->{'MATCH'} = [@subst];
        }
        $fh->read($dat, 2);
        $count = TTF_Unpack('S', $dat);
        unless ($count == 0)
        {
            @subst = ();
            $fh->read($dat, $count << 1);
            foreach $s (TTF_Unpack('S*', $dat))
            { push(@subst, $self->read_cover($s, $loc, $lookup, $fh, 1)); }
            $t->{'POST'} = [@subst];
        }
        $fh->read($dat, 2);
        $count = TTF_Unpack('S', $dat);
        @subst = ();
        $fh->read($dat, $count << 2);
        for ($i = 0; $i < $count; $i++)
        { push (@subst, [TTF_Unpack('S2', substr($dat, $i << 2, 4))]); }
        $t->{'ACTION'} = [@subst];
        $lookup->{'RULES'} = [[$t]];
        $lookup->{'ACTION_TYPE'} = 'l';
        $lookup->{'MATCH_TYPE'} = 'o';
    }
    $lookup;
}


=head2 $self->out_context($lookup, $fh, $type, $fmt, $ctables, $out, $num)

Provides shared behaviour between GSUB and GPOS tables during output for context
(chained and simple) rules. In addition, support is provided here for type 4 GSUB
tables, which are not used in GPOS. The value for $type corresponds to the type
in a GSUB table so calling from GPOS should adjust the value accordingly.

=cut

sub out_context
{
    my ($self, $lookup, $fh, $type, $fmt, $ctables, $out, $num, $base) = @_;
    my ($offc, $offd, $i, $j, $r, $t, $numd);

    $out ||= '';
    if (($type == 4 || $type == 5 || $type == 6) && ($fmt == 1 || $fmt == 2))
    {
        my ($base_off);
        
        if ($fmt == 1)
        {
            $out = pack("nnn", $fmt, Font::TTF::Ttopen::ref_cache($lookup->{'COVERAGE'}, $ctables, 2 + $base),
                            $num);
            $base_off = 6;
        } elsif ($type == 5)
        {
            $out = pack("nnnn", $fmt, Font::TTF::Ttopen::ref_cache($lookup->{'COVERAGE'}, $ctables, 2 + $base),
                            Font::TTF::Ttopen::ref_cache($lookup->{'CLASS'}, $ctables, 4 + $base), $num);
            $base_off = 8;
        } elsif ($type == 6)
        {
            $out = pack("n6", $fmt, Font::TTF::Ttopen::ref_cache($lookup->{'COVERAGE'}, $ctables, 2 + $base),
                                Font::TTF::Ttopen::ref_cache($lookup->{'PRE_CLASS'}, $ctables, 4 + $base),
                                Font::TTF::Ttopen::ref_cache($lookup->{'CLASS'}, $ctables, 6 + $base),
                                Font::TTF::Ttopen::ref_cache($lookup->{'POST_CLASS'}, $ctables, 8 + $base),
                                $num);
            $base_off = 12;
        }

        $out .= pack('n*', (0) x $num);
        $offc = length($out);
        for ($i = 0; $i < $num; $i++)
        {
            $r = $lookup->{'RULES'}[$i];
            next unless exists $r->[0]{'ACTION'};
            $numd = $#{$r} + 1;
            substr($out, ($i << 1) + $base_off, 2) = pack('n', $offc);
            $out .= pack('n*', $numd, (0) x $numd);
            $offd = length($out) - $offc;
            for ($j = 0; $j < $numd; $j++)
            {
                substr($out, $offc + 2 + ($j << 1), 2) = pack('n', $offd);
                if ($type == 4)
                {
                    $out .= pack('n*', $r->[$j]{'ACTION'}[0], $#{$r->[$j]{'MATCH'}} + 2,
                                        @{$r->[$j]{'MATCH'}});
                } elsif ($type == 5)
                {
                    $out .= pack('n*', $#{$r->[$j]{'MATCH'}} + 2,
                                        $#{$r->[$j]{'ACTION'}} + 1,
                                        @{$r->[$j]{'MATCH'}});
                    foreach $t (@{$r->[$j]{'ACTION'}})
                    { $out .= pack('n2', @$t); }
                } elsif ($type == 6)
                {
                    $out .= pack('n*', $#{$r->[$j]{'PRE'}} + 1, @{$r->[$j]{'PRE'}},
                                    $#{$r->[$j]{'MATCH'}} + 2, @{$r->[$j]{'MATCH'}},
                                    $#{$r->[$j]{'POST'}} + 1, @{$r->[$j]{'POST'}},
                                    $#{$r->[$j]{'ACTION'}} + 1);
                    foreach $t (@{$r->[$j]{'ACTION'}})
                    { $out .= pack('n2', @$t); }
                }
                $offd = length($out) - $offc;
            }
            $offc = length($out);
        }
    } elsif ($type == 5 && $fmt == 3)
    {
        $out .= pack('n3', $fmt, $#{$lookup->{'RULES'}[0][0]{'MATCH'}} + 1,
                                $#{$lookup->{'RULES'}[0][0]{'ACTION'}} + 1);
        foreach $t (@{$lookup->{'RULES'}[0][0]{'MATCH'}})
        { $out .= pack('n', Font::TTF::Ttopen::ref_cache($t, $ctables, length($out) + $base)); }
        foreach $t (@{$lookup->{'RULES'}[0][0]{'ACTION'}})
        { $out .= pack('n2', @$t); }
    } elsif ($type == 6 && $fmt == 3)
    {
        $r = $lookup->{'RULES'}[0][0];
        no strict 'refs';   # temp fix - more code needed (probably "if" statements in the event 'PRE' or 'POST' are empty)
        $out .= pack('n2', $fmt, defined $r->{'PRE'} ? scalar @{$r->{'PRE'}} : 0);
        foreach $t (@{$r->{'PRE'}})
        { $out .= pack('n', Font::TTF::Ttopen::ref_cache($t, $ctables, length($out) + $base)); }
        $out .= pack('n', defined $r->{'MATCH'} ? scalar @{$r->{'MATCH'}} : 0);
        foreach $t (@{$r->{'MATCH'}})
        { $out .= pack('n', Font::TTF::Ttopen::ref_cache($t, $ctables, length($out) + $base)); }
        $out .= pack('n', defined $r->{'POST'} ? scalar @{$r->{'POST'}} : 0);
        foreach $t (@{$r->{'POST'}})
        { $out .= pack('n', Font::TTF::Ttopen::ref_cache($t, $ctables, length($out) + $base)); }
        $out .= pack('n', defined $r->{'ACTION'} ? scalar @{$r->{'ACTION'}} : 0);
        foreach $t (@{$r->{'ACTION'}})
        { $out .= pack('n2', @$t); }
    }
    $out;
}

1;


=head1 BUGS

=over 4

=item *

No way to share cachable items (coverage tables, classes, anchors, device tables)
across different lookups. The items are always output after the lookup and
repeated if necessary. Within lookup sharing is possible.

=back

=head1 AUTHOR

Martin Hosken L<http://scripts.sil.org/FontUtils>. 


=head1 LICENSING

Copyright (c) 1998-2014, SIL International (http://www.sil.org) 

This module is released under the terms of the Artistic License 2.0. 
For details, see the full text of the license in the file LICENSE.



=cut