X-Git-Url: https://git.mdrn.pl/librarian.git/blobdiff_plain/e9aeedc51047d8d5e9e45c5253c776f8994da965..3a0c83394d5783715fab2be29fa1a9cfc3574e28:/src/librarian/font-optimizer/ext/Font-TTF/lib/Font/TTF/Table.pm 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 deleted file mode 100644 index bbdb48d..0000000 --- a/src/librarian/font-optimizer/ext/Font-TTF/lib/Font/TTF/Table.pm +++ /dev/null @@ -1,382 +0,0 @@ -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 -