c837f41724ef7a131155f028c9c07eaa9dd9bc60
[librarian.git] / 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