1package Font::TTF::Font;
2
3=head1 NAME
4
5Font::TTF::Font - Memory representation of a font
6
7=head1 SYNOPSIS
8
9Here is the regression test (you provide your own font). Run it once and then
10again on the output of the first run. There should be no differences between
11the 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
28A Truetype font consists of a header containing a directory of tables which
29constitute the rest of the file. This class holds that header and directory and
30also creates objects of the appropriate type for each table within the font.
31Note that it does not read each table into memory, but creates a short reference
32which can be read using the form:
33
34    $f->{$tablename}->read;
35
36Classes are included that support many of the different TrueType tables. For
37those for which no special code exists, the table type C<table> is used, which
38defaults to L<Font::TTF::Table>. 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
78Links are:
79
80L<Font::TTF::Table>
81L<Font::TTF::EBDT> L<Font::TTF::EBLC> L<Font::TTF::GrFeat>
82L<Font::TTF::GDEF> L<Font::TTF::GPOS> L<Font::TTF::GSUB> L<Font::TTF::Glat> L<Font::TTF::Gloc> L<Font::TTF::LTSH>
83L<Font::TTF::OS_2> L<Font::TTF::PCLT> L<Font::TTF::Sill> L<Font::TTF::Silf> L<Font::TTF::Bsln> L<Font::TTF::Cmap> L<Font::TTF::Cvt_>
84L<Font::TTF::Fdsc> L<Font::TTF::Feat> L<Font::TTF::Fmtx> L<Font::TTF::Fpgm> L<Font::TTF::Glyf>
85L<Font::TTF::Hdmx> L<Font::TTF::Head> L<Font::TTF::Hhea> L<Font::TTF::Hmtx> L<Font::TTF::Kern>
86L<Font::TTF::Loca> L<Font::TTF::Maxp> L<Font::TTF::Mort> L<Font::TTF::Name> L<Font::TTF::Post>
87L<Font::TTF::Prep> L<Font::TTF::Prop> L<Font::TTF::Vhea> L<Font::TTF::Vmtx> L<Font::TTF::OldCmap>
88L<Font::TTF::Glyph> L<Font::TTF::AATKern> L<Font::TTF::OldMort>
89L<Font::TTF::DSIG>
90
91
92=head1 INSTANCE VARIABLES
93
94Instance variables begin with a space (and have lengths greater than the 4
95characters which make up table names).
96
97=over
98
99=item nocsum
100
101This is used during output to disable the creation of the file checksum in the
102head table. For example, during DSIG table creation, this flag will be set to
103ensure that the file checksum is left at zero.
104
105=item noharmony
106
107If set, do not harmonize the script and lang trees of GPOS and GSUB tables. See L<Font::TTF::Ttopen> for more info.
108
109=item nocompress
110
111Is the default value controlling WOFF output table compression. If undef, all tables will be compressed if there is
112a size benefit in doing so.
113It may be set to an array of tagnames naming tables that should not be compressed, or to a scalar integer specifying a
114table size threshold below which tables will not be compressed.
115Note that individual L<Font::TTF::Table> objects may override this default. See L<Font::TTF::Table> for more info.
116
117=item fname (R)
118
119Contains the filename of the font which this object was read from.
120
121=item INFILE (P)
122
123The file handle which reflects the source file for this font.
124
125=item OFFSET (P)
126
127Contains the offset from the beginning of the read file of this particular
128font directory, thus providing support for TrueType Collections.
129
130=item WOFF
131
132Contains a reference to a C<Font::TTF::Woff> object.
133
134=back
135
136=head1 METHODS
137
138=cut
139
140use IO::File;
141
142use strict;
143use vars qw(%tables $VERSION $dumper);
144use Symbol();
145
146require 5.004;
147
148my $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
240BEGIN {
241    my ($p);
242
243    foreach $p (@INC)
244    {
245        if (-f "$p/mydumpvar.pl")
246        {
247            $dumper = 'mydumpvar.pl';
248            last;
249        }
250    }
251    $dumper ||= 'dumpvar.pl';
252}
253
254sub main::dumpValue
255{ do $dumper; &main::dumpValue; }
256
257
258=head2 Font::TTF::Font->AddTable($tablename, $class)
259
260Adds the given class to be used when representing the given table name. It also
261'requires' the class for you.
262
263=cut
264
265sub AddTable
266{
267    my ($class, $table, $useclass) = @_;
268
269    $tables{$table} = $useclass;
270#    $useclass =~ s|::|/|oig;
271#    require "$useclass.pm";
272}
273
274
275=head2 Font::TTF::Font->Init
276
277For those people who like making fonts without reading them. This subroutine
278will require all the table code for the various table types for you. Not
279needed if using Font::TTF::Font::read before using a table.
280
281=cut
282
283sub Init
284{
285    my ($class) = @_;
286    my ($t);
287
288    foreach $t (values %tables)
289    {
290        $t =~ s|::|/|oig;
291        require "$t.pm";
292    }
293}
294
295=head2 Font::TTF::Font->new(%props)
296
297Creates a new font object and initialises with the given properties. This is
298primarily for use when a TTF is embedded somewhere. Notice that the properties
299are automatically preceded by a space when inserted into the object. This is in
300order that fields do not clash with tables.
301
302=cut
303
304sub new
305{
306    my ($class, %props) = @_;
307    my ($self) = {};
308
309    bless $self, $class;
310
311    foreach (keys %props)
312    { $self->{" $_"} = $props{$_}; }
313    $self;
314}
315
316
317=head2 Font::TTF::Font->open($fname)
318
319Reads the header and directory for the given font file and creates appropriate
320objects for each table in the font.
321
322=cut
323
324sub open
325{
326    my ($class, $fname) = @_;
327    my ($fh);
328    my ($self) = {};
329
330    unless (ref($fname))
331    {
332        $fh = IO::File->new($fname) or return undef;
333        binmode $fh;
334    } else
335    { $fh = $fname; }
336
337    $self->{' INFILE'} = $fh;
338    $self->{' fname'} = $fname;
339    $self->{' OFFSET'} = 0;
340    bless $self, $class;
341
342    $self->read;
343}
344
345=head2 $f->read
346
347Reads a Truetype font directory starting from location C<$self->{' OFFSET'}> in the file.
348This has been separated from the C<open> function to allow support for embedded
349TTFs for example in TTCs. Also reads the C<head> and C<maxp> tables immediately.
350
351=cut
352
353sub read
354{
355    my ($self) = @_;
356    my ($fh) = $self->{' INFILE'};
357    my ($dat, $i, $ver, $dir_num, $type, $name, $check, $off, $len, $t);
358    my ($iswoff, $woffLength, $sfntSize, $zlen);    # needed for WOFF files
359
360    $fh->seek($self->{' OFFSET'}, 0);
361    $fh->read($dat, 4);
362    $ver = unpack("N", $dat);
363    $iswoff = ($ver == unpack('N', 'wOFF'));
364    if ($iswoff)
365    {
366        require Font::TTF::Woff;
367        my $woff = Font::TTF::Woff->new(PARENT  => $self);
368        $fh->read($dat, 32);
369        ($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        if ($off)
373        {
374            # Font has metadata
375            if ($off + $zlen > $woffLength)
376            {
377                warn "invalid WOFF header in $self->{' fname'}: meta data beyond end.";
378                return undef;
379            }
380            require Font::TTF::Woff::MetaData;
381            $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        $fh->read($dat, 8);
390        ($off, $len) = unpack('NN', $dat);
391        if ($off)
392        {
393            # Font has private data
394            if ($off + $len > $woffLength)
395            {
396                warn "invalid WOFF header in $self->{' fname'}: private data beyond end.";
397                return undef;
398            }
399            require Font::TTF::Woff::PrivateData;
400            $woff->{'privateData'} = Font::TTF::Woff::PrivateData->new(
401                PARENT     => $woff,
402                INFILE     => $fh,
403                OFFSET     => $off,
404                LENGTH     => $len);
405        }
406
407        $self->{' WOFF'} = $woff;
408    }
409    else
410    {
411        $fh->read($dat, 8);
412        $dir_num = unpack("n", $dat);
413    }
414
415    $ver == 1 << 16                 # TrueType outlines
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    for ($i = 0; $i < $dir_num; $i++)
422    {
423        $fh->read($dat, $iswoff ? 20 : 16) || die "Reading table entry";
424        if ($iswoff)
425        {
426            ($name, $off, $zlen, $len, $check) = unpack("a4NNNN", $dat);
427            if ($off + $zlen > $woffLength || $zlen > $len)
428            {
429                my $err;
430                $err = "Offset + compressed length > total length. " if $off + $zlen > $woffLength;
431                $err = "Compressed length > uncompressed length. " if $zlen > $len;
432                warn "invalid WOFF '$name' table in $self->{' fname'}: $err\n";
433                return undef;
434            }
435        }
436        else
437        {
438            ($name, $check, $off, $len) = unpack("a4NNN", $dat);
439            $zlen = $len;
440        }
441        $self->{$name} = $self->{' PARENT'}->find($self, $name, $check, $off, $len) and next
442                if (defined $self->{' PARENT'});
443        $type = $tables{$name} || 'Font::TTF::Table';
444        $t = $type;
445        if ($^O eq "MacOS")
446        { $t =~ s/^|::/:/oig; }
447        else
448        { $t =~ s|::|/|oig; }
449        require "$t.pm";
450        $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    foreach $t ('head', 'maxp')
460    { $self->{$t}->read if defined $self->{$t}; }
461
462    $self;
463}
464
465
466=head2 $f->out($fname [, @tablelist])
467
468Writes a TTF file consisting of the tables in tablelist. The list is checked to
469ensure that only tables that exist are output. (This means that you cannot have
470non table information stored in the font object with key length of exactly 4)
471
472In many cases the user simply wants to output all the tables in alphabetical order.
473This can be done by not including a @tablelist, in which case the subroutine will
474output all the defined tables in the font in alphabetical order.
475
476Returns $f on success and undef on failure, including warnings.
477
478All output files must include the C<head> table.
479
480=cut
481
482sub out
483{
484    my ($self, $fname, @tlist) = @_;
485    my ($fh);
486    my ($dat, $numTables, $sRange, $eSel);
487    my (%dir, $k, $mloc, $count);
488    my ($csum, $lsum, $msum, $loc, $oldloc, $len, $shift);
489
490    my ($iswoff); # , $woffLength, $sfntSize, $zlen);   # needed for WOFF files
491
492    unless (ref($fname))
493    {
494        $fh = IO::File->new("+>$fname") || return warn("Unable to open $fname for writing"), undef;
495        binmode $fh;
496    } else
497    { $fh = $fname; }
498
499    $self->{' oname'} = $fname;
500    $self->{' outfile'} = $fh;
501
502    if ($self->{' wantsig'})
503    {
504        $self->{' nocsum'} = 1;
505#        $self->{'head'}{'checkSumAdjustment'} = 0;
506        $self->{' tempDSIG'} = $self->{'DSIG'};
507        $self->{' tempcsum'} = $self->{'head'}{' CSUM'};
508        delete $self->{'DSIG'};
509        @tlist = sort {$self->{$a}{' OFFSET'} <=> $self->{$b}{' OFFSET'}}
510            grep (length($_) == 4 && defined $self->{$_}, keys %$self) if ($#tlist < 0);
511    }
512    elsif ($#tlist < 0)
513    { @tlist = sort keys %$self; }
514
515    @tlist = grep(length($_) == 4 && defined $self->{$_}, @tlist);
516    $numTables = $#tlist + 1;
517    $numTables++ if ($self->{' wantsig'});
518
519    if ($iswoff)
520    {
521    }
522    else
523    {
524        ($numTables, $sRange, $eSel, $shift) = Font::TTF::Utils::TTF_bininfo($numTables, 16);
525        $dat = pack("Nnnnn", 1 << 16, $numTables, $sRange, $eSel, $shift);
526        $fh->print($dat);
527        $msum = unpack("%32N*", $dat);
528    }
529
530# reserve place holders for each directory entry
531    foreach $k (@tlist)
532    {
533        $dir{$k} = pack("A4NNN", $k, 0, 0, 0);
534        $fh->print($dir{$k});
535    }
536
537    $fh->print(pack('A4NNN', '', 0, 0, 0)) if ($self->{' wantsig'});
538
539    $loc = $fh->tell();
540    if ($loc & 3)
541    {
542        $fh->print(substr("\000" x 4, $loc & 3));
543        $loc += 4 - ($loc & 3);
544    }
545
546    foreach $k (@tlist)
547    {
548        $oldloc = $loc;
549        if ($iswoff && $havezlib &&
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            my $dat;
558            my $fh2 = IO::String->new($dat);
559            binmode $fh2;
560            $self->{$k}->out($fh2);
561            $len = $fh2->tell();
562            close $fh2;
563
564            # Is table long enough to try compression?
565            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                my $zdat = Compress::Zlib::compress($dat);
571                my $zlen = bytes::length($zdat);
572                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            $self->{$k}->out($fh);
593            $loc = $fh->tell();
594            $len = $loc - $oldloc;
595        }
596        if ($loc & 3)
597        {
598            $fh->print(substr("\000" x 4, $loc & 3));
599            $loc += 4 - ($loc & 3);
600        }
601        $fh->seek($oldloc, 0);
602        $csum = 0; $mloc = $loc;
603        while ($mloc > $oldloc)
604        {
605            $count = ($mloc - $oldloc > 4096) ? 4096 : $mloc - $oldloc;
606            $fh->read($dat, $count);
607            $csum += unpack("%32N*", $dat);
608# this line ensures $csum stays within 32 bit bounds, clipping as necessary
609            if ($csum > 0xffffffff) { $csum -= 0xffffffff; $csum--; }
610            $mloc -= $count;
611        }
612        $dir{$k} = pack("A4NNN", $k, $csum, $oldloc, $len);
613        $msum += $csum + unpack("%32N*", $dir{$k});
614        while ($msum > 0xffffffff) { $msum -= 0xffffffff; $msum--; }
615        $fh->seek($loc, 0);
616    }
617
618    unless ($self->{' nocsum'})             # assuming we want a file checksum
619    {
620# Now we need to sort out the head table's checksum
621        if (!defined $dir{'head'})
622        {                                   # you have to have a head table
623            $fh->close();
624            return warn("No 'head' table to output in $fname"), undef;
625        }
626        ($csum, $loc, $len) = unpack("x4NNN", $dir{'head'});
627        $fh->seek($loc + 8, 0);
628        $fh->read($dat, 4);
629        $lsum = unpack("N", $dat);
630        if ($lsum != 0)
631        {
632            $csum -= $lsum;
633            if ($csum < 0) { $csum += 0xffffffff; $csum++; }
634            $msum -= $lsum * 2;                     # twice (in head and in csum)
635            while ($msum < 0) { $msum += 0xffffffff; $msum++; }
636        }
637        $lsum = 0xB1B0AFBA - $msum;
638        $fh->seek($loc + 8, 0);
639        $fh->print(pack("N", $lsum));
640        $dir{'head'} = pack("A4NNN", 'head', $csum, $loc, $len);
641    } elsif ($self->{' wantsig'})
642    {
643        if (!defined $dir{'head'})
644        {                                   # you have to have a head table
645            $fh->close();
646            return warn("No 'head' table to output in $fname"), undef;
647        }
648        ($csum, $loc, $len) = unpack("x4NNN", $dir{'head'});
649        $fh->seek($loc + 8, 0);
650        $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    if ($self->{' wantsig'})
656    { @tlist = sort @tlist; }
657    $fh->seek(12, 0);
658    foreach $k (@tlist)
659    { $fh->print($dir{$k}); }
660    $fh->print(pack('A4NNN', '', 0, 0, 0)) if ($self->{' wantsig'});
661    $fh->close();
662    $self;
663}
664
665
666=head2 $f->out_xml($filename [, @tables])
667
668Outputs the font in XML format
669
670=cut
671
672sub out_xml
673{
674    my ($self, $fname, @tlist) = @_;
675    my ($fh, $context, $numTables, $k);
676
677    $context->{'indent'} = ' ' x 4;
678
679    unless (ref($fname))
680    {
681        $fh = IO::File->new("+>$fname") || return warn("Unable to open $fname"), undef;
682        binmode $fh;
683    } else
684    { $fh = $fname; }
685
686    unless (scalar @tlist > 0)
687    {
688        @tlist = sort keys %$self;
689        @tlist = grep(length($_) == 4 && defined $self->{$_}, @tlist);
690    }
691    $numTables = $#tlist + 1;
692
693    $context->{'fh'} = $fh;
694    $fh->print("<?xml version='1.0' encoding='UTF-8'?>\n");
695    $fh->print("<font tables='$numTables'>\n\n");
696
697    foreach $k (@tlist)
698    {
699        $fh->print("<table name='$k'>\n");
700        $self->{$k}->out_xml($context, $context->{'indent'});
701        $fh->print("</table>\n");
702    }
703
704    $fh->print("</font>\n");
705    $fh->close;
706    $self;
707}
708
709
710=head2 $f->XML_start($context, $tag, %attrs)
711
712Handles start messages from the XML parser. Of particular interest to us are <font> and
713<table>.
714
715=cut
716
717sub XML_start
718{
719    my ($self, $context, $tag, %attrs) = @_;
720    my ($name, $type, $t);
721
722    if ($tag eq 'font')
723    { $context->{'tree'}[-1] = $self; }
724    elsif ($tag eq 'table')
725    {
726        $name = $attrs{'name'};
727        unless (defined $self->{$name})
728        {
729            $type = $tables{$name} || 'Font::TTF::Table';
730            $t = $type;
731            if ($^O eq "MacOS")
732            { $t =~ s/^|::/:/oig; }
733            else
734            { $t =~ s|::|/|oig; }
735            require "$t.pm";
736            $self->{$name} = $type->new('PARENT' => $self, 'NAME' => $name, 'read' => 1);
737        }
738        $context->{'receiver'} = ($context->{'tree'}[-1] = $self->{$name});
739    }
740    $context;
741}
742
743
744sub XML_end
745{
746    my ($self) = @_;
747    my ($context, $tag, %attrs) = @_;
748    my ($i);
749
750    return undef unless ($tag eq 'table' && $attrs{'name'} eq 'loca');
751    if (defined $context->{'glyphs'} && $context->{'glyphs'} ne $self->{'loca'}{'glyphs'})
752    {
753        for ($i = 0; $i <= $#{$context->{'glyphs'}}; $i++)
754        { $self->{'loca'}{'glyphs'}[$i] = $context->{'glyphs'}[$i] if defined $context->{'glyphs'}[$i]; }
755        $context->{'glyphs'} = $self->{'loca'}{'glyphs'};
756    }
757    return undef;
758}
759
760=head2 $f->update
761
762Sends update to all the tables in the font and then resets all the isDirty
763flags on each table. The data structure in now consistent as a font (we hope).
764
765=cut
766
767sub update
768{
769    my ($self) = @_;
770
771    $self->tables_do(sub { $_[0]->update; });
772
773    $self;
774}
775
776=head2 $f->dirty
777
778Dirties all the tables in the font
779
780=cut
781
782sub dirty
783{ $_[0]->tables_do(sub { $_[0]->dirty; }); $_[0]; }
784
785=head2 $f->tables_do(&func [, tables])
786
787Calls &func for each table in the font. Calls the table in alphabetical sort
788order as per the order in the directory:
789
790    &func($table, $name);
791
792May optionally take a list of table names in which case func is called
793for each of them in the given order.
794
795=cut
796
797sub tables_do
798{
799    my ($self, $func, @tables) = @_;
800    my ($t);
801
802    foreach $t (@tables ? @tables : sort grep {length($_) == 4} keys %$self)
803    { &$func($self->{$t}, $t); }
804    $self;
805}
806
807
808=head2 $f->release
809
810Releases ALL of the memory used by the TTF font and all of its component
811objects.  After calling this method, do B<NOT> expect to have anything left in
812the C<Font::TTF::Font> object.
813
814B<NOTE>, that it is important that you call this method on any
815C<Font::TTF::Font> object when you wish to destruct it and free up its memory.
816Internally, we track things in a structure that can result in circular
817references, and without calling 'C<release()>' these will not properly get
818cleaned up by Perl.  Once you've called this method, though, don't expect to be
819able to do anything else with the C<Font::TTF::Font> object; it'll have B<no>
820internal state whatsoever.
821
822B<Developer note:> As part of the brute-force cleanup done here, this method
823will throw a warning message whenever unexpected key values are found within
824the C<Font::TTF::Font> object.  This is done to help ensure that any unexpected
825and unfreed values are brought to your attention so that you can bug us to keep
826the module updated properly; otherwise the potential for memory leaks due to
827dangling circular references will exist.
828
829=cut
830
831sub release
832{
833    my ($self) = @_;
834
835# delete stuff that we know we can, here
836
837    my @tofree = map { delete $self->{$_} } keys %{$self};
838
839    while (my $item = shift @tofree)
840    {
841        my $ref = ref($item);
842        if (UNIVERSAL::can($item, 'release'))
843        { $item->release(); }
844        elsif ($ref eq 'ARRAY')
845        { push( @tofree, @{$item} ); }
846        elsif (UNIVERSAL::isa($ref, 'HASH'))
847        { release($item); }
848    }
849
850# check that everything has gone - it better had!
851    foreach my $key (keys %{$self})
852    { warn ref($self) . " still has '$key' key left after release.\n"; }
853}
854
8551;
856
857=head1 BUGS
858
859Bugs abound aplenty I am sure. There is a lot of code here and plenty of scope.
860The parts of the code which haven't been implemented yet are:
861
862=over 4
863
864=item Post
865
866Version 4 format types are not supported yet.
867
868=item Cmap
869
870Format type 2 (MBCS) has not been implemented yet and therefore may cause
871somewhat spurious results for this table type.
872
873=item Kern
874
875Only type 0 & type 2 tables are supported (type 1 & type 3 yet to come).
876
877=item TTC and WOFF
878
879The current Font::TTF::Font::out method does not support the writing of TrueType
880Collections or WOFF files.
881
882=item DSIG
883
884Haven't figured out how to correctly calculate and output digital signature (DSIG) table
885
886=back
887
888In addition there are weaknesses or features of this module library
889
890=over 4
891
892=item *
893
894There is very little (or no) error reporting. This means that if you have
895garbled data or garbled data structures, then you are liable to generate duff
896fonts.
897
898=item *
899
900The exposing of the internal data structures everywhere means that doing
901radical re-structuring is almost impossible. But it stop the code from becoming
902ridiculously large.
903
904=back
905
906Apart from these, I try to keep the code in a state of "no known bugs", which
907given the amount of testing this code has had, is not a guarantee of high
908quality, yet.
909
910For more details see the appropriate class files.
911
912=head1 AUTHOR
913
914Martin Hosken L<http://scripts.sil.org/FontUtils>.
915
916
917=head1 LICENSING
918
919Copyright (c) 1998-2016, SIL International (http://www.sil.org)
920
921This module is released under the terms of the Artistic License 2.0.
922For details, see the full text of the license in the file LICENSE.
923
924
925
926=cut
927
928