fix for new perl (redundant defined)
[librarian.git] / 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