File Coverage

blib/lib/PDF/Builder/Basic/PDF/Objind.pm
Criterion Covered Total %
statement 57 72 79.1
branch 24 34 70.5
condition 11 17 64.7
subroutine 13 17 76.4
pod 12 13 92.3
total 117 153 76.4


line stmt bran cond sub pod time code
1             #=======================================================================
2             #
3             # THIS IS A REUSED PERL MODULE, FOR PROPER LICENCING TERMS SEE BELOW:
4             #
5             # Copyright Martin Hosken
6             #
7             # No warranty or expression of effectiveness, least of all regarding
8             # anyone's safety, is implied in this software or documentation.
9             #
10             # This specific module is licensed under the Perl Artistic License.
11             #
12             #=======================================================================
13             package PDF::Builder::Basic::PDF::Objind;
14              
15 36     36   279 use strict;
  36         77  
  36         1005  
16 36     36   220 use warnings;
  36         66  
  36         2224  
17              
18             our $VERSION = '3.017'; # VERSION
19             my $LAST_UPDATE = '3.016'; # manually update whenever code is changed
20              
21             =head1 NAME
22              
23             PDF::Builder::Basic::PDF::Objind - PDF indirect object reference. Also acts as an
24             abstract superclass for all elements in a PDF file.
25              
26             =head1 INSTANCE VARIABLES
27              
28             Instance variables differ from content variables in that they all start with
29             a space.
30              
31             =over
32              
33             =item ' parent'
34              
35             For an object which is a reference to an object in some source, this holds the
36             reference to the source object, so that should the reference have to be
37             de-referenced, then we know where to go and get the info.
38              
39             =item ' objnum' (R)
40              
41             The object number in the source (only for object references)
42              
43             =item ' objgen' (R)
44              
45             The object generation in the source
46              
47             There are other instance variables which are used by the parent for file control.
48              
49             =item ' isfree'
50              
51             This marks whether the object is in the free list and available for re-use as
52             another object elsewhere in the file.
53              
54             =item ' nextfree'
55              
56             Holds a direct reference to the next free object in the free list.
57              
58             =back
59              
60             =head1 METHODS
61              
62             =cut
63              
64 36     36   252 use Scalar::Util qw(blessed reftype weaken);
  36         75  
  36         2444  
65              
66 36     36   228 use vars qw($uidc @inst %inst);
  36         67  
  36         39266  
