File Coverage

blib/lib/PDF/API2/Basic/PDF/Objind.pm
Criterion Covered Total %
statement 57 68 83.8
branch 24 34 70.5
condition 11 17 64.7
subroutine 14 18 77.7
pod 12 13 92.3
total 118 150 78.6


line stmt bran cond sub pod time code
1             # Code in the PDF::API2::Basic::PDF namespace was originally copied from the
2             # Text::PDF distribution.
3             #
4             # Copyright Martin Hosken
5             #
6             # Martin Hosken's code may be used under the terms of the MIT license.
7             # Subsequent versions of the code have the same license as PDF::API2.
8              
9             package PDF::API2::Basic::PDF::Objind;
10              
11 40     40   333 use strict;
  40         88  
  40         1179  
12 40     40   204 use warnings;
  40         98  
  40         1960  
13              
14             our $VERSION = '2.044'; # VERSION
15              
16             =head1 NAME
17              
18             PDF::API2::Basic::PDF::Objind - Low-level PDF indirect object
19              
20             =head1 INSTANCE VARIABLES
21              
22             Instance variables differ from content variables in that they all start with
23             a space.
24              
25             =over
26              
27             =item parent
28              
29             For an object which is a reference to an object in some source, this holds the
30             reference to the source object, so that should the reference have to be
31             de-referenced, then we know where to go and get the info.
32              
33             =item objnum (R)
34              
35             The object number in the source (only for object references)
36              
37             =item objgen (R)
38              
39             The object generation in the source
40              
41             There are other instance variables which are used by the parent for file control.
42              
43             =item isfree
44              
45             This marks whether the object is in the free list and available for re-use as
46             another object elsewhere in the file.
47              
48             =item nextfree
49              
50             Holds a direct reference to the next free object in the free list.
51              
52             =back
53              
54             =head1 METHODS
55              
56             =cut
57              
58 40     40   240 use Scalar::Util qw(blessed reftype weaken);
  40         81  
  40         2588  
59              
60 40     40   280 use vars qw($uidc @inst %inst);
  40         88  
  40         10721  
