bbdb48d3a0522e4f4d8cd92561110360af640099
[librarian.git] / font-optimizer / ext / Font-TTF / lib / Font / TTF / Table.pm
1 package Font::TTF::Table;
2
3 =head1 NAME
4
5 Font::TTF::Table - Superclass for tables and used for tables we don't have a class for
6
7 =head1 DESCRIPTION
8
9 Looks after the purely table aspects of a TTF table, such as whether the table
10 has been read before, locating the file pointer, etc. Also copies tables from
11 input to output.
12
13 =head1 INSTANCE VARIABLES
14
15 Instance variables start with a space
16
17 =over 4
18
19 =item read
20
21 Flag which indicates that the table has already been read from file.
22
23 =item dat
24
25 Allows the creation of unspecific tables. Data is simply output to any font
26 file being created.
27
28 =item INFILE
29
30 The read file handle
31
32 =item OFFSET
33
34 Location of the file in the input file
35
36 =item LENGTH
37
38 Length in the input directory
39
40 =item CSUM
41
42 Checksum read from the input file's directory
43
44 =item PARENT
45
46 The L<Font::TTF::Font> that table is part of
47
48 =back
49
50 =head1 METHODS
51
52 =cut
53
54 use strict;
55 use vars qw($VERSION);
56 use Font::TTF::Utils;
57
58 $VERSION = 0.0001;
59
60 =head2 Font::TTF::Table->new(%parms)
61
62 Creates a new table or subclass. Table instance variables are passed in
63 at this point as an associative array.
64
65 =cut
66
67 sub new
68 {
69     my ($class, %parms) = @_;
70     my ($self) = {};
71     my ($p);
72
73     $class = ref($class) || $class;
74     foreach $p (keys %parms)
75     { $self->{" $p"} = $parms{$p}; }
76     bless $self, $class;
77 }
78
79
80 =head2 $t->read
81
82 Reads the table from the input file. Acts as a superclass to all true tables.
83 This method marks the table as read and then just sets the input file pointer
84 but does not read any data. If the table has already been read, then returns
85 C<undef> else returns C<$self>
86
87 =cut
88
89 sub read
90 {
91     my ($self) = @_;
92
93     return $self->read_dat if (ref($self) eq "Font::TTF::Table");
94     return undef if $self->{' read'};
95     $self->{' INFILE'}->seek($self->{' OFFSET'}, 0);
96     $self->{' read'} = 1;
97     $self;
98 }
99
100
101 =head2 $t->read_dat
102
103 Reads the table into the C<dat> instance variable for those tables which don't
104 know any better
105
106 =cut
107
108 sub read_dat
109 {
110     my ($self) = @_;
111
112 # can't just $self->read here otherwise those tables which start their read sub with
113 # $self->read_dat are going to permanently loop
114     return undef if ($self->{' read'});
115 #    $self->{' read'} = 1;      # Let read do this, now out will call us for subclasses
116     $self->{' INFILE'}->seek($self->{' OFFSET'}, 0);
117     $self->{' INFILE'}->read($self->{' dat'}, $self->{' LENGTH'});
118     $self;
119 }
120
121 =head2 $t->out($fh)
122
123 Writes out the table to the font file. If there is anything in the
124 C<data> instance variable then this is output, otherwise the data is copied
125 from the input file to the output
126
127 =cut
128
129 sub out
130 {
131     my ($self, $fh) = @_;
132     my ($dat, $i, $len, $count);
133
134     if (defined $self->{' dat'})
135     {
136         $fh->print($self->{' dat'});
137         return $self;
138     }
139
140     return undef unless defined $self->{' INFILE'};
141     $self->{' INFILE'}->seek($self->{' OFFSET'}, 0);
142     $len = $self->{' LENGTH'};
143     while ($len > 0)
144     {
145         $count = ($len > 4096) ? 4096 : $len;
146         $self->{' INFILE'}->read($dat, $count);
147         $fh->print($dat);
148         $len -= $count;
149     }
150     $self;
151 }
152
153
154 =head2 $t->out_xml($context)
155
156 Outputs this table in XML format. The table is first read (if not already read) and then if
157 there is no subclass, then the data is dumped as hex data
158
159 =cut
160
161 sub out_xml
162 {
163     my ($self, $context, $depth) = @_;
164     my ($k);
165
166     if (ref($self) eq __PACKAGE__)
167     {
168         $self->read_dat;
169         Font::TTF::Utils::XML_hexdump($context, $depth, $self->{' dat'});
170     }
171     else
172     {
173         $self->read;
174         foreach $k (sort grep {$_ !~ m/^\s/o} keys %{$self})
175         {
176             $self->XML_element($context, $depth, $k, $self->{$k});
177         }
178     }
179     $self;
180 }
181
182
183 =head2 $t->XML_element
184
185 Output a particular element based on its contents.
186
187 =cut
188
189 sub XML_element
190 {
191     my ($self, $context, $depth, $k, $dat) = @_;
192     my ($fh) = $context->{'fh'};
193     my ($ndepth, $d);
194
195     return unless defined $dat;
196     
197     if (!ref($dat))
198     {
199         $fh->printf("%s<%s>%s</%s>\n", $depth, $k, $dat, $k);
200         return $self;
201     }
202
203     $fh->printf("%s<%s>\n", $depth, $k);
204     $ndepth = $depth . $context->{'indent'};
205
206     if (ref($dat) eq 'SCALAR')
207     { $self->XML_element($context, $ndepth, 'scalar', $$dat); }
208     elsif (ref($dat) eq 'ARRAY')
209     {
210         foreach $d (@{$dat})
211         { $self->XML_element($context, $ndepth, 'elem', $d); }
212     }
213     elsif (ref($dat) eq 'HASH')
214     {
215         foreach $d (sort grep {$_ !~ m/^\s/o} keys %{$dat})
216         { $self->XML_element($context, $ndepth, $d, $dat->{$d}); }
217     }
218     else
219     {
220         $context->{'name'} = ref($dat);
221         $context->{'name'} =~ s/^.*://o;
222         $dat->out_xml($context, $ndepth);
223     }
224
225     $fh->printf("%s</%s>\n", $depth, $k);
226     $self;
227 }
228
229
230 =head2 $t->XML_end($context, $tag, %attrs)
231
232 Handles the default type of <data> for those tables which aren't subclassed
233
234 =cut
235
236 sub XML_end
237 {
238     my ($self, $context, $tag, %attrs) = @_;
239     my ($dat, $addr);
240
241     return undef unless ($tag eq 'data');
242     $dat = $context->{'text'};
243     $dat =~ s/([0-9a-f]{2})\s*/hex($1)/oig;
244     if (defined $attrs{'addr'})
245     { $addr = hex($attrs{'addr'}); }
246     else
247     { $addr = length($self->{' dat'}); }
248     substr($self->{' dat'}, $addr, length($dat)) = $dat;
249     return $context;
250 }
251     
252
253 =head2 $t->dirty($val)
254
255 This sets the dirty flag to the given value or 1 if no given value. It returns the
256 value of the flag
257
258 =cut
259
260 sub dirty
261 {
262     my ($self, $val) = @_;
263     my ($res) = $self->{' isDirty'};
264
265     $self->{' isDirty'} = defined $val ? $val : 1;
266     $res;
267 }
268
269 =head2 $t->update
270
271 Each table knows how to update itself. This consists of doing whatever work
272 is required to ensure that the memory version of the table is consistent
273 and that other parameters in other tables have been updated accordingly.
274 I.e. by the end of sending C<update> to all the tables, the memory version
275 of the font should be entirely consistent.
276
277 Some tables which do no work indicate to themselves the need to update
278 themselves by setting isDirty above 1. This method resets that accordingly.
279
280 =cut
281
282 sub update
283 {
284     my ($self) = @_;
285
286     if ($self->{' isDirty'})
287     {
288         $self->read;
289         $self->{' isDirty'} = 0;
290         return $self;
291     }
292     else
293     { return undef; }
294 }
295
296
297 =head2 $t->empty
298
299 Clears a table of all data to the level of not having been read
300
301 =cut
302
303 sub empty
304 {
305     my ($self) = @_;
306     my (%keep);
307
308     foreach (qw(INFILE LENGTH OFFSET CSUM PARENT))
309     { $keep{" $_"} = 1; }
310
311     map {delete $self->{$_} unless $keep{$_}} keys %$self;
312     $self;
313 }
314
315
316 =head2 $t->release
317
318 Releases ALL of the memory used by this table, and all of its component/child
319 objects.  This method is called automatically by
320 'Font::TTF::Font-E<gt>release' (so you don't have to call it yourself).
321
322 B<NOTE>, that it is important that this method get called at some point prior
323 to the actual destruction of the object.  Internally, we track things in a
324 structure that can result in circular references, and without calling
325 'C<release()>' these will not properly get cleaned up by Perl.  Once this
326 method has been called, though, don't expect to be able to do anything with the
327 C<Font::TTF::Table> object; it'll have B<no> internal state whatsoever.
328
329 B<Developer note:>  As part of the brute-force cleanup done here, this method
330 will throw a warning message whenever unexpected key values are found within
331 the C<Font::TTF::Table> object.  This is done to help ensure that any
332 unexpected and unfreed values are brought to your attention so that you can bug
333 us to keep the module updated properly; otherwise the potential for memory
334 leaks due to dangling circular references will exist.
335
336 =cut
337
338 sub release
339 {
340     my ($self) = @_;
341
342 # delete stuff that we know we can, here
343
344     my @tofree = map { delete $self->{$_} } keys %{$self};
345
346     while (my $item = shift @tofree)
347     {
348         my $ref = ref($item);
349         if (UNIVERSAL::can($item, 'release'))
350         { $item->release(); }
351         elsif ($ref eq 'ARRAY')
352         { push( @tofree, @{$item} ); }
353         elsif (UNIVERSAL::isa($ref, 'HASH'))
354         { release($item); }
355     }
356
357 # check that everything has gone - it better had!
358     foreach my $key (keys %{$self})
359     { warn ref($self) . " still has '$key' key left after release.\n"; }
360 }
361
362
363 sub __dumpvar__
364 {
365     my ($self, $key) = @_;
366
367     return ($key eq ' PARENT' ? '...parent...' : $self->{$key});
368 }
369
370 1;
371
372 =head1 BUGS
373
374 No known bugs
375
376 =head1 AUTHOR
377
378 Martin Hosken Martin_Hosken@sil.org. See L<Font::TTF::Font> for copyright and
379 licensing.
380
381 =cut
382