--- /dev/null
+package Font::TTF::Table;
+
+=head1 NAME
+
+Font::TTF::Table - Superclass for tables and used for tables we don't have a class for
+
+=head1 DESCRIPTION
+
+Looks after the purely table aspects of a TTF table, such as whether the table
+has been read before, locating the file pointer, etc. Also copies tables from
+input to output.
+
+=head1 INSTANCE VARIABLES
+
+Instance variables start with a space
+
+=over 4
+
+=item read
+
+Flag which indicates that the table has already been read from file.
+
+=item dat
+
+Allows the creation of unspecific tables. Data is simply output to any font
+file being created.
+
+=item INFILE
+
+The read file handle
+
+=item OFFSET
+
+Location of the file in the input file
+
+=item LENGTH
+
+Length in the input directory
+
+=item CSUM
+
+Checksum read from the input file's directory
+
+=item PARENT
+
+The L<Font::TTF::Font> that table is part of
+
+=back
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw($VERSION);
+use Font::TTF::Utils;
+
+$VERSION = 0.0001;
+
+=head2 Font::TTF::Table->new(%parms)
+
+Creates a new table or subclass. Table instance variables are passed in
+at this point as an associative array.
+
+=cut
+
+sub new
+{
+ my ($class, %parms) = @_;
+ my ($self) = {};
+ my ($p);
+
+ $class = ref($class) || $class;
+ foreach $p (keys %parms)
+ { $self->{" $p"} = $parms{$p}; }
+ bless $self, $class;
+}
+
+
+=head2 $t->read
+
+Reads the table from the input file. Acts as a superclass to all true tables.
+This method marks the table as read and then just sets the input file pointer
+but does not read any data. If the table has already been read, then returns
+C<undef> else returns C<$self>
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+
+ return $self->read_dat if (ref($self) eq "Font::TTF::Table");
+ return undef if $self->{' read'};
+ $self->{' INFILE'}->seek($self->{' OFFSET'}, 0);
+ $self->{' read'} = 1;
+ $self;
+}
+
+
+=head2 $t->read_dat
+
+Reads the table into the C<dat> instance variable for those tables which don't
+know any better
+
+=cut
+
+sub read_dat
+{
+ my ($self) = @_;
+
+# can't just $self->read here otherwise those tables which start their read sub with
+# $self->read_dat are going to permanently loop
+ return undef if ($self->{' read'});
+# $self->{' read'} = 1; # Let read do this, now out will call us for subclasses
+ $self->{' INFILE'}->seek($self->{' OFFSET'}, 0);
+ $self->{' INFILE'}->read($self->{' dat'}, $self->{' LENGTH'});
+ $self;
+}
+
+=head2 $t->out($fh)
+
+Writes out the table to the font file. If there is anything in the
+C<data> instance variable then this is output, otherwise the data is copied
+from the input file to the output
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+ my ($dat, $i, $len, $count);
+
+ if (defined $self->{' dat'})
+ {
+ $fh->print($self->{' dat'});
+ return $self;
+ }
+
+ return undef unless defined $self->{' INFILE'};
+ $self->{' INFILE'}->seek($self->{' OFFSET'}, 0);
+ $len = $self->{' LENGTH'};
+ while ($len > 0)
+ {
+ $count = ($len > 4096) ? 4096 : $len;
+ $self->{' INFILE'}->read($dat, $count);
+ $fh->print($dat);
+ $len -= $count;
+ }
+ $self;
+}
+
+
+=head2 $t->out_xml($context)
+
+Outputs this table in XML format. The table is first read (if not already read) and then if
+there is no subclass, then the data is dumped as hex data
+
+=cut
+
+sub out_xml
+{
+ my ($self, $context, $depth) = @_;
+ my ($k);
+
+ if (ref($self) eq __PACKAGE__)
+ {
+ $self->read_dat;
+ Font::TTF::Utils::XML_hexdump($context, $depth, $self->{' dat'});
+ }
+ else
+ {
+ $self->read;
+ foreach $k (sort grep {$_ !~ m/^\s/o} keys %{$self})
+ {
+ $self->XML_element($context, $depth, $k, $self->{$k});
+ }
+ }
+ $self;
+}
+
+
+=head2 $t->XML_element
+
+Output a particular element based on its contents.
+
+=cut
+
+sub XML_element
+{
+ my ($self, $context, $depth, $k, $dat) = @_;
+ my ($fh) = $context->{'fh'};
+ my ($ndepth, $d);
+
+ return unless defined $dat;
+
+ if (!ref($dat))
+ {
+ $fh->printf("%s<%s>%s</%s>\n", $depth, $k, $dat, $k);
+ return $self;
+ }
+
+ $fh->printf("%s<%s>\n", $depth, $k);
+ $ndepth = $depth . $context->{'indent'};
+
+ if (ref($dat) eq 'SCALAR')
+ { $self->XML_element($context, $ndepth, 'scalar', $$dat); }
+ elsif (ref($dat) eq 'ARRAY')
+ {
+ foreach $d (@{$dat})
+ { $self->XML_element($context, $ndepth, 'elem', $d); }
+ }
+ elsif (ref($dat) eq 'HASH')
+ {
+ foreach $d (sort grep {$_ !~ m/^\s/o} keys %{$dat})
+ { $self->XML_element($context, $ndepth, $d, $dat->{$d}); }
+ }
+ else
+ {
+ $context->{'name'} = ref($dat);
+ $context->{'name'} =~ s/^.*://o;
+ $dat->out_xml($context, $ndepth);
+ }
+
+ $fh->printf("%s</%s>\n", $depth, $k);
+ $self;
+}
+
+
+=head2 $t->XML_end($context, $tag, %attrs)
+
+Handles the default type of <data> for those tables which aren't subclassed
+
+=cut
+
+sub XML_end
+{
+ my ($self, $context, $tag, %attrs) = @_;
+ my ($dat, $addr);
+
+ return undef unless ($tag eq 'data');
+ $dat = $context->{'text'};
+ $dat =~ s/([0-9a-f]{2})\s*/hex($1)/oig;
+ if (defined $attrs{'addr'})
+ { $addr = hex($attrs{'addr'}); }
+ else
+ { $addr = length($self->{' dat'}); }
+ substr($self->{' dat'}, $addr, length($dat)) = $dat;
+ return $context;
+}
+
+
+=head2 $t->dirty($val)
+
+This sets the dirty flag to the given value or 1 if no given value. It returns the
+value of the flag
+
+=cut
+
+sub dirty
+{
+ my ($self, $val) = @_;
+ my ($res) = $self->{' isDirty'};
+
+ $self->{' isDirty'} = defined $val ? $val : 1;
+ $res;
+}
+
+=head2 $t->update
+
+Each table knows how to update itself. This consists of doing whatever work
+is required to ensure that the memory version of the table is consistent
+and that other parameters in other tables have been updated accordingly.
+I.e. by the end of sending C<update> to all the tables, the memory version
+of the font should be entirely consistent.
+
+Some tables which do no work indicate to themselves the need to update
+themselves by setting isDirty above 1. This method resets that accordingly.
+
+=cut
+
+sub update
+{
+ my ($self) = @_;
+
+ if ($self->{' isDirty'})
+ {
+ $self->read;
+ $self->{' isDirty'} = 0;
+ return $self;
+ }
+ else
+ { return undef; }
+}
+
+
+=head2 $t->empty
+
+Clears a table of all data to the level of not having been read
+
+=cut
+
+sub empty
+{
+ my ($self) = @_;
+ my (%keep);
+
+ foreach (qw(INFILE LENGTH OFFSET CSUM PARENT))
+ { $keep{" $_"} = 1; }
+
+ map {delete $self->{$_} unless $keep{$_}} keys %$self;
+ $self;
+}
+
+
+=head2 $t->release
+
+Releases ALL of the memory used by this table, and all of its component/child
+objects. This method is called automatically by
+'Font::TTF::Font-E<gt>release' (so you don't have to call it yourself).
+
+B<NOTE>, that it is important that this method get called at some point prior
+to the actual destruction of the object. Internally, we track things in a
+structure that can result in circular references, and without calling
+'C<release()>' these will not properly get cleaned up by Perl. Once this
+method has been called, though, don't expect to be able to do anything with the
+C<Font::TTF::Table> object; it'll have B<no> internal state whatsoever.
+
+B<Developer note:> As part of the brute-force cleanup done here, this method
+will throw a warning message whenever unexpected key values are found within
+the C<Font::TTF::Table> object. This is done to help ensure that any
+unexpected and unfreed values are brought to your attention so that you can bug
+us to keep the module updated properly; otherwise the potential for memory
+leaks due to dangling circular references will exist.
+
+=cut
+
+sub release
+{
+ my ($self) = @_;
+
+# delete stuff that we know we can, here
+
+ my @tofree = map { delete $self->{$_} } keys %{$self};
+
+ while (my $item = shift @tofree)
+ {
+ my $ref = ref($item);
+ if (UNIVERSAL::can($item, 'release'))
+ { $item->release(); }
+ elsif ($ref eq 'ARRAY')
+ { push( @tofree, @{$item} ); }
+ elsif (UNIVERSAL::isa($ref, 'HASH'))
+ { release($item); }
+ }
+
+# check that everything has gone - it better had!
+ foreach my $key (keys %{$self})
+ { warn ref($self) . " still has '$key' key left after release.\n"; }
+}
+
+
+sub __dumpvar__
+{
+ my ($self, $key) = @_;
+
+ return ($key eq ' PARENT' ? '...parent...' : $self->{$key});
+}
+
+1;
+
+=head1 BUGS
+
+No known bugs
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken@sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
fnp / librarian.git / blobdiff