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

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