fix for new perl (redundant defined)
[librarian.git] / librarian / font-optimizer / ext / Font-TTF / lib / Font / TTF / Mort / Ligature.pm
1 package Font::TTF::Mort::Ligature;
2
3 =head1 NAME
4
5 Font::TTF::Mort::Ligature - Ligature Mort subtable for AAT
6
7 =head1 METHODS
8
9 =cut
10
11 use strict;
12 use vars qw(@ISA);
13 use Font::TTF::Utils;
14 use Font::TTF::AATutils;
15 use IO::File;
16
17 @ISA = qw(Font::TTF::Mort::Subtable);
18
19 sub new
20 {
21     my ($class, $direction, $orientation, $subFeatureFlags) = @_;
22     my ($self) = {
23                     'direction'            => $direction,
24                     'orientation'        => $orientation,
25                     'subFeatureFlags'    => $subFeatureFlags
26                 };
27
28     $class = ref($class) || $class;
29     bless $self, $class;
30 }
31
32 =head2 $t->read
33
34 Reads the table into memory
35
36 =cut
37
38 sub read
39 {
40     my ($self, $fh) = @_;
41     my ($dat);
42
43     my $stateTableStart = $fh->tell();
44     my ($classes, $states, $entries) = AAT_read_state_table($fh, 0);
45     
46     $fh->seek($stateTableStart, IO::File::SEEK_SET);
47     $fh->read($dat, 14);
48     my ($stateSize, $classTable, $stateArray, $entryTable,
49         $ligActionTable, $componentTable, $ligatureTable) = unpack("nnnnnnn", $dat);
50     my $limits = [$classTable, $stateArray, $entryTable, $ligActionTable, $componentTable, $ligatureTable, $self->{'length'} - 8];
51     
52     my %actions;
53     my $actionLists;
54     foreach (@$entries) {
55         my $offset = $_->{'flags'} & 0x3fff;
56         $_->{'flags'} &= ~0x3fff;
57         if ($offset != 0) {
58             if (not defined $actions{$offset}) {
59                 $fh->seek($stateTableStart + $offset, IO::File::SEEK_SET);
60                 my $actionList;
61                 while (1) {
62                     $fh->read($dat, 4);
63                     my $action = unpack("N", $dat);
64                     my ($last, $store, $component) = (($action & 0x80000000) != 0, ($action & 0xC0000000) != 0, ($action & 0x3fffffff));
65                     $component -= 0x40000000 if $component > 0x1fffffff;
66                     $component -= $componentTable / 2;
67                     push @$actionList, { 'store' => $store, 'component' => $component };
68                     last if $last;
69                 }
70                 push @$actionLists, $actionList;
71                 $actions{$offset} = $#$actionLists;
72             }
73             $_->{'actions'} = $actions{$offset};
74         }
75     }
76     
77     $self->{'componentTable'} = $componentTable;
78     my $components = [unpack("n*", AAT_read_subtable($fh, $stateTableStart, $componentTable, $limits))];
79     foreach (@$components) {
80         $_ = ($_ - $ligatureTable) . " +" if $_ >= $ligatureTable;
81     }
82     $self->{'components'} = $components;
83     
84     $self->{'ligatureTable'} = $ligatureTable;
85     $self->{'ligatures'} = [unpack("n*", AAT_read_subtable($fh, $stateTableStart, $ligatureTable, $limits))];
86     
87     $self->{'classes'} = $classes;
88     $self->{'states'} = $states;
89     $self->{'actionLists'} = $actionLists;
90         
91     $self;
92 }
93
94 =head2 $t->pack_sub($fh)
95
96 =cut
97
98 sub pack_sub
99 {
100     my ($self) = @_;
101     my ($dat);
102     
103     $dat .= pack("nnnnnnn", (0) x 7);    # placeholders for stateSize, classTable, stateArray, entryTable, actionLists, components, ligatures
104
105     my $classTable = length($dat);
106     my $classes = $self->{'classes'};
107     $dat .= AAT_pack_classes($classes);
108     
109     my $stateArray = length($dat);
110     my $states = $self->{'states'};
111     
112     my ($dat1, $stateSize, $entries) = AAT_pack_states($classes, $stateArray, $states,
113             sub {
114                 ( $_->{'flags'} & 0xc000, $_->{'actions'} )
115             }
116         );
117     $dat .= $dat1;
118     
119     my $actionLists = $self->{'actionLists'};
120     my %actionListOffset;
121     my $actionListDataLength = 0;
122     my @actionListEntries;
123     foreach (0 .. $#$entries) {
124         my ($nextState, $flags, $offset) = split(/,/, $entries->[$_]);
125         if ($offset eq "") {
126             $offset = undef;
127         }
128         else {
129             if (defined $actionListOffset{$offset}) {
130                 $offset = $actionListOffset{$offset};
131             }
132             else {
133                 $actionListOffset{$offset} = $actionListDataLength;
134                 my $list = $actionLists->[$offset];
135                 $actionListDataLength += 4 * @$list;
136                 push @actionListEntries, $list;
137                 $offset = $actionListOffset{$offset};
138             }
139         }
140         $entries->[$_] = [ $nextState, $flags, $offset ];
141     }
142     my $entryTable = length($dat);
143     my $ligActionLists = ($entryTable + @$entries * 4 + 3) & ~3;
144     foreach (@$entries) {
145         $_->[2] += $ligActionLists if defined $_->[2];
146         $dat .= pack("nn", $_->[0], $_->[1] + $_->[2]);
147     }
148     $dat .= pack("C*", (0) x ($ligActionLists - $entryTable - @$entries * 4));
149     
150     die "internal error" unless length($dat) == $ligActionLists;
151     
152     my $componentTable = length($dat) + $actionListDataLength;
153     my $actionList;
154     foreach $actionList (@actionListEntries) {
155         foreach (0 .. $#$actionList) {
156             my $action = $actionList->[$_];
157             my $val = $action->{'component'} + $componentTable / 2;
158             $val += 0x40000000 if $val < 0;
159             $val &= 0x3fffffff;
160             $val |= 0x40000000 if $action->{'store'};
161             $val |= 0x80000000 if $_ == $#$actionList;
162             $dat .= pack("N", $val);
163         }
164     }
165
166     die "internal error" unless length($dat) == $componentTable;
167
168     my $components = $self->{'components'};
169     my $ligatureTable = $componentTable + @$components * 2;
170     $dat .= pack("n*", map { (index($_, '+') >= 0 ? $ligatureTable : 0) + $_ } @$components);
171     
172     my $ligatures = $self->{'ligatures'};
173     $dat .= pack("n*", @$ligatures);
174     
175     $dat1 = pack("nnnnnnn", $stateSize, $classTable, $stateArray, $entryTable, $ligActionLists, $componentTable, $ligatureTable);
176     substr($dat, 0, length($dat1)) = $dat1;
177
178     return $dat;
179 }
180
181 =head2 $t->print($fh)
182
183 Prints a human-readable representation of the table
184
185 =cut
186
187 sub print
188 {
189     my ($self, $fh) = @_;
190     
191     my $post = $self->post();
192     
193     $fh = 'STDOUT' unless defined $fh;
194
195     $self->print_classes($fh);
196     
197     $fh->print("\n");
198     my $states = $self->{'states'};
199     foreach (0 .. $#$states) {
200         $fh->printf("\t\tState %d:", $_);
201         my $state = $states->[$_];
202         foreach (@$state) {
203             my $flags;
204             $flags .= "!" if ($_->{'flags'} & 0x4000);
205             $flags .= "*" if ($_->{'flags'} & 0x8000);
206             $fh->printf("\t(%s%d,%s)", $flags, $_->{'nextState'}, defined $_->{'actions'} ? $_->{'actions'} : "=");
207         }
208         $fh->print("\n");
209     }
210
211     $fh->print("\n");
212     my $actionLists = $self->{'actionLists'};
213     foreach (0 .. $#$actionLists) {
214         $fh->printf("\t\tList %d:\t", $_);
215         my $actionList = $actionLists->[$_];
216         $fh->printf("%s\n", join(", ", map { ($_->{'component'} . ($_->{'store'} ? "*" : "") ) } @$actionList));
217     }
218
219     my $ligatureTable = $self->{'ligatureTable'};
220
221     $fh->print("\n");
222     my $components = $self->{'components'};
223     foreach (0 .. $#$components) {
224         $fh->printf("\t\tComponent %d: %s\n", $_, $components->[$_]);
225     }
226     
227     $fh->print("\n");
228     my $ligatures = $self->{'ligatures'};
229     foreach (0 .. $#$ligatures) {
230         $fh->printf("\t\tLigature %d: %d [%s]\n", $_, $ligatures->[$_], $post->{'VAL'}[$ligatures->[$_]]);
231     }
232 }
233
234 1;
235
236 =head1 BUGS
237
238 None known
239
240 =head1 AUTHOR
241
242 Jonathan Kew L<Jonathan_Kew@sil.org>. See L<Font::TTF::Font> for copyright and
243 licensing.
244
245 =cut
246