src/librarian/font-optimizer/ext/Font-TTF/lib/Font/TTF/AATutils.pm

   1 package Font::TTF::AATutils;
   2
   3 use strict;
   4 use vars qw(@ISA @EXPORT);
   5 require Exporter;
   6
   7 use Font::TTF::Utils;
   8 use IO::File;
   9
  10 @ISA = qw(Exporter);
  11 @EXPORT = qw(
  12     AAT_read_lookup
  13     AAT_pack_lookup
  14     AAT_write_lookup
  15     AAT_pack_classes
  16     AAT_write_classes
  17     AAT_pack_states
  18     AAT_write_states
  19     AAT_read_state_table
  20     AAT_read_subtable
  21     xmldump
  22 );
  23
  24 sub xmldump
  25 {
  26     my ($var, $links, $depth, $processedVars, $type) = @_;
  27
  28     $processedVars = {} unless (defined $processedVars);
  29     print("<?xml version='1.0' encoding='UTF-8'?>\n") if $depth == 0;    # not necessarily true encoding for all text!
  30
  31     my $indent = "\t" x $depth;
  32
  33     my ($objType, $addr) = ($var =~ m/^.+=(.+)\((.+)\)$/);
  34     unless (defined $type) {
  35         if (defined $addr) {
  36             if (defined $processedVars->{$addr}) {
  37                 if ($links) {
  38                     printf("%s%s\n", $indent, "<a href=\"#$addr\">$objType</a>");
  39                 }
  40                 else {
  41                     printf("%s%s\n", $indent, "<a>$objType</a>");
  42                 }
  43                 return;
  44             }
  45             $processedVars->{$addr} = 1;
  46         }
  47     }
  48
  49     $type = ref $var unless defined $type;
  50
  51     if ($type eq 'REF') {
  52         printf("%s<ref val=\"%s\"/>\n", $indent, $$var);
  53     }
  54     elsif ($type eq 'SCALAR') {
  55         printf("%s<scalar>%s</scalar>\n", $indent, $var);
  56     }
  57     elsif ($type eq 'ARRAY') {
  58         # printf("%s<array>\n", $indent);
  59         foreach (0 .. $#$var) {
  60             if (ref($var->[$_])) {
  61                 printf("%s<arrayItem index=\"%d\">\n", $indent, $_);
  62                 xmldump($var->[$_], $links, $depth + 1, $processedVars);
  63                 printf("%s</arrayItem>\n", $indent);
  64             }
  65             else {
  66                 printf("%s<arrayItem index=\"%d\">%s</arrayItem>\n", $indent, $_, $var->[$_]);
  67             }
  68         }
  69         # printf("%s</array>\n", $indent);
  70     }
  71     elsif ($type eq 'HASH') {
  72         # printf("%s<hash>\n", $indent);
  73         foreach (sort keys %$var) {
  74             if (ref($var->{$_})) {
  75                 printf("%s<hashElem key=\"%s\">\n", $indent, $_);
  76                 xmldump($var->{$_}, $links, $depth + 1, $processedVars);
  77                 printf("%s</hashElem>\n", $indent);
  78             }
  79             else {
  80                 printf("%s<hashElem key=\"%s\">%s</hashElem>\n", $indent, $_, $var->{$_});
  81             }
  82         }
  83         # printf("%s</hash>\n", $indent);
  84     }
  85     elsif ($type eq 'CODE') {
  86         printf("%s<CODE/>\n", $indent, $var);
  87     }
  88     elsif ($type eq 'GLOB') {
  89         printf("%s<GLOB/>\n", $indent, $var);
  90     }
  91     elsif ($type eq '') {
  92         printf("%s<val>%s</val>\n", $indent, $var);
  93     }
  94     else {
  95         if ($links) {
  96             printf("%s<obj class=\"%s\" id=\"#%s\">\n", $indent, $type, $addr);
  97         }
  98         else {
  99             printf("%s<obj class=\"%s\">\n", $indent, $type);
 100         }
 101         xmldump($var, $links, $depth + 1, $processedVars, $objType);
 102         printf("%s</obj>\n", $indent);
 103     }
 104 }
 105
 106 =head2 ($classes, $states) = AAT_read_subtable($fh, $baseOffset, $subtableStart, $limits)
 107
 108 =cut
 109
 110 sub AAT_read_subtable
 111 {
 112     my ($fh, $baseOffset, $subtableStart, $limits) = @_;
 113
 114     my $limit = 0xffffffff;
 115     foreach (@$limits) {
 116         $limit = $_ if ($_ > $subtableStart and $_ < $limit);
 117     }
 118     die if $limit == 0xffffffff;
 119
 120     my $dat;
 121     $fh->seek($baseOffset + $subtableStart, IO::File::SEEK_SET);
 122     $fh->read($dat, $limit - $subtableStart);
 123
 124     $dat;
 125 }
 126
 127 =head2 $length = AAT_write_state_table($fh, $classes, $states, $numExtraTables, $packEntry)
 128
 129 $packEntry is a subroutine for packing an entry into binary form, called as
 130
 131 $dat = $packEntry($entry, $entryTable, $numEntries)
 132
 133 where the entry is a comma-separated list of nextStateOffset, flags, actions
 134
 135 =cut
 136
 137 sub AAT_pack_state_table
 138 {
 139     my ($classes, $states, $numExtraTables, $packEntry) = @_;
 140
 141     my ($dat) = pack("n*", (0) x (4 + $numExtraTables));    # placeholders for stateSize, classTable, stateArray, entryTable
 142
 143     my ($firstGlyph, $lastGlyph) = (0xffff, 0, 0);
 144     my (@classTable, $i);
 145     foreach $i (0 .. $#$classes) {
 146         my $class = $classes->[$i];
 147         foreach (@$class) {
 148             $firstGlyph = $_ if $_ < $firstGlyph;
 149             $lastGlyph = $_ if $_ > $lastGlyph;
 150             $classTable[$_] = $i;
 151         }
 152     }
 153
 154     my $classTable = length($dat);
 155     $dat .= pack("nnC*", $firstGlyph, $lastGlyph - $firstGlyph + 1,
 156                     map { defined $classTable[$_] ? $classTable[$_] : 1 } ($firstGlyph .. $lastGlyph));
 157     $dat .= pack("C", 0) if (($lastGlyph - $firstGlyph) & 1) == 0;    # pad if odd number of glyphs
 158
 159     my $stateArray = length($dat);
 160     my (@entries, %entries);
 161     my $state = $states->[0];
 162     my $stateSize = @$state;
 163     die "stateSize below minimum allowed (4)" if $stateSize < 4;
 164     die "stateSize (" . $stateSize . ") too small for max class number (" . $#$classes . ")" if $stateSize < $#$classes + 1;
 165     warn "state array has unreachable columns" if $stateSize > $#$classes + 1;
 166
 167     foreach (@$states) {
 168         die "inconsistent state size" if @$_ != $stateSize;
 169         foreach (@$_) {
 170             my $actions = $_->{'actions'};
 171             my $entry = join(",", $stateArray + $_->{'nextState'} * $stateSize, $_->{'flags'}, ref($actions) eq 'ARRAY' ? @$actions : $actions);
 172             if (not defined $entries{$entry}) {
 173                 push @entries, $entry;
 174                 $entries{$entry} = $#entries;
 175                 die "too many different state array entries" if $#entries == 256;
 176             }
 177             $dat .= pack("C", $entries{$entry});
 178         }
 179     }
 180     $dat .= pack("C", 0) if (@$states & 1) != 0 and ($stateSize & 1) != 0;    # pad if state array size is odd
 181
 182     my $entryTable = length($dat);
 183     $dat .= map { &$packEntry($_, $entryTable, $#entries + 1) } @entries;
 184
 185     my ($dat1) = pack("nnnn", $stateSize, $classTable, $stateArray, $entryTable);
 186     substr($dat, 0, length($dat1)) = $dat1;
 187
 188     return $dat;
 189 }
 190
 191 sub AAT_write_state_table
 192 {
 193     my ($fh, $classes, $states, $numExtraTables, $packEntry) = @_;
 194
 195     my $stateTableStart = $fh->tell();
 196
 197     $fh->print(pack("n*", (0) x (4 + $numExtraTables)));    # placeholders for stateSize, classTable, stateArray, entryTable
 198
 199     my ($firstGlyph, $lastGlyph) = (0xffff, 0, 0);
 200     my (@classTable, $i);
 201     foreach $i (0 .. $#$classes) {
 202         my $class = $classes->[$i];
 203         foreach (@$class) {
 204             $firstGlyph = $_ if $_ < $firstGlyph;
 205             $lastGlyph = $_ if $_ > $lastGlyph;
 206             $classTable[$_] = $i;
 207         }
 208     }
 209
 210     my $classTable = $fh->tell() - $stateTableStart;
 211     $fh->print(pack("nnC*", $firstGlyph, $lastGlyph - $firstGlyph + 1,
 212                     map { defined $classTable[$_] ? $classTable[$_] : 1 } ($firstGlyph .. $lastGlyph)));
 213     $fh->print(pack("C", 0)) if (($lastGlyph - $firstGlyph) & 1) == 0;    # pad if odd number of glyphs
 214
 215     my $stateArray = $fh->tell() - $stateTableStart;
 216     my (@entries, %entries);
 217     my $state = $states->[0];
 218     my $stateSize = @$state;
 219     die "stateSize below minimum allowed (4)" if $stateSize < 4;
 220     die "stateSize (" . $stateSize . ") too small for max class number (" . $#$classes . ")" if $stateSize < $#$classes + 1;
 221     warn "state array has unreachable columns" if $stateSize > $#$classes + 1;
 222
 223     foreach (@$states) {
 224         die "inconsistent state size" if @$_ != $stateSize;
 225         foreach (@$_) {
 226             my $actions = $_->{'actions'};
 227             my $entry = join(",", $stateArray + $_->{'nextState'} * $stateSize, $_->{'flags'}, ref($actions) eq 'ARRAY' ? @$actions : $actions);
 228             if (not defined $entries{$entry}) {
 229                 push @entries, $entry;
 230                 $entries{$entry} = $#entries;
 231                 die "too many different state array entries" if $#entries == 256;
 232             }
 233             $fh->print(pack("C", $entries{$entry}));
 234         }
 235     }
 236     $fh->print(pack("C", 0)) if (@$states & 1) != 0 and ($stateSize & 1) != 0;    # pad if state array size is odd
 237
 238     my $entryTable = $fh->tell() - $stateTableStart;
 239     $fh->print(map { &$packEntry($_, $entryTable, $#entries + 1) } @entries);
 240
 241     my $length = $fh->tell() - $stateTableStart;
 242     $fh->seek($stateTableStart, IO::File::SEEK_SET);
 243     $fh->print(pack("nnnn", $stateSize, $classTable, $stateArray, $entryTable));
 244
 245     $fh->seek($stateTableStart + $length, IO::File::SEEK_SET);
 246     $length;
 247 }
 248
 249 sub AAT_pack_classes
 250 {
 251     my ($classes) = @_;
 252
 253     my ($firstGlyph, $lastGlyph) = (0xffff, 0, 0);
 254     my (@classTable, $i);
 255     foreach $i (0 .. $#$classes) {
 256         my $class = $classes->[$i];
 257         foreach (@$class) {
 258             $firstGlyph = $_ if $_ < $firstGlyph;
 259             $lastGlyph = $_ if $_ > $lastGlyph;
 260             $classTable[$_] = $i;
 261         }
 262     }
 263
 264     my ($dat) = pack("nnC*", $firstGlyph, $lastGlyph - $firstGlyph + 1,
 265                     map { defined $classTable[$_] ? $classTable[$_] : 1 } ($firstGlyph .. $lastGlyph));
 266     $dat .= pack("C", 0) if (($lastGlyph - $firstGlyph) & 1) == 0;    # pad if odd number of glyphs
 267
 268     return $dat;
 269 }
 270
 271 sub AAT_write_classes
 272 {
 273     my ($fh, $classes) = @_;
 274
 275     $fh->print(AAT_pack_classes($fh, $classes));
 276 }
 277
 278 sub AAT_pack_states
 279 {
 280     my ($classes, $stateArray, $states, $buildEntryProc) = @_;
 281
 282     my ($entries, %entryHash);
 283     my $state = $states->[0];
 284     my $stateSize = @$state;
 285
 286     die "stateSize below minimum allowed (4)" if $stateSize < 4;
 287     die "stateSize (" . $stateSize . ") too small for max class number (" . $#$classes . ")" if $stateSize < $#$classes + 1;
 288     warn "state array has unreachable columns" if $stateSize > $#$classes + 1;
 289
 290     my ($dat);
 291     foreach (@$states) {
 292         die "inconsistent state size" if @$_ != $stateSize;
 293         foreach (@$_) {
 294             my $entry = join(",", $stateArray + $_->{'nextState'} * $stateSize, &$buildEntryProc($_));
 295             if (not defined $entryHash{$entry}) {
 296                 push @$entries, $entry;
 297                 $entryHash{$entry} = $#$entries;
 298                 die "too many different state array entries" if $#$entries == 256;
 299             }
 300             $dat .= pack("C", $entryHash{$entry});
 301         }
 302     }
 303     $dat .= pack("C", 0) if (@$states & 1) != 0 and ($stateSize & 1) != 0;    # pad if state array size is odd
 304
 305     ($dat, $stateSize, $entries);
 306 }
 307
 308 sub AAT_write_states
 309 {
 310     my ($fh, $classes, $stateArray, $states, $buildEntryProc) = @_;
 311
 312     my ($entries, %entryHash);
 313     my $state = $states->[0];
 314     my $stateSize = @$state;
 315
 316     die "stateSize below minimum allowed (4)" if $stateSize < 4;
 317     die "stateSize (" . $stateSize . ") too small for max class number (" . $#$classes . ")" if $stateSize < $#$classes + 1;
 318     warn "state array has unreachable columns" if $stateSize > $#$classes + 1;
 319
 320     foreach (@$states) {
 321         die "inconsistent state size" if @$_ != $stateSize;
 322         foreach (@$_) {
 323             my $entry = join(",", $stateArray + $_->{'nextState'} * $stateSize, &$buildEntryProc($_));
 324             if (not defined $entryHash{$entry}) {
 325                 push @$entries, $entry;
 326                 $entryHash{$entry} = $#$entries;
 327                 die "too many different state array entries" if $#$entries == 256;
 328             }
 329             $fh->print(pack("C", $entryHash{$entry}));
 330         }
 331     }
 332     $fh->print(pack("C", 0)) if (@$states & 1) != 0 and ($stateSize & 1) != 0;    # pad if state array size is odd
 333
 334     ($stateSize, $entries);
 335 }
 336
 337 =head2 ($classes, $states, $entries) = AAT_read_state_table($fh, $numActionWords)
 338
 339 =cut
 340
 341 sub AAT_read_state_table
 342 {
 343     my ($fh, $numActionWords) = @_;
 344
 345     my $stateTableStart = $fh->tell();
 346     my $dat;
 347     $fh->read($dat, 8);
 348     my ($stateSize, $classTable, $stateArray, $entryTable) = unpack("nnnn", $dat);
 349
 350     my $classes;    # array of lists of glyphs
 351
 352     $fh->seek($stateTableStart + $classTable, IO::File::SEEK_SET);
 353     $fh->read($dat, 4);
 354     my ($firstGlyph, $nGlyphs) = unpack("nn", $dat);
 355     $fh->read($dat, $nGlyphs);
 356     foreach (unpack("C*", $dat)) {
 357         if ($_ != 1) {
 358             my $class = $classes->[$_];
 359             push(@$class, $firstGlyph);
 360             $classes->[$_] = $class unless defined $classes->[$_];
 361         }
 362         $firstGlyph++;
 363     }
 364
 365     $fh->seek($stateTableStart + $stateArray, IO::File::SEEK_SET);
 366     my $states;    # array of arrays of hashes{nextState, flags, actions}
 367
 368     my $entrySize = 4 + ($numActionWords * 2);
 369     my $lastState = 1;
 370     my $entries;
 371     while ($#$states < $lastState) {
 372         $fh->read($dat, $stateSize);
 373         my @stateEntries = unpack("C*", $dat);
 374         my $state;
 375         foreach (@stateEntries) {
 376             if (not defined $entries->[$_]) {
 377                 my $loc = $fh->tell();
 378                 $fh->seek($stateTableStart + $entryTable + ($_ * $entrySize), IO::File::SEEK_SET);
 379                 $fh->read($dat, $entrySize);
 380                 my ($nextState, $flags, $actions);
 381                 ($nextState, $flags, @$actions) = unpack("n*", $dat);
 382                 $nextState -= $stateArray;
 383                 $nextState /= $stateSize;
 384                 $entries->[$_] = { 'nextState' => $nextState, 'flags' => $flags };
 385                 $entries->[$_]->{'actions'} = $actions if $numActionWords > 0;
 386                 $lastState = $nextState if ($nextState > $lastState);
 387                 $fh->seek($loc, IO::File::SEEK_SET);
 388             }
 389             push(@$state, $entries->[$_]);
 390         }
 391         push(@$states, $state);
 392     }
 393
 394     ($classes, $states, $entries);
 395 }
 396
 397 =head2 ($format, $lookup) = AAT_read_lookup($fh, $valueSize, $length, $default)
 398
 399 =cut
 400
 401 sub AAT_read_lookup
 402 {
 403     my ($fh, $valueSize, $length, $default) = @_;
 404
 405     my $lookupStart = $fh->tell();
 406     my ($dat, $unpackChar);
 407     if ($valueSize == 1) {
 408         $unpackChar = "C";
 409     }
 410     elsif ($valueSize == 2) {
 411         $unpackChar = "n";
 412     }
 413     elsif ($valueSize == 4) {
 414         $unpackChar = "N";
 415     }
 416     else {
 417         die "unsupported value size";
 418     }
 419
 420     $fh->read($dat, 2);
 421     my $format = unpack("n", $dat);
 422     my $lookup;
 423
 424     if ($format == 0) {
 425         $fh->read($dat, $length - 2);
 426         my $i = -1;
 427         $lookup = { map { $i++; ($_ != $default) ? ($i, $_) : () } unpack($unpackChar . "*", $dat) };
 428     }
 429
 430     elsif ($format == 2) {
 431         $fh->read($dat, 10);
 432         my ($unitSize, $nUnits, $searchRange, $entrySelector, $rangeShift) = unpack("nnnnn", $dat);
 433         die if $unitSize != 4 + $valueSize;
 434         foreach (1 .. $nUnits) {
 435             $fh->read($dat, $unitSize);
 436             my ($lastGlyph, $firstGlyph, $value) = unpack("nn" . $unpackChar, $dat);
 437             if ($firstGlyph != 0xffff and $value != $default) {
 438                 foreach ($firstGlyph .. $lastGlyph) {
 439                     $lookup->{$_} = $value;
 440                 }
 441             }
 442         }
 443     }
 444
 445     elsif ($format == 4) {
 446         $fh->read($dat, 10);
 447         my ($unitSize, $nUnits, $searchRange, $entrySelector, $rangeShift) = unpack("nnnnn", $dat);
 448         die if $unitSize != 6;
 449         foreach (1 .. $nUnits) {
 450             $fh->read($dat, $unitSize);
 451             my ($lastGlyph, $firstGlyph, $offset) = unpack("nnn", $dat);
 452             if ($firstGlyph != 0xffff) {
 453                 my $loc = $fh->tell();
 454                 $fh->seek($lookupStart + $offset, IO::File::SEEK_SET);
 455                 $fh->read($dat, ($lastGlyph - $firstGlyph + 1) * $valueSize);
 456                 my @values = unpack($unpackChar . "*", $dat);
 457                 foreach (0 .. $lastGlyph - $firstGlyph) {
 458                     $lookup->{$firstGlyph + $_} = $values[$_] if $values[$_] != $default;
 459                 }
 460                 $fh->seek($loc, IO::File::SEEK_SET);
 461             }
 462         }
 463     }
 464
 465     elsif ($format == 6) {
 466         $fh->read($dat, 10);
 467         my ($unitSize, $nUnits, $searchRange, $entrySelector, $rangeShift) = unpack("nnnnn", $dat);
 468         die if $unitSize != 2 + $valueSize;
 469         foreach (1 .. $nUnits) {
 470             $fh->read($dat, $unitSize);
 471             my ($glyph, $value) = unpack("n" . $unpackChar, $dat);
 472             $lookup->{$glyph} = $value if $glyph != 0xffff and $value != $default;
 473         }
 474     }
 475
 476     elsif ($format == 8) {
 477         $fh->read($dat, 4);
 478         my ($firstGlyph, $glyphCount) = unpack("nn", $dat);
 479         $fh->read($dat, $glyphCount * $valueSize);
 480         $firstGlyph--;
 481         $lookup = { map { $firstGlyph++; $_ != $default ? ($firstGlyph, $_) : () } unpack($unpackChar . "*", $dat) };
 482     }
 483
 484     else {
 485         die "unknown lookup format";
 486     }
 487
 488     $fh->seek($lookupStart + $length, IO::File::SEEK_SET);
 489
 490     ($format, $lookup);
 491 }
 492
 493 =head2 AAT_write_lookup($fh, $format, $lookup, $valueSize, $default)
 494
 495 =cut
 496
 497 sub AAT_pack_lookup
 498 {
 499     my ($format, $lookup, $valueSize, $default) = @_;
 500
 501     my $packChar;
 502     if ($valueSize == 1) {
 503         $packChar = "C";
 504     }
 505     elsif ($valueSize == 2) {
 506         $packChar = "n";
 507     }
 508     elsif ($valueSize == 4) {
 509         $packChar = "N";
 510     }
 511     else {
 512         die "unsupported value size";
 513     }
 514
 515     my ($dat) = pack("n", $format);
 516
 517     my ($firstGlyph, $lastGlyph) = (0xffff, 0);
 518     foreach (keys %$lookup) {
 519         $firstGlyph = $_ if $_ < $firstGlyph;
 520         $lastGlyph = $_ if $_ > $lastGlyph;
 521     }
 522     my $glyphCount = $lastGlyph - $firstGlyph + 1;
 523
 524     if ($format == 0) {
 525         $dat .= pack($packChar . "*", map { defined $lookup->{$_} ? $lookup->{$_} : defined $default ? $default : $_ } (0 .. $lastGlyph));
 526     }
 527
 528     elsif ($format == 2) {
 529         my $prev = $default;
 530         my $segStart = $firstGlyph;
 531         my $dat1;
 532         foreach ($firstGlyph .. $lastGlyph + 1) {
 533             my $val = $lookup->{$_};
 534             $val = $default unless defined $val;
 535             if ($val != $prev) {
 536                 $dat1 .= pack("nn" . $packChar, $_ - 1, $segStart, $prev) if $prev != $default;
 537                 $prev = $val;
 538                 $segStart = $_;
 539             }
 540         }
 541         $dat1 .= pack("nn" . $packChar, 0xffff, 0xffff, 0);
 542         my $unitSize = 4 + $valueSize;
 543         $dat .= pack("nnnnn", $unitSize, TTF_bininfo(length($dat1) / $unitSize, $unitSize));
 544         $dat .= $dat1;
 545     }
 546
 547     elsif ($format == 4) {
 548         my $segArray = new Font::TTF::Segarr($valueSize);
 549         $segArray->add_segment($firstGlyph, 1, map { $lookup->{$_} } ($firstGlyph .. $lastGlyph));
 550         my ($start, $end, $offset);
 551         $offset = 12 + @$segArray * 6 + 6;    # 12 is size of format word + binSearchHeader; 6 bytes per segment; 6 for terminating segment
 552         my $dat1;
 553         foreach (@$segArray) {
 554             $start = $_->{'START'};
 555             $end = $start + $_->{'LEN'} - 1;
 556             $dat1 .= pack("nnn", $end, $start, $offset);
 557             $offset += $_->{'LEN'} * 2;
 558         }
 559         $dat1 .= pack("nnn", 0xffff, 0xffff, 0);
 560         $dat .= pack("nnnnn", 6, TTF_bininfo(length($dat1) / 6, 6));
 561         $dat .= $dat1;
 562         foreach (@$segArray) {
 563             $dat1 = $_->{'VAL'};
 564             $dat .= pack($packChar . "*", @$dat1);
 565         }
 566     }
 567
 568     elsif ($format == 6) {
 569         die "unsupported" if $valueSize != 2;
 570         my $dat1 = pack("n*", map { $_, $lookup->{$_} } sort { $a <=> $b } grep { $lookup->{$_} ne $default } keys %$lookup);
 571         my $unitSize = 2 + $valueSize;
 572         $dat .= pack("nnnnn", $unitSize, TTF_bininfo(length($dat1) / $unitSize, $unitSize));
 573         $dat .= $dat1;
 574     }
 575
 576     elsif ($format == 8) {
 577         $dat .= pack("nn", $firstGlyph, $lastGlyph - $firstGlyph + 1);
 578         $dat .= pack($packChar . "*", map { defined $lookup->{$_} ? $lookup->{$_} : defined $default ? $default : $_ } ($firstGlyph .. $lastGlyph));
 579     }
 580
 581     else {
 582         die "unknown lookup format";
 583     }
 584
 585     my $padBytes = (4 - (length($dat) & 3)) & 3;
 586     $dat .= pack("C*", (0) x $padBytes);
 587
 588     return $dat;
 589 }
 590
 591 sub AAT_write_lookup
 592 {
 593     my ($fh, $format, $lookup, $valueSize, $default) = @_;
 594
 595     my $lookupStart = $fh->tell();
 596     my $packChar;
 597     if ($valueSize == 1) {
 598         $packChar = "C";
 599     }
 600     elsif ($valueSize == 2) {
 601         $packChar = "n";
 602     }
 603     elsif ($valueSize == 4) {
 604         $packChar = "N";
 605     }
 606     else {
 607         die "unsupported value size";
 608     }
 609
 610     $fh->print(pack("n", $format));
 611
 612     my ($firstGlyph, $lastGlyph) = (0xffff, 0);
 613     foreach (keys %$lookup) {
 614         $firstGlyph = $_ if $_ < $firstGlyph;
 615         $lastGlyph = $_ if $_ > $lastGlyph;
 616     }
 617     my $glyphCount = $lastGlyph - $firstGlyph + 1;
 618
 619     if ($format == 0) {
 620         $fh->print(pack($packChar . "*", map { defined $lookup->{$_} ? $lookup->{$_} : defined $default ? $default : $_ } (0 .. $lastGlyph)));
 621     }
 622
 623     elsif ($format == 2) {
 624         my $prev = $default;
 625         my $segStart = $firstGlyph;
 626         my $dat;
 627         foreach ($firstGlyph .. $lastGlyph + 1) {
 628             my $val = $lookup->{$_};
 629             $val = $default unless defined $val;
 630             if ($val != $prev) {
 631                 $dat .= pack("nn" . $packChar, $_ - 1, $segStart, $prev) if $prev != $default;
 632                 $prev = $val;
 633                 $segStart = $_;
 634             }
 635         }
 636         $dat .= pack("nn" . $packChar, 0xffff, 0xffff, 0);
 637         my $unitSize = 4 + $valueSize;
 638         $fh->print(pack("nnnnn", $unitSize, TTF_bininfo(length($dat) / $unitSize, $unitSize)));
 639         $fh->print($dat);
 640     }
 641
 642     elsif ($format == 4) {
 643         my $segArray = new Font::TTF::Segarr($valueSize);
 644         $segArray->add_segment($firstGlyph, 1, map { $lookup->{$_} } ($firstGlyph .. $lastGlyph));
 645         my ($start, $end, $offset);
 646         $offset = 12 + @$segArray * 6 + 6;    # 12 is size of format word + binSearchHeader; 6 bytes per segment; 6 for terminating segment
 647         my $dat;
 648         foreach (@$segArray) {
 649             $start = $_->{'START'};
 650             $end = $start + $_->{'LEN'} - 1;
 651             $dat .= pack("nnn", $end, $start, $offset);
 652             $offset += $_->{'LEN'} * 2;
 653         }
 654         $dat .= pack("nnn", 0xffff, 0xffff, 0);
 655         $fh->print(pack("nnnnn", 6, TTF_bininfo(length($dat) / 6, 6)));
 656         $fh->print($dat);
 657         foreach (@$segArray) {
 658             $dat = $_->{'VAL'};
 659             $fh->print(pack($packChar . "*", @$dat));
 660         }
 661     }
 662
 663     elsif ($format == 6) {
 664         die "unsupported" if $valueSize != 2;
 665         my $dat = pack("n*", map { $_, $lookup->{$_} } sort { $a <=> $b } grep { $lookup->{$_} ne $default } keys %$lookup);
 666         my $unitSize = 2 + $valueSize;
 667         $fh->print(pack("nnnnn", $unitSize, TTF_bininfo(length($dat) / $unitSize, $unitSize)));
 668         $fh->print($dat);
 669     }
 670
 671     elsif ($format == 8) {
 672         $fh->print(pack("nn", $firstGlyph, $lastGlyph - $firstGlyph + 1));
 673         $fh->print(pack($packChar . "*", map { defined $lookup->{$_} ? $lookup->{$_} : defined $default ? $default : $_ } ($firstGlyph .. $lastGlyph)));
 674     }
 675
 676     else {
 677         die "unknown lookup format";
 678     }
 679
 680     my $length = $fh->tell() - $lookupStart;
 681     my $padBytes = (4 - ($length & 3)) & 3;
 682     $fh->print(pack("C*", (0) x $padBytes));
 683     $length += $padBytes;
 684
 685     $length;
 686 }
 687
 688 1;
 689