File Coverage

blib/lib/Font/TTF/Table.pm
Criterion Covered Total %
statement 52 146 35.6
branch 14 58 24.1
condition 5 12 41.6
subroutine 8 17 47.0
pod 12 12 100.0
total 91 245 37.1


line stmt bran cond sub pod time code
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 nocompress
29              
30             If set, overrides the font default for WOFF table compression. Is a scalar integer specifying a
31             table size threshold below which this table will not be compressed. Set to -1 to never
32             compress; 0 to always compress.
33              
34             =item INFILE
35              
36             The read file handle
37              
38             =item OFFSET
39              
40             Location of the file in the input file
41              
42             =item LENGTH
43              
44             Length in the input directory
45              
46             =item ZLENGTH
47              
48             Compressed length of the table if a WOFF font. 0 < ZLENGTH < LENGTH implies table is compressed.
49              
50             =item CSUM
51              
52             Checksum read from the input file's directory
53              
54             =item PARENT
55              
56             The L that table is part of
57              
58             =back
59              
60             =head1 METHODS
61              
62             =cut
63              
64 1     1   4 use strict;
  1         1  
  1         30  
65 1     1   4 use vars qw($VERSION);
  1         0  
  1         29  
66 1     1   370 use Font::TTF::Utils;
  1         3  
  1         91  
67 1     1   505 use IO::String;
  1         1736  
  1         1195  
