386 lines
9.5 KiB
Perl
386 lines
9.5 KiB
Perl
package Font::TTF::Segarr;
|
|
|
|
=head1 NAME
|
|
|
|
Font::TTF::Segarr - Segmented array
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Holds data either directly or indirectly as a series of arrays. This class
|
|
looks after the set of arrays and masks the individual sub-arrays, thus saving
|
|
a class, we hope.
|
|
|
|
=head1 INSTANCE VARIABLES
|
|
|
|
All instance variables do not start with a space.
|
|
|
|
The segmented array is simply an array of segments
|
|
|
|
Each segment is a more complex affair:
|
|
|
|
=over 4
|
|
|
|
=item START
|
|
|
|
In terms of the array, the address for the 0th element in this segment.
|
|
|
|
=item LEN
|
|
|
|
Number of elements in this segment
|
|
|
|
=item VAL
|
|
|
|
The array which contains the elements
|
|
|
|
=back
|
|
|
|
=head1 METHODS
|
|
|
|
=cut
|
|
|
|
use strict;
|
|
use vars qw(@types $VERSION);
|
|
$VERSION = 0.0001;
|
|
|
|
@types = ('', 'C', 'n', '', 'N');
|
|
|
|
=head2 Font::TTF::Segarr->new($size)
|
|
|
|
Creates a new segmented array with a given data size
|
|
|
|
=cut
|
|
|
|
sub new
|
|
{
|
|
my ($class) = @_;
|
|
my ($self) = [];
|
|
|
|
bless $self, (ref($class) || $class);
|
|
}
|
|
|
|
|
|
=head2 $s->fastadd_segment($start, $is_sparse, @dat)
|
|
|
|
Creates a new segment and adds it to the array assuming no overlap between
|
|
the new segment and any others in the array. $is_sparse indicates whether the
|
|
passed in array contains C<undef>s or not. If false no checking is done (which
|
|
is faster, but riskier). If equal to 2 then 0 is considered undef as well.
|
|
|
|
Returns the number of segments inserted.
|
|
|
|
=cut
|
|
|
|
sub fastadd_segment
|
|
{
|
|
my ($self) = shift;
|
|
my ($start) = shift;
|
|
my ($sparse) = shift;
|
|
my ($p, $i, $seg, @seg);
|
|
|
|
|
|
if ($sparse)
|
|
{
|
|
for ($i = 0; $i <= $#_; $i++)
|
|
{
|
|
if (!defined $seg && (($sparse != 2 && defined $_[$i]) || $_[$i] != 0))
|
|
{ $seg->{'START'} = $start + $i; $seg->{'VAL'} = []; }
|
|
|
|
if (defined $seg && (($sparse == 2 && $_[$i] == 0) || !defined $_[$i]))
|
|
{
|
|
$seg->{'LEN'} = $start + $i - $seg->{'START'};
|
|
push(@seg, $seg);
|
|
$seg = undef;
|
|
} elsif (defined $seg)
|
|
{ push (@{$seg->{'VAL'}}, $_[$i]); }
|
|
}
|
|
if (defined $seg)
|
|
{
|
|
push(@seg, $seg);
|
|
$seg->{'LEN'} = $start + $i - $seg->{'START'};
|
|
}
|
|
} else
|
|
{
|
|
$seg->{'START'} = $start;
|
|
$seg->{'LEN'} = $#_ + 1;
|
|
$seg->{'VAL'} = [@_];
|
|
@seg = ($seg);
|
|
}
|
|
|
|
for ($i = 0; $i <= $#$self; $i++)
|
|
{
|
|
if ($self->[$i]{'START'} > $start)
|
|
{
|
|
splice(@$self, $i, 0, @seg);
|
|
return wantarray ? @seg : scalar(@seg);
|
|
}
|
|
}
|
|
push(@$self, @seg);
|
|
return wantarray ? @seg : scalar(@seg);
|
|
}
|
|
|
|
|
|
=head2 $s->add_segment($start, $overwrite, @dat)
|
|
|
|
Creates a new segment and adds it to the array allowing for possible overlaps
|
|
between the new segment and the existing ones. In the case of overlaps, elements
|
|
from the new segment are deleted unless $overwrite is set in which case the
|
|
elements already there are over-written.
|
|
|
|
This method also checks the data coming in to see if it is sparse (i.e. contains
|
|
undef values). Gaps cause new segments to be created or not to over-write existing
|
|
values.
|
|
|
|
=cut
|
|
|
|
sub add_segment
|
|
{
|
|
my ($self) = shift;
|
|
my ($start) = shift;
|
|
my ($over) = shift;
|
|
my ($seg, $i, $s, $offset, $j, $newi);
|
|
|
|
return $self->fastadd_segment($start, $over, @_) if ($#$self < 0);
|
|
$offset = 0;
|
|
for ($i = 0; $i <= $#$self && $offset <= $#_; $i++)
|
|
{
|
|
$s = $self->[$i];
|
|
if ($s->{'START'} <= $start + $offset) # only < for $offset == 0
|
|
{
|
|
if ($s->{'START'} + $s->{'LEN'} > $start + $#_)
|
|
{
|
|
for ($j = $offset; $j <= $#_; $j++)
|
|
{
|
|
if ($over)
|
|
{ $s->{'VAL'}[$start - $s->{'START'} + $j] = $_[$j] if defined $_[$j]; }
|
|
else
|
|
{ $s->{'VAL'}[$start - $s->{'START'} + $j] ||= $_[$j] if defined $_[$j]; }
|
|
}
|
|
$offset = $#_ + 1;
|
|
last;
|
|
} elsif ($s->{'START'} + $s->{'LEN'} > $start + $offset) # is $offset needed here?
|
|
{
|
|
for ($j = $offset; $j < $s->{'START'} + $s->{'LEN'} - $start; $j++)
|
|
{
|
|
if ($over)
|
|
{ $s->{'VAL'}[$start - $s->{'START'} + $j] = $_[$j] if defined $_[$j]; }
|
|
else
|
|
{ $s->{'VAL'}[$start - $s->{'START'} + $j] ||= $_[$j] if defined $_[$j]; }
|
|
}
|
|
$offset = $s->{'START'} + $s->{'LEN'} - $start;
|
|
}
|
|
} else # new seg please
|
|
{
|
|
if ($s->{'START'} > $start + $#_ + 1)
|
|
{
|
|
$i += $self->fastadd_segment($start + $offset, 1, @_[$offset .. $#_]) - 1;
|
|
$offset = $#_ + 1;
|
|
}
|
|
else
|
|
{
|
|
$i += $self->fastadd_segment($start + $offset, 1, @_[$offset .. $s->{'START'} - $start]) - 1;
|
|
$offset = $s->{'START'} - $start + 1;
|
|
}
|
|
}
|
|
}
|
|
if ($offset <= $#_)
|
|
{
|
|
$seg->{'START'} = $start + $offset;
|
|
$seg->{'LEN'} = $#_ - $offset + 1;
|
|
$seg->{'VAL'} = [@_[$offset .. $#_]];
|
|
push (@$self, $seg);
|
|
}
|
|
$self->tidy;
|
|
}
|
|
|
|
|
|
=head2 $s->tidy
|
|
|
|
Merges any immediately adjacent segments
|
|
|
|
=cut
|
|
|
|
sub tidy
|
|
{
|
|
my ($self) = @_;
|
|
my ($i, $sl, $s);
|
|
|
|
for ($i = 1; $i <= $#$self; $i++)
|
|
{
|
|
$sl = $self->[$i - 1];
|
|
$s = $self->[$i];
|
|
if ($s->{'START'} == $sl->{'START'} + $sl->{'LEN'})
|
|
{
|
|
$sl->{'LEN'} += $s->{'LEN'};
|
|
push (@{$sl->{'VAL'}}, @{$s->{'VAL'}});
|
|
splice(@$self, $i, 1);
|
|
$i--;
|
|
}
|
|
}
|
|
$self;
|
|
}
|
|
|
|
|
|
=head2 $s->at($addr, [$len])
|
|
|
|
Looks up the data held at the given address by locating the appropriate segment
|
|
etc. If $len > 1 then returns an array of values, spaces being filled with undef.
|
|
|
|
=cut
|
|
|
|
sub at
|
|
{
|
|
my ($self, $addr, $len) = @_;
|
|
my ($i, $dat, $s, @res, $offset);
|
|
|
|
$len = 1 unless defined $len;
|
|
$offset = 0;
|
|
for ($i = 0; $i <= $#$self; $i++)
|
|
{
|
|
$s = $self->[$i];
|
|
next if ($s->{'START'} + $s->{'LEN'} < $addr + $offset); # only fires on $offset == 0
|
|
if ($s->{'START'} > $addr + $offset)
|
|
{
|
|
push (@res, (undef) x ($s->{'START'} > $addr + $len ?
|
|
$len - $offset : $s->{'START'} - $addr - $offset));
|
|
$offset = $s->{'START'} - $addr;
|
|
}
|
|
last if ($s->{'START'} >= $addr + $len);
|
|
|
|
if ($s->{'START'} + $s->{'LEN'} >= $addr + $len)
|
|
{
|
|
push (@res, @{$s->{'VAL'}}[$addr + $offset - $s->{'START'} ..
|
|
$addr + $len - $s->{'START'} - 1]);
|
|
$offset = $len;
|
|
last;
|
|
} else
|
|
{
|
|
push (@res, @{$s->{'VAL'}}[$addr + $offset - $s->{'START'} .. $s->{'LEN'} - 1]);
|
|
$offset = $s->{'START'} + $s->{'LEN'} - $addr;
|
|
}
|
|
}
|
|
push (@res, (undef) x ($len - $offset)) if ($offset < $len);
|
|
return wantarray ? @res : $res[0];
|
|
}
|
|
|
|
|
|
=head2 $s->remove($addr, [$len])
|
|
|
|
Removes the item or items from addr returning them as an array or the first
|
|
value in a scalar context. This is very like C<at>, including padding with
|
|
undef, but it deletes stuff as it goes.
|
|
|
|
=cut
|
|
|
|
sub remove
|
|
{
|
|
my ($self, $addr, $len) = @_;
|
|
my ($i, $dat, $s, @res, $offset);
|
|
|
|
$len = 1 unless defined $len;
|
|
$offset = 0;
|
|
for ($i = 0; $i <= $#$self; $i++)
|
|
{
|
|
$s = $self->[$i];
|
|
next if ($s->{'START'} + $s->{'LEN'} < $addr + $offset);
|
|
if ($s->{'START'} > $addr + $offset)
|
|
{
|
|
push (@res, (undef) x ($s->{'START'} > $addr + $len ?
|
|
$len - $offset : $s->{'START'} - $addr - $offset));
|
|
$offset = $s->{'START'} - $addr;
|
|
}
|
|
last if ($s->{'START'} >= $addr + $len);
|
|
|
|
unless ($s->{'START'} == $addr + $offset)
|
|
{
|
|
my ($seg) = {};
|
|
|
|
$seg->{'START'} = $s->{'START'};
|
|
$seg->{'LEN'} = $addr + $offset - $s->{'START'};
|
|
$seg->{'VAL'} = [splice(@{$s->{'VAL'}}, 0, $addr + $offset - $s->{'START'})];
|
|
$s->{'LEN'} -= $addr + $offset - $s->{'START'};
|
|
$s->{'START'} = $addr + $offset;
|
|
|
|
splice(@$self, $i, 0, $seg);
|
|
$i++;
|
|
}
|
|
|
|
if ($s->{'START'} + $s->{'LEN'} >= $addr + $len)
|
|
{
|
|
push (@res, splice(@{$s->{'VAL'}}, 0, $len - $offset));
|
|
$s->{'LEN'} -= $len - $offset;
|
|
$s->{'START'} += $len - $offset;
|
|
$offset = $len;
|
|
last;
|
|
} else
|
|
{
|
|
push (@res, @{$s->{'VAL'}});
|
|
$offset = $s->{'START'} + $s->{'LEN'} - $addr;
|
|
splice(@$self, $i, 0);
|
|
$i--;
|
|
}
|
|
}
|
|
push (@res, (undef) x ($len - $offset)) if ($offset < $len);
|
|
return wantarray ? @res : $res[0];
|
|
}
|
|
|
|
|
|
=head2 $s->copy
|
|
|
|
Deep copies this array
|
|
|
|
=cut
|
|
|
|
sub copy
|
|
{
|
|
my ($self) = @_;
|
|
my ($res, $p);
|
|
|
|
$res = [];
|
|
foreach $p (@$self)
|
|
{ push (@$res, $self->copy_seg($p)); }
|
|
$res;
|
|
}
|
|
|
|
|
|
=head2 $s->copy_seg($seg)
|
|
|
|
Creates a deep copy of a segment
|
|
|
|
=cut
|
|
|
|
sub copy_seg
|
|
{
|
|
my ($self, $seg) = @_;
|
|
my ($p, $res);
|
|
|
|
$res = {};
|
|
$res->{'VAL'} = [@{$seg->{'VAL'}}];
|
|
foreach $p (keys %$seg)
|
|
{ $res->{$p} = $seg->{$p} unless defined $res->{$p}; }
|
|
$res;
|
|
}
|
|
|
|
|
|
1;
|
|
|
|
=head1 BUGS
|
|
|
|
No known bugs.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Martin Hosken L<http://scripts.sil.org/FontUtils>.
|
|
|
|
|
|
=head1 LICENSING
|
|
|
|
Copyright (c) 1998-2016, SIL International (http://www.sil.org)
|
|
|
|
This module is released under the terms of the Artistic License 2.0.
|
|
For details, see the full text of the license in the file LICENSE.
|
|
|
|
|
|
|
|
=cut
|
|
|