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

=head1 NAME

Font::TTF::Cmap - Character map table

=head1 DESCRIPTION

Looks after the character map. For ease of use, the actual cmap is held in
a hash against codepoint. Thus for a given table:

    $gid = $font-&gt;{'cmap'}{'Tables'}[0]{'val'}{$code};

Note that C&lt;$code&gt; should be a true value (0x1234) rather than a string representation.

=head1 INSTANCE VARIABLES

The instance variables listed here are not preceeded by a space due to their
emulating structural information in the font.

=over 4

=item Num

Number of subtables in this table

=item Tables

An array of subtables ([0..Num-1])

=back

Each subtables also has its own instance variables which are, again, not
preceeded by a space.

=over 4

=item Platform

The platform number for this subtable

=item Encoding

The encoding number for this subtable

=item Format

Gives the stored format of this subtable

=item Ver

Gives the version (or language) information for this subtable

=item val

A hash keyed by the codepoint value (not a string) storing the glyph id

=back

=head1 METHODS

=cut

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

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


=head2 $t-&gt;read

Reads the cmap into memory. Format 4 subtables read the whole subtable and
fill in the segmented array accordingly.

=cut

sub read
{
    my ($self) = @_;
    my ($dat, $i, $j, $k, $id, @ids, $s);
    my ($start, $end, $range, $delta, $form, $len, $num, $ver, $sg);
    my ($fh) = $self-&gt;{' INFILE'};

    $self-&gt;SUPER::read or return $self;
    $fh-&gt;read($dat, 4);
    $self-&gt;{'Num'} = unpack("x2n", $dat);
    $self-&gt;{'Tables'} = [];
    for ($i = 0; $i &lt; $self-&gt;{'Num'}; $i++)
    {
        $s = {};
        $fh-&gt;read($dat, 8);
        ($s-&gt;{'Platform'}, $s-&gt;{'Encoding'}, $s-&gt;{'LOC'}) = (unpack("nnN", $dat));
        $s-&gt;{'LOC'} += $self-&gt;{' OFFSET'};
        push(@{$self-&gt;{'Tables'}}, $s);
    }
    for ($i = 0; $i &lt; $self-&gt;{'Num'}; $i++)
    {
        $s = $self-&gt;{'Tables'}[$i];
        $fh-&gt;seek($s-&gt;{'LOC'}, 0);
        $fh-&gt;read($dat, 2);
        $form = unpack("n", $dat);

        $s-&gt;{'Format'} = $form;
        if ($form == 0)
        {
            my $j = 0;

            $fh-&gt;read($dat, 4);
            ($len, $s-&gt;{'Ver'}) = unpack('n2', $dat);
            $fh-&gt;read($dat, 256);
            $s-&gt;{'val'} = {map {$j++; ($_ ? ($j - 1, $_) : ())} unpack("C*", $dat)};
        } elsif ($form == 6)
        {
            my ($start, $ecount);
            
            $fh-&gt;read($dat, 8);
            ($len, $s-&gt;{'Ver'}, $start, $ecount) = unpack('n4', $dat);
            $fh-&gt;read($dat, $ecount &lt;&lt; 1);
            $s-&gt;{'val'} = {map {$start++; ($_ ? ($start - 1, $_) : ())} unpack("n*", $dat)};
        } elsif ($form == 2)        # Contributed by Huw Rogers
        {
            $fh-&gt;read($dat, 4);
            ($len, $s-&gt;{'Ver'}) = unpack('n2', $dat);
            $fh-&gt;read($dat, 512);
            my ($j, $k, $l, $m, $n, @subHeaderKeys, @subHeaders, $subHeader);
            $n = 1;
            for ($j = 0; $j &lt; 256; $j++) {
                my $k = unpack('@'.($j&lt;&lt;1).'n', $dat)&gt;&gt;3;
                $n = $k + 1 if $k &gt;= $n;
                $subHeaders[$subHeaderKeys[$j] = $k] ||= [ ];
            }
            $fh-&gt;read($dat, $n&lt;&lt;3); # read subHeaders[]
            for ($k = 0; $k &lt; $n; $k++) {
                $subHeader = $subHeaders[$k];
                $l = $k&lt;&lt;3;
                @$subHeader = unpack('@'.$l.'n4', $dat);
                $subHeader-&gt;[2] = unpack('s', pack('S', $subHeader-&gt;[2]))
                    if $subHeader-&gt;[2] &amp; 0x8000; # idDelta
                $subHeader-&gt;[3] =
                    ($subHeader-&gt;[3] - (($n - $k)&lt;&lt;3) + 6)&gt;&gt;1; # idRangeOffset
            }
            $fh-&gt;read($dat, $len - ($n&lt;&lt;3) - 518); # glyphIndexArray[]
            for ($j = 0; $j &lt; 256; $j++) {
                $k = $subHeaderKeys[$j];
                $subHeader = $subHeaders[$k];
                unless ($k) {
                    $l = $j - $subHeader-&gt;[0];
                    if ($l &gt;= 0 &amp;&amp; $l &lt; $subHeader-&gt;[1]) {
                        $m = unpack('@'.(($l + $subHeader-&gt;[3])&lt;&lt;1).'n', $dat);
                        $m += $subHeader-&gt;[2] if $m;
                        $s-&gt;{'val'}{$j} = $m;
                    }
                } else {
                    for ($l = 0; $l &lt; $subHeader-&gt;[1]; $l++) {
                        $m = unpack('@'.(($l + $subHeader-&gt;[3])&lt;&lt;1).'n', $dat);
                        $m += $subHeader-&gt;[2] if $m;
                        $s-&gt;{'val'}{($j&lt;&lt;8) + $l + $subHeader-&gt;[0]} = $m;
                    }
                }
            }
        } elsif ($form == 4)
        {
            $fh-&gt;read($dat, 12);
            ($len, $s-&gt;{'Ver'}, $num) = unpack('n3', $dat);
            $num &gt;&gt;= 1;
            $fh-&gt;read($dat, $len - 14);
            for ($j = 0; $j &lt; $num; $j++)
            {
                $end = unpack("n", substr($dat, $j &lt;&lt; 1, 2));
                $start = unpack("n", substr($dat, ($j &lt;&lt; 1) + ($num &lt;&lt; 1) + 2, 2));
                $delta = unpack("n", substr($dat, ($j &lt;&lt; 1) + ($num &lt;&lt; 2) + 2, 2));
                $delta -= 65536 if $delta &gt; 32767;
                $range = unpack("n", substr($dat, ($j &lt;&lt; 1) + $num * 6 + 2, 2));
                for ($k = $start; $k &lt;= $end; $k++)
                {
                    if ($range == 0 || $range == 65535)         # support the buggy FOG with its range=65535 for final segment
                    { $id = $k + $delta; }
                    else
                    { $id = unpack("n", substr($dat, ($j &lt;&lt; 1) + $num * 6 +
                                        2 + ($k - $start) * 2 + $range, 2)) + $delta; }
                            $id -= 65536 if $id &gt;= 65536;
                    $s-&gt;{'val'}{$k} = $id if ($id);
                }
            }
        } elsif ($form == 8 || $form == 12)
        {
            $fh-&gt;read($dat, 10);
            ($len, $s-&gt;{'Ver'}) = unpack('x2N2', $dat);
            if ($form == 8)
            {
                $fh-&gt;read($dat, 8196);
                $num = unpack("N", substr($dat, 8192, 4)); # don't need the map
            } else
            {
                $fh-&gt;read($dat, 4);
                $num = unpack("N", $dat);
            }
            $fh-&gt;read($dat, 12 * $num);
            for ($j = 0; $j &lt; $num; $j++)
            {
                ($start, $end, $sg) = unpack("N3", substr($dat, $j * 12, 12));
                for ($k = $start; $k &lt;= $end; $k++)
                { $s-&gt;{'val'}{$k} = $sg++; }
            }
        } elsif ($form == 10)
        {
            $fh-&gt;read($dat, 18);
            ($len, $s-&gt;{'Ver'}, $start, $num) = unpack('x2N4', $dat);
            $fh-&gt;read($dat, $num &lt;&lt; 1);
            for ($j = 0; $j &lt; $num; $j++)
            { $s-&gt;{'val'}{$start + $j} = unpack("n", substr($dat, $j &lt;&lt; 1, 2)); }
        }
    }
    $self;
}


