980188d9569b422227c3e0df5ec8fe58144f322d
[librarian.git] / 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