|
Packit |
5d935b |
package Font::TTF::Table;
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=head1 NAME
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Font::TTF::Table - Superclass for tables and used for tables we don't have a class for
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=head1 DESCRIPTION
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Looks after the purely table aspects of a TTF table, such as whether the table
|
|
Packit |
5d935b |
has been read before, locating the file pointer, etc. Also copies tables from
|
|
Packit |
5d935b |
input to output.
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=head1 INSTANCE VARIABLES
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Instance variables start with a space
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=over 4
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=item read
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Flag which indicates that the table has already been read from file.
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=item dat
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Allows the creation of unspecific tables. Data is simply output to any font
|
|
Packit |
5d935b |
file being created.
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=item nocompress
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
If set, overrides the font default for WOFF table compression. Is a scalar integer specifying a
|
|
Packit |
5d935b |
table size threshold below which this table will not be compressed. Set to -1 to never
|
|
Packit |
5d935b |
compress; 0 to always compress.
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=item INFILE
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
The read file handle
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=item OFFSET
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Location of the file in the input file
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=item LENGTH
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Length in the input directory
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=item ZLENGTH
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Compressed length of the table if a WOFF font. 0 < ZLENGTH < LENGTH implies table is compressed.
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=item CSUM
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Checksum read from the input file's directory
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=item PARENT
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
The L<Font::TTF::Font> that table is part of
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=back
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=head1 METHODS
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=cut
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
use strict;
|
|
Packit |
5d935b |
use vars qw($VERSION);
|
|
Packit |
5d935b |
use Font::TTF::Utils;
|
|
Packit |
5d935b |
use IO::String;
|
|
Packit |
5d935b |
$VERSION = 0.0001;
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
my $havezlib = eval {require Compress::Zlib};
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=head2 Font::TTF::Table->new(%parms)
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Creates a new table or subclass. Table instance variables are passed in
|
|
Packit |
5d935b |
at this point as an associative array.
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=cut
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
sub new
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
my ($class, %parms) = @_;
|
|
Packit |
5d935b |
my ($self) = {};
|
|
Packit |
5d935b |
my ($p);
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
$class = ref($class) || $class;
|
|
Packit |
5d935b |
foreach $p (keys %parms)
|
|
Packit |
5d935b |
{ $self->{" $p"} = $parms{$p}; }
|
|
Packit |
5d935b |
bless $self, $class;
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=head2 $t->read
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Reads the table from the input file. Acts as a superclass to all true tables.
|
|
Packit |
5d935b |
This method marks the table as read and then just sets the input file pointer
|
|
Packit |
5d935b |
but does not read any data. If the table has already been read, then returns
|
|
Packit |
5d935b |
C<undef> else returns C<$self>
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
For WOFF-compressed tables, the table is first decompressed and a
|
|
Packit |
5d935b |
replacement file handle is created for reading the decompressed data. In this
|
|
Packit |
5d935b |
case ORIGINALOFFSET will preserve the original value of OFFSET for
|
|
Packit |
5d935b |
applications that care.
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=cut
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
sub read
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
my ($self) = @_;
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
return $self->read_dat if (ref($self) eq "Font::TTF::Table");
|
|
Packit |
5d935b |
return undef if $self->{' read'};
|
|
Packit |
5d935b |
$self->{' INFILE'}->seek($self->{' OFFSET'}, 0);
|
|
Packit |
5d935b |
if (0 < $self->{' ZLENGTH'} && $self->{' ZLENGTH'} < $self->{' LENGTH'})
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
# WOFF table is compressed. Uncompress it to memory and create new fh
|
|
Packit |
5d935b |
die ("Cannot uncompress WOFF data: Compress::Zlib not present.\n") unless $havezlib;
|
|
Packit |
5d935b |
$self->{' ORIGINALOFFSET'} = $self->{' OFFSET'}; # Preserve this for those who care
|
|
Packit |
5d935b |
my $dat;
|
|
Packit |
5d935b |
$self->{' INFILE'}->read($dat, $self->{' ZLENGTH'});
|
|
Packit |
5d935b |
$dat = Compress::Zlib::uncompress($dat);
|
|
Packit |
5d935b |
warn "$self->{' NAME'} table decompressed to wrong length" if $self->{' LENGTH'} != bytes::length($dat);
|
|
Packit |
5d935b |
$self->{' INFILE'} = IO::String->new($dat);
|
|
Packit |
5d935b |
binmode $self->{' INFILE'};
|
|
Packit |
5d935b |
$self->{' OFFSET'} = 0;
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
$self->{' read'} = 1;
|
|
Packit |
5d935b |
$self;
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=head2 $t->read_dat
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Reads the table into the C<dat> instance variable for those tables which don't
|
|
Packit |
5d935b |
know any better
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=cut
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
sub read_dat
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
my ($self) = @_;
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
# can't just $self->read here otherwise those tables which start their read sub with
|
|
Packit |
5d935b |
# $self->read_dat are going to permanently loop
|
|
Packit |
5d935b |
return undef if ($self->{' read'});
|
|
Packit |
5d935b |
# $self->{' read'} = 1; # Let read do this, now out will call us for subclasses
|
|
Packit |
5d935b |
$self->{' INFILE'}->seek($self->{' OFFSET'}, 0);
|
|
Packit |
5d935b |
if (0 < $self->{' ZLENGTH'} && $self->{' ZLENGTH'} < $self->{' LENGTH'})
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
# WOFF table is compressed. Uncompress it directly to ' dat'
|
|
Packit |
5d935b |
die ("Cannot uncompress WOFF data: Compress::Zlib not present.\n") unless $havezlib;
|
|
Packit |
5d935b |
my $dat;
|
|
Packit |
5d935b |
$self->{' INFILE'}->read($dat, $self->{' ZLENGTH'});
|
|
Packit |
5d935b |
$dat = Compress::Zlib::uncompress($dat);
|
|
Packit |
5d935b |
warn "$self->{' NAME'} table decompressed to wrong length" if $self->{' LENGTH'} != bytes::length($dat);
|
|
Packit |
5d935b |
$self->{' dat'} = $dat;
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
else
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
$self->{' INFILE'}->read($self->{' dat'}, $self->{' LENGTH'});
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
$self;
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=head2 $t->out($fh)
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Writes out the table to the font file. If there is anything in the
|
|
Packit |
5d935b |
C<dat> instance variable then this is output, otherwise the data is copied
|
|
Packit |
5d935b |
from the input file to the output
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=cut
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
sub out
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
my ($self, $fh) = @_;
|
|
Packit |
5d935b |
my ($dat, $i, $len, $count);
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
if (defined $self->{' dat'})
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
$fh->print($self->{' dat'});
|
|
Packit |
5d935b |
return $self;
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
return undef unless defined $self->{' INFILE'};
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
if (0 < $self->{' ZLENGTH'} && $self->{' ZLENGTH'} < $self->{' LENGTH'})
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
# WOFF table is compressed. Have to uncompress first
|
|
Packit |
5d935b |
$self->read_dat;
|
|
Packit |
5d935b |
$fh->print($self->{' dat'});
|
|
Packit |
5d935b |
return $self;
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
# We don't really have to keep the following code... we could have
|
|
Packit |
5d935b |
# just always done a full read_dat() on the table. But the following
|
|
Packit |
5d935b |
# is more memory-friendly so I've kept it for the more common case
|
|
Packit |
5d935b |
# of non-compressed tables.
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
$self->{' INFILE'}->seek($self->{' OFFSET'}, 0);
|
|
Packit |
5d935b |
$len = $self->{' LENGTH'};
|
|
Packit |
5d935b |
while ($len > 0)
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
$count = ($len > 4096) ? 4096 : $len;
|
|
Packit |
5d935b |
$self->{' INFILE'}->read($dat, $count);
|
|
Packit |
5d935b |
$fh->print($dat);
|
|
Packit |
5d935b |
$len -= $count;
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
$self;
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=head2 $t->out_xml($context)
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Outputs this table in XML format. The table is first read (if not already read) and then if
|
|
Packit |
5d935b |
there is no subclass, then the data is dumped as hex data
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=cut
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
sub out_xml
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
my ($self, $context, $depth) = @_;
|
|
Packit |
5d935b |
my ($k);
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
if (ref($self) eq __PACKAGE__)
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
$self->read_dat;
|
|
Packit |
5d935b |
Font::TTF::Utils::XML_hexdump($context, $depth, $self->{' dat'});
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
else
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
$self->read;
|
|
Packit |
5d935b |
foreach $k (sort grep {$_ !~ m/^\s/o} keys %{$self})
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
$self->XML_element($context, $depth, $k, $self->{$k});
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
$self;
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=head2 $t->XML_element
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Output a particular element based on its contents.
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=cut
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
sub XML_element
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
my ($self, $context, $depth, $k, $dat, $ind) = @_;
|
|
Packit |
5d935b |
my ($fh) = $context->{'fh'};
|
|
Packit |
5d935b |
my ($ndepth, $d);
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
return unless defined $dat;
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
if (!ref($dat))
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
$fh->printf("%s<%s>%s</%s>\n", $depth, $k, $dat, $k);
|
|
Packit |
5d935b |
return $self;
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
if ($ind)
|
|
Packit |
5d935b |
{ $fh->printf("%s<%s i='%d'>\n", $depth, $k, $ind); }
|
|
Packit |
5d935b |
else
|
|
Packit |
5d935b |
{ $fh->printf("%s<%s>\n", $depth, $k); }
|
|
Packit |
5d935b |
$ndepth = $depth . $context->{'indent'};
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
if (ref($dat) eq 'SCALAR')
|
|
Packit |
5d935b |
{ $self->XML_element($context, $ndepth, 'scalar', $$dat); }
|
|
Packit |
5d935b |
elsif (ref($dat) eq 'ARRAY')
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
my ($c) = 1;
|
|
Packit |
5d935b |
foreach $d (@{$dat})
|
|
Packit |
5d935b |
{ $self->XML_element($context, $ndepth, 'elem', $d, $c++); }
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
elsif (ref($dat) eq 'HASH')
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
foreach $d (sort grep {$_ !~ m/^\s/o} keys %{$dat})
|
|
Packit |
5d935b |
{ $self->XML_element($context, $ndepth, $d, $dat->{$d}); }
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
else
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
$context->{'name'} = ref($dat);
|
|
Packit |
5d935b |
$context->{'name'} =~ s/^.*://o;
|
|
Packit |
5d935b |
$dat->out_xml($context, $ndepth);
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
$fh->printf("%s</%s>\n", $depth, $k);
|
|
Packit |
5d935b |
$self;
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=head2 $t->XML_end($context, $tag, %attrs)
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Handles the default type of <data> for those tables which aren't subclassed
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=cut
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
sub XML_end
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
my ($self, $context, $tag, %attrs) = @_;
|
|
Packit |
5d935b |
my ($dat, $addr);
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
return undef unless ($tag eq 'data');
|
|
Packit |
5d935b |
$dat = $context->{'text'};
|
|
Packit |
5d935b |
$dat =~ s/([0-9a-f]{2})\s*/hex($1)/oig;
|
|
Packit |
5d935b |
if (defined $attrs{'addr'})
|
|
Packit |
5d935b |
{ $addr = hex($attrs{'addr'}); }
|
|
Packit |
5d935b |
else
|
|
Packit |
5d935b |
{ $addr = length($self->{' dat'}); }
|
|
Packit |
5d935b |
substr($self->{' dat'}, $addr, length($dat)) = $dat;
|
|
Packit |
5d935b |
return $context;
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=head2 $t->minsize()
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Returns the minimum size this table can be. If it is smaller than this, then the table
|
|
Packit |
5d935b |
must be bad and should be deleted or whatever.
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=cut
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
sub minsize
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
return 0;
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=head2 $t->dirty($val)
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
This sets the dirty flag to the given value or 1 if no given value. It returns the
|
|
Packit |
5d935b |
value of the flag
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=cut
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
sub dirty
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
my ($self, $val) = @_;
|
|
Packit |
5d935b |
my ($res) = $self->{' isDirty'};
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
$self->{' isDirty'} = defined $val ? $val : 1;
|
|
Packit |
5d935b |
$res;
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=head2 $t->update
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Each table knows how to update itself. This consists of doing whatever work
|
|
Packit |
5d935b |
is required to ensure that the memory version of the table is consistent
|
|
Packit |
5d935b |
and that other parameters in other tables have been updated accordingly.
|
|
Packit |
5d935b |
I.e. by the end of sending C<update> to all the tables, the memory version
|
|
Packit |
5d935b |
of the font should be entirely consistent.
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Some tables which do no work indicate to themselves the need to update
|
|
Packit |
5d935b |
themselves by setting isDirty above 1. This method resets that accordingly.
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=cut
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
sub update
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
my ($self) = @_;
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
if ($self->{' isDirty'})
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
$self->read;
|
|
Packit |
5d935b |
$self->{' isDirty'} = 0;
|
|
Packit |
5d935b |
return $self;
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
else
|
|
Packit |
5d935b |
{ return undef; }
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=head2 $t->empty
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Clears a table of all data to the level of not having been read
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=cut
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
sub empty
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
my ($self) = @_;
|
|
Packit |
5d935b |
my (%keep);
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
foreach (qw(INFILE LENGTH OFFSET CSUM PARENT))
|
|
Packit |
5d935b |
{ $keep{" $_"} = 1; }
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
map {delete $self->{$_} unless $keep{$_}} keys %$self;
|
|
Packit |
5d935b |
$self;
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=head2 $t->release
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Releases ALL of the memory used by this table, and all of its component/child
|
|
Packit |
5d935b |
objects. This method is called automatically by
|
|
Packit |
5d935b |
'Font::TTF::Font-E<gt>release' (so you don't have to call it yourself).
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
B<NOTE>, that it is important that this method get called at some point prior
|
|
Packit |
5d935b |
to the actual destruction of the object. Internally, we track things in a
|
|
Packit |
5d935b |
structure that can result in circular references, and without calling
|
|
Packit |
5d935b |
'C<release()>' these will not properly get cleaned up by Perl. Once this
|
|
Packit |
5d935b |
method has been called, though, don't expect to be able to do anything with the
|
|
Packit |
5d935b |
C<Font::TTF::Table> object; it'll have B<no> internal state whatsoever.
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
B<Developer note:> As part of the brute-force cleanup done here, this method
|
|
Packit |
5d935b |
will throw a warning message whenever unexpected key values are found within
|
|
Packit |
5d935b |
the C<Font::TTF::Table> object. This is done to help ensure that any
|
|
Packit |
5d935b |
unexpected and unfreed values are brought to your attention so that you can bug
|
|
Packit |
5d935b |
us to keep the module updated properly; otherwise the potential for memory
|
|
Packit |
5d935b |
leaks due to dangling circular references will exist.
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=cut
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
sub release
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
my ($self) = @_;
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
# delete stuff that we know we can, here
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
my @tofree = map { delete $self->{$_} } keys %{$self};
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
while (my $item = shift @tofree)
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
my $ref = ref($item);
|
|
Packit |
5d935b |
if (UNIVERSAL::can($item, 'release'))
|
|
Packit |
5d935b |
{ $item->release(); }
|
|
Packit |
5d935b |
elsif ($ref eq 'ARRAY')
|
|
Packit |
5d935b |
{ push( @tofree, @{$item} ); }
|
|
Packit |
5d935b |
elsif (UNIVERSAL::isa($ref, 'HASH'))
|
|
Packit |
5d935b |
{ release($item); }
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
# check that everything has gone - it better had!
|
|
Packit |
5d935b |
foreach my $key (keys %{$self})
|
|
Packit |
5d935b |
{ warn ref($self) . " still has '$key' key left after release.\n"; }
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
sub __dumpvar__
|
|
Packit |
5d935b |
{
|
|
Packit |
5d935b |
my ($self, $key) = @_;
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
return ($key eq ' PARENT' ? '...parent...' : $self->{$key});
|
|
Packit |
5d935b |
}
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
1;
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=head1 BUGS
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
No known bugs
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=head1 AUTHOR
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Martin Hosken L<http://scripts.sil.org/FontUtils>.
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=head1 LICENSING
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
Copyright (c) 1998-2016, SIL International (http://www.sil.org)
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
This module is released under the terms of the Artistic License 2.0.
|
|
Packit |
5d935b |
For details, see the full text of the license in the file LICENSE.
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
=cut
|
|
Packit |
5d935b |
|
|
Packit |
5d935b |
|