font-optimizer/ext/Font-TTF/lib/Font/TTF/Mort/Subtable.pm

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