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

   1 package Font::TTF::Cmap;
   2
   3 =head1 NAME
   4
   5 Font::TTF::Cmap - Character map table
   6
   7 =head1 DESCRIPTION
   8
   9 Looks after the character map. For ease of use, the actual cmap is held in
  10 a hash against codepoint. Thus for a given table:
  11
  12     $gid = $font->{'cmap'}{'Tables'}[0]{'val'}{$code};
  13
  14 Note that C<$code> should be a true value (0x1234) rather than a string representation.
  15
  16 =head1 INSTANCE VARIABLES
  17
  18 The instance variables listed here are not preceeded by a space due to their
  19 emulating structural information in the font.
  20
  21 =over 4
  22
  23 =item Num
  24
  25 Number of subtables in this table
  26
  27 =item Tables
  28
  29 An array of subtables ([0..Num-1])
  30
  31 =back
  32
  33 Each subtables also has its own instance variables which are, again, not
  34 preceeded by a space.
  35
  36 =over 4
  37
  38 =item Platform
  39
  40 The platform number for this subtable
  41
  42 =item Encoding
  43
  44 The encoding number for this subtable
  45
  46 =item Format
  47
  48 Gives the stored format of this subtable
  49
  50 =item Ver
  51
  52 Gives the version (or language) information for this subtable
  53
  54 =item val
  55
  56 A hash keyed by the codepoint value (not a string) storing the glyph id
  57
  58 =back
  59
  60 =head1 METHODS
  61
  62 =cut
  63
  64 use strict;
  65 use vars qw(@ISA);
  66 use Font::TTF::Table;
  67 use Font::TTF::Utils;
  68
  69 @ISA = qw(Font::TTF::Table);
  70
  71
  72 =head2 $t->read
  73
  74 Reads the cmap into memory. Format 4 subtables read the whole subtable and
  75 fill in the segmented array accordingly.
  76
  77 =cut
  78
  79 sub read
  80 {
  81     my ($self) = @_;
  82     my ($dat, $i, $j, $k, $id, @ids, $s);
  83     my ($start, $end, $range, $delta, $form, $len, $num, $ver, $sg);
  84     my ($fh) = $self->{' INFILE'};
  85
  86     $self->SUPER::read or return $self;
  87     $fh->read($dat, 4);
  88     $self->{'Num'} = unpack("x2n", $dat);
  89     $self->{'Tables'} = [];
  90     for ($i = 0; $i < $self->{'Num'}; $i++)
  91     {
  92         $s = {};
  93         $fh->read($dat, 8);
  94         ($s->{'Platform'}, $s->{'Encoding'}, $s->{'LOC'}) = (unpack("nnN", $dat));
  95         $s->{'LOC'} += $self->{' OFFSET'};
  96         push(@{$self->{'Tables'}}, $s);
  97     }
  98     for ($i = 0; $i < $self->{'Num'}; $i++)
  99     {
 100         $s = $self->{'Tables'}[$i];
 101         $fh->seek($s->{'LOC'}, 0);
 102         $fh->read($dat, 2);
 103         $form = unpack("n", $dat);
 104
 105         $s->{'Format'} = $form;
 106         if ($form == 0)
 107         {
 108             my $j = 0;
 109
 110             $fh->read($dat, 4);
 111             ($len, $s->{'Ver'}) = unpack('n2', $dat);
 112             $fh->read($dat, 256);
 113             $s->{'val'} = {map {$j++; ($_ ? ($j - 1, $_) : ())} unpack("C*", $dat)};
 114         } elsif ($form == 6)
 115         {
 116             my ($start, $ecount);
 117
 118             $fh->read($dat, 8);
 119             ($len, $s->{'Ver'}, $start, $ecount) = unpack('n4', $dat);
 120             $fh->read($dat, $ecount << 1);
 121             $s->{'val'} = {map {$start++; ($_ ? ($start - 1, $_) : ())} unpack("n*", $dat)};
 122         } elsif ($form == 2)        # Contributed by Huw Rogers
 123         {
 124             $fh->read($dat, 4);
 125             ($len, $s->{'Ver'}) = unpack('n2', $dat);
 126             $fh->read($dat, 512);
 127             my ($j, $k, $l, $m, $n, @subHeaderKeys, @subHeaders, $subHeader);
 128             $n = 1;
 129             for ($j = 0; $j < 256; $j++) {
 130                 my $k = unpack('@'.($j<<1).'n', $dat)>>3;
 131                 $n = $k + 1 if $k >= $n;
 132                 $subHeaders[$subHeaderKeys[$j] = $k] ||= [ ];
 133             }
 134             $fh->read($dat, $n<<3); # read subHeaders[]
 135             for ($k = 0; $k < $n; $k++) {
 136                 $subHeader = $subHeaders[$k];
 137                 $l = $k<<3;
 138                 @$subHeader = unpack('@'.$l.'n4', $dat);
 139                 $subHeader->[2] = unpack('s', pack('S', $subHeader->[2]))
 140                     if $subHeader->[2] & 0x8000; # idDelta
 141                 $subHeader->[3] =
 142                     ($subHeader->[3] - (($n - $k)<<3) + 6)>>1; # idRangeOffset
 143             }
 144             $fh->read($dat, $len - ($n<<3) - 518); # glyphIndexArray[]
 145             for ($j = 0; $j < 256; $j++) {
 146                 $k = $subHeaderKeys[$j];
 147                 $subHeader = $subHeaders[$k];
 148                 unless ($k) {
 149                     $l = $j - $subHeader->[0];
 150                     if ($l >= 0 && $l < $subHeader->[1]) {
 151                         $m = unpack('@'.(($l + $subHeader->[3])<<1).'n', $dat);
 152                         $m += $subHeader->[2] if $m;
 153                         $s->{'val'}{$j} = $m;
 154                     }
 155                 } else {
 156                     for ($l = 0; $l < $subHeader->[1]; $l++) {
 157                         $m = unpack('@'.(($l + $subHeader->[3])<<1).'n', $dat);
 158                         $m += $subHeader->[2] if $m;
 159                         $s->{'val'}{($j<<8) + $l + $subHeader->[0]} = $m;
 160                     }
 161                 }
 162             }
 163         } elsif ($form == 4)
 164         {
 165             $fh->read($dat, 12);
 166             ($len, $s->{'Ver'}, $num) = unpack('n3', $dat);
 167             $num >>= 1;
 168             $fh->read($dat, $len - 14);
 169             for ($j = 0; $j < $num; $j++)
 170             {
 171                 $end = unpack("n", substr($dat, $j << 1, 2));
 172                 $start = unpack("n", substr($dat, ($j << 1) + ($num << 1) + 2, 2));
 173                 $delta = unpack("n", substr($dat, ($j << 1) + ($num << 2) + 2, 2));
 174                 $delta -= 65536 if $delta > 32767;
 175                 $range = unpack("n", substr($dat, ($j << 1) + $num * 6 + 2, 2));
 176                 for ($k = $start; $k <= $end; $k++)
 177                 {
 178                     if ($range == 0 || $range == 65535)         # support the buggy FOG with its range=65535 for final segment
 179                     { $id = $k + $delta; }
 180                     else
 181                     { $id = unpack("n", substr($dat, ($j << 1) + $num * 6 +
 182                                         2 + ($k - $start) * 2 + $range, 2)) + $delta; }
 183                             $id -= 65536 if $id >= 65536;
 184                     $s->{'val'}{$k} = $id if ($id);
 185                 }
 186             }
 187         } elsif ($form == 8 || $form == 12)
 188         {
 189             $fh->read($dat, 10);
 190             ($len, $s->{'Ver'}) = unpack('x2N2', $dat);
 191             if ($form == 8)
 192             {
 193                 $fh->read($dat, 8196);
 194                 $num = unpack("N", substr($dat, 8192, 4)); # don't need the map
 195             } else
 196             {
 197                 $fh->read($dat, 4);
 198                 $num = unpack("N", $dat);
 199             }
 200             $fh->read($dat, 12 * $num);
 201             for ($j = 0; $j < $num; $j++)
 202             {
 203                 ($start, $end, $sg) = unpack("N3", substr($dat, $j * 12, 12));
 204                 for ($k = $start; $k <= $end; $k++)
 205                 { $s->{'val'}{$k} = $sg++; }
 206             }
 207         } elsif ($form == 10)
 208         {
 209             $fh->read($dat, 18);
 210             ($len, $s->{'Ver'}, $start, $num) = unpack('x2N4', $dat);
 211             $fh->read($dat, $num << 1);
 212             for ($j = 0; $j < $num; $j++)
 213             { $s->{'val'}{$start + $j} = unpack("n", substr($dat, $j << 1, 2)); }
 214         }
 215     }
 216     $self;
 217 }
 218
 219
 220 =head2 $t->ms_lookup($uni)
 221
 222 Finds a Unicode table, giving preference to the MS one, and looks up the given
 223 Unicode codepoint in it to find the glyph id.
 224
 225 =cut
 226
 227 sub ms_lookup
 228 {
 229     my ($self, $uni) = @_;
 230
 231     $self->find_ms || return undef unless (defined $self->{' mstable'});
 232     return $self->{' mstable'}{'val'}{$uni};
 233 }
 234
 235
 236 =head2 $t->find_ms
 237
 238 Finds the a Unicode table, giving preference to the Microsoft one, and sets the C<mstable> instance variable
 239 to it if found. Returns the table it finds.
 240
 241 =cut
 242 sub find_ms
 243 {
 244     my ($self) = @_;
 245     my ($i, $s, $alt, $found);
 246
 247     return $self->{' mstable'} if defined $self->{' mstable'};
 248     $self->read;
 249     for ($i = 0; $i < $self->{'Num'}; $i++)
 250     {
 251         $s = $self->{'Tables'}[$i];
 252         if ($s->{'Platform'} == 3)
 253         {
 254             $self->{' mstable'} = $s;
 255             last if ($s->{'Encoding'} == 10);
 256             $found = 1 if ($s->{'Encoding'} == 1);
 257         } elsif ($s->{'Platform'} == 0 || ($s->{'Platform'} == 2 && $s->{'Encoding'} == 1))
 258         { $alt = $s; }
 259     }
 260     $self->{' mstable'} = $alt if ($alt && !$found);
 261     $self->{' mstable'};
 262 }
 263
 264
 265 =head2 $t->ms_enc
 266
 267 Returns the encoding of the microsoft table (0 => symbol, etc.). Returns undef if there is
 268 no Microsoft cmap.
 269
 270 =cut
 271
 272 sub ms_enc
 273 {
 274     my ($self) = @_;
 275     my ($s);
 276
 277     return $self->{' mstable'}{'Encoding'}
 278         if (defined $self->{' mstable'} && $self->{' mstable'}{'Platform'} == 3);
 279
 280     foreach $s (@{$self->{'Tables'}})
 281     {
 282         return $s->{'Encoding'} if ($s->{'Platform'} == 3);
 283     }
 284     return undef;
 285 }
 286
 287
 288 =head2 $t->out($fh)
 289
 290 Writes out a cmap table to a filehandle. If it has not been read, then
 291 just copies from input file to output
 292
 293 =cut
 294
 295 sub out
 296 {
 297     my ($self, $fh) = @_;
 298     my ($loc, $s, $i, $base_loc, $j, @keys);
 299
 300     return $self->SUPER::out($fh) unless $self->{' read'};
 301
 302
 303     $self->{'Tables'} = [sort {$a->{'Platform'} <=> $b->{'Platform'}
 304                                 || $a->{'Encoding'} <=> $b->{'Encoding'}
 305                                 || $a->{'Ver'} <=> $b->{'Ver'}} @{$self->{'Tables'}}];
 306     $self->{'Num'} = scalar @{$self->{'Tables'}};
 307
 308     $base_loc = $fh->tell();
 309     $fh->print(pack("n2", 0, $self->{'Num'}));
 310
 311     for ($i = 0; $i < $self->{'Num'}; $i++)
 312     { $fh->print(pack("nnN", $self->{'Tables'}[$i]{'Platform'}, $self->{'Tables'}[$i]{'Encoding'}, 0)); }
 313
 314     for ($i = 0; $i < $self->{'Num'}; $i++)
 315     {
 316         $s = $self->{'Tables'}[$i];
 317         if ($s->{'Format'} < 8)
 318         { @keys = sort {$a <=> $b} grep { $_ <= 0xFFFF} keys %{$s->{'val'}}; }
 319         else
 320         { @keys = sort {$a <=> $b} keys %{$s->{'val'}}; }
 321         $s->{' outloc'} = $fh->tell();
 322         if ($s->{'Format'} < 8)
 323         { $fh->print(pack("n3", $s->{'Format'}, 0, $s->{'Ver'})); }       # come back for length
 324         else
 325         { $fh->print(pack("n2N2", $s->{'Format'}, 0, 0, $s->{'Ver'})); }
 326
 327         if ($s->{'Format'} == 0)
 328         {
 329             $fh->print(pack("C256", @{$s->{'val'}}{0 .. 255}));
 330         } elsif ($s->{'Format'} == 6)
 331         {
 332             $fh->print(pack("n2", $keys[0], $keys[-1] - $keys[0] + 1));
 333             $fh->print(pack("n*", @{$s->{'val'}}{$keys[0] .. $keys[-1]}));
 334         } elsif ($s->{'Format'} == 2)       # Contributed by Huw Rogers
 335         {
 336             my ($g, $k, $h, $l, $m, $n);
 337             my (@subHeaderKeys, @subHeaders, $subHeader, @glyphIndexArray);
 338             $n = 0;
 339             @subHeaderKeys = (-1) x 256;
 340             for $j (@keys) {
 341                 next unless defined($g = $s->{'val'}{$j});
 342                 $h = int($j>>8);
 343                 $l = ($j & 0xff);
 344                 if (($k = $subHeaderKeys[$h]) < 0) {
 345                     $subHeader = [ $l, 1, 0, 0, [ $g ] ];
 346                     $subHeaders[$k = $n++] = $subHeader;
 347                     $subHeaderKeys[$h] = $k;
 348                 } else {
 349                     $subHeader = $subHeaders[$k];
 350                     $m = ($l - $subHeader->[0] + 1) - $subHeader->[1];
 351                     $subHeader->[1] += $m;
 352                     push @{$subHeader->[4]}, (0) x ($m - 1), $g - $subHeader->[2];
 353                 }
 354             }
 355             @subHeaderKeys = map { $_ < 0 ? 0 : $_ } @subHeaderKeys;
 356             $subHeader = $subHeaders[0];
 357             $subHeader->[3] = 0;
 358             push @glyphIndexArray, @{$subHeader->[4]};
 359             splice(@$subHeader, 4);
 360             {
 361                 my @subHeaders_ = sort {@{$a->[4]} <=> @{$b->[4]}} @subHeaders[1..$#subHeaders];
 362                 my ($f, $d, $r, $subHeader_);
 363                 for ($k = 0; $k < @subHeaders_; $k++) {
 364                     $subHeader = $subHeaders_[$k];
 365                     $f = $r = shift @{$subHeader->[4]};
 366                     $subHeader->[5] = join(':',
 367                         map {
 368                             $d = $_ - $r;
 369                             $r = $_;
 370                             $d < 0 ?
 371                                 sprintf('-%04x', -$d) :
 372                                 sprintf('+%04x', $d)
 373                         } @{$subHeader->[4]});
 374                     unshift @{$subHeader->[4]}, $f;
 375                 }
 376                 for ($k = 0; $k < @subHeaders_; $k++) {
 377                     $subHeader = $subHeaders_[$k];
 378                     next unless $subHeader->[4];
 379                     $subHeader->[3] = @glyphIndexArray;
 380                     push @glyphIndexArray, @{$subHeader->[4]};
 381                     for ($l = $k + 1; $l < @subHeaders_; $l++) {
 382                         $subHeader_ = $subHeaders_[$l];
 383                         next unless $subHeader_->[4];
 384                         $d = $subHeader_->[5];
 385                         if ($subHeader->[5] =~ /\Q$d\E/) {
 386                             my $o = length($`)/6;               #`
 387                             $subHeader_->[2] +=
 388                                 $subHeader_->[4]->[$o] - $subHeader->[4]->[0];
 389                             $subHeader_->[3] = $subHeader->[3] + $o;
 390                             splice(@$subHeader_, 4);
 391                         }
 392                     }
 393                     splice(@$subHeader, 4);
 394                 }
 395             }
 396             $fh->print(pack('n*', map { $_<<3 } @subHeaderKeys));
 397             for ($j = 0; $j < 256; $j++) {
 398                 $k = $subHeaderKeys[$j];
 399                 $subHeader = $subHeaders[$k];
 400             }
 401             for ($k = 0; $k < $n; $k++) {
 402                 $subHeader = $subHeaders[$k];
 403                 $fh->print(pack('n4',
 404                     $subHeader->[0],
 405                     $subHeader->[1],
 406                     $subHeader->[2] < 0 ?
 407                         unpack('S', pack('s', $subHeader->[2])) :
 408                         $subHeader->[2],
 409                     ($subHeader->[3]<<1) + (($n - $k)<<3) - 6
 410                 ));
 411             }
 412             $fh->print(pack('n*', @glyphIndexArray));
 413         } elsif ($s->{'Format'} == 4)
 414         {
 415             my ($num, $sRange, $eSel, $eShift, @starts, @ends, $doff);
 416             my (@deltas, $delta, @range, $flat, $k, $segs, $count, $newseg, $v);
 417
 418             push(@keys, 0xFFFF) unless ($keys[-1] == 0xFFFF);
 419             $newseg = 1; $num = 0;
 420             for ($j = 0; $j <= $#keys && $keys[$j] <= 0xFFFF; $j++)
 421             {
 422                 $v = $s->{'val'}{$keys[$j]} || 0;
 423                 if ($newseg)
 424                 {
 425                     $delta = $v;
 426                     $doff = $j;
 427                     $flat = 1;
 428                     push(@starts, $keys[$j]);
 429                     $newseg = 0;
 430                 }
 431                 $delta = 0 if ($delta + $j - $doff != $v);
 432                 $flat = 0 if ($v == 0);
 433                 if ($j == $#keys || $keys[$j] + 1 != $keys[$j+1])
 434                 {
 435                     push (@ends, $keys[$j]);
 436                     push (@deltas, $delta ? $delta - $keys[$doff] : 0);
 437                     push (@range, $flat);
 438                     $num++;
 439                     $newseg = 1;
 440                 }
 441             }
 442
 443             ($num, $sRange, $eSel, $eShift) = Font::TTF::Utils::TTF_bininfo($num, 2);
 444             $fh->print(pack("n4", $num * 2, $sRange, $eSel, $eShift));
 445             $fh->print(pack("n*", @ends));
 446             $fh->print(pack("n", 0));
 447             $fh->print(pack("n*", @starts));
 448             $fh->print(pack("n*", @deltas));
 449
 450             $count = 0;
 451             for ($j = 0; $j < $num; $j++)
 452             {
 453                 $delta = $deltas[$j];
 454                 if ($delta != 0 && $range[$j] == 1)
 455                 { $range[$j] = 0; }
 456                 else
 457                 {
 458                     $range[$j] = ($count + $num - $j) << 1;
 459                     $count += $ends[$j] - $starts[$j] + 1;
 460                 }
 461             }
 462
 463             $fh->print(pack("n*", @range));
 464
 465             for ($j = 0; $j < $num; $j++)
 466             {
 467                 next if ($range[$j] == 0);
 468                 $fh->print(pack("n*", map {$_ || 0} @{$s->{'val'}}{$starts[$j] .. $ends[$j]}));
 469             }
 470         } elsif ($s->{'Format'} == 8 || $s->{'Format'} == 12)
 471         {
 472             my (@jobs, $start, $current, $curr_glyf, $map);
 473
 474             $current = 0; $curr_glyf = 0;
 475             $map = "\000" x 8192;
 476             foreach $j (@keys)
 477             {
 478                 if ($j > 0xFFFF)
 479                 {
 480                     if (defined $s->{'val'}{$j >> 16})
 481                     { $s->{'Format'} = 12; }
 482                     vec($map, $j >> 16, 1) = 1;
 483                 }
 484                 if ($j != $current + 1 || $s->{'val'}{$j} != $curr_glyf + 1)
 485                 {
 486                     push (@jobs, [$start, $current, $curr_glyf - ($current - $start)]) if (defined $start);
 487                     $start = $j; $current = $j; $curr_glyf = $s->{'val'}{$j};
 488                 }
 489                 $current = $j;
 490                 $curr_glyf = $s->{'val'}{$j};
 491             }
 492             push (@jobs, [$start, $current, $curr_glyf - ($current - $start)]) if (defined $start);
 493             $fh->print($map) if ($s->{'Format'} == 8);
 494             $fh->print(pack('N', $#jobs + 1));
 495             foreach $j (@jobs)
 496             { $fh->print(pack('N3', @{$j})); }
 497         } elsif ($s->{'Format'} == 10)
 498         {
 499             $fh->print(pack('N2', $keys[0], $keys[-1] - $keys[0] + 1));
 500             $fh->print(pack('n*', $s->{'val'}{$keys[0] .. $keys[-1]}));
 501         }
 502
 503         $loc = $fh->tell();
 504         if ($s->{'Format'} < 8)
 505         {
 506             $fh->seek($s->{' outloc'} + 2, 0);
 507             $fh->print(pack("n", $loc - $s->{' outloc'}));
 508         } else
 509         {
 510             $fh->seek($s->{' outloc'} + 4, 0);
 511             $fh->print(pack("N", $loc - $s->{' outloc'}));
 512         }
 513         $fh->seek($base_loc + 8 + ($i << 3), 0);
 514         $fh->print(pack("N", $s->{' outloc'} - $base_loc));
 515         $fh->seek($loc, 0);
 516     }
 517     $self;
 518 }
 519
 520
 521 =head2 $t->XML_element($context, $depth, $name, $val)
 522
 523 Outputs the elements of the cmap in XML. We only need to process val here
 524
 525 =cut
 526
 527 sub XML_element
 528 {
 529     my ($self, $context, $depth, $k, $val) = @_;
 530     my ($fh) = $context->{'fh'};
 531     my ($i);
 532
 533     return $self if ($k eq 'LOC');
 534     return $self->SUPER::XML_element($context, $depth, $k, $val) unless ($k eq 'val');
 535
 536     $fh->print("$depth<mappings>\n");
 537     foreach $i (sort {$a <=> $b} keys %{$val})
 538     { $fh->printf("%s<map code='%04X' glyph='%s'/>\n", $depth . $context->{'indent'}, $i, $val->{$i}); }
 539     $fh->print("$depth</mappings>\n");
 540     $self;
 541 }
 542
 543 =head2 @map = $t->reverse(%opt)
 544
 545 Returns a reverse map of the Unicode cmap. I.e. given a glyph gives the Unicode value for it. Options are:
 546
 547 =over 4
 548
 549 =item tnum
 550
 551 Table number to use rather than the default Unicode table
 552
 553 =item array
 554
 555 Returns each element of reverse as an array since a glyph may be mapped by more
 556 than one Unicode value. The arrays are unsorted. Otherwise store any one unicode value for a glyph.
 557
 558 =back
 559
 560 =cut
 561
 562 sub reverse
 563 {
 564     my ($self, %opt) = @_;
 565     my ($table) = defined $opt{'tnum'} ? $self->{'Tables'}[$opt{'tnum'}] : $self->find_ms;
 566     my (@res, $code, $gid);
 567
 568     while (($code, $gid) = each(%{$table->{'val'}}))
 569     {
 570         if ($opt{'array'})
 571         { push (@{$res[$gid]}, $code); }
 572         else
 573         { $res[$gid] = $code unless (defined $res[$gid] && $res[$gid] > 0 && $res[$gid] < $code); }
 574     }
 575     @res;
 576 }
 577
 578
 579 =head2 is_unicode($index)
 580
 581 Returns whether the table of a given index is known to be a unicode table
 582 (as specified in the specifications)
 583
 584 =cut
 585
 586 sub is_unicode
 587 {
 588     my ($self, $index) = @_;
 589     my ($pid, $eid) = ($self->{'Tables'}[$index]{'Platform'}, $self->{'Tables'}[$index]{'Encoding'});
 590
 591     return ($pid == 3 || $pid == 0 || ($pid == 2 && $eid == 1));
 592 }
 593
 594 1;
 595
 596 =head1 BUGS
 597
 598 =over 4
 599
 600 =item *
 601
 602 No support for format 2 tables (MBCS)
 603
 604 =back
 605
 606 =head1 AUTHOR
 607
 608 Martin Hosken Martin_Hosken@sil.org. See L<Font::TTF::Font> for copyright and
 609 licensing.
 610
 611 =cut
 612