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

   1 package Font::TTF::Table;
   2
   3 =head1 NAME
   4
   5 Font::TTF::Table - Superclass for tables and used for tables we don't have a class for
   6
   7 =head1 DESCRIPTION
   8
   9 Looks after the purely table aspects of a TTF table, such as whether the table
  10 has been read before, locating the file pointer, etc. Also copies tables from
  11 input to output.
  12
  13 =head1 INSTANCE VARIABLES
  14
  15 Instance variables start with a space
  16
  17 =over 4
  18
  19 =item read
  20
  21 Flag which indicates that the table has already been read from file.
  22
  23 =item dat
  24
  25 Allows the creation of unspecific tables. Data is simply output to any font
  26 file being created.
  27
  28 =item INFILE
  29
  30 The read file handle
  31
  32 =item OFFSET
  33
  34 Location of the file in the input file
  35
  36 =item LENGTH
  37
  38 Length in the input directory
  39
  40 =item CSUM
  41
  42 Checksum read from the input file's directory
  43
  44 =item PARENT
  45
  46 The L<Font::TTF::Font> that table is part of
  47
  48 =back
  49
  50 =head1 METHODS
  51
  52 =cut
  53
  54 use strict;
  55 use vars qw($VERSION);
  56 use Font::TTF::Utils;
  57
  58 $VERSION = 0.0001;
  59
  60 =head2 Font::TTF::Table->new(%parms)
  61
  62 Creates a new table or subclass. Table instance variables are passed in
  63 at this point as an associative array.
  64
  65 =cut
  66
  67 sub new
  68 {
  69     my ($class, %parms) = @_;
  70     my ($self) = {};
  71     my ($p);
  72
  73     $class = ref($class) || $class;
  74     foreach $p (keys %parms)
  75     { $self->{" $p"} = $parms{$p}; }
  76     bless $self, $class;
  77 }
  78
  79
  80 =head2 $t->read
  81
  82 Reads the table from the input file. Acts as a superclass to all true tables.
  83 This method marks the table as read and then just sets the input file pointer
  84 but does not read any data. If the table has already been read, then returns
  85 C<undef> else returns C<$self>
  86
  87 =cut
  88
  89 sub read
  90 {
  91     my ($self) = @_;
  92
  93     return $self->read_dat if (ref($self) eq "Font::TTF::Table");
  94     return undef if $self->{' read'};
  95     $self->{' INFILE'}->seek($self->{' OFFSET'}, 0);
  96     $self->{' read'} = 1;
  97     $self;
  98 }
  99
 100
 101 =head2 $t->read_dat
 102
 103 Reads the table into the C<dat> instance variable for those tables which don't
 104 know any better
 105
 106 =cut
 107
 108 sub read_dat
 109 {
 110     my ($self) = @_;
 111
 112 # can't just $self->read here otherwise those tables which start their read sub with
 113 # $self->read_dat are going to permanently loop
 114     return undef if ($self->{' read'});
 115 #    $self->{' read'} = 1;      # Let read do this, now out will call us for subclasses
 116     $self->{' INFILE'}->seek($self->{' OFFSET'}, 0);
 117     $self->{' INFILE'}->read($self->{' dat'}, $self->{' LENGTH'});
 118     $self;
 119 }
 120
 121 =head2 $t->out($fh)
 122
 123 Writes out the table to the font file. If there is anything in the
 124 C<data> instance variable then this is output, otherwise the data is copied
 125 from the input file to the output
 126
 127 =cut
 128
 129 sub out
 130 {
 131     my ($self, $fh) = @_;
 132     my ($dat, $i, $len, $count);
 133
 134     if (defined $self->{' dat'})
 135     {
 136         $fh->print($self->{' dat'});
 137         return $self;
 138     }
 139
 140     return undef unless defined $self->{' INFILE'};
 141     $self->{' INFILE'}->seek($self->{' OFFSET'}, 0);
 142     $len = $self->{' LENGTH'};
 143     while ($len > 0)
 144     {
 145         $count = ($len > 4096) ? 4096 : $len;
 146         $self->{' INFILE'}->read($dat, $count);
 147         $fh->print($dat);
 148         $len -= $count;
 149     }
 150     $self;
 151 }
 152
 153
 154 =head2 $t->out_xml($context)
 155
 156 Outputs this table in XML format. The table is first read (if not already read) and then if
 157 there is no subclass, then the data is dumped as hex data
 158
 159 =cut
 160
 161 sub out_xml
 162 {
 163     my ($self, $context, $depth) = @_;
 164     my ($k);
 165
 166     if (ref($self) eq __PACKAGE__)
 167     {
 168         $self->read_dat;
 169         Font::TTF::Utils::XML_hexdump($context, $depth, $self->{' dat'});
 170     }
 171     else
 172     {
 173         $self->read;
 174         foreach $k (sort grep {$_ !~ m/^\s/o} keys %{$self})
 175         {
 176             $self->XML_element($context, $depth, $k, $self->{$k});
 177         }
 178     }
 179     $self;
 180 }
 181
 182
 183 =head2 $t->XML_element
 184
 185 Output a particular element based on its contents.
 186
 187 =cut
 188
 189 sub XML_element
 190 {
 191     my ($self, $context, $depth, $k, $dat) = @_;
 192     my ($fh) = $context->{'fh'};
 193     my ($ndepth, $d);
 194
 195     return unless defined $dat;
 196
 197     if (!ref($dat))
 198     {
 199         $fh->printf("%s<%s>%s</%s>\n", $depth, $k, $dat, $k);
 200         return $self;
 201     }
 202
 203     $fh->printf("%s<%s>\n", $depth, $k);
 204     $ndepth = $depth . $context->{'indent'};
 205
 206     if (ref($dat) eq 'SCALAR')
 207     { $self->XML_element($context, $ndepth, 'scalar', $$dat); }
 208     elsif (ref($dat) eq 'ARRAY')
 209     {
 210         foreach $d (@{$dat})
 211         { $self->XML_element($context, $ndepth, 'elem', $d); }
 212     }
 213     elsif (ref($dat) eq 'HASH')
 214     {
 215         foreach $d (sort grep {$_ !~ m/^\s/o} keys %{$dat})
 216         { $self->XML_element($context, $ndepth, $d, $dat->{$d}); }
 217     }
 218     else
 219     {
 220         $context->{'name'} = ref($dat);
 221         $context->{'name'} =~ s/^.*://o;
 222         $dat->out_xml($context, $ndepth);
 223     }
 224
 225     $fh->printf("%s</%s>\n", $depth, $k);
 226     $self;
 227 }
 228
 229
 230 =head2 $t->XML_end($context, $tag, %attrs)
 231
 232 Handles the default type of <data> for those tables which aren't subclassed
 233
 234 =cut
 235
 236 sub XML_end
 237 {
 238     my ($self, $context, $tag, %attrs) = @_;
 239     my ($dat, $addr);
 240
 241     return undef unless ($tag eq 'data');
 242     $dat = $context->{'text'};
 243     $dat =~ s/([0-9a-f]{2})\s*/hex($1)/oig;
 244     if (defined $attrs{'addr'})
 245     { $addr = hex($attrs{'addr'}); }
 246     else
 247     { $addr = length($self->{' dat'}); }
 248     substr($self->{' dat'}, $addr, length($dat)) = $dat;
 249     return $context;
 250 }
 251
 252
 253 =head2 $t->dirty($val)
 254
 255 This sets the dirty flag to the given value or 1 if no given value. It returns the
 256 value of the flag
 257
 258 =cut
 259
 260 sub dirty
 261 {
 262     my ($self, $val) = @_;
 263     my ($res) = $self->{' isDirty'};
 264
 265     $self->{' isDirty'} = defined $val ? $val : 1;
 266     $res;
 267 }
 268
 269 =head2 $t->update
 270
 271 Each table knows how to update itself. This consists of doing whatever work
 272 is required to ensure that the memory version of the table is consistent
 273 and that other parameters in other tables have been updated accordingly.
 274 I.e. by the end of sending C<update> to all the tables, the memory version
 275 of the font should be entirely consistent.
 276
 277 Some tables which do no work indicate to themselves the need to update
 278 themselves by setting isDirty above 1. This method resets that accordingly.
 279
 280 =cut
 281
 282 sub update
 283 {
 284     my ($self) = @_;
 285
 286     if ($self->{' isDirty'})
 287     {
 288         $self->read;
 289         $self->{' isDirty'} = 0;
 290         return $self;
 291     }
 292     else
 293     { return undef; }
 294 }
 295
 296
 297 =head2 $t->empty
 298
 299 Clears a table of all data to the level of not having been read
 300
 301 =cut
 302
 303 sub empty
 304 {
 305     my ($self) = @_;
 306     my (%keep);
 307
 308     foreach (qw(INFILE LENGTH OFFSET CSUM PARENT))
 309     { $keep{" $_"} = 1; }
 310
 311     map {delete $self->{$_} unless $keep{$_}} keys %$self;
 312     $self;
 313 }
 314
 315
 316 =head2 $t->release
 317
 318 Releases ALL of the memory used by this table, and all of its component/child
 319 objects.  This method is called automatically by
 320 'Font::TTF::Font-E<gt>release' (so you don't have to call it yourself).
 321
 322 B<NOTE>, that it is important that this method get called at some point prior
 323 to the actual destruction of the object.  Internally, we track things in a
 324 structure that can result in circular references, and without calling
 325 'C<release()>' these will not properly get cleaned up by Perl.  Once this
 326 method has been called, though, don't expect to be able to do anything with the
 327 C<Font::TTF::Table> object; it'll have B<no> internal state whatsoever.
 328
 329 B<Developer note:>  As part of the brute-force cleanup done here, this method
 330 will throw a warning message whenever unexpected key values are found within
 331 the C<Font::TTF::Table> object.  This is done to help ensure that any
 332 unexpected and unfreed values are brought to your attention so that you can bug
 333 us to keep the module updated properly; otherwise the potential for memory
 334 leaks due to dangling circular references will exist.
 335
 336 =cut
 337
 338 sub release
 339 {
 340     my ($self) = @_;
 341
 342 # delete stuff that we know we can, here
 343
 344     my @tofree = map { delete $self->{$_} } keys %{$self};
 345
 346     while (my $item = shift @tofree)
 347     {
 348         my $ref = ref($item);
 349         if (UNIVERSAL::can($item, 'release'))
 350         { $item->release(); }
 351         elsif ($ref eq 'ARRAY')
 352         { push( @tofree, @{$item} ); }
 353         elsif (UNIVERSAL::isa($ref, 'HASH'))
 354         { release($item); }
 355     }
 356
 357 # check that everything has gone - it better had!
 358     foreach my $key (keys %{$self})
 359     { warn ref($self) . " still has '$key' key left after release.\n"; }
 360 }
 361
 362
 363 sub __dumpvar__
 364 {
 365     my ($self, $key) = @_;
 366
 367     return ($key eq ' PARENT' ? '...parent...' : $self->{$key});
 368 }
 369
 370 1;
 371
 372 =head1 BUGS
 373
 374 No known bugs
 375
 376 =head1 AUTHOR
 377
 378 Martin Hosken Martin_Hosken@sil.org. See L<Font::TTF::Font> for copyright and
 379 licensing.
 380
 381 =cut
 382