61             $uidc = "pdfuid000";
62              
63             # protected keys during emptying and copying, etc.
64             @inst = qw(parent objnum objgen isfree nextfree uid realised);
65             $inst{" $_"} = 1 for @inst;
66              
67             =head2 PDF::API2::Basic::PDF::Objind->new()
68              
69             Creates a new indirect object
70              
71             =cut
72              
73             sub new {
74 1751     1751 1 3349 my ($class) = @_;
75              
76 1751   33     7606 bless {}, ref $class || $class;
77             }
78              
79             =head2 uid
80              
81             Returns a Unique id for this object, creating one if it didn't have one before
82              
83             =cut
84              
85             sub uid {
86 17887 100   17887 1 74789 $_[0]->{' uid'} || ($_[0]->{' uid'} = $uidc++);
87             }
88              
89             =head2 $r->release
90              
91             Releases ALL of the memory used by this indirect object, and all of
92             its component/child objects. This method is called automatically by
93             'Crelease>' (so you don't have to
94             call it yourself).
95              
96             B it is important that this method get called at some point
97             prior to the actual destruction of the object. Internally, PDF files
98             have an enormous amount of cross-references and this causes circular
99             references within our own internal data structures. Calling
100             'C' forces these circular references to be cleaned up and
101             the entire internal data structure purged.
102              
103             =cut
104              
105             # Maintainer's Question: Couldn't this be handled by a DESTROY method
106             # instead of requiring an explicit call to release()?
107             sub release {
108 6688     6688 1 10347 my ($self) = @_;
109              
110 6688         14807 my @tofree = values %$self;
111 6688         11771 %$self = ();
112              
113             # PDFs with highly-interconnected page trees or outlines can hit Perl's
114             # recursion limit pretty easily, so disable the warning for this specific
115             # loop.
116 40     40   331 no warnings 'recursion';
  40         114  
  40         37057  
117              
118 6688         17007 while (my $item = shift @tofree) {
119             # common case: value is not reference
120 17573   100     44792 my $ref = ref($item) || next;
121              
122 5761 100 100     26977 if (blessed($item) and $item->can('release')) {
    100 33        
    50          
123 5067         10055 $item->release();
124             }
125             elsif ($ref eq 'ARRAY') {
126 673         2199 push @tofree, @$item;
127             }
128             elsif (defined(reftype($ref)) and reftype($ref) eq 'HASH') {
129 0         0 release($item);
130             }
131             }
132             }
133              
134             =head2 $r->val
135              
136             Returns the value of this object or reads the object and then returns
137             its value.
138              
139             Note that all direct subclasses *must* make their own versions of this
140             subroutine otherwise we could be in for a very deep loop!
141              
142             =cut
143              
144             sub val {
145 0     0 1 0 my ($self) = @_;
146              
147 0 0       0 $self->{' parent'}->read_obj(@_)->val unless $self->{' realised'};
148             }
149              
150             =head2 $r->realise
151              
152             Makes sure that the object is fully read in, etc.
153              
154             =cut
155              
156             sub realise {
157 1931     1931 1 2856 my $self = shift();
158 1931 100       6404 return $self if $self->{' realised'};
159 106 100       478 return $self->{' parent'}->read_obj($self, @_) if $self->{' objnum'};
160 29         105 return $self;
161             }
162              
163             =head2 $r->outobjdeep($fh, $pdf)
164              
165             If you really want to output this object, then you must need to read it first.
166             This also means that all direct subclasses must subclass this method or loop forever!
167              
168             =cut
169              
170             sub outobjdeep {
171 0     0 1 0 my ($self, $fh, $pdf) = @_;
172              
173 0 0       0 $self->{' parent'}->read_obj($self)->outobjdeep($fh, $pdf) unless $self->{' realised'};
174             }
175              
176             =head2 $r->outobj($fh)
177              
178             If this is a full object then outputs a reference to the object, otherwise calls
179             outobjdeep to output the contents of the object at this point.
180              
181             =cut
182              
183             sub outobj {
184 5212     5212 1 8705 my ($self, $fh, $pdf) = @_;
185              
186 5212 100       9641 if (defined $pdf->{' objects'}{$self->uid}) {
187 1048         1804 $fh->printf("%d %d R", @{$pdf->{' objects'}{$self->uid}}[0..1]);
  1048         1899  
188             }
189             else {
190 4164         10534 $self->outobjdeep($fh, $pdf);
191             }
192             }
193              
194             =head2 $r->elements
195              
196             Abstract superclass function filler. Returns self here but should return
197             something more useful if an array.
198              
199             =cut
200              
201 0     0 0 0 sub elementsof { return elements(@_) }
202              
203             sub elements {
204 3     3 1 10 my ($self) = @_;
205              
206 3 50       17 if ($self->{' realised'}) {
207 3         13 return $self;
208             }
209             else {
210 0         0 return $self->{' parent'}->read_obj($self)->elements();
211             }
212             }
213              
214              
215             =head2 $r->empty
216              
217             Empties all content from this object to free up memory or to be read to pass
218             the object into the free list. Simplistically undefs all instance variables
219             other than object number and generation.
220              
221             =cut
222              
223             sub empty {
224 0     0 1 0 my ($self) = @_;
225              
226 0         0 for my $k (keys %$self) {
227 0 0       0 undef $self->{$k} unless $inst{$k};
228             }
229              
230 0         0 return $self;
231             }
232              
233              
234             =head2 $r->merge($objind)
235              
236             This merges content information into an object reference place-holder.
237             This occurs when an object reference is read before the object definition
238             and the information in the read data needs to be merged into the object
239             place-holder
240              
241             =cut
242              
243             sub merge {
244 81     81 1 185 my ($self, $other) = @_;
245              
246 81         418 for my $k (keys %$other) {
247 375 100       770 next if $inst{$k};
248 294         587 $self->{$k} = $other->{$k};
249              
250             # This doesn't seem like the right place to do this, but I haven't
251             # yet found all of the places where Parent is being set
252 294 100       716 weaken $self->{$k} if $k eq 'Parent';
253             }
254 81         296 $self->{' realised'} = 1;
255 81         272 bless $self, ref($other);
256             }
257              
258              
259             =head2 $r->is_obj($pdf)
260              
261             Returns whether this object is a full object with its own object number or
262             whether it is purely a sub-object. $pdf indicates which output file we are
263             concerned that the object is an object in.
264              
265             =cut
266              
267             sub is_obj {
268 2412     2412 1 5895 return defined $_[1]->{' objects'}{$_[0]->uid};
269             }
270              
271              
272             =head2 $r->copy($pdf, $res)
273              
274             Returns a new copy of this object. The object is assumed to be some kind
275             of associative array and the copy is a deep copy for elements which are
276             not PDF objects, according to $pdf, and shallow copy for those that are.
277             Notice that calling C on an object forces at least a one level
278             copy even if it is a PDF object. The returned object loses its PDF
279             object status though.
280              
281             If $res is defined then the copy goes into that object rather than creating a
282             new one. It is up to the caller to bless $res, etc. Notice that elements from
283             $self are not copied into $res if there is already an entry for them existing
284             in $res.
285              
286             =cut
287              
288             sub copy {
289 1023     1023 1 1990 my ($self, $pdf, $res) = @_;
290              
291 1023 50       1911 unless (defined $res) {
292 1023         1592 $res = {};
293 1023         1804 bless $res, ref($self);
294             }
295 1023         2681 foreach my $k (keys %$self) {
296 3089 100       5954 next if $inst{$k};
297 1027 50       1927 next if defined $res->{$k};
298 1027 100 66     3793 if (blessed($self->{$k}) and $self->{$k}->can('is_obj') and not $self->{$k}->is_obj($pdf)) {
      66        
299 147         565 $res->{$k} = $self->{$k}->copy($pdf);
300             }
301             else {
302 880         1953 $res->{$k} = $self->{$k};
303             }
304             }
305 1023         2888 return $res;
306             }
307              
308             1;