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

   1 package Font::TTF::Mort::Insertion;
   2
   3 =head1 NAME
   4
   5 Font::TTF::Mort::Insertion - Insertion 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 $subtableStart = $fh->tell();
  44
  45     my $stateTableStart = $fh->tell();
  46     my ($classes, $states, $entries) = AAT_read_state_table($fh, 2);
  47
  48     my %insertListHash;
  49     my $insertLists;
  50     foreach (@$entries) {
  51         my $flags = $_->{'flags'};
  52         my @insertCount = (($flags & 0x03e0) >> 5, ($flags & 0x001f));
  53         my $actions = $_->{'actions'};
  54         foreach (0 .. 1) {
  55             if ($insertCount[$_] > 0) {
  56                 $fh->seek($stateTableStart + $actions->[$_], IO::File::SEEK_SET);
  57                 $fh->read($dat, $insertCount[$_] * 2);
  58                 if (not defined $insertListHash{$dat}) {
  59                     push @$insertLists, [unpack("n*", $dat)];
  60                     $insertListHash{$dat} = $#$insertLists;
  61                 }
  62                 $actions->[$_] = $insertListHash{$dat};
  63             }
  64             else {
  65                 $actions->[$_] = undef;
  66             }
  67         }
  68     }
  69
  70     $self->{'classes'} = $classes;
  71     $self->{'states'} = $states;
  72     $self->{'insertLists'} = $insertLists;
  73
  74     $self;
  75 }
  76
  77 =head2 $t->pack_sub()
  78
  79 =cut
  80
  81 sub pack_sub
  82 {
  83     my ($self) = @_;
  84
  85     my ($dat) = pack("nnnn", (0) x 4);
  86
  87     my $classTable = length($dat);
  88     my $classes = $self->{'classes'};
  89     $dat .= AAT_pack_classes($classes);
  90
  91     my $stateArray = length($dat);
  92     my $states = $self->{'states'};
  93     my ($dat1, $stateSize, $entries) = AAT_pack_states($classes, $stateArray, $states,
  94             sub {
  95                 my $actions = $_->{'actions'};
  96                 ( $_->{'flags'}, @$actions )
  97             }
  98         );
  99     $dat .= $dat1;
 100
 101     my $entryTable = length($dat);
 102     my $offset = ($entryTable + 8 * @$entries);
 103     my @insListOffsets;
 104     my $insertLists = $self->{'insertLists'};
 105     foreach (@$insertLists) {
 106         push @insListOffsets, $offset;
 107         $offset += 2 * scalar @$_;
 108     }
 109     foreach (@$entries) {
 110         my ($nextState, $flags, @lists) = split /,/;
 111         $flags &= ~0x03ff;
 112         $flags |= (scalar @{$insertLists->[$lists[0]]}) << 5 if $lists[0] ne '';
 113         $flags |= (scalar @{$insertLists->[$lists[1]]}) if $lists[1] ne '';
 114         $dat .= pack("nnnn", $nextState, $flags,
 115                     map { $_ eq '' ? 0 : $insListOffsets[$_] } @lists);
 116     }
 117
 118     foreach (@$insertLists) {
 119         $dat .= pack("n*", @$_);
 120     }
 121
 122     $dat1 = pack("nnnn", $stateSize, $classTable, $stateArray, $entryTable);
 123     substr($dat, 0, length($dat1)) = $dat1;
 124
 125     return $dat;
 126 }
 127
 128 =head2 $t->print($fh)
 129
 130 Prints a human-readable representation of the table
 131
 132 =cut
 133
 134 sub print
 135 {
 136     my ($self, $fh) = @_;
 137
 138     my $post = $self->post();
 139
 140     $fh = 'STDOUT' unless defined $fh;
 141
 142     $self->print_classes($fh);
 143
 144     $fh->print("\n");
 145     my $states = $self->{'states'};
 146     foreach (0 .. $#$states) {
 147         $fh->printf("\t\tState %d:", $_);
 148         my $state = $states->[$_];
 149         foreach (@$state) {
 150             my $flags;
 151             $flags .= "!" if ($_->{'flags'} & 0x4000);
 152             $flags .= "*" if ($_->{'flags'} & 0x8000);
 153             my $actions = $_->{'actions'};
 154             $fh->printf("\t(%s%d,%s,%s)", $flags, $_->{'nextState'}, map { defined $_ ? $_ : "=" } @$actions);
 155         }
 156         $fh->print("\n");
 157     }
 158
 159     $fh->print("\n");
 160     my $insertLists = $self->{'insertLists'};
 161     foreach (0 .. $#$insertLists) {
 162         my $insertList = $insertLists->[$_];
 163         $fh->printf("\t\tList %d: %s\n", $_, join(", ", map { $_ . " [" . $post->{'VAL'}[$_] . "]" } @$insertList));
 164     }
 165 }
 166
 167 1;
 168
 169 =head1 BUGS
 170
 171 None known
 172
 173 =head1 AUTHOR
 174
 175 Jonathan Kew L<Jonathan_Kew@sil.org>. See L<Font::TTF::Font> for copyright and
 176 licensing.
 177
 178 =cut
 179