libfont-ttf-perl 1.04-1 / usr / share / perl5 / Font / TTF / GDEF.pm

package Font::TTF::GDEF;

=head1 NAME

Font::TTF::GDEF - Opentype GDEF table support

=head1 DESCRIPTION

The GDEF table contains various global lists of information which are apparantly
used in other places in an OpenType renderer. But precisely where is open to
speculation...

=head1 INSTANCE VARIABLES

There are up to 5 tables in the GDEF table, each with their own structure:

=over 4

=item GLYPH

This is an L<Font::TTF::Coverage> Class Definition table containing information
as to what type each glyph is.

=item ATTACH

The attach table consists of a coverage table and then attachment points for
each glyph in the coverage table:

=over 8

=item COVERAGE

This is a coverage table

=item POINTS

This is an array of point elements. Each element is an array of curve points
corresponding to the attachment points on that glyph. The order of the curve points
in the array corresponds to the attachment point number specified in the MARKS
coverage table (see below).

=back

=item LIG

This contains the ligature caret positioning information for ligature glyphs

=over 8

=item COVERAGE

A coverage table to say which glyphs are ligatures

=item LIGS

An array of elements for each ligature. Each element is an array of information
for each caret position in the ligature (there being number of components - 1 of
these, generally)

=over 12

=item FMT

This is the format of the information and is important to provide the semantics
for the value. This value must be set correctly before output

=item VAL

The value which has meaning according to FMT

=item DEVICE

For FMT = 3, a device table is also referenced which is stored here

=back

=back

=item MARKS

This class definition table defines the classes of mark glyphs that can be selected
for processing using the MarkAttachmentType field of lookup FLAG words. 

=item MARKSETS

Contains an array of coverage tables indexed by the FILTER value of a lookup.

=back


=head1 METHODS

=cut

use strict;
use Font::TTF::Table;
use Font::TTF::Utils;
use Font::TTF::Ttopen;
use vars qw(@ISA $new_gdef);

@ISA = qw(Font::TTF::Table);
$new_gdef = 1;	# Prior to 2012-07, this config variable did more than it does today.
				# Currently all it does is force the GDEF to include a field in the
				# header for the MARKS class definition. That is, it makes sure the
				# font is compatible with at least the OT 1.2 specification.

=head2 $t->read

Reads the table into the data structure

