src/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