File Coverage

blib/lib/PDF/Builder/Basic/PDF/Objind.pm
Criterion Covered Total %
statement 61 76 80.2
branch 24 34 70.5
condition 11 17 64.7
subroutine 14 18 77.7
pod 12 13 92.3
total 122 158 77.2


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             # Effective 28 January 2021, the original author and copyright holder,
12             # Martin Hosken, has given permission to use and redistribute this module
13             # under the MIT license.
14             #
15             #=======================================================================
16             package PDF::Builder::Basic::PDF::Objind;
17              
18 37     37   314 use strict;
  37         80  
  37         1075  
19 37     37   191 use warnings;
  37         70  
  37         1241  
20 37     37   239 use Scalar::Util 'isweak';
  37         96  
  37         3584  
21              
22             our $VERSION = '3.023'; # VERSION
23             our $LAST_UPDATE = '3.022'; # manually update whenever code is changed
24              
25             =head1 NAME
26              
27             PDF::Builder::Basic::PDF::Objind - PDF indirect object reference. Also acts as an
28             abstract superclass for all elements in a PDF file.
29              
30             =head1 INSTANCE VARIABLES
31              
32             Instance variables differ from content variables in that they all start with
33             a space.
34              
35             =over
36              
37             =item ' parent'
38              
39             For an object which is a reference to an object in some source, this holds the
40             reference to the source object, so that should the reference have to be
41             de-referenced, then we know where to go and get the info.
42              
43             =item ' objnum' (R)
44              
45             The object number in the source (only for object references)
46              
47             =item ' objgen' (R)
48              
49             The object generation in the source
50              
51             There are other instance variables which are used by the parent for file control.
52              
53             =item ' isfree'
54              
55             This marks whether the object is in the free list and available for re-use as
56             another object elsewhere in the file.
57              
58             =item ' nextfree'
59              
60             Holds a direct reference to the next free object in the free list.
61              
62             =back
63              
64             =head1 METHODS
65              
66             =cut
67              
68 37     37   258 use Scalar::Util qw(blessed reftype weaken);
  37         94  
  37         2474  
69              
70 37     37   261 use vars qw($uidc @inst %inst);
  37         70  
  37         45258  
