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

   1 package Font::TTF::Mort::Chain;
   2
   3 =head1 NAME
   4
   5 Font::TTF::Mort::Chain - Chain Mort subtable for AAT
   6
   7 =cut
   8
   9 use strict;
  10 use Font::TTF::Utils;
  11 use Font::TTF::AATutils;
  12 use Font::TTF::Mort::Subtable;
  13 use IO::File;
  14
  15 =head2 $t->new
  16
  17 =cut
  18
  19 sub new
  20 {
  21     my ($class, %parms) = @_;
  22     my ($self) = {};
  23     my ($p);
  24
  25     $class = ref($class) || $class;
  26     foreach $p (keys %parms)
  27     { $self->{" $p"} = $parms{$p}; }
  28     bless $self, $class;
  29 }
  30
  31 =head2 $t->read($fh)
  32
  33 Reads the chain into memory
  34
  35 =cut
  36
  37 sub read
  38 {
  39     my ($self, $fh) = @_;
  40     my ($dat);
  41
  42     my $chainStart = $fh->tell();
  43     $fh->read($dat, 12);
  44     my ($defaultFlags, $chainLength, $nFeatureEntries, $nSubtables) = TTF_Unpack("LLSS", $dat);
  45
  46     my $featureEntries = [];
  47     foreach (1 .. $nFeatureEntries) {
  48         $fh->read($dat, 12);
  49         my ($featureType, $featureSetting, $enableFlags, $disableFlags) = TTF_Unpack("SSLL", $dat);
  50         push @$featureEntries,    {
  51                                     'type'        => $featureType,
  52                                     'setting'    => $featureSetting,
  53                                     'enable'    => $enableFlags,
  54                                     'disable'    => $disableFlags
  55                                 };
  56     }
  57
  58     my $subtables = [];
  59     foreach (1 .. $nSubtables) {
  60         my $subtableStart = $fh->tell();
  61
  62         $fh->read($dat, 8);
  63         my ($length, $coverage, $subFeatureFlags) = TTF_Unpack("SSL", $dat);
  64         my $type = $coverage & 0x0007;
  65
  66         my $subtable = Font::TTF::Mort::Subtable->create($type, $coverage, $subFeatureFlags, $length);
  67         $subtable->read($fh);
  68         $subtable->{' PARENT'} = $self;
  69
  70         push @$subtables, $subtable;
  71         $fh->seek($subtableStart + $length, IO::File::SEEK_SET);
  72     }
  73
  74     $self->{'defaultFlags'} = $defaultFlags;
  75     $self->{'featureEntries'} = $featureEntries;
  76     $self->{'subtables'} = $subtables;
  77
  78     $fh->seek($chainStart + $chainLength, IO::File::SEEK_SET);
  79
  80     $self;
  81 }
  82
  83 =head2 $t->out($fh)
  84
  85 Writes the table to a file either from memory or by copying
  86
  87 =cut
  88
  89 sub out
  90 {
  91     my ($self, $fh) = @_;
  92
  93     my $chainStart = $fh->tell();
  94     my ($featureEntries, $subtables) = ($_->{'featureEntries'}, $_->{'subtables'});
  95     $fh->print(TTF_Pack("LLSS", $_->{'defaultFlags'}, 0, scalar @$featureEntries, scalar @$subtables)); # placeholder for length
  96
  97     foreach (@$featureEntries) {
  98         $fh->print(TTF_Pack("SSLL", $_->{'type'}, $_->{'setting'}, $_->{'enable'}, $_->{'disable'}));
  99     }
 100
 101     foreach (@$subtables) {
 102         $_->out($fh);
 103     }
 104
 105     my $chainLength = $fh->tell() - $chainStart;
 106     $fh->seek($chainStart + 4, IO::File::SEEK_SET);
 107     $fh->print(pack("N", $chainLength));
 108     $fh->seek($chainStart + $chainLength, IO::File::SEEK_SET);
 109 }
 110
 111 =head2 $t->print($fh)
 112
 113 Prints a human-readable representation of the chain
 114
 115 =cut
 116
 117 sub feat
 118 {
 119     my ($self) = @_;
 120
 121     my $feat = $self->{' PARENT'}{' PARENT'}{'feat'};
 122     if (defined $feat) {
 123         $feat->read;
 124     }
 125     else {
 126         $feat = {};
 127     }
 128
 129     return $feat;
 130 }
 131
 132 sub print
 133 {
 134     my ($self, $fh) = @_;
 135
 136     $fh->printf("version %f\n", $self->{'version'});
 137
 138     my $defaultFlags = $self->{'defaultFlags'};
 139     $fh->printf("chain: defaultFlags = %08x\n", $defaultFlags);
 140
 141     my $feat = $self->feat();
 142     my $featureEntries = $self->{'featureEntries'};
 143     foreach (@$featureEntries) {
 144         $fh->printf("\tfeature %d, setting %d : enableFlags = %08x, disableFlags = %08x # '%s: %s'\n",
 145                     $_->{'type'}, $_->{'setting'}, $_->{'enable'}, $_->{'disable'},
 146                     $feat->settingName($_->{'type'}, $_->{'setting'}));
 147     }
 148
 149     my $subtables = $self->{'subtables'};
 150     foreach (@$subtables) {
 151         my $type = $_->{'type'};
 152         my $subFeatureFlags = $_->{'subFeatureFlags'};
 153         $fh->printf("\n\t%s table, %s, %s, subFeatureFlags = %08x # %s (%s)\n",
 154                     subtable_type_($type), $_->{'direction'}, $_->{'orientation'}, $subFeatureFlags,
 155                     "Default " . ((($subFeatureFlags & $defaultFlags) != 0) ? "On" : "Off"),
 156                     join(", ",
 157                         map {
 158                             join(": ", $feat->settingName($_->{'type'}, $_->{'setting'}) )
 159                         } grep { ($_->{'enable'} & $subFeatureFlags) != 0 } @$featureEntries
 160                     ) );
 161
 162         $_->print($fh);
 163     }
 164 }
 165
 166 sub subtable_type_
 167 {
 168     my ($val) = @_;
 169     my ($res);
 170
 171     my @types =    (
 172                     'Rearrangement',
 173                     'Contextual',
 174                     'Ligature',
 175                     undef,
 176                     'Non-contextual',
 177                     'Insertion',
 178                 );
 179     $res = $types[$val] or ('Undefined (' . $val . ')');
 180
 181     $res;
 182 }
 183
 184 1;
 185
 186 =head1 BUGS
 187
 188 None known
 189
 190 =head1 AUTHOR
 191
 192 Jonathan Kew L<Jonathan_Kew@sil.org>. See L<Font::TTF::Font> for copyright and
 193 licensing.
 194
 195 =cut
 196