=head2 $t-&gt;ms_lookup($uni)

Finds a Unicode table, giving preference to the MS one, and looks up the given
Unicode codepoint in it to find the glyph id.

=cut

sub ms_lookup
{
    my ($self, $uni) = @_;

    $self-&gt;find_ms || return undef unless (defined $self-&gt;{' mstable'});
    return $self-&gt;{' mstable'}{'val'}{$uni};
}


=head2 $t-&gt;find_ms

Finds the a Unicode table, giving preference to the Microsoft one, and sets the C&lt;mstable&gt; instance variable
to it if found. Returns the table it finds.

=cut
sub find_ms
{
    my ($self) = @_;
    my ($i, $s, $alt, $found);

    return $self-&gt;{' mstable'} if defined $self-&gt;{' mstable'};
    $self-&gt;read;
    for ($i = 0; $i &lt; $self-&gt;{'Num'}; $i++)
    {
        $s = $self-&gt;{'Tables'}[$i];
        if ($s-&gt;{'Platform'} == 3)
        {
            $self-&gt;{' mstable'} = $s;
            last if ($s-&gt;{'Encoding'} == 10);
            $found = 1 if ($s-&gt;{'Encoding'} == 1);
        } elsif ($s-&gt;{'Platform'} == 0 || ($s-&gt;{'Platform'} == 2 &amp;&amp; $s-&gt;{'Encoding'} == 1))
        { $alt = $s; }
    }
    $self-&gt;{' mstable'} = $alt if ($alt &amp;&amp; !$found);
    $self-&gt;{' mstable'};
}


