line
stmt
bran
cond
sub
pod
time
code
1
package PDF::Builder;
2
3
34
34
2463283
use strict;
34
359
34
1094
4
34
34
175
use warnings;
34
65
34
3229
5
6
# $VERSION defined here so developers can run PDF::Builder from git.
7
# it should be automatically updated as part of the CPAN build.
8
our $VERSION = '3.023'; # VERSION
9
our $LAST_UPDATE = '3.023'; # manually update whenever code is changed
10
11
my $GrTFversion = 16; # minimum version of Graphics::TIFF
12
my $LpngVersion = 0.57; # minimum version of Image::PNG::Libpng
13
14
34
34
267
use Carp;
34
67
34
2524
15
34
34
21557
use Encode qw(:all);
34
370082
34
9289
16
34
34
16373
use FileHandle;
34
340092
34
212
17
18
34
34
29144
use PDF::Builder::Basic::PDF::Utils;
34
123
34
3096
19
34
34
18806
use PDF::Builder::Util;
34
132
34
5680
20
21
34
34
26388
use PDF::Builder::Basic::PDF::File;
34
116
34
1589
22
34
34
352
use PDF::Builder::Basic::PDF::Pages;
34
74
34
725
23
34
34
20575
use PDF::Builder::Page;
34
130
34
1622
24
25
34
34
21266
use PDF::Builder::Resource::XObject::Form::Hybrid;
34
114
34
1260
26
27
34
34
17808
use PDF::Builder::Resource::ExtGState;
34
111
34
1301
28
34
34
16288
use PDF::Builder::Resource::Pattern;
34
103
34
1118
29
34
34
15375
use PDF::Builder::Resource::Shading;
34
100
34
1158
30
31
34
34
15676
use PDF::Builder::NamedDestination;
34
104
34
1318
32
33
34
34
240
use Scalar::Util qw(weaken);
34
74
34
470595
34
35
our @FontDirs = ( (map { "$_/PDF/Builder/fonts" } @INC),
36
qw[ /usr/share/fonts /usr/local/share/fonts c:/windows/fonts c:/winnt/fonts ] );
37
our @MSG_COUNT = (0, # [0] Graphics::TIFF not installed
38
0, # [1] Image::PNG::Libpng not installed
39
0, # [2] TBD...
40
);
41
our $outVer = 1.4; # desired PDF version for output, bump up w/ warning on read or feature output
42
our $msgVer = 1; # 0=don't, 1=do issue message when PDF output version is bumped up
43
our $myself; # holds self->pdf
44
45
=head1 NAME
46
47
PDF::Builder - Facilitates the creation and modification of PDF files
48
49
=head1 SYNOPSIS
50
51
use PDF::Builder;
52
53
# Create a blank PDF file
54
$pdf = PDF::Builder->new();
55
56
# Open an existing PDF file
57
$pdf = PDF::Builder->open('some.pdf');
58
59
# Add a blank page
60
$page = $pdf->page();
61
62
# Retrieve an existing page
63
$page = $pdf->open_page($page_number);
64
65
# Set the page size
66
$page->mediabox('Letter');
67
68
# Add a built-in font to the PDF
69
$font = $pdf->corefont('Helvetica-Bold');
70
71
# Add an external TTF font to the PDF
72
$font = $pdf->ttfont('/path/to/font.ttf');
73
74
# Add some text to the page
75
$text = $page->text();
76
$text->font($font, 20);
77
$text->translate(200, 700);
78
$text->text('Hello World!');
79
80
# Save the PDF
81
$pdf->saveas('/path/to/new.pdf');
82
83
=head1 SOME SPECIAL NOTES
84
85
See the file README (in downloadable package and on CPAN) for a summary of
86
prerequisites and tools needed to install PDF::Builder, both mandatory and
87
optional.
88
89
=head2 SOFTWARE DEVELOPMENT KIT
90
91
There are four levels of involvement with PDF::Builder. Depending on what you
92
want to do, different kinds of installs are recommended.
93
See L for suggestions.
94
95
=head2 OPTIONAL LIBRARIES
96
97
PDF::Builder can make use of some optional libraries, which are not I
98
for a successful installation, but improve speed and capabilities. See
99
L for more information.
100
101
=head2 STRINGS (CHARACTER TEXT)
102
103
There are some things you should know about character encoding (for text),
104
before you dive in to coding. Please go to L and have a read.
105
106
=head2 RENDERING ORDER
107
108
Invoking "text" and "graphics" methods can lead to unexpected results (a
109
different ordering of output than intended). See L for more information.
110
111
=head2 PDF VERSIONS SUPPORTED
112
113
PDF::Builder is mostly PDF 1.4-compliant, but there I complications you
114
should be aware of. Please read L
115
for details.
116
117
=head2 SUPPORTED PERL VERSIONS
118
119
PDF::Builder intends to support all major Perl versions that were released in
120
the past six years, plus one, in order to continue working for the life of
121
most long-term-stable (LTS) server distributions.
122
See the L table
123
B x.xxxx0 "Major" release dates.
124
125
For example, a version of PDF::Builder released on 2018-06-05 would support
126
the last major version of Perl released I 2012-06-05 (5.18), and
127
then one before that, which would be 5.16. Alternatively, the last major
128
version of Perl released I 2012-06-05 is 5.16.
129
130
The intent is to avoid expending unnecessary effort in supporting very old
131
(obsolete) versions of Perl.
132
If you need to use this module on a server with an extremely out-of-date version
133
of Perl, consider using either plenv or Perlbrew to run a newer version of Perl
134
without needing admin privileges.
135
136
=head2 KNOWN ISSUES
137
138
This module does not work with perl's -l command-line switch.
139
140
There is a file INFO/KNOWN_INCOMP which lists known incompatibilities with
141
PDF::API2, in case you're thinking of porting over something from that world,
142
or have experience there and want to try PDF::Builder. There is also a file
143
INFO/DEPRECATED, which lists things which are planned to be removed at some
144
point.
145
146
=head2 HISTORY
147
148
The history of PDF::Builder is a complex and exciting saga... OK, it may be
149
mildly interesting. Have a look at L section.
150
151
=head1 AUTHOR
152
153
PDF::API2 was originally written by Alfred Reibenschuh. See the HISTORY section
154
for more information.
155
156
It was maintained by Steve Simms.
157
158
PDF::Builder is currently being maintained by Phil M. Perry.
159
160
=head2 SUPPORT
161
162
The full source is on https://github.com/PhilterPaper/Perl-PDF-Builder.
163
164
The release distribution is on CPAN: https://metacpan.org/pod/PDF::Builder.
165
166
Bug reports are on https://github.com/PhilterPaper/Perl-PDF-Builder/issues?q=is%3Aissue+sort%3Aupdated-desc (with "bug" label), feature requests have an "enhancement" label, and general discussions (architecture, roadmap, etc.) have a "general discussion" label.
167
168
Do B under I circumstances open a PR (Pull Request) to report a bug. It is a waste of both your and our time and effort. Open a regular ticket (issue), and attach a Perl (.pl) program illustrating the problem, if possible. If you believe that you have a program patch, and offer to share it as a PR, we may give the go-ahead. Unsolicited PRs may be closed without further action.
169
170
=head1 LICENSE
171
172
This software is Copyright (c) 2017-2021 by Phil M. Perry.
173
174
This is free software, licensed under:
175
176
The GNU Lesser General Public License (LGPL) Version 2.1, February 1999
177
178
(The master copy of this license lives on the GNU website.)
179
(A copy is provided in the INFO/LICENSE file for your convenience.)
180
181
This section of Builder.pm is intended only as a very brief summary
182
of the license; please consider INFO/LICENSE to be the controlling version,
183
if there is any conflict or ambiguity between the two.
184
185
This program is free software; you can redistribute it and/or modify it under
186
the terms of the GNU Lesser General Public License, as published by the Free
187
Software Foundation, either version 2.1 of the License, or (at your option) any
188
later version of this license.
189
190
NOTE: there are several files in this distribution which were incorporated from
191
outside sources and carry different licenses. If a file states that it is under
192
a license different than LGPL 2.1, that license and its terms will apply to
193
that file, and not LGPL 2.1.
194
195
This library is distributed in the hope that it will be useful, but WITHOUT ANY
196
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
197
PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details.
198
199
=head1 GENERIC METHODS
200
201
=over
202
203
=item $pdf = PDF::Builder->new(%options)
204
205
=item $pdf = PDF::Builder->new()
206
207
Creates a new PDF object.
208
209
B
210
211
=over
212
213
=item -file
214
215
If you will be saving it as a file and
216
already know the filename, you can give the '-file' option to minimize
217
possible memory requirements later on.
218
219
=item -compress
220
221
The '-compress' option can be
222
given to specify stream compression: default is 'flate', 'none' is no
223
compression. No other compression methods are currently supported.
224
225
=item -outver
226
227
The '-outver' option defaults to 1.4 as the output PDF version and the highest
228
allowed feature version (attempts to use anything higher will give a warning).
229
If an existing PDF with a higher version is read in, -outver will be increased
230
to that version, with a warning.
231
232
=item -msgver
233
234
The '-msgver' option value of 1 (default) gives a warning message if the
235
'-outver' PDF level has to be bumped up due to either a higher PDF level file
236
being read in, or a higher level feature was requested. A value of 0
237
suppresses the warning message.
238
239
=item -diaglevel
240
241
The '-diaglevel' option can be
242
given to specify the level of diagnostics given by IntegrityCheck(). The
243
default is level 2 (errors and warnings).
244
See L for more information.
245
246
=back
247
248
B
249
250
$pdf = PDF::Builder->new();
251
...
252
print $pdf->stringify();
253
254
$pdf = PDF::Builder->new(-compress => 'none');
255
# equivalent to $pdf->{'forcecompress'} = 'none'; (or older, 0)
256
257
$pdf = PDF::Builder->new();
258
...
259
$pdf->saveas('our/new.pdf');
260
261
$pdf = PDF::Builder->new(-file => 'our/new.pdf');
262
...
263
$pdf->save();
264
265
=cut
266
267
sub new {
268
162
162
1
16237
my ($class, %options) = @_;
269
270
162
443
my $self = {};
271
162
426
bless $self, $class;
272
162
1275
$self->{'pdf'} = PDF::Builder::Basic::PDF::File->new();
273
274
# make available to other routines
275
162
658
$myself = $self->{'pdf'};
276
277
# default output version
278
162
595
$self->{'pdf'}->{' version'} = $outVer;
279
162
1140
$self->{'pages'} = PDF::Builder::Basic::PDF::Pages->new($self->{'pdf'});
280
162
803
$self->{'pages'}->proc_set(qw(PDF Text ImageB ImageC ImageI));
281
162
33
649
$self->{'pages'}->{'Resources'} ||= PDFDict();
282
162
50
745
$self->{'pdf'}->new_obj($self->{'pages'}->{'Resources'}) unless $self->{'pages'}->{'Resources'}->is_obj($self->{'pdf'});
283
162
456
$self->{'catalog'} = $self->{'pdf'}->{'Root'};
284
162
667
weaken $self->{'catalog'};
285
162
353
$self->{'fonts'} = {};
286
162
416
$self->{'pagestack'} = [];
287
288
162
372
$self->{'pdf'}->{' userUnit'} = 1.0; # default global User Unit
289
162
610
$self->mediabox('letter'); # default to US Letter 8.5in x 11in
290
291
162
100
513
if (exists $options{'-compress'}) {
292
107
311
$self->{'forcecompress'} = $options{'-compress'};
293
# at this point, no validation of given value! none/flate (0/1).
294
# note that >0 is often used as equivalent to 'flate'
295
} else {
296
55
164
$self->{'forcecompress'} = 'flate';
297
# code should also allow integers 0 (= 'none') and >0 (= 'flate')
298
# for compatibility with old usage where forcecompress is directly set.
299
}
300
162
50
440
if (exists $options{'-diaglevel'}) {
301
0
0
my $diaglevel = $options{'-diaglevel'};
302
0
0
0
0
if ($diaglevel < 0 || $diaglevel > 5) {
303
0
0
print "-diaglevel must be in range 0-5. using 2\n";
304
0
0
$diaglevel = 2;
305
}
306
0
0
$self->{'diaglevel'} = $diaglevel;
307
} else {
308
162
363
$self->{'diaglevel'} = 2; # default: errors and warnings
309
}
310
311
162
820
$self->preferences(%options);
312
162
100
452
if (defined $options{'-outver'}) {
313
2
50
9
if ($options{'-outver'} >= 1.4) {
314
2
6
$self->{'pdf'}->{' version'} = $outVer = $options{'-outver'};
315
} else {
316
0
0
print STDERR "Invalid -outver given, or less than 1.4. Ignored.\n";
317
}
318
}
319
162
50
453
if (defined $options{'-msgver'}) {
320
0
0
0
0
if ($options{'-msgver'} == 0 || $options{'-msgver'} == 1) {
321
0
0
$msgVer = $options{'-msgver'};
322
} else {
323
0
0
print STDERR "Invalid -msgver given, not 0 or 1. Ignored.\n";
324
}
325
}
326
162
50
410
if ($options{'-file'}) {
327
0
0
$self->{'pdf'}->create_file($options{'-file'});
328
0
0
$self->{'partial_save'} = 1;
329
}
330
162
794
$self->{'infoMeta'} = [qw(Author CreationDate ModDate Creator Producer Title Subject Keywords)];
331
332
162
50
333
my $version = eval { $PDF::Builder::VERSION } || '(Unreleased Version)';
333
#$self->info('Producer' => "PDF::Builder $version [$^O]");
334
162
928
$self->info('Producer' => "PDF::Builder $version [see https://github.com/PhilterPaper/Perl-PDF-Builder/blob/master/INFO/SUPPORT]");
335
336
162
1806
return $self;
337
} # end of new()
338
339
=item $pdf = PDF::Builder->open($pdf_file, %options)
340
341
=item $pdf = PDF::Builder->open($pdf_file)
342
343
Opens an existing PDF file. See C for options.
344
345
B
346
347
$pdf = PDF::Builder->open('our/old.pdf');
348
...
349
$pdf->saveas('our/new.pdf');
350
351
$pdf = PDF::Builder->open('our/to/be/updated.pdf');
352
...
353
$pdf->update();
354
355
=cut
356
357
sub open { ## no critic
358
8
8
1
1589
my ($class, $file, %options) = @_;
359
8
50
174
croak "File '$file' does not exist" unless -f $file;
360
8
50
116
croak "File '$file' is not readable" unless -r $file;
361
362
8
24
my $content;
363
8
74
my $scalar_fh = FileHandle->new();
364
8
50
24
641
CORE::open($scalar_fh, '+<', \$content) or die "Can't begin scalar IO";
24
213
24
55
24
219
365
8
4071
binmode $scalar_fh, ':raw';
366
367
8
45
my $disk_fh = FileHandle->new();
368
8
50
518
CORE::open($disk_fh, '<', $file) or die "Can't open $file for reading: $!";
369
8
55
binmode $disk_fh, ':raw';
370
8
58
$disk_fh->seek(0, 0);
371
8
103
my $data;
372
8
42
while (not $disk_fh->eof()) {
373
49
772
$disk_fh->read($data, 512);
374
49
334
$scalar_fh->print($data);
375
}
376
# check if final %%EOF lacks a carriage return on the end (add one)
377
8
50
148
if ($data =~ m/%%EOF$/) {
378
#print "open() says missing final EOF\n";
379
8
30
$scalar_fh->print("\n");
380
}
381
8
66
$disk_fh->close();
382
8
151
$scalar_fh->seek(0, 0);
383
384
8
87
my $self = $class->open_scalar($content, %options);
385
8
29
$self->{'pdf'}->{' fname'} = $file;
386
387
8
107
return $self;
388
} # end of open()
389
390
# when outputting a PDF feature, verCheckOutput(n, 'feature name') returns TRUE
391
# if n > $pdf->{' version'), plus a warning message. It returns FALSE otherwise.
392
#
393
# a typical use:
394
#
395
# PDF::Builder->verCheckOutput(1.6, "portzebie with foo-dangle");
396
#
397
# if -msgver defaults to 1, a message will be output if the output PDF version
398
# has to be increased to 1.6 in order to use the "portzebie" feature
399
#
400
# this is still somewhat experimental, and as experience is gained, the code
401
# might have to be modified.
402
#
403
sub verCheckOutput {
404
3
3
0
10
my ($dummy, $PDFver, $featureName) = @_; # $self will be this package's
405
406
# check if feature required PDF version is higher than planned output
407
# ' version' should be the same as $outVer
408
3
50
23
if ($PDFver > $outVer) {
409
0
0
0
if ($msgVer) {
410
0
0
print "PDF version of requested feature '$featureName'\n is higher than outVer of $outVer (outVer reset to $PDFver)\n";
411
}
412
0
0
$outVer = $myself->{' version'} = $PDFver;
413
0
0
return 1;
414
} else {
415
3
10
return 0;
416
}
417
}
418
# when reading in a PDF, verCheckInput(n) gives a warning message if n (the PDF
419
# version just read in) > outVer, and resets outVer to n. return TRUE if
420
# outVer changed, FALSE otherwise. outVer is used instead of
421
# $pdf->{' version'} because the latter is often overwritten by a file read
422
# operation.
423
#
424
# this is still somewhat experimental, and as experience is gained, the code
425
# might have to be modified.
426
#
427
# WARNING: just because the PDF output version has been increased does NOT
428
# guarantee that any particular content will be handled correctly! There are
429
# many known cases of PDF 1.5 and up files being read in, that have content
430
# that PDF::Builder does not handle correctly, corrupting the resulting PDF.
431
# Pay attention to run-time warning messages that the PDF output level has
432
# been increased due to a PDF file being read in, and check the resulting
433
# file carefully.
434
435
sub verCheckInput {
436
15
15
0
49
my ($self, $PDFver) = @_;
437
438
# warning message and bump up outVer if read-in PDF level higher
439
15
50
78
if ($PDFver > $outVer) {
440
0
0
0
if ($msgVer) {
441
0
0
print "PDF version just read in is higher than outVer of $outVer (outVer reset to $PDFver)\n";
442
}
443
0
0
$outVer = $self->{'pdf'}->{' version'} = $PDFver;
444
0
0
return 1;
445
} else {
446
15
35
return 0;
447
}
448
}
449
450
=item $pdf = PDF::Builder->open_scalar($pdf_string, %options)
451
452
=item $pdf = PDF::Builder->open_scalar($pdf_string)
453
454
Opens a PDF contained in a string. See C for other options.
455
456
=over
457
458
=item -diags => 1
459
460
Display warnings when non-conforming PDF structure is found, and fix up
461
where possible. See L for more information.
462
463
=back
464
465
B
466
467
# Read a PDF into a string, for the purpose of demonstration
468
open $fh, 'our/old.pdf' or die $@;
469
undef $/; # Read the whole file at once
470
$pdf_string = <$fh>;
471
472
$pdf = PDF::Builder->open_scalar($pdf_string);
473
...
474
$pdf->saveas('our/new.pdf');
475
476
477
=cut
478
479
sub open_scalar {
480
15
15
1
1409
my ($class, $content, %options) = @_;
481
482
15
38
my $self = {};
483
15
41
bless $self, $class;
484
15
48
foreach my $parameter (keys %options) {
485
3
12
$self->default($parameter, $options{$parameter});
486
}
487
488
15
76
$self->{'content_ref'} = \$content;
489
15
107
my $diaglevel = 2;
490
15
50
72
if (defined $self->{'diaglevel'}) { $diaglevel = $self->{'diaglevel'}; }
0
0
491
15
50
33
101
if ($diaglevel < 0 || $diaglevel > 5) { $diaglevel = 2; }
0
0
492
15
73
my $newVer = $self->IntegrityCheck($diaglevel, $content);
493
# if Version override defined in PDF, need to overwrite the %PDF-x.y
494
# statement with the new (if higher) value. it's too late to wait until
495
# after File->open, as it's already complained about some >1.4 features.
496
15
50
49
if (defined $newVer) {
497
0
0
my ($verStr, $currentVer, $pos);
498
0
0
$pos = index $content, "%PDF-";
499
0
0
0
if ($pos < 0) { die "no PDF version found in PDF input!\n"; }
0
0
500
# assume major and minor PDF version numbers max 2 digits each for now
501
# (are 1 or 2 and 0-7 at this writing)
502
0
0
$verStr = substr($content, $pos, 10);
503
0
0
0
if ($verStr =~ m#^%PDF-(\d+)\.(\d+)#) {
504
0
0
$currentVer = "$1.$2";
505
} else {
506
0
0
die "unable to get PDF input's version number.\n";
507
}
508
0
0
0
if ($newVer > $currentVer) {
509
0
0
0
if (length($newVer) > length($currentVer)) {
510
0
0
print STDERR "Unable to update 'content' version because override '$newVer' is longer than header version '$currentVer'.\nYou may receive warnings about features that bump up the PDF level.\n";
511
} else {
512
0
0
0
if (length($newVer) < length($currentVer)) {
513
# unlikely, but cover all the bases
514
0
0
$newVer = substr($newVer, 0, length($currentVer));
515
}
516
0
0
substr($content, $pos+5, length($newVer)) = $newVer;
517
0
0
$outVer = $newVer;
518
}
519
}
520
}
521
522
15
28
my $fh;
523
15
50
253
CORE::open($fh, '+<', \$content) or die "Can't begin scalar IO";
524
525
# this would replace any existing self->pdf with a new one
526
15
172
$self->{'pdf'} = PDF::Builder::Basic::PDF::File->open($fh, 1, %options);
527
15
83
$self->{'pdf'}->{'Root'}->realise();
528
15
90
$self->{'pages'} = $self->{'pdf'}->{'Root'}->{'Pages'}->realise();
529
15
75
weaken $self->{'pages'};
530
531
15
50
59
$self->{'pdf'}->{' version'} ||= 1.4; # default minimum
532
# if version higher than desired output PDF level, give warning and
533
# bump up desired output PDF level
534
15
98
$self->verCheckInput($self->{'pdf'}->{' version'});
535
536
15
67
my @pages = _proc_pages($self->{'pdf'}, $self->{'pages'});
537
15
68
$self->{'pagestack'} = [sort { $a->{' pnum'} <=> $b->{' pnum'} } @pages];
2
9
538
15
33
weaken $self->{'pagestack'}->[$_] for (0 .. scalar @{$self->{'pagestack'}});
15
149
539
15
57
$self->{'catalog'} = $self->{'pdf'}->{'Root'};
540
15
75
weaken $self->{'catalog'};
541
15
35
$self->{'opened_scalar'} = 1;
542
15
100
75
if (exists $options{'-compress'}) {
543
3
8
$self->{'forcecompress'} = $options{'-compress'};
544
# at this point, no validation of given value! none/flate (0/1).
545
# note that >0 is often used as equivalent to 'flate'
546
} else {
547
12
52
$self->{'forcecompress'} = 'flate';
548
# code should also allow integers 0 (= 'none') and >0 (= 'flate')
549
# for compatibility with old usage where forcecompress is directly set.
550
}
551
15
50
50
if (exists $options{'-diaglevel'}) {
552
0
0
$self->{'diaglevel'} = $options{'-diaglevel'};
553
0
0
0
0
if ($self->{'diaglevel'} < 0 || $self->{'diaglevel'} > 5) {
554
0
0
$self->{'diaglevel'} = 2;
555
}
556
} else {
557
15
45
$self->{'diaglevel'} = 2;
558
}
559
15
48
$self->{'fonts'} = {};
560
15
80
$self->{'infoMeta'} = [qw(Author CreationDate ModDate Creator Producer Title Subject Keywords)];
561
562
15
87
return $self;
563
} # end of open_scalar()
564
565
=item $pdf->preferences(%options)
566
567
Controls viewing preferences for the PDF, including the B,
568
B, B, and B Options. See
569
L for details on all these
570
option groups.
571
572
=cut
573
574
sub preferences {
575
167
167
1
477
my ($self, %options) = @_;
576
577
# Page Mode Options
578
167
50
768
if ($options{'-fullscreen'}) {
50
50
579
0
0
$self->{'catalog'}->{'PageMode'} = PDFName('FullScreen');
580
} elsif ($options{'-thumbs'}) {
581
0
0
$self->{'catalog'}->{'PageMode'} = PDFName('UseThumbs');
582
} elsif ($options{'-outlines'}) {
583
0
0
$self->{'catalog'}->{'PageMode'} = PDFName('UseOutlines');
584
} else {
585
167
488
$self->{'catalog'}->{'PageMode'} = PDFName('UseNone');
586
}
587
588
# Page Layout Options
589
167
50
5586
if ($options{'-singlepage'}) {
50
50
50
590
0
0
$self->{'catalog'}->{'PageLayout'} = PDFName('SinglePage');
591
} elsif ($options{'-onecolumn'}) {
592
0
0
$self->{'catalog'}->{'PageLayout'} = PDFName('OneColumn');
593
} elsif ($options{'-twocolumnleft'}) {
594
0
0
$self->{'catalog'}->{'PageLayout'} = PDFName('TwoColumnLeft');
595
} elsif ($options{'-twocolumnright'}) {
596
0
0
$self->{'catalog'}->{'PageLayout'} = PDFName('TwoColumnRight');
597
} else {
598
167
511
$self->{'catalog'}->{'PageLayout'} = PDFName('SinglePage');
599
}
600
601
# Viewer Preferences
602
167
66
829
$self->{'catalog'}->{'ViewerPreferences'} ||= PDFDict();
603
167
700
$self->{'catalog'}->{'ViewerPreferences'}->realise();
604
605
167
50
464
if ($options{'-hidetoolbar'}) {
606
0
0
$self->{'catalog'}->{'ViewerPreferences'}->{'HideToolbar'} = PDFBool(1);
607
}
608
167
50
418
if ($options{'-hidemenubar'}) {
609
0
0
$self->{'catalog'}->{'ViewerPreferences'}->{'HideMenubar'} = PDFBool(1);
610
}
611
167
50
401
if ($options{'-hidewindowui'}) {
612
0
0
$self->{'catalog'}->{'ViewerPreferences'}->{'HideWindowUI'} = PDFBool(1);
613
}
614
167
50
402
if ($options{'-fitwindow'}) {
615
0
0
$self->{'catalog'}->{'ViewerPreferences'}->{'FitWindow'} = PDFBool(1);
616
}
617
167
50
380
if ($options{'-centerwindow'}) {
618
0
0
$self->{'catalog'}->{'ViewerPreferences'}->{'CenterWindow'} = PDFBool(1);
619
}
620
167
50
399
if ($options{'-displaytitle'}) {
621
0
0
$self->{'catalog'}->{'ViewerPreferences'}->{'DisplayDocTitle'} = PDFBool(1);
622
}
623
167
50
384
if ($options{'-righttoleft'}) {
624
0
0
$self->{'catalog'}->{'ViewerPreferences'}->{'Direction'} = PDFName('R2L');
625
}
626
627
167
50
478
if ($options{'-afterfullscreenthumbs'}) {
50
628
0
0
$self->{'catalog'}->{'ViewerPreferences'}->{'NonFullScreenPageMode'} = PDFName('UseThumbs');
629
} elsif ($options{'-afterfullscreenoutlines'}) {
630
0
0
$self->{'catalog'}->{'ViewerPreferences'}->{'NonFullScreenPageMode'} = PDFName('UseOutlines');
631
} else {
632
167
393
$self->{'catalog'}->{'ViewerPreferences'}->{'NonFullScreenPageMode'} = PDFName('UseNone');
633
}
634
635
167
50
422
if ($options{'-printscalingnone'}) {
636
0
0
$self->{'catalog'}->{'ViewerPreferences'}->{'PrintScaling'} = PDFName('None');
637
}
638
639
167
100
645
if ($options{'-simplex'}) {
100
100
640
1
3
$self->{'catalog'}->{'ViewerPreferences'}->{'Duplex'} = PDFName('Simplex');
641
} elsif ($options{'-duplexfliplongedge'}) {
642
1
3
$self->{'catalog'}->{'ViewerPreferences'}->{'Duplex'} = PDFName('DuplexFlipLongEdge');
643
} elsif ($options{'-duplexflipshortedge'}) {
644
1
3
$self->{'catalog'}->{'ViewerPreferences'}->{'Duplex'} = PDFName('DuplexFlipShortEdge');
645
}
646
647
# Open Action
648
167
100
385
if ($options{'-firstpage'}) {
649
2
4
my ($page, %args) = @{$options{'-firstpage'}};
2
6
650
2
50
7
$args{'-fit'} = 1 unless scalar keys %args;
651
652
# $page can be either a page number (which needs to be wrapped
653
# in PDFNum) or a page object (which doesn't).
654
2
100
7
$page = PDFNum($page) unless ref($page);
655
656
2
50
5
if (defined $args{'-fit'}) {
0
0
0
0
0
0
0
657
2
6
$self->{'catalog'}->{'OpenAction'} = PDFArray($page, PDFName('Fit'));
658
} elsif (defined $args{'-fith'}) {
659
0
0
$self->{'catalog'}->{'OpenAction'} = PDFArray($page, PDFName('FitH'), PDFNum($args{'-fith'}));
660
} elsif (defined $args{'-fitb'}) {
661
0
0
$self->{'catalog'}->{'OpenAction'} = PDFArray($page, PDFName('FitB'));
662
} elsif (defined $args{'-fitbh'}) {
663
0
0
$self->{'catalog'}->{'OpenAction'} = PDFArray($page, PDFName('FitBH'), PDFNum($args{'-fitbh'}));
664
} elsif (defined $args{'-fitv'}) {
665
0
0
$self->{'catalog'}->{'OpenAction'} = PDFArray($page, PDFName('FitV'), PDFNum($args{'-fitv'}));
666
} elsif (defined $args{'-fitbv'}) {
667
0
0
$self->{'catalog'}->{'OpenAction'} = PDFArray($page, PDFName('FitBV'), PDFNum($args{'-fitbv'}));
668
} elsif (defined $args{'-fitr'}) {
669
0
0
0
croak 'insufficient parameters to -fitr => []' unless scalar @{$args{'-fitr'}} == 4;
0
0
670
0
0
$self->{'catalog'}->{'OpenAction'} = PDFArray($page, PDFName('FitR'), map { PDFNum($_) } @{$args{'-fitr'}});
0
0
0
0
671
} elsif (defined $args{'-xyz'}) {
672
0
0
0
croak 'insufficient parameters to -xyz => []' unless scalar @{$args{'-xyz'}} == 3;
0
0
673
0
0
$self->{'catalog'}->{'OpenAction'} = PDFArray($page, PDFName('XYZ'), map { PDFNum($_) } @{$args{'-xyz'}});
0
0
0
0
674
}
675
}
676
167
697
$self->{'pdf'}->out_obj($self->{'catalog'});
677
678
167
361
return $self;
679
} # end of preferences()
680
681
=item $val = $pdf->default($parameter)
682
683
=item $pdf->default($parameter, $value)
684
685
Gets/sets the default value for a behavior of PDF::Builder.
686
687
B
688
689
=over
690
691
=item nounrotate
692
693
prohibits Builder from rotating imported/opened page to re-create a
694
default pdf-context.
695
696
=item pageencaps
697
698
enables Builder's adding save/restore commands upon importing/opening
699
pages to preserve graphics-state for modification.
700
701
=item copyannots
702
703
enables importing of annotations (B<*EXPERIMENTAL*>).
704
705
=back
706
707
B Perl::Critic (tools/1_pc.pl) has started flagging the name
708
"default" as a reserved keyword in higher Perl versions. Use with caution, and
709
be aware that this name I have to be changed in the future.
710
711
=cut
712
713
sub default {
714
11
11
1
23
my ($self, $parameter, $value) = @_;
715
716
# Parameter names may consist of lowercase letters, numbers, and underscores
717
11
34
$parameter = lc $parameter;
718
11
37
$parameter =~ s/[^a-z\d_]//g;
719
720
11
20
my $previous_value = $self->{$parameter};
721
11
100
30
if (defined $value) {
722
3
7
$self->{$parameter} = $value;
723
}
724
725
11
28
return $previous_value;
726
}
727
728
=item $version = $pdf->version($new_version)
729
730
=item $version = $pdf->version()
731
732
Get/set the PDF version (e.g. 1.4).
733
734
For compatibility with earlier releases, if no decimal point is given, assume
735
"1." precedes the number given.
736
737
A warning message is given if you attempt to I the PDF version, as you
738
might have already read in a higher level file, or used a higher level feature.
739
740
=cut
741
742
sub version {
743
0
0
1
0
my $self = shift();
744
0
0
0
if (scalar @_) {
745
0
0
my $version = shift();
746
0
0
0
if ($version =~ m/^\d+$/) { $version = "1.$version"; } # no x.? assume it's 1.something
0
0
747
0
0
0
croak "Invalid version $version" unless $version =~ /^(\d+\.\d+)$/;
748
0
0
0
if ($outVer > $1) {
749
0
0
print "Warning: call to self->version() to LOWER the output PDF version number!\n";
750
}
751
0
0
$self->{'pdf'}->{' version'} = $outVer = $1;
752
}
753
754
0
0
return $self->{'pdf'}->{' version'};
755
}
756
757
=item $bool = $pdf->isEncrypted()
758
759
Checks if the previously opened PDF is encrypted.
760
761
=cut
762
763
sub isEncrypted {
764
0
0
1
0
my $self = shift();
765
0
0
0
return defined($self->{'pdf'}->{'Encrypt'}) ? 1 : 0;
766
}
767
768
=item %infohash = $pdf->info(%infohash)
769
770
Gets/sets the info structure of the document.
771
772
See L section for an example of the use
773
of this method.
774
775
=cut
776
777
sub info {
778
165
165
1
525
my ($self, %opt) = @_;
779
780
165
100
483
if (not defined($self->{'pdf'}->{'Info'})) {
781
162
421
$self->{'pdf'}->{'Info'} = PDFDict();
782
162
552
$self->{'pdf'}->new_obj($self->{'pdf'}->{'Info'});
783
} else {
784
3
7
$self->{'pdf'}->{'Info'}->realise();
785
}
786
787
# Maintenance Note: Since we're not shifting at the beginning of
788
# this sub, this "if" will always be true
789
165
50
480
if (scalar @_) {
790
165
265
foreach my $k (@{$self->{'infoMeta'}}) {
165
431
791
1320
100
2584
next unless defined $opt{$k};
792
163
50
719
$self->{'pdf'}->{'Info'}->{$k} = PDFString($opt{$k} || 'NONE', 'm');
793
}
794
165
513
$self->{'pdf'}->out_obj($self->{'pdf'}->{'Info'});
795
}
796
797
165
50
429
if (defined $self->{'pdf'}->{'Info'}) {
798
165
392
%opt = ();
799
165
252
foreach my $k (@{$self->{'infoMeta'}}) {
165
420
800
1320
100
2634
next unless defined $self->{'pdf'}->{'Info'}->{$k};
801
165
489
$opt{$k} = $self->{'pdf'}->{'Info'}->{$k}->val();
802
165
50
33
1533
if ((unpack('n', $opt{$k}) == 0xfffe) or (unpack('n', $opt{$k}) == 0xfeff)) {
803
0
0
$opt{$k} = decode('UTF-16', $self->{'pdf'}->{'Info'}->{$k}->val());
804
}
805
}
806
}
807
808
165
362
return %opt;
809
} # end of info()
810
811
=item @metadata_attributes = $pdf->infoMetaAttributes(@metadata_attributes)
812
813
Gets/sets the supported info-structure tags.
814
815
B
816
817
@attributes = $pdf->infoMetaAttributes;
818
print "Supported Attributes: @attr\n";
819
820
@attributes = $pdf->infoMetaAttributes('CustomField1');
821
print "Supported Attributes: @attributes\n";
822
823
=cut
824
825
sub infoMetaAttributes {
826
0
0
1
0
my ($self, @attr) = @_;
827
828
0
0
0
if (scalar @attr) {
829
0
0
my %at = map { $_ => 1 } @{$self->{'infoMeta'}}, @attr;
0
0
0
0
830
0
0
@{$self->{'infoMeta'}} = keys %at;
0
0
831
}
832
833
0
0
return @{$self->{'infoMeta'}};
0
0
834
}
835
836
=item $xml = $pdf->xmpMetadata($xml)
837
838
Gets/sets the XMP XML data stream.
839
840
See L section for an example of the use
841
of this method.
842
843
=cut
844
845
sub xmpMetadata {
846
0
0
1
0
my ($self, $value) = @_;
847
848
0
0
0
if (not defined($self->{'catalog'}->{'Metadata'})) {
849
0
0
$self->{'catalog'}->{'Metadata'} = PDFDict();
850
0
0
$self->{'catalog'}->{'Metadata'}->{'Type'} = PDFName('Metadata');
851
0
0
$self->{'catalog'}->{'Metadata'}->{'Subtype'} = PDFName('XML');
852
0
0
$self->{'pdf'}->new_obj($self->{'catalog'}->{'Metadata'});
853
} else {
854
0
0
$self->{'catalog'}->{'Metadata'}->realise();
855
0
0
$self->{'catalog'}->{'Metadata'}->{' stream'} = unfilter($self->{'catalog'}->{'Metadata'}->{'Filter'}, $self->{'catalog'}->{'Metadata'}->{' stream'});
856
0
0
delete $self->{'catalog'}->{'Metadata'}->{' nofilt'};
857
0
0
delete $self->{'catalog'}->{'Metadata'}->{'Filter'};
858
}
859
860
0
0
my $md = $self->{'catalog'}->{'Metadata'};
861
862
0
0
0
if (defined $value) {
863
0
0
$md->{' stream'} = $value;
864
0
0
delete $md->{'Filter'};
865
0
0
delete $md->{' nofilt'};
866
0
0
$self->{'pdf'}->out_obj($md);
867
0
0
$self->{'pdf'}->out_obj($self->{'catalog'});
868
}
869
870
0
0
return $md->{' stream'};
871
} # end of xmpMetadata()
872
873
=item $pdf->pageLabel($index, $options)
874
875
Sets page label options.
876
877
B
878
879
=over
880
881
=item -style
882
883
Roman, roman, decimal, Alpha or alpha.
884
885
=item -start
886
887
Restart numbering at given number.
888
889
=item -prefix
890
891
Text prefix for numbering.
892
893
=back
894
895
B
896
897
# Start with Roman Numerals
898
$pdf->pageLabel(0, {
899
-style => 'roman',
900
});
901
902
# Switch to Arabic
903
$pdf->pageLabel(4, {
904
-style => 'decimal',
905
});
906
907
# Numbering for Appendix A
908
$pdf->pageLabel(32, {
909
-start => 1,
910
-prefix => 'A-'
911
});
912
913
# Numbering for Appendix B
914
$pdf->pageLabel( 36, {
915
-start => 1,
916
-prefix => 'B-'
917
});
918
919
# Numbering for the Index
920
$pdf->pageLabel(40, {
921
-style => 'Roman'
922
-start => 1,
923
-prefix => 'Index '
924
});
925
926
=cut
927
928
sub pageLabel {
929
7
7
1
50
my $self = shift();
930
931
7
33
34
$self->{'catalog'}->{'PageLabels'} ||= PDFDict();
932
7
33
23
$self->{'catalog'}->{'PageLabels'}->{'Nums'} ||= PDFArray();
933
934
7
8
my $nums = $self->{'catalog'}->{'PageLabels'}->{'Nums'};
935
7
18
while (scalar @_) {
936
7
8
my $index = shift();
937
7
8
my $opts = shift();
938
939
7
14
$nums->add_elements(PDFNum($index));
940
941
7
12
my $d = PDFDict();
942
7
100
14
if (defined $opts->{'-style'}) {
943
$d->{'S'} = PDFName($opts->{'-style'} eq 'Roman' ? 'R' :
944
$opts->{'-style'} eq 'roman' ? 'r' :
945
$opts->{'-style'} eq 'Alpha' ? 'A' :
946
5
100
23
$opts->{'-style'} eq 'alpha' ? 'a' : 'D');
100
100
100
947
} else {
948
2
6
$d->{'S'} = PDFName('D');
949
}
950
951
7
100
16
if (defined $opts->{'-prefix'}) {
952
1
4
$d->{'P'} = PDFString($opts->{'-prefix'}, 's');
953
}
954
955
7
100
15
if (defined $opts->{'-start'}) {
956
1
3
$d->{'St'} = PDFNum($opts->{'-start'});
957
}
958
959
7
14
$nums->add_elements($d);
960
}
961
962
7
13
return;
963
} # end of pageLabel()
964
965
=item $pdf->finishobjects(@objects)
966
967
Force objects to be written to file if possible.
968
969
B
970
971
$pdf = PDF::Builder->new(-file => 'our/new.pdf');
972
...
973
$pdf->finishobjects($page, $gfx, $txt);
974
...
975
$pdf->save();
976
977
=cut
978
979
sub finishobjects {
980
0
0
1
0
my ($self, @objs) = @_;
981
982
0
0
0
if ($self->{'opened_scalar'}) {
0
983
0
0
die "invalid method invocation: no file, use 'saveas' instead.";
984
} elsif ($self->{'partial_save'}) {
985
0
0
$self->{'pdf'}->ship_out(@objs);
986
} else {
987
0
0
die "invalid method invocation: no file, use 'saveas' instead.";
988
}
989
990
0
0
return;
991
}
992
993
sub _proc_pages {
994
15
15
43
my ($pdf, $object) = @_;
995
996
15
50
64
if (defined $object->{'Resources'}) {
997
15
32
eval {
998
15
52
$object->{'Resources'}->realise();
999
};
1000
}
1001
1002
15
31
my @pages;
1003
15
50
92
$pdf->{' apipagecount'} ||= 0;
1004
15
67
foreach my $page ($object->{'Kids'}->elements()) {
1005
16
55
$page->realise();
1006
16
50
66
if ($page->{'Type'}->val() eq 'Pages') {
1007
0
0
push @pages, _proc_pages($pdf, $page);
1008
}
1009
else {
1010
16
39
$pdf->{' apipagecount'}++;
1011
16
38
$page->{' pnum'} = $pdf->{' apipagecount'};
1012
16
50
51
if (defined $page->{'Resources'}) {
1013
16
35
eval {
1014
16
59
$page->{'Resources'}->realise();
1015
};
1016
}
1017
16
62
push @pages, $page;
1018
}
1019
}
1020
1021
15
58
return @pages;
1022
} # end of _proc_pages()
1023
1024
=item $pdf->update()
1025
1026
Saves a previously opened document.
1027
1028
B
1029
1030
$pdf = PDF::Builder->open('our/to/be/updated.pdf');
1031
...
1032
$pdf->update();
1033
1034
=cut
1035
1036
sub update {
1037
0
0
1
0
my $self = shift();
1038
0
0
$self->saveas($self->{'pdf'}->{' fname'});
1039
0
0
return;
1040
}
1041
1042
=item $pdf->saveas($file)
1043
1044
Save the document to $file and remove the object structure from memory.
1045
1046
B Although the object C<$pdf> will still exist, it is no longer
1047
usable for any purpose after invoking this method! You will receive error
1048
messages about "can't call method new_obj on an undefined value".
1049
1050
B
1051
1052
$pdf = PDF::Builder->new();
1053
...
1054
$pdf->saveas('our/new.pdf');
1055
1056
=cut
1057
1058
sub saveas {
1059
1
1
1
5
my ($self, $file) = @_;
1060
1061
1
50
3
if ($self->{'opened_scalar'}) {
0
1062
1
5
$self->{'pdf'}->append_file();
1063
1
3
my $fh;
1064
1
50
97
CORE::open($fh, '>', $file) or die "Can't open $file for writing: $!";
1065
1
8
binmode($fh, ':raw');
1066
1
3
print $fh ${$self->{'content_ref'}};
1
5
1067
1
132
CORE::close($fh);
1068
} elsif ($self->{'partial_save'}) {
1069
0
0
$self->{'pdf'}->close_file();
1070
} else {
1071
0
0
$self->{'pdf'}->out_file($file);
1072
}
1073
1074
1
7
$self->end();
1075
1
2
return;
1076
}
1077
1078
=item $pdf->save()
1079
1080
Save the document to an already-defined file (or filename) and
1081
remove the object structure from memory.
1082
1083
B Although the object C<$pdf> will still exist, it is no longer
1084
usable for any purpose after invoking this method! You will receive error
1085
messages about "can't call method new_obj on an undefined value".
1086
1087
B
1088
1089
$pdf = PDF::Builder->new(-file => 'file_to_output');
1090
...
1091
$pdf->save();
1092
1093
=cut
1094
1095
sub save {
1096
0
0
1
0
my ($self) = @_;
1097
1098
0
0
0
if ($self->{'opened_scalar'}) {
0
1099
0
0
die "Invalid method invocation: use 'saveas' instead of 'save'.";
1100
} elsif ($self->{'partial_save'}) {
1101
0
0
$self->{'pdf'}->close_file();
1102
} else {
1103
0
0
die "Invalid method invocation: use 'saveas' instead of 'save'.";
1104
}
1105
1106
0
0
$self->end();
1107
0
0
return;
1108
}
1109
1110
=item $string = $pdf->stringify()
1111
1112
Return the document as a string and remove the object structure from memory.
1113
1114
B Although the object C<$pdf> will still exist, it is no longer
1115
usable for any purpose after invoking this method! You will receive error
1116
messages about "can't call method new_obj on an undefined value".
1117
1118
B
1119
1120
$pdf = PDF::Builder->new();
1121
...
1122
print $pdf->stringify();
1123
1124
=cut
1125
1126
# Maintainer's note: The object is being destroyed because it contains
1127
# circular references that would otherwise result in memory not being
1128
# freed if the object merely goes out of scope. If possible, the
1129
# circular references should be eliminated so that stringify doesn't
1130
# need to be destructive.
1131
#
1132
# I've opted not to just require a separate call to release() because
1133
# it would likely introduce memory leaks in many existing programs
1134
# that use this module.
1135
# - Steve S. (see bug RT 81530)
1136
1137
sub stringify {
1138
126
126
1
1090
my $self = shift();
1139
1140
126
255
my $str = '';
1141
# is only set to 1 (within open_scalar()), otherwise is undef
1142
126
100
339
if ($self->{'opened_scalar'}) {
1143
7
40
$self->{'pdf'}->append_file();
1144
7
12
$str = ${$self->{'content_ref'}};
7
69
1145
} else {
1146
119
838
my $fh = FileHandle->new();
1147
# we should be writing to the STRING $str
1148
119
50
7296
CORE::open($fh, '>', \$str) || die "Can't begin scalar IO";
1149
119
18399
$self->{'pdf'}->out_file($fh);
1150
119
452
$fh->close();
1151
}
1152
126
1272
$self->end();
1153
1154
126
2818
return $str;
1155
}
1156
1157
# there IS a release() method defined and documented in Basic/PDF/File.pm
1158
# it's not clear whether this release is just an internal (rename to _release)
1159
sub release {
1160
0
0
0
0
my $self = shift();
1161
0
0
$self->end();
1162
0
0
return;
1163
}
1164
1165
=item $pdf->end()
1166
1167
Remove the object structure from memory. PDF::Builder contains circular
1168
references, so this call is necessary in long-running processes to
1169
keep from running out of memory.
1170
1171
This will be called automatically when you save or stringify a PDF.
1172
You should only need to call it explicitly if you are reading PDF
1173
files and not writing them.
1174
1175
=cut
1176
1177
sub end {
1178
127
127
1
269
my $self = shift();
1179
127
50
791
$self->{'pdf'}->release() if defined $self->{'pdf'};
1180
1181
127
570
foreach my $key (keys %$self) {
1182
1037
1890
$self->{$key} = undef;
1183
1037
1544
delete $self->{$key};
1184
}
1185
1186
127
296
return;
1187
}
1188
1189
=back
1190
1191
=head1 PAGE METHODS
1192
1193
=over
1194
1195
=item $page = $pdf->page()
1196
1197
=item $page = $pdf->page($page_number)
1198
1199
Returns a I page object. By default, the page is added to the end
1200
of the document. If you give an existing page number, the new page
1201
will be inserted in that position, pushing existing pages back by 1 (e.g.,
1202
C would insert an empty page 5, with the old page 5 now page 6,
1203
etc.
1204
1205
If $page_number is -1, the new page is inserted as the second-last page;
1206
if $page_number is 0, the new page is inserted as the last page.
1207
1208
B
1209
1210
$pdf = PDF::Builder->new();
1211
1212
# Add a page. This becomes page 1.
1213
$page = $pdf->page();
1214
1215
# Add a new first page. $page becomes page 2.
1216
$another_page = $pdf->page(1);
1217
1218
=cut
1219
1220
sub page {
1221
141
141
1
17218
my $self = shift();
1222
141
100
563
my $index = shift() || 0; # default to new "last" page
1223
141
227
my $page;
1224
1225
141
100
358
if ($index == 0) {
1226
139
1012
$page = PDF::Builder::Page->new($self->{'pdf'}, $self->{'pages'});
1227
} else {
1228
2
12
$page = PDF::Builder::Page->new($self->{'pdf'}, $self->{'pages'}, $index-1);
1229
}
1230
141
353
$page->{' apipdf'} = $self->{'pdf'};
1231
141
464
$page->{' api'} = $self;
1232
141
468
weaken $page->{' apipdf'};
1233
141
423
weaken $page->{' api'};
1234
141
431
$self->{'pdf'}->out_obj($page);
1235
141
459
$self->{'pdf'}->out_obj($self->{'pages'});
1236
141
100
363
if ($index == 0) {
50
1237
139
254
push @{$self->{'pagestack'}}, $page;
139
380
1238
139
463
weaken $self->{'pagestack'}->[-1];
1239
} elsif ($index < 0) {
1240
0
0
splice @{$self->{'pagestack'}}, $index, 0, $page;
0
0
1241
0
0
weaken $self->{'pagestack'}->[$index];
1242
} else {
1243
2
4
splice @{$self->{'pagestack'}}, $index-1, 0, $page;
2
8
1244
2
9
weaken $self->{'pagestack'}->[$index - 1];
1245
}
1246
1247
# $page->{'Resources'}=$self->{'pages'}->{'Resources'};
1248
141
615
return $page;
1249
} # end of page()
1250
1251
=item $page = $pdf->open_page($page_number)
1252
1253
Returns the L object of page $page_number.
1254
This is similar to C<< $page = $pdf->page() >>, except that C<$page> is
1255
I a new, empty page; but contains the contents of that existing page.
1256
1257
If $page_number is 0 or -1, it will return the last page in the
1258
document.
1259
1260
B
1261
1262
$pdf = PDF::Builder->open('our/99page.pdf');
1263
$page = $pdf->open_page(1); # returns the first page
1264
$page = $pdf->open_page(99); # returns the last page
1265
$page = $pdf->open_page(-1); # returns the last page
1266
$page = $pdf->open_page(999); # returns undef
1267
1268
=cut
1269
1270
sub open_page {
1271
7
7
1
649
my $self = shift();
1272
7
50
29
my $index = shift() || 0;
1273
7
16
my ($page, $rotate, $media, $trans);
1274
1275
7
50
30
if ($index == 0) {
50
1276
0
0
$page = $self->{'pagestack'}->[-1];
1277
} elsif ($index < 0) {
1278
0
0
$page = $self->{'pagestack'}->[$index];
1279
} else {
1280
7
22
$page = $self->{'pagestack'}->[$index - 1];
1281
}
1282
7
50
23
return unless ref($page);
1283
1284
7
100
41
if (ref($page) ne 'PDF::Builder::Page') {
1285
6
33
bless $page, 'PDF::Builder::Page';
1286
6
16
$page->{' apipdf'} = $self->{'pdf'};
1287
6
13
$page->{' api'} = $self;
1288
6
47
weaken $page->{' apipdf'};
1289
6
43
weaken $page->{' api'};
1290
6
35
$self->{'pdf'}->out_obj($page);
1291
6
50
33
32
if (($rotate = $page->find_prop('Rotate')) and not $page->{' opened'}) {
1292
0
0
$rotate = ($rotate->val() + 360) % 360;
1293
1294
0
0
0
0
if ($rotate != 0 and not $self->default('nounrotate')) {
1295
0
0
$page->{'Rotate'} = PDFNum(0);
1296
0
0
foreach my $mediatype (qw(MediaBox CropBox BleedBox TrimBox ArtBox)) {
1297
0
0
0
if ($media = $page->find_prop($mediatype)) {
1298
0
0
$media = [ map { $_->val() } $media->elements() ];
0
0
1299
} else {
1300
0
0
$media = [0, 0, 612, 792]; # US Letter default
1301
0
0
0
next if $mediatype ne 'MediaBox';
1302
}
1303
0
0
0
if ($rotate == 90) {
0
0
1304
0
0
0
$trans = "0 -1 1 0 0 $media->[2] cm" if $mediatype eq 'MediaBox';
1305
0
0
$media = [$media->[1], $media->[0], $media->[3], $media->[2]];
1306
} elsif ($rotate == 180) {
1307
0
0
0
$trans = "-1 0 0 -1 $media->[2] $media->[3] cm" if $mediatype eq 'MediaBox';
1308
} elsif ($rotate == 270) {
1309
0
0
0
$trans = "0 1 -1 0 $media->[3] 0 cm" if $mediatype eq 'MediaBox';
1310
0
0
$media = [$media->[1], $media->[0], $media->[3], $media->[2]];
1311
}
1312
0
0
$page->{$mediatype} = PDFArray(map { PDFNum($_) } @$media);
0
0
1313
}
1314
} else {
1315
0
0
$trans = '';
1316
}
1317
} else {
1318
6
16
$trans = '';
1319
}
1320
1321
6
100
66
32
if (defined $page->{'Contents'} and not $page->{' opened'}) {
1322
4
24
$page->fixcontents();
1323
4
10
my $uncontent = delete $page->{'Contents'};
1324
4
14
my $content = $page->gfx();
1325
4
25
$content->add(" $trans ");
1326
1327
4
50
17
if ($self->default('pageencaps')) {
1328
0
0
$content->{' stream'} .= ' q ';
1329
}
1330
4
14
foreach my $k ($uncontent->elements()) {
1331
4
24
$k->realise();
1332
4
83
$content->{' stream'} .= ' ' . unfilter($k->{'Filter'}, $k->{' stream'}) . ' ';
1333
}
1334
4
50
15
if ($self->default('pageencaps')) {
1335
0
0
$content->{' stream'} .= ' Q ';
1336
}
1337
1338
# if we like compress we will do it now to do quicker saves
1339
4
50
33
19
if ($self->{'forcecompress'} eq 'flate' ||
1340
$self->{'forcecompress'} =~ m/^[1-9]\d*$/) {
1341
4
43
$content->{' stream'} = dofilter($content->{'Filter'}, $content->{' stream'});
1342
4
11
$content->{' nofilt'} = 1;
1343
4
9
delete $content->{'-docompress'};
1344
4
13
$content->{'Length'} = PDFNum(length($content->{' stream'}));
1345
}
1346
}
1347
6
16
$page->{' opened'} = 1;
1348
}
1349
1350
7
30
$self->{'pdf'}->out_obj($page);
1351
7
34
$self->{'pdf'}->out_obj($self->{'pages'});
1352
7
18
$page->{' apipdf'} = $self->{'pdf'};
1353
7
14
$page->{' api'} = $self;
1354
7
174
weaken $page->{' apipdf'};
1355
7
124
weaken $page->{' api'};
1356
1357
7
22
return $page;
1358
} # end of openpage()
1359
1360
=item $page = $pdf->openpage($page_number)
1361
1362
B Will be removed on or after June, 2023. Use C call
1363
instead.
1364
1365
=cut
1366
1367
1
1
1
8
sub openpage { return open_page(@_); } ## no critic
1368
1369
# internal utility
1370
1371
sub _walk_obj {
1372
518
518
684
my ($object_cache, $source_pdf, $target_pdf, $source_object, @keys) = @_;
1373
1374
518
100
756
if (ref($source_object) =~ /Objind$/) {
1375
1
4
$source_object->realise();
1376
}
1377
1378
518
50
1021
return $object_cache->{scalar $source_object} if defined $object_cache->{scalar $source_object};
1379
#die "infinite loop while copying objects" if $source_object->{' copied'};
1380
1381
518
888
my $target_object = $source_object->copy($source_pdf); ## thanks to: yaheath // Fri, 17 Sep 2004
1382
1383
#$source_object->{' copied'} = 1;
1384
518
100
809
$target_pdf->new_obj($target_object) if $source_object->is_obj($source_pdf);
1385
1386
518
1352
$object_cache->{scalar $source_object} = $target_object;
1387
1388
518
100
1117
if (ref($source_object) =~ /Array$/) {
100
1389
7
87
$target_object->{' val'} = [];
1390
7
22
foreach my $k ($source_object->elements()) {
1391
501
50
810
$k->realise() if ref($k) =~ /Objind$/;
1392
501
698
$target_object->add_elements(_walk_obj($object_cache, $source_pdf, $target_pdf, $k));
1393
}
1394
} elsif (ref($source_object) =~ /Dict$/) {
1395
2
50
12
@keys = keys(%$target_object) unless scalar @keys;
1396
2
5
foreach my $k (@keys) {
1397
12
100
22
next if $k =~ /^ /;
1398
11
50
20
next unless defined $source_object->{$k};
1399
11
19
$target_object->{$k} = _walk_obj($object_cache, $source_pdf, $target_pdf, $source_object->{$k});
1400
}
1401
2
50
7
if ($source_object->{' stream'}) {
1402
0
0
0
if ($target_object->{'Filter'}) {
1403
0
0
$target_object->{' nofilt'} = 1;
1404
} else {
1405
0
0
delete $target_object->{' nofilt'};
1406
0
0
$target_object->{'Filter'} = PDFArray(PDFName('FlateDecode'));
1407
}
1408
0
0
$target_object->{' stream'} = $source_object->{' stream'};
1409
}
1410
}
1411
518
564
delete $target_object->{' streamloc'};
1412
518
468
delete $target_object->{' streamsrc'};
1413
1414
518
1110
return $target_object;
1415
} # end of _walk_obj()
1416
1417
=item $xoform = $pdf->importPageIntoForm($source_pdf, $source_page_number)
1418
1419
Returns a Form XObject created by extracting the specified page from
1420
$source_pdf.
1421
1422
This is useful if you want to transpose the imported page somewhat
1423
differently onto a page (e.g. two-up, four-up, etc.).
1424
1425
If $source_page_number is 0 or -1, it will return the last page in the
1426
document.
1427
1428
B
1429
1430
$pdf = PDF::Builder->new();
1431
$old = PDF::Builder->open('our/old.pdf');
1432
$page = $pdf->page();
1433
$gfx = $page->gfx();
1434
1435
# Import Page 2 from the old PDF
1436
$xo = $pdf->importPageIntoForm($old, 2);
1437
1438
# Add it to the new PDF's first page at 1/2 scale
1439
$gfx->formimage($xo, 0, 0, 0.5);
1440
1441
$pdf->saveas('our/new.pdf');
1442
1443
B You can only import a page from an existing PDF file.
1444
1445
=cut
1446
1447
sub importPageIntoForm {
1448
4
4
1
29
my ($self, $s_pdf, $s_idx) = @_;
1449
4
50
23
$s_idx ||= 0;
1450
1451
4
50
33
78
unless (ref($s_pdf) and $s_pdf->isa('PDF::Builder')) {
1452
0
0
die "Invalid usage: first argument must be PDF::Builder instance, not: " . ref($s_pdf);
1453
}
1454
1455
4
13
my ($s_page, $xo);
1456
1457
4
24
$xo = $self->xo_form();
1458
1459
4
100
28
if (ref($s_idx) eq 'PDF::Builder::Page') {
1460
1
4
$s_page = $s_idx;
1461
} else {
1462
3
20
$s_page = $s_pdf->open_page($s_idx);
1463
}
1464
1465
4
100
23
$self->{'apiimportcache'} ||= {};
1466
4
100
34
$self->{'apiimportcache'}->{$s_pdf} ||= {};
1467
1468
# This should never get past MediaBox, since it's a required object.
1469
4
12
foreach my $k (qw(MediaBox ArtBox TrimBox BleedBox CropBox)) {
1470
#next unless defined $s_page->{$k};
1471
#my $box = _walk_obj($self->{'apiimportcache'}->{$s_pdf}, $s_pdf->{'pdf'}, $self->{'pdf'}, $s_page->{$k});
1472
4
50
16
next unless defined $s_page->find_prop($k);
1473
4
19
my $box = _walk_obj($self->{'apiimportcache'}->{$s_pdf}, $s_pdf->{'pdf'}, $self->{'pdf'}, $s_page->find_prop($k));
1474
4
13
$xo->bbox(map { $_->val() } $box->elements());
16
36
1475
4
9
last;
1476
}
1477
4
50
17
$xo->bbox(0,0, 612,792) unless defined $xo->{'BBox'}; # US Letter default
1478
1479
4
12
foreach my $k (qw(Resources)) {
1480
4
16
$s_page->{$k} = $s_page->find_prop($k);
1481
4
50
16
next unless defined $s_page->{$k};
1482
4
50
18
$s_page->{$k}->realise() if ref($s_page->{$k}) =~ /Objind$/;
1483
1484
4
11
foreach my $sk (qw(XObject ExtGState Font ProcSet Properties ColorSpace Pattern Shading)) {
1485
32
100
84
next unless defined $s_page->{$k}->{$sk};
1486
5
50
22
$s_page->{$k}->{$sk}->realise() if ref($s_page->{$k}->{$sk}) =~ /Objind$/;
1487
5
10
foreach my $ssk (keys %{$s_page->{$k}->{$sk}}) {
5
23
1488
10
100
40
next if $ssk =~ /^ /;
1489
1
6
$xo->resource($sk, $ssk, _walk_obj($self->{'apiimportcache'}->{$s_pdf}, $s_pdf->{'pdf'}, $self->{'pdf'}, $s_page->{$k}->{$sk}->{$ssk}));
1490
}
1491
}
1492
}
1493
1494
# create a whole content stream
1495
## technically it is possible to submit an unfinished
1496
## (e.g., newly created) source-page, but that's nonsense,
1497
## so we expect a page fixed by open_page and die otherwise
1498
4
50
14
unless ($s_page->{' opened'}) {
1499
0
0
croak join(' ',
1500
"Pages may only be imported from a complete PDF.",
1501
"Save and reopen the source PDF object first.");
1502
}
1503
1504
4
100
16
if (defined $s_page->{'Contents'}) {
1505
3
21
$s_page->fixcontents();
1506
1507
3
8
$xo->{' stream'} = '';
1508
# open_page pages only contain one stream
1509
3
18
my ($k) = $s_page->{'Contents'}->elements();
1510
3
20
$k->realise();
1511
3
50
9
if ($k->{' nofilt'}) {
1512
# we have a finished stream here, so we unfilter
1513
3
16
$xo->add('q', unfilter($k->{'Filter'}, $k->{' stream'}), 'Q');
1514
} else {
1515
# stream is an unfinished/unfiltered content
1516
# so we just copy it and add the required "qQ"
1517
0
0
$xo->add('q', $k->{' stream'}, 'Q');
1518
}
1519
$xo->compressFlate() if $self->{'forcecompress'} eq 'flate' ||
1520
3
100
66
25
$self->{'forcecompress'} =~ m/^[1-9]\d*$/;
1521
}
1522
1523
4
45
return $xo;
1524
} # end of importPageIntoForm()
1525
1526
=item $page = $pdf->import_page($source_pdf)
1527
1528
=item $page = $pdf->import_page($source_pdf, $source_page_number)
1529
1530
=item $page = $pdf->import_page($source_pdf, $source_page_number, $target_page_number)
1531
1532
=item $page = $pdf->import_page($source_pdf, $source_page_number, $target_page_object)
1533
1534
Imports a page from $source_pdf and adds it to the specified position
1535
in $pdf.
1536
1537
If the C<$source_page_number> is omitted, 0, or -1; the last page of the
1538
source is imported.
1539
If the C<$target_page_number> is omitted, 0, or -1; the imported page will be
1540
placed as the new last page of the target (C<$pdf>).
1541
Otherwise, as with the C method, the page will be inserted before an
1542
existing page of that number.
1543
1544
B If you pass a page I instead of a page I for
1545
C<$target_page_number>, the contents of the page will be B into the
1546
existing page.
1547
1548
B
1549
1550
$pdf = PDF::Builder->new();
1551
$old = PDF::Builder->open('our/old.pdf');
1552
1553
# Add page 2 from the old PDF as page 1 of the new PDF
1554
$page = $pdf->import_page($old, 2);
1555
1556
$pdf->saveas('our/new.pdf');
1557
1558
B You can only import a page from an existing PDF file.
1559
1560
=cut
1561
1562
# importpage() renamed to import_page()
1563
1564
sub import_page {
1565
1
1
1
9
my ($self, $s_pdf, $s_idx, $t_idx) = @_;
1566
1567
1
50
3
$s_idx ||= 0; # default to last page
1568
1
50
6
$t_idx ||= 0; # default to last page
1569
1
2
my ($s_page, $t_page);
1570
1571
1
50
33
14
unless (ref($s_pdf) and $s_pdf->isa('PDF::Builder')) {
1572
0
0
die "Invalid usage: first argument must be PDF::Builder instance, not: " . ref($s_pdf);
1573
}
1574
1575
1
50
5
if (ref($s_idx) eq 'PDF::Builder::Page') {
1576
0
0
$s_page = $s_idx;
1577
} else {
1578
1
6
$s_page = $s_pdf->open_page($s_idx);
1579
}
1580
1581
1
50
5
if (ref($t_idx) eq 'PDF::Builder::Page') {
1582
0
0
$t_page = $t_idx;
1583
} else {
1584
1
50
5
if ($self->pages() < $t_idx) {
1585
0
0
$t_page = $self->page();
1586
} else {
1587
1
5
$t_page = $self->page($t_idx);
1588
}
1589
}
1590
1591
1
50
7
$self->{'apiimportcache'} = $self->{'apiimportcache'} || {};
1592
1
50
7
$self->{'apiimportcache'}->{$s_pdf} = $self->{'apiimportcache'}->{$s_pdf} || {};
1593
1594
# we now import into a form to keep
1595
# all those nasty resources from polluting
1596
# our very own resource naming space.
1597
1
7
my $xo = $self->importPageIntoForm($s_pdf, $s_page);
1598
1599
# copy all page dimensions
1600
1
3
foreach my $k (qw(MediaBox ArtBox TrimBox BleedBox CropBox)) {
1601
5
12
my $prop = $s_page->find_prop($k);
1602
5
100
14
next unless defined $prop;
1603
1604
1
5
my $box = _walk_obj({}, $s_pdf->{'pdf'}, $self->{'pdf'}, $prop);
1605
1
4
my $method = lc $k;
1606
1607
1
4
$t_page->$method(map { $_->val() } $box->elements());
4
9
1608
}
1609
1610
1
5
$t_page->gfx()->formimage($xo, 0, 0, 1);
1611
1612
# copy annotations and/or form elements as well
1613
1
0
33
4
if (exists $s_page->{'Annots'} and $s_page->{'Annots'} and $self->{'copyannots'}) {
0
1614
# first set up the AcroForm, if required
1615
0
0
my $AcroForm;
1616
0
0
0
if (my $a = $s_pdf->{'pdf'}->{'Root'}->realise()->{'AcroForm'}) {
1617
0
0
$a->realise();
1618
1619
0
0
$AcroForm = _walk_obj({}, $s_pdf->{'pdf'}, $self->{'pdf'}, $a, qw(NeedAppearances SigFlags CO DR DA Q));
1620
}
1621
0
0
my @Fields = ();
1622
0
0
my @Annots = ();
1623
0
0
foreach my $a ($s_page->{'Annots'}->elements()) {
1624
0
0
$a->realise();
1625
0
0
my $t_a = PDFDict();
1626
0
0
$self->{'pdf'}->new_obj($t_a);
1627
# these objects are likely to be both annotations and Acroform fields
1628
# key names are copied from PDF Reference 1.4 (Tables)
1629
0
0
my @k = (
1630
qw( Type Subtype Contents P Rect NM M F BS Border AP AS C CA T Popup A AA StructParent Rotate
1631
), # Annotations - Common (8.10)
1632
qw( Subtype Contents Open Name ), # Text Annotations (8.15)
1633
qw( Subtype Contents Dest H PA ), # Link Annotations (8.16)
1634
qw( Subtype Contents DA Q ), # Free Text Annotations (8.17)
1635
qw( Subtype Contents L BS LE IC ), # Line Annotations (8.18)
1636
qw( Subtype Contents BS IC ), # Square and Circle Annotations (8.20)
1637
qw( Subtype Contents QuadPoints ), # Markup Annotations (8.21)
1638
qw( Subtype Contents Name ), # Rubber Stamp Annotations (8.22)
1639
qw( Subtype Contents InkList BS ), # Ink Annotations (8.23)
1640
qw( Subtype Contents Parent Open ), # Popup Annotations (8.24)
1641
qw( Subtype FS Contents Name ), # File Attachment Annotations (8.25)
1642
qw( Subtype Sound Contents Name ), # Sound Annotations (8.26)
1643
qw( Subtype Movie Contents A ), # Movie Annotations (8.27)
1644
qw( Subtype Contents H MK ), # Widget Annotations (8.28)
1645
# Printers Mark Annotations (none)
1646
# Trap Network Annotations (none)
1647
);
1648
0
0
0
push @k, (
1649
qw( Subtype FT Parent Kids T TU TM Ff V DV AA
1650
), # Fields - Common (8.49)
1651
qw( DR DA Q ), # Fields containing variable text (8.51)
1652
qw( Opt ), # Checkbox field (8.54)
1653
qw( Opt ), # Radio field (8.55)
1654
qw( MaxLen ), # Text field (8.57)
1655
qw( Opt TI I ), # Choice field (8.59)
1656
) if $AcroForm;
1657
1658
# sorting out dupes
1659
0
0
my %ky = map { $_ => 1 } @k;
0
0
1660
# we do P separately, as it points to the page the Annotation is on
1661
0
0
delete $ky{'P'};
1662
# copy everything else
1663
0
0
foreach my $k (keys %ky) {
1664
0
0
0
next unless defined $a->{$k};
1665
0
0
$a->{$k}->realise();
1666
0
0
$t_a->{$k} = _walk_obj({}, $s_pdf->{'pdf'}, $self->{'pdf'}, $a->{$k});
1667
}
1668
0
0
$t_a->{'P'} = $t_page;
1669
0
0
push @Annots, $t_a;
1670
0
0
0
0
push @Fields, $t_a if ($AcroForm and $t_a->{'Subtype'}->val() eq 'Widget');
1671
}
1672
0
0
$t_page->{'Annots'} = PDFArray(@Annots);
1673
0
0
0
$AcroForm->{'Fields'} = PDFArray(@Fields) if $AcroForm;
1674
0
0
$self->{'pdf'}->{'Root'}->{'AcroForm'} = $AcroForm;
1675
}
1676
1
3
$t_page->{' imported'} = 1;
1677
1678
1
13
$self->{'pdf'}->out_obj($t_page);
1679
1
4
$self->{'pdf'}->out_obj($self->{'pages'});
1680
1681
1
3
return $t_page;
1682
} # end of import_page()
1683
1684
=item $count = $pdf->pages()
1685
1686
Returns the number of pages in the document.
1687
1688
=cut
1689
1690
sub pages {
1691
3
3
1
377
my $self = shift();
1692
3
6
return scalar @{$self->{'pagestack'}};
3
26
1693
}
1694
1695
# set global User Unit scale factor (default 1.0)
1696
1697
=item $pdf->userunit($value)
1698
1699
Sets the global UserUnit, defining the scale factor to multiply any size or
1700
coordinate by. For example, C results in a User Unit of 72 points,
1701
or 1 inch.
1702
1703
See L for more information.
1704
1705
=cut
1706
1707
sub userunit {
1708
0
0
1
0
my ($self, $value) = @_;
1709
1710
0
0
0
if (float($value) <= 0.0) {
1711
0
0
warn "Invalid User Unit value '$value', set to 1.0";
1712
0
0
$value = 1.0;
1713
}
1714
1715
0
0
PDF::Builder->verCheckOutput(1.6, "set User Unit");
1716
0
0
$self->{'pdf'}->{' userUnit'} = float($value);
1717
0
0
$self->{'pages'}->{'UserUnit'} = PDFNum(float($value));
1718
0
0
0
if (defined $self->{'pages'}->{'MediaBox'}) { # should be default letter
1719
0
0
0
if ($value != 1.0) { # divide points by User Unit
1720
0
0
my @corners = ( 0, 0, 612/$value, 792/$value );
1721
0
0
$self->{'pages'}->{'MediaBox'} = PDFArray( map { PDFNum(float($_)) } @corners );
0
0
1722
}
1723
}
1724
1725
0
0
return $self;
1726
}
1727
1728
# utility to handle calling page_size, and name with or without -orient setting
1729
sub _bbox {
1730
179
179
507
my ($self, @corners) = @_;
1731
1732
# if 1 or 3 elements in @corners, and [0] contains a letter, it's a name
1733
179
339
my $isName = 0;
1734
179
100
66
1390
if (scalar @corners && $corners[0] =~ m/[a-z]/i) { $isName = 1; }
163
335
1735
1736
179
50
536
if (scalar @corners == 3) {
1737
# name plus one option (-orient)
1738
0
0
my ($name, %opts) = @corners;
1739
0
0
@corners = page_size(($name)); # now 4 numeric values
1740
0
0
0
if (defined $opts{'-orient'}) {
1741
0
0
0
if ($opts{'-orient'} =~ m/^l/i) { # 'landscape' or just 'l'
1742
# 0 0 W H -> 0 0 H W
1743
0
0
my $temp;
1744
0
0
$temp = $corners[2]; $corners[2] = $corners[3]; $corners[3] = $temp;
0
0
0
0
1745
}
1746
}
1747
} else {
1748
# name without [-orient] option, or numeric coordinates given
1749
179
810
@corners = page_size(@corners);
1750
}
1751
1752
179
492
my $UU = $self->{'pdf'}->{' userUnit'};
1753
# scale down size if User Unit given (e.g., Letter => 0 0 8.5 11)
1754
179
50
66
1102
if ($isName && $UU != 1.0) {
1755
0
0
for (my $i=0; $i<4; $i++) {
1756
0
0
$corners[$i] /= $UU;
1757
}
1758
}
1759
1760
179
552
return (@corners);
1761
} # end of _bbox()
1762
1763
# utility to get a bounding box by name
1764
sub _get_bbox {
1765
201
201
492
my ($self, $boxname) = @_;
1766
1767
# if requested box not set, return next higher box's corners
1768
# MediaBox should always at least have a default value
1769
201
100
603
if (not defined $self->{'pages'}->{$boxname}) {
1770
8
100
100
46
if ($boxname eq 'CropBox') {
50
66
1771
2
3
$boxname = 'MediaBox';
1772
} elsif ($boxname eq 'BleedBox' ||
1773
$boxname eq 'TrimBox' ||
1774
$boxname eq 'ArtBox' ) {
1775
6
50
14
if (defined $self->{'pages'}->{'CropBox'}) {
1776
0
0
$boxname = 'CropBox';
1777
} else {
1778
6
11
$boxname = 'MediaBox';
1779
}
1780
} else {
1781
# invalid box name (silent error). just use MediaBox
1782
0
0
$boxname = 'MediaBox';
1783
}
1784
}
1785
1786
# now $boxname is known to exist
1787
201
747
return map { $_->val() } $self->{'pages'}->{$boxname}->elements();
804
1782
1788
1789
} # end of _get_bbox()
1790
1791
=item $pdf->mediabox($name)
1792
1793
=item $pdf->mediabox($name, -orient => 'orientation')
1794
1795
=item $pdf->mediabox($w,$h)
1796
1797
=item $pdf->mediabox($llx,$lly, $urx,$ury)
1798
1799
=item ($llx,$lly, $urx,$ury) = $pdf->mediabox()
1800
1801
Sets (or gets) the global MediaBox, defining the width and height (or by
1802
corner coordinates, or by standard name) of the output page itself, such as
1803
the physical paper size.
1804
1805
See L for more information.
1806
The method always returns the current bounds (after any set operation).
1807
1808
=cut
1809
1810
sub mediabox {
1811
173
173
1
1864
my ($self, @corners) = @_;
1812
173
100
511
if (defined $corners[0]) {
1813
167
591
@corners = $self->_bbox(@corners);
1814
167
416
$self->{'pages'}->{'MediaBox'} = PDFArray( map { PDFNum(float($_)) } @corners );
668
1536
1815
}
1816
1817
173
619
return $self->_get_bbox('MediaBox');
1818
}
1819
1820
=item $pdf->cropbox($name)
1821
1822
=item $pdf->cropbox($name, -orient => 'orientation')
1823
1824
=item $pdf->cropbox($w,$h)
1825
1826
=item $pdf->cropbox($llx,$lly, $urx,$ury)
1827
1828
=item ($llx,$lly, $urx,$ury) = $pdf->cropbox()
1829
1830
Sets (or gets) the global CropBox. This will define the media size to which
1831
the output will later be clipped.
1832
1833
See L for more information.
1834
The method always returns the current bounds (after any set operation).
1835
1836
=cut
1837
1838
sub cropbox {
1839
7
7
1
4629
my ($self, @corners) = @_;
1840
7
100
24
if (defined $corners[0]) {
1841
3
9
@corners = $self->_bbox(@corners);
1842
3
8
$self->{'pages'}->{'CropBox'} = PDFArray( map { PDFNum(float($_)) } @corners );
12
25
1843
}
1844
1845
7
19
return $self->_get_bbox('CropBox');
1846
}
1847
1848
=item $pdf->bleedbox($name)
1849
1850
=item $pdf->bleedbox($name, -orient => 'orientation')
1851
1852
=item $pdf->bleedbox($w,$h)
1853
1854
=item $pdf->bleedbox($llx,$lly, $urx,$ury)
1855
1856
=item ($llx,$lly, $urx,$ury) = $pdf->bleedbox()
1857
1858
Sets (or gets) the global BleedBox. This is typically used for hard copy
1859
printing where you want ink to go to the edge of the cut paper.
1860
1861
See L for more information.
1862
The method always returns the current bounds (after any set operation).
1863
1864
=cut
1865
1866
sub bleedbox {
1867
7
7
1
3989
my ($self, @corners) = @_;
1868
7
100
22
if (defined $corners[0]) {
1869
3
12
@corners = $self->_bbox(@corners);
1870
3
9
$self->{'pages'}->{'BleedBox'} = PDFArray( map { PDFNum(float($_)) } @corners );
12
29
1871
}
1872
1873
7
23
return $self->_get_bbox('BleedBox');
1874
}
1875
1876
=item $pdf->trimbox($name)
1877
1878
=item $pdf->trimbox($name, -orient => 'orientation')
1879
1880
=item $pdf->trimbox($w,$h)
1881
1882
=item $pdf->trimbox($llx,$lly, $urx,$ury)
1883
1884
=item ($llx,$lly, $urx,$ury) = $pdf->trimbox()
1885
1886
Sets (or gets) the global TrimBox. This is supposed to be the actual
1887
dimensions of the finished page (after trimming of the paper).
1888
1889
See L for more information.
1890
The method always returns the current bounds (after any set operation).
1891
1892
=cut
1893
1894
sub trimbox {
1895
7
7
1
4021
my ($self, @corners) = @_;
1896
7
100
24
if (defined $corners[0]) {
1897
3
10
@corners = $self->_bbox(@corners);
1898
3
8
$self->{'pages'}->{'TrimBox'} = PDFArray( map { PDFNum(float($_)) } @corners );
12
27
1899
}
1900
1901
7
22
return $self->_get_bbox('TrimBox');
1902
}
1903
1904
=item $pdf->artbox($name)
1905
1906
=item $pdf->artbox($name, -orient => 'orientation')
1907
1908
=item $pdf->artbox($w,$h)
1909
1910
=item $pdf->artbox($llx,$lly, $urx,$ury)
1911
1912
=item ($llx,$lly, $urx,$ury) = $pdf->artbox()
1913
1914
Sets (or gets) the global ArtBox. This is supposed to define "the extent of
1915
the page's I content".
1916
1917
See L for more information.
1918
The method always returns the current bounds (after any set operation).
1919
1920
=cut
1921
1922
sub artbox {
1923
7
7
1
3990
my ($self, @corners) = @_;
1924
7
100
26
if (defined $corners[0]) {
1925
3
10
@corners = $self->_bbox(@corners);
1926
3
9
$self->{'pages'}->{'ArtBox'} = PDFArray( map { PDFNum(float($_)) } @corners );
12
28
1927
}
1928
1929
7
20
return $self->_get_bbox('ArtBox');
1930
}
1931
1932
=back
1933
1934
=head1 FONT METHODS
1935
1936
=over
1937
1938
=item @directories = PDF::Builder::addFontDirs($dir1, $dir2, ...)
1939
1940
Adds one or more directories to the search path for finding font
1941
files.
1942
1943
Returns the list of searched directories.
1944
1945
=cut
1946
1947
sub addFontDirs {
1948
0
0
1
0
my @dirs = @_;
1949
0
0
push @FontDirs, @dirs;
1950
0
0
return @FontDirs;
1951
}
1952
1953
sub _findFont {
1954
0
0
0
my $font = shift();
1955
1956
0
0
my @fonts = ($font, map { "$_/$font" } @FontDirs);
0
0
1957
0
0
0
shift @fonts while scalar(@fonts) and not -f $fonts[0];
1958
1959
0
0
return $fonts[0];
1960
}
1961
1962
=item $font = $pdf->corefont($fontname, %options)
1963
1964
=item $font = $pdf->corefont($fontname)
1965
1966
Returns a new Adobe core font object. For details, see L.
1967
1968
See also L.
1969
1970
=cut
1971
1972
sub corefont {
1973
52
52
1
19760
my ($self, $name, %opts) = @_;
1974
1975
52
5478
require PDF::Builder::Resource::Font::CoreFont;
1976
52
500
my $obj = PDF::Builder::Resource::Font::CoreFont->new($self->{'pdf'}, $name, %opts);
1977
52
546
$self->{'pdf'}->out_obj($self->{'pages'});
1978
52
50
198
$obj->tounicodemap() if $opts{'-unicodemap'}; # UTF-8 not usable
1979
1980
52
707
return $obj;
1981
}
1982
1983
=item $font = $pdf->psfont($ps_file, %options)
1984
1985
=item $font = $pdf->psfont($ps_file)
1986
1987
Returns a new Adobe Type1 ("PostScript") font object.
1988
For details, see L.
1989
1990
See also L.
1991
1992
=cut
1993
1994
sub psfont {
1995
0
0
1
0
my ($self, $psf, %opts) = @_;
1996
1997
0
0
foreach my $o (qw(-afmfile -pfmfile)) {
1998
0
0
0
next unless defined $opts{$o};
1999
0
0
$opts{$o} = _findFont($opts{$o});
2000
}
2001
0
0
$psf = _findFont($psf);
2002
0
0
require PDF::Builder::Resource::Font::Postscript;
2003
0
0
my $obj = PDF::Builder::Resource::Font::Postscript->new($self->{'pdf'}, $psf, %opts);
2004
2005
0
0
$self->{'pdf'}->out_obj($self->{'pages'});
2006
0
0
0
$obj->tounicodemap() if $opts{'-unicodemap'}; # UTF-8 not usable
2007
2008
0
0
return $obj;
2009
}
2010
2011
=item $font = $pdf->ttfont($ttf_file, %options)
2012
2013
=item $font = $pdf->ttfont($ttf_file)
2014
2015
Returns a new TrueType (or OpenType) font object.
2016
For details, see L.
2017
2018
=cut
2019
2020
sub ttfont {
2021
0
0
1
0
my ($self, $file, %opts) = @_;
2022
2023
# PDF::Builder doesn't set BaseEncoding for TrueType fonts, so text
2024
# isn't searchable unless a ToUnicode CMap is included. Include
2025
# the ToUnicode CMap by default, but allow it to be disabled (for
2026
# performance and file size reasons) by setting -unicodemap to 0.
2027
0
0
0
$opts{'-unicodemap'} = 1 unless exists $opts{'-unicodemap'};
2028
2029
0
0
$file = _findFont($file);
2030
0
0
require PDF::Builder::Resource::CIDFont::TrueType;
2031
0
0
my $obj = PDF::Builder::Resource::CIDFont::TrueType->new($self->{'pdf'}, $file, %opts);
2032
2033
0
0
$self->{'pdf'}->out_obj($self->{'pages'});
2034
0
0
0
$obj->tounicodemap() if $opts{'-unicodemap'};
2035
2036
0
0
return $obj;
2037
}
2038
2039
=item $font = $pdf->cjkfont($cjkname, %options)
2040
2041
=item $font = $pdf->cjkfont($cjkname)
2042
2043
Returns a new CJK font object. These are TrueType-like fonts for East Asian
2044
languages (Chinese, Japanese, Korean).
2045
For details, see L.
2046
2047
See also L
2048
2049
=cut
2050
2051
sub cjkfont {
2052
1
1
1
9
my ($self, $name, %opts) = @_;
2053
2054
1
572
require PDF::Builder::Resource::CIDFont::CJKFont;
2055
1
15
my $obj = PDF::Builder::Resource::CIDFont::CJKFont->new($self->{'pdf'}, $name, %opts);
2056
2057
1
11
$self->{'pdf'}->out_obj($self->{'pages'});
2058
1
50
4
$obj->tounicodemap() if $opts{'-unicodemap'};
2059
2060
1
7
return $obj;
2061
}
2062
2063
=item $font = $pdf->synfont($basefont, %options)
2064
2065
=item $font = $pdf->synfont($basefont)
2066
2067
Returns a new synthetic font object. These are modifications to a core (or
2068
PS/T1 or TTF/OTF) font, where the font may be replaced by a Type1 or Type3
2069
PostScript font.
2070
This does not appear to work with CJK fonts (created with C method).
2071
For details, see L.
2072
2073
See also L
2074
2075
=cut
2076
2077
sub synfont {
2078
0
0
1
0
my ($self, $font, %opts) = @_;
2079
2080
# PDF::Builder doesn't set BaseEncoding for TrueType fonts, so text
2081
# isn't searchable unless a ToUnicode CMap is included. Include
2082
# the ToUnicode CMap by default, but allow it to be disabled (for
2083
# performance and file size reasons) by setting -unicodemap to 0.
2084
0
0
0
$opts{'-unicodemap'} = 1 unless exists $opts{'-unicodemap'};
2085
2086
0
0
require PDF::Builder::Resource::Font::SynFont;
2087
0
0
my $obj = PDF::Builder::Resource::Font::SynFont->new($self->{'pdf'}, $font, %opts);
2088
2089
0
0
$self->{'pdf'}->out_obj($self->{'pages'});
2090
0
0
0
$obj->tounicodemap() if $opts{'-unicodemap'};
2091
2092
0
0
return $obj;
2093
}
2094
2095
=item $font = $pdf->bdfont($bdf_file, @options)
2096
2097
=item $font = $pdf->bdfont($bdf_file)
2098
2099
Returns a new BDF (bitmapped distribution format) font object, based on the
2100
specified Adobe BDF file.
2101
2102
See also L
2103
2104
=cut
2105
2106
sub bdfont {
2107
0
0
1
0
my ($self, $bdf_file, @opts) = @_;
2108
2109
0
0
require PDF::Builder::Resource::Font::BdFont;
2110
0
0
my $obj = PDF::Builder::Resource::Font::BdFont->new($self->{'pdf'}, $bdf_file, @opts);
2111
2112
0
0
$self->{'pdf'}->out_obj($self->{'pages'});
2113
# $obj->tounicodemap(); # does not support Unicode!
2114
2115
0
0
return $obj;
2116
}
2117
2118
=item $font = $pdf->unifont(@fontspecs, %options)
2119
2120
=item $font = $pdf->unifont(@fontspecs)
2121
2122
Returns a new uni-font object, based on the specified fonts and options.
2123
2124
B This is not a true PDF-object, but a virtual/abstract font definition!
2125
2126
See also L.
2127
2128
Valid %options are:
2129
2130
=over
2131
2132
=item -encode
2133
2134
Changes the encoding of the font from its default.
2135
2136
=back
2137
2138
=cut
2139
2140
sub unifont {
2141
1
1
1
12
my ($self, @opts) = @_;
2142
2143
1
741
require PDF::Builder::Resource::UniFont;
2144
1
12
my $obj = PDF::Builder::Resource::UniFont->new($self->{'pdf'}, @opts);
2145
2146
1
6
return $obj;
2147
}
2148
2149
=back
2150
2151
=head1 IMAGE METHODS
2152
2153
=over
2154
2155
=item $jpeg = $pdf->image_jpeg($file)
2156
2157
Imports and returns a new JPEG image object. C<$file> may be either a filename
2158
or a filehandle.
2159
2160
See L for additional information
2161
and C for some examples of placing an image on a page.
2162
2163
=cut
2164
2165
# =item $jpeg = $pdf->image_jpeg($file, %options) no current options
2166
2167
sub image_jpeg {
2168
2
2
1
13
my ($self, $file, %opts) = @_;
2169
2170
2
546
require PDF::Builder::Resource::XObject::Image::JPEG;
2171
2
19
my $obj = PDF::Builder::Resource::XObject::Image::JPEG->new($self->{'pdf'}, $file);
2172
2173
1
9
$self->{'pdf'}->out_obj($self->{'pages'});
2174
2175
1
4
return $obj;
2176
}
2177
2178
=item $tiff = $pdf->image_tiff($file, %opts)
2179
2180
=item $tiff = $pdf->image_tiff($file)
2181
2182
Imports and returns a new TIFF image object. C<$file> may be either a filename
2183
or a filehandle.
2184
For details, see L.
2185
2186
See L and
2187
L for additional information
2188
and C
2189
for some examples of placing an image on a page (JPEG, but the principle is
2190
the same). There is an optional TIFF library described, that gives more
2191
capability than the default one.
2192
2193
=cut
2194
2195
sub image_tiff {
2196
4
4
1
141
my ($self, $file, %opts) = @_;
2197
2198
4
9
my ($rc, $obj);
2199
4
18
$rc = $self->LA_GT();
2200
4
50
13
if ($rc) {
2201
# Graphics::TIFF available
2202
0
0
0
0
if (defined $opts{'-nouseGT'} && $opts{'-nouseGT'} == 1) {
2203
0
0
$rc = -1; # don't use it
2204
}
2205
}
2206
4
50
16
if ($rc == 1) {
2207
# Graphics::TIFF (_GT suffix) available and to be used
2208
0
0
require PDF::Builder::Resource::XObject::Image::TIFF_GT;
2209
0
0
$obj = PDF::Builder::Resource::XObject::Image::TIFF_GT->new($self->{'pdf'}, $file, 'Ix'.pdfkey(), %opts);
2210
0
0
$self->{'pdf'}->out_obj($self->{'pages'});
2211
} else {
2212
# Graphics::TIFF not available, or is but is not to be used
2213
4
1041
require PDF::Builder::Resource::XObject::Image::TIFF;
2214
4
35
$obj = PDF::Builder::Resource::XObject::Image::TIFF->new($self->{'pdf'}, $file, 'Ix'.pdfkey(), %opts);
2215
3
24
$self->{'pdf'}->out_obj($self->{'pages'});
2216
2217
3
100
66
24
if ($rc == 0 && $MSG_COUNT[0]++ == 0) {
2218
# give warning message once, unless silenced (-silent) or
2219
# deliberately not using Graphics::TIFF (rc == -1)
2220
1
50
33
10
if (!defined $opts{'-silent'} || $opts{'-silent'} == 0) {
2221
0
0
print STDERR "Your system does not have Graphics::TIFF installed, so some\nTIFF functions may not run correctly.\n";
2222
# even if -silent only once, COUNT still incremented
2223
}
2224
}
2225
}
2226
3
14
$obj->{'usesGT'} = PDFNum($rc); # -1 available but unused
2227
# 0 not available
2228
# 1 available and used
2229
# $tiff->usesLib() to get number
2230
2231
3
42
return $obj;
2232
}
2233
2234
=item $rc = $pdf->LA_GT()
2235
2236
Returns 1 if the library name (package) Graphics::TIFF is installed, and
2237
0 otherwise. For this optional library, this call can be used to know if it
2238
is safe to use certain functions. For example:
2239
2240
if ($pdf->LA_GT() {
2241
# is installed and usable
2242
} else {
2243
# not available. you will be running the old, pure PERL code
2244
}
2245
2246
=cut
2247
2248
# there doesn't seem to be a way to pass in a string (or bare) package name,
2249
# to make a generic check routine
2250
sub LA_GT {
2251
4
4
1
11
my ($self) = @_;
2252
2253
4
7
my ($rc);
2254
4
8
$rc = eval {
2255
4
1030
require Graphics::TIFF;
2256
0
0
1;
2257
};
2258
4
50
29
if (!defined $rc) { $rc = 0; } # else is 1
4
10
2259
4
50
13
if ($rc) {
2260
# installed, but not up to date?
2261
0
0
0
if ($Graphics::TIFF::VERSION < $GrTFversion) { $rc = 0; }
0
0
2262
}
2263
2264
4
14
return $rc;
2265
}
2266
2267
=item $pnm = $pdf->image_pnm($file)
2268
2269
Imports and returns a new PNM image object. C<$file> may be either a filename
2270
or a filehandle.
2271
2272
See C
2273
for some examples of placing an image on a page (JPEG, but the principle is
2274
the same).
2275
2276
=cut
2277
2278
# =item $pnm = $pdf->image_pnm($file, %options) no current options
2279
2280
sub image_pnm {
2281
3
3
1
74
my ($self, $file, %opts) = @_;
2282
2283
3
611
require PDF::Builder::Resource::XObject::Image::PNM;
2284
3
27
my $obj = PDF::Builder::Resource::XObject::Image::PNM->new($self->{'pdf'}, $file);
2285
2
9
$self->{'pdf'}->out_obj($self->{'pages'});
2286
2287
2
20
return $obj;
2288
}
2289
2290
=item $png = $pdf->image_png($file, %options)
2291
2292
=item $png = $pdf->image_png($file)
2293
2294
Imports and returns a new PNG image object. C<$file> may be either
2295
a filename or a filehandle.
2296
For details, see L.
2297
2298
See L and
2299
L for additional information
2300
and C
2301
for some examples of placing an image on a page (JPEG, but the principle is
2302
the same). There is an optional PNG library (PNG_IPL) described, that gives more
2303
capability than the default one.
2304
2305
=cut
2306
2307
sub image_png {
2308
3
3
1
69
my ($self, $file, %opts) = @_;
2309
2310
3
7
my ($rc, $obj);
2311
3
7
$rc = $self->LA_IPL();
2312
3
50
7
if ($rc) {
2313
# Image::PNG::Libpng available
2314
0
0
0
0
if (defined $opts{'-nouseIPL'} && $opts{'-nouseIPL'} == 1) {
2315
0
0
$rc = -1; # don't use it
2316
}
2317
}
2318
3
50
8
if ($rc == 1) {
2319
# Image::PNG::Libpng (_IPL suffix) available and to be used
2320
0
0
require PDF::Builder::Resource::XObject::Image::PNG_IPL;
2321
0
0
$obj = PDF::Builder::Resource::XObject::Image::PNG_IPL->new($self->{'pdf'}, $file, 'Px'.pdfkey(), %opts);
2322
0
0
$self->{'pdf'}->out_obj($self->{'pages'});
2323
} else {
2324
# Image::PNG::Libpng not available, or is but is not to be used
2325
3
665
require PDF::Builder::Resource::XObject::Image::PNG;
2326
3
15
$obj = PDF::Builder::Resource::XObject::Image::PNG->new($self->{'pdf'}, $file, 'Px'.pdfkey(), %opts);
2327
2
11
$self->{'pdf'}->out_obj($self->{'pages'});
2328
2329
2
100
66
14
if ($rc == 0 && $MSG_COUNT[1]++ == 0) {
2330
# give warning message once, unless silenced (-silent) or
2331
# deliberately not using Image::PNG::Libpng (rc == -1)
2332
1
50
33
6
if (!defined $opts{'-silent'} || $opts{'-silent'} == 0) {
2333
0
0
print STDERR "Your system does not have Image::PNG::Libpng installed, so some\nPNG functions may not run correctly.\n";
2334
# even if -silent only once, COUNT still incremented
2335
}
2336
}
2337
}
2338
2
6
$obj->{'usesIPL'} = PDFNum($rc); # -1 available but unused
2339
# 0 not available
2340
# 1 available and used
2341
# $png->usesLib() to get number
2342
2
23
return $obj;
2343
}
2344
2345
=item $rc = $pdf->LA_IPL()
2346
2347
Returns 1 if the library name (package) Image::PNG::Libpng is installed, and
2348
0 otherwise. For this optional library, this call can be used to know if it
2349
is safe to use certain functions. For example:
2350
2351
if ($pdf->LA_IPL() {
2352
# is installed and usable
2353
} else {
2354
# not available. don't use 16bps or interlaced PNG image files
2355
}
2356
2357
=cut
2358
2359
# there doesn't seem to be a way to pass in a string (or bare) package name,
2360
# to make a generic check routine
2361
sub LA_IPL {
2362
3
3
1
5
my ($self) = @_;
2363
2364
3
6
my ($rc);
2365
3
5
$rc = eval {
2366
3
481
require Image::PNG::Libpng;
2367
0
0
1;
2368
};
2369
3
50
19
if (!defined $rc) { $rc = 0; } # else is 1
3
6
2370
3
50
19
if ($rc) {
2371
# installed, but not up to date?
2372
0
0
0
if ($Image::PNG::Libpng::VERSION < $LpngVersion) { $rc = 0; }
0
0
2373
}
2374
2375
3
7
return $rc;
2376
}
2377
2378
=item $gif = $pdf->image_gif($file)
2379
2380
Imports and returns a new GIF image object. C<$file> may be either a filename
2381
or a filehandle.
2382
2383
See L for additional information
2384
and C for some examples of placing an image on a page
2385
(JPEG, but the principle is the same).
2386
2387
=cut
2388
2389
# =item $gif = $pdf->image_gif($file, %options) no current options
2390
2391
sub image_gif {
2392
3
3
1
104
my ($self, $file, %opts) = @_;
2393
2394
3
608
require PDF::Builder::Resource::XObject::Image::GIF;
2395
3
28
my $obj = PDF::Builder::Resource::XObject::Image::GIF->new($self->{'pdf'}, $file);
2396
2
10
$self->{'pdf'}->out_obj($self->{'pages'});
2397
2398
2
20
return $obj;
2399
}
2400
2401
=item $gdf = $pdf->image_gd($gd_object, %options)
2402
2403
=item $gdf = $pdf->image_gd($gd_object)
2404
2405
Imports and returns a new image object from Image::GD.
2406
2407
Valid %options are:
2408
2409
=over
2410
2411
=item -lossless => 1
2412
2413
Use lossless compression.
2414
2415
=back
2416
2417
See L for additional information
2418
and C for some examples of placing an image on a page
2419
(JPEG, but the principle is the same).
2420
2421
=cut
2422
2423
sub image_gd {
2424
0
0
1
0
my ($self, $gd, %options) = @_;
2425
2426
0
0
require PDF::Builder::Resource::XObject::Image::GD;
2427
0
0
my $obj = PDF::Builder::Resource::XObject::Image::GD->new($self->{'pdf'}, $gd, undef, %options);
2428
0
0
$self->{'pdf'}->out_obj($self->{'pages'});
2429
2430
0
0
return $obj;
2431
}
2432
2433
=back
2434
2435
=head1 COLORSPACE METHODS
2436
2437
=over
2438
2439
=item $cs = $pdf->colorspace_act($file)
2440
2441
Returns a new colorspace object based on an Adobe Color Table file.
2442
2443
See L for a
2444
reference to the file format's specification.
2445
2446
=cut
2447
2448
# =item $cs = $pdf->colorspace_act($file, %options) no current options
2449
2450
sub colorspace_act {
2451
0
0
1
0
my ($self, $file, %opts) = @_;
2452
2453
0
0
require PDF::Builder::Resource::ColorSpace::Indexed::ACTFile;
2454
0
0
my $obj = PDF::Builder::Resource::ColorSpace::Indexed::ACTFile->new($self->{'pdf'}, $file);
2455
0
0
$self->{'pdf'}->out_obj($self->{'pages'});
2456
2457
0
0
return $obj;
2458
}
2459
2460
=item $cs = $pdf->colorspace_web()
2461
2462
Returns a new colorspace-object based on the "web-safe" color palette.
2463
2464
=cut
2465
2466
# =item $cs = $pdf->colorspace_web($file, %options) no current options
2467
# =item $cs = $pdf->colorspace_web($file) no current file
2468
2469
sub colorspace_web {
2470
1
1
1
6
my ($self, $file, %opts) = @_;
2471
2472
1
550
require PDF::Builder::Resource::ColorSpace::Indexed::WebColor;
2473
1
13
my $obj = PDF::Builder::Resource::ColorSpace::Indexed::WebColor->new($self->{'pdf'});
2474
2475
1
6
$self->{'pdf'}->out_obj($self->{'pages'});
2476
2477
1
4
return $obj;
2478
}
2479
2480
=item $cs = $pdf->colorspace_hue()
2481
2482
Returns a new colorspace-object based on the hue color palette.
2483
2484
See L for an explanation.
2485
2486
=cut
2487
2488
# =item $cs = $pdf->colorspace_hue($file, %options) no current options
2489
# =item $cs = $pdf->colorspace_hue($file) no current file
2490
2491
sub colorspace_hue {
2492
0
0
1
0
my ($self, $file, %opts) = @_;
2493
2494
0
0
require PDF::Builder::Resource::ColorSpace::Indexed::Hue;
2495
0
0
my $obj = PDF::Builder::Resource::ColorSpace::Indexed::Hue->new($self->{'pdf'});
2496
0
0
$self->{'pdf'}->out_obj($self->{'pages'});
2497
2498
0
0
return $obj;
2499
}
2500
2501
=item $cs = $pdf->colorspace_separation($tint, $color)
2502
2503
Returns a new separation colorspace object based on the parameters.
2504
2505
I<$tint> can be any valid ink identifier, including but not limited
2506
to: 'Cyan', 'Magenta', 'Yellow', 'Black', 'Red', 'Green', 'Blue' or
2507
'Orange'.
2508
2509
I<$color> must be a valid color specification limited to: '#rrggbb',
2510
'!hhssvv', '%ccmmyykk' or a "named color" (rgb).
2511
2512
The colorspace model will automatically be chosen based on the
2513
specified color.
2514
2515
=cut
2516
2517
sub colorspace_separation {
2518
0
0
1
0
my ($self, $tint, @clr) = @_;
2519
2520
0
0
require PDF::Builder::Resource::ColorSpace::Separation;
2521
0
0
my $obj = PDF::Builder::Resource::ColorSpace::Separation->new($self->{'pdf'}, pdfkey(), $tint, @clr);
2522
0
0
$self->{'pdf'}->out_obj($self->{'pages'});
2523
2524
0
0
return $obj;
2525
}
2526
2527
=item $cs = $pdf->colorspace_devicen(\@tintCSx, $samples)
2528
2529
=item $cs = $pdf->colorspace_devicen(\@tintCSx)
2530
2531
Returns a new DeviceN colorspace object based on the parameters.
2532
2533
B
2534
2535
$cy = $pdf->colorspace_separation('Cyan', '%f000');
2536
$ma = $pdf->colorspace_separation('Magenta', '%0f00');
2537
$ye = $pdf->colorspace_separation('Yellow', '%00f0');
2538
$bk = $pdf->colorspace_separation('Black', '%000f');
2539
2540
$pms023 = $pdf->colorspace_separation('PANTONE 032CV', '%0ff0');
2541
2542
$dncs = $pdf->colorspace_devicen( [ $cy,$ma,$ye,$bk, $pms023 ] );
2543
2544
The colorspace model will automatically be chosen based on the first
2545
colorspace specified.
2546
2547
=cut
2548
2549
sub colorspace_devicen {
2550
0
0
1
0
my ($self, $clrs, $samples) = @_;
2551
0
0
0
$samples ||= 2;
2552
2553
0
0
require PDF::Builder::Resource::ColorSpace::DeviceN;
2554
0
0
my $obj = PDF::Builder::Resource::ColorSpace::DeviceN->new($self->{'pdf'}, pdfkey(), $clrs, $samples);
2555
0
0
$self->{'pdf'}->out_obj($self->{'pages'});
2556
2557
0
0
return $obj;
2558
}
2559
2560
=back
2561
2562
=head1 BARCODE METHODS
2563
2564
These are glue routines to the actual barcode rendering routines found
2565
elsewhere.
2566
2567
=over
2568
2569
=item $bc = $pdf->xo_codabar(%options)
2570
2571
=item $bc = $pdf->xo_code128(%options)
2572
2573
=item $bc = $pdf->xo_2of5int(%options)
2574
2575
=item $bc = $pdf->xo_3of9(%options)
2576
2577
=item $bc = $pdf->xo_ean13(%options)
2578
2579
Creates the specified barcode object as a form XObject.
2580
2581
=cut
2582
2583
# TBD consider moving these to a BarCodes subdirectory, as the number of bar
2584
# code routines increases
2585
2586
sub xo_code128 {
2587
1
1
1
650
my ($self, @options) = @_;
2588
2589
1
859
require PDF::Builder::Resource::XObject::Form::BarCode::code128;
2590
1
8
my $obj = PDF::Builder::Resource::XObject::Form::BarCode::code128->new($self->{'pdf'}, @options);
2591
1
11
$self->{'pdf'}->out_obj($self->{'pages'});
2592
2593
1
5
return $obj;
2594
}
2595
2596
sub xo_codabar {
2597
1
1
1
9
my ($self, @options) = @_;
2598
2599
1
661
require PDF::Builder::Resource::XObject::Form::BarCode::codabar;
2600
1
9
my $obj = PDF::Builder::Resource::XObject::Form::BarCode::codabar->new($self->{'pdf'}, @options);
2601
1
11
$self->{'pdf'}->out_obj($self->{'pages'});
2602
2603
1
5
return $obj;
2604
}
2605
2606
sub xo_2of5int {
2607
1
1
1
639
my ($self, @options) = @_;
2608
2609
1
728
require PDF::Builder::Resource::XObject::Form::BarCode::int2of5;
2610
1
6
my $obj = PDF::Builder::Resource::XObject::Form::BarCode::int2of5->new($self->{'pdf'}, @options);
2611
1
10
$self->{'pdf'}->out_obj($self->{'pages'});
2612
2613
1
6
return $obj;
2614
}
2615
2616
sub xo_3of9 {
2617
2
2
1
635
my ($self, @options) = @_;
2618
2619
2
826
require PDF::Builder::Resource::XObject::Form::BarCode::code3of9;
2620
2
31
my $obj = PDF::Builder::Resource::XObject::Form::BarCode::code3of9->new($self->{'pdf'}, @options);
2621
2
22
$self->{'pdf'}->out_obj($self->{'pages'});
2622
2623
2
13
return $obj;
2624
}
2625
2626
sub xo_ean13 {
2627
1
1
1
675
my ($self, @options) = @_;
2628
2629
1
676
require PDF::Builder::Resource::XObject::Form::BarCode::ean13;
2630
1
7
my $obj = PDF::Builder::Resource::XObject::Form::BarCode::ean13->new($self->{'pdf'}, @options);
2631
1
12
$self->{'pdf'}->out_obj($self->{'pages'});
2632
2633
1
5
return $obj;
2634
}
2635
2636
=back
2637
2638
=head1 OTHER METHODS
2639
2640
=over
2641
2642
=item $xo = $pdf->xo_form()
2643
2644
Returns a new form XObject.
2645
2646
=cut
2647
2648
sub xo_form {
2649
4
4
1
18
my $self = shift();
2650
2651
4
74
my $obj = PDF::Builder::Resource::XObject::Form::Hybrid->new($self->{'pdf'});
2652
4
21
$self->{'pdf'}->out_obj($self->{'pages'});
2653
2654
4
8
return $obj;
2655
}
2656
2657
=item $egs = $pdf->egstate()
2658
2659
Returns a new extended graphics state object.
2660
2661
=cut
2662
2663
sub egstate {
2664
3
3
1
16
my $self = shift();
2665
2666
3
14
my $obj = PDF::Builder::Resource::ExtGState->new($self->{'pdf'}, pdfkey());
2667
3
17
$self->{'pdf'}->out_obj($self->{'pages'});
2668
2669
3
13
return $obj;
2670
}
2671
2672
=item $obj = $pdf->pattern(%options)
2673
2674
=item $obj = $pdf->pattern()
2675
2676
Returns a new pattern object.
2677
2678
=cut
2679
2680
sub pattern {
2681
0
0
1
0
my ($self, %options) = @_;
2682
2683
0
0
my $obj = PDF::Builder::Resource::Pattern->new($self->{'pdf'}, undef, %options);
2684
0
0
$self->{'pdf'}->out_obj($self->{'pages'});
2685
2686
0
0
return $obj;
2687
}
2688
2689
=item $obj = $pdf->shading(%options)
2690
2691
=item $obj = $pdf->shading()
2692
2693
Returns a new shading object.
2694
2695
=cut
2696
2697
sub shading {
2698
0
0
1
0
my ($self, %options) = @_;
2699
2700
0
0
my $obj = PDF::Builder::Resource::Shading->new($self->{'pdf'}, undef, %options);
2701
0
0
$self->{'pdf'}->out_obj($self->{'pages'});
2702
2703
0
0
return $obj;
2704
}
2705
2706
=item $otls = $pdf->outlines()
2707
2708
Returns a new or existing outlines object.
2709
2710
=cut
2711
2712
sub outlines {
2713
1
1
1
6
my $self = shift();
2714
2715
1
481
require PDF::Builder::Outlines;
2716
1
33
17
$self->{'pdf'}->{'Root'}->{'Outlines'} ||= PDF::Builder::Outlines->new($self);
2717
2718
1
3
my $obj = $self->{'pdf'}->{'Root'}->{'Outlines'};
2719
# bless $obj, 'PDF::Builder::Outlines';
2720
# $obj->{' apipdf'} = $self->{'pdf'};
2721
# $obj->{' api'} = $self;
2722
# weaken $obj->{' apipdf'};
2723
# weaken $obj->{' api'};
2724
2725
1
50
8
$self->{'pdf'}->new_obj($obj) unless $obj->is_obj($self->{'pdf'});
2726
1
4
$self->{'pdf'}->out_obj($obj);
2727
1
3
$self->{'pdf'}->out_obj($self->{'pdf'}->{'Root'});
2728
2729
1
3
return $obj;
2730
}
2731
2732
=item $ndest = $pdf->named_destination()
2733
2734
Returns a new or existing named destination object.
2735
2736
=cut
2737
2738
sub named_destination {
2739
0
0
1
0
my ($self, $cat, $name, $obj) = @_;
2740
0
0
my $root = $self->{'catalog'};
2741
2742
0
0
0
$root->{'Names'} ||= PDFDict();
2743
0
0
0
$root->{'Names'}->{$cat} ||= PDFDict();
2744
0
0
0
$root->{'Names'}->{$cat}->{'-vals'} ||= {};
2745
0
0
0
$root->{'Names'}->{$cat}->{'Limits'} ||= PDFArray();
2746
0
0
0
$root->{'Names'}->{$cat}->{'Names'} ||= PDFArray();
2747
2748
0
0
0
unless (defined $obj) {
2749
0
0
$obj = PDF::Builder::NamedDestination->new($self->{'pdf'});
2750
}
2751
0
0
$root->{'Names'}->{$cat}->{'-vals'}->{$name} = $obj;
2752
2753
0
0
my @names = sort {$a cmp $b} keys %{$root->{'Names'}->{$cat}->{'-vals'}};
0
0
0
0
2754
2755
0
0
$root->{'Names'}->{$cat}->{'Limits'}->{' val'}->[0] = PDFString($names[0], 'n');
2756
0
0
$root->{'Names'}->{$cat}->{'Limits'}->{' val'}->[1] = PDFString($names[-1], 'n');
2757
2758
0
0
@{$root->{'Names'}->{$cat}->{'Names'}->{' val'}} = ();
0
0
2759
2760
0
0
foreach my $k (@names) {
2761
0
0
push @{$root->{'Names'}->{$cat}->{'Names'}->{' val'}},
2762
( PDFString($k, 'n'),
2763
0
0
$root->{'Names'}->{$cat}->{'-vals'}->{$k}
2764
);
2765
}
2766
2767
0
0
return $obj;
2768
} # end of named_destination()
2769
2770
# ==================================================
2771
# input: level of checking, PDF as a string
2772
# level: 0 just return with any version override
2773
# 1 return version override, and errors
2774
# 2 return version override, and errors and warnings
2775
# 3 return version override, plus errors, warnings, notes
2776
# 4 like (3), plus dump analysis data
2777
# 5 like (4), plus dump $self (PDF) contents
2778
# returns any /Version value found in Catalog, last one if multiple ones found,
2779
# else undefined
2780
2781
sub IntegrityCheck {
2782
15
15
0
46
my ($self, $level, $string) = @_;
2783
2784
15
31
my $level_nodiag = 0;
2785
15
26
my $level_error = 1;
2786
15
28
my $level_warning = 2;
2787
15
24
my $level_note = 3;
2788
15
28
my $level_dump = 4;
2789
15
83
my $level_dumpself = 5;
2790
2791
15
35
my $IC = "PDF Integrity Check:";
2792
2793
#print "$IC level $level\n" if $level >= $level_error;
2794
15
38
my $Version = undef;
2795
15
39
my ($Info, $Root, $str, $pos, $Parent, @Kids, @others);
2796
2797
15
27
my $idx_defined = 0; # has this object been explicitly defined?
2798
15
28
my $idx_refcount = 1; # count of all pointing to this obj except as Kid
2799
15
26
my $idx_par_clmd = 2; # other object claiming this object as Kid
2800
15
26
my $idx_parent = 3; # this object's /Parent entry
2801
15
21
my $idx_kid_cnt = 4; # size of kid_list
2802
15
28
my $idx_kid_list = 5; # this object's /Kids list
2803
# intialize each element to [ 0 0 -1 -1 -1 [] ]
2804
2805
15
50
50
return $Version if !length($string); # nothing to examine?
2806
# even if $level 0, still want to get any higher /Version
2807
# build analysis data and issue errors/warnings at appropriate $level
2808
15
245
my @major = split /%%EOF/, $string; # typically [0] entire PDF [1] empty
2809
15
46
my %objList;
2810
15
30
my $update = -1;
2811
15
43
foreach (@major) {
2812
# update section number 0, 1, 2... with %%EOF in-between
2813
32
50
$update++;
2814
32
50
75
next if !length($_);
2815
2816
# split on "endobj"
2817
32
235
my @rawObjects = split /endobj/, $_;
2818
# each element contains an object plus leading stuff, not incl endobj
2819
2820
32
65
foreach my $rawObject (@rawObjects) {
2821
140
50
248
next if !length($rawObject);
2822
2823
# remove bulky and unwanted stream...endstream
2824
140
100
371
if ($rawObject =~ m/^(.*)stream\s.*\sendstream(.*)$/s) {
2825
21
70
$rawObject = $1.$2;
2826
}
2827
2828
# trim off anything before obj clause. endobj already gone.
2829
140
100
66
692
if ($rawObject =~ m/^(.*?)\s?(\d+) (\d+) obj\s(.*)$/s ||
2830
$rawObject =~ m/^(.*?)\s?(\d+) (\d+) obj(.*)$/s) {
2831
108
391
$rawObject = $4;
2832
2833
# found an obj, full string is $rawObject. parse into
2834
# selected fields, build $objList{key} entry.
2835
108
259
my $objKey = "$2.$3"; # e.g., 4 0 obj -> 4.0
2836
# if this is a replacement object in an update, clear Parent
2837
# and Kids
2838
108
100
100
342
if (defined $objList{$objKey} && $update > 0) {
2839
9
12
$objList{$objKey}->[$idx_parent] = -1;
2840
9
10
$objList{$objKey}->[$idx_kid_cnt] = -1;
2841
9
16
$objList{$objKey}->[$idx_kid_list] = [];
2842
}
2843
# might have already created this object element as target
2844
# from another object
2845
108
100
233
if (!defined $objList{$objKey}) {
2846
42
154
$objList{$objKey} = [0, 0, -1, -1, -1, []];
2847
}
2848
# mark object as defined
2849
108
173
$objList{$objKey}->[$idx_defined] = 1;
2850
2851
# found an object
2852
# looking for /Parent x y R
2853
# /Kids [ x y R ]
2854
# /Type = /Catalog -> /Version /x.y
2855
# for now, ignoring any /BaseVersion
2856
# all other x y R
2857
# remove from $rawObject as we find a match
2858
2859
# /Parent x y R -> $Parent
2860
108
100
299
if ($rawObject =~ m#/Parent(\s+)(\d+)(\s+)(\d+)(\s+)R#) {
2861
17
54
$Parent = "$2.$4";
2862
17
61
$str = "/Parent$1$2$3$4$5R";
2863
17
41
$pos = index $rawObject, $str;
2864
17
43
substr($rawObject, $pos, length($str)) = '';
2865
# TBD realistically, do we need to check for >1 /Parent ?
2866
#if ($objList{$objKey}->[$idx_parent] == -1) {
2867
# first /Parent (should not be more)
2868
17
45
$objList{$objKey}->[$idx_parent] = $Parent;
2869
#} else {
2870
# print STDERR "$IC Additional Parent ($Parent) in object $objKey, already list $objList{$objKey}->[$idx_parent] as Parent.\n" if $level >= $level_error;
2871
#}
2872
}
2873
2874
# /Kids [ x y R ] -> @Kids
2875
# should we check for multiple Kids arrays in one object (error)?
2876
108
100
279
if ($rawObject =~ m#/Kids(\s+)\[(.*)\]#) {
2877
17
91
$str = "/Kids$1\[$2\]";
2878
17
62
$pos = index $rawObject, $str;
2879
17
64
substr($rawObject, $pos, length($str)) = '';
2880
2881
17
57
my $str2 = " $2"; # guarantee a leading \s
2882
17
34
@Kids = ();
2883
17
29
while (1) {
2884
35
100
153
if ($str2 =~ m#(\s+)(\d+)(\s+)(\d+)(\s+)R#) {
2885
18
80
$str = "$1$2$3$4$5R";
2886
18
84
push @Kids, "$2.$4";
2887
18
46
$pos = index $str2, $str;
2888
18
45
substr($str2, $pos, length($str)) = '';
2889
} else {
2890
17
30
last;
2891
}
2892
}
2893
# TBD: realistically, any need to check for >1 /Kids?
2894
#if (!scalar(@{$objList{$objKey}->[$idx_kid_list]})) {
2895
# first /Kids (should not be more)
2896
17
33
@{$objList{$objKey}->[$idx_kid_list]} = @Kids;
17
57
2897
17
50
$objList{$objKey}->[$idx_kid_cnt] = scalar(@Kids);
2898
#} else {
2899
# print STDERR "$IC Multiple Kids lists in object $objKey, already list @{$objList{$objKey}->[$idx_kid_list]} as Kids.\n" if $level >= $level_error;
2900
#}
2901
}
2902
2903
# /Type /Catalog -> /Version /x.y -> $Version
2904
# both x and y are normally single digits, but allow room
2905
# just global $Version, assuming that each one physically
2906
# later overrides any earlier ones
2907
108
100
280
if ($rawObject =~ m#/Type(\s+)/Catalog#) {
2908
15
50
my $sp1 = $1;
2909
15
50
73
if ($rawObject =~ m#/Version /(\d+)\.(\d+)#) {
2910
0
0
$Version = "$1.$2";
2911
0
0
$str = "/Version$sp1/$Version";
2912
0
0
$pos = index $rawObject, $str;
2913
0
0
substr($rawObject, $pos, length($str)) = '';
2914
}
2915
}
2916
2917
# if using cross-reference stream, will find /Root x y R
2918
# and /Info x y R entries in an object of /Type /Xref
2919
# it looks like last ones will win
2920
108
100
66
436
if ($rawObject =~ m#/Type(\s+)/XRef# ||
2921
$rawObject =~ m#/Type/XRef#) {
2922
3
50
16
if ($rawObject =~ m#/Root(\s+)(\d+)(\s+)(\d+)(\s+)R#) {
2923
3
11
$Root = "$2.$4";
2924
3
10
$str = "/Root$1$2$3$4$5R";
2925
3
7
$pos = index $rawObject, $str;
2926
3
9
substr($rawObject, $pos, length($str)) = '';
2927
}
2928
3
50
15
if ($rawObject =~ m#/Info(\s+)(\d+)(\s+)(\d+)(\s+)R#) {
2929
3
10
$Info = "$2.$4";
2930
3
11
$str = "/Info$1$2$3$4$5R";
2931
3
7
$pos = index $rawObject, $str;
2932
3
6
substr($rawObject, $pos, length($str)) = '';
2933
}
2934
}
2935
2936
# all other x y R -> @others
2937
108
218
@others = ();
2938
108
135
while (1) {
2939
162
100
1507
if ($rawObject =~ m#(\d+)(\s+)(\d+)(\s+)R#) {
2940
54
161
$str = "$1$2$3$4R";
2941
54
141
push @others, "$1.$3";
2942
54
124
$pos = index $rawObject, $str;
2943
54
125
substr($rawObject, $pos, length($str)) = '';
2944
} else {
2945
108
149
last;
2946
}
2947
}
2948
# go through all other refs and create element if necessary,
2949
# then increment its refcnt array element
2950
108
179
foreach (@others) {
2951
54
100
165
if (!defined $objList{$_}) {
2952
49
178
$objList{$_} = [0, 0, -1, -1, -1, []];
2953
}
2954
54
112
$objList{$_}->[$idx_refcount]++;
2955
}
2956
108
179
foreach (@Kids) {
2957
95
100
178
if (!defined $objList{$_}) {
2958
15
76
$objList{$_} = [0, 0, -1, -1, -1, []];
2959
}
2960
95
160
$objList{$_}->[$idx_refcount]++;
2961
}
2962
2963
} else {
2964
# not an object, but could be other stuff of interest
2965
# looking for trailer -> /Root x y R & /Info x y R
2966
32
100
125
if ($rawObject =~ m/trailer/) {
2967
15
50
102
if ($rawObject =~ m#trailer(.*)/Info(\s+)(\d+)(\s+)(\d+)(\s+)R#s) {
2968
15
47
$Info = "$3.$5";
2969
}
2970
15
50
83
if ($rawObject =~ m#trailer(.*)/Root(\s+)(\d+)(\s+)(\d+)(\s+)R#s) {
2971
15
68
$Root = "$3.$5";
2972
}
2973
}
2974
}
2975
}
2976
}
2977
2978
# increment Root and Info objects reference counts
2979
# they probably SHOULD already be defined (issue warning if not)
2980
15
50
57
if (!defined $Root) {
2981
0
0
0
print STDERR "$IC No Root object defined!\n" if $level >= $level_error;
2982
} else {
2983
15
50
99
if (!defined $objList{$Root}) {
2984
0
0
$objList{$Root} = [1, 0, -1, -1, -1, []];
2985
0
0
0
print STDERR "$IC Root object $Root not found!\n" if $level >= $level_error;
2986
}
2987
15
42
$objList{$Root}->[$idx_refcount]++;
2988
}
2989
2990
# Info is optional
2991
15
50
48
if (!defined $Info) {
2992
0
0
0
print STDERR "$IC No Info object defined!\n" if $level >= $level_note;
2993
} else {
2994
15
50
60
if (!defined $objList{$Info}) {
2995
0
0
$objList{$Info} = [1, 0, -1, -1, -1, []];
2996
0
0
0
print STDERR "$IC Info object $Info not found!\n" if $level >= $level_note;
2997
# possibly in a deleted object (on free list)
2998
}
2999
15
46
$objList{$Info}->[$idx_refcount]++;
3000
}
3001
3002
# revisit each element in objList
3003
# visit each Kid, their $idx_par_clmd should be -1 (set to this object)
3004
# (if not -1, is on multiple Kids lists)
3005
# their $idx_parent should be this object
3006
# they should have a Parent declared
3007
# any element with ref count of 0 and no Parent give warning unreachable
3008
# TBD: anything else to add to things to check?
3009
15
140
foreach my $thisObj (sort keys %objList) {
3010
3011
# was an object actually defined for this entry?
3012
# missing Info and Root messages already given, so flag is 1 ("defined")
3013
106
100
235
if ($objList{$thisObj}->[$idx_defined] == 0) {
3014
2
50
7
print STDERR "$IC object $thisObj referenced, but no entry found.\n" if $level >= $level_note;
3015
# it's apparently OK if the missing object is on the free list --
3016
# it will just be ignored
3017
}
3018
3019
# check any Kids
3020
106
100
196
if ($objList{$thisObj}[$idx_kid_cnt] > 0) {
3021
# this object has children (/Kids), so explore them one level deep
3022
14
58
for (my $kidObj=0; $kidObj<$objList{$thisObj}[$idx_kid_cnt]; $kidObj++) {
3023
16
40
my $child = $objList{$thisObj}[$idx_kid_list]->[$kidObj];
3024
# child's claimed parent should be -1, set to thisObj
3025
16
50
48
if ($objList{$child}[$idx_par_clmd] == -1) {
3026
# no one has claimed to be parent, so set to thisObj
3027
16
39
$objList{$child}[$idx_par_clmd] = $thisObj;
3028
} else {
3029
# someone else has already claimed to be parent
3030
0
0
0
print STDERR "$IC object $thisObj wants to claim object $child as its child, but $objList{$child}[$idx_par_clmd] already has!\nPossibly $child is on more than one /Kids list?\n" if $level >= $level_error;
3031
}
3032
# if no object defined for child, already flagged as missing
3033
16
50
63
if ($objList{$child}[$idx_defined] == 1) {
3034
# child should list thisObj as its Parent
3035
16
50
147
if ($objList{$child}[$idx_parent] == -1) {
50
3036
0
0
0
print STDERR "$IC object $thisObj claims $child as a child (/Kids), but $child claims no Parent!\n" if $level >= $level_error;
3037
0
0
$objList{$child}[$idx_parent] = $thisObj;
3038
} elsif ($objList{$child}[$idx_parent] != $thisObj) {
3039
0
0
0
print STDERR "$IC object $thisObj claims $child as a child (/Kids), but $child claims $objList{$child}[$idx_parent] as its parent!\n" if $level >= $level_error;
3040
}
3041
}
3042
}
3043
}
3044
3045
106
100
100
370
if ($objList{$thisObj}[$idx_parent] == -1 &&
3046
$objList{$thisObj}[$idx_refcount] == 0) {
3047
8
50
21
print STDERR "$IC Warning: object $thisObj appears to be unreachable.\n" if $level >= $level_note;
3048
}
3049
}
3050
3051
15
50
74
if ($level >= $level_dump) {
3052
# dump analysis data
3053
34
34
28130
use Data::Dumper;
34
228549
34
4353
3054
0
0
my $d = Data::Dumper->new([\%objList]);
3055
0
0
print "========= dump of $IC analysis data ===========\n";
3056
0
0
print $d->Dump();
3057
}
3058
3059
# if have entire processed PDF in $self
3060
15
50
43
if ($level >= $level_dumpself) {
3061
# dump whole data
3062
34
34
333
use Data::Dumper;
34
86
34
7753
3063
0
0
my $d = Data::Dumper->new([$self]);
3064
0
0
print "========= dump of $IC PDF (self) data ===========\n";
3065
0
0
print $d->Dump();
3066
}
3067
3068
15
125
return $Version;
3069
}
3070
3071
1;
3072
3073
__END__