librarian/font-optimizer/ext/Font-TTF/lib/Font/TTF/Feat.pm

   1 package Font::TTF::Feat;
   2
   3 =head1 NAME
   4
   5 Font::TTF::Feat - Font Features
   6
   7 =head1 DESCRIPTION
   8
   9 =head1 INSTANCE VARIABLES
  10
  11 =over 4
  12
  13 =item version
  14
  15 =item features
  16
  17 An array of hashes of the following form
  18
  19 =over 8
  20
  21 =item feature
  22
  23 feature id number
  24
  25 =item name
  26
  27 name index in name table
  28
  29 =item exclusive
  30
  31 exclusive flag
  32
  33 =item settings
  34
  35 hash of setting number against name string index
  36
  37 =back
  38
  39 =back
  40
  41 =head1 METHODS
  42
  43 =cut
  44
  45 use strict;
  46 use vars qw(@ISA);
  47
  48 use Font::TTF::Utils;
  49
  50 require Font::TTF::Table;
  51
  52 @ISA = qw(Font::TTF::Table);
  53
  54 =head2 $t->read
  55
  56 Reads the features from the TTF file into memory
  57
  58 =cut
  59
  60 sub read
  61 {
  62     my ($self) = @_;
  63     my ($featureCount, $features);
  64
  65     $self->SUPER::read_dat or return $self;
  66
  67     ($self->{'version'}, $featureCount) = TTF_Unpack("vS", $self->{' dat'});
  68
  69     $features = [];
  70     foreach (1 .. $featureCount) {
  71         my ($feature, $nSettings, $settingTable, $featureFlags, $nameIndex)
  72                 = TTF_Unpack("SSLSS", substr($self->{' dat'}, $_ * 12, 12));
  73         push @$features,
  74             {
  75                 'feature'    => $feature,
  76                 'name'        => $nameIndex,
  77                 'exclusive'    => (($featureFlags & 0x8000) != 0),
  78                 'settings'    => { TTF_Unpack("S*", substr($self->{' dat'}, $settingTable, $nSettings * 4)) }
  79             };
  80     }
  81     $self->{'features'} = $features;
  82
  83     delete $self->{' dat'}; # no longer needed, and may become obsolete
  84
  85     $self;
  86 }
  87
  88 =head2 $t->out($fh)
  89
  90 Writes the features to a TTF file
  91
  92 =cut
  93
  94 sub out
  95 {
  96     my ($self, $fh) = @_;
  97     my ($features, $numFeatures, $settings, $featuresData, $settingsData);
  98
  99     return $self->SUPER::out($fh) unless $self->{' read'};
 100
 101     $features = $self->{'features'};
 102     $numFeatures = @$features;
 103
 104     foreach (@$features) {
 105         $settings = $_->{'settings'};
 106         $featuresData .= TTF_Pack("SSLSS",
 107                                     $_->{'feature'},
 108                                     scalar keys %$settings,
 109                                     12 + 12 * $numFeatures + length $settingsData,
 110                                     ($_->{'exclusive'} ? 0x8000 : 0x0000),
 111                                     $_->{'name'});
 112         foreach (sort {$a <=> $b} keys %$settings) {
 113             $settingsData .= TTF_Pack("SS", $_, $settings->{$_});
 114         }
 115     }
 116
 117     $fh->print(TTF_Pack("vSSL", $self->{'version'}, $numFeatures, 0, 0));
 118     $fh->print($featuresData);
 119     $fh->print($settingsData);
 120
 121     $self;
 122 }
 123
 124 =head2 $t->print($fh)
 125
 126 Prints a human-readable representation of the table
 127
 128 =cut
 129
 130 sub print
 131 {
 132     my ($self, $fh) = @_;
 133     my ($names, $features, $settings);
 134
 135     $self->read;
 136
 137     $names = $self->{' PARENT'}->{'name'};
 138     $names->read;
 139
 140     $fh = 'STDOUT' unless defined $fh;
 141
 142     $features = $self->{'features'};
 143     foreach (@$features) {
 144         $fh->printf("Feature %d, %s, name %d # '%s'\n",
 145                     $_->{'feature'},
 146                     ($_->{'exclusive'} ? "exclusive" : "additive"),
 147                     $_->{'name'},
 148                     $names->{'strings'}[$_->{'name'}][1][0]{0});
 149         $settings = $_->{'settings'};
 150         foreach (sort { $a <=> $b } keys %$settings) {
 151             $fh->printf("\tSetting %d, name %d # '%s'\n",
 152                         $_, $settings->{$_}, $names->{'strings'}[$settings->{$_}][1][0]{0});
 153         }
 154     }
 155
 156     $self;
 157 }
 158
 159 sub settingName
 160 {
 161     my ($self, $feature, $setting) = @_;
 162
 163     $self->read;
 164
 165     my $names = $self->{' PARENT'}->{'name'};
 166     $names->read;
 167
 168     my $features = $self->{'features'};
 169     my ($featureEntry) = grep { $_->{'feature'} == $feature } @$features;
 170     my $featureName = $names->{'strings'}[$featureEntry->{'name'}][1][0]{0};
 171     my $settingName = $featureEntry->{'exclusive'}
 172             ? $names->{'strings'}[$featureEntry->{'settings'}->{$setting}][1][0]{0}
 173             : $names->{'strings'}[$featureEntry->{'settings'}->{$setting & ~1}][1][0]{0}
 174                 . (($setting & 1) == 0 ? " On" : " Off");
 175
 176     ($featureName, $settingName);
 177 }
 178
 179 1;
 180
 181 =head1 BUGS
 182
 183 None known
 184
 185 =head1 AUTHOR
 186
 187 Jonathan Kew L<Jonathan_Kew@sil.org>. See L<Font::TTF::Font> for copyright and
 188 licensing.
 189
 190 =cut
 191