=head2 $t-&gt;ms_enc

Returns the encoding of the microsoft table (0 =&gt; symbol, etc.). Returns undef if there is
no Microsoft cmap.

=cut

sub ms_enc
{
    my ($self) = @_;
    my ($s);
    
    return $self-&gt;{' mstable'}{'Encoding'} 
        if (defined $self-&gt;{' mstable'} &amp;&amp; $self-&gt;{' mstable'}{'Platform'} == 3);
    
    foreach $s (@{$self-&gt;{'Tables'}})
    {
        return $s-&gt;{'Encoding'} if ($s-&gt;{'Platform'} == 3);
    }
    return undef;
}


=head2 $t-&gt;out($fh)

Writes out a cmap table to a filehandle. If it has not been read, then
just copies from input file to output

=cut

sub out
{
    my ($self, $fh) = @_;
    my ($loc, $s, $i, $base_loc, $j, @keys);

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


    $self-&gt;{'Tables'} = [sort {$a-&gt;{'Platform'} &lt;=&gt; $b-&gt;{'Platform'}
                                || $a-&gt;{'Encoding'} &lt;=&gt; $b-&gt;{'Encoding'}
                                || $a-&gt;{'Ver'} &lt;=&gt; $b-&gt;{'Ver'}} @{$self-&gt;{'Tables'}}];
    $self-&gt;{'Num'} = scalar @{$self-&gt;{'Tables'}};

    $base_loc = $fh-&gt;tell();
    $fh-&gt;print(pack("n2", 0, $self-&gt;{'Num'}));

    for ($i = 0; $i &lt; $self-&gt;{'Num'}; $i++)
    { $fh-&gt;print(pack("nnN", $self-&gt;{'Tables'}[$i]{'Platform'}, $self-&gt;{'Tables'}[$i]{'Encoding'}, 0)); }

    for ($i = 0; $i &lt; $self-&gt;{'Num'}; $i++)
    {
        $s = $self-&gt;{'Tables'}[$i];
        if ($s-&gt;{'Format'} &lt; 8)
        { @keys = sort {$a &lt;=&gt; $b} grep { $_ &lt;= 0xFFFF} keys %{$s-&gt;{'val'}}; }
        else
        { @keys = sort {$a &lt;=&gt; $b} keys %{$s-&gt;{'val'}}; }
        $s-&gt;{' outloc'} = $fh-&gt;tell();
        if ($s-&gt;{'Format'} &lt; 8)
        { $fh-&gt;print(pack("n3", $s-&gt;{'Format'}, 0, $s-&gt;{'Ver'})); }       # come back for length
        else
        { $fh-&gt;print(pack("n2N2", $s-&gt;{'Format'}, 0, 0, $s-&gt;{'Ver'})); }
            
        if ($s-&gt;{'Format'} == 0)
        {
            $fh-&gt;print(pack("C256", @{$s-&gt;{'val'}}{0 .. 255}));
        } elsif ($s-&gt;{'Format'} == 6)
        {
            $fh-&gt;print(pack("n2", $keys[0], $keys[-1] - $keys[0] + 1));
            $fh-&gt;print(pack("n*", @{$s-&gt;{'val'}}{$keys[0] .. $keys[-1]}));
        } elsif ($s-&gt;{'Format'} == 2)       # Contributed by Huw Rogers
        {
            my ($g, $k, $h, $l, $m, $n);
            my (@subHeaderKeys, @subHeaders, $subHeader, @glyphIndexArray);
            $n = 0;
            @subHeaderKeys = (-1) x 256;
            for $j (@keys) {
                next unless defined($g = $s-&gt;{'val'}{$j});
                $h = int($j&gt;&gt;8);
                $l = ($j &amp; 0xff);
                if (($k = $subHeaderKeys[$h]) &lt; 0) {
                    $subHeader = [ $l, 1, 0, 0, [ $g ] ];
                    $subHeaders[$k = $n++] = $subHeader;
                    $subHeaderKeys[$h] = $k;
                } else {
                    $subHeader = $subHeaders[$k];
                    $m = ($l - $subHeader-&gt;[0] + 1) - $subHeader-&gt;[1];
                    $subHeader-&gt;[1] += $m;
                    push @{$subHeader-&gt;[4]}, (0) x ($m - 1), $g - $subHeader-&gt;[2];
                }
            }
            @subHeaderKeys = map { $_ &lt; 0 ? 0 : $_ } @subHeaderKeys;
            $subHeader = $subHeaders[0];
            $subHeader-&gt;[3] = 0;
            push @glyphIndexArray, @{$subHeader-&gt;[4]};
            splice(@$subHeader, 4);
            {
                my @subHeaders_ = sort {@{$a-&gt;[4]} &lt;=&gt; @{$b-&gt;[4]}} @subHeaders[1..$#subHeaders];
                my ($f, $d, $r, $subHeader_);
                for ($k = 0; $k &lt; @subHeaders_; $k++) {
                    $subHeader = $subHeaders_[$k];
                    $f = $r = shift @{$subHeader-&gt;[4]};
                    $subHeader-&gt;[5] = join(':',
                        map {
                            $d = $_ - $r;
                            $r = $_;
                            $d &lt; 0 ?
                                sprintf('-%04x', -$d) :
                                sprintf('+%04x', $d)
                        } @{$subHeader-&gt;[4]});
                    unshift @{$subHeader-&gt;[4]}, $f;
                }
                for ($k = 0; $k &lt; @subHeaders_; $k++) {
                    $subHeader = $subHeaders_[$k];
                    next unless $subHeader-&gt;[4];
                    $subHeader-&gt;[3] = @glyphIndexArray;
                    push @glyphIndexArray, @{$subHeader-&gt;[4]};
                    for ($l = $k + 1; $l &lt; @subHeaders_; $l++) {
                        $subHeader_ = $subHeaders_[$l];
                        next unless $subHeader_-&gt;[4];
                        $d = $subHeader_-&gt;[5];
                        if ($subHeader-&gt;[5] =~ /\Q$d\E/) {
                            my $o = length($`)/6;               #`
                            $subHeader_-&gt;[2] +=
                                $subHeader_-&gt;[4]-&gt;[$o] - $subHeader-&gt;[4]-&gt;[0];
                            $subHeader_-&gt;[3] = $subHeader-&gt;[3] + $o;
                            splice(@$subHeader_, 4);
                        }
                    }
                    splice(@$subHeader, 4);
                }
            }
            $fh-&gt;print(pack('n*', map { $_&lt;&lt;3 } @subHeaderKeys));
            for ($j = 0; $j &lt; 256; $j++) {
                $k = $subHeaderKeys[$j];
                $subHeader = $subHeaders[$k];
            }
            for ($k = 0; $k &lt; $n; $k++) {
                $subHeader = $subHeaders[$k];
                $fh-&gt;print(pack('n4',
                    $subHeader-&gt;[0],
                    $subHeader-&gt;[1],
                    $subHeader-&gt;[2] &lt; 0 ?
                        unpack('S', pack('s', $subHeader-&gt;[2])) :
                        $subHeader-&gt;[2],
                    ($subHeader-&gt;[3]&lt;&lt;1) + (($n - $k)&lt;&lt;3) - 6
                ));
            }
            $fh-&gt;print(pack('n*', @glyphIndexArray));
        } elsif ($s-&gt;{'Format'} == 4)
        {
            my ($num, $sRange, $eSel, $eShift, @starts, @ends, $doff);
            my (@deltas, $delta, @range, $flat, $k, $segs, $count, $newseg, $v);

            push(@keys, 0xFFFF) unless ($keys[-1] == 0xFFFF);
            $newseg = 1; $num = 0;
            for ($j = 0; $j &lt;= $#keys &amp;&amp; $keys[$j] &lt;= 0xFFFF; $j++)
            {
                $v = $s-&gt;{'val'}{$keys[$j]} || 0;
                if ($newseg)
                {
                    $delta = $v;
                    $doff = $j;
                    $flat = 1;
                    push(@starts, $keys[$j]);
                    $newseg = 0;
                }
                $delta = 0 if ($delta + $j - $doff != $v);
                $flat = 0 if ($v == 0);
                if ($j == $#keys || $keys[$j] + 1 != $keys[$j+1])
                {
                    push (@ends, $keys[$j]);
                    push (@deltas, $delta ? $delta - $keys[$doff] : 0);
                    push (@range, $flat);
                    $num++;
                    $newseg = 1;
                }
            }

            ($num, $sRange, $eSel, $eShift) = Font::TTF::Utils::TTF_bininfo($num, 2);
            $fh-&gt;print(pack("n4", $num * 2, $sRange, $eSel, $eShift));
            $fh-&gt;print(pack("n*", @ends));
            $fh-&gt;print(pack("n", 0));
            $fh-&gt;print(pack("n*", @starts));
            $fh-&gt;print(pack("n*", @deltas));

            $count = 0;
            for ($j = 0; $j &lt; $num; $j++)
            {
                $delta = $deltas[$j];
                if ($delta != 0 &amp;&amp; $range[$j] == 1)
                { $range[$j] = 0; }
                else
                {
                    $range[$j] = ($count + $num - $j) &lt;&lt; 1;
                    $count += $ends[$j] - $starts[$j] + 1;
                }
            }

            $fh-&gt;print(pack("n*", @range));

            for ($j = 0; $j &lt; $num; $j++)
            {
                next if ($range[$j] == 0);
                $fh-&gt;print(pack("n*", map {$_ || 0} @{$s-&gt;{'val'}}{$starts[$j] .. $ends[$j]}));
            }
        } elsif ($s-&gt;{'Format'} == 8 || $s-&gt;{'Format'} == 12)
        {
            my (@jobs, $start, $current, $curr_glyf, $map);
            
            $current = 0; $curr_glyf = 0;
            $map = "\000" x 8192;
            foreach $j (@keys)
            {
                if ($j &gt; 0xFFFF)
                {
                    if (defined $s-&gt;{'val'}{$j &gt;&gt; 16})
                    { $s-&gt;{'Format'} = 12; }
                    vec($map, $j &gt;&gt; 16, 1) = 1;
                }
                if ($j != $current + 1 || $s-&gt;{'val'}{$j} != $curr_glyf + 1)
                {
                    push (@jobs, [$start, $current, $curr_glyf - ($current - $start)]) if (defined $start);
                    $start = $j; $current = $j; $curr_glyf = $s-&gt;{'val'}{$j};
                }
                $current = $j;
                $curr_glyf = $s-&gt;{'val'}{$j};
            }
            push (@jobs, [$start, $current, $curr_glyf - ($current - $start)]) if (defined $start);
            $fh-&gt;print($map) if ($s-&gt;{'Format'} == 8);
            $fh-&gt;print(pack('N', $#jobs + 1));
            foreach $j (@jobs)
            { $fh-&gt;print(pack('N3', @{$j})); }
        } elsif ($s-&gt;{'Format'} == 10)
        {
            $fh-&gt;print(pack('N2', $keys[0], $keys[-1] - $keys[0] + 1));
            $fh-&gt;print(pack('n*', $s-&gt;{'val'}{$keys[0] .. $keys[-1]}));
        }

        $loc = $fh-&gt;tell();
        if ($s-&gt;{'Format'} &lt; 8)
        {
            $fh-&gt;seek($s-&gt;{' outloc'} + 2, 0);
            $fh-&gt;print(pack("n", $loc - $s-&gt;{' outloc'}));
        } else
        {
            $fh-&gt;seek($s-&gt;{' outloc'} + 4, 0);
            $fh-&gt;print(pack("N", $loc - $s-&gt;{' outloc'}));
        }
        $fh-&gt;seek($base_loc + 8 + ($i &lt;&lt; 3), 0);
        $fh-&gt;print(pack("N", $s-&gt;{' outloc'} - $base_loc));
        $fh-&gt;seek($loc, 0);
    }
    $self;
}


=head2 $t-&gt;XML_element($context, $depth, $name, $val)

Outputs the elements of the cmap in XML. We only need to process val here

=cut

sub XML_element
{
    my ($self, $context, $depth, $k, $val) = @_;
    my ($fh) = $context-&gt;{'fh'};
    my ($i);

    return $self if ($k eq 'LOC');
    return $self-&gt;SUPER::XML_element($context, $depth, $k, $val) unless ($k eq 'val');

    $fh-&gt;print("$depth&lt;mappings&gt;\n");
    foreach $i (sort {$a &lt;=&gt; $b} keys %{$val})
    { $fh-&gt;printf("%s&lt;map code='%04X' glyph='%s'/&gt;\n", $depth . $context-&gt;{'indent'}, $i, $val-&gt;{$i}); }
    $fh-&gt;print("$depth&lt;/mappings&gt;\n");
    $self;
}

=head2 @map = $t-&gt;reverse(%opt)

Returns a reverse map of the Unicode cmap. I.e. given a glyph gives the Unicode value for it. Options are:

=over 4

=item tnum

Table number to use rather than the default Unicode table

=item array

Returns each element of reverse as an array since a glyph may be mapped by more
than one Unicode value. The arrays are unsorted. Otherwise store any one unicode value for a glyph.

=back

=cut

sub reverse
{
    my ($self, %opt) = @_;
    my ($table) = defined $opt{'tnum'} ? $self-&gt;{'Tables'}[$opt{'tnum'}] : $self-&gt;find_ms;
    my (@res, $code, $gid);

    while (($code, $gid) = each(%{$table-&gt;{'val'}}))
    {
        if ($opt{'array'})
        { push (@{$res[$gid]}, $code); }
        else
        { $res[$gid] = $code unless (defined $res[$gid] &amp;&amp; $res[$gid] &gt; 0 &amp;&amp; $res[$gid] &lt; $code); }
    }
    @res;
}


=head2 is_unicode($index)

Returns whether the table of a given index is known to be a unicode table
(as specified in the specifications)

=cut

sub is_unicode
{
    my ($self, $index) = @_;
    my ($pid, $eid) = ($self-&gt;{'Tables'}[$index]{'Platform'}, $self-&gt;{'Tables'}[$index]{'Encoding'});

    return ($pid == 3 || $pid == 0 || ($pid == 2 &amp;&amp; $eid == 1));
}

1;

=head1 BUGS

=over 4

=item *

No support for format 2 tables (MBCS)

=back

=head1 AUTHOR

Martin Hosken Martin_Hosken@sil.org. See L&lt;Font::TTF::Font&gt; for copyright and
licensing.

=cut

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