fix for new perl (redundant defined)
[librarian.git] / librarian / font-optimizer / ext / Font-TTF / lib / Font / TTF / Mort / Insertion.pm
1 package Font::TTF::Mort::Insertion;
2
3 =head1 NAME
4
5 Font::TTF::Mort::Insertion - Insertion 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 $subtableStart = $fh->tell();
44
45     my $stateTableStart = $fh->tell();
46     my ($classes, $states, $entries) = AAT_read_state_table($fh, 2);
47     
48     my %insertListHash;
49     my $insertLists;
50     foreach (@$entries) {
51         my $flags = $_->{'flags'};
52         my @insertCount = (($flags & 0x03e0) >> 5, ($flags & 0x001f));
53         my $actions = $_->{'actions'};
54         foreach (0 .. 1) {
55             if ($insertCount[$_] > 0) {
56                 $fh->seek($stateTableStart + $actions->[$_], IO::File::SEEK_SET);
57                 $fh->read($dat, $insertCount[$_] * 2);
58                 if (not defined $insertListHash{$dat}) {
59                     push @$insertLists, [unpack("n*", $dat)];
60                     $insertListHash{$dat} = $#$insertLists;
61                 }
62                 $actions->[$_] = $insertListHash{$dat};
63             }
64             else {
65                 $actions->[$_] = undef;
66             }
67         }
68     }
69
70     $self->{'classes'} = $classes;
71     $self->{'states'} = $states;
72     $self->{'insertLists'} = $insertLists;
73             
74     $self;
75 }
76
77 =head2 $t->pack_sub()
78
79 =cut
80
81 sub pack_sub
82 {
83     my ($self) = @_;
84     
85     my ($dat) = pack("nnnn", (0) x 4);
86     
87     my $classTable = length($dat);
88     my $classes = $self->{'classes'};
89     $dat .= AAT_pack_classes($classes);
90     
91     my $stateArray = length($dat);
92     my $states = $self->{'states'};
93     my ($dat1, $stateSize, $entries) = AAT_pack_states($classes, $stateArray, $states, 
94             sub {
95                 my $actions = $_->{'actions'};
96                 ( $_->{'flags'}, @$actions )
97             }
98         );
99     $dat .= $dat1;
100
101     my $entryTable = length($dat);
102     my $offset = ($entryTable + 8 * @$entries);
103     my @insListOffsets;
104     my $insertLists = $self->{'insertLists'};
105     foreach (@$insertLists) {
106         push @insListOffsets, $offset;
107         $offset += 2 * scalar @$_;
108     }
109     foreach (@$entries) {
110         my ($nextState, $flags, @lists) = split /,/;
111         $flags &= ~0x03ff;
112         $flags |= (scalar @{$insertLists->[$lists[0]]}) << 5 if $lists[0] ne '';
113         $flags |= (scalar @{$insertLists->[$lists[1]]}) if $lists[1] ne '';
114         $dat .= pack("nnnn", $nextState, $flags,
115                     map { $_ eq '' ? 0 : $insListOffsets[$_] } @lists);
116     }
117     
118     foreach (@$insertLists) {
119         $dat .= pack("n*", @$_);
120     }
121
122     $dat1 = pack("nnnn", $stateSize, $classTable, $stateArray, $entryTable);
123     substr($dat, 0, length($dat1)) = $dat1;
124
125     return $dat;
126 }
127
128 =head2 $t->print($fh)
129
130 Prints a human-readable representation of the table
131
132 =cut
133
134 sub print
135 {
136     my ($self, $fh) = @_;
137     
138     my $post = $self->post();
139     
140     $fh = 'STDOUT' unless defined $fh;
141
142     $self->print_classes($fh);
143     
144     $fh->print("\n");
145     my $states = $self->{'states'};
146     foreach (0 .. $#$states) {
147         $fh->printf("\t\tState %d:", $_);
148         my $state = $states->[$_];
149         foreach (@$state) {
150             my $flags;
151             $flags .= "!" if ($_->{'flags'} & 0x4000);
152             $flags .= "*" if ($_->{'flags'} & 0x8000);
153             my $actions = $_->{'actions'};
154             $fh->printf("\t(%s%d,%s,%s)", $flags, $_->{'nextState'}, map { defined $_ ? $_ : "=" } @$actions);
155         }
156         $fh->print("\n");
157     }
158
159     $fh->print("\n");
160     my $insertLists = $self->{'insertLists'};
161     foreach (0 .. $#$insertLists) {
162         my $insertList = $insertLists->[$_];
163         $fh->printf("\t\tList %d: %s\n", $_, join(", ", map { $_ . " [" . $post->{'VAL'}[$_] . "]" } @$insertList));
164     }
165 }
166
167 1;
168
169 =head1 BUGS
170
171 None known
172
173 =head1 AUTHOR
174
175 Jonathan Kew L<Jonathan_Kew@sil.org>. See L<Font::TTF::Font> for copyright and
176 licensing.
177
178 =cut
179