File Coverage

blib/lib/Font/TTF/Font.pm
Criterion Covered Total %
statement 146 279 52.3
branch 39 110 35.4
condition 11 45 24.4
subroutine 9 21 42.8
pod 12 13 92.3
total 217 468 46.3


line stmt bran cond sub pod time code
1             package Font::TTF::Font;
2              
3             =head1 NAME
4              
5             Font::TTF::Font - Memory representation of a font
6              
7             =head1 SYNOPSIS
8              
9             Here is the regression test (you provide your own font). Run it once and then
10             again on the output of the first run. There should be no differences between
11             the outputs of the two runs.
12              
13             $f = Font::TTF::Font->open($ARGV[0]);
14              
15             # force a read of all the tables
16             $f->tables_do(sub { $_[0]->read; });
17              
18             # force read of all glyphs (use read_dat to use lots of memory!)
19             # $f->{'loca'}->glyphs_do(sub { $_[0]->read; });
20             $f->{'loca'}->glyphs_do(sub { $_[0]->read_dat; });
21             # NB. no need to $g->update since $f->{'glyf'}->out will do it for us
22              
23             $f->out($ARGV[1]);
24             $f->release; # clear up memory forcefully!
25              
26             =head1 DESCRIPTION
27              
28             A Truetype font consists of a header containing a directory of tables which
29             constitute the rest of the file. This class holds that header and directory and
30             also creates objects of the appropriate type for each table within the font.
31             Note that it does not read each table into memory, but creates a short reference
32             which can be read using the form:
33              
34             $f->{$tablename}->read;
35              
36             Classes are included that support many of the different TrueType tables. For
37             those for which no special code exists, the table type C is used, which
38             defaults to L. The current tables which are supported are:
39              
40             table Font::TTF::Table - for unknown tables
41             EBDT Font::TTF::EBDT
42             EBLC Font::TTF::EBLC
43             Feat Font::TTF::GrFeat
44             GDEF Font::TTF::GDEF
45             GPOS Font::TTF::GPOS
46             GSUB Font::TTF::GSUB
47             Glat Font::TTF::Glat
48             Gloc Font::TTF::Gloc
49             LTSH Font::TTF::LTSH
50             OS/2 Font::TTF::OS_2
51             PCLT Font::TTF::PCLT
52             Sill Font::TTF::Sill
53             Silf Font::TTF::Silf
54             bsln Font::TTF::Bsln
55             cmap Font::TTF::Cmap - see also Font::TTF::OldCmap
56             cvt Font::TTF::Cvt_
57             fdsc Font::TTF::Fdsc
58             feat Font::TTF::Feat
59             fmtx Font::TTF::Fmtx
60             fpgm Font::TTF::Fpgm
61             glyf Font::TTF::Glyf - see also Font::TTF::Glyph
62             hdmx Font::TTF::Hdmx
63             head Font::TTF::Head
64             hhea Font::TTF::Hhea
65             hmtx Font::TTF::Hmtx
66             kern Font::TTF::Kern - see alternative Font::TTF::AATKern
67             loca Font::TTF::Loca
68             maxp Font::TTF::Maxp
69             mort Font::TTF::Mort - see also Font::TTF::OldMort
70             name Font::TTF::Name
71             post Font::TTF::Post
72             prep Font::TTF::Prep
73             prop Font::TTF::Prop
74             vhea Font::TTF::Vhea
75             vmtx Font::TTF::Vmtx
76             DSIG FONT::TTF::DSIG
77              
78             Links are:
79              
80             L
81             L L L
82             L L L L L L
83             L L L L L L L
84             L L L L L
85             L L L L L
86             L L L L L
87             L L L L L
88             L L L
89             L
90              
91              
92             =head1 INSTANCE VARIABLES
93              
94             Instance variables begin with a space (and have lengths greater than the 4
95             characters which make up table names).
96              
97             =over
98              
99             =item nocsum
100              
101             This is used during output to disable the creation of the file checksum in the
102             head table. For example, during DSIG table creation, this flag will be set to
103             ensure that the file checksum is left at zero.
104              
105             =item noharmony
106              
107             If set, do not harmonize the script and lang trees of GPOS and GSUB tables. See L for more info.
108              
109             =item nocompress
110              
111             Is the default value controlling WOFF output table compression. If undef, all tables will be compressed if there is
112             a size benefit in doing so.
113             It may be set to an array of tagnames naming tables that should not be compressed, or to a scalar integer specifying a
114             table size threshold below which tables will not be compressed.
115             Note that individual L objects may override this default. See L for more info.
116              
117             =item fname (R)
118              
119             Contains the filename of the font which this object was read from.
120              
121             =item INFILE (P)
122              
123             The file handle which reflects the source file for this font.
124              
125             =item OFFSET (P)
126              
127             Contains the offset from the beginning of the read file of this particular
128             font directory, thus providing support for TrueType Collections.
129              
130             =item WOFF
131              
132             Contains a reference to a C object.
133              
134             =back
135              
136             =head1 METHODS
137              
138             =cut
139              
140 1     1   10639 use IO::File;
  1         6286  
  1         82  
