<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package Font::TTF::AATutils;

use strict;
use vars qw(@ISA @EXPORT);
require Exporter;

use Font::TTF::Utils;
use IO::File;

@ISA = qw(Exporter);
@EXPORT = qw(
    AAT_read_lookup
    AAT_pack_lookup
    AAT_write_lookup
    AAT_pack_classes
    AAT_write_classes
    AAT_pack_states
    AAT_write_states
    AAT_read_state_table
    AAT_read_subtable
    xmldump
);

sub xmldump
{
    my ($var, $links, $depth, $processedVars, $type) = @_;

    $processedVars = {} unless (defined $processedVars);
    print("&lt;?xml version='1.0' encoding='UTF-8'?&gt;\n") if $depth == 0;    # not necessarily true encoding for all text!

    my $indent = "\t" x $depth;

    my ($objType, $addr) = ($var =~ m/^.+=(.+)\((.+)\)$/);
    unless (defined $type) {
        if (defined $addr) {
            if (defined $processedVars-&gt;{$addr}) {
                if ($links) {
                    printf("%s%s\n", $indent, "&lt;a href=\"#$addr\"&gt;$objType&lt;/a&gt;");
                }
                else {
                    printf("%s%s\n", $indent, "&lt;a&gt;$objType&lt;/a&gt;");
                }
                return;
            }
            $processedVars-&gt;{$addr} = 1;
        }
    }
    
    $type = ref $var unless defined $type;
    
    if ($type eq 'REF') {
        printf("%s&lt;ref val=\"%s\"/&gt;\n", $indent, $$var);
    }
    elsif ($type eq 'SCALAR') {
        printf("%s&lt;scalar&gt;%s&lt;/scalar&gt;\n", $indent, $var);
    }
    elsif ($type eq 'ARRAY') {
        # printf("%s&lt;array&gt;\n", $indent);
        foreach (0 .. $#$var) {
            if (ref($var-&gt;[$_])) {
                printf("%s&lt;arrayItem index=\"%d\"&gt;\n", $indent, $_);
                xmldump($var-&gt;[$_], $links, $depth + 1, $processedVars);
                printf("%s&lt;/arrayItem&gt;\n", $indent);
            }
            else {
                printf("%s&lt;arrayItem index=\"%d\"&gt;%s&lt;/arrayItem&gt;\n", $indent, $_, $var-&gt;[$_]);
            }
        }
        # printf("%s&lt;/array&gt;\n", $indent);
    }
    elsif ($type eq 'HASH') {
        # printf("%s&lt;hash&gt;\n", $indent);
        foreach (sort keys %$var) {
            if (ref($var-&gt;{$_})) {
                printf("%s&lt;hashElem key=\"%s\"&gt;\n", $indent, $_);
                xmldump($var-&gt;{$_}, $links, $depth + 1, $processedVars);
                printf("%s&lt;/hashElem&gt;\n", $indent);
            }
            else {
                printf("%s&lt;hashElem key=\"%s\"&gt;%s&lt;/hashElem&gt;\n", $indent, $_, $var-&gt;{$_});
            }
        }
        # printf("%s&lt;/hash&gt;\n", $indent);
    }
    elsif ($type eq 'CODE') {
        printf("%s&lt;CODE/&gt;\n", $indent, $var);
    }
    elsif ($type eq 'GLOB') {
        printf("%s&lt;GLOB/&gt;\n", $indent, $var);
    }
    elsif ($type eq '') {
        printf("%s&lt;val&gt;%s&lt;/val&gt;\n", $indent, $var);
    }
    else {
        if ($links) {
            printf("%s&lt;obj class=\"%s\" id=\"#%s\"&gt;\n", $indent, $type, $addr);
        }
        else {
            printf("%s&lt;obj class=\"%s\"&gt;\n", $indent, $type);
        }
        xmldump($var, $links, $depth + 1, $processedVars, $objType);
        printf("%s&lt;/obj&gt;\n", $indent);
    }
}

=head2 ($classes, $states) = AAT_read_subtable($fh, $baseOffset, $subtableStart, $limits)

=cut

