src/librarian/font-optimizer/ext/Font-TTF/lib/Font/TTF/Segarr.pm

   1 package Font::TTF::Segarr;
   2
   3 =head1 NAME
   4
   5 Font::TTF::Segarr - Segmented array
   6
   7 =head1 DESCRIPTION
   8
   9 Holds data either directly or indirectly as a series of arrays. This class
  10 looks after the set of arrays and masks the individual sub-arrays, thus saving
  11 a class, we hope.
  12
  13 =head1 INSTANCE VARIABLES
  14
  15 All instance variables do not start with a space.
  16
  17 The segmented array is simply an array of segments
  18
  19 Each segment is a more complex affair:
  20
  21 =over 4
  22
  23 =item START
  24
  25 In terms of the array, the address for the 0th element in this segment.
  26
  27 =item LEN
  28
  29 Number of elements in this segment
  30
  31 =item VAL
  32
  33 The array which contains the elements
  34
  35 =back
  36
  37 =head1 METHODS
  38
  39 =cut
  40
  41 use strict;
  42 use vars qw(@types $VERSION);
  43 $VERSION = 0.0001;
  44
  45 @types = ('', 'C', 'n', '', 'N');
  46
  47 =head2 Font::TTF::Segarr->new($size)
  48
  49 Creates a new segmented array with a given data size
  50
  51 =cut
  52
  53 sub new
  54 {
  55     my ($class) = @_;
  56     my ($self) = [];
  57
  58     bless $self, (ref($class) || $class);
  59 }
  60
  61
  62 =head2 $s->fastadd_segment($start, $is_sparse, @dat)
  63
  64 Creates a new segment and adds it to the array assuming no overlap between
  65 the new segment and any others in the array. $is_sparse indicates whether the
  66 passed in array contains C<undef>s or not. If false no checking is done (which
  67 is faster, but riskier). If equal to 2 then 0 is considered undef as well.
  68
  69 Returns the number of segments inserted.
  70
  71 =cut
  72
  73 sub fastadd_segment
  74 {
  75     my ($self) = shift;
  76     my ($start) = shift;
  77     my ($sparse) = shift;
  78     my ($p, $i, $seg, @seg);
  79
  80
  81     if ($sparse)
  82     {
  83         for ($i = 0; $i <= $#_; $i++)
  84         {
  85             if (!defined $seg && (($sparse != 2 && defined $_[$i]) || $_[$i] != 0))
  86             { $seg->{'START'} = $start + $i; $seg->{'VAL'} = []; }
  87
  88             if (defined $seg && (($sparse == 2 && $_[$i] == 0) || !defined $_[$i]))
  89             {
  90                 $seg->{'LEN'} = $start + $i - $seg->{'START'};
  91                 push(@seg, $seg);
  92                 $seg = undef;
  93             } elsif (defined $seg)
  94             { push (@{$seg->{'VAL'}}, $_[$i]); }
  95         }
  96         if (defined $seg)
  97         {
  98             push(@seg, $seg);
  99             $seg->{'LEN'} = $start + $i - $seg->{'START'};
 100         }
 101     } else
 102     {
 103         $seg->{'START'} = $start;
 104         $seg->{'LEN'} = $#_ + 1;
 105         $seg->{'VAL'} = [@_];
 106         @seg = ($seg);
 107     }
 108
 109     for ($i = 0; $i <= $#$self; $i++)
 110     {
 111         if ($self->[$i]{'START'} > $start)
 112         {
 113             splice(@$self, $i, 0, @seg);
 114             return wantarray ? @seg : scalar(@seg);
 115         }
 116     }
 117     push(@$self, @seg);
 118     return wantarray ? @seg : scalar(@seg);
 119 }
 120
 121
 122 =head2 $s->add_segment($start, $overwrite, @dat)
 123
 124 Creates a new segment and adds it to the array allowing for possible overlaps
 125 between the new segment and the existing ones. In the case of overlaps, elements
 126 from the new segment are deleted unless $overwrite is set in which case the
 127 elements already there are over-written.
 128
 129 This method also checks the data coming in to see if it is sparse (i.e. contains
 130 undef values). Gaps cause new segments to be created or not to over-write existing
 131 values.
 132
 133 =cut
 134
 135 sub add_segment
 136 {
 137     my ($self) = shift;
 138     my ($start) = shift;
 139     my ($over) = shift;
 140     my ($seg, $i, $s, $offset, $j, $newi);
 141
 142     return $self->fastadd_segment($start, $over, @_) if ($#$self < 0);
 143     $offset = 0;
 144     for ($i = 0; $i <= $#$self && $offset <= $#_; $i++)
 145     {
 146         $s = $self->[$i];
 147         if ($s->{'START'} <= $start + $offset)              # only < for $offset == 0
 148         {
 149             if ($s->{'START'} + $s->{'LEN'} > $start + $#_)
 150             {
 151                 for ($j = $offset; $j <= $#_; $j++)
 152                 {
 153                     if ($over)
 154                     { $s->{'VAL'}[$start - $s->{'START'} + $j] = $_[$j] if defined $_[$j]; }
 155                     else
 156                     { $s->{'VAL'}[$start - $s->{'START'} + $j] ||= $_[$j] if defined $_[$j]; }
 157                 }
 158                 $offset = $#_ + 1;
 159                 last;
 160             } elsif ($s->{'START'} + $s->{'LEN'} > $start + $offset)        # is $offset needed here?
 161             {
 162                 for ($j = $offset; $j < $s->{'START'} + $s->{'LEN'} - $start; $j++)
 163                 {
 164                     if ($over)
 165                     { $s->{'VAL'}[$start - $s->{'START'} + $j] = $_[$j] if defined $_[$j]; }
 166                     else
 167                     { $s->{'VAL'}[$start - $s->{'START'} + $j] ||= $_[$j] if defined $_[$j]; }
 168                 }
 169                 $offset = $s->{'START'} + $s->{'LEN'} - $start;
 170             }
 171         } else                                              # new seg please
 172         {
 173             if ($s->{'START'} > $start + $#_ + 1)
 174             {
 175                 $i += $self->fastadd_segment($start + $offset, 1, @_[$offset .. $#_]) - 1;
 176                 $offset = $#_ + 1;
 177             }
 178             else
 179             {
 180                 $i += $self->fastadd_segment($start + $offset, 1, @_[$offset .. $s->{'START'} - $start]) - 1;
 181                 $offset = $s->{'START'} - $start + 1;
 182             }
 183         }
 184     }
 185     if ($offset <= $#_)
 186     {
 187         $seg->{'START'} = $start + $offset;
 188         $seg->{'LEN'} = $#_ - $offset + 1;
 189         $seg->{'VAL'} = [@_[$offset .. $#_]];
 190         push (@$self, $seg);
 191     }
 192     $self->tidy;
 193 }
 194
 195
 196 =head2 $s->tidy
 197
 198 Merges any immediately adjacent segments
 199
 200 =cut
 201
 202 sub tidy
 203 {
 204     my ($self) = @_;
 205     my ($i, $sl, $s);
 206
 207     for ($i = 1; $i <= $#$self; $i++)
 208     {
 209         $sl = $self->[$i - 1];
 210         $s = $self->[$i];
 211         if ($s->{'START'} == $sl->{'START'} + $sl->{'LEN'})
 212         {
 213             $sl->{'LEN'} += $s->{'LEN'};
 214             push (@{$sl->{'VAL'}}, @{$s->{'VAL'}});
 215             splice(@$self, $i, 1);
 216             $i--;
 217         }
 218     }
 219     $self;
 220 }
 221
 222
 223 =head2 $s->at($addr, [$len])
 224
 225 Looks up the data held at the given address by locating the appropriate segment
 226 etc. If $len > 1 then returns an array of values, spaces being filled with undef.
 227
 228 =cut
 229
 230 sub at
 231 {
 232     my ($self, $addr, $len) = @_;
 233     my ($i, $dat, $s, @res, $offset);
 234
 235     $len = 1 unless defined $len;
 236     $offset = 0;
 237     for ($i = 0; $i <= $#$self; $i++)
 238     {
 239         $s = $self->[$i];
 240         next if ($s->{'START'} + $s->{'LEN'} < $addr + $offset);        # only fires on $offset == 0
 241         if ($s->{'START'} > $addr + $offset)
 242         {
 243             push (@res, (undef) x ($s->{'START'} > $addr + $len ?
 244                     $len - $offset : $s->{'START'} - $addr - $offset));
 245             $offset = $s->{'START'} - $addr;
 246         }
 247         last if ($s->{'START'} >= $addr + $len);
 248
 249         if ($s->{'START'} + $s->{'LEN'} >= $addr + $len)
 250         {
 251             push (@res, @{$s->{'VAL'}}[$addr + $offset - $s->{'START'} ..
 252                     $addr + $len - $s->{'START'} - 1]);
 253             $offset = $len;
 254             last;
 255         } else
 256         {
 257             push (@res, @{$s->{'VAL'}}[$addr + $offset - $s->{'START'} .. $s->{'LEN'} - 1]);
 258             $offset = $s->{'START'} + $s->{'LEN'} - $addr;
 259         }
 260     }
 261     push (@res, (undef) x ($len - $offset)) if ($offset < $len);
 262     return wantarray ? @res : $res[0];
 263 }
 264
 265
 266 =head2 $s->remove($addr, [$len])
 267
 268 Removes the item or items from addr returning them as an array or the first
 269 value in a scalar context. This is very like C<at>, including padding with
 270 undef, but it deletes stuff as it goes.
 271
 272 =cut
 273
 274 sub remove
 275 {
 276     my ($self, $addr, $len) = @_;
 277     my ($i, $dat, $s, @res, $offset);
 278
 279     $len = 1 unless defined $len;
 280     $offset = 0;
 281     for ($i = 0; $i <= $#$self; $i++)
 282     {
 283         $s = $self->[$i];
 284         next if ($s->{'START'} + $s->{'LEN'} < $addr + $offset);
 285         if ($s->{'START'} > $addr + $offset)
 286         {
 287             push (@res, (undef) x ($s->{'START'} > $addr + $len ?
 288                     $len - $offset : $s->{'START'} - $addr - $offset));
 289             $offset = $s->{'START'} - $addr;
 290         }
 291         last if ($s->{'START'} >= $addr + $len);
 292
 293         unless ($s->{'START'} == $addr + $offset)
 294         {
 295             my ($seg) = {};
 296
 297             $seg->{'START'} = $s->{'START'};
 298             $seg->{'LEN'} = $addr + $offset - $s->{'START'};
 299             $seg->{'VAL'} = [splice(@{$s->{'VAL'}}, 0, $addr + $offset - $s->{'START'})];
 300             $s->{'LEN'} -= $addr + $offset - $s->{'START'};
 301             $s->{'START'} = $addr + $offset;
 302
 303             splice(@$self, $i, 0, $seg);
 304             $i++;
 305         }
 306
 307         if ($s->{'START'} + $s->{'LEN'} >= $addr + $len)
 308         {
 309             push (@res, splice(@{$s->{'VAL'}}, 0, $len - $offset));
 310             $s->{'LEN'} -= $len - $offset;
 311             $s->{'START'} += $len - $offset;
 312             $offset = $len;
 313             last;
 314         } else
 315         {
 316             push (@res, @{$s->{'VAL'}});
 317             $offset = $s->{'START'} + $s->{'LEN'} - $addr;
 318             splice(@$self, $i, 0);
 319             $i--;
 320         }
 321     }
 322     push (@res, (undef) x ($len - $offset)) if ($offset < $len);
 323     return wantarray ? @res : $res[0];
 324 }
 325
 326
 327 =head2 $s->copy
 328
 329 Deep copies this array
 330
 331 =cut
 332
 333 sub copy
 334 {
 335     my ($self) = @_;
 336     my ($res, $p);
 337
 338     $res = [];
 339     foreach $p (@$self)
 340     { push (@$res, $self->copy_seg($p)); }
 341     $res;
 342 }
 343
 344
 345 =head2 $s->copy_seg($seg)
 346
 347 Creates a deep copy of a segment
 348
 349 =cut
 350
 351 sub copy_seg
 352 {
 353     my ($self, $seg) = @_;
 354     my ($p, $res);
 355
 356     $res = {};
 357     $res->{'VAL'} = [@{$seg->{'VAL'}}];
 358     foreach $p (keys %$seg)
 359     { $res->{$p} = $seg->{$p} unless defined $res->{$p}; }
 360     $res;
 361 }
 362
 363
 364 1;
 365
 366 =head1 BUGS
 367
 368 No known bugs.
 369
 370 =head1 AUTHOR
 371
 372 Martin Hosken Martin_Hosken@sil.org. See L<Font::TTF::Font> for copyright and
 373 licensing.
 374
 375 =cut
 376