71             $uidc = "pdfuid000";
72              
73             # protected keys during emptying and copying, etc.
74             @inst = qw(parent objnum objgen isfree nextfree uid realised);
75             $inst{" $_"} = 1 for @inst;
76              
77             =head2 PDF::Builder::Basic::PDF::Objind->new()
78              
79             Creates a new indirect object
80              
81             =cut
82              
83             sub new {
84 1650     1650 1 3253 my ($class) = @_;
85              
86 1650   33     7462 return bless {}, ref $class || $class;
87             }
88              
89             =head2 $UID = $r->uid()
90              
91             Returns a Unique id for this object, creating one if it didn't have one before
92              
93             =cut
94              
95             sub uid {
96 26047 100   26047 1 65223 $_[0]->{' uid'} || ($_[0]->{' uid'} = $uidc++);
97 26047         67098 return $_[0]->{' uid'};
98             }
99              
100             =head2 $r->release()
101              
102             Releases ALL of the memory used by this indirect object, and all of
103             its component/child objects. This method is called automatically by
104             'Crelease>' (so you don't have to
105             call it yourself).
106              
107             B it is important that this method get called at some point
108             prior to the actual destruction of the object. Internally, PDF files
109             have an enormous amount of cross-references and this causes circular
110             references within our own internal data structures. Calling
111             'C' forces these circular references to be cleaned up and
112             the entire internal data structure purged.
113              
114             =cut
115              
116             # Maintainer's Question: Couldn't this be handled by a DESTROY method
117             # instead of requiring an explicit call to release()?
118             sub release {
119 13959     13959 1 21688 my ($self) = @_;
120              
121 13959         28707 my @tofree = grep { !isweak $_ } values %$self;
  43012         90230  
122 13959         24495 %$self = ();
123              
124 13959         27804 while (my $item = shift @tofree) {
125             # common case: value is not reference
126 47635   100     104555 my $ref = ref($item) || next;
127              
128 12901 100 100     57545 if (blessed($item) and $item->can('release')) {
    100 33        
    50          
129 12159         21998 $item->release();
130             } elsif ($ref eq 'ARRAY') {
131 723         3050 push @tofree, @$item;
132             } elsif (defined(reftype($ref)) and reftype($ref) eq 'HASH') {
133 0         0 release($item);
134             }
135             }
136 13959         38527 return;
137             }
138              
139             =head2 $value = $r->val()
140              
141             Returns the value of this object or reads the object and then returns
142             its value.
143              
144             Note that all direct subclasses *must* make their own versions of this
145             subroutine otherwise we could be in for a very deep loop!
146              
147             =cut
148              
149             sub val {
150 0     0 1 0 my ($self) = @_;
151              
152             # this original code is very confusing. is this a
153             # recursive call to this val(), or another? what is
154             # supposed to be returned when self->realised is True?
155             # perlcritic doesn't like this...
156             #$self->{' parent'}->read_obj(@_)->val()
157             # unless $self->{' realised'}; ## no critic
158              
159 0 0       0 if ($self->{' realised'}) {
160 0         0 return $self->{' realised'}; # return undef in any cases?
161             } else {
162 0         0 return $self->{' parent'}->read_obj(@_)->val();
163             }
164             }
165              
166             =head2 $r->realise()
167              
168             Makes sure that the object is fully read in, etc.
169              
170             =cut
171              
172             sub realise {
173 2009     2009 1 3076 my $self = shift();
174              
175 2009 100       6872 return $self if $self->{' realised'};
176 98 100       401 return $self->{' parent'}->read_obj($self, @_) if $self->{' objnum'};
177 30         115 return $self;
178             }
179              
180             =head2 $v = $r->outobjdeep($fh, $pdf)
181              
182             If you really want to output this object, then you need to read it first.
183             This also means that all direct subclasses must subclass this method, or they
184             will loop forever!
185              
186             =cut
187              
188             sub outobjdeep {
189 0     0 1 0 my ($self, $fh, $pdf) = @_;
190              
191             # this original code is very confusing. is this a
192             # recursive call to this outobjdeep(), or another? what is
193             # supposed to be returned when self->realised is True?
194             # perlcritic doesn't like the lack of explicit return...
195             #$self->{' parent'}->read_obj($self)->outobjdeep($fh, $pdf)
196             # unless $self->{' realised'}; ## no critic
197              
198 0 0       0 if ($self->{' realised'}) {
199 0         0 return $self->{' realised'}; # return undef in any cases?
200             } else {
201 0         0 return $self->{' parent'}->read_obj($self)->outobjdeep($fh, $pdf);
202             }
203             }
204              
205             =head2 $r->outobj($fh, $pdf)
206              
207             If this is a full object then outputs a reference to the object, otherwise calls
208             outobjdeep to output the contents of the object at this point.
209              
210             =cut
211              
212             sub outobj {
213 13328     13328 1 22077 my ($self, $fh, $pdf) = @_;
214              
215 13328 100       23596 if (defined $pdf->{' objects'}{$self->uid()}) {
216 878         1486 $fh->printf("%d %d R", @{$pdf->{' objects'}{$self->uid()}}[0..1]);
  878         1658  
217             } else {
218 12450         26121 $self->outobjdeep($fh, $pdf);
219             }
220 13328         28328 return;
221             }
222              
223             =head2 $s = $r->elements()
224              
225             Abstract superclass function filler. Returns self here but should return
226             something more useful if an array.
227              
228             The old name of this method, C, has been B and will
229             be removed in the future.
230              
231             =cut
232              
233 0     0 0 0 sub elementsof { return elements(@_); }
234              
235             sub elements {
236 3     3 1 10 my ($self) = @_;
237              
238 3 50       9 if ($self->{' realised'}) {
239 3         14 return $self;
240             } else {
241 0         0 return $self->{' parent'}->read_obj($self)->elements();
242             }
243             }
244              
245             =head2 $s = $r->empty()
246              
247             Empties all content from this object to free up memory or to be read to pass
248             the object into the free list. Simplistically undefs all instance variables
249             other than object number and generation.
250              
251             =cut
252              
253             sub empty {
254 0     0 1 0 my ($self) = @_;
255              
256 0         0 for my $k (keys %$self) {
257 0 0       0 undef $self->{$k} unless $inst{$k};
258             }
259              
260 0         0 return $self;
261             }
262              
263             =head2 $o = $r->merge($objind)
264              
265             This merges content information into an object reference placeholder.
266             This occurs when an object reference is read before the object definition
267             and the information in the read data needs to be merged into the object
268             placeholder.
269              
270             =cut
271              
272             sub merge {
273 72     72 1 141 my ($self, $other) = @_;
274              
275 72         357 for my $k (keys %$other) {
276 349 100       684 next if $inst{$k};
277 277         533 $self->{$k} = $other->{$k};
278              
279             # This doesn't seem like the right place to do this, but I haven't
280             # yet found all of the places where Parent is being set
281 277 100       691 weaken $self->{$k} if $k eq 'Parent';
282             }
283 72         151 $self->{' realised'} = 1;
284 72         200 return bless $self, ref($other);
285             }
286              
287             =head2 $r->is_obj($pdf)
288              
289             Returns whether this object is a full object with its own object number or
290             whether it is purely a sub-object. C<$pdf> indicates which output file we are
291             concerned that the object is an object in.
292              
293             =cut
294              
295             sub is_obj {
296 3954     3954 1 8270 return defined $_[1]->{' objects'}{$_[0]->uid()};
297             }
298              
299             =head2 $r->copy($pdf, $res)
300              
301             Returns a new copy of this object. The object is assumed to be some kind
302             of associative array and the copy is a deep copy for elements which are
303             not PDF objects, according to C<$pdf>, and shallow copy for those that are.
304             Notice that calling C on an object forces at least a one level
305             copy even if it is a PDF object. The returned object loses its PDF
306             object status though.
307              
308             If C<$res> is defined then the copy goes into that object rather than creating a
309             new one. It is up to the caller to bless C<$res>, etc. Notice that elements from
310             C<$self> are not copied into C<$res> if there is already an entry for them
311             existing in C<$res>.
312              
313             =cut
314              
315             sub copy {
316 2758     2758 1 4133 my ($self, $pdf, $res) = @_;
317              
318 2758 50       4633 unless (defined $res) {
319 2758         3706 $res = {};
320 2758         4083 bless $res, ref($self);
321             }
322 2758         5997 foreach my $k (keys %$self) {
323 8299 100       13446 next if $inst{$k};
324 2769 50       4258 next if defined $res->{$k};
325 2769 100 66     7540 if (blessed($self->{$k}) and $self->{$k}->can('is_obj') and not $self->{$k}->is_obj($pdf)) {
      66        
326 155         555 $res->{$k} = $self->{$k}->copy($pdf);
327             } else {
328 2614         5108 $res->{$k} = $self->{$k};
329             }
330             }
331 2758         6188 return $res;
332             }
333              
334             1;