src/librarian/font-optimizer/ext/Font-TTF/lib/Font/TTF/Mort/Ligature.pm

   1 package Font::TTF::Mort::Ligature;
   2
   3 =head1 NAME
   4
   5 Font::TTF::Mort::Ligature - Ligature Mort subtable for AAT
   6
   7 =head1 METHODS
   8
   9 =cut
  10
  11 use strict;
  12 use vars qw(@ISA);
  13 use Font::TTF::Utils;
  14 use Font::TTF::AATutils;
  15 use IO::File;
  16
  17 @ISA = qw(Font::TTF::Mort::Subtable);
  18
  19 sub new
  20 {
  21     my ($class, $direction, $orientation, $subFeatureFlags) = @_;
  22     my ($self) = {
  23                     'direction'            => $direction,
  24                     'orientation'        => $orientation,
  25                     'subFeatureFlags'    => $subFeatureFlags
  26                 };
  27
  28     $class = ref($class) || $class;
  29     bless $self, $class;
  30 }
  31
  32 =head2 $t->read
  33
  34 Reads the table into memory
  35
  36 =cut
  37
  38 sub read
  39 {
  40     my ($self, $fh) = @_;
  41     my ($dat);
  42
  43     my $stateTableStart = $fh->tell();
  44     my ($classes, $states, $entries) = AAT_read_state_table($fh, 0);
  45
  46     $fh->seek($stateTableStart, IO::File::SEEK_SET);
  47     $fh->read($dat, 14);
  48     my ($stateSize, $classTable, $stateArray, $entryTable,
  49         $ligActionTable, $componentTable, $ligatureTable) = unpack("nnnnnnn", $dat);
  50     my $limits = [$classTable, $stateArray, $entryTable, $ligActionTable, $componentTable, $ligatureTable, $self->{'length'} - 8];
  51
  52     my %actions;
  53     my $actionLists;
  54     foreach (@$entries) {
  55         my $offset = $_->{'flags'} & 0x3fff;
  56         $_->{'flags'} &= ~0x3fff;
  57         if ($offset != 0) {
  58             if (not defined $actions{$offset}) {
  59                 $fh->seek($stateTableStart + $offset, IO::File::SEEK_SET);
  60                 my $actionList;
  61                 while (1) {
  62                     $fh->read($dat, 4);
  63                     my $action = unpack("N", $dat);
  64                     my ($last, $store, $component) = (($action & 0x80000000) != 0, ($action & 0xC0000000) != 0, ($action & 0x3fffffff));
  65                     $component -= 0x40000000 if $component > 0x1fffffff;
  66                     $component -= $componentTable / 2;
  67                     push @$actionList, { 'store' => $store, 'component' => $component };
  68                     last if $last;
  69                 }
  70                 push @$actionLists, $actionList;
  71                 $actions{$offset} = $#$actionLists;
  72             }
  73             $_->{'actions'} = $actions{$offset};
  74         }
  75     }
  76
  77     $self->{'componentTable'} = $componentTable;
  78     my $components = [unpack("n*", AAT_read_subtable($fh, $stateTableStart, $componentTable, $limits))];
  79     foreach (@$components) {
  80         $_ = ($_ - $ligatureTable) . " +" if $_ >= $ligatureTable;
  81     }
  82     $self->{'components'} = $components;
  83
  84     $self->{'ligatureTable'} = $ligatureTable;
  85     $self->{'ligatures'} = [unpack("n*", AAT_read_subtable($fh, $stateTableStart, $ligatureTable, $limits))];
  86
  87     $self->{'classes'} = $classes;
  88     $self->{'states'} = $states;
  89     $self->{'actionLists'} = $actionLists;
  90
  91     $self;
  92 }
  93
  94 =head2 $t->pack_sub($fh)
  95
  96 =cut
  97
  98 sub pack_sub
  99 {
 100     my ($self) = @_;
 101     my ($dat);
 102
 103     $dat .= pack("nnnnnnn", (0) x 7);    # placeholders for stateSize, classTable, stateArray, entryTable, actionLists, components, ligatures
 104
 105     my $classTable = length($dat);
 106     my $classes = $self->{'classes'};
 107     $dat .= AAT_pack_classes($classes);
 108
 109     my $stateArray = length($dat);
 110     my $states = $self->{'states'};
 111
 112     my ($dat1, $stateSize, $entries) = AAT_pack_states($classes, $stateArray, $states,
 113             sub {
 114                 ( $_->{'flags'} & 0xc000, $_->{'actions'} )
 115             }
 116         );
 117     $dat .= $dat1;
 118
 119     my $actionLists = $self->{'actionLists'};
 120     my %actionListOffset;
 121     my $actionListDataLength = 0;
 122     my @actionListEntries;
 123     foreach (0 .. $#$entries) {
 124         my ($nextState, $flags, $offset) = split(/,/, $entries->[$_]);
 125         if ($offset eq "") {
 126             $offset = undef;
 127         }
 128         else {
 129             if (defined $actionListOffset{$offset}) {
 130                 $offset = $actionListOffset{$offset};
 131             }
 132             else {
 133                 $actionListOffset{$offset} = $actionListDataLength;
 134                 my $list = $actionLists->[$offset];
 135                 $actionListDataLength += 4 * @$list;
 136                 push @actionListEntries, $list;
 137                 $offset = $actionListOffset{$offset};
 138             }
 139         }
 140         $entries->[$_] = [ $nextState, $flags, $offset ];
 141     }
 142     my $entryTable = length($dat);
 143     my $ligActionLists = ($entryTable + @$entries * 4 + 3) & ~3;
 144     foreach (@$entries) {
 145         $_->[2] += $ligActionLists if defined $_->[2];
 146         $dat .= pack("nn", $_->[0], $_->[1] + $_->[2]);
 147     }
 148     $dat .= pack("C*", (0) x ($ligActionLists - $entryTable - @$entries * 4));
 149
 150     die "internal error" unless length($dat) == $ligActionLists;
 151
 152     my $componentTable = length($dat) + $actionListDataLength;
 153     my $actionList;
 154     foreach $actionList (@actionListEntries) {
 155         foreach (0 .. $#$actionList) {
 156             my $action = $actionList->[$_];
 157             my $val = $action->{'component'} + $componentTable / 2;
 158             $val += 0x40000000 if $val < 0;
 159             $val &= 0x3fffffff;
 160             $val |= 0x40000000 if $action->{'store'};
 161             $val |= 0x80000000 if $_ == $#$actionList;
 162             $dat .= pack("N", $val);
 163         }
 164     }
 165
 166     die "internal error" unless length($dat) == $componentTable;
 167
 168     my $components = $self->{'components'};
 169     my $ligatureTable = $componentTable + @$components * 2;
 170     $dat .= pack("n*", map { (index($_, '+') >= 0 ? $ligatureTable : 0) + $_ } @$components);
 171
 172     my $ligatures = $self->{'ligatures'};
 173     $dat .= pack("n*", @$ligatures);
 174
 175     $dat1 = pack("nnnnnnn", $stateSize, $classTable, $stateArray, $entryTable, $ligActionLists, $componentTable, $ligatureTable);
 176     substr($dat, 0, length($dat1)) = $dat1;
 177
 178     return $dat;
 179 }
 180
 181 =head2 $t->print($fh)
 182
 183 Prints a human-readable representation of the table
 184
 185 =cut
 186
 187 sub print
 188 {
 189     my ($self, $fh) = @_;
 190
 191     my $post = $self->post();
 192
 193     $fh = 'STDOUT' unless defined $fh;
 194
 195     $self->print_classes($fh);
 196
 197     $fh->print("\n");
 198     my $states = $self->{'states'};
 199     foreach (0 .. $#$states) {
 200         $fh->printf("\t\tState %d:", $_);
 201         my $state = $states->[$_];
 202         foreach (@$state) {
 203             my $flags;
 204             $flags .= "!" if ($_->{'flags'} & 0x4000);
 205             $flags .= "*" if ($_->{'flags'} & 0x8000);
 206             $fh->printf("\t(%s%d,%s)", $flags, $_->{'nextState'}, defined $_->{'actions'} ? $_->{'actions'} : "=");
 207         }
 208         $fh->print("\n");
 209     }
 210
 211     $fh->print("\n");
 212     my $actionLists = $self->{'actionLists'};
 213     foreach (0 .. $#$actionLists) {
 214         $fh->printf("\t\tList %d:\t", $_);
 215         my $actionList = $actionLists->[$_];
 216         $fh->printf("%s\n", join(", ", map { ($_->{'component'} . ($_->{'store'} ? "*" : "") ) } @$actionList));
 217     }
 218
 219     my $ligatureTable = $self->{'ligatureTable'};
 220
 221     $fh->print("\n");
 222     my $components = $self->{'components'};
 223     foreach (0 .. $#$components) {
 224         $fh->printf("\t\tComponent %d: %s\n", $_, $components->[$_]);
 225     }
 226
 227     $fh->print("\n");
 228     my $ligatures = $self->{'ligatures'};
 229     foreach (0 .. $#$ligatures) {
 230         $fh->printf("\t\tLigature %d: %d [%s]\n", $_, $ligatures->[$_], $post->{'VAL'}[$ligatures->[$_]]);
 231     }
 232 }
 233
 234 1;
 235
 236 =head1 BUGS
 237
 238 None known
 239
 240 =head1 AUTHOR
 241
 242 Jonathan Kew L<Jonathan_Kew@sil.org>. See L<Font::TTF::Font> for copyright and
 243 licensing.
 244
 245 =cut
 246