File Coverage

blib/lib/PDF/Builder/Basic/PDF/Pages.pm
Criterion Covered Total %
statement 115 181 63.5
branch 39 82 47.5
condition 6 41 14.6
subroutine 17 23 73.9
pod 10 15 66.6
total 187 342 54.6


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::Pages;
17              
18 35     35   317 use strict;
  35         78  
  35         1105  
19 35     35   184 use warnings;
  35         77  
  35         960  
20              
21 35     35   184 use base 'PDF::Builder::Basic::PDF::Dict';
  35         155  
  35         5580  
22              
23             our $VERSION = '3.023'; # VERSION
24             our $LAST_UPDATE = '3.022'; # manually update whenever code is changed
25              
26 35     35   269 use PDF::Builder::Basic::PDF::Array;
  35         90  
  35         847  
27 35     35   184 use PDF::Builder::Basic::PDF::Dict;
  35         76  
  35         4441  
28 35     35   329 use PDF::Builder::Basic::PDF::Utils;
  35         73  
  35         3015  
29              
30 35     35   219 use Scalar::Util qw(weaken);
  35         71  
  35         78064  
31              
32             our %inst = map {$_ => 1} qw(Parent Type);
33              
34             =head1 NAME
35              
36             PDF::Builder::Basic::PDF::Pages - a PDF pages hierarchical element.
37             Inherits from L
38              
39             =head1 DESCRIPTION
40              
41             A Pages object is the parent to other pages objects or to page objects
42             themselves.
43              
44             =head1 METHODS
45              
46             =head2 PDF::Builder::Basic::PDF::Pages->new($pdf, $parent)
47              
48             This creates a new Pages object in a PDF. Notice that the C<$parent> here is
49             not the file context for the object, but the parent pages object for these
50             pages. If we are using this class to create a root node, C<$parent> should
51             point to the file context, which is identified by I having a Type of
52             I. C<$pdf> is the file object (or a reference to an array of I
53             file object [3.016 and later, or multiple file objects earlier]) in which to
54             create the new Pages object.
55              
56             =cut
57              
58             sub new {
59 303     303 1 782 my ($class, $pdf, $parent) = @_;
60 303 50 0     734 $pdf //= $class->get_top()->{' parent'} if ref($class);
61              
62             # before PDF::API2 2.034/PDF::Builder 3.016, $pdf could be an array of PDFs
63 303 50       899 if (ref($pdf) eq 'ARRAY') {
64 0 0       0 die 'Pages: Only one PDF is supported as of version 3.016' if scalar(@$pdf) > 1;
65 0         0 ($pdf) = @$pdf;
66             }
67              
68 303 50       676 $class = ref($class) if ref($class);
69 303         1042 my $self = $class->SUPER::new($pdf, $parent);
70              
71 303         959 $self->{'Type'} = PDFName('Pages');
72 303 100       868 $self->{'Parent'} = $parent if defined $parent;
73 303         784 $self->{'Count'} = PDFNum(0);
74 303         1374 $self->{'Kids'} = PDF::Builder::Basic::PDF::Array->new();
75              
76 303         1089 $pdf->new_obj($self);
77 303 100       841 unless (defined $self->{'Parent'}) {
78 162         414 $pdf->{'Root'}->{'Pages'} = $self;
79 162         611 $pdf->out_obj($pdf->{'Root'});
80              
81 162         360 $self->{' parent'} = $pdf;
82 162         773 weaken $self->{' parent'};
83             }
84 303 100       1507 weaken $self->{'Parent'} if defined $parent;
85              
86 303         927 return $self;
87             }
88              
89             #sub init {
90             # my ($self, $pdf) = @_;
91             # $self->{' destination_pdfs'} = [$pdf];
92             # weaken $self->{' destination_pdfs'}->[0] if defined $pdf;
93             #
94             # return $self;
95             #}
96              
97             #=head2 $p->out_obj($is_new)
98             #
99             #Tells all the files that this thing is destined for that they should output this
100             #object, come time to output. If this object has no parent, then it must be the
101             #root. So set as the root for the files in question and tell it to be output too.
102             #If C<$is_new> is set, then call C rather than C to create as
103             #a new object in the file.
104             #
105             #=cut
106             #
107             #sub out_obj {
108             # my ($self, $is_new) = @_;
109             #
110             # foreach my $pdf (@{$self->{' destination_pdfs'}}) {
111             # if ($is_new) {
112             # $pdf->new_obj($self);
113             # } else {
114             # $pdf->out_obj($self);
115             # }
116             #
117             # unless (defined $self->{'Parent'}) {
118             # $pdf->{'Root'}{'Pages'} = $self;
119             # $pdf->out_obj($pdf->{'Root'});
120             # }
121             # }
122             #
123             # return $self;
124             #}
125              
126             sub _pdf {
127 423     423   834 my ($self) = @_;
128 423         931 return $self->get_top()->{' parent'};
129             }
130              
131             =head2 $p->find_page($page_number)
132              
133             Returns the given page, using the page count values in the pages tree. Pages
134             start at 0.
135              
136             =cut
137              
138             sub find_page {
139 141     141 1 337 my ($self, $page_number) = @_;
140 141         307 my $top = $self->get_top();
141              
142 141         481 return $top->find_page_recursively(\$page_number);
143             }
144              
145             sub find_page_recursively {
146 141     141 0 307 my ($self, $page_number_ref) = @_;
147              
148 141 50       474 if ($self->{'Count'}->realise()->val() <= $$page_number_ref) {
149 0         0 $$page_number_ref -= $self->{'Count'}->val();
150 0         0 return;
151             }
152              
153 141         267 my $result;
154 141         469 foreach my $kid ($self->{'Kids'}->realise()->elements()) {
155 9 50       58 if ($kid->{'Type'}->realise()->val() eq 'Page') {
    0          
156 9 50       41 return $kid if $$page_number_ref == 0;
157 0         0 $$page_number_ref--;
158             } elsif ($result = $kid->realise()->find_page_recursively($page_number_ref)) {
159 0         0 return $result;
160             }
161             }
162              
163 132         336 return;
164             }
165              
166             =head2 $p->add_page($page, $page_number)
167              
168             Inserts the page before the given C<$page_number>. C<$page_number> can be
169             negative to count backwards from the END of the document. -1 is after the last
170             page. Likewise C<$page_number> can be greater than the number of pages
171             currently in the document, to append.
172              
173             This method only guarantees to provide a reasonable pages tree if pages are
174             appended or prepended to the document. Pages inserted in the middle of the
175             document may simply be inserted in the appropriate leaf in the pages tree
176             without adding any new branches or leaves, leaving it unbalanced (slower
177             performance, but still usable).
178              
179             =cut
180              
181             # -- removed from end of second para:
182             #To tidy up such a mess, it is best
183             #to call C<$p->rebuild_tree()> to rebuild the pages tree into something
184             #efficient. B is currently a no-op!>
185              
186             sub add_page {
187 141     141 1 342 my ($self, $page, $page_number) = @_;
188 141         354 my $top = $self->get_top();
189              
190 141 100 66     530 $page_number = -1 unless defined $page_number and $page_number <= $top->{'Count'}->val();
191              
192 141         285 my $previous_page;
193 141 100       373 if ($page_number == -1) {
194 139         559 $previous_page = $top->find_page($top->{'Count'}->val() - 1);
195             } else {
196 2 50       6 $page_number = $top->{'Count'}->val() + $page_number + 1 if $page_number < 0;
197 2         7 $previous_page = $top->find_page($page_number);
198             }
199              
200 141         280 my $parent;
201 141 100       469 if (defined $previous_page->{'Parent'}) {
202 9         30 $parent = $previous_page->{'Parent'}->realise();
203             } else {
204 132         264 $parent = $self;
205             }
206              
207 141         399 my $parent_kid_count = scalar $parent->{'Kids'}->realise()->elements();
208              
209 141         258 my $page_index;
210 141 100       380 if ($page_number == -1) {
211 139         256 $page_index = -1;
212             } else {
213 2         6 for ($page_index = 0;
214             $page_index < $parent_kid_count;
215             $page_index++) {
216 2 50       12 last if $parent->{'Kids'}{' val'}[$page_index] eq $previous_page;
217             }
218 2 50       14 $page_index = -1 if $page_index == $parent_kid_count;
219             }
220              
221 141         505 $parent->add_page_recursively($page->realise(), $page_index);
222 141         530 for ($parent = $page->{'Parent'};
223             defined $parent->{'Parent'};
224             $parent = $parent->{'Parent'}->realise()) {
225 0         0 $parent->set_modified();
226 0         0 $parent->{'Count'}->realise()->{'val'}++;
227             }
228 141         404 $parent->set_modified();
229 141         397 $parent->{'Count'}->realise()->{'val'}++;
230              
231 141         417 return $page;
232             } # end of add_page()
233              
234             sub add_page_recursively {
235 141     141 0 328 my ($self, $page, $page_index) = @_;
236              
237 141         237 my $parent = $self;
238 141         260 my $max_kids_per_parent = 8; # Why 8?
239 141 50 33     422 if (scalar $parent->{'Kids'}->elements() >= $max_kids_per_parent and
      0        
240             $parent->{'Parent'} and
241             $page_index < 1) {
242 0         0 my $grandparent = $parent->{'Parent'}->realise();
243 0         0 $parent = $parent->new($parent->_pdf(), $grandparent);
244              
245 0         0 my $grandparent_kid_count = scalar $grandparent->{'Kids'}->realise()->elements();
246 0         0 my $new_parent_index;
247 0         0 for ($new_parent_index = 0;
248             $new_parent_index < $grandparent_kid_count;
249             $new_parent_index++) {
250 0 0       0 last if $grandparent->{'Kids'}{' val'}[$new_parent_index] eq $self;
251             }
252 0         0 $new_parent_index++;
253 0 0       0 $new_parent_index = -1 if $new_parent_index > $grandparent_kid_count;
254 0         0 $grandparent->add_page_recursively($parent, $new_parent_index);
255             } else {
256 141         409 $parent->set_modified();
257             }
258              
259 141 100       399 if ($page_index < 0) {
260 139         231 push @{$parent->{'Kids'}->realise()->{' val'}}, $page;
  139         390  
261             } else {
262 2         3 splice @{$parent->{'Kids'}{' val'}}, $page_index, 0, $page;
  2         8  
263             }
264 141         336 $page->{'Parent'} = $parent;
265 141         494 weaken $page->{'Parent'};
266              
267 141         255 return;
268             } # end of add_page_recursively()
269              
270             sub set_modified {
271 282     282 0 521 my ($self) = @_;
272 282         584 $self->_pdf()->out_obj($self);
273 282         504 return;
274             }
275              
276             #=head2 $root_pages = $p->rebuild_tree([@pglist])
277             #
278             #B
279             #
280             #Rebuilds the pages tree to make a nice balanced tree that conforms to Adobe
281             #recommendations. If passed a C<@pglist> then the tree is built for that list of
282             #pages. No check is made of whether the C<@pglist> contains pages.
283             #
284             #Returns the top of the tree for insertion in the root object.
285             #
286             #=cut
287              
288             # TBD where's the code?
289             #sub rebuild_tree {
290             # my ($self, @pglist) = @_;
291             # return;
292             #}
293              
294             =head2 @objects = $p->get_pages()
295              
296             Returns a list of page objects in the document, in page order.
297              
298             =cut
299              
300             sub get_pages {
301 0     0 1 0 my ($self) = @_;
302              
303 0         0 return $self->get_top()->get_pages_recursively();
304             }
305              
306             # Renamed for clarity. should this be deprecated?
307             # appears not to have been used, and was undocumented.
308 0     0 0 0 sub get_kids { return get_pages_recursively(@_); }
309              
310             sub get_pages_recursively {
311 0     0 0 0 my ($self) = @_;
312 0         0 my @pages;
313              
314 0         0 foreach my $kid ($self->{'Kids'}->elements()) {
315 0         0 $kid->realise();
316 0 0       0 if ($kid->{'Type'}->val() eq 'Pages') {
317 0         0 push @pages, $kid->get_pages_recursively();
318             } else {
319 0         0 push @pages, $kid;
320             }
321             }
322              
323 0         0 return @pages;
324             }
325              
326             =head2 $p->find_prop($key)
327              
328             Searches up through the inheritance tree to find a property (key).
329              
330             =cut
331              
332             sub find_prop {
333 516     516 1 1413 my ($self, $key) = @_;
334              
335 516 100       1724 if (defined $self->{$key}) {
    100          
336 186 50 33     1549 if (ref($self->{$key}) and
337             $self->{$key}->isa('PDF::Builder::Basic::PDF::Objind')) {
338 186         658 return $self->{$key}->realise();
339             } else {
340 0         0 return $self->{$key};
341             }
342             # Per Klaus Ethgen (RT 131147), this is an alternative patch for the
343             # problem of Null objects bubbling up. If Vadim Repin's patch in ./File.pm
344             # turns out to have too wide of scope, we might use this one instead.
345             # comment out 1, uncomment 2, and reverse change made in ./File.pm.
346             } elsif (defined $self->{'Parent'}) {
347             #} elsif (defined $self->{'Parent'} and
348             # ref($self->('Parent'}) ne 'PDF::Builder::Basic::PDF::Null') {
349 158         549 return $self->{'Parent'}->find_prop($key);
350             }
351              
352 172         428 return;
353             }
354              
355             =head2 $p->add_font($pdf, $font)
356              
357             Creates or edits the resource dictionary at this level in the hierarchy. If
358             the font is already supported, even through the hierarchy, then it is not added.
359              
360             B if this method was used in older releases, the code may have
361             swapped the order of C<$pdf> and C<$font>, requiring ad hoc swapping of
362             parameters in user code, contrary to the POD definition above. Now the code
363             matches the documentation.
364              
365             =cut
366              
367             sub add_font {
368 0     0 1 0 my ($self, $pdf, $font) = @_;
369              
370 0         0 my $name = $font->{'Name'}->val();
371 0         0 my $dict = $self->find_prop('Resources');
372              
373             return $self if ($dict and
374             defined $dict->{'Font'} and
375 0 0 0     0 defined $dict->{'Font'}{$name});
      0        
376 0 0       0 unless (defined $self->{'Resources'}) {
377 0 0       0 $dict = $dict ? $dict->copy($pdf) : PDFDict();
378 0         0 $self->{'Resources'} = $dict;
379             } else {
380 0         0 $dict = $self->{'Resources'};
381             }
382 0   0     0 $dict->{'Font'} //= PDFDict();
383              
384 0         0 my $resource = $dict->{'Font'}->val();
385 0   0     0 $resource->{$name} //= $font;
386 0 0 0     0 if (ref($dict) ne 'HASH' and $dict->is_obj($pdf)) {
387 0         0 $pdf->out_obj($dict);
388             }
389 0 0 0     0 if (ref($resource) ne 'HASH' and $resource->is_obj($pdf)) {
390 0         0 $pdf->out_obj($resource);
391             }
392              
393 0         0 return $self;
394             } # end of add_font()
395              
396             =head2 $p->bbox($xmin,$ymin, $xmax,$ymax, $param)
397              
398             =head2 $p->bbox($xmin,$ymin, $xmax,$ymax)
399              
400             Specifies the bounding box for this and all child pages. If the values are
401             identical to those inherited, no change is made. C<$param> specifies the
402             attribute name so that other 'bounding box'es can be set with this method.
403              
404             =cut
405              
406             sub bbox {
407 0     0 1 0 my ($self, @bbox) = @_;
408 0   0     0 my $key = $bbox[4] || 'MediaBox';
409 0         0 my $inherited = $self->find_prop($key);
410              
411 0 0       0 if ($inherited) {
412 0         0 my $is_changed = 0;
413 0         0 my $i = 0;
414 0         0 foreach my $element ($inherited->elements()) {
415 0 0       0 $is_changed = 1 unless $element->val() == $bbox[$i++];
416             }
417 0 0 0     0 return $self if $i == 4 and not $is_changed;
418             }
419              
420 0         0 my $array = PDF::Builder::Basic::PDF::Array->new();
421 0         0 foreach my $element (@bbox[0 .. 3]) {
422 0         0 $array->add_elements(PDFNum($element));
423             }
424 0         0 $self->{$key} = $array;
425              
426 0         0 return $self;
427             }
428              
429             =head2 $p->proc_set(@entries)
430              
431             Ensures that the current resource contains all the entries in the proc_sets
432             listed. If necessary, it creates a local resource dictionary to achieve this.
433              
434             =cut
435              
436             sub proc_set {
437 303     303 1 944 my ($self, @entries) = @_;
438              
439 303         956 my $dict = $self->find_prop('Resources');
440 303 100 66     1152 if ($dict and defined $dict->{'ProcSet'}) {
441 141         405 my @missing = @entries;
442 141         476 foreach my $element ($dict->{'ProcSet'}->elements()) {
443 705         1164 @missing = grep { $_ ne $element } @missing;
  3525         7169  
444             }
445 141 50       472 return $self if scalar @missing == 0;
446 141 50       478 @entries = @missing if defined $self->{'Resources'};
447             }
448              
449 303 50       857 unless (defined $self->{'Resources'}) {
450 303 100       1260 $self->{'Resources'} = $dict ? $dict->copy($self->_pdf()) : PDFDict();
451             }
452              
453 303 50       1248 $self->{'Resources'}{'ProcSet'} = PDFArray() unless defined $self->{'ProcSet'};
454              
455 303         774 foreach my $element (@entries) {
456 1515         4237 $self->{'Resources'}{'ProcSet'}->add_elements(PDFName($element));
457             }
458              
459 303         813 return $self;
460             } # end of proc_set()
461              
462             sub empty {
463 0     0 1 0 my ($self) = @_;
464 0         0 my $parent = $self->{'Parent'};
465              
466 0         0 $self->SUPER::empty();
467 0 0       0 if (defined $parent) {
468 0         0 $self->{'Parent'} = $parent;
469 0         0 weaken $self->{'Parent'};
470             }
471              
472 0         0 return $self;
473             }
474              
475             =head2 $p->get_top()
476              
477             Returns the top of the pages tree.
478              
479             =cut
480              
481             sub get_top {
482 705     705 1 1176 my ($self) = @_;
483              
484 705         985 my $top = $self;
485 705         1706 $top = $top->{'Parent'} while defined $top->{'Parent'};
486              
487 705         1496 return $top->realise();
488             }
489              
490             1;