141              
142 1     1   6 use strict;
  1         1  
  1         16  
143 1     1   2 use vars qw(%tables $VERSION $dumper);
  1         1  
  1         48  
144 1     1   4 use Symbol();
  1         1  
  1         145  
145              
146             require 5.004;
147              
148             my $havezlib = eval {require Compress::Zlib};
149              
150             $VERSION = 0.39; # MJPH 2-FEB-2008 Add DSIG table
151             # $VERSION = 0.38; # MJPH 2-FEB-2008 Add Sill table
152             # $VERSION = 0.37; # MJPH 7-OCT-2005 Force hhea update if dirty, give more OS/2 stuff in update
153             # $VERSION = 0.36; # MJPH 19-AUG-2005 Change cmap::reverse api to be opts based
154             # $VERSION = 0.35; # MJPH 4-MAY-2004 Various fixes to OpenType stuff, separate off scripts
155             # $VERSION = 0.34; # MJPH 22-MAY-2003 Update PSNames to latest AGL
156             # $VERSION = 0.33; # MJPH 9-OCT-2002 Support CFF OpenType (just by version=='OTTO'?!)
157             # $VERSION = 0.32; # MJPH 2-OCT-2002 Bug fixes to TTFBuilder, new methods and some
158             # extension table support in Ttopen and Coverage
159             # $VERSION = 0.31; # MJPH 1-JUL-2002 fix read format 12 cmap (bart@cs.pdx.edu)
160             # improve surrogate support in ttfremap
161             # fix return warn to return warn,undef
162             # ensure correct indexToLocFormat
163             # $VERSION = 0.30; # MJPH 28-MAY-2002 add updated release
164             # $VERSION = 0.29; # MJPH 9-APR-2002 update ttfbuilder, sort out surrogates
165             # $VERSION = 0.28; # MJPH 13-MAR-2002 update ttfbuilder, add Font::TTF::Cmap::ms_enc()
166             # $VERSION = 0.27; # MJPH 6-FEB-2002 update ttfbuilder, support no fpgm, no more __DATA__
167             # $VERSION = 0.26; # MJPH 19-SEP-2001 Update ttfbuilder
168             # $VERSION = 0.25; # MJPH 18-SEP-2001 problems in update of head
169             # $VERSION = 0.24; # MJPH 1-AUG-2001 Sort out update
170             # $VERSION = 0.23; # GST 30-MAY-2001 Memory leak fixed
171             # $VERSION = 0.22; # MJPH 09-APR-2001 Ensure all of AAT stuff included
172             # $VERSION = 0.21; # MJPH 23-MAR-2001 Improve Opentype support
173             # $VERSION = 0.20; # MJPH 13-JAN-2001 Add XML output and some of XML input, AAT & OT tables
174             # $VERSION = 0.19; # MJPH 29-SEP-2000 Add cmap::is_unicode, debug makefile.pl
175             # $VERSION = 0.18; # MJPH 21-JUL-2000 Debug Utils::TTF_bininfo
176             # $VERSION = 0.17; # MJPH 16-JUN-2000 Add utf8 support to names
177             # $VERSION = 0.16; # MJPH 26-APR-2000 Mark read tables as read, tidy up POD
178             # $VERSION = 0.15; # MJPH 5-FEB-2000 Ensure right versions released
179             # $VERSION = 0.14; # MJPH 11-SEP-1999 Sort out Unixisms, agian!
180             # $VERSION = 0.13; # MJPH 9-SEP-1999 Add empty, debug update_bbox
181             # $VERSION = 0.12; # MJPH 22-JUL-1999 Add update_bbox
182             # $VERSION = 0.11; # MJPH 7-JUL-1999 Don't store empties in cmaps
183             # $VERSION = 0.10; # MJPH 21-JUN-1999 Use IO::File
184             # $VERSION = 0.09; # MJPH 9-JUN-1999 Add 5.004 require, minor tweeks in cmap
185             # $VERSION = 0.08; # MJPH 19-MAY-1999 Sort out line endings for Unix
186             # $VERSION = 0.07; # MJPH 28-APR-1999 Get the regression tests to work
187             # $VERSION = 0.06; # MJPH 26-APR-1999 Start to add to CVS, correct MANIFEST.SKIP
188             # $VERSION = 0.05; # MJPH 13-APR-1999 See changes for 0.05
189             # $VERSION = 0.04; # MJPH 13-MAR-1999 Tidy up Tarball
190             # $VERSION = 0.03; # MJPH 9-MAR-1999 Move to Font::TTF for CPAN
191             # $VERSION = 0.02; # MJPH 12-FEB-1999 Add support for ' nocsum' for DSIGS
192             # $VERSION = 0.0001;
193              
194             %tables = (
195             'table' => 'Font::TTF::Table',
196             'DSIG' => 'Font::TTF::DSIG',
197             'EBDT' => 'Font::TTF::EBDT',
198             'EBLC' => 'Font::TTF::EBLC',
199             'Feat' => 'Font::TTF::GrFeat',
200             'GDEF' => 'Font::TTF::GDEF',
201             'Glat' => 'Font::TTF::Glat',
202             'Gloc' => 'Font::TTF::Gloc',
203             'GPOS' => 'Font::TTF::GPOS',
204             'GSUB' => 'Font::TTF::GSUB',
205             'Glat' => 'Font::TTF::Glat',
206             'Gloc' => 'Font::TTF::Gloc',
207             'LTSH' => 'Font::TTF::LTSH',
208             'OS/2' => 'Font::TTF::OS_2',
209             'PCLT' => 'Font::TTF::PCLT',
210             'Sill' => 'Font::TTF::Sill',
211             'Silf' => 'Font::TTF::Silf',
212             'bsln' => 'Font::TTF::Bsln',
213             'cmap' => 'Font::TTF::Cmap',
214             'cvt ' => 'Font::TTF::Cvt_',
215             'fdsc' => 'Font::TTF::Fdsc',
216             'feat' => 'Font::TTF::Feat',
217             'fmtx' => 'Font::TTF::Fmtx',
218             'fpgm' => 'Font::TTF::Fpgm',
219             'glyf' => 'Font::TTF::Glyf',
220             'hdmx' => 'Font::TTF::Hdmx',
221             'head' => 'Font::TTF::Head',
222             'hhea' => 'Font::TTF::Hhea',
223             'hmtx' => 'Font::TTF::Hmtx',
224             'kern' => 'Font::TTF::Kern',
225             'loca' => 'Font::TTF::Loca',
226             'maxp' => 'Font::TTF::Maxp',
227             'mort' => 'Font::TTF::Mort',
228             'name' => 'Font::TTF::Name',
229             'post' => 'Font::TTF::Post',
230             'prep' => 'Font::TTF::Prep',
231             'prop' => 'Font::TTF::Prop',
232             'vhea' => 'Font::TTF::Vhea',
233             'vmtx' => 'Font::TTF::Vmtx',
234             );
235              
236             # This is special code because I am fed up of every time I x a table in the debugger
237             # I get the whole font printed. Thus substitutes my 3 line change to dumpvar into
238             # the debugger. Clunky, but nice. You are welcome to a copy if you want one.
239            
240             BEGIN {
241 1     1   1 my ($p);
242              
243 1         2 foreach $p (@INC)
244             {
245 11 50       151 if (-f "$p/mydumpvar.pl")
246             {
247 0         0 $dumper = 'mydumpvar.pl';
248 0         0 last;
249             }
250             }
251 1   50     2020 $dumper ||= 'dumpvar.pl';
252             }
253              
254             sub main::dumpValue
255 0     0   0 { do $dumper; &main::dumpValue; }
  0         0  