68             $VERSION = 0.0001;
69              
70             my $havezlib = eval {require Compress::Zlib};
71              
72             =head2 Font::TTF::Table->new(%parms)
73              
74             Creates a new table or subclass. Table instance variables are passed in
75             at this point as an associative array.
76              
77             =cut
78              
79             sub new
80             {
81 29     29 1 149 my ($class, %parms) = @_;
82 29         44 my ($self) = {};
83 29         60 my ($p);
84              
85 29   33     105 $class = ref($class) || $class;
86 29         82 foreach $p (keys %parms)
87 197         328 { $self->{" $p"} = $parms{$p}; }
88 29         223 bless $self, $class;
89             }
90              
91             =head2 $t->read
92              
93             Reads the table from the input file. Acts as a superclass to all true tables.
94             This method marks the table as read and then just sets the input file pointer
95             but does not read any data. If the table has already been read, then returns
96             C else returns C<$self>
97              
98             For WOFF-compressed tables, the table is first decompressed and a
99             replacement file handle is created for reading the decompressed data. In this
100             case ORIGINALOFFSET will preserve the original value of OFFSET for
101             applications that care.
102              
103             =cut
104              
105             sub read
106             {
107 34     34 1 46 my ($self) = @_;
108              
109 34 100       102 return $self->read_dat if (ref($self) eq "Font::TTF::Table");
110 32 100       141 return undef if $self->{' read'};
111 20         120 $self->{' INFILE'}->seek($self->{' OFFSET'}, 0);
112 20 100 66     234 if (0 < $self->{' ZLENGTH'} && $self->{' ZLENGTH'} < $self->{' LENGTH'})
113             {
114             # WOFF table is compressed. Uncompress it to memory and create new fh
115 8 50       27 die ("Cannot uncompress WOFF data: Compress::Zlib not present.\n") unless $havezlib;
116 8         39 $self->{' ORIGINALOFFSET'} = $self->{' OFFSET'}; # Preserve this for those who care
117 8         13 my $dat;
118 8         37 $self->{' INFILE'}->read($dat, $self->{' ZLENGTH'});
119 8         168 $dat = Compress::Zlib::uncompress($dat);
120 8 50       1143 warn "$self->{' NAME'} table decompressed to wrong length" if $self->{' LENGTH'} != bytes::length($dat);
121 8         89 $self->{' INFILE'} = IO::String->new($dat);
122 8         533 binmode $self->{' INFILE'};
123 8         55 $self->{' OFFSET'} = 0;
124             }
125 20         44 $self->{' read'} = 1;
126 20         73 $self;
127             }
128              
129              
130             =head2 $t->read_dat
131              
132             Reads the table into the C instance variable for those tables which don't
133             know any better
134              
135             =cut
136              
137             sub read_dat
138             {
139 8     8 1 11 my ($self) = @_;
140              
141             # can't just $self->read here otherwise those tables which start their read sub with
142             # $self->read_dat are going to permanently loop
143 8 50       32 return undef if ($self->{' read'});
144             # $self->{' read'} = 1; # Let read do this, now out will call us for subclasses
145 8         35 $self->{' INFILE'}->seek($self->{' OFFSET'}, 0);
146 8 100 66     83 if (0 < $self->{' ZLENGTH'} && $self->{' ZLENGTH'} < $self->{' LENGTH'})
147             {
148             # WOFF table is compressed. Uncompress it directly to ' dat'
149 2 50       9 die ("Cannot uncompress WOFF data: Compress::Zlib not present.\n") unless $havezlib;
150 2         4 my $dat;
151 2         10 $self->{' INFILE'}->read($dat, $self->{' ZLENGTH'});
152 2         26 $dat = Compress::Zlib::uncompress($dat);
153 2 50       98 warn "$self->{' NAME'} table decompressed to wrong length" if $self->{' LENGTH'} != bytes::length($dat);
154 2         16 $self->{' dat'} = $dat;
155             }
156             else
157             {
158 6         26 $self->{' INFILE'}->read($self->{' dat'}, $self->{' LENGTH'});
159             }
160 8         106 $self;
161             }
162              
163             =head2 $t->out($fh)
164              
165             Writes out the table to the font file. If there is anything in the
166             C instance variable then this is output, otherwise the data is copied
167             from the input file to the output
168              
169             =cut
170              
171             sub out
172             {
173 8     8 1 14 my ($self, $fh) = @_;
174 8         10 my ($dat, $i, $len, $count);
175              
176 8 50       29 if (defined $self->{' dat'})
177             {
178 8         25 $fh->print($self->{' dat'});
179 8         51 return $self;
180             }
181              
182 0 0         return undef unless defined $self->{' INFILE'};
183            
184 0 0 0       if (0 < $self->{' ZLENGTH'} && $self->{' ZLENGTH'} < $self->{' LENGTH'})
185             {
186             # WOFF table is compressed. Have to uncompress first
187 0           $self->read_dat;
188 0           $fh->print($self->{' dat'});
189 0           return $self;
190             }
191              
192             # We don't really have to keep the following code... we could have
193             # just always done a full read_dat() on the table. But the following
194             # is more memory-friendly so I've kept it for the more common case
195             # of non-compressed tables.
196              
197 0           $self->{' INFILE'}->seek($self->{' OFFSET'}, 0);
198 0           $len = $self->{' LENGTH'};
199 0           while ($len > 0)
200             {
201 0 0         $count = ($len > 4096) ? 4096 : $len;
202 0           $self->{' INFILE'}->read($dat, $count);
203 0           $fh->print($dat);
204 0           $len -= $count;
205             }
206 0           $self;
207             }
208              
209              
210             =head2 $t->out_xml($context)
211              
212             Outputs this table in XML format. The table is first read (if not already read) and then if
213             there is no subclass, then the data is dumped as hex data
214              
215             =cut
216              
217             sub out_xml
218             {
219 0     0 1   my ($self, $context, $depth) = @_;
220 0           my ($k);
221              
222 0 0         if (ref($self) eq __PACKAGE__)
223             {
224 0           $self->read_dat;
225 0           Font::TTF::Utils::XML_hexdump($context, $depth, $self->{' dat'});
226             }
227             else
228             {
229 0           $self->read;
230 0           foreach $k (sort grep {$_ !~ m/^\s/o} keys %{$self})
  0            
  0            
231             {
232 0           $self->XML_element($context, $depth, $k, $self->{$k});
233             }
234             }
235 0           $self;
236             }
237              
238              
239             =head2 $t->XML_element
240              
241             Output a particular element based on its contents.
242              
243             =cut
244              
245             sub XML_element
246             {
247 0     0 1   my ($self, $context, $depth, $k, $dat, $ind) = @_;
248 0           my ($fh) = $context->{'fh'};
249 0           my ($ndepth, $d);
250              
251 0 0         return unless defined $dat;
252            
253 0 0         if (!ref($dat))
254             {
255 0           $fh->printf("%s<%s>%s\n", $depth, $k, $dat, $k);
256 0           return $self;
257             }
258              
259 0 0         if ($ind)
260 0           { $fh->printf("%s<%s i='%d'>\n", $depth, $k, $ind); }
261             else
262 0           { $fh->printf("%s<%s>\n", $depth, $k); }
263 0           $ndepth = $depth . $context->{'indent'};
264              
265 0 0         if (ref($dat) eq 'SCALAR')
    0          
    0          
266 0           { $self->XML_element($context, $ndepth, 'scalar', $$dat); }
267             elsif (ref($dat) eq 'ARRAY')
268             {
269 0           my ($c) = 1;
270 0           foreach $d (@{$dat})
  0            
271 0           { $self->XML_element($context, $ndepth, 'elem', $d, $c++); }
272             }
273             elsif (ref($dat) eq 'HASH')
274             {
275 0           foreach $d (sort grep {$_ !~ m/^\s/o} keys %{$dat})
  0            
  0            
276 0           { $self->XML_element($context, $ndepth, $d, $dat->{$d}); }
277             }
278             else
279             {
280 0           $context->{'name'} = ref($dat);
281 0           $context->{'name'} =~ s/^.*://o;
282 0           $dat->out_xml($context, $ndepth);
283             }
284              
285 0           $fh->printf("%s\n", $depth, $k);
286 0           $self;
287             }
288              
289              
290             =head2 $t->XML_end($context, $tag, %attrs)
291              
292             Handles the default type of for those tables which aren't subclassed
293              
294             =cut
295              
296             sub XML_end
297             {
298 0     0 1   my ($self, $context, $tag, %attrs) = @_;
299 0           my ($dat, $addr);
300              
301 0 0         return undef unless ($tag eq 'data');
302 0           $dat = $context->{'text'};
303 0           $dat =~ s/([0-9a-f]{2})\s*/hex($1)/oig;
304 0 0         if (defined $attrs{'addr'})
305 0           { $addr = hex($attrs{'addr'}); }
306             else
307 0           { $addr = length($self->{' dat'}); }
308 0           substr($self->{' dat'}, $addr, length($dat)) = $dat;
309 0           return $context;
310             }
311            
312              
313             =head2 $t->minsize()
314              
315             Returns the minimum size this table can be. If it is smaller than this, then the table
316             must be bad and should be deleted or whatever.
317              
318             =cut
319              
320             sub minsize
321             {
322 0     0 1   return 0;
323             }
324              
325             =head2 $t->dirty($val)
326              
327             This sets the dirty flag to the given value or 1 if no given value. It returns the
328             value of the flag
329              
330             =cut
331              
332             sub dirty
333             {
334 0     0 1   my ($self, $val) = @_;
335 0           my ($res) = $self->{' isDirty'};
336              
337 0 0         $self->{' isDirty'} = defined $val ? $val : 1;
338 0           $res;
339             }
340              
341             =head2 $t->update
342              
343             Each table knows how to update itself. This consists of doing whatever work
344             is required to ensure that the memory version of the table is consistent
345             and that other parameters in other tables have been updated accordingly.
346             I.e. by the end of sending C to all the tables, the memory version
347             of the font should be entirely consistent.
348              
349             Some tables which do no work indicate to themselves the need to update
350             themselves by setting isDirty above 1. This method resets that accordingly.
351              
352             =cut
353              
354             sub update
355             {
356 0     0 1   my ($self) = @_;
357              
358 0 0         if ($self->{' isDirty'})
359             {
360 0           $self->read;
361 0           $self->{' isDirty'} = 0;
362 0           return $self;
363             }
364             else
365 0           { return undef; }
366             }
367              
368              
369             =head2 $t->empty
370              
371             Clears a table of all data to the level of not having been read
372              
373             =cut
374              
375             sub empty
376             {
377 0     0 1   my ($self) = @_;
378 0           my (%keep);
379              
380 0           foreach (qw(INFILE LENGTH OFFSET CSUM PARENT))
381 0           { $keep{" $_"} = 1; }
382              
383 0 0         map {delete $self->{$_} unless $keep{$_}} keys %$self;
  0            
384 0           $self;
385             }
386              
387              
388             =head2 $t->release
389              
390             Releases ALL of the memory used by this table, and all of its component/child
391             objects. This method is called automatically by
392             'Font::TTF::Font-Erelease' (so you don't have to call it yourself).
393              
394             B, that it is important that this method get called at some point prior
395             to the actual destruction of the object. Internally, we track things in a
396             structure that can result in circular references, and without calling
397             'C' these will not properly get cleaned up by Perl. Once this
398             method has been called, though, don't expect to be able to do anything with the
399             C object; it'll have B internal state whatsoever.
400              
401             B As part of the brute-force cleanup done here, this method
402             will throw a warning message whenever unexpected key values are found within
403             the C object. This is done to help ensure that any
404             unexpected and unfreed values are brought to your attention so that you can bug
405             us to keep the module updated properly; otherwise the potential for memory
406             leaks due to dangling circular references will exist.
407              
408             =cut
409              
410             sub release
411             {
412 0     0 1   my ($self) = @_;
413              
414             # delete stuff that we know we can, here
415              
416 0           my @tofree = map { delete $self->{$_} } keys %{$self};
  0            
  0            
417              
418 0           while (my $item = shift @tofree)
419             {
420 0           my $ref = ref($item);
421 0 0         if (UNIVERSAL::can($item, 'release'))
    0          
    0          
422 0           { $item->release(); }
423             elsif ($ref eq 'ARRAY')
424 0           { push( @tofree, @{$item} ); }
  0            
425             elsif (UNIVERSAL::isa($ref, 'HASH'))
426 0           { release($item); }
427             }
428              
429             # check that everything has gone - it better had!
430 0           foreach my $key (keys %{$self})
  0            
431 0           { warn ref($self) . " still has '$key' key left after release.\n"; }
432             }
433              
434              
435             sub __dumpvar__
436             {
437 0     0     my ($self, $key) = @_;
438              
439 0 0         return ($key eq ' PARENT' ? '...parent...' : $self->{$key});
440             }
441              
442             1;
443              
444             =head1 BUGS
445              
446             No known bugs
447              
448             =head1 AUTHOR
449              
450             Martin Hosken L.
451              
452              
453             =head1 LICENSING
454              
455             Copyright (c) 1998-2014, SIL International (http://www.sil.org)
456              
457             This module is released under the terms of the Artistic License 2.0.
458             For details, see the full text of the license in the file LICENSE.
459              
460              
461              
462             =cut
463              
464