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