File Coverage

blib/lib/PDF/API2/Outline.pm
Criterion Covered Total %
statement 163 200 81.5
branch 58 84 69.0
condition 7 22 31.8
subroutine 27 36 75.0
pod 19 27 70.3
total 274 369 74.2


line stmt bran cond sub pod time code
1             package PDF::API2::Outline;
2              
3 2     2   18 use base 'PDF::API2::Basic::PDF::Dict';
  2         5  
  2         254  
4              
5 2     2   13 use strict;
  2         5  
  2         46  
6 2     2   10 use warnings;
  2         4  
  2         108  
7              
8             our $VERSION = '2.043'; # VERSION
9              
10 2     2   13 use Carp qw(croak);
  2         5  
  2         106  
11 2     2   13 use PDF::API2::Basic::PDF::Utils;
  2         5  
  2         205  
12 2     2   19 use Scalar::Util qw(weaken);
  2         4  
  2         4969  
13              
14             =head1 NAME
15              
16             PDF::API2::Outline - Manage PDF outlines (a.k.a. bookmarks)
17              
18             =head1 SYNOPSIS
19              
20             # Get/create the top-level outline tree
21             my $outline = $pdf->outline();
22              
23             # Add an entry
24             my $item = $outline->outline();
25             $item->title('First Page');
26             $item->destination($pdf->open_page(1));
27              
28             =head1 METHODS
29              
30             =cut
31              
32             sub new {
33 17     17 1 37 my ($class, $api, $parent, $prev) = @_;
34 17         44 my $self = $class->SUPER::new();
35 17 100       40 $self->{'Parent'} = $parent if defined $parent;
36 17 50       30 $self->{'Prev'} = $prev if defined $prev;
37 17         25 $self->{' api'} = $api;
38 17         49 weaken $self->{' api'};
39 17         43 weaken $self->{'Parent'};
40 17         32 return $self;
41             }
42              
43             =head2 Examine the Outline Tree
44              
45             =head3 has_children
46              
47             my $boolean = $outline->has_children();
48              
49             Return true if the current outline item has child items.
50              
51             =cut
52              
53             sub has_children {
54 67     67 1 85 my $self = shift();
55              
56             # Opened by PDF::API2
57 67 100       175 return 1 if exists $self->{'First'};
58              
59             # Created by PDF::API2
60 54 100       88 return @{$self->{' children'}} > 0 if exists $self->{' children'};
  18         52  
61              
62 36         82 return;
63             }
64              
65             =head3 count
66              
67             my $integer = $outline->count();
68              
69             Return the number of descendants that are visible when the current outline item
70             is open (expanded).
71              
72             =cut
73              
74             sub count {
75 26     26 1 35 my $self = shift();
76              
77             # Set count to the number of descendant items that will be visible when the
78             # current item is open.
79 26         37 my $count = 0;
80 26 100       46 if ($self->has_children()) {
81 20 100       49 $self->_load_children() unless exists $self->{' children'};
82 20         25 $count += @{$self->{' children'}};
  20         35  
83 20         25 foreach my $child (@{$self->{' children'}}) {
  20         36  
84 39 100       70 next unless $child->has_children();
85 10 100       20 next unless $child->is_open();
86 6         17 $count += $child->count();
87             }
88             }
89              
90 26 100       52 if ($count) {
91 20 100       66 $self->{'Count'} = PDFNum($self->is_open() ? $count : -$count);
92             }
93              
94 26         107 return $count;
95             }
96              
97             sub _load_children {
98 2     2   4 my $self = shift();
99 2         2 my $item = $self->{'First'};
100 2 50       6 return unless $item;
101 2         6 $item->realise();
102 2         5 bless $item, __PACKAGE__;
103              
104 2         2 push @{$self->{' children'}}, $item;
  2         6  
105 2         7 while ($item->next()) {
106 2         5 $item = $item->next();
107 2         7 $item->realise();
108 2         5 bless $item, __PACKAGE__;
109 2         2 push @{$self->{' children'}}, $item;
  2         8  
110             }
111 2         4 return $self;
112             }
113              
114             =head3 first
115              
116             my $child = $outline->first();
117              
118             Return the first child of the current outline level, if one exists.
119              
120             =cut
121              
122             sub first {
123 19     19 1 32 my $self = shift();
124 19 100 66     66 if (defined $self->{' children'} and defined $self->{' children'}->[0]) {
125 14         29 $self->{'First'} = $self->{' children'}->[0];
126             }
127 19         41 return $self->{'First'};
128             }
129              
130             =head3 last
131              
132             my $child = $outline->last();
133              
134             Return the last child of the current outline level, if one exists.
135              
136             =cut
137              
138             sub last {
139 11     11 1 15 my $self = shift();
140 11 100 66     34 if (defined $self->{' children'} and defined $self->{' children'}->[-1]) {
141 6         13 $self->{'Last'} = $self->{' children'}->[-1];
142             }
143 11         18 return $self->{'Last'};
144             }
145              
146             =head3 parent
147              
148             my $parent = $outline->parent();
149              
150             Return the parent of the current item, if not at the top level of the outline
151             tree.
152              
153             =cut
154              
155             sub parent {
156 11     11 1 18 my $self = shift();
157 11 50       21 $self->{'Parent'} = shift() if defined $_[0];
158 11         38 return $self->{'Parent'};
159             }
160              
161             =head3 prev
162              
163             my $sibling = $outline->prev();
164              
165             Return the previous item of the current level of the outline tree.
166              
167             =cut
168              
169             sub prev {
170 25     25 1 47 my $self = shift();
171 25 100       53 $self->{'Prev'} = shift() if defined $_[0];
172 25         65 return $self->{'Prev'};
173             }
174              
175             =head3 next
176              
177             my $sibling = $outline->next();
178              
179             Return the next item of the current level of the outline tree.
180              
181             =cut
182              
183             sub next {
184 67     67 1 91 my $self = shift();
185 67 100       121 $self->{'Next'} = shift() if defined $_[0];
186 67         136 return $self->{'Next'};
187             }
188              
189             =head2 Modify the Outline Tree
190              
191             =head3 outline
192              
193             my $child = $outline->outline();
194              
195             Add an outline item at the end of the current outline's list of children.
196              
197             =cut
198              
199             sub outline {
200 10     10 1 52 my $self = shift();
201              
202 10         19 my $child = PDF::API2::Outline->new($self->{' api'}, $self);
203 10   100     44 $self->{' children'} //= [];
204 10 100       12 $child->prev($self->{' children'}->[-1]) if @{$self->{' children'}};
  10         28  
205 10 100       14 $self->{' children'}->[-1]->next($child) if @{$self->{' children'}};
  10         24  
206 10         13 push @{$self->{' children'}}, $child;
  10         20  
207 10 50       26 unless ($child->is_obj($self->{' api'}->{'pdf'})) {
208 10         31 $self->{' api'}->{'pdf'}->new_obj($child);
209             }
210              
211 10         63 return $child;
212             }
213              
214             =head3 insert_after
215              
216             my $sibling = $outline->insert_after();
217              
218             Add an outline item immediately following the current item.
219              
220             =cut
221              
222             sub insert_after {
223 2     2 1 11 my $self = shift();
224              
225 2         5 my $sibling = PDF::API2::Outline->new($self->{' api'}, $self->parent());
226 2         6 $sibling->next($self->next());
227 2 100       5 $self->next->prev($sibling) if $self->next();
228 2         5 $self->next($sibling);
229 2         6 $sibling->prev($self);
230 2 50       5 unless ($sibling->is_obj($self->{' api'}->{'pdf'})) {
231 2         8 $self->{' api'}->{'pdf'}->new_obj($sibling);
232             }
233 2         5 $self->parent->_reset_children();
234 2         6 return $sibling;
235             }
236              
237             =head3 insert_before
238              
239             $sibling = $outline->insert_before();
240              
241             Add an outline item immediately preceding the current item.
242              
243             =cut
244              
245             sub insert_before {
246 2     2 1 5 my $self = shift();
247              
248 2         6 my $sibling = PDF::API2::Outline->new($self->{' api'}, $self->parent());
249 2         4 $sibling->prev($self->prev());
250 2 100       5 $self->prev->next($sibling) if $self->prev();
251 2         4 $self->prev($sibling);
252 2         5 $sibling->next($self);
253 2 50       5 unless ($sibling->is_obj($self->{' api'}->{'pdf'})) {
254 2         8 $self->{' api'}->{'pdf'}->new_obj($sibling);
255             }
256 2         5 $self->parent->_reset_children();
257 2         5 return $sibling;
258             }
259              
260             sub _reset_children {
261 4     4   5 my $self = shift();
262 4         11 my $item = $self->first();
263 4         8 $self->{' children'} = [];
264 4 50       10 return unless $item;
265              
266 4         5 push @{$self->{' children'}}, $item;
  4         11  
267 4         8 while ($item->next()) {
268 16         24 $item = $item->next();
269 16         18 push @{$self->{' children'}}, $item;
  16         31  
270             }
271 4         6 return $self;
272             }
273              
274             =head3 delete
275              
276             $outline->delete();
277              
278             Remove the current outline item from the outline tree. If the item has any
279             children, they will effectively be deleted as well since they will no longer be
280             linked.
281              
282             =cut
283              
284             sub delete {
285 1     1 1 2 my $self = shift();
286              
287 1         3 my $prev = $self->prev();
288 1         3 my $next = $self->next();
289 1 50       3 $prev->next($next) if defined $prev;
290 1 50       3 $next->prev($prev) if defined $next;
291              
292 1         3 my $siblings = $self->parent->{' children'};
293 1         2 @$siblings = grep { $_ ne $self } @$siblings;
  1         5  
294 1 50       3 delete $self->parent->{' children'} unless $self->parent->has_children();
295              
296 1         3 return;
297             }
298              
299             =head3 is_open
300              
301             # Get
302             my $boolean = $outline->is_open();
303              
304             # Set
305             my $outline = $outline->is_open($boolean);
306              
307             Get/set whether the outline is expanded or collapsed.
308              
309             =cut
310              
311             sub is_open {
312 33     33 1 48 my $self = shift();
313              
314             # Get
315 33 100       64 unless (@_) {
316             # Created by PDF::API2
317 32 50       80 return $self->{' closed'} ? 0 : 1 if exists $self->{' closed'};
    100          
318              
319             # Opened by PDF::API2
320 26 100       70 return $self->{'Count'}->val() > 0 if exists $self->{'Count'};
321              
322             # Default
323 7         25 return 1;
324             }
325              
326             # Set
327 1         2 my $is_open = shift();
328 1         3 $self->{' closed'} = (not $is_open);
329              
330 1         2 return $self;
331             }
332              
333             # Deprecated
334             sub open {
335 0     0 0 0 my $self = shift();
336 0         0 return $self->is_open(1);
337             }
338              
339             # Deprecated
340             sub closed {
341 0     0 0 0 my $self = shift();
342 0         0 return $self->is_open(0);
343             }
344              
345             =head2 Set Outline Attributes
346              
347             =head3 title
348              
349             # Get
350             my $title = $outline->title();
351              
352             # Set
353             $outline = $outline->title($text);
354              
355             Get/set the title of the outline item.
356              
357             =cut
358              
359             sub title {
360 4     4 1 20 my $self = shift();
361              
362             # Get
363 4 100       13 unless (@_) {
364 1 50       4 return unless $self->{'Title'};
365 1         4 return $self->{'Title'}->val();
366             }
367              
368             # Set
369 3         7 my $text = shift();
370 3         19 $self->{'Title'} = PDFStr($text);
371 3         6 return $self;
372             }
373              
374             =head3 destination
375              
376             $outline = $outline->destination($destination, $location, @args);
377              
378             Set the destination page and optional position of the outline. C<$location> and
379             C<@args> are as defined in L.
380              
381             C<$destination> can optionally be the name of a named destination defined
382             elsewhere.
383              
384             =cut
385              
386             sub _destination {
387 2     2   12 require PDF::API2::NamedDestination;
388 2         7 return PDF::API2::NamedDestination::_destination(@_);
389             }
390              
391             sub destination {
392 2     2 1 5 my ($self, $destination, $location, @args) = @_;
393              
394             # Remove an existing action dictionary
395 2         3 delete $self->{'A'};
396              
397 2 50       5 if (ref($destination)) {
398             # Page Destination
399 2         6 $self->{'Dest'} = _destination($destination, $location, @args);
400             }
401             else {
402             # Named Destination
403 0         0 $self->{'Dest'} = PDFStr($destination);
404             }
405              
406 2         7 return $self;
407             }
408              
409             # Deprecated: Use destination with the indicated changes
410             sub dest {
411 2     2 0 27 my ($self, $destination, $location, @args) = @_;
412              
413             # Replace -fit => 1 or -fitb => 1 with just the location
414 2 50       7 if (defined $location) {
415 0 0 0     0 @args = () if $location eq '-fit' or $location eq '-fitb';
416             }
417              
418             # Convert args from arrayref to array
419 2 50 33     6 @args = @{$args[0]} if @args and ref($args[0]) eq 'ARRAY';
  0         0  
420              
421             # Remove hyphen prefix from location
422 2 50       4 $location =~ s/^-// if defined $location;
423              
424 2         5 return $self->destination($destination, $location, @args);
425             }
426              
427             =head3 uri
428              
429             $outline = $outline->uri($uri);
430              
431             Launch a URI -- typically a web page -- when the outline item is activated.
432              
433             =cut
434              
435             # Deprecated (renamed)
436 0     0 0 0 sub url { return uri(@_) }
437              
438             sub uri {
439 0     0 1 0 my ($self, $uri) = @_;
440 0         0 delete $self->{'Dest'};
441              
442 0         0 $self->{'A'} = PDFDict();
443 0         0 $self->{'A'}->{'S'} = PDFName('URI');
444 0         0 $self->{'A'}->{'URI'} = PDFStr($uri);
445              
446 0         0 return $self;
447             }
448              
449             =head3 launch
450              
451             $outline->launch($file);
452              
453             Launch an application or file when the outline item is activated.
454              
455             =cut
456              
457             # Deprecated (renamed)
458 0     0 0 0 sub file { return launch(@_) }
459              
460             sub launch {
461 0     0 1 0 my ($self, $file) = @_;
462 0         0 delete $self->{'Dest'};
463              
464 0         0 $self->{'A'} = PDFDict();
465 0         0 $self->{'A'}->{'S'} = PDFName('Launch');
466 0         0 $self->{'A'}->{'F'} = PDFStr($file);
467              
468 0         0 return $self;
469             }
470              
471             =head3 pdf
472              
473             $outline = $outline->pdf($filename, $page_number, $location, @args);
474              
475             Open another PDF file to a particular page number (first page is zero, which is
476             also the default). The page can optionally be positioned at a particular
477             location if C<$location> and C<@args> are set -- see
478             L for possible settings.
479              
480             =cut
481              
482             # Deprecated (renamed)
483 0     0 0 0 sub pdfile { return pdf_file(@_) }
484              
485             # Deprecated; use pdf instead, with the indicated changes
486             sub pdf_file {
487 0     0 0 0 my ($self, $file, $page_number, $location, @args);
488              
489             # Replace -fit => 1 or -fitb => 1 with just the location
490 0 0       0 if (defined $location) {
491 0 0 0     0 @args = () if $location eq '-fit' or $location eq '-fitb';
492             }
493              
494             # Convert args from arrayref to array
495 0 0 0     0 @args = @{$args[0]} if @args and ref($args[0]) eq 'ARRAY';
  0         0  
496              
497             # Remove hyphen prefix from location
498 0 0       0 $location =~ s/^-// if defined $location;
499              
500 0         0 return $self->pdf($file, $page_number, $location, @args);
501             }
502              
503             sub pdf {
504 0     0 1 0 my ($self, $file, $page_number, $location, @args) = @_;
505 0   0     0 $page_number //= 0;
506 0         0 delete $self->{'Dest'};
507              
508 0         0 $self->{'A'} = PDFDict();
509 0         0 $self->{'A'}->{'S'} = PDFName('GoToR');
510 0         0 $self->{'A'}->{'F'} = PDFStr($file);
511              
512 0         0 $self->{'A'}->{'D'} = _destination(PDFNum($page_number), $location, @args);
513              
514 0         0 return $self;
515             }
516              
517             sub fix_outline {
518 9     9 0 21 my $self = shift();
519 9         32 $self->first();
520 9         23 $self->last();
521 9         18 $self->count();
522             }
523              
524             sub outobjdeep {
525 9     9 1 15 my $self = shift();
526 9         24 $self->fix_outline();
527 9         26 return $self->SUPER::outobjdeep(@_);
528             }
529              
530             1;