67             $uidc = "pdfuid000";
68              
69             # protected keys during emptying and copying, etc.
70             @inst = qw(parent objnum objgen isfree nextfree uid realised);
71             $inst{" $_"} = 1 for @inst;
72              
73             =head2 PDF::Builder::Basic::PDF::Objind->new()
74              
75             Creates a new indirect object
76              
77             =cut
78              
79             sub new {
80 1256     1256 1 2207 my ($class) = @_;
81              
82 1256   33     5115 return bless {}, ref $class || $class;
83             }
84              
85             =head2 $UID = $r->uid()
86              
87             Returns a Unique id for this object, creating one if it didn't have one before
88              
89             =cut
90              
91             sub uid {
92 16837 100   16837 1 37101 $_[0]->{' uid'} || ($_[0]->{' uid'} = $uidc++);
93 16837         41690 return $_[0]->{' uid'};
94             }
95              
96             =head2 $r->release()
97              
98             Releases ALL of the memory used by this indirect object, and all of
99             its component/child objects. This method is called automatically by
100             'Crelease>' (so you don't have to
101             call it yourself).
102              
103             B it is important that this method get called at some point
104             prior to the actual destruction of the object. Internally, PDF files
105             have an enormous amount of cross-references and this causes circular
106             references within our own internal data structures. Calling
107             'C' forces these circular references to be cleaned up and
108             the entire internal data structure purged.
109              
110             =cut
111              
112             # Maintainer's Question: Couldn't this be handled by a DESTROY method
113             # instead of requiring an explicit call to release()?
114             sub release {
115 6662     6662 1 9318 my ($self) = @_;
116              
117 6662         13419 my @tofree = values %$self;
118 6662         10094 %$self = ();
119              
120 6662         11474 while (my $item = shift @tofree) {
121             # common case: value is not reference
122 19929   100     39273 my $ref = ref($item) || next;
123              
124 6106 100 100     22233 if (blessed($item) and $item->can('release')) {
    100 33        
    50          
125 5503         9095 $item->release();
126             } elsif ($ref eq 'ARRAY') {
127 598         1737 push @tofree, @$item;
128             } elsif (defined(reftype($ref)) and reftype($ref) eq 'HASH') {
129 0         0 release($item);
130             }
131             }
132 6662         26801 return;
133             }
134              
135             =head2 $value = $r->val()
136              
137             Returns the value of this object or reads the object and then returns
138             its value.
139              
140             Note that all direct subclasses *must* make their own versions of this
141             subroutine otherwise we could be in for a very deep loop!
142              
143             =cut
144              
145             sub val {
146 0     0 1 0 my ($self) = @_;
147              
148             # this original code is very confusing. is this a
149             # recursive call to this val(), or another? what is
150             # supposed to be returned when self->realised is True?
151             # perlcritic doesn't like this...
152             #$self->{' parent'}->read_obj(@_)->val()
153             # unless $self->{' realised'}; ## no critic
154              
155 0 0       0 if ($self->{' realised'}) {
156 0         0 return $self->{' realised'}; # return undef in any cases?
157             } else {
158 0         0 return $self->{' parent'}->read_obj(@_)->val();
159             }
160             }
161              
162             =head2 $r->realise()
163              
164             Makes sure that the object is fully read in, etc.
165              
166             =cut
167              
168             sub realise {
169 1426     1426 1 1998 my $self = shift();
170              
171 1426 100       4302 return $self if $self->{' realised'};
172 61 100       277 return $self->{' parent'}->read_obj($self, @_) if $self->{' objnum'};
173 16         70 return $self;
174             }
175              
176             =head2 $v = $r->outobjdeep($fh, $pdf)
177              
178             If you really want to output this object, then you need to read it first.
179             This also means that all direct subclasses must subclass this method, or they
180             will loop forever!
181              
182             =cut
183              
184             sub outobjdeep {
185 0     0 1 0 my ($self, $fh, $pdf) = @_;
186              
187             # this original code is very confusing. is this a
188             # recursive call to this outobjdeep(), or another? what is
189             # supposed to be returned when self->realised is True?
190             # perlcritic doesn't like the lack of explicit return...
191             #$self->{' parent'}->read_obj($self)->outobjdeep($fh, $pdf)
192             # unless $self->{' realised'}; ## no critic
193              
194 0 0       0 if ($self->{' realised'}) {
195 0         0 return $self->{' realised'}; # return undef in any cases?
196             } else {
197 0         0 return $self->{' parent'}->read_obj($self)->outobjdeep($fh, $pdf);
198             }
199             }
200              
201             =head2 $r->outobj($fh, $pdf)
202              
203             If this is a full object then outputs a reference to the object, otherwise calls
204             outobjdeep to output the contents of the object at this point.
205              
206             =cut
207              
208             sub outobj {
209 6178     6178 1 9033 my ($self, $fh, $pdf) = @_;
210              
211 6178 100       9974 if (defined $pdf->{' objects'}{$self->uid()}) {
212 729         1080 $fh->printf("%d %d R", @{$pdf->{' objects'}{$self->uid()}}[0..1]);
  729         1155  
213             } else {
214 5449         10637 $self->outobjdeep($fh, $pdf);
215             }
216 6178         13742 return;
217             }
218              
219             =head2 $s = $r->elements()
220              
221             Abstract superclass function filler. Returns self here but should return
222             something more useful if an array.
223              
224             The old name of this method, C, has been B and will
225             be removed in the future.
226              
227             =cut
228              
229 0     0 0 0 sub elementsof { return elements(@_); }
230              
231             sub elements {
232 3     3 1 8 my ($self) = @_;
233              
234 3 50       8 if ($self->{' realised'}) {
235 3         11 return $self;
236             } else {
237 0         0 return $self->{' parent'}->read_obj($self)->elements();
238             }
239             }
240              
241             =head2 $s = $r->empty()
242              
243             Empties all content from this object to free up memory or to be read to pass
244             the object into the free list. Simplistically undefs all instance variables
245             other than object number and generation.
246              
247             =cut
248              
249             sub empty {
250 0     0 1 0 my ($self) = @_;
251              
252 0         0 for my $k (keys %$self) {
253 0 0       0 undef $self->{$k} unless $inst{$k};
254             }
255              
256 0         0 return $self;
257             }
258              
259             =head2 $o = $r->merge($objind)
260              
261             This merges content information into an object reference placeholder.
262             This occurs when an object reference is read before the object definition
263             and the information in the read data needs to be merged into the object
264             placeholder.
265              
266             =cut
267              
268             sub merge {
269 49     49 1 109 my ($self, $other) = @_;
270              
271 49         257 for my $k (keys %$other) {
272 235 100       498 next if $inst{$k};
273 186         376 $self->{$k} = $other->{$k};
274              
275             # This doesn't seem like the right place to do this, but I haven't
276             # yet found all of the places where Parent is being set
277 186 100       422 weaken $self->{$k} if $k eq 'Parent';
278             }
279 49         106 $self->{' realised'} = 1;
280 49         156 return bless $self, ref($other);
281             }
282              
283             =head2 $r->is_obj($pdf)
284              
285             Returns whether this object is a full object with its own object number or
286             whether it is purely a sub-object. C<$pdf> indicates which output file we are
287             concerned that the object is an object in.
288              
289             =cut
290              
291             sub is_obj {
292 3426     3426 1 6936 return defined $_[1]->{' objects'}{$_[0]->uid()};
293             }
294              
295             =head2 $r->copy($pdf, $res)
296              
297             Returns a new copy of this object. The object is assumed to be some kind
298             of associative array and the copy is a deep copy for elements which are
299             not PDF objects, according to C<$pdf>, and shallow copy for those that are.
300             Notice that calling C on an object forces at least a one level
301             copy even if it is a PDF object. The returned object loses its PDF
302             object status though.
303              
304             If C<$res> is defined then the copy goes into that object rather than creating a
305             new one. It is up to the caller to bless C<$res>, etc. Notice that elements from
306             C<$self> are not copied into C<$res> if there is already an entry for them
307             existing in C<$res>.
308              
309             =cut
310              
311             sub copy {
312 2453     2453 1 4062 my ($self, $pdf, $res) = @_;
313              
314 2453 50       4433 unless (defined $res) {
315 2453         3652 $res = {};
316 2453         4163 bless $res, ref($self);
317             }
318 2453         5571 foreach my $k (keys %$self) {
319 7382 100       13085 next if $inst{$k};
320 2464 50       4136 next if defined $res->{$k};
321 2464 100 66     7075 if (blessed($self->{$k}) and $self->{$k}->can('is_obj') and not $self->{$k}->is_obj($pdf)) {
      66        
322 114         365 $res->{$k} = $self->{$k}->copy($pdf);
323             } else {
324 2350         5288 $res->{$k} = $self->{$k};
325             }
326             }
327 2453         6246 return $res;
328             }
329              
330             1;