=cut

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

    my ($fh) = $self->{' INFILE'};
    my ($boff) = $self->{' OFFSET'};
    my ($dat, $goff, $aoff, $loff, $macoff, $mgsoff, $r, $s, $bloc);

    $bloc = $fh->tell();
    $fh->read($dat, 10);
    ($self->{'Version'}, $goff, $aoff, $loff) = TTF_Unpack('LS3', $dat);
    
    # GDEF is the ONLY table that uses a ULONG for version rather than a Fixed or USHORT,
    # and this seems to clearly be a hack. 
    # OpenType 1.2 introduced MarkAttachClassDef but left the table version at 0x00010000
    # Up through OpenType 1.5, the Version field was typed as Fixed.
    # OpenType 1.6 introduced MarkGlyphSetsDef and bumped table version to 0x00010002 (sic)
    # and changed it to ULONG.
    
    
    # Thus some trickery here to read the table correctly!
    
    if ($self->{'Version'} > 0x00010000)
    {
    	# Ok, header guaranteed to have both MarAttachClassDef MarkGlyphSetsDef
        $fh->read($dat, 4);
        ($macoff, $mgsoff) = TTF_Unpack('S2', $dat);
    }
    else
    {
    	# What I've seen in other code (examples:
    	#     http://skia.googlecode.com/svn/trunk/third_party/harfbuzz/src/harfbuzz-gdef.c and
    	#     http://doxygen.reactos.org/d0/d55/otvalid_8h_a0487daffceceb98ba425bbf2806fbaff.html
    	# ) is to read GPOS and GDEF and see if any lookups have a
    	# MarkAttachType in the upper byte of their flag word and if so then assume that the
    	# MarkAttachClassDef field is in the header. While this is probably the most 
    	# reliable way to do it, it would require us to read GSUB and GPOS. 
    	# Prior to 2012-07 what we did is depend on our $new_gdef class variable to tell us
    	# whether to assume a MarkAttachClassDef. 
    	# What we do now is see if the header actually has room for the MarkAttachClassDef field.
    	
    	my $minOffset = $self->{' LENGTH'};
    	foreach ($goff, $aoff, $loff)
    	{
    		$minOffset = $_ if $_ > 0 && $_ < $minOffset;
    	}
    	if ($minOffset >= 12)
    	{
    		# There is room for the field, so read it:
		    $fh->read($dat, 2);
		    ($macoff) = TTF_Unpack('S', $dat);
		    # Sanity check:
		    $macoff = 0 if $macoff >= $self->{' LENGTH'};
		}
	}

    if ($goff > 0)
    {
        $fh->seek($goff + $boff, 0);
        $self->{'GLYPH'} = Font::TTF::Coverage->new(0)->read($fh);
    }

    if ($aoff > 0)
    {
        my ($off, $gcount, $pcount);
        
        $fh->seek($aoff + $boff, 0);
        $fh->read($dat, 4);
        ($off, $gcount) = TTF_Unpack('SS', $dat);
        $fh->read($dat, $gcount << 1);

        $fh->seek($aoff + $boff +  $off, 0);
        $self->{'ATTACH'}{'COVERAGE'} = Font::TTF::Coverage->new(1)->read($fh);

        foreach $r (TTF_Unpack('S*', $dat))
        {
            unless ($r)
            {
                push (@{$self->{'ATTACH'}{'POINTS'}}, []);
                next;
            }
            $fh->seek($aoff + $boff + $r, 0);
            $fh->read($dat, 2);
            $pcount = TTF_Unpack('S', $dat);
            $fh->read($dat, $pcount << 1);
            push (@{$self->{'ATTACH'}{'POINTS'}}, [TTF_Unpack('S*', $dat)]);
        }
    }

    if ($loff > 0)
    {
        my ($lcount, $off, $ccount, $srec, $comp);

        $fh->seek($loff + $boff, 0);
        $fh->read($dat, 4);
        ($off, $lcount) = TTF_Unpack('SS', $dat);
        $fh->read($dat, $lcount << 1);

        $fh->seek($off + $loff + $boff, 0);
        $self->{'LIG'}{'COVERAGE'} = Font::TTF::Coverage->new(1)->read($fh);

        foreach $r (TTF_Unpack('S*', $dat))
        {
            $fh->seek($r + $loff + $boff, 0);
            $fh->read($dat, 2);
            $ccount = TTF_Unpack('S', $dat);
            $fh->read($dat, $ccount << 1);

            $srec = [];
            foreach $s (TTF_Unpack('S*', $dat))
            {
                $comp = {};
                $fh->seek($s + $r + $loff + $boff, 0);
                $fh->read($dat, 4);
                ($comp->{'FMT'}, $comp->{'VAL'}) = TTF_Unpack('S*', $dat);
                if ($comp->{'FMT'} == 3)
                {
                    $fh->read($dat, 2);
                    $off = TTF_Unpack('S', $dat);
                    if (defined $self->{' CACHE'}{$off + $s + $r + $loff})
                    { $comp->{'DEVICE'} = $self->{' CACHE'}{$off + $s + $r + $loff}; }
                    else
                    {
                        $fh->seek($off + $s + $r + $loff + $boff, 0);
                        $comp->{'DEVICE'} = Font::TTF::Delta->new->read($fh);
                        $self->{' CACHE'}{$off + $s + $r + $loff} = $comp->{'DEVICE'};
                    }
                }
                push (@$srec, $comp);
            }
            push (@{$self->{'LIG'}{'LIGS'}}, $srec);
        }
    }

    if ($macoff > 0)
    {
        $fh->seek($macoff + $boff, 0);
        $self->{'MARKS'} = Font::TTF::Coverage->new(0)->read($fh);
    }
    
    if ($mgsoff > 0)
    {
    	my ($fmt, $count, $off);
    	$fh->seek($mgsoff + $boff, 0);
    	$fh->read($dat, 4);
    	($fmt, $count) = TTF_Unpack('SS', $dat);
    	# Sanity check opportunity: Could verify $fmt == 1, but I don't.
    	$self->{'MARKSETS'} = [];
    	$fh->read($dat, $count << 2);	# NB: These offets are ULONGs!
    	foreach $off (TTF_Unpack('L*', $dat))
    	{
            unless (defined $self->{' CACHE'}{$off + $mgsoff})
            {
                $fh->seek($off + $mgsoff + $boff, 0);
                $self->{' CACHE'}{$off + $mgsoff} = Font::TTF::Coverage->new(1)->read($fh);
            }
            push @{$self->{'MARKSETS'}}, $self->{' CACHE'}{$off + $mgsoff};
    	}
    }

    $self;
}