sub AAT_read_subtable
{
    my ($fh, $baseOffset, $subtableStart, $limits) = @_;
    
    my $limit = 0xffffffff;
    foreach (@$limits) {
        $limit = $_ if ($_ &gt; $subtableStart and $_ &lt; $limit);
    }
    die if $limit == 0xffffffff;
    
    my $dat;
    $fh-&gt;seek($baseOffset + $subtableStart, IO::File::SEEK_SET);
    $fh-&gt;read($dat, $limit - $subtableStart);
    
    $dat;
}

=head2 $length = AAT_write_state_table($fh, $classes, $states, $numExtraTables, $packEntry)

$packEntry is a subroutine for packing an entry into binary form, called as

$dat = $packEntry($entry, $entryTable, $numEntries)

where the entry is a comma-separated list of nextStateOffset, flags, actions

=cut

sub AAT_pack_state_table
{
    my ($classes, $states, $numExtraTables, $packEntry) = @_;
    
    my ($dat) = pack("n*", (0) x (4 + $numExtraTables));    # placeholders for stateSize, classTable, stateArray, entryTable
    
    my ($firstGlyph, $lastGlyph) = (0xffff, 0, 0);
    my (@classTable, $i);
    foreach $i (0 .. $#$classes) {
        my $class = $classes-&gt;[$i];
        foreach (@$class) {
            $firstGlyph = $_ if $_ &lt; $firstGlyph;
            $lastGlyph = $_ if $_ &gt; $lastGlyph;
            $classTable[$_] = $i;
        }
    }
    
    my $classTable = length($dat);
    $dat .= pack("nnC*", $firstGlyph, $lastGlyph - $firstGlyph + 1,
                    map { defined $classTable[$_] ? $classTable[$_] : 1 } ($firstGlyph .. $lastGlyph));
    $dat .= pack("C", 0) if (($lastGlyph - $firstGlyph) &amp; 1) == 0;    # pad if odd number of glyphs
    
    my $stateArray = length($dat);
    my (@entries, %entries);
    my $state = $states-&gt;[0];
    my $stateSize = @$state;
    die "stateSize below minimum allowed (4)" if $stateSize &lt; 4;
    die "stateSize (" . $stateSize . ") too small for max class number (" . $#$classes . ")" if $stateSize &lt; $#$classes + 1;
    warn "state array has unreachable columns" if $stateSize &gt; $#$classes + 1;

    foreach (@$states) {
        die "inconsistent state size" if @$_ != $stateSize;
        foreach (@$_) {
            my $actions = $_-&gt;{'actions'};
            my $entry = join(",", $stateArray + $_-&gt;{'nextState'} * $stateSize, $_-&gt;{'flags'}, ref($actions) eq 'ARRAY' ? @$actions : $actions);
            if (not defined $entries{$entry}) {
                push @entries, $entry;
                $entries{$entry} = $#entries;
                die "too many different state array entries" if $#entries == 256;
            }
            $dat .= pack("C", $entries{$entry});
        }
    }
    $dat .= pack("C", 0) if (@$states &amp; 1) != 0 and ($stateSize &amp; 1) != 0;    # pad if state array size is odd
    
    my $entryTable = length($dat);
    $dat .= map { &amp;$packEntry($_, $entryTable, $#entries + 1) } @entries;
    
    my ($dat1) = pack("nnnn", $stateSize, $classTable, $stateArray, $entryTable);
    substr($dat, 0, length($dat1)) = $dat1;
    
    return $dat;
}

sub AAT_write_state_table
{
    my ($fh, $classes, $states, $numExtraTables, $packEntry) = @_;
    
    my $stateTableStart = $fh-&gt;tell();

    $fh-&gt;print(pack("n*", (0) x (4 + $numExtraTables)));    # placeholders for stateSize, classTable, stateArray, entryTable
    
    my ($firstGlyph, $lastGlyph) = (0xffff, 0, 0);
    my (@classTable, $i);
    foreach $i (0 .. $#$classes) {
        my $class = $classes-&gt;[$i];
        foreach (@$class) {
            $firstGlyph = $_ if $_ &lt; $firstGlyph;
            $lastGlyph = $_ if $_ &gt; $lastGlyph;
            $classTable[$_] = $i;
        }
    }
    
    my $classTable = $fh-&gt;tell() - $stateTableStart;
    $fh-&gt;print(pack("nnC*", $firstGlyph, $lastGlyph - $firstGlyph + 1,
                    map { defined $classTable[$_] ? $classTable[$_] : 1 } ($firstGlyph .. $lastGlyph)));
    $fh-&gt;print(pack("C", 0)) if (($lastGlyph - $firstGlyph) &amp; 1) == 0;    # pad if odd number of glyphs
    
    my $stateArray = $fh-&gt;tell() - $stateTableStart;
    my (@entries, %entries);
    my $state = $states-&gt;[0];
    my $stateSize = @$state;
    die "stateSize below minimum allowed (4)" if $stateSize &lt; 4;
    die "stateSize (" . $stateSize . ") too small for max class number (" . $#$classes . ")" if $stateSize &lt; $#$classes + 1;
    warn "state array has unreachable columns" if $stateSize &gt; $#$classes + 1;

    foreach (@$states) {
        die "inconsistent state size" if @$_ != $stateSize;
        foreach (@$_) {
            my $actions = $_-&gt;{'actions'};
            my $entry = join(",", $stateArray + $_-&gt;{'nextState'} * $stateSize, $_-&gt;{'flags'}, ref($actions) eq 'ARRAY' ? @$actions : $actions);
            if (not defined $entries{$entry}) {
                push @entries, $entry;
                $entries{$entry} = $#entries;
                die "too many different state array entries" if $#entries == 256;
            }
            $fh-&gt;print(pack("C", $entries{$entry}));
        }
    }
    $fh-&gt;print(pack("C", 0)) if (@$states &amp; 1) != 0 and ($stateSize &amp; 1) != 0;    # pad if state array size is odd
    
    my $entryTable = $fh-&gt;tell() - $stateTableStart;
    $fh-&gt;print(map { &amp;$packEntry($_, $entryTable, $#entries + 1) } @entries);
    
    my $length = $fh-&gt;tell() - $stateTableStart;
    $fh-&gt;seek($stateTableStart, IO::File::SEEK_SET);
    $fh-&gt;print(pack("nnnn", $stateSize, $classTable, $stateArray, $entryTable));
    
    $fh-&gt;seek($stateTableStart + $length, IO::File::SEEK_SET);
    $length;
}

sub AAT_pack_classes
{
    my ($classes) = @_;
    
    my ($firstGlyph, $lastGlyph) = (0xffff, 0, 0);
    my (@classTable, $i);
    foreach $i (0 .. $#$classes) {
        my $class = $classes-&gt;[$i];
        foreach (@$class) {
            $firstGlyph = $_ if $_ &lt; $firstGlyph;
            $lastGlyph = $_ if $_ &gt; $lastGlyph;
            $classTable[$_] = $i;
        }
    }
    
    my ($dat) = pack("nnC*", $firstGlyph, $lastGlyph - $firstGlyph + 1,
                    map { defined $classTable[$_] ? $classTable[$_] : 1 } ($firstGlyph .. $lastGlyph));
    $dat .= pack("C", 0) if (($lastGlyph - $firstGlyph) &amp; 1) == 0;    # pad if odd number of glyphs
    
    return $dat;
}

sub AAT_write_classes
{
    my ($fh, $classes) = @_;
    
    $fh-&gt;print(AAT_pack_classes($fh, $classes));
}

sub AAT_pack_states
{
    my ($classes, $stateArray, $states, $buildEntryProc) = @_;
    
    my ($entries, %entryHash);
    my $state = $states-&gt;[0];
    my $stateSize = @$state;
    
    die "stateSize below minimum allowed (4)" if $stateSize &lt; 4;
    die "stateSize (" . $stateSize . ") too small for max class number (" . $#$classes . ")" if $stateSize &lt; $#$classes + 1;
    warn "state array has unreachable columns" if $stateSize &gt; $#$classes + 1;
    
    my ($dat);
    foreach (@$states) {
        die "inconsistent state size" if @$_ != $stateSize;
        foreach (@$_) {
            my $entry = join(",", $stateArray + $_-&gt;{'nextState'} * $stateSize, &amp;$buildEntryProc($_));
            if (not defined $entryHash{$entry}) {
                push @$entries, $entry;
                $entryHash{$entry} = $#$entries;
                die "too many different state array entries" if $#$entries == 256;
            }
            $dat .= pack("C", $entryHash{$entry});
        }
    }
    $dat .= pack("C", 0) if (@$states &amp; 1) != 0 and ($stateSize &amp; 1) != 0;    # pad if state array size is odd

    ($dat, $stateSize, $entries);
}

sub AAT_write_states
{
    my ($fh, $classes, $stateArray, $states, $buildEntryProc) = @_;
    
    my ($entries, %entryHash);
    my $state = $states-&gt;[0];
    my $stateSize = @$state;
    
    die "stateSize below minimum allowed (4)" if $stateSize &lt; 4;
    die "stateSize (" . $stateSize . ") too small for max class number (" . $#$classes . ")" if $stateSize &lt; $#$classes + 1;
    warn "state array has unreachable columns" if $stateSize &gt; $#$classes + 1;

    foreach (@$states) {
        die "inconsistent state size" if @$_ != $stateSize;
        foreach (@$_) {
            my $entry = join(",", $stateArray + $_-&gt;{'nextState'} * $stateSize, &amp;$buildEntryProc($_));
            if (not defined $entryHash{$entry}) {
                push @$entries, $entry;
                $entryHash{$entry} = $#$entries;
                die "too many different state array entries" if $#$entries == 256;
            }
            $fh-&gt;print(pack("C", $entryHash{$entry}));
        }
    }
    $fh-&gt;print(pack("C", 0)) if (@$states &amp; 1) != 0 and ($stateSize &amp; 1) != 0;    # pad if state array size is odd

    ($stateSize, $entries);
}

=head2 ($classes, $states, $entries) = AAT_read_state_table($fh, $numActionWords)

=cut

sub AAT_read_state_table
{
    my ($fh, $numActionWords) = @_;
    
    my $stateTableStart = $fh-&gt;tell();
    my $dat;
    $fh-&gt;read($dat, 8);
    my ($stateSize, $classTable, $stateArray, $entryTable) = unpack("nnnn", $dat);
    
    my $classes;    # array of lists of glyphs

    $fh-&gt;seek($stateTableStart + $classTable, IO::File::SEEK_SET);
    $fh-&gt;read($dat, 4);
    my ($firstGlyph, $nGlyphs) = unpack("nn", $dat);
    $fh-&gt;read($dat, $nGlyphs);
    foreach (unpack("C*", $dat)) {
        if ($_ != 1) {
            my $class = $classes-&gt;[$_];
            push(@$class, $firstGlyph);
            $classes-&gt;[$_] = $class unless defined $classes-&gt;[$_];
        }
        $firstGlyph++;
    }

    $fh-&gt;seek($stateTableStart + $stateArray, IO::File::SEEK_SET);
    my $states;    # array of arrays of hashes{nextState, flags, actions}

    my $entrySize = 4 + ($numActionWords * 2);
    my $lastState = 1;
    my $entries;
    while ($#$states &lt; $lastState) {
        $fh-&gt;read($dat, $stateSize);
        my @stateEntries = unpack("C*", $dat);
        my $state;
        foreach (@stateEntries) {
            if (not defined $entries-&gt;[$_]) {
                my $loc = $fh-&gt;tell();
                $fh-&gt;seek($stateTableStart + $entryTable + ($_ * $entrySize), IO::File::SEEK_SET);
                $fh-&gt;read($dat, $entrySize);
                my ($nextState, $flags, $actions);
                ($nextState, $flags, @$actions) = unpack("n*", $dat);
                $nextState -= $stateArray;
                $nextState /= $stateSize;
                $entries-&gt;[$_] = { 'nextState' =&gt; $nextState, 'flags' =&gt; $flags };
                $entries-&gt;[$_]-&gt;{'actions'} = $actions if $numActionWords &gt; 0;
                $lastState = $nextState if ($nextState &gt; $lastState);
                $fh-&gt;seek($loc, IO::File::SEEK_SET);
            }
            push(@$state, $entries-&gt;[$_]);
        }
        push(@$states, $state);
    }

    ($classes, $states, $entries);
}

=head2 ($format, $lookup) = AAT_read_lookup($fh, $valueSize, $length, $default)

=cut

sub AAT_read_lookup
{
    my ($fh, $valueSize, $length, $default) = @_;

    my $lookupStart = $fh-&gt;tell();
    my ($dat, $unpackChar);
    if ($valueSize == 1) {
        $unpackChar = "C";
    }
    elsif ($valueSize == 2) {
        $unpackChar = "n";
    }
    elsif ($valueSize == 4) {
        $unpackChar = "N";
    }
    else {
        die "unsupported value size";
    }
        
    $fh-&gt;read($dat, 2);
    my $format = unpack("n", $dat);
    my $lookup;
    
    if ($format == 0) {
        $fh-&gt;read($dat, $length - 2);
        my $i = -1;
        $lookup = { map { $i++; ($_ != $default) ? ($i, $_) : () } unpack($unpackChar . "*", $dat) };
    }
    
    elsif ($format == 2) {
        $fh-&gt;read($dat, 10);
        my ($unitSize, $nUnits, $searchRange, $entrySelector, $rangeShift) = unpack("nnnnn", $dat);
        die if $unitSize != 4 + $valueSize;
        foreach (1 .. $nUnits) {
            $fh-&gt;read($dat, $unitSize);
            my ($lastGlyph, $firstGlyph, $value) = unpack("nn" . $unpackChar, $dat);
            if ($firstGlyph != 0xffff and $value != $default) {
                foreach ($firstGlyph .. $lastGlyph) {
                    $lookup-&gt;{$_} = $value;
                }
            }
        }
    }
    
    elsif ($format == 4) {
        $fh-&gt;read($dat, 10);
        my ($unitSize, $nUnits, $searchRange, $entrySelector, $rangeShift) = unpack("nnnnn", $dat);
        die if $unitSize != 6;
        foreach (1 .. $nUnits) {
            $fh-&gt;read($dat, $unitSize);
            my ($lastGlyph, $firstGlyph, $offset) = unpack("nnn", $dat);
            if ($firstGlyph != 0xffff) {
                my $loc = $fh-&gt;tell();
                $fh-&gt;seek($lookupStart + $offset, IO::File::SEEK_SET);
                $fh-&gt;read($dat, ($lastGlyph - $firstGlyph + 1) * $valueSize);
                my @values = unpack($unpackChar . "*", $dat);
                foreach (0 .. $lastGlyph - $firstGlyph) {
                    $lookup-&gt;{$firstGlyph + $_} = $values[$_] if $values[$_] != $default;
                }
                $fh-&gt;seek($loc, IO::File::SEEK_SET);
            }
        }
    }
    
    elsif ($format == 6) {
        $fh-&gt;read($dat, 10);
        my ($unitSize, $nUnits, $searchRange, $entrySelector, $rangeShift) = unpack("nnnnn", $dat);
        die if $unitSize != 2 + $valueSize;
        foreach (1 .. $nUnits) {
            $fh-&gt;read($dat, $unitSize);
            my ($glyph, $value) = unpack("n" . $unpackChar, $dat);
            $lookup-&gt;{$glyph} = $value if $glyph != 0xffff and $value != $default;
        }
    }
    
    elsif ($format == 8) {
        $fh-&gt;read($dat, 4);
        my ($firstGlyph, $glyphCount) = unpack("nn", $dat);
        $fh-&gt;read($dat, $glyphCount * $valueSize);
        $firstGlyph--;
        $lookup = { map { $firstGlyph++; $_ != $default ? ($firstGlyph, $_) : () } unpack($unpackChar . "*", $dat) };
    }
    
    else {
        die "unknown lookup format";
    }

    $fh-&gt;seek($lookupStart + $length, IO::File::SEEK_SET);

    ($format, $lookup);
}

=head2 AAT_write_lookup($fh, $format, $lookup, $valueSize, $default)

=cut

sub AAT_pack_lookup
{
    my ($format, $lookup, $valueSize, $default) = @_;

    my $packChar;
    if ($valueSize == 1) {
        $packChar = "C";
    }
    elsif ($valueSize == 2) {
        $packChar = "n";
    }
    elsif ($valueSize == 4) {
        $packChar = "N";
    }
    else {
        die "unsupported value size";
    }
        
    my ($dat) = pack("n", $format);

    my ($firstGlyph, $lastGlyph) = (0xffff, 0);
    foreach (keys %$lookup) {
        $firstGlyph = $_ if $_ &lt; $firstGlyph;
        $lastGlyph = $_ if $_ &gt; $lastGlyph;
    }
    my $glyphCount = $lastGlyph - $firstGlyph + 1;

    if ($format == 0) {
        $dat .= pack($packChar . "*", map { defined $lookup-&gt;{$_} ? $lookup-&gt;{$_} : defined $default ? $default : $_ } (0 .. $lastGlyph));
    }

    elsif ($format == 2) {
        my $prev = $default;
        my $segStart = $firstGlyph;
        my $dat1;
        foreach ($firstGlyph .. $lastGlyph + 1) {
            my $val = $lookup-&gt;{$_};
            $val = $default unless defined $val;
            if ($val != $prev) {
                $dat1 .= pack("nn" . $packChar, $_ - 1, $segStart, $prev) if $prev != $default;
                $prev = $val;
                $segStart = $_;
            }
        }
        $dat1 .= pack("nn" . $packChar, 0xffff, 0xffff, 0);
        my $unitSize = 4 + $valueSize;
        $dat .= pack("nnnnn", $unitSize, TTF_bininfo(length($dat1) / $unitSize, $unitSize));
        $dat .= $dat1;
    }
        
    elsif ($format == 4) {
        my $segArray = new Font::TTF::Segarr($valueSize);
        $segArray-&gt;add_segment($firstGlyph, 1, map { $lookup-&gt;{$_} } ($firstGlyph .. $lastGlyph));
        my ($start, $end, $offset);
        $offset = 12 + @$segArray * 6 + 6;    # 12 is size of format word + binSearchHeader; 6 bytes per segment; 6 for terminating segment
        my $dat1;
        foreach (@$segArray) {
            $start = $_-&gt;{'START'};
            $end = $start + $_-&gt;{'LEN'} - 1;
            $dat1 .= pack("nnn", $end, $start, $offset);
            $offset += $_-&gt;{'LEN'} * 2;
        }
        $dat1 .= pack("nnn", 0xffff, 0xffff, 0);
        $dat .= pack("nnnnn", 6, TTF_bininfo(length($dat1) / 6, 6));
        $dat .= $dat1;
        foreach (@$segArray) {
            $dat1 = $_-&gt;{'VAL'};
            $dat .= pack($packChar . "*", @$dat1);
        }
    }
        
    elsif ($format == 6) {
        die "unsupported" if $valueSize != 2;
        my $dat1 = pack("n*", map { $_, $lookup-&gt;{$_} } sort { $a &lt;=&gt; $b } grep { $lookup-&gt;{$_} ne $default } keys %$lookup);
        my $unitSize = 2 + $valueSize;
        $dat .= pack("nnnnn", $unitSize, TTF_bininfo(length($dat1) / $unitSize, $unitSize));
        $dat .= $dat1;
    }
        
    elsif ($format == 8) {
        $dat .= pack("nn", $firstGlyph, $lastGlyph - $firstGlyph + 1);
        $dat .= pack($packChar . "*", map { defined $lookup-&gt;{$_} ? $lookup-&gt;{$_} : defined $default ? $default : $_ } ($firstGlyph .. $lastGlyph));
    }
    
    else {
        die "unknown lookup format";
    }
    
    my $padBytes = (4 - (length($dat) &amp; 3)) &amp; 3;
    $dat .= pack("C*", (0) x $padBytes);
    
    return $dat;
}

sub AAT_write_lookup
{
    my ($fh, $format, $lookup, $valueSize, $default) = @_;

    my $lookupStart = $fh-&gt;tell();
    my $packChar;
    if ($valueSize == 1) {
        $packChar = "C";
    }
    elsif ($valueSize == 2) {
        $packChar = "n";
    }
    elsif ($valueSize == 4) {
        $packChar = "N";
    }
    else {
        die "unsupported value size";
    }
        
    $fh-&gt;print(pack("n", $format));

    my ($firstGlyph, $lastGlyph) = (0xffff, 0);
    foreach (keys %$lookup) {
        $firstGlyph = $_ if $_ &lt; $firstGlyph;
        $lastGlyph = $_ if $_ &gt; $lastGlyph;
    }
    my $glyphCount = $lastGlyph - $firstGlyph + 1;

    if ($format == 0) {
        $fh-&gt;print(pack($packChar . "*", map { defined $lookup-&gt;{$_} ? $lookup-&gt;{$_} : defined $default ? $default : $_ } (0 .. $lastGlyph)));
    }

    elsif ($format == 2) {
        my $prev = $default;
        my $segStart = $firstGlyph;
        my $dat;
        foreach ($firstGlyph .. $lastGlyph + 1) {
            my $val = $lookup-&gt;{$_};
            $val = $default unless defined $val;
            if ($val != $prev) {
                $dat .= pack("nn" . $packChar, $_ - 1, $segStart, $prev) if $prev != $default;
                $prev = $val;
                $segStart = $_;
            }
        }
        $dat .= pack("nn" . $packChar, 0xffff, 0xffff, 0);
        my $unitSize = 4 + $valueSize;
        $fh-&gt;print(pack("nnnnn", $unitSize, TTF_bininfo(length($dat) / $unitSize, $unitSize)));
        $fh-&gt;print($dat);
    }
        
    elsif ($format == 4) {
        my $segArray = new Font::TTF::Segarr($valueSize);
        $segArray-&gt;add_segment($firstGlyph, 1, map { $lookup-&gt;{$_} } ($firstGlyph .. $lastGlyph));
        my ($start, $end, $offset);
        $offset = 12 + @$segArray * 6 + 6;    # 12 is size of format word + binSearchHeader; 6 bytes per segment; 6 for terminating segment
        my $dat;
        foreach (@$segArray) {
            $start = $_-&gt;{'START'};
            $end = $start + $_-&gt;{'LEN'} - 1;
            $dat .= pack("nnn", $end, $start, $offset);
            $offset += $_-&gt;{'LEN'} * 2;
        }
        $dat .= pack("nnn", 0xffff, 0xffff, 0);
        $fh-&gt;print(pack("nnnnn", 6, TTF_bininfo(length($dat) / 6, 6)));
        $fh-&gt;print($dat);
        foreach (@$segArray) {
            $dat = $_-&gt;{'VAL'};
            $fh-&gt;print(pack($packChar . "*", @$dat));
        }
    }
        
    elsif ($format == 6) {
        die "unsupported" if $valueSize != 2;
        my $dat = pack("n*", map { $_, $lookup-&gt;{$_} } sort { $a &lt;=&gt; $b } grep { $lookup-&gt;{$_} ne $default } keys %$lookup);
        my $unitSize = 2 + $valueSize;
        $fh-&gt;print(pack("nnnnn", $unitSize, TTF_bininfo(length($dat) / $unitSize, $unitSize)));
        $fh-&gt;print($dat);
    }
        
    elsif ($format == 8) {
        $fh-&gt;print(pack("nn", $firstGlyph, $lastGlyph - $firstGlyph + 1));
        $fh-&gt;print(pack($packChar . "*", map { defined $lookup-&gt;{$_} ? $lookup-&gt;{$_} : defined $default ? $default : $_ } ($firstGlyph .. $lastGlyph)));
    }
    
    else {
        die "unknown lookup format";
    }
    
    my $length = $fh-&gt;tell() - $lookupStart;
    my $padBytes = (4 - ($length &amp; 3)) &amp; 3;
    $fh-&gt;print(pack("C*", (0) x $padBytes));
    $length += $padBytes;
    
    $length;
}

1;

</pre></body></html>