256            
257              
258             =head2 Font::TTF::Font->AddTable($tablename, $class)
259              
260             Adds the given class to be used when representing the given table name. It also
261             'requires' the class for you.
262              
263             =cut
264              
265             sub AddTable
266             {
267 0     0 1 0 my ($class, $table, $useclass) = @_;
268              
269 0         0 $tables{$table} = $useclass;
270             # $useclass =~ s|::|/|oig;
271             # require "$useclass.pm";
272             }
273              
274              
275             =head2 Font::TTF::Font->Init
276              
277             For those people who like making fonts without reading them. This subroutine
278             will require all the table code for the various table types for you. Not
279             needed if using Font::TTF::Font::read before using a table.
280              
281             =cut
282              
283             sub Init
284             {
285 0     0 1 0 my ($class) = @_;
286 0         0 my ($t);
287              
288 0         0 foreach $t (values %tables)
289             {
290 0         0 $t =~ s|::|/|oig;
291 0         0 require "$t.pm";
292             }
293             }
294              
295             =head2 Font::TTF::Font->new(%props)
296              
297             Creates a new font object and initialises with the given properties. This is
298             primarily for use when a TTF is embedded somewhere. Notice that the properties
299             are automatically preceded by a space when inserted into the object. This is in
300             order that fields do not clash with tables.
301              
302             =cut
303              
304             sub new
305             {
306 0     0 1 0 my ($class, %props) = @_;
307 0         0 my ($self) = {};
308              
309 0         0 bless $self, $class;
310              
311 0         0 foreach (keys %props)
312 0         0 { $self->{" $_"} = $props{$_}; }
313 0         0 $self;
314             }
315              
316              
317             =head2 Font::TTF::Font->open($fname)
318              
319             Reads the header and directory for the given font file and creates appropriate
320             objects for each table in the font.
321              
322             =cut
323              
324             sub open
325             {
326 2     2 1 2564 my ($class, $fname) = @_;
327 2         3 my ($fh);
328 2         4 my ($self) = {};
329            
330 2 50       5 unless (ref($fname))
331             {
332 2 50       27 $fh = IO::File->new($fname) or return undef;
333 2         138 binmode $fh;
334             } else
335 0         0 { $fh = $fname; }
336              
337 2         4 $self->{' INFILE'} = $fh;
338 2         5 $self->{' fname'} = $fname;
339 2         9 $self->{' OFFSET'} = 0;
340 2         5 bless $self, $class;
341            
342 2         6 $self->read;
343             }
344              
345             =head2 $f->read
346              
347             Reads a Truetype font directory starting from location C<$self->{' OFFSET'}> in the file.
348             This has been separated from the C function to allow support for embedded
349             TTFs for example in TTCs. Also reads the C and C tables immediately.
350              
351             =cut
352              
353             sub read
354             {
355 2     2 1 3 my ($self) = @_;
356 2         5 my ($fh) = $self->{' INFILE'};
357 2         3 my ($dat, $i, $ver, $dir_num, $type, $name, $check, $off, $len, $t);
358 0         0 my ($iswoff, $woffLength, $sfntSize, $zlen); # needed for WOFF files
359              
360 2         12 $fh->seek($self->{' OFFSET'}, 0);
361 2         20 $fh->read($dat, 4);
362 2         34 $ver = unpack("N", $dat);
363 2         5 $iswoff = ($ver == unpack('N', 'wOFF'));
364 2 100       5 if ($iswoff)
365             {
366 1         423 require Font::TTF::Woff;
367 1         11 my $woff = Font::TTF::Woff->new(PARENT => $self);
368 1         5 $fh->read($dat, 32);
369 1         13 ($ver, $woffLength, $dir_num, undef, $sfntSize, $woff->{'majorVersion'}, $woff->{'minorVersion'},
370             $off, $zlen, $len) = unpack('NNnnNnnNNN', $dat);
371             # TODO: According to WOFF spec we should verify $woffLength and $sfntSize, and fail if the values are wrong.
372 1 50       5 if ($off)
373             {
374             # Font has metadata
375 0 0       0 if ($off + $zlen > $woffLength)
376             {
377 0         0 warn "invalid WOFF header in $self->{' fname'}: meta data beyond end.";
378 0         0 return undef;
379             }
380 0         0 require Font::TTF::Woff::MetaData;
381 0         0 $woff->{'metaData'} = Font::TTF::Woff::MetaData->new(
382             PARENT => $woff,
383             INFILE => $fh,
384             OFFSET => $off,
385             LENGTH => $len,
386             ZLENGTH => $zlen);
387             }
388            
389 1         3 $fh->read($dat, 8);
390 1         4 ($off, $len) = unpack('NN', $dat);
391 1 50       3 if ($off)
392             {
393             # Font has private data
394 0 0       0 if ($off + $len > $woffLength)
395             {
396 0         0 warn "invalid WOFF header in $self->{' fname'}: private data beyond end.";
397 0         0 return undef;
398             }
399 0         0 require Font::TTF::Woff::PrivateData;
400 0         0 $woff->{'privateData'} = Font::TTF::Woff::PrivateData->new(
401             PARENT => $woff,
402             INFILE => $fh,
403             OFFSET => $off,
404             LENGTH => $len);
405             }
406            
407 1         2 $self->{' WOFF'} = $woff;
408             }
409             else
410             {
411 1         2 $fh->read($dat, 8);
412 1         4 $dir_num = unpack("n", $dat);
413             }
414            
415 2 0 33     7 $ver == 1 << 16 # TrueType outlines
      33        
416             || $ver == unpack('N', 'OTTO') # 0x4F54544F CFF outlines
417             || $ver == unpack('N', 'true') # 0x74727565 Mac sfnts
418             or return undef; # else unrecognized type
419            
420            
421 2         7 for ($i = 0; $i < $dir_num; $i++)
422             {
423 28 100       72 $fh->read($dat, $iswoff ? 20 : 16) || die "Reading table entry";
    50          
424 28 100       143 if ($iswoff)
425             {
426 14         27 ($name, $off, $zlen, $len, $check) = unpack("a4NNNN", $dat);
427 14 50 33     44 if ($off + $zlen > $woffLength || $zlen > $len)
428             {
429 0         0 my $err;
430 0 0       0 $err = "Offset + compressed length > total length. " if $off + $zlen > $woffLength;
431 0 0       0 $err = "Compressed length > uncompressed length. " if $zlen > $len;
432 0         0 warn "invalid WOFF '$name' table in $self->{' fname'}: $err\n";
433 0         0 return undef;
434             }
435             }
436             else
437             {
438 14         42 ($name, $check, $off, $len) = unpack("a4NNN", $dat);
439 14         15 $zlen = $len;
440             }
441             $self->{$name} = $self->{' PARENT'}->find($self, $name, $check, $off, $len) and next
442 28 50 0     45 if (defined $self->{' PARENT'});
443 28   100     61 $type = $tables{$name} || 'Font::TTF::Table';
444 28         28 $t = $type;
445 28 50       47 if ($^O eq "MacOS")
446 0         0 { $t =~ s/^|::/:/oig; }
447             else
448 28         75 { $t =~ s|::|/|oig; }
449 28         4753 require "$t.pm";
450 28         145 $self->{$name} = $type->new(PARENT => $self,
451             NAME => $name,
452             INFILE => $fh,
453             OFFSET => $off,
454             LENGTH => $len,
455             ZLENGTH => $zlen,
456             CSUM => $check);
457             }
458            
459 2         4 foreach $t ('head', 'maxp')
460 4 50       28 { $self->{$t}->read if defined $self->{$t}; }
461              
462 2         8 $self;
463             }
464              
465              
466             =head2 $f->out($fname [, @tablelist])
467              
468             Writes a TTF file consisting of the tables in tablelist. The list is checked to
469             ensure that only tables that exist are output. (This means that you cannot have
470             non table information stored in the font object with key length of exactly 4)
471              
472             In many cases the user simply wants to output all the tables in alphabetical order.
473             This can be done by not including a @tablelist, in which case the subroutine will
474             output all the defined tables in the font in alphabetical order.
475              
476             Returns $f on success and undef on failure, including warnings.
477              
478             All output files must include the C table.
479              
480             =cut
481              
482             sub out
483             {
484 2     2 1 26 my ($self, $fname, @tlist) = @_;
485 2         4 my ($fh);
486 2         2 my ($dat, $numTables, $sRange, $eSel);
487 0         0 my (%dir, $k, $mloc, $count);
488 0         0 my ($csum, $lsum, $msum, $loc, $oldloc, $len, $shift);
489              
490 0         0 my ($iswoff); # , $woffLength, $sfntSize, $zlen); # needed for WOFF files
491              
492 2 50       6 unless (ref($fname))
493             {
494 2   50     23 $fh = IO::File->new("+>$fname") || return warn("Unable to open $fname for writing"), undef;
495 2         363 binmode $fh;
496             } else
497 0         0 { $fh = $fname; }
498            
499 2         6 $self->{' oname'} = $fname;
500 2         4 $self->{' outfile'} = $fh;
501              
502 2 50       12 if ($self->{' wantsig'})
    50          
503             {
504 0         0 $self->{' nocsum'} = 1;
505             # $self->{'head'}{'checkSumAdjustment'} = 0;
506 0         0 $self->{' tempDSIG'} = $self->{'DSIG'};
507 0         0 $self->{' tempcsum'} = $self->{'head'}{' CSUM'};
508 0         0 delete $self->{'DSIG'};
509 0         0 @tlist = sort {$self->{$a}{' OFFSET'} <=> $self->{$b}{' OFFSET'}}
510 0 0 0     0 grep (length($_) == 4 && defined $self->{$_}, keys %$self) if ($#tlist < 0);
511             }
512             elsif ($#tlist < 0)
513 2         32 { @tlist = sort keys %$self; }
514            
515 2   66     63 @tlist = grep(length($_) == 4 && defined $self->{$_}, @tlist);
516 2         5 $numTables = $#tlist + 1;
517 2 50       5 $numTables++ if ($self->{' wantsig'});
518            
519 2 50       6 if ($iswoff)
520             {
521             }
522             else
523             {
524 2         10 ($numTables, $sRange, $eSel, $shift) = Font::TTF::Utils::TTF_bininfo($numTables, 16);
525 2         11 $dat = pack("Nnnnn", 1 << 16, $numTables, $sRange, $eSel, $shift);
526 2         18 $fh->print($dat);
527 2         29 $msum = unpack("%32N*", $dat);
528             }
529              
530             # reserve place holders for each directory entry
531 2         4 foreach $k (@tlist)
532             {
533 28         92 $dir{$k} = pack("A4NNN", $k, 0, 0, 0);
534 28         33 $fh->print($dir{$k});
535             }
536              
537 2 50       10 $fh->print(pack('A4NNN', '', 0, 0, 0)) if ($self->{' wantsig'});
538              
539 2         8 $loc = $fh->tell();
540 2 50       15 if ($loc & 3)
541             {
542 0         0 $fh->print(substr("\000" x 4, $loc & 3));
543 0         0 $loc += 4 - ($loc & 3);
544             }
545              
546 2         3 foreach $k (@tlist)
547             {
548 28         81 $oldloc = $loc;
549 28 50 33     120 if ($iswoff && $havezlib &&
    50 33        
    50          
550             # output font is WOFF -- should we try to compress this table?
551             exists ($self->{$k}->{' nocompress'}) ? $self->{$k}->{' nocompress'} != -1 :
552             ref($self->{' nocompress'}) eq 'ARRAY' ? !exists($self->{' nocompress'}{$k}) :
553             ref($self->{' nocompress'}) eq 'SCALAR' && $self->{' nocompress'} != -1)
554             {
555             # Yes -- we may want to compress this table.
556             # Create string file handle to hold uncompressed table
557 0         0 my $dat;
558 0         0 my $fh2 = IO::String->new($dat);
559 0         0 binmode $fh2;
560 0         0 $self->{$k}->out($fh2);
561 0         0 $len = $fh2->tell();
562 0         0 close $fh2;
563            
564             # Is table long enough to try compression?
565 0 0 0     0 unless (
566             exists ($self->{$k}->{' nocompress'}) && $len <= $self->{$k}->{' nocompress'} ||
567             ref($self->{' nocompress'}) eq 'SCALAR' && $len <= $self->{' nocompress'})
568             {
569             # Yes -- so compress and check lengths:
570 0         0 my $zdat = Compress::Zlib::compress($dat);
571 0         0 my $zlen = bytes::length($zdat);
572 0 0       0 if ($zlen < $len)
573             {
574             # write the compressed $zdat
575            
576             }
577             else
578             {
579             # write the uncompressed $dat
580             }
581             }
582             else
583             {
584             # write uncompressed $dat
585             }
586            
587            
588             }
589             else
590             {
591             # Output table normally
592 28         136 $self->{$k}->out($fh);
593 28         54 $loc = $fh->tell();
594 28         80 $len = $loc - $oldloc;
595             }
596 28 100       44 if ($loc & 3)
597             {
598 12         28 $fh->print(substr("\000" x 4, $loc & 3));
599 12         51 $loc += 4 - ($loc & 3);
600             }
601 28         48 $fh->seek($oldloc, 0);
602 28         314 $csum = 0; $mloc = $loc;
  28         27  
603 28         42 while ($mloc > $oldloc)
604             {
605 48 100       66 $count = ($mloc - $oldloc > 4096) ? 4096 : $mloc - $oldloc;
606 48         68 $fh->read($dat, $count);
607 48         339 $csum += unpack("%32N*", $dat);
608             # this line ensures $csum stays within 32 bit bounds, clipping as necessary
609 48 100       68 if ($csum > 0xffffffff) { $csum -= 0xffffffff; $csum--; }
  12         6  
  12         9  
610 48         63 $mloc -= $count;
611             }
612 28         65 $dir{$k} = pack("A4NNN", $k, $csum, $oldloc, $len);
613 28         36 $msum += $csum + unpack("%32N*", $dir{$k});
614 28         38 while ($msum > 0xffffffff) { $msum -= 0xffffffff; $msum--; }
  22         15  
  22         27  
615 28         44 $fh->seek($loc, 0);
616             }
617              
618 2 50       11 unless ($self->{' nocsum'}) # assuming we want a file checksum
    0          
619             {
620             # Now we need to sort out the head table's checksum
621 2 50       5 if (!defined $dir{'head'})
622             { # you have to have a head table
623 0         0 $fh->close();
624 0         0 return warn("No 'head' table to output in $fname"), undef;
625             }
626 2         6 ($csum, $loc, $len) = unpack("x4NNN", $dir{'head'});
627 2         7 $fh->seek($loc + 8, 0);
628 2         7 $fh->read($dat, 4);
629 2         11 $lsum = unpack("N", $dat);
630 2 50       5 if ($lsum != 0)
631             {
632 2         2 $csum -= $lsum;
633 2 50       6 if ($csum < 0) { $csum += 0xffffffff; $csum++; }
  2         3  
  2         2  
634 2         2 $msum -= $lsum * 2; # twice (in head and in csum)
635 2         3 while ($msum < 0) { $msum += 0xffffffff; $msum++; }
  2         2  
  2         4  
636             }
637 2         3 $lsum = 0xB1B0AFBA - $msum;
638 2         5 $fh->seek($loc + 8, 0);
639 2         10 $fh->print(pack("N", $lsum));
640 2         10 $dir{'head'} = pack("A4NNN", 'head', $csum, $loc, $len);
641             } elsif ($self->{' wantsig'})
642             {
643 0 0       0 if (!defined $dir{'head'})
644             { # you have to have a head table
645 0         0 $fh->close();
646 0         0 return warn("No 'head' table to output in $fname"), undef;
647             }
648 0         0 ($csum, $loc, $len) = unpack("x4NNN", $dir{'head'});
649 0         0 $fh->seek($loc + 8, 0);
650 0         0 $fh->print(pack("N", 0));
651             # $dir{'head'} = pack("A4NNN", 'head', $self->{' tempcsum'}, $loc, $len);
652             }
653              
654             # Now we can output the directory again
655 2 50       6 if ($self->{' wantsig'})
656 0         0 { @tlist = sort @tlist; }
657 2         4 $fh->seek(12, 0);
658 2         14 foreach $k (@tlist)
659 28         77 { $fh->print($dir{$k}); }
660 2 50       10 $fh->print(pack('A4NNN', '', 0, 0, 0)) if ($self->{' wantsig'});
661 2         11 $fh->close();
662 2         86 $self;
663             }
664              
665              
666             =head2 $f->out_xml($filename [, @tables])
667              
668             Outputs the font in XML format
669              
670             =cut
671              
672             sub out_xml
673             {
674 0     0 1 0 my ($self, $fname, @tlist) = @_;
675 0         0 my ($fh, $context, $numTables, $k);
676              
677 0         0 $context->{'indent'} = ' ' x 4;
678              
679 0 0       0 unless (ref($fname))
680             {
681 0   0     0 $fh = IO::File->new("+>$fname") || return warn("Unable to open $fname"), undef;
682 0         0 binmode $fh;
683             } else
684 0         0 { $fh = $fname; }
685              
686 0 0       0 unless (scalar @tlist > 0)
687             {
688 0         0 @tlist = sort keys %$self;
689 0   0     0 @tlist = grep(length($_) == 4 && defined $self->{$_}, @tlist);
690             }
691 0         0 $numTables = $#tlist + 1;
692              
693 0         0 $context->{'fh'} = $fh;
694 0         0 $fh->print("\n");
695 0         0 $fh->print("\n\n");
696            
697 0         0 foreach $k (@tlist)
698             {
699 0         0 $fh->print("\n");
700 0         0 $self->{$k}->out_xml($context, $context->{'indent'});
701 0         0 $fh->print("
\n");
702             }
703              
704 0         0 $fh->print("\n");
705 0         0 $fh->close;
706 0         0 $self;
707             }
708              
709              
710             =head2 $f->XML_start($context, $tag, %attrs)
711              
712             Handles start messages from the XML parser. Of particular interest to us are and
713             .
714              
715             =cut
716              
717             sub XML_start
718             {
719 0     0 1 0 my ($self, $context, $tag, %attrs) = @_;
720 0         0 my ($name, $type, $t);
721              
722 0 0       0 if ($tag eq 'font')
    0          
723 0         0 { $context->{'tree'}[-1] = $self; }
724             elsif ($tag eq 'table')
725             {
726 0         0 $name = $attrs{'name'};
727 0 0       0 unless (defined $self->{$name})
728             {
729 0   0     0 $type = $tables{$name} || 'Font::TTF::Table';
730 0         0 $t = $type;
731 0 0       0 if ($^O eq "MacOS")
732 0         0 { $t =~ s/^|::/:/oig; }
733             else
734 0         0 { $t =~ s|::|/|oig; }
735 0         0 require "$t.pm";
736 0         0 $self->{$name} = $type->new('PARENT' => $self, 'NAME' => $name, 'read' => 1);
737             }
738 0         0 $context->{'receiver'} = ($context->{'tree'}[-1] = $self->{$name});
739             }
740 0         0 $context;
741             }
742              
743              
744             sub XML_end
745             {
746 0     0 0 0 my ($self) = @_;
747 0         0 my ($context, $tag, %attrs) = @_;
748 0         0 my ($i);
749              
750 0 0 0     0 return undef unless ($tag eq 'table' && $attrs{'name'} eq 'loca');
751 0 0 0     0 if (defined $context->{'glyphs'} && $context->{'glyphs'} ne $self->{'loca'}{'glyphs'})
752             {
753 0         0 for ($i = 0; $i <= $#{$context->{'glyphs'}}; $i++)
  0         0  
754 0 0       0 { $self->{'loca'}{'glyphs'}[$i] = $context->{'glyphs'}[$i] if defined $context->{'glyphs'}[$i]; }
755 0         0 $context->{'glyphs'} = $self->{'loca'}{'glyphs'};
756             }
757 0         0 return undef;
758             }
759              
760             =head2 $f->update
761              
762             Sends update to all the tables in the font and then resets all the isDirty
763             flags on each table. The data structure in now consistent as a font (we hope).
764              
765             =cut
766              
767             sub update
768             {
769 0     0 1 0 my ($self) = @_;
770            
771 0     0   0 $self->tables_do(sub { $_[0]->update; });
  0         0  
772              
773 0         0 $self;
774             }
775              
776             =head2 $f->dirty
777              
778             Dirties all the tables in the font
779              
780             =cut
781              
782             sub dirty
783 0     0 1 0 { $_[0]->tables_do(sub { $_[0]->dirty; }); $_[0]; }
  0     0   0  
  0         0  
784              
785             =head2 $f->tables_do(&func [, tables])
786              
787             Calls &func for each table in the font. Calls the table in alphabetical sort
788             order as per the order in the directory:
789              
790             &func($table, $name);
791              
792             May optionally take a list of table names in which case func is called
793             for each of them in the given order.
794              
795             =cut
796              
797             sub tables_do
798             {
799 2     2 1 814 my ($self, $func, @tables) = @_;
800 2         2 my ($t);
801              
802 2 50       12 foreach $t (@tables ? @tables : sort grep {length($_) == 4} keys %$self)
  35         40  
803 28         66 { &$func($self->{$t}, $t); }
804 2         6 $self;
805             }
806              
807              
808             =head2 $f->release
809              
810             Releases ALL of the memory used by the TTF font and all of its component
811             objects. After calling this method, do B expect to have anything left in
812             the C object.
813              
814             B, that it is important that you call this method on any
815             C object when you wish to destruct it and free up its memory.
816             Internally, we track things in a structure that can result in circular
817             references, and without calling 'C' these will not properly get
818             cleaned up by Perl. Once you've called this method, though, don't expect to be
819             able to do anything else with the C object; it'll have B
820             internal state whatsoever.
821              
822             B As part of the brute-force cleanup done here, this method
823             will throw a warning message whenever unexpected key values are found within
824             the C object. This is done to help ensure that any unexpected
825             and unfreed values are brought to your attention so that you can bug us to keep
826             the module updated properly; otherwise the potential for memory leaks due to
827             dangling circular references will exist.
828              
829             =cut
830              
831             sub release
832             {
833 0     0 1   my ($self) = @_;
834              
835             # delete stuff that we know we can, here
836              
837 0           my @tofree = map { delete $self->{$_} } keys %{$self};
  0            
  0            
838              
839 0           while (my $item = shift @tofree)
840             {
841 0           my $ref = ref($item);
842 0 0         if (UNIVERSAL::can($item, 'release'))
    0          
    0          
843 0           { $item->release(); }
844             elsif ($ref eq 'ARRAY')
845 0           { push( @tofree, @{$item} ); }
  0            
846             elsif (UNIVERSAL::isa($ref, 'HASH'))
847 0           { release($item); }
848             }
849              
850             # check that everything has gone - it better had!
851 0           foreach my $key (keys %{$self})
  0            
852 0           { warn ref($self) . " still has '$key' key left after release.\n"; }
853             }
854              
855             1;
856              
857             =head1 BUGS
858              
859             Bugs abound aplenty I am sure. There is a lot of code here and plenty of scope.
860             The parts of the code which haven't been implemented yet are:
861              
862             =over 4
863              
864             =item Post
865              
866             Version 4 format types are not supported yet.
867              
868             =item Cmap
869              
870             Format type 2 (MBCS) has not been implemented yet and therefore may cause
871             somewhat spurious results for this table type.
872              
873             =item Kern
874              
875             Only type 0 & type 2 tables are supported (type 1 & type 3 yet to come).
876              
877             =item TTC and WOFF
878              
879             The current Font::TTF::Font::out method does not support the writing of TrueType
880             Collections or WOFF files.
881              
882             =item DSIG
883              
884             Haven't figured out how to correctly calculate and output digital signature (DSIG) table
885              
886             =back
887              
888             In addition there are weaknesses or features of this module library
889              
890             =over 4
891              
892             =item *
893              
894             There is very little (or no) error reporting. This means that if you have
895             garbled data or garbled data structures, then you are liable to generate duff
896             fonts.
897              
898             =item *
899              
900             The exposing of the internal data structures everywhere means that doing
901             radical re-structuring is almost impossible. But it stop the code from becoming
902             ridiculously large.
903              
904             =back
905              
906             Apart from these, I try to keep the code in a state of "no known bugs", which
907             given the amount of testing this code has had, is not a guarantee of high
908             quality, yet.
909              
910             For more details see the appropriate class files.
911              
912             =head1 AUTHOR
913              
914             Martin Hosken L.
915              
916              
917             =head1 LICENSING
918              
919             Copyright (c) 1998-2016, SIL International (http://www.sil.org)
920              
921             This module is released under the terms of the Artistic License 2.0.
922             For details, see the full text of the license in the file LICENSE.
923              
924              
925              
926             =cut
927