X-Git-Url: https://git.mdrn.pl/librarian.git/blobdiff_plain/2ada86c7bb585d419b95c95ce42d5b7a9fa45475..fefdce4e24f9e397df5538fe6e7f54b5ece4d841:/src/librarian/font-optimizer/ext/Font-TTF/lib/Font/TTF/Table.pm?ds=sidebyside diff --git a/src/librarian/font-optimizer/ext/Font-TTF/lib/Font/TTF/Table.pm b/src/librarian/font-optimizer/ext/Font-TTF/lib/Font/TTF/Table.pm new file mode 100644 index 0000000..bbdb48d --- /dev/null +++ b/src/librarian/font-optimizer/ext/Font-TTF/lib/Font/TTF/Table.pm @@ -0,0 +1,382 @@ +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 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 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 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 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\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\n", $depth, $k); + $self; +} + + +=head2 $t->XML_end($context, $tag, %attrs) + +Handles the default type of 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 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-Erelease' (so you don't have to call it yourself). + +B, 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' 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 object; it'll have B internal state whatsoever. + +B 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 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 for copyright and +licensing. + +=cut +