bb3d63c071f04c2a548edf1fd623675390fd3ce8
[librarian.git] / 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