=head2 $t->out($fh)

Writes out this table.

=cut

sub out
{
    my ($self, $fh) = @_;
    my ($goff, $aoff, $loff, $macoff, $mgsoff, @offs, $loc1, $coff, $loc);

    return $self->SUPER::out($fh) unless $self->{' read'};

    $loc = $fh->tell();
    if (defined $self->{'MARKSETS'} && @{$self->{'MARKSETS'}} > 0)
    {
    	$self->{'Version'} = 0x00010002;
    	$fh->print(TTF_Pack('LSSSSS', $self->{'Version'}, 0, 0, 0, 0, 0));
    }
    else
    {
    	$self->{'Version'} = 0x00010000;
	    if ($new_gdef || defined $self->{'MARKS'})
	    { $fh->print(TTF_Pack('LSSSS', $self->{'Version'}, 0, 0, 0, 0)); }
	    else
	    { $fh->print(TTF_Pack('LSSS', $self->{'Version'}, 0, 0, 0)); }
	}

    if (defined $self->{'GLYPH'})
    {
        $goff = $fh->tell() - $loc;
        $self->{'GLYPH'}->out($fh);
    }

    if (defined $self->{'ATTACH'})
    {
        my ($r);
        
        $aoff = $fh->tell() - $loc;
        $fh->print(pack('n*', (0) x ($#{$self->{'ATTACH'}{'POINTS'}} + 3)));
        foreach $r (@{$self->{'ATTACH'}{'POINTS'}})
        {
            push (@offs, $fh->tell() - $loc - $aoff);
            $fh->print(pack('n*', $#{$r} + 1, @$r));
        }
        $coff = $fh->tell() - $loc - $aoff;
        $self->{'ATTACH'}{'COVERAGE'}->out($fh);
        $loc1 = $fh->tell();
        $fh->seek($aoff + $loc, 0);
        $fh->print(pack('n*', $coff, $#offs + 1, @offs));
        $fh->seek($loc1, 0);
    }

    if (defined $self->{'LIG'})
    {
        my (@reftables, $ltables, $i, $j, $out, $r, $s);

        $ltables = {};
        $loff = $fh->tell() - $loc;
        $out = pack('n*',
                        Font::TTF::Ttopen::ref_cache($self->{'LIG'}{'COVERAGE'}, $ltables, 0),
                        $#{$self->{'LIG'}{'LIGS'}} + 1,
                        (0) x ($#{$self->{'LIG'}{'LIGS'}} + 1));
        push (@reftables, [$ltables, 0]);
        $i = 0;
        foreach $r (@{$self->{'LIG'}{'LIGS'}})
        {
            $ltables = {};
            $loc1 = length($out);
            substr($out, ($i << 1) + 4, 2) = TTF_Pack('S', $loc1);
            $out .= pack('n*', $#{$r} + 1, (0) x ($#{$r} + 1));
            @offs = (); $j = 0;
            foreach $s (@$r)
            {
                substr($out, ($j << 1) + 2 + $loc1, 2) =
                        TTF_Pack('S', length($out) - $loc1);
                $out .= TTF_Pack('SS', $s->{'FMT'}, $s->{'VAL'});
                $out .= pack('n', Font::TTF::Ttopen::ref_cache($s->{'DEVICE'},
                        $ltables, length($out))) if ($s->{'FMT'} == 3);
                $j++;
            }
            push (@reftables, [$ltables, $loc1]);
            $i++;
        }
        Font::TTF::Ttopen::out_final($fh, $out, \@reftables);
    }

    if (defined $self->{'MARKS'})
    {
        $macoff = $fh->tell() - $loc;
        $self->{'MARKS'}->out($fh);
    }
    
    if (defined $self->{'MARKSETS'})
    {

        my (@reftables, $ctables, $c, $out); 
    	$ctables = {};    	
    	$mgsoff = $fh->tell() - $loc;
    	$out = TTF_Pack('SS', 1, $#{$self->{'MARKSETS'}}+1);
    	foreach $c (@{$self->{'MARKSETS'}})
		{
			$out .= pack('N', Font::TTF::Ttopen::ref_cache($c, $ctables, length($out), 'N'));
		}
		push (@reftables, [$ctables, 0]);
		Font::TTF::Ttopen::out_final($fh, $out, \@reftables);
    }

    $loc1 = $fh->tell();
    $fh->seek($loc + 4, 0);
    if ($mgsoff)
    { $fh->print(TTF_Pack('S5', $goff, $aoff, $loff, $macoff, $mgsoff)); }
    elsif ($macoff)
    { $fh->print(TTF_Pack('S4', $goff, $aoff, $loff, $macoff)); }
    else
    { $fh->print(TTF_Pack('S3', $goff, $aoff, $loff)); }
    $fh->seek($loc1, 0);
    $self;
}


=head2 $t->minsize()

Returns the minimum size this table can be. If it is smaller than this, then the table
must be bad and should be deleted or whatever.

=cut

sub minsize
{
    return 10;
}


=head2 $t->update

Sort COVERAGE tables.

=cut

sub update
{
    my ($self) = @_;
    
    return undef unless ($self->SUPER::update);
    
    unless ($Font::TTF::Coverage::dontsort)
    {
    	if (defined $self->{'ATTACH'} and defined $self->{'ATTACH'}{'COVERAGE'} and !$self->{'ATTACH'}{'COVERAGE'}{'dontsort'} )
    	{
    		my @map = $self->{'ATTACH'}{'COVERAGE'}->sort();
        	if (defined $self->{'ATTACH'}{'POINTS'})
        	{
				# And also a POINTS array which now needs to be re-sorted
                my $newpoints = [];
                foreach (0 .. $#map)
                { push @{$newpoints}, $self->{'ATTACH'}{'POINTS'}[$map[$_]]; }
                $self->{'ATTACH'}{'POINTS'} = $newpoints;
            }
    	}
    	if (defined $self->{'LIG'} and defined $self->{'LIG'}{'COVERAGE'} and !$self->{'LIG'}{'COVERAGE'}{'dontsort'} )
    	{
    		my @map = $self->{'LIG'}{'COVERAGE'}->sort();
        	if (defined $self->{'LIG'}{'LIGS'})
        	{
				# And also a LIGS array which now needs to be re-sorted
                my $newligs = [];
                foreach (0 .. $#map)
                { push @{$newligs}, $self->{'LIG'}{'LIGS'}[$map[$_]]; }
                $self->{'LIG'}{'LIGS'} = $newligs;
            }
    	}
    	if (defined $self->{'MARKSETS'})
    	{
    		foreach (@{$self->{'MARKSETS'}})
    		{$_->sort();}		# Don't care about map
    	}
    }
    
    $self;
}
    	
1;

=head1 AUTHOR

Martin Hosken L<Martin_Hosken@sil.org>. 


=head1 LICENSING

Copyright (c) 1998-2013, 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