610a66e896a96166e4323d8b283ad3fb0bbeaaf0
[librarian.git] / librarian / font-optimizer / ext / Font-TTF / lib / Font / TTF / Ttopen.pm
1 package Font::TTF::Ttopen;
2
3 =head1 NAME
4
5 Font::TTF::Ttopen - Opentype superclass for standard Opentype lookup based tables
6 (GSUB and GPOS)
7
8 =head1 DESCRIPTION
9
10 Handles all the script, lang, feature, lookup stuff for a
11 L<Font::TTF::Gsub>/L<Font::TTF::Gpos> table leaving the class specifics to the
12 subclass
13
14 =head1 INSTANCE VARIABLES
15
16 The instance variables of an opentype table form a complex sub-module hierarchy.
17
18 =over 4
19
20 =item Version
21
22 This contains the version of the table as a floating point number
23
24 =item SCRIPTS
25
26 The scripts list is a hash of script tags. Each script tag (of the form
27 $t->{'SCRIPTS'}{$tag}) has information below it.
28
29 =over 8
30
31 =item OFFSET
32
33 This variable is preceeded by a space and gives the offset from the start of the
34 table (not the table section) to the script table for this script
35
36 =item REFTAG
37
38 This variable is preceded by a space and gives a corresponding script tag to this
39 one such that the offsets in the file are the same. When writing, it is up to the
40 caller to ensure that the REFTAGs are set correctly, since these will be used to
41 assume that the scripts are identical. Note that REFTAG must refer to a script which
42 has no REFTAG of its own.
43
44 =item DEFAULT
45
46 This corresponds to the default language for this script, if there is one, and
47 contains the same information as an itemised language
48
49 =item LANG_TAGS
50
51 This contains an array of language tag strings (each 4 bytes) corresponding to
52 the languages listed by this script
53
54 =item $lang
55
56 Each language is a hash containing its information:
57
58 =over 12
59
60 =item OFFSET
61
62 This variable is preceeded by a a space and gives the offset from the start of
63 the whole table to the language table for this language
64
65 =item REFTAG
66
67 This variable is preceded by a space and has the same function as for the script
68 REFTAG, only for the languages within a script.
69
70 =item RE-ORDER
71
72 This indicates re-ordering information, and has not been set. The value should
73 always be 0.
74
75 =item DEFAULT
76
77 This holds the index of the default feature, if there is one, or -1 otherwise.
78
79 =item FEATURES
80
81 This is an array of feature tags for all the features enabled for this language
82
83 =back
84
85 =back
86
87 =item FEATURES
88
89 The features section of instance variables corresponds to the feature table in
90 the opentype table.
91
92 =over 8
93
94 =item FEAT_TAGS
95
96 This array gives the ordered list of feature tags for this table. It is used during
97 reading and writing for converting between feature index and feature tag.
98
99 =back
100
101 The rest of the FEATURES variable is itself a hash based on the feature tag for
102 each feature. Each feature has the following structure:
103
104 =over 8
105
106 =item OFFSET
107
108 This attribute is preceeded by a space and gives the offset relative to the start of the whole
109 table of this particular feature.
110
111 =item PARMS
112
113 This is an unused offset to the parameters for each feature
114
115 =item LOOKUPS
116
117 This is an array containing indices to lookups in the LOOKUP instance variable of the table
118
119 =item INDEX
120
121 This gives the feature index for this feature and is used during reading and writing for
122 converting between feature tag and feature index.
123
124 =back
125
126 =item LOOKUP
127
128 This variable is an array of lookups in order and is indexed via the features of a language of a
129 script. Each lookup contains subtables and other information:
130
131 =over 8
132
133 =item OFFSET
134
135 This name is preceeded by a space and contains the offset from the start of the table to this
136 particular lookup
137
138 =item TYPE
139
140 This is a subclass specific type for a lookup. It stipulates the type of lookup and hence subtables
141 within the lookup
142
143 =item FLAG
144
145 Holds the lookup flag bits
146
147 =item SUB
148
149 This holds an array of subtables which are subclass specific. Each subtable must have
150 an OFFSET. The other variables described here are an abstraction used in both the
151 GSUB and GPOS tables which are the target subclasses of this class.
152
153 =over 12
154
155 =item OFFSET
156
157 This is preceeded by a space and gives the offset relative to the start of the table for this
158 subtable
159
160 =item FORMAT
161
162 Gives the sub-table sub format for this GSUB subtable. It is assumed that this
163 value is correct when it comes time to write the subtable.
164
165 =item COVERAGE
166
167 Most lookups consist of a coverage table corresponding to the first
168 glyph to match. The offset of this coverage table is stored here and the coverage
169 table looked up against the GSUB table proper. There are two lookups
170 without this initial coverage table which is used to index into the RULES array.
171 These lookups have one element in the RULES array which is used for the whole
172 match.
173
174 =item RULES
175
176 The rules are a complex array. Each element of the array corresponds to an
177 element in the coverage table (governed by the coverage index). If there is
178 no coverage table, then there is considered to be only one element in the rules
179 array. Each element of the array is itself an array corresponding to the
180 possibly multiple string matches which may follow the initial glyph. Each
181 element of this array is a hash with fixed keys corresponding to information
182 needed to match a glyph string or act upon it. Thus the RULES element is an
183 array of arrays of hashes which contain the following keys:
184
185 =over 16
186
187 =item MATCH
188
189 This contains a sequence of elements held as an array. The elements may be
190 glyph ids (gid), class ids (cids), or offsets to coverage tables. Each element
191 corresponds to one glyph in the glyph string. See MATCH_TYPE for details of
192 how the different element types are marked.
193
194 =item PRE
195
196 This array holds the sequence of elements preceeding the first match element
197 and has the same form as the MATCH array.
198
199 =item POST
200
201 This array holds the sequence of elements to be tested for following the match
202 string and is of the same form as the MATCH array.
203
204 =item ACTION
205
206 This array holds information regarding what should be done if a match is found.
207 The array may either hold glyph ids (which are used to replace or insert or
208 whatever glyphs in the glyph string) or 2 element arrays consisting of:
209
210 =over 20
211
212 =item OFFSET
213
214 Offset from the start of the matched string that the lookup should start at
215 when processing the substring.
216
217 =item LOOKUP_INDEX
218
219 The index to a lookup to be acted upon on the match string.
220
221 =back
222
223 =back
224
225 =back
226
227 =back
228
229 =item CLASS
230
231 For those lookups which use class categories rather than glyph ids for matching
232 this is the offset to the class definition used to categories glyphs in the
233 match string.
234
235 =item PRE_CLASS
236
237 This is the offset to the class definition for the before match glyphs
238
239 =item POST_CLASS
240
241 This is the offset to the class definition for the after match glyphs.
242
243 =item ACTION_TYPE
244
245 This string holds the type of information held in the ACTION variable of a RULE.
246 It is subclass specific.
247
248 =item MATCH_TYPE
249
250 This holds the type of information in the MATCH array of a RULE. This is subclass
251 specific.
252
253 =item ADJUST
254
255 This corresponds to a single action for all items in a coverage table. The meaning
256 is subclass specific.
257
258 =item CACHE
259
260 This key starts with a space
261
262 A hash of other tables (such as coverage tables, classes, anchors, device tables)
263 based on the offset given in the subtable to that other information.
264 Note that the documentation is particularly
265 unhelpful here in that such tables are given as offsets relative to the
266 beginning of the subtable not the whole GSUB table. This includes those items which
267 are stored relative to another base within the subtable.
268
269 =back
270
271
272 =head1 METHODS
273
274 =cut
275
276 use Font::TTF::Table;
277 use Font::TTF::Utils;
278 use Font::TTF::Coverage;
279 use strict;
280 use vars qw(@ISA);
281
282 @ISA = qw(Font::TTF::Table);
283
284 =head2 $t->read
285
286 Reads the table passing control to the subclass to handle the subtable specifics
287
288 =cut
289
290 sub read
291 {
292     my ($self) = @_;
293     my ($dat, $i, $l, $oScript, $oFeat, $oLook, $tag, $nScript, $off, $dLang, $nLang, $lTag);
294     my ($nFeat, $nLook, $nSub, $j, $temp);
295     my ($fh) = $self->{' INFILE'};
296     my ($moff) = $self->{' OFFSET'};
297
298     $self->SUPER::read or return $self;
299     $fh->read($dat, 10);
300     ($self->{'Version'}, $oScript, $oFeat, $oLook) = TTF_Unpack("vSSS", $dat);
301
302 # read features first so that in the script/lang hierarchy we can use feature tags
303
304     $fh->seek($moff + $oFeat, 0);
305     $fh->read($dat, 2);
306     $nFeat = unpack("n", $dat);
307     $self->{'FEATURES'} = {};
308     $l = $self->{'FEATURES'};
309     $fh->read($dat, 6 * $nFeat);
310     for ($i = 0; $i < $nFeat; $i++)
311     {
312         ($tag, $off) = unpack("a4n", substr($dat, $i * 6, 6));
313         while (defined $l->{$tag})
314         {
315             if ($tag =~ m/(.*?)\s_(\d+)$/o)
316             { $tag = $1 . " _" . ($2 + 1); }
317             else
318             { $tag .= " _0"; }
319         }
320             $l->{$tag}{' OFFSET'} = $off + $oFeat;
321             $l->{$tag}{'INDEX'} = $i;
322             push (@{$l->{'FEAT_TAGS'}}, $tag);
323     }
324
325     foreach $tag (grep {m/^.{4}(?:\s_\d+)?$/o} keys %$l)
326     {
327             $fh->seek($moff + $l->{$tag}{' OFFSET'}, 0);
328         $fh->read($dat, 4);
329             ($l->{$tag}{'PARMS'}, $nLook) = unpack("n2", $dat);
330         $fh->read($dat, $nLook * 2);
331             $l->{$tag}{'LOOKUPS'} = [unpack("n*", $dat)];
332     }
333
334 # Now the script/lang hierarchy
335
336     $fh->seek($moff + $oScript, 0);
337     $fh->read($dat, 2);
338     $nScript = unpack("n", $dat);
339     $self->{'SCRIPTS'} = {};
340     $l = $self->{'SCRIPTS'};
341     $fh->read($dat, 6 * $nScript);
342     for ($i = 0; $i < $nScript; $i++)
343     {
344         ($tag, $off) = unpack("a4n", substr($dat, $i * 6, 6));
345         $off += $oScript;
346         foreach (keys %$l)
347         { $l->{$tag}{' REFTAG'} = $_ if ($l->{$_}{' OFFSET'} == $off
348                                         && !defined $l->{$_}{' REFTAG'}); }
349             $l->{$tag}{' OFFSET'} = $off;
350     }
351
352     foreach $tag (keys %$l)
353     {
354         next if ($l->{$tag}{' REFTAG'});
355         $fh->seek($moff + $l->{$tag}{' OFFSET'}, 0);
356         $fh->read($dat, 4);
357         ($dLang, $nLang) = unpack("n2", $dat);
358         $l->{$tag}{'DEFAULT'}{' OFFSET'} =
359                 $dLang + $l->{$tag}{' OFFSET'} if $dLang;
360         $fh->read($dat, 6 * $nLang);
361         for ($i = 0; $i < $nLang; $i++)
362         {
363             ($lTag, $off) = unpack("a4n", substr($dat, $i * 6, 6));
364             $off += $l->{$tag}{' OFFSET'};
365             $l->{$tag}{$lTag}{' OFFSET'} = $off;
366             foreach (@{$l->{$tag}{'LANG_TAGS'}}, 'DEFAULT')
367             { $l->{$tag}{$lTag}{' REFTAG'} = $_ if ($l->{$tag}{$_}{' OFFSET'} == $off
368                                                    && !$l->{$tag}{$_}{' REFTAG'}); }
369             push (@{$l->{$tag}{'LANG_TAGS'}}, $lTag);
370         }
371         foreach $lTag (@{$l->{$tag}{'LANG_TAGS'}}, 'DEFAULT')
372         {
373             next unless defined $l->{$tag}{$lTag};
374             next if ($l->{$tag}{$lTag}{' REFTAG'});
375             $fh->seek($moff + $l->{$tag}{$lTag}{' OFFSET'}, 0);
376             $fh->read($dat, 6);
377             ($l->{$tag}{$lTag}{'RE-ORDER'}, $l->{$tag}{$lTag}{'DEFAULT'}, $nFeat) 
378               = unpack("n3", $dat);
379             $fh->read($dat, $nFeat * 2);
380             $l->{$tag}{$lTag}{'FEATURES'} = [map {$self->{'FEATURES'}{'FEAT_TAGS'}[$_]} unpack("n*", $dat)];
381         }
382         foreach $lTag (@{$l->{$tag}{'LANG_TAGS'}}, 'DEFAULT')
383         {
384             next unless $l->{$tag}{$lTag}{' REFTAG'};
385             $temp = $l->{$tag}{$lTag}{' REFTAG'};
386             $l->{$tag}{$lTag} = &copy($l->{$tag}{$temp});
387             $l->{$tag}{$lTag}{' REFTAG'} = $temp;
388         }
389     }
390     foreach $tag (keys %$l)
391     {
392         next unless $l->{$tag}{' REFTAG'};
393         $temp = $l->{$tag}{' REFTAG'};
394         $l->{$tag} = &copy($l->{$temp});
395         $l->{$tag}{' REFTAG'} = $temp;
396     }
397
398 # And finally the lookups
399
400     $fh->seek($moff + $oLook, 0);
401     $fh->read($dat, 2);
402     $nLook = unpack("n", $dat);
403     $fh->read($dat, $nLook * 2);
404     $i = 0;
405     map { $self->{'LOOKUP'}[$i++]{' OFFSET'} = $_; } unpack("n*", $dat);
406
407     for ($i = 0; $i < $nLook; $i++)
408     {
409         $l = $self->{'LOOKUP'}[$i];
410         $fh->seek($l->{' OFFSET'} + $moff + $oLook, 0);
411         $fh->read($dat, 6);
412         ($l->{'TYPE'}, $l->{'FLAG'}, $nSub) = unpack("n3", $dat);
413         $fh->read($dat, $nSub * 2);
414         $j = 0;
415         my @offsets = unpack("n*", $dat);
416         my $isExtension = ($l->{'TYPE'} == $self->extension());
417         for ($j = 0; $j < $nSub; $j++)
418         {
419             $l->{'SUB'}[$j]{' OFFSET'} = $offsets[$j];
420             $fh->seek($moff + $oLook + $l->{' OFFSET'} + $l->{'SUB'}[$j]{' OFFSET'}, 0);
421             if ($isExtension)
422             {
423                 $fh->read($dat, 8);
424                 my $longOff;
425                 (undef, $l->{'TYPE'}, $longOff) = unpack("nnN", $dat);
426                 $l->{'SUB'}[$j]{' OFFSET'} += $longOff;
427                     $fh->seek($moff + $oLook + $l->{' OFFSET'} + $l->{'SUB'}[$j]{' OFFSET'}, 0);
428             }
429                 $self->read_sub($fh, $l, $j);
430             }
431     }
432     return $self;
433 }
434
435 =head2 $t->read_sub($fh, $lookup, $index)
436
437 This stub is to allow subclasses to read subtables of lookups in a table specific manner. A
438 reference to the lookup is passed in along with the subtable index. The file is located at the
439 start of the subtable to be read
440
441 =cut
442
443 sub read_sub
444 { }
445
446
447 =head2 $t->extension()
448
449 Returns the lookup number for the extension table that allows access to 32-bit offsets.
450
451 =cut
452
453 sub extension
454 { }
455
456
457 =head2 $t->out($fh)
458
459 Writes this Opentype table to the output calling $t->out_sub for each sub table
460 at the appropriate point in the output. The assumption is that on entry the
461 number of scripts, languages, features, lookups, etc. are all resolved and
462 the relationships fixed. This includes a script's LANG_TAGS list and that all
463 scripts and languages in their respective dictionaries either have a REFTAG or contain
464 real data.
465
466 =cut
467
468 sub out
469 {
470     my ($self, $fh) = @_;
471     my ($i, $j, $base, $off, $tag, $t, $l, $lTag, $oScript, @script, @tags);
472     my ($end, $nTags, @offs, $oFeat, $oLook, $nSub, $nSubs, $big, $out);
473
474     return $self->SUPER::out($fh) unless $self->{' read'};
475
476 # First sort the features
477     $i = 0;
478     $self->{'FEATURES'}{'FEAT_TAGS'} = [sort grep {m/^.{4}(?:\s_\d+)?$/o} %{$self->{'FEATURES'}}]
479             if (!defined $self->{'FEATURES'}{'FEAT_TAGS'});
480     foreach $t (@{$self->{'FEATURES'}{'FEAT_TAGS'}})
481     { $self->{'FEATURES'}{$t}{'INDEX'} = $i++; }
482
483     $base = $fh->tell();
484     $fh->print(TTF_Pack("v", $self->{'Version'}));
485     $fh->print(pack("n3", 10, 0, 0));
486     $oScript = $fh->tell() - $base;
487     @script = sort grep {length($_) == 4} keys %{$self->{'SCRIPTS'}};
488     $fh->print(pack("n", $#script + 1));
489     foreach $t (@script)
490     { $fh->print(pack("a4n", $t, 0)); }
491
492     $end = $fh->tell();
493     foreach $t (@script)
494     {
495         $fh->seek($end, 0);
496         $tag = $self->{'SCRIPTS'}{$t};
497         next if ($tag->{' REFTAG'});
498         $tag->{' OFFSET'} = tell($fh) - $base - $oScript;
499         $fh->print(pack("n2", 0, $#{$tag->{'LANG_TAGS'}} + 1));
500         foreach $lTag (sort @{$tag->{'LANG_TAGS'}})
501         { $fh->print(pack("a4n", $lTag, 0)); }
502         foreach $lTag (@{$tag->{'LANG_TAGS'}}, 'DEFAULT')
503         {
504             my ($def);
505             $l = $tag->{$lTag};
506             next if (!defined $l || (defined $l->{' REFTAG'} && $l->{' REFTAG'} ne ''));
507             $l->{' OFFSET'} = $fh->tell() - $base - $oScript - $tag->{' OFFSET'};
508             if (defined $l->{'DEFAULT'})
509 #           { $def = $self->{'FEATURES'}{$l->{'FEATURES'}[$l->{'DEFAULT'}]}{'INDEX'}; }
510             { $def = $l->{'DEFAULT'}; }
511             else
512             { $def = -1; }
513             $fh->print(pack("n*", $l->{'RE_ORDER'} || 0, $def, $#{$l->{'FEATURES'}} + 1,
514                     map {$self->{'FEATURES'}{$_}{'INDEX'} || 0} @{$l->{'FEATURES'}}));
515         }
516         $end = $fh->tell();
517         if ($tag->{'DEFAULT'}{' REFTAG'} || defined $tag->{'DEFAULT'}{'FEATURES'})
518         {
519                 $fh->seek($base + $oScript + $tag->{' OFFSET'}, 0);
520             if (defined $tag->{'DEFAULT'}{' REFTAG'})
521             {
522                 my ($ttag);
523                 for ($ttag = $tag->{'DEFAULT'}{' REFTAG'}; defined $tag->{$ttag}{' REFTAG'}; $ttag = $tag->{$ttag}{' REFTAG'})
524                 { }
525                 $off = $tag->{$ttag}{' OFFSET'};
526             }
527             else
528             { $off = $tag->{'DEFAULT'}{' OFFSET'}; }
529                 $fh->print(pack("n", $off));
530         }
531         $fh->seek($base + $oScript + $tag->{' OFFSET'} + 4, 0);
532         foreach (sort @{$tag->{'LANG_TAGS'}})
533         {
534             if (defined $tag->{$_}{' REFTAG'})
535             {
536                 my ($ttag);
537                 for ($ttag = $tag->{$_}{' REFTAG'}; defined $tag->{$ttag}{' REFTAG'}; $ttag = $tag->{$ttag}{' REFTAG'})
538                 { }
539                 $off = $tag->{$ttag}{' OFFSET'};
540             }
541             else
542             { $off = $tag->{$_}{' OFFSET'}; }
543             $fh->print(pack("a4n", $_, $off));
544         }
545     }
546     $fh->seek($base + $oScript + 2, 0);
547     foreach $t (@script)
548     {
549         $tag = $self->{'SCRIPTS'}{$t};
550         $off = $tag->{' REFTAG'} ? $tag->{$tag->{' REFTAG'}}{' OFFSET'} : $tag->{' OFFSET'};
551         $fh->print(pack("a4n", $t, $off));
552     }
553
554     $fh->seek($end, 0);
555     $oFeat = $end - $base;
556     $nTags = $#{$self->{'FEATURES'}{'FEAT_TAGS'}} + 1;
557     $fh->print(pack("n", $nTags));
558     $fh->print(pack("a4n", "    ", 0) x $nTags);
559     
560     foreach $t (@{$self->{'FEATURES'}{'FEAT_TAGS'}})
561     {
562         $tag = $self->{'FEATURES'}{$t};
563         $tag->{' OFFSET'} = tell($fh) - $base - $oFeat;
564         $fh->print(pack("n*", 0, $#{$tag->{'LOOKUPS'}} + 1, @{$tag->{'LOOKUPS'}}));
565     }
566     $end = $fh->tell();
567     $fh->seek($oFeat + $base + 2, 0);
568     foreach $t (@{$self->{'FEATURES'}{'FEAT_TAGS'}})
569     { $fh->print(pack("a4n", $t, $self->{'FEATURES'}{$t}{' OFFSET'})); }
570
571     undef $big;
572     $fh->seek($end, 0);
573     $oLook = $end - $base;
574     
575     # Start Lookup List Table
576     $nTags = $#{$self->{'LOOKUP'}} + 1;
577     $fh->print(pack("n", $nTags));
578     $fh->print(pack("n", 0) x $nTags);
579     $end = $fh->tell();         # end of LookupListTable = start of Lookups
580     foreach $tag (@{$self->{'LOOKUP'}})
581     { $nSubs += $self->num_sub($tag); }
582     for ($i = 0; $i < $nTags; $i++)
583     {
584         $fh->seek($end, 0);
585         $tag = $self->{'LOOKUP'}[$i];
586         $off = $end - $base - $oLook;   # BH 2004-03-04
587         # Is there room, from the start of this i'th lookup, for this and the remaining
588         # lookups to be wrapped in extension lookups?
589         if (!defined $big && $off + ($nTags - $i) * 6 + $nSubs * 10 > 65535) # BH 2004-03-04
590         {
591                         # Not enough room -- need to start an extension!            
592             my ($k, $ext);
593             $ext = $self->extension();
594             # Must turn previous lookup into the first extension
595             $i--;
596             $tag = $self->{'LOOKUP'}[$i];
597             $end = $tag->{' OFFSET'} + $base + $oLook;
598             $fh->seek($end, 0);
599             $big = $i;
600             # For this and the remaining lookups, build extensions lookups
601             for ($j = $i; $j < $nTags; $j++)
602             {
603                 $tag = $self->{'LOOKUP'}[$j];
604                 $nSub = $self->num_sub($tag);
605                 $fh->print(pack("nnn", $ext, $tag->{'FLAG'}, $nSub));
606                 $fh->print(pack("n*", map {$_ * 8 + 6 + $nSub * 2} (0 .. $nSub-1)));    # BH 2004-03-04
607                 $tag->{' EXT_OFFSET'} = $fh->tell();    # = first extension lookup subtable
608                 $tag->{' OFFSET'} = $tag->{' EXT_OFFSET'} - $nSub * 2 - 6 - $base - $oLook; # offset to this extension lookup
609                 for ($k = 0; $k < $nSub; $k++)
610                 { $fh->print(pack('nnN', 1, $tag->{'TYPE'}, 0)); }
611             }
612             
613             $tag = $self->{'LOOKUP'}[$i];
614             # Leave file positioned after all the extension lookups -- where the referenced lookups will start.
615         }
616         $tag->{' OFFSET'} = $off unless defined $big;   # BH 2004-03-04
617         $nSub = $self->num_sub($tag);
618         if (!defined $big)
619         {
620             $fh->print(pack("nnn", $tag->{'TYPE'}, $tag->{'FLAG'}, $nSub));
621             $fh->print(pack("n", 0) x $nSub);
622         }
623         else
624         { $end = $tag->{' EXT_OFFSET'}; }
625         my (@offs, $out, @refs);
626         for ($j = 0; $j < $nSub; $j++)
627         {
628             my ($ctables) = {};
629             my ($base) = length($out);
630             push(@offs, tell($fh) - $end + $base);
631             $out .= $self->out_sub($fh, $tag, $j, $ctables, $base);
632             push (@refs, [$ctables, $base]);
633         }
634         out_final($fh, $out, \@refs);
635         $end = $fh->tell();
636         if (!defined $big)
637         {
638             $fh->seek($tag->{' OFFSET'} + $base + $oLook + 6, 0);
639             $fh->print(pack("n*", @offs));
640         }
641         else
642         {
643             $fh->seek($tag->{' EXT_OFFSET'}, 0);
644             for ($j = 0; $j < $nSub; $j++)
645             { $fh->print(pack('nnN', 1, $tag->{'TYPE'}, $offs[$j] - $j * 8)); }
646         }
647     }
648     $fh->seek($oLook + $base + 2, 0);
649     $fh->print(pack("n*", map {$self->{'LOOKUP'}[$_]{' OFFSET'}} (0 .. $nTags - 1)));
650     $fh->seek($base + 6, 0);
651     $fh->print(pack('n2', $oFeat, $oLook));
652     $fh->seek($end, 0);
653     $self;
654 }
655
656
657 =head2 $t->num_sub($lookup)
658
659 Asks the subclass to count the number of subtables for a particular lookup and to
660 return that value. Used in out().
661
662 =cut
663
664 sub num_sub
665 {
666     my ($self, $lookup) = @_;
667
668     return $#{$lookup->{'SUB'}} + 1;
669 }
670
671
672 =head2 $t->out_sub($fh, $lookup, $index)
673
674 This stub is to allow subclasses to output subtables of lookups in a table specific manner. A
675 reference to the lookup is passed in along with the subtable index. The file is located at the
676 start of the subtable to be output
677
678 =cut
679
680 sub out_sub
681 { }
682
683 =head2 $t->dirty
684
685 Setting GPOS or GSUB dirty means that OS/2 may need updating, so set it dirty.
686
687 =cut
688
689 sub dirty
690 {
691     my ($self, $val) = @_;
692     my $res = $self->SUPER::dirty ($val);
693     $self->{' PARENT'}{'OS/2'}->read->dirty($val) if exists $self->{' PARENT'}{'OS/2'};
694     $res;
695 }
696
697 =head2 $t->maxContext
698
699 Returns the length of the longest opentype rule in this table.
700
701 =cut
702
703 sub maxContext
704 {
705     my ($self) = @_;
706     
707     # Make sure table is read
708     $self->read;
709
710     # Calculate my contribution to OS/2 usMaxContext
711     
712     my ($maxcontext, $l, $s, $r, $m);
713    
714     for $l (@{$self->{'LOOKUP'}})        # Examine each lookup
715     {
716         for $s (@{$l->{'SUB'}})         # Multiple possible subtables for this lookup
717         {
718             for $r (@{$s->{'RULES'}})   # One ruleset for each covered glyph
719             {
720                 for $m (@{$r})          # Multiple possible matches for this covered glyph 
721                 {
722                     my $lgt;
723                     $lgt++ if exists $s->{'COVERAGE'};  # Count 1 for the coverage table if it exists
724                     for (qw(MATCH PRE POST))
725                     {
726                         $lgt += @{$m->{$_}} if exists $m->{$_};
727                     }
728                     $maxcontext = $lgt if $lgt > $maxcontext;
729                 }
730             }
731             
732         }
733     }
734     
735     $maxcontext;    
736 }    
737
738
739 =head2 $t->update
740
741 Unless $t->{' PARENT'}{' noharmony'} is true, update will make sure that GPOS and GSUB include 
742 the same scripts and languages. Any added scripts and languages will have empty feature sets.
743
744 =cut
745
746 # Assumes we are called on both GSUB and GPOS. So simply ADDS scripts and languages to $self that it finds
747 # in the other table.
748
749 sub update
750 {
751     my ($self) = @_;
752     
753     return undef unless ($self->SUPER::update);
754
755     # Enforce script/lang congruence unless asked not to:
756     return $self if $self->{' PARENT'}{' noharmony'};
757
758     # Find my sibling (GSUB or GPOS, depending on which I am)
759     my $sibling = ref($self) eq 'Font::TTF::GSUB' ? 'GPOS' : ref($self) eq 'Font::TTF::GPOS' ? 'GSUB' : undef;
760     return $self unless $sibling && exists $self->{' PARENT'}{$sibling};
761     $sibling = $self->{' PARENT'}{$sibling};
762     next unless defined $sibling;
763     
764     # Look through scripts defined in sibling:
765     for my $sTag (grep {length($_) == 4} keys %{$sibling->{'SCRIPTS'}})
766     {
767         my $sibScript = $sibling->{'SCRIPTS'}{$sTag};
768         $sibScript = $sibling->{$sibScript->{' REFTAG'}} if exists $sibScript->{' REFTAG'} && $sibScript->{' REFTAG'} ne '';
769         
770         $self->{'SCRIPTS'}{$sTag} = {} unless defined $self->{'SCRIPTS'}{$sTag}; # Create script if not present in $self
771         
772         my $myScript = $self->{'SCRIPTS'}{$sTag};
773         $myScript = $self->{$myScript->{' REFTAG'}} if exists $myScript->{' REFTAG'} && $myScript->{' REFTAG'} ne '';
774                 
775         foreach my $lTag (@{$sibScript->{'LANG_TAGS'}})
776         {
777             # Ok, found a script/lang that is in our sibling.
778             next if exists $myScript->{$lTag};  # Already in $self
779             
780             # Need to create this lang:
781             push @{$myScript->{'LANG_TAGS'}}, $lTag;
782             $myScript->{$lTag} = { 'FEATURES' => [] };
783         }
784         unless (defined $myScript->{'DEFAULT'})
785         {
786             # Create default lang for this script. Link to 'dflt' if it exists
787             $myScript->{'DEFAULT'} = exists $myScript->{'dflt'} ? {' REFTAG' => 'dflt'} : { 'FEATURES' => [] };
788         }
789     }
790     $self;
791 }
792
793 =head1 Internal Functions & Methods
794
795 Most of these methods are used by subclasses for handling such things as coverage
796 tables.
797
798 =head2 copy($ref)
799
800 Internal function to copy the top level of a dictionary to create a new dictionary.
801 Only the top level is copied.
802
803 =cut
804
805 sub copy
806 {
807     my ($ref) = @_;
808     my ($res) = {};
809
810     foreach (keys %$ref)
811     { $res->{$_} = $ref->{$_}; }
812     $res;
813 }
814
815
816 =head2 $t->read_cover($cover_offset, $lookup_loc, $lookup, $fh, $is_cover)
817
818 Reads a coverage table and stores the results in $lookup->{' CACHE'}, that is, if
819 it hasn't been read already.
820
821 =cut
822
823 sub read_cover
824 {
825     my ($self, $offset, $base, $lookup, $fh, $is_cover) = @_;
826     my ($loc) = $fh->tell();
827     my ($cover, $str);
828
829     return undef unless $offset;
830     $str = sprintf("%X", $base + $offset);
831     return $lookup->{' CACHE'}{$str} if defined $lookup->{' CACHE'}{$str};
832     $fh->seek($base + $offset, 0);
833     $cover = Font::TTF::Coverage->new($is_cover)->read($fh);
834     $fh->seek($loc, 0);
835     $lookup->{' CACHE'}{$str} = $cover;
836     return $cover;
837 }
838
839
840 =head2 ref_cache($obj, $cache, $offset)
841
842 Internal function to keep track of the local positioning of subobjects such as
843 coverage and class definition tables, and their offsets.
844 What happens is that the cache is a hash of
845 sub objects indexed by the reference (using a string mashing of the
846 reference name which is valid for the duration of the reference) and holds a
847 list of locations in the output string which should be filled in with the
848 offset to the sub object when the final string is output in out_final.
849
850 Uses tricks for Tie::Refhash
851
852 =cut
853
854 sub ref_cache
855 {
856     my ($obj, $cache, $offset) = @_;
857
858     return 0 unless defined $obj;
859     unless (defined $cache->{"$obj"})
860     { push (@{$cache->{''}}, $obj); }
861     push (@{$cache->{"$obj"}}, $offset);
862     return 0;
863 }
864
865
866 =head2 out_final($fh, $out, $cache_list, $state)
867
868 Internal function to actually output everything to the file handle given that
869 now we know the offset to the first sub object to be output and which sub objects
870 are to be output and what locations need to be updated, we can now
871 generate everything. $cache_list is an array of two element arrays. The first element
872 is a cache object, the second is an offset to be subtracted from each reference
873 to that object made in the cache.
874
875 If $state is 1, then the output is not sent to the filehandle and the return value
876 is the string to be output. If $state is absent or 0 then output is not limited
877 by storing in a string first and the return value is "";
878
879 =cut
880
881 sub out_final
882 {
883     my ($fh, $out, $cache_list, $state) = @_;
884     my ($len) = length($out || '');
885     my ($base_loc) = $state ? 0 : $fh->tell();
886     my ($loc, $t, $r, $s, $master_cache, $offs, $str, %vecs);
887
888     $fh->print($out || '') unless $state;       # first output the current attempt
889     foreach $r (@$cache_list)
890     {
891         $offs = $r->[1];
892         foreach $t (@{$r->[0]{''}})
893         {
894             $str = "$t";
895             if (!defined $master_cache->{$str})
896             {
897                 my ($vec) = $t->signature();
898                 if ($vecs{$vec})
899                 { $master_cache->{$str} = $master_cache->{$vecs{$vec}}; }
900                 else
901                 {
902                     $vecs{$vec} = $str;
903                     $master_cache->{$str} = ($state ? length($out) : $fh->tell())
904                                                                        - $base_loc;
905                     if ($state)
906                     { $out .= $t->out($fh, 1); }
907                     else
908                     { $t->out($fh, 0); }
909                 }
910             }
911             foreach $s (@{$r->[0]{$str}})
912             { substr($out, $s, 2) = pack('n', $master_cache->{$str} - $offs); }
913         }
914     }
915     if ($state)
916     { return $out; }
917     else
918     {
919         $loc = $fh->tell();
920         $fh->seek($base_loc, 0);
921         $fh->print($out || '');       # the corrected version
922         $fh->seek($loc, 0);
923     }
924 }
925
926
927 =head2 $self->read_context($lookup, $fh, $type, $fmt, $cover, $count, $loc)
928
929 Internal method to read context (simple and chaining context) lookup subtables for
930 the GSUB and GPOS table types. The assumed values for $type correspond to those
931 for GSUB, so GPOS should adjust the values upon calling.
932
933 =cut
934
935 sub read_context
936 {
937     my ($self, $lookup, $fh, $type, $fmt, $cover, $count, $loc) = @_;
938     my ($dat, $i, $s, $t, @subst, @srec, $mcount, $scount);
939     
940     if ($type == 5 && $fmt < 3)
941     {
942         if ($fmt == 2)
943         {
944             $fh->read($dat, 2);
945             $lookup->{'CLASS'} = $self->read_cover($count, $loc, $lookup, $fh, 0);
946             $count = TTF_Unpack('S', $dat);
947         }
948         $fh->read($dat, $count << 1);
949         foreach $s (TTF_Unpack('S*', $dat))
950         {
951             if ($s == 0)
952             {
953                 push (@{$lookup->{'RULES'}}, []);
954                 next;
955             }
956             @subst = ();
957             $fh->seek($loc + $s, 0);
958             $fh->read($dat, 2);
959             $t = TTF_Unpack('S', $dat);
960             $fh->read($dat, $t << 1);
961             foreach $t (TTF_Unpack('S*', $dat))
962             {
963                 $fh->seek($loc + $s + $t, 0);
964                 @srec = ();
965                 $fh->read($dat, 4);
966                 ($mcount, $scount) = TTF_Unpack('S2', $dat);
967                 $mcount--;
968                 $fh->read($dat, ($mcount << 1) + ($scount << 2));
969                 for ($i = 0; $i < $scount; $i++)
970                 { push (@srec, [TTF_Unpack('S2', substr($dat,
971                     ($mcount << 1) + ($i << 2), 4))]); }
972                 push (@subst, {'ACTION' => [@srec],
973                                'MATCH' => [TTF_Unpack('S*',
974                                     substr($dat, 0, $mcount << 1))]});
975             }
976             push (@{$lookup->{'RULES'}}, [@subst]);
977         }
978         $lookup->{'ACTION_TYPE'} = 'l';
979         $lookup->{'MATCH_TYPE'} = ($fmt == 2 ? 'c' : 'g');
980     } elsif ($type == 5 && $fmt == 3)
981     {
982         $fh->read($dat, ($cover << 1) + ($count << 2));
983         @subst = (); @srec = ();
984         for ($i = 0; $i < $cover; $i++)
985         { push (@subst, $self->read_cover(TTF_Unpack('S', substr($dat, $i << 1, 2)),
986                                 $loc, $lookup, $fh, 1)); }
987         for ($i = 0; $i < $count; $i++)
988         { push (@srec, [TTF_Unpack('S2', substr($dat, ($count << 1) + ($i << 2), 4))]); }
989         $lookup->{'RULES'} = [[{'ACTION' => [@srec], 'MATCH' => [@subst]}]];
990         $lookup->{'ACTION_TYPE'} = 'l';
991         $lookup->{'MATCH_TYPE'} = 'o';
992     } elsif ($type == 6 && $fmt < 3)
993     {
994         if ($fmt == 2)
995         {
996             $fh->read($dat, 6);
997             $lookup->{'PRE_CLASS'} = $self->read_cover($count, $loc, $lookup, $fh, 0) if $count;
998             ($i, $mcount, $count) = TTF_Unpack('S3', $dat);     # messy: 2 classes & count
999             $lookup->{'CLASS'} = $self->read_cover($i, $loc, $lookup, $fh, 0) if $i;
1000             $lookup->{'POST_CLASS'} = $self->read_cover($mcount, $loc, $lookup, $fh, 0) if $mcount;
1001         }
1002         $fh->read($dat, $count << 1);
1003         foreach $s (TTF_Unpack('S*', $dat))
1004         {
1005             if ($s == 0)
1006             {
1007                 push (@{$lookup->{'RULES'}}, []);
1008                 next;
1009             }
1010             @subst = ();
1011             $fh->seek($loc + $s, 0);
1012             $fh->read($dat, 2);
1013             $t = TTF_Unpack('S', $dat);
1014             $fh->read($dat, $t << 1);
1015             foreach $i (TTF_Unpack('S*', $dat))
1016             {
1017                 $fh->seek($loc + $s + $i, 0);
1018                 @srec = ();
1019                 $t = {};
1020                 $fh->read($dat, 2);
1021                 $mcount = TTF_Unpack('S', $dat);
1022                 if ($mcount > 0)
1023                 {
1024                     $fh->read($dat, $mcount << 1);
1025                     $t->{'PRE'} = [TTF_Unpack('S*', $dat)];
1026                 }
1027                 $fh->read($dat, 2);
1028                 $mcount = TTF_Unpack('S', $dat);
1029                 if ($mcount > 1)
1030                 {
1031                     $fh->read($dat, ($mcount - 1) << 1);
1032                     $t->{'MATCH'} = [TTF_Unpack('S*', $dat)];
1033                 }
1034                 $fh->read($dat, 2);
1035                 $mcount = TTF_Unpack('S', $dat);
1036                 if ($mcount > 0)
1037                 {
1038                     $fh->read($dat, $mcount << 1);
1039                     $t->{'POST'} = [TTF_Unpack('S*', $dat)];
1040                 }
1041                 $fh->read($dat, 2);
1042                 $scount = TTF_Unpack('S', $dat);
1043                 $fh->read($dat, $scount << 2);
1044                 for ($i = 0; $i < $scount; $i++)
1045                 { push (@srec, [TTF_Unpack('S2', substr($dat, $i << 2))]); }
1046                 $t->{'ACTION'} = [@srec];
1047                 push (@subst, $t);
1048             }
1049             push (@{$lookup->{'RULES'}}, [@subst]);
1050         }
1051         $lookup->{'ACTION_TYPE'} = 'l';
1052         $lookup->{'MATCH_TYPE'} = ($fmt == 2 ? 'c' : 'g');
1053     } elsif ($type == 6 && $fmt == 3)
1054     {
1055         $t = {};
1056         unless ($cover == 0)
1057         {
1058             @subst = ();
1059             $fh->read($dat, $cover << 1);
1060             foreach $s (TTF_Unpack('S*', $dat))
1061             { push(@subst, $self->read_cover($s, $loc, $lookup, $fh, 1)); }
1062             $t->{'PRE'} = [@subst];
1063         }
1064         $fh->read($dat, 2);
1065         $count = TTF_Unpack('S', $dat);
1066         unless ($count == 0)
1067         {
1068             @subst = ();
1069             $fh->read($dat, $count << 1);
1070             foreach $s (TTF_Unpack('S*', $dat))
1071             { push(@subst, $self->read_cover($s, $loc, $lookup, $fh, 1)); }
1072             $t->{'MATCH'} = [@subst];
1073         }
1074         $fh->read($dat, 2);
1075         $count = TTF_Unpack('S', $dat);
1076         unless ($count == 0)
1077         {
1078             @subst = ();
1079             $fh->read($dat, $count << 1);
1080             foreach $s (TTF_Unpack('S*', $dat))
1081             { push(@subst, $self->read_cover($s, $loc, $lookup, $fh, 1)); }
1082             $t->{'POST'} = [@subst];
1083         }
1084         $fh->read($dat, 2);
1085         $count = TTF_Unpack('S', $dat);
1086         @subst = ();
1087         $fh->read($dat, $count << 2);
1088         for ($i = 0; $i < $count; $i++)
1089         { push (@subst, [TTF_Unpack('S2', substr($dat, $i << 2, 4))]); }
1090         $t->{'ACTION'} = [@subst];
1091         $lookup->{'RULES'} = [[$t]];
1092         $lookup->{'ACTION_TYPE'} = 'l';
1093         $lookup->{'MATCH_TYPE'} = 'o';
1094     }
1095     $lookup;
1096 }
1097
1098
1099 =head2 $self->out_context($lookup, $fh, $type, $fmt, $ctables, $out, $num)
1100
1101 Provides shared behaviour between GSUB and GPOS tables during output for context
1102 (chained and simple) rules. In addition, support is provided here for type 4 GSUB
1103 tables, which are not used in GPOS. The value for $type corresponds to the type
1104 in a GSUB table so calling from GPOS should adjust the value accordingly.
1105
1106 =cut
1107
1108 sub out_context
1109 {
1110     my ($self, $lookup, $fh, $type, $fmt, $ctables, $out, $num, $base) = @_;
1111     my ($offc, $offd, $i, $j, $r, $t, $numd);
1112
1113     $out ||= '';
1114     if (($type == 4 || $type == 5 || $type == 6) && ($fmt == 1 || $fmt == 2))
1115     {
1116         my ($base_off);
1117         
1118         if ($fmt == 1)
1119         {
1120             $out = pack("nnn", $fmt, Font::TTF::Ttopen::ref_cache($lookup->{'COVERAGE'}, $ctables, 2 + $base),
1121                             $num);
1122             $base_off = 6;
1123         } elsif ($type == 5)
1124         {
1125             $out = pack("nnnn", $fmt, Font::TTF::Ttopen::ref_cache($lookup->{'COVERAGE'}, $ctables, 2 + $base),
1126                             Font::TTF::Ttopen::ref_cache($lookup->{'CLASS'}, $ctables, 4 + $base), $num);
1127             $base_off = 8;
1128         } elsif ($type == 6)
1129         {
1130             $out = pack("n6", $fmt, Font::TTF::Ttopen::ref_cache($lookup->{'COVERAGE'}, $ctables, 2 + $base),
1131                                 Font::TTF::Ttopen::ref_cache($lookup->{'PRE_CLASS'}, $ctables, 4 + $base),
1132                                 Font::TTF::Ttopen::ref_cache($lookup->{'CLASS'}, $ctables, 6 + $base),
1133                                 Font::TTF::Ttopen::ref_cache($lookup->{'POST_CLASS'}, $ctables, 8 + $base),
1134                                 $num);
1135             $base_off = 12;
1136         }
1137
1138         $out .= pack('n*', (0) x $num);
1139         $offc = length($out);
1140         for ($i = 0; $i < $num; $i++)
1141         {
1142             $r = $lookup->{'RULES'}[$i];
1143             next unless exists $r->[0]{'ACTION'};
1144             $numd = $#{$r} + 1;
1145             substr($out, ($i << 1) + $base_off, 2) = pack('n', $offc);
1146             $out .= pack('n*', $numd, (0) x $numd);
1147             $offd = length($out) - $offc;
1148             for ($j = 0; $j < $numd; $j++)
1149             {
1150                 substr($out, $offc + 2 + ($j << 1), 2) = pack('n', $offd);
1151                 if ($type == 4)
1152                 {
1153                     $out .= pack('n*', $r->[$j]{'ACTION'}[0], $#{$r->[$j]{'MATCH'}} + 2,
1154                                         @{$r->[$j]{'MATCH'}});
1155                 } elsif ($type == 5)
1156                 {
1157                     $out .= pack('n*', $#{$r->[$j]{'MATCH'}} + 2,
1158                                         $#{$r->[$j]{'ACTION'}} + 1,
1159                                         @{$r->[$j]{'MATCH'}});
1160                     foreach $t (@{$r->[$j]{'ACTION'}})
1161                     { $out .= pack('n2', @$t); }
1162                 } elsif ($type == 6)
1163                 {
1164                     $out .= pack('n*', $#{$r->[$j]{'PRE'}} + 1, @{$r->[$j]{'PRE'}},
1165                                     $#{$r->[$j]{'MATCH'}} + 2, @{$r->[$j]{'MATCH'}},
1166                                     $#{$r->[$j]{'POST'}} + 1, @{$r->[$j]{'POST'}},
1167                                     $#{$r->[$j]{'ACTION'}} + 1);
1168                     foreach $t (@{$r->[$j]{'ACTION'}})
1169                     { $out .= pack('n2', @$t); }
1170                 }
1171                 $offd = length($out) - $offc;
1172             }
1173             $offc = length($out);
1174         }
1175     } elsif ($type == 5 && $fmt == 3)
1176     {
1177         $out .= pack('n3', $fmt, $#{$lookup->{'RULES'}[0][0]{'MATCH'}} + 1,
1178                                 $#{$lookup->{'RULES'}[0][0]{'ACTION'}} + 1);
1179         foreach $t (@{$lookup->{'RULES'}[0][0]{'MATCH'}})
1180         { $out .= pack('n', Font::TTF::Ttopen::ref_cache($t, $ctables, length($out) + $base)); }
1181         foreach $t (@{$lookup->{'RULES'}[0][0]{'ACTION'}})
1182         { $out .= pack('n2', @$t); }
1183     } elsif ($type == 6 && $fmt == 3)
1184     {
1185         $r = $lookup->{'RULES'}[0][0];
1186                 no strict 'refs';       # temp fix - more code needed (probably "if" statements in the event 'PRE' or 'POST' are empty)
1187         $out .= pack('n2', $fmt, defined $r->{'PRE'} ? scalar @{$r->{'PRE'}} : 0);
1188         foreach $t (@{$r->{'PRE'}})
1189         { $out .= pack('n', Font::TTF::Ttopen::ref_cache($t, $ctables, length($out) + $base)); }
1190         $out .= pack('n', defined $r->{'MATCH'} ? scalar @{$r->{'MATCH'}} : 0);
1191         foreach $t (@{$r->{'MATCH'}})
1192         { $out .= pack('n', Font::TTF::Ttopen::ref_cache($t, $ctables, length($out) + $base)); }
1193         $out .= pack('n', defined $r->{'POST'} ? scalar @{$r->{'POST'}} : 0);
1194         foreach $t (@{$r->{'POST'}})
1195         { $out .= pack('n', Font::TTF::Ttopen::ref_cache($t, $ctables, length($out) + $base)); }
1196         $out .= pack('n', defined $r->{'ACTION'} ? scalar @{$r->{'ACTION'}} : 0);
1197         foreach $t (@{$r->{'ACTION'}})
1198         { $out .= pack('n2', @$t); }
1199     }
1200     $out;
1201 }
1202
1203 =head1 BUGS
1204
1205 =over 4
1206
1207 =item *
1208
1209 No way to share cachable items (coverage tables, classes, anchors, device tables)
1210 across different lookups. The items are always output after the lookup and
1211 repeated if necessary. Within lookup sharing is possible.
1212
1213 =back
1214
1215 =head1 AUTHOR
1216
1217 Martin Hosken Martin_Hosken@sil.org. See L<Font::TTF::Font> for copyright and
1218 licensing.
1219
1220 =cut
1221
1222 1;
1223