1package PDF::Builder;
2
3use strict;
4use warnings;
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.
8our $VERSION = '3.023'; # VERSION
9our $LAST_UPDATE = '3.023'; # manually update whenever code is changed
10
11my $GrTFversion = 16;    # minimum version of Graphics::TIFF
12my $LpngVersion = 0.57;  # minimum version of Image::PNG::Libpng
13
14use Carp;
15use Encode qw(:all);
16use FileHandle;
17
18use PDF::Builder::Basic::PDF::Utils;
19use PDF::Builder::Util;
20
21use PDF::Builder::Basic::PDF::File;
22use PDF::Builder::Basic::PDF::Pages;
23use PDF::Builder::Page;
24
25use PDF::Builder::Resource::XObject::Form::Hybrid;
26
27use PDF::Builder::Resource::ExtGState;
28use PDF::Builder::Resource::Pattern;
29use PDF::Builder::Resource::Shading;
30
31use PDF::Builder::NamedDestination;
32
33use Scalar::Util qw(weaken);
34
35our @FontDirs = ( (map { "$_/PDF/Builder/fonts" } @INC),
36                  qw[ /usr/share/fonts /usr/local/share/fonts c:/windows/fonts c:/winnt/fonts ] );
37our @MSG_COUNT = (0,  # [0] Graphics::TIFF not installed
38	          0,  # [1] Image::PNG::Libpng not installed
39		  0,  # [2] TBD...
40	         );
41our $outVer = 1.4; # desired PDF version for output, bump up w/ warning on read or feature output
42our $msgVer = 1;   # 0=don't, 1=do issue message when PDF output version is bumped up
43our $myself;       # holds self->pdf
44
45=head1 NAME
46
47PDF::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
85See the file README (in downloadable package and on CPAN) for a summary of
86prerequisites and tools needed to install PDF::Builder, both mandatory and
87optional.
88
89=head2 SOFTWARE DEVELOPMENT KIT
90
91There are four levels of involvement with PDF::Builder. Depending on what you
92want to do, different kinds of installs are recommended.
93See L<PDF::Builder::Docs/Software Development Kit> for suggestions.
94
95=head2 OPTIONAL LIBRARIES
96
97PDF::Builder can make use of some optional libraries, which are not I<required>
98for a successful installation, but improve speed and capabilities. See
99L<PDF::Builder::Docs/Optional Libraries> for more information.
100
101=head2 STRINGS (CHARACTER TEXT)
102
103There are some things you should know about character encoding (for text),
104before you dive in to coding. Please go to L<PDF::Builder::Docs/Strings (Character Text)> and have a read.
105
106=head2 RENDERING ORDER
107
108Invoking "text" and "graphics" methods can lead to unexpected results (a
109different ordering of output than intended). See L<PDF::Builder::Docs/Rendering Order> for more information.
110
111=head2 PDF VERSIONS SUPPORTED
112
113PDF::Builder is mostly PDF 1.4-compliant, but there I<are> complications you
114should be aware of. Please read L<PDF::Builder::Docs/PDF Versions Supported>
115for details.
116
117=head2 SUPPORTED PERL VERSIONS
118
119PDF::Builder intends to support all major Perl versions that were released in
120the past six years, plus one, in order to continue working for the life of
121most long-term-stable (LTS) server distributions.
122See the L<https://www.cpan.org/src/> table
123B<First release in each branch of Perl> x.xxxx0 "Major" release dates.
124
125For example, a version of PDF::Builder released on 2018-06-05 would support
126the last major version of Perl released I<on or after> 2012-06-05 (5.18), and
127then one before that, which would be 5.16. Alternatively, the last major
128version of Perl released I<before> 2012-06-05 is 5.16.
129
130The intent is to avoid expending unnecessary effort in supporting very old
131(obsolete) versions of Perl.
132If you need to use this module on a server with an extremely out-of-date version
133of Perl, consider using either plenv or Perlbrew to run a newer version of Perl
134without needing admin privileges.
135
136=head2 KNOWN ISSUES
137
138This module does not work with perl's -l command-line switch.
139
140There is a file INFO/KNOWN_INCOMP which lists known incompatibilities with
141PDF::API2, in case you're thinking of porting over something from that world,
142or have experience there and want to try PDF::Builder. There is also a file
143INFO/DEPRECATED, which lists things which are planned to be removed at some
144point.
145
146=head2 HISTORY
147
148The history of PDF::Builder is a complex and exciting saga... OK, it may be
149mildly interesting. Have a look at L<PDF::Builder::Docs/History> section.
150
151=head1 AUTHOR
152
153PDF::API2 was originally written by Alfred Reibenschuh. See the HISTORY section
154for more information.
155
156It was maintained by Steve Simms.
157
158PDF::Builder is currently being maintained by Phil M. Perry.
159
160=head2 SUPPORT
161
162The full source is on https://github.com/PhilterPaper/Perl-PDF-Builder.
163
164The release distribution is on CPAN: https://metacpan.org/pod/PDF::Builder.
165
166Bug 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
168Do B<not> under I<any> 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
172This software is Copyright (c) 2017-2021 by Phil M. Perry.
173
174This is free software, licensed under:
175
176The 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
181This section of Builder.pm is intended only as a very brief summary
182of the license; please consider INFO/LICENSE to be the controlling version,
183if there is any conflict or ambiguity between the two.
184
185This program is free software; you can redistribute it and/or modify it under
186the terms of the GNU Lesser General Public License, as published by the Free
187Software Foundation, either version 2.1 of the License, or (at your option) any
188later version of this license.
189
190NOTE: there are several files in this distribution which were incorporated from
191outside sources and carry different licenses. If a file states that it is under
192a license different than LGPL 2.1, that license and its terms will apply to
193that file, and not LGPL 2.1.
194
195This library is distributed in the hope that it will be useful, but WITHOUT ANY
196WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
197PARTICULAR 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
207Creates a new PDF object.
208
209B<Options>
210
211=over
212
213=item -file
214
215If you will be saving it as a file and
216already know the filename, you can give the '-file' option to minimize
217possible memory requirements later on.
218
219=item -compress
220
221The '-compress' option can be
222given to specify stream compression: default is 'flate', 'none' is no
223compression. No other compression methods are currently supported.
224
225=item -outver
226
227The '-outver' option defaults to 1.4 as the output PDF version and the highest
228allowed feature version (attempts to use anything higher will give a warning).
229If an existing PDF with a higher version is read in, -outver will be increased
230to that version, with a warning.
231
232=item -msgver
233
234The '-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
236being read in, or a higher level feature was requested. A value of 0
237suppresses the warning message.
238
239=item -diaglevel
240
241The '-diaglevel' option can be
242given to specify the level of diagnostics given by IntegrityCheck(). The
243default is level 2 (errors and warnings).
244See L<PDF::Builder::Docs/IntegrityCheck> for more information.
245
246=back
247
248B<Example:>
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
267sub new {
268    my ($class, %options) = @_;
269
270    my $self = {};
271    bless $self, $class;
272    $self->{'pdf'} = PDF::Builder::Basic::PDF::File->new();
273
274    # make available to other routines
275    $myself = $self->{'pdf'};
276
277    # default output version
278    $self->{'pdf'}->{' version'} = $outVer;
279    $self->{'pages'} = PDF::Builder::Basic::PDF::Pages->new($self->{'pdf'});
280    $self->{'pages'}->proc_set(qw(PDF Text ImageB ImageC ImageI));
281    $self->{'pages'}->{'Resources'} ||= PDFDict();
282    $self->{'pdf'}->new_obj($self->{'pages'}->{'Resources'}) unless $self->{'pages'}->{'Resources'}->is_obj($self->{'pdf'});
283    $self->{'catalog'} = $self->{'pdf'}->{'Root'};
284    weaken $self->{'catalog'};
285    $self->{'fonts'} = {};
286    $self->{'pagestack'} = [];
287
288    $self->{'pdf'}->{' userUnit'} = 1.0; # default global User Unit
289    $self->mediabox('letter');  # default to US Letter 8.5in x 11in
290
291    if (exists $options{'-compress'}) {
292      $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      $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    if (exists $options{'-diaglevel'}) {
301	my $diaglevel = $options{'-diaglevel'};
302	if ($diaglevel < 0 || $diaglevel > 5) {
303	    print "-diaglevel must be in range 0-5. using 2\n";
304	    $diaglevel = 2;
305	}
306	$self->{'diaglevel'} = $diaglevel;
307    } else {
308	$self->{'diaglevel'} = 2; # default: errors and warnings
309    }
310
311    $self->preferences(%options);
312    if (defined $options{'-outver'}) {
313        if ($options{'-outver'} >= 1.4) {
314	    $self->{'pdf'}->{' version'} = $outVer = $options{'-outver'};
315	} else {
316	    print STDERR "Invalid -outver given, or less than 1.4. Ignored.\n";
317	}
318    }
319    if (defined $options{'-msgver'}) {
320        if ($options{'-msgver'} == 0 || $options{'-msgver'} == 1) {
321            $msgVer = $options{'-msgver'};
322        } else {
323            print STDERR "Invalid -msgver given, not 0 or 1. Ignored.\n";
324        }
325    }
326    if ($options{'-file'}) {
327        $self->{'pdf'}->create_file($options{'-file'});
328        $self->{'partial_save'} = 1;
329    }
330    $self->{'infoMeta'} = [qw(Author CreationDate ModDate Creator Producer Title Subject Keywords)];
331
332    my $version = eval { $PDF::Builder::VERSION } || '(Unreleased Version)';
333   #$self->info('Producer' => "PDF::Builder $version [$^O]");
334    $self->info('Producer' => "PDF::Builder $version [see https://github.com/PhilterPaper/Perl-PDF-Builder/blob/master/INFO/SUPPORT]");
335
336    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
343Opens an existing PDF file. See C<new()> for options.
344
345B<Example:>
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
357sub open {  ## no critic
358    my ($class, $file, %options) = @_;
359    croak "File '$file' does not exist" unless -f $file;
360    croak "File '$file' is not readable" unless -r $file;
361
362    my $content;
363    my $scalar_fh = FileHandle->new();
364    CORE::open($scalar_fh, '+<', \$content) or die "Can't begin scalar IO";
365    binmode $scalar_fh, ':raw';
366
367    my $disk_fh = FileHandle->new();
368    CORE::open($disk_fh, '<', $file) or die "Can't open $file for reading: $!";
369    binmode $disk_fh, ':raw';
370    $disk_fh->seek(0, 0);
371    my $data;
372    while (not $disk_fh->eof()) {
373        $disk_fh->read($data, 512);
374        $scalar_fh->print($data);
375    }
376    # check if final %%EOF lacks a carriage return on the end (add one)
377    if ($data =~ m/%%EOF$/) {
378       #print "open() says missing final EOF\n";
379        $scalar_fh->print("\n");
380    }
381    $disk_fh->close();
382    $scalar_fh->seek(0, 0);
383
384    my $self = $class->open_scalar($content, %options);
385    $self->{'pdf'}->{' fname'} = $file;
386
387    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#
403sub verCheckOutput {
404    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    if ($PDFver > $outVer) {
409        if ($msgVer) {
410	    print "PDF version of requested feature '$featureName'\n  is higher than outVer of $outVer (outVer reset to $PDFver)\n";
411	}
412        $outVer = $myself->{' version'} = $PDFver;
413        return 1;
414    } else {
415        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
435sub verCheckInput {
436    my ($self, $PDFver) = @_;
437
438    # warning message and bump up outVer if read-in PDF level higher
439    if ($PDFver > $outVer) {
440        if ($msgVer) {
441	    print "PDF version just read in is higher than outVer of $outVer (outVer reset to $PDFver)\n";
442	}
443        $outVer = $self->{'pdf'}->{' version'} = $PDFver;
444        return 1;
445    } else {
446        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
454Opens a PDF contained in a string. See C<new()> for other options.
455
456=over
457
458=item -diags => 1
459
460Display warnings when non-conforming PDF structure is found, and fix up
461where possible. See L<PDF::Builder::Basic::PDF::File> for more information.
462
463=back
464
465B<Example:>
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
479sub open_scalar {
480    my ($class, $content, %options) = @_;
481
482    my $self = {};
483    bless $self, $class;
484    foreach my $parameter (keys %options) {
485        $self->default($parameter, $options{$parameter});
486    }
487
488    $self->{'content_ref'} = \$content;
489    my $diaglevel = 2;
490    if (defined $self->{'diaglevel'}) { $diaglevel = $self->{'diaglevel'}; }
491    if ($diaglevel < 0 || $diaglevel > 5) { $diaglevel = 2; }
492    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    if (defined $newVer) {
497	my ($verStr, $currentVer, $pos);
498	$pos = index $content, "%PDF-";
499	if ($pos < 0) { die "no PDF version found in PDF input!\n"; }
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	$verStr = substr($content, $pos, 10);
503	if ($verStr =~ m#^%PDF-(\d+)\.(\d+)#) {
504	    $currentVer = "$1.$2";
505	} else {
506	    die "unable to get PDF input's version number.\n";
507        }
508        if ($newVer > $currentVer) {
509	    if (length($newVer) > length($currentVer)) {
510		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		if (length($newVer) < length($currentVer)) {
513		    # unlikely, but cover all the bases
514		    $newVer = substr($newVer, 0, length($currentVer));
515		}
516	        substr($content, $pos+5, length($newVer)) = $newVer;
517		$outVer = $newVer;
518            }
519	}
520    }
521
522    my $fh;
523    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    $self->{'pdf'} = PDF::Builder::Basic::PDF::File->open($fh, 1, %options);
527    $self->{'pdf'}->{'Root'}->realise();
528    $self->{'pages'} = $self->{'pdf'}->{'Root'}->{'Pages'}->realise();
529    weaken $self->{'pages'};
530
531    $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    $self->verCheckInput($self->{'pdf'}->{' version'});
535
536    my @pages = _proc_pages($self->{'pdf'}, $self->{'pages'});
537    $self->{'pagestack'} = [sort { $a->{' pnum'} <=> $b->{' pnum'} } @pages];
538    weaken $self->{'pagestack'}->[$_] for (0 .. scalar @{$self->{'pagestack'}});
539    $self->{'catalog'} = $self->{'pdf'}->{'Root'};
540    weaken $self->{'catalog'};
541    $self->{'opened_scalar'} = 1;
542    if (exists $options{'-compress'}) {
543      $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      $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    if (exists $options{'-diaglevel'}) {
552      $self->{'diaglevel'} = $options{'-diaglevel'};
553      if ($self->{'diaglevel'} < 0 || $self->{'diaglevel'} > 5) {
554        $self->{'diaglevel'} = 2;
555      }
556    } else {
557      $self->{'diaglevel'} = 2;
558    }
559    $self->{'fonts'} = {};
560    $self->{'infoMeta'} = [qw(Author CreationDate ModDate Creator Producer Title Subject Keywords)];
561
562    return $self;
563} # end of open_scalar()
564
565=item $pdf->preferences(%options)
566
567Controls viewing preferences for the PDF, including the B<Page Mode>,
568B<Page Layout>, B<Viewer>, and B<Initial Page> Options. See
569L<PDF::Builder::Docs/Preferences - set user display preferences> for details on all these
570option groups.
571
572=cut
573
574sub preferences {
575    my ($self, %options) = @_;
576
577    # Page Mode Options
578    if      ($options{'-fullscreen'}) {
579        $self->{'catalog'}->{'PageMode'} = PDFName('FullScreen');
580    } elsif ($options{'-thumbs'}) {
581        $self->{'catalog'}->{'PageMode'} = PDFName('UseThumbs');
582    } elsif ($options{'-outlines'}) {
583        $self->{'catalog'}->{'PageMode'} = PDFName('UseOutlines');
584    } else {
585        $self->{'catalog'}->{'PageMode'} = PDFName('UseNone');
586    }
587
588    # Page Layout Options
589    if      ($options{'-singlepage'}) {
590        $self->{'catalog'}->{'PageLayout'} = PDFName('SinglePage');
591    } elsif ($options{'-onecolumn'}) {
592        $self->{'catalog'}->{'PageLayout'} = PDFName('OneColumn');
593    } elsif ($options{'-twocolumnleft'}) {
594        $self->{'catalog'}->{'PageLayout'} = PDFName('TwoColumnLeft');
595    } elsif ($options{'-twocolumnright'}) {
596        $self->{'catalog'}->{'PageLayout'} = PDFName('TwoColumnRight');
597    } else {
598        $self->{'catalog'}->{'PageLayout'} = PDFName('SinglePage');
599    }
600
601    # Viewer Preferences
602    $self->{'catalog'}->{'ViewerPreferences'} ||= PDFDict();
603    $self->{'catalog'}->{'ViewerPreferences'}->realise();
604
605    if ($options{'-hidetoolbar'}) {
606        $self->{'catalog'}->{'ViewerPreferences'}->{'HideToolbar'} = PDFBool(1);
607    }
608    if ($options{'-hidemenubar'}) {
609        $self->{'catalog'}->{'ViewerPreferences'}->{'HideMenubar'} = PDFBool(1);
610    }
611    if ($options{'-hidewindowui'}) {
612        $self->{'catalog'}->{'ViewerPreferences'}->{'HideWindowUI'} = PDFBool(1);
613    }
614    if ($options{'-fitwindow'}) {
615        $self->{'catalog'}->{'ViewerPreferences'}->{'FitWindow'} = PDFBool(1);
616    }
617    if ($options{'-centerwindow'}) {
618        $self->{'catalog'}->{'ViewerPreferences'}->{'CenterWindow'} = PDFBool(1);
619    }
620    if ($options{'-displaytitle'}) {
621        $self->{'catalog'}->{'ViewerPreferences'}->{'DisplayDocTitle'} = PDFBool(1);
622    }
623    if ($options{'-righttoleft'}) {
624        $self->{'catalog'}->{'ViewerPreferences'}->{'Direction'} = PDFName('R2L');
625    }
626
627    if      ($options{'-afterfullscreenthumbs'}) {
628        $self->{'catalog'}->{'ViewerPreferences'}->{'NonFullScreenPageMode'} = PDFName('UseThumbs');
629    } elsif ($options{'-afterfullscreenoutlines'}) {
630        $self->{'catalog'}->{'ViewerPreferences'}->{'NonFullScreenPageMode'} = PDFName('UseOutlines');
631    } else {
632        $self->{'catalog'}->{'ViewerPreferences'}->{'NonFullScreenPageMode'} = PDFName('UseNone');
633    }
634
635    if ($options{'-printscalingnone'}) {
636        $self->{'catalog'}->{'ViewerPreferences'}->{'PrintScaling'} = PDFName('None');
637    }
638
639    if      ($options{'-simplex'}) {
640        $self->{'catalog'}->{'ViewerPreferences'}->{'Duplex'} = PDFName('Simplex');
641    } elsif ($options{'-duplexfliplongedge'}) {
642        $self->{'catalog'}->{'ViewerPreferences'}->{'Duplex'} = PDFName('DuplexFlipLongEdge');
643    } elsif ($options{'-duplexflipshortedge'}) {
644        $self->{'catalog'}->{'ViewerPreferences'}->{'Duplex'} = PDFName('DuplexFlipShortEdge');
645    }
646
647    # Open Action
648    if ($options{'-firstpage'}) {
649        my ($page, %args) = @{$options{'-firstpage'}};
650        $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        $page = PDFNum($page) unless ref($page);
655
656        if      (defined $args{'-fit'}) {
657            $self->{'catalog'}->{'OpenAction'} = PDFArray($page, PDFName('Fit'));
658        } elsif (defined $args{'-fith'}) {
659            $self->{'catalog'}->{'OpenAction'} = PDFArray($page, PDFName('FitH'), PDFNum($args{'-fith'}));
660        } elsif (defined $args{'-fitb'}) {
661            $self->{'catalog'}->{'OpenAction'} = PDFArray($page, PDFName('FitB'));
662        } elsif (defined $args{'-fitbh'}) {
663            $self->{'catalog'}->{'OpenAction'} = PDFArray($page, PDFName('FitBH'), PDFNum($args{'-fitbh'}));
664        } elsif (defined $args{'-fitv'}) {
665            $self->{'catalog'}->{'OpenAction'} = PDFArray($page, PDFName('FitV'), PDFNum($args{'-fitv'}));
666        } elsif (defined $args{'-fitbv'}) {
667            $self->{'catalog'}->{'OpenAction'} = PDFArray($page, PDFName('FitBV'), PDFNum($args{'-fitbv'}));
668        } elsif (defined $args{'-fitr'}) {
669            croak 'insufficient parameters to -fitr => []' unless scalar @{$args{'-fitr'}} == 4;
670            $self->{'catalog'}->{'OpenAction'} = PDFArray($page, PDFName('FitR'), map { PDFNum($_) } @{$args{'-fitr'}});
671        } elsif (defined $args{'-xyz'}) {
672            croak 'insufficient parameters to -xyz => []' unless scalar @{$args{'-xyz'}} == 3;
673            $self->{'catalog'}->{'OpenAction'} = PDFArray($page, PDFName('XYZ'), map { PDFNum($_) } @{$args{'-xyz'}});
674        }
675    }
676    $self->{'pdf'}->out_obj($self->{'catalog'});
677
678    return $self;
679}  # end of preferences()
680
681=item $val = $pdf->default($parameter)
682
683=item $pdf->default($parameter, $value)
684
685Gets/sets the default value for a behavior of PDF::Builder.
686
687B<Supported Parameters:>
688
689=over
690
691=item nounrotate
692
693prohibits Builder from rotating imported/opened page to re-create a
694default pdf-context.
695
696=item pageencaps
697
698enables Builder's adding save/restore commands upon importing/opening
699pages to preserve graphics-state for modification.
700
701=item copyannots
702
703enables importing of annotations (B<*EXPERIMENTAL*>).
704
705=back
706
707B<CAUTION:> 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
709be aware that this name I<may> have to be changed in the future.
710
711=cut
712
713sub default {
714    my ($self, $parameter, $value) = @_;
715
716    # Parameter names may consist of lowercase letters, numbers, and underscores
717    $parameter = lc $parameter;
718    $parameter =~ s/[^a-z\d_]//g;
719
720    my $previous_value = $self->{$parameter};
721    if (defined $value) {
722        $self->{$parameter} = $value;
723    }
724
725    return $previous_value;
726}
727
728=item $version = $pdf->version($new_version)
729
730=item $version = $pdf->version()
731
732Get/set the PDF version (e.g. 1.4).
733
734For compatibility with earlier releases, if no decimal point is given, assume
735"1." precedes the number given.
736
737A warning message is given if you attempt to I<decrease> the PDF version, as you
738might have already read in a higher level file, or used a higher level feature.
739
740=cut
741
742sub version {
743    my $self = shift();
744    if (scalar @_) {
745        my $version = shift();
746	if ($version =~ m/^\d+$/) { $version = "1.$version"; }  # no x.? assume it's 1.something
747        croak "Invalid version $version" unless $version =~ /^(\d+\.\d+)$/;
748	if ($outVer > $1) {
749	    print "Warning: call to self->version() to LOWER the output PDF version number!\n";
750	}
751        $self->{'pdf'}->{' version'} = $outVer = $1;
752    }
753
754    return $self->{'pdf'}->{' version'};
755}
756
757=item $bool = $pdf->isEncrypted()
758
759Checks if the previously opened PDF is encrypted.
760
761=cut
762
763sub isEncrypted {
764    my $self = shift();
765    return defined($self->{'pdf'}->{'Encrypt'}) ? 1 : 0;
766}
767
768=item %infohash = $pdf->info(%infohash)
769
770Gets/sets the info structure of the document.
771
772See L<PDF::Builder::Docs/info Example> section for an example of the use
773of this method.
774
775=cut
776
777sub info {
778    my ($self, %opt) = @_;
779
780    if (not defined($self->{'pdf'}->{'Info'})) {
781        $self->{'pdf'}->{'Info'} = PDFDict();
782        $self->{'pdf'}->new_obj($self->{'pdf'}->{'Info'});
783    } else {
784        $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    if (scalar @_) {
790        foreach my $k (@{$self->{'infoMeta'}}) {
791            next unless defined $opt{$k};
792            $self->{'pdf'}->{'Info'}->{$k} = PDFString($opt{$k} || 'NONE', 'm');
793        }
794        $self->{'pdf'}->out_obj($self->{'pdf'}->{'Info'});
795    }
796
797    if (defined $self->{'pdf'}->{'Info'}) {
798        %opt = ();
799        foreach my $k (@{$self->{'infoMeta'}}) {
800            next unless defined $self->{'pdf'}->{'Info'}->{$k};
801            $opt{$k} = $self->{'pdf'}->{'Info'}->{$k}->val();
802            if ((unpack('n', $opt{$k}) == 0xfffe) or (unpack('n', $opt{$k}) == 0xfeff)) {
803                $opt{$k} = decode('UTF-16', $self->{'pdf'}->{'Info'}->{$k}->val());
804            }
805        }
806    }
807
808    return %opt;
809} # end of info()
810
811=item @metadata_attributes = $pdf->infoMetaAttributes(@metadata_attributes)
812
813Gets/sets the supported info-structure tags.
814
815B<Example:>
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
825sub infoMetaAttributes {
826    my ($self, @attr) = @_;
827
828    if (scalar @attr) {
829        my %at = map { $_ => 1 } @{$self->{'infoMeta'}}, @attr;
830        @{$self->{'infoMeta'}} = keys %at;
831    }
832
833    return @{$self->{'infoMeta'}};
834}
835
836=item $xml = $pdf->xmpMetadata($xml)
837
838Gets/sets the XMP XML data stream.
839
840See L<PDF::Builder::Docs/XMP XML example> section for an example of the use
841of this method.
842
843=cut
844
845sub xmpMetadata {
846    my ($self, $value) = @_;
847
848    if (not defined($self->{'catalog'}->{'Metadata'})) {
849        $self->{'catalog'}->{'Metadata'} = PDFDict();
850        $self->{'catalog'}->{'Metadata'}->{'Type'} = PDFName('Metadata');
851        $self->{'catalog'}->{'Metadata'}->{'Subtype'} = PDFName('XML');
852        $self->{'pdf'}->new_obj($self->{'catalog'}->{'Metadata'});
853    } else {
854        $self->{'catalog'}->{'Metadata'}->realise();
855        $self->{'catalog'}->{'Metadata'}->{' stream'} = unfilter($self->{'catalog'}->{'Metadata'}->{'Filter'}, $self->{'catalog'}->{'Metadata'}->{' stream'});
856        delete $self->{'catalog'}->{'Metadata'}->{' nofilt'};
857        delete $self->{'catalog'}->{'Metadata'}->{'Filter'};
858    }
859
860    my $md = $self->{'catalog'}->{'Metadata'};
861
862    if (defined $value) {
863        $md->{' stream'} = $value;
864        delete $md->{'Filter'};
865        delete $md->{' nofilt'};
866        $self->{'pdf'}->out_obj($md);
867        $self->{'pdf'}->out_obj($self->{'catalog'});
868    }
869
870    return $md->{' stream'};
871} # end of xmpMetadata()
872
873=item $pdf->pageLabel($index, $options)
874
875Sets page label options.
876
877B<Supported Options:>
878
879=over
880
881=item -style
882
883Roman, roman, decimal, Alpha or alpha.
884
885=item -start
886
887Restart numbering at given number.
888
889=item -prefix
890
891Text prefix for numbering.
892
893=back
894
895B<Example:>
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
928sub pageLabel {
929    my $self = shift();
930
931    $self->{'catalog'}->{'PageLabels'} ||= PDFDict();
932    $self->{'catalog'}->{'PageLabels'}->{'Nums'} ||= PDFArray();
933
934    my $nums = $self->{'catalog'}->{'PageLabels'}->{'Nums'};
935    while (scalar @_) {
936        my $index = shift();
937        my $opts = shift();
938
939        $nums->add_elements(PDFNum($index));
940
941        my $d = PDFDict();
942        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                                $opts->{'-style'} eq 'alpha' ? 'a' : 'D');
947        } else {
948            $d->{'S'} = PDFName('D');
949        }
950
951        if (defined $opts->{'-prefix'}) {
952            $d->{'P'} = PDFString($opts->{'-prefix'}, 's');
953        }
954
955        if (defined $opts->{'-start'}) {
956            $d->{'St'} = PDFNum($opts->{'-start'});
957        }
958
959        $nums->add_elements($d);
960    }
961
962    return;
963} # end of pageLabel()
964
965=item $pdf->finishobjects(@objects)
966
967Force objects to be written to file if possible.
968
969B<Example:>
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
979sub finishobjects {
980    my ($self, @objs) = @_;
981
982    if ($self->{'opened_scalar'}) {
983        die "invalid method invocation: no file, use 'saveas' instead.";
984    } elsif ($self->{'partial_save'}) {
985        $self->{'pdf'}->ship_out(@objs);
986    } else {
987        die "invalid method invocation: no file, use 'saveas' instead.";
988    }
989
990    return;
991}
992
993sub _proc_pages {
994    my ($pdf, $object) = @_;
995
996    if (defined $object->{'Resources'}) {
997        eval {
998            $object->{'Resources'}->realise();
999        };
1000    }
1001
1002    my @pages;
1003    $pdf->{' apipagecount'} ||= 0;
1004    foreach my $page ($object->{'Kids'}->elements()) {
1005        $page->realise();
1006        if ($page->{'Type'}->val() eq 'Pages') {
1007            push @pages, _proc_pages($pdf, $page);
1008        }
1009        else {
1010            $pdf->{' apipagecount'}++;
1011            $page->{' pnum'} = $pdf->{' apipagecount'};
1012            if (defined $page->{'Resources'}) {
1013                eval {
1014                    $page->{'Resources'}->realise();
1015                };
1016            }
1017            push @pages, $page;
1018        }
1019    }
1020
1021    return @pages;
1022} # end of _proc_pages()
1023
1024=item $pdf->update()
1025
1026Saves a previously opened document.
1027
1028B<Example:>
1029
1030    $pdf = PDF::Builder->open('our/to/be/updated.pdf');
1031    ...
1032    $pdf->update();
1033
1034=cut
1035
1036sub update {
1037    my $self = shift();
1038    $self->saveas($self->{'pdf'}->{' fname'});
1039    return;
1040}
1041
1042=item $pdf->saveas($file)
1043
1044Save the document to $file and remove the object structure from memory.
1045
1046B<Caution:> Although the object C<$pdf> will still exist, it is no longer
1047usable for any purpose after invoking this method! You will receive error
1048messages about "can't call method new_obj on an undefined value".
1049
1050B<Example:>
1051
1052    $pdf = PDF::Builder->new();
1053    ...
1054    $pdf->saveas('our/new.pdf');
1055
1056=cut
1057
1058sub saveas {
1059    my ($self, $file) = @_;
1060
1061    if ($self->{'opened_scalar'}) {
1062        $self->{'pdf'}->append_file();
1063        my $fh;
1064        CORE::open($fh, '>', $file) or die "Can't open $file for writing: $!";
1065        binmode($fh, ':raw');
1066        print $fh ${$self->{'content_ref'}};
1067        CORE::close($fh);
1068    } elsif ($self->{'partial_save'}) {
1069        $self->{'pdf'}->close_file();
1070    } else {
1071        $self->{'pdf'}->out_file($file);
1072    }
1073
1074    $self->end();
1075    return;
1076}
1077
1078=item $pdf->save()
1079
1080Save the document to an already-defined file (or filename) and
1081remove the object structure from memory.
1082
1083B<Caution:> Although the object C<$pdf> will still exist, it is no longer
1084usable for any purpose after invoking this method! You will receive error
1085messages about "can't call method new_obj on an undefined value".
1086
1087B<Example:>
1088
1089    $pdf = PDF::Builder->new(-file => 'file_to_output');
1090    ...
1091    $pdf->save();
1092
1093=cut
1094
1095sub save {
1096    my ($self) = @_;
1097
1098    if      ($self->{'opened_scalar'}) {
1099        die "Invalid method invocation: use 'saveas' instead of 'save'.";
1100    } elsif ($self->{'partial_save'}) {
1101        $self->{'pdf'}->close_file();
1102    } else {
1103        die "Invalid method invocation: use 'saveas' instead of 'save'.";
1104    }
1105
1106    $self->end();
1107    return;
1108}
1109
1110=item $string = $pdf->stringify()
1111
1112Return the document as a string and remove the object structure from memory.
1113
1114B<Caution:> Although the object C<$pdf> will still exist, it is no longer
1115usable for any purpose after invoking this method! You will receive error
1116messages about "can't call method new_obj on an undefined value".
1117
1118B<Example:>
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
1137sub stringify {
1138    my $self = shift();
1139
1140    my $str = '';
1141    # is only set to 1 (within open_scalar()), otherwise is undef
1142    if ($self->{'opened_scalar'}) {
1143        $self->{'pdf'}->append_file();
1144        $str = ${$self->{'content_ref'}};
1145    } else {
1146        my $fh = FileHandle->new();
1147        # we should be writing to the STRING $str
1148        CORE::open($fh, '>', \$str) || die "Can't begin scalar IO";
1149        $self->{'pdf'}->out_file($fh);
1150        $fh->close();
1151    }
1152    $self->end();
1153
1154    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)
1159sub release {
1160    my $self = shift();
1161    $self->end();
1162    return;
1163}
1164
1165=item $pdf->end()
1166
1167Remove the object structure from memory. PDF::Builder contains circular
1168references, so this call is necessary in long-running processes to
1169keep from running out of memory.
1170
1171This will be called automatically when you save or stringify a PDF.
1172You should only need to call it explicitly if you are reading PDF
1173files and not writing them.
1174
1175=cut
1176
1177sub end {
1178    my $self = shift();
1179    $self->{'pdf'}->release() if defined $self->{'pdf'};
1180
1181    foreach my $key (keys %$self) {
1182        $self->{$key} = undef;
1183        delete $self->{$key};
1184    }
1185
1186    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
1199Returns a I<new> page object.  By default, the page is added to the end
1200of the document.  If you give an existing page number, the new page
1201will be inserted in that position, pushing existing pages back by 1 (e.g.,
1202C<page(5)> would insert an empty page 5, with the old page 5 now page 6,
1203etc.
1204
1205If $page_number is -1, the new page is inserted as the second-last page;
1206if $page_number is 0, the new page is inserted as the last page.
1207
1208B<Example:>
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
1220sub page {
1221    my $self = shift();
1222    my $index = shift() || 0;  # default to new "last" page
1223    my $page;
1224
1225    if ($index == 0) {
1226        $page = PDF::Builder::Page->new($self->{'pdf'}, $self->{'pages'});
1227    } else {
1228        $page = PDF::Builder::Page->new($self->{'pdf'}, $self->{'pages'}, $index-1);
1229    }
1230    $page->{' apipdf'} = $self->{'pdf'};
1231    $page->{' api'} = $self;
1232    weaken $page->{' apipdf'};
1233    weaken $page->{' api'};
1234    $self->{'pdf'}->out_obj($page);
1235    $self->{'pdf'}->out_obj($self->{'pages'});
1236    if ($index == 0) {
1237        push @{$self->{'pagestack'}}, $page;
1238        weaken $self->{'pagestack'}->[-1];
1239    } elsif ($index < 0) {
1240        splice @{$self->{'pagestack'}}, $index, 0, $page;
1241        weaken $self->{'pagestack'}->[$index];
1242    } else {
1243        splice @{$self->{'pagestack'}}, $index-1, 0, $page;
1244        weaken $self->{'pagestack'}->[$index - 1];
1245    }
1246
1247    #   $page->{'Resources'}=$self->{'pages'}->{'Resources'};
1248    return $page;
1249} # end of page()
1250
1251=item $page = $pdf->open_page($page_number)
1252
1253Returns the L<PDF::Builder::Page> object of page $page_number.
1254This is similar to C<< $page = $pdf->page() >>, except that C<$page> is
1255I<not> a new, empty page; but contains the contents of that existing page.
1256
1257If $page_number is 0 or -1, it will return the last page in the
1258document.
1259
1260B<Example:>
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
1270sub open_page {
1271    my $self = shift();
1272    my $index = shift() || 0;
1273    my ($page, $rotate, $media, $trans);
1274
1275    if ($index == 0) {
1276        $page = $self->{'pagestack'}->[-1];
1277    } elsif ($index < 0) {
1278        $page = $self->{'pagestack'}->[$index];
1279    } else {
1280        $page = $self->{'pagestack'}->[$index - 1];
1281    }
1282    return unless ref($page);
1283
1284    if (ref($page) ne 'PDF::Builder::Page') {
1285        bless $page, 'PDF::Builder::Page';
1286        $page->{' apipdf'} = $self->{'pdf'};
1287        $page->{' api'} = $self;
1288        weaken $page->{' apipdf'};
1289        weaken $page->{' api'};
1290        $self->{'pdf'}->out_obj($page);
1291        if (($rotate = $page->find_prop('Rotate')) and not $page->{' opened'}) {
1292            $rotate = ($rotate->val() + 360) % 360;
1293
1294            if ($rotate != 0 and not $self->default('nounrotate')) {
1295                $page->{'Rotate'} = PDFNum(0);
1296                foreach my $mediatype (qw(MediaBox CropBox BleedBox TrimBox ArtBox)) {
1297                    if ($media = $page->find_prop($mediatype)) {
1298                        $media = [ map { $_->val() } $media->elements() ];
1299                    } else {
1300                        $media = [0, 0, 612, 792]; # US Letter default
1301                        next if $mediatype ne 'MediaBox';
1302                    }
1303                    if ($rotate == 90) {
1304                        $trans = "0 -1 1 0 0 $media->[2] cm" if $mediatype eq 'MediaBox';
1305                        $media = [$media->[1], $media->[0], $media->[3], $media->[2]];
1306                    } elsif ($rotate == 180) {
1307                        $trans = "-1 0 0 -1 $media->[2] $media->[3] cm" if $mediatype eq 'MediaBox';
1308                    } elsif ($rotate == 270) {
1309                        $trans = "0 1 -1 0 $media->[3] 0 cm" if $mediatype eq 'MediaBox';
1310                        $media = [$media->[1], $media->[0], $media->[3], $media->[2]];
1311                    }
1312                    $page->{$mediatype} = PDFArray(map { PDFNum($_) } @$media);
1313                }
1314            } else {
1315                $trans = '';
1316            }
1317        } else {
1318            $trans = '';
1319        }
1320
1321        if (defined $page->{'Contents'} and not $page->{' opened'}) {
1322            $page->fixcontents();
1323            my $uncontent = delete $page->{'Contents'};
1324            my $content = $page->gfx();
1325            $content->add(" $trans ");
1326
1327            if ($self->default('pageencaps')) {
1328                $content->{' stream'} .= ' q ';
1329            }
1330            foreach my $k ($uncontent->elements()) {
1331                $k->realise();
1332                $content->{' stream'} .= ' ' . unfilter($k->{'Filter'}, $k->{' stream'}) . ' ';
1333            }
1334            if ($self->default('pageencaps')) {
1335                $content->{' stream'} .= ' Q ';
1336            }
1337
1338            # if we like compress we will do it now to do quicker saves
1339            if ($self->{'forcecompress'} eq 'flate' ||
1340                $self->{'forcecompress'} =~ m/^[1-9]\d*$/) {
1341                $content->{' stream'} = dofilter($content->{'Filter'}, $content->{' stream'});
1342                $content->{' nofilt'} = 1;
1343                delete $content->{'-docompress'};
1344                $content->{'Length'} = PDFNum(length($content->{' stream'}));
1345            }
1346        }
1347        $page->{' opened'} = 1;
1348    }
1349
1350    $self->{'pdf'}->out_obj($page);
1351    $self->{'pdf'}->out_obj($self->{'pages'});
1352    $page->{' apipdf'} = $self->{'pdf'};
1353    $page->{' api'} = $self;
1354    weaken $page->{' apipdf'};
1355    weaken $page->{' api'};
1356
1357    return $page;
1358} # end of openpage()
1359
1360=item $page = $pdf->openpage($page_number)
1361
1362B<Deprecated.> Will be removed on or after June, 2023. Use C<open_page> call
1363instead.
1364
1365=cut
1366
1367sub openpage { return open_page(@_); } ## no critic
1368
1369# internal utility
1370
1371sub _walk_obj {
1372    my ($object_cache, $source_pdf, $target_pdf, $source_object, @keys) = @_;
1373
1374    if (ref($source_object) =~ /Objind$/) {
1375        $source_object->realise();
1376    }
1377
1378    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    my $target_object = $source_object->copy($source_pdf); ## thanks to: yaheath // Fri, 17 Sep 2004
1382
1383   #$source_object->{' copied'} = 1;
1384    $target_pdf->new_obj($target_object) if $source_object->is_obj($source_pdf);
1385
1386    $object_cache->{scalar $source_object} = $target_object;
1387
1388    if (ref($source_object) =~ /Array$/) {
1389        $target_object->{' val'} = [];
1390        foreach my $k ($source_object->elements()) {
1391            $k->realise() if ref($k) =~ /Objind$/;
1392            $target_object->add_elements(_walk_obj($object_cache, $source_pdf, $target_pdf, $k));
1393        }
1394    } elsif (ref($source_object) =~ /Dict$/) {
1395        @keys = keys(%$target_object) unless scalar @keys;
1396        foreach my $k (@keys) {
1397            next if $k =~ /^ /;
1398            next unless defined $source_object->{$k};
1399            $target_object->{$k} = _walk_obj($object_cache, $source_pdf, $target_pdf, $source_object->{$k});
1400        }
1401        if ($source_object->{' stream'}) {
1402            if ($target_object->{'Filter'}) {
1403                $target_object->{' nofilt'} = 1;
1404            } else {
1405                delete $target_object->{' nofilt'};
1406                $target_object->{'Filter'} = PDFArray(PDFName('FlateDecode'));
1407            }
1408            $target_object->{' stream'} = $source_object->{' stream'};
1409        }
1410    }
1411    delete $target_object->{' streamloc'};
1412    delete $target_object->{' streamsrc'};
1413
1414    return $target_object;
1415} # end of _walk_obj()
1416
1417=item $xoform = $pdf->importPageIntoForm($source_pdf, $source_page_number)
1418
1419Returns a Form XObject created by extracting the specified page from
1420$source_pdf.
1421
1422This is useful if you want to transpose the imported page somewhat
1423differently onto a page (e.g. two-up, four-up, etc.).
1424
1425If $source_page_number is 0 or -1, it will return the last page in the
1426document.
1427
1428B<Example:>
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
1443B<Note:> You can only import a page from an existing PDF file.
1444
1445=cut
1446
1447sub importPageIntoForm {
1448    my ($self, $s_pdf, $s_idx) = @_;
1449    $s_idx ||= 0;
1450
1451    unless (ref($s_pdf) and $s_pdf->isa('PDF::Builder')) {
1452        die "Invalid usage: first argument must be PDF::Builder instance, not: " . ref($s_pdf);
1453    }
1454
1455    my ($s_page, $xo);
1456
1457    $xo = $self->xo_form();
1458
1459    if (ref($s_idx) eq 'PDF::Builder::Page') {
1460        $s_page = $s_idx;
1461    } else {
1462        $s_page = $s_pdf->open_page($s_idx);
1463    }
1464
1465    $self->{'apiimportcache'} ||= {};
1466    $self->{'apiimportcache'}->{$s_pdf} ||= {};
1467
1468    # This should never get past MediaBox, since it's a required object.
1469    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        next unless defined $s_page->find_prop($k);
1473        my $box = _walk_obj($self->{'apiimportcache'}->{$s_pdf}, $s_pdf->{'pdf'}, $self->{'pdf'}, $s_page->find_prop($k));
1474        $xo->bbox(map { $_->val() } $box->elements());
1475        last;
1476    }
1477    $xo->bbox(0,0, 612,792) unless defined $xo->{'BBox'}; # US Letter default
1478
1479    foreach my $k (qw(Resources)) {
1480        $s_page->{$k} = $s_page->find_prop($k);
1481        next unless defined $s_page->{$k};
1482        $s_page->{$k}->realise() if ref($s_page->{$k}) =~ /Objind$/;
1483
1484        foreach my $sk (qw(XObject ExtGState Font ProcSet Properties ColorSpace Pattern Shading)) {
1485            next unless defined $s_page->{$k}->{$sk};
1486            $s_page->{$k}->{$sk}->realise() if ref($s_page->{$k}->{$sk}) =~ /Objind$/;
1487            foreach my $ssk (keys %{$s_page->{$k}->{$sk}}) {
1488                next if $ssk =~ /^ /;
1489                $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    unless ($s_page->{' opened'}) {
1499        croak join(' ',
1500		   "Pages may only be imported from a complete PDF.",
1501		   "Save and reopen the source PDF object first.");
1502    }
1503
1504    if (defined $s_page->{'Contents'}) {
1505        $s_page->fixcontents();
1506
1507        $xo->{' stream'} = '';
1508        # open_page pages only contain one stream
1509        my ($k) = $s_page->{'Contents'}->elements();
1510        $k->realise();
1511        if ($k->{' nofilt'}) {
1512            # we have a finished stream here, so we unfilter
1513            $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            $xo->add('q', $k->{' stream'}, 'Q');
1518        }
1519        $xo->compressFlate() if $self->{'forcecompress'} eq 'flate' ||
1520	                        $self->{'forcecompress'} =~ m/^[1-9]\d*$/;
1521    }
1522
1523    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
1534Imports a page from $source_pdf and adds it to the specified position
1535in $pdf.
1536
1537If the C<$source_page_number> is omitted, 0, or -1; the last page of the
1538source is imported.
1539If the C<$target_page_number> is omitted, 0, or -1; the imported page will be
1540placed as the new last page of the target (C<$pdf>).
1541Otherwise, as with the C<page()> method, the page will be inserted before an
1542existing page of that number.
1543
1544B<Note:> If you pass a page I<object> instead of a page I<number> for
1545C<$target_page_number>, the contents of the page will be B<merged> into the
1546existing page.
1547
1548B<Example:>
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
1558B<Note:> You can only import a page from an existing PDF file.
1559
1560=cut
1561
1562# importpage() renamed to import_page()
1563
1564sub import_page {
1565    my ($self, $s_pdf, $s_idx, $t_idx) = @_;
1566
1567    $s_idx ||= 0;  # default to last page
1568    $t_idx ||= 0;  # default to last page
1569    my ($s_page, $t_page);
1570
1571    unless (ref($s_pdf) and $s_pdf->isa('PDF::Builder')) {
1572        die "Invalid usage: first argument must be PDF::Builder instance, not: " . ref($s_pdf);
1573    }
1574
1575    if (ref($s_idx) eq 'PDF::Builder::Page') {
1576        $s_page = $s_idx;
1577    } else {
1578        $s_page = $s_pdf->open_page($s_idx);
1579    }
1580
1581    if (ref($t_idx) eq 'PDF::Builder::Page') {
1582        $t_page = $t_idx;
1583    } else {
1584        if ($self->pages() < $t_idx) {
1585            $t_page = $self->page();
1586        } else {
1587            $t_page = $self->page($t_idx);
1588        }
1589    }
1590
1591    $self->{'apiimportcache'} = $self->{'apiimportcache'} || {};
1592    $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    my $xo = $self->importPageIntoForm($s_pdf, $s_page);
1598
1599    # copy all page dimensions
1600    foreach my $k (qw(MediaBox ArtBox TrimBox BleedBox CropBox)) {
1601        my $prop = $s_page->find_prop($k);
1602        next unless defined $prop;
1603
1604        my $box = _walk_obj({}, $s_pdf->{'pdf'}, $self->{'pdf'}, $prop);
1605        my $method = lc $k;
1606
1607        $t_page->$method(map { $_->val() } $box->elements());
1608    }
1609
1610    $t_page->gfx()->formimage($xo, 0, 0, 1);
1611
1612    # copy annotations and/or form elements as well
1613    if (exists $s_page->{'Annots'} and $s_page->{'Annots'} and $self->{'copyannots'}) {
1614        # first set up the AcroForm, if required
1615        my $AcroForm;
1616        if (my $a = $s_pdf->{'pdf'}->{'Root'}->realise()->{'AcroForm'}) {
1617            $a->realise();
1618
1619            $AcroForm = _walk_obj({}, $s_pdf->{'pdf'}, $self->{'pdf'}, $a, qw(NeedAppearances SigFlags CO DR DA Q));
1620        }
1621        my @Fields = ();
1622        my @Annots = ();
1623        foreach my $a ($s_page->{'Annots'}->elements()) {
1624            $a->realise();
1625            my $t_a = PDFDict();
1626            $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            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            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            my %ky = map { $_ => 1 } @k;
1660            # we do P separately, as it points to the page the Annotation is on
1661            delete $ky{'P'};
1662            # copy everything else
1663            foreach my $k (keys %ky) {
1664                next unless defined $a->{$k};
1665                $a->{$k}->realise();
1666                $t_a->{$k} = _walk_obj({}, $s_pdf->{'pdf'}, $self->{'pdf'}, $a->{$k});
1667            }
1668            $t_a->{'P'} = $t_page;
1669            push @Annots, $t_a;
1670            push @Fields, $t_a if ($AcroForm and $t_a->{'Subtype'}->val() eq 'Widget');
1671        }
1672        $t_page->{'Annots'} = PDFArray(@Annots);
1673        $AcroForm->{'Fields'} = PDFArray(@Fields) if $AcroForm;
1674        $self->{'pdf'}->{'Root'}->{'AcroForm'} = $AcroForm;
1675    }
1676    $t_page->{' imported'} = 1;
1677
1678    $self->{'pdf'}->out_obj($t_page);
1679    $self->{'pdf'}->out_obj($self->{'pages'});
1680
1681    return $t_page;
1682} # end of import_page()
1683
1684=item $count = $pdf->pages()
1685
1686Returns the number of pages in the document.
1687
1688=cut
1689
1690sub pages {
1691    my $self = shift();
1692    return scalar @{$self->{'pagestack'}};
1693}
1694
1695# set global User Unit scale factor (default 1.0)
1696
1697=item $pdf->userunit($value)
1698
1699Sets the global UserUnit, defining the scale factor to multiply any size or
1700coordinate by. For example, C<userunit(72)> results in a User Unit of 72 points,
1701or 1 inch.
1702
1703See L<PDF::Builder::Docs/User Units> for more information.
1704
1705=cut
1706
1707sub userunit {
1708    my ($self, $value) = @_;
1709
1710    if (float($value) <= 0.0) {
1711        warn "Invalid User Unit value '$value', set to 1.0";
1712        $value = 1.0;
1713    }
1714
1715    PDF::Builder->verCheckOutput(1.6, "set User Unit");
1716    $self->{'pdf'}->{' userUnit'} = float($value);
1717    $self->{'pages'}->{'UserUnit'} = PDFNum(float($value));
1718    if (defined $self->{'pages'}->{'MediaBox'}) { # should be default letter
1719        if ($value != 1.0) { # divide points by User Unit
1720            my @corners = ( 0, 0, 612/$value, 792/$value );
1721            $self->{'pages'}->{'MediaBox'} = PDFArray( map { PDFNum(float($_)) } @corners );
1722        }
1723    }
1724
1725    return $self;
1726}
1727
1728# utility to handle calling page_size, and name with or without -orient setting
1729sub _bbox {
1730    my ($self, @corners) = @_;
1731
1732    # if 1 or 3 elements in @corners, and [0] contains a letter, it's a name
1733    my $isName = 0;
1734    if (scalar @corners && $corners[0] =~ m/[a-z]/i) { $isName = 1; }
1735
1736    if (scalar @corners == 3) {
1737	    # name plus one option (-orient)
1738	    my ($name, %opts) = @corners;
1739	    @corners = page_size(($name)); # now 4 numeric values
1740	    if (defined $opts{'-orient'}) {
1741	        if ($opts{'-orient'} =~ m/^l/i) { # 'landscape' or just 'l'
1742		        # 0 0 W H -> 0 0 H W
1743		        my $temp;
1744		        $temp = $corners[2]; $corners[2] = $corners[3]; $corners[3] = $temp;
1745	        }
1746	    }
1747    } else {
1748        # name without [-orient] option, or numeric coordinates given
1749        @corners = page_size(@corners);
1750    }
1751
1752    my $UU = $self->{'pdf'}->{' userUnit'};
1753    # scale down size if User Unit given (e.g., Letter => 0 0 8.5 11)
1754    if ($isName && $UU != 1.0) {
1755        for (my $i=0; $i<4; $i++) {
1756            $corners[$i] /= $UU;
1757        }
1758    }
1759
1760    return (@corners);
1761} # end of _bbox()
1762
1763# utility to get a bounding box by name
1764sub _get_bbox {
1765    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    if (not defined $self->{'pages'}->{$boxname}) {
1770        if      ($boxname eq 'CropBox') {
1771	    $boxname = 'MediaBox';
1772        } elsif ($boxname eq 'BleedBox' ||
1773	         $boxname eq 'TrimBox' ||
1774	         $boxname eq 'ArtBox' ) {
1775	    if (defined $self->{'pages'}->{'CropBox'}) {
1776	        $boxname = 'CropBox';
1777	    } else {
1778	        $boxname = 'MediaBox';
1779	    }
1780	} else {
1781            # invalid box name (silent error). just use MediaBox
1782	    $boxname = 'MediaBox';
1783	}
1784    }
1785
1786    # now $boxname is known to exist
1787    return map { $_->val() } $self->{'pages'}->{$boxname}->elements();
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
1801Sets (or gets) the global MediaBox, defining the width and height (or by
1802corner coordinates, or by standard name) of the output page itself, such as
1803the physical paper size.
1804
1805See L<PDF::Builder::Docs/Media Box> for more information.
1806The method always returns the current bounds (after any set operation).
1807
1808=cut
1809
1810sub mediabox {
1811    my ($self, @corners) = @_;
1812    if (defined $corners[0]) {
1813        @corners = $self->_bbox(@corners);
1814        $self->{'pages'}->{'MediaBox'} = PDFArray( map { PDFNum(float($_)) } @corners );
1815    }
1816
1817    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
1830Sets (or gets) the global CropBox. This will define the media size to which
1831the output will later be clipped.
1832
1833See L<PDF::Builder::Docs/Crop Box> for more information.
1834The method always returns the current bounds (after any set operation).
1835
1836=cut
1837
1838sub cropbox {
1839    my ($self, @corners) = @_;
1840    if (defined $corners[0]) {
1841        @corners = $self->_bbox(@corners);
1842        $self->{'pages'}->{'CropBox'} = PDFArray( map { PDFNum(float($_)) } @corners );
1843    }
1844
1845    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
1858Sets (or gets) the global BleedBox. This is typically used for hard copy
1859printing where you want ink to go to the edge of the cut paper.
1860
1861See L<PDF::Builder::Docs/Bleed Box> for more information.
1862The method always returns the current bounds (after any set operation).
1863
1864=cut
1865
1866sub bleedbox {
1867    my ($self, @corners) = @_;
1868    if (defined $corners[0]) {
1869        @corners = $self->_bbox(@corners);
1870        $self->{'pages'}->{'BleedBox'} = PDFArray( map { PDFNum(float($_)) } @corners );
1871    }
1872
1873    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
1886Sets (or gets) the global TrimBox. This is supposed to be the actual
1887dimensions of the finished page (after trimming of the paper).
1888
1889See L<PDF::Builder::Docs/Trim Box> for more information.
1890The method always returns the current bounds (after any set operation).
1891
1892=cut
1893
1894sub trimbox {
1895    my ($self, @corners) = @_;
1896    if (defined $corners[0]) {
1897        @corners = $self->_bbox(@corners);
1898        $self->{'pages'}->{'TrimBox'} = PDFArray( map { PDFNum(float($_)) } @corners );
1899    }
1900
1901    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
1914Sets (or gets) the global ArtBox. This is supposed to define "the extent of
1915the page's I<meaningful> content".
1916
1917See L<PDF::Builder::Docs/Art Box> for more information.
1918The method always returns the current bounds (after any set operation).
1919
1920=cut
1921
1922sub artbox {
1923    my ($self, @corners) = @_;
1924    if (defined $corners[0]) {
1925        @corners = $self->_bbox(@corners);
1926        $self->{'pages'}->{'ArtBox'} = PDFArray( map { PDFNum(float($_)) } @corners );
1927    }
1928
1929    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
1940Adds one or more directories to the search path for finding font
1941files.
1942
1943Returns the list of searched directories.
1944
1945=cut
1946
1947sub addFontDirs {
1948    my @dirs = @_;
1949    push @FontDirs, @dirs;
1950    return @FontDirs;
1951}
1952
1953sub _findFont {
1954    my $font = shift();
1955
1956    my @fonts = ($font, map { "$_/$font" } @FontDirs);
1957    shift @fonts while scalar(@fonts) and not -f $fonts[0];
1958
1959    return $fonts[0];
1960}
1961
1962=item $font = $pdf->corefont($fontname, %options)
1963
1964=item $font = $pdf->corefont($fontname)
1965
1966Returns a new Adobe core font object. For details, see L<PDF::Builder::Docs/Core Fonts>.
1967
1968See also L<PDF::Builder::Resource::Font::CoreFont>.
1969
1970=cut
1971
1972sub corefont {
1973    my ($self, $name, %opts) = @_;
1974
1975    require PDF::Builder::Resource::Font::CoreFont;
1976    my $obj = PDF::Builder::Resource::Font::CoreFont->new($self->{'pdf'}, $name, %opts);
1977    $self->{'pdf'}->out_obj($self->{'pages'});
1978    $obj->tounicodemap() if $opts{'-unicodemap'}; # UTF-8 not usable
1979
1980    return $obj;
1981}
1982
1983=item $font = $pdf->psfont($ps_file, %options)
1984
1985=item $font = $pdf->psfont($ps_file)
1986
1987Returns a new Adobe Type1 ("PostScript") font object.
1988For details, see L<PDF::Builder::Docs/PS Fonts>.
1989
1990See also L<PDF::Builder::Resource::Font::Postscript>.
1991
1992=cut
1993
1994sub psfont {
1995    my ($self, $psf, %opts) = @_;
1996
1997    foreach my $o (qw(-afmfile -pfmfile)) {
1998        next unless defined $opts{$o};
1999        $opts{$o} = _findFont($opts{$o});
2000    }
2001    $psf = _findFont($psf);
2002    require PDF::Builder::Resource::Font::Postscript;
2003    my $obj = PDF::Builder::Resource::Font::Postscript->new($self->{'pdf'}, $psf, %opts);
2004
2005    $self->{'pdf'}->out_obj($self->{'pages'});
2006    $obj->tounicodemap() if $opts{'-unicodemap'}; # UTF-8 not usable
2007
2008    return $obj;
2009}
2010
2011=item $font = $pdf->ttfont($ttf_file, %options)
2012
2013=item $font = $pdf->ttfont($ttf_file)
2014
2015Returns a new TrueType (or OpenType) font object.
2016For details, see L<PDF::Builder::Docs/TrueType Fonts>.
2017
2018=cut
2019
2020sub ttfont {
2021    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    $opts{'-unicodemap'} = 1 unless exists $opts{'-unicodemap'};
2028
2029    $file = _findFont($file);
2030    require PDF::Builder::Resource::CIDFont::TrueType;
2031    my $obj = PDF::Builder::Resource::CIDFont::TrueType->new($self->{'pdf'}, $file, %opts);
2032
2033    $self->{'pdf'}->out_obj($self->{'pages'});
2034    $obj->tounicodemap() if $opts{'-unicodemap'};
2035
2036    return $obj;
2037}
2038
2039=item $font = $pdf->cjkfont($cjkname, %options)
2040
2041=item $font = $pdf->cjkfont($cjkname)
2042
2043Returns a new CJK font object. These are TrueType-like fonts for East Asian
2044languages (Chinese, Japanese, Korean).
2045For details, see L<PDF::Builder::Docs/CJK Fonts>.
2046
2047See also L<PDF::Builder::Resource::CIDFont::CJKFont>
2048
2049=cut
2050
2051sub cjkfont {
2052    my ($self, $name, %opts) = @_;
2053
2054    require PDF::Builder::Resource::CIDFont::CJKFont;
2055    my $obj = PDF::Builder::Resource::CIDFont::CJKFont->new($self->{'pdf'}, $name, %opts);
2056
2057    $self->{'pdf'}->out_obj($self->{'pages'});
2058    $obj->tounicodemap() if $opts{'-unicodemap'};
2059
2060    return $obj;
2061}
2062
2063=item $font = $pdf->synfont($basefont, %options)
2064
2065=item $font = $pdf->synfont($basefont)
2066
2067Returns a new synthetic font object. These are modifications to a core (or
2068PS/T1 or TTF/OTF) font, where the font may be replaced by a Type1 or Type3
2069PostScript font.
2070This does not appear to work with CJK fonts (created with C<cjkfont> method).
2071For details, see L<PDF::Builder::Docs/Synthetic Fonts>.
2072
2073See also L<PDF::Builder::Resource::Font::SynFont>
2074
2075=cut
2076
2077sub synfont {
2078    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    $opts{'-unicodemap'} = 1 unless exists $opts{'-unicodemap'};
2085
2086    require PDF::Builder::Resource::Font::SynFont;
2087    my $obj = PDF::Builder::Resource::Font::SynFont->new($self->{'pdf'}, $font, %opts);
2088
2089    $self->{'pdf'}->out_obj($self->{'pages'});
2090    $obj->tounicodemap() if $opts{'-unicodemap'};
2091
2092    return $obj;
2093}
2094
2095=item $font = $pdf->bdfont($bdf_file, @options)
2096
2097=item $font = $pdf->bdfont($bdf_file)
2098
2099Returns a new BDF (bitmapped distribution format) font object, based on the
2100specified Adobe BDF file.
2101
2102See also L<PDF::Builder::Resource::Font::BdFont>
2103
2104=cut
2105
2106sub bdfont {
2107    my ($self, $bdf_file, @opts) = @_;
2108
2109    require PDF::Builder::Resource::Font::BdFont;
2110    my $obj = PDF::Builder::Resource::Font::BdFont->new($self->{'pdf'}, $bdf_file, @opts);
2111
2112    $self->{'pdf'}->out_obj($self->{'pages'});
2113    # $obj->tounicodemap(); # does not support Unicode!
2114
2115    return $obj;
2116}
2117
2118=item $font = $pdf->unifont(@fontspecs, %options)
2119
2120=item $font = $pdf->unifont(@fontspecs)
2121
2122Returns a new uni-font object, based on the specified fonts and options.
2123
2124B<BEWARE:> This is not a true PDF-object, but a virtual/abstract font definition!
2125
2126See also L<PDF::Builder::Resource::UniFont>.
2127
2128Valid %options are:
2129
2130=over
2131
2132=item -encode
2133
2134Changes the encoding of the font from its default.
2135
2136=back
2137
2138=cut
2139
2140sub unifont {
2141    my ($self, @opts) = @_;
2142
2143    require PDF::Builder::Resource::UniFont;
2144    my $obj = PDF::Builder::Resource::UniFont->new($self->{'pdf'}, @opts);
2145
2146    return $obj;
2147}
2148
2149=back
2150
2151=head1 IMAGE METHODS
2152
2153=over
2154
2155=item $jpeg = $pdf->image_jpeg($file)
2156
2157Imports and returns a new JPEG image object. C<$file> may be either a filename
2158or a filehandle.
2159
2160See L<PDF::Builder::Resource::XObject::Image::JPEG> for additional information
2161and C<examples/Content.pl> 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
2167sub image_jpeg {
2168    my ($self, $file, %opts) = @_;
2169
2170    require PDF::Builder::Resource::XObject::Image::JPEG;
2171    my $obj = PDF::Builder::Resource::XObject::Image::JPEG->new($self->{'pdf'}, $file);
2172
2173    $self->{'pdf'}->out_obj($self->{'pages'});
2174
2175    return $obj;
2176}
2177
2178=item $tiff = $pdf->image_tiff($file, %opts)
2179
2180=item $tiff = $pdf->image_tiff($file)
2181
2182Imports and returns a new TIFF image object. C<$file> may be either a filename
2183or a filehandle.
2184For details, see L<PDF::Builder::Docs/TIFF Images>.
2185
2186See L<PDF::Builder::Resource::XObject::Image::TIFF> and
2187L<PDF::Builder::Resource::XObject::Image::TIFF_GT> for additional information
2188and C<examples/Content.pl>
2189for some examples of placing an image on a page (JPEG, but the principle is
2190the same). There is an optional TIFF library described, that gives more
2191capability than the default one.
2192
2193=cut
2194
2195sub image_tiff {
2196    my ($self, $file, %opts) = @_;
2197
2198    my ($rc, $obj);
2199    $rc = $self->LA_GT();
2200    if ($rc) {
2201	# Graphics::TIFF available
2202	if (defined $opts{'-nouseGT'} && $opts{'-nouseGT'} == 1) {
2203	   $rc = -1;  # don't use it
2204	}
2205    }
2206    if ($rc == 1) {
2207	# Graphics::TIFF (_GT suffix) available and to be used
2208        require PDF::Builder::Resource::XObject::Image::TIFF_GT;
2209        $obj = PDF::Builder::Resource::XObject::Image::TIFF_GT->new($self->{'pdf'}, $file, 'Ix'.pdfkey(), %opts);
2210        $self->{'pdf'}->out_obj($self->{'pages'});
2211    } else {
2212	# Graphics::TIFF not available, or is but is not to be used
2213        require PDF::Builder::Resource::XObject::Image::TIFF;
2214        $obj = PDF::Builder::Resource::XObject::Image::TIFF->new($self->{'pdf'}, $file, 'Ix'.pdfkey(), %opts);
2215        $self->{'pdf'}->out_obj($self->{'pages'});
2216
2217	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	    if (!defined $opts{'-silent'} || $opts{'-silent'} == 0) {
2221	        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    $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    return $obj;
2232}
2233
2234=item $rc = $pdf->LA_GT()
2235
2236Returns 1 if the library name (package) Graphics::TIFF is installed, and
22370 otherwise. For this optional library, this call can be used to know if it
2238is 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
2250sub LA_GT {
2251    my ($self) = @_;
2252
2253    my ($rc);
2254    $rc = eval {
2255        require Graphics::TIFF;
2256        1;
2257    };
2258    if (!defined $rc) { $rc = 0; }  # else is 1
2259    if ($rc) {
2260	# installed, but not up to date?
2261	if ($Graphics::TIFF::VERSION < $GrTFversion) { $rc = 0; }
2262    }
2263
2264    return $rc;
2265}
2266
2267=item $pnm = $pdf->image_pnm($file)
2268
2269Imports and returns a new PNM image object. C<$file> may be either a filename
2270or a filehandle.
2271
2272See C<examples/Content.pl>
2273for some examples of placing an image on a page (JPEG, but the principle is
2274the same).
2275
2276=cut
2277
2278# =item $pnm = $pdf->image_pnm($file, %options)   no current options
2279
2280sub image_pnm {
2281    my ($self, $file, %opts) = @_;
2282
2283    require PDF::Builder::Resource::XObject::Image::PNM;
2284    my $obj = PDF::Builder::Resource::XObject::Image::PNM->new($self->{'pdf'}, $file);
2285    $self->{'pdf'}->out_obj($self->{'pages'});
2286
2287    return $obj;
2288}
2289
2290=item $png = $pdf->image_png($file, %options)
2291
2292=item $png = $pdf->image_png($file)
2293
2294Imports and returns a new PNG image object. C<$file> may be either
2295a filename or a filehandle.
2296For details, see L<PDF::Builder::Docs/PNG Images>.
2297
2298See L<PDF::Builder::Resource::XObject::Image::PNG> and
2299L<PDF::Builder::Resource::XObject::Image::PNG_IPL> for additional information
2300and C<examples/Content.pl>
2301for some examples of placing an image on a page (JPEG, but the principle is
2302the same). There is an optional PNG library (PNG_IPL) described, that gives more
2303capability than the default one.
2304
2305=cut
2306
2307sub image_png {
2308    my ($self, $file, %opts) = @_;
2309
2310    my ($rc, $obj);
2311    $rc = $self->LA_IPL();
2312    if ($rc) {
2313        # Image::PNG::Libpng available
2314        if (defined $opts{'-nouseIPL'} && $opts{'-nouseIPL'} == 1) {
2315            $rc = -1;  # don't use it
2316        }
2317    }
2318    if ($rc == 1) {
2319        # Image::PNG::Libpng (_IPL suffix) available and to be used
2320        require PDF::Builder::Resource::XObject::Image::PNG_IPL;
2321        $obj = PDF::Builder::Resource::XObject::Image::PNG_IPL->new($self->{'pdf'}, $file, 'Px'.pdfkey(), %opts);
2322        $self->{'pdf'}->out_obj($self->{'pages'});
2323    } else {
2324        # Image::PNG::Libpng not available, or is but is not to be used
2325        require PDF::Builder::Resource::XObject::Image::PNG;
2326        $obj = PDF::Builder::Resource::XObject::Image::PNG->new($self->{'pdf'}, $file, 'Px'.pdfkey(), %opts);
2327        $self->{'pdf'}->out_obj($self->{'pages'});
2328
2329        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            if (!defined $opts{'-silent'} || $opts{'-silent'} == 0) {
2333                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    $obj->{'usesIPL'} = PDFNum($rc);  # -1 available but unused
2339                                      #  0 not available
2340                                      #  1 available and used
2341                                      # $png->usesLib() to get number
2342    return $obj;
2343}
2344
2345=item $rc = $pdf->LA_IPL()
2346
2347Returns 1 if the library name (package) Image::PNG::Libpng is installed, and
23480 otherwise. For this optional library, this call can be used to know if it
2349is 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
2361sub LA_IPL {
2362    my ($self) = @_;
2363
2364    my ($rc);
2365    $rc = eval {
2366        require Image::PNG::Libpng;
2367        1;
2368    };
2369    if (!defined $rc) { $rc = 0; }  # else is 1
2370    if ($rc) {
2371	# installed, but not up to date?
2372	if ($Image::PNG::Libpng::VERSION < $LpngVersion) { $rc = 0; }
2373    }
2374
2375    return $rc;
2376}
2377
2378=item $gif = $pdf->image_gif($file)
2379
2380Imports and returns a new GIF image object. C<$file> may be either a filename
2381or a filehandle.
2382
2383See L<PDF::Builder::Resource::XObject::Image::GIF> for additional information
2384and C<examples/Content.pl> 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
2391sub image_gif {
2392    my ($self, $file, %opts) = @_;
2393
2394    require PDF::Builder::Resource::XObject::Image::GIF;
2395    my $obj = PDF::Builder::Resource::XObject::Image::GIF->new($self->{'pdf'}, $file);
2396    $self->{'pdf'}->out_obj($self->{'pages'});
2397
2398    return $obj;
2399}
2400
2401=item $gdf = $pdf->image_gd($gd_object, %options)
2402
2403=item $gdf = $pdf->image_gd($gd_object)
2404
2405Imports and returns a new image object from Image::GD.
2406
2407Valid %options are:
2408
2409=over
2410
2411=item -lossless => 1
2412
2413Use lossless compression.
2414
2415=back
2416
2417See L<PDF::Builder::Resource::XObject::Image::GD> for additional information
2418and C<examples/Content.pl> for some examples of placing an image on a page
2419(JPEG, but the principle is the same).
2420
2421=cut
2422
2423sub image_gd {
2424    my ($self, $gd, %options) = @_;
2425
2426    require PDF::Builder::Resource::XObject::Image::GD;
2427    my $obj = PDF::Builder::Resource::XObject::Image::GD->new($self->{'pdf'}, $gd, undef, %options);
2428    $self->{'pdf'}->out_obj($self->{'pages'});
2429
2430    return $obj;
2431}
2432
2433=back
2434
2435=head1 COLORSPACE METHODS
2436
2437=over
2438
2439=item $cs = $pdf->colorspace_act($file)
2440
2441Returns a new colorspace object based on an Adobe Color Table file.
2442
2443See L<PDF::Builder::Resource::ColorSpace::Indexed::ACTFile> for a
2444reference to the file format's specification.
2445
2446=cut
2447
2448# =item $cs = $pdf->colorspace_act($file, %options)   no current options
2449
2450sub colorspace_act {
2451    my ($self, $file, %opts) = @_;
2452
2453    require PDF::Builder::Resource::ColorSpace::Indexed::ACTFile;
2454    my $obj = PDF::Builder::Resource::ColorSpace::Indexed::ACTFile->new($self->{'pdf'}, $file);
2455    $self->{'pdf'}->out_obj($self->{'pages'});
2456
2457    return $obj;
2458}
2459
2460=item $cs = $pdf->colorspace_web()
2461
2462Returns 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
2469sub colorspace_web {
2470    my ($self, $file, %opts) = @_;
2471
2472    require PDF::Builder::Resource::ColorSpace::Indexed::WebColor;
2473    my $obj = PDF::Builder::Resource::ColorSpace::Indexed::WebColor->new($self->{'pdf'});
2474
2475    $self->{'pdf'}->out_obj($self->{'pages'});
2476
2477    return $obj;
2478}
2479
2480=item $cs = $pdf->colorspace_hue()
2481
2482Returns a new colorspace-object based on the hue color palette.
2483
2484See L<PDF::Builder::Resource::ColorSpace::Indexed::Hue> 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
2491sub colorspace_hue {
2492    my ($self, $file, %opts) = @_;
2493
2494    require PDF::Builder::Resource::ColorSpace::Indexed::Hue;
2495    my $obj = PDF::Builder::Resource::ColorSpace::Indexed::Hue->new($self->{'pdf'});
2496    $self->{'pdf'}->out_obj($self->{'pages'});
2497
2498    return $obj;
2499}
2500
2501=item $cs = $pdf->colorspace_separation($tint, $color)
2502
2503Returns a new separation colorspace object based on the parameters.
2504
2505I<$tint> can be any valid ink identifier, including but not limited
2506to: 'Cyan', 'Magenta', 'Yellow', 'Black', 'Red', 'Green', 'Blue' or
2507'Orange'.
2508
2509I<$color> must be a valid color specification limited to: '#rrggbb',
2510'!hhssvv', '%ccmmyykk' or a "named color" (rgb).
2511
2512The colorspace model will automatically be chosen based on the
2513specified color.
2514
2515=cut
2516
2517sub colorspace_separation {
2518    my ($self, $tint, @clr) = @_;
2519
2520    require PDF::Builder::Resource::ColorSpace::Separation;
2521    my $obj = PDF::Builder::Resource::ColorSpace::Separation->new($self->{'pdf'}, pdfkey(), $tint, @clr);
2522    $self->{'pdf'}->out_obj($self->{'pages'});
2523
2524    return $obj;
2525}
2526
2527=item $cs = $pdf->colorspace_devicen(\@tintCSx, $samples)
2528
2529=item $cs = $pdf->colorspace_devicen(\@tintCSx)
2530
2531Returns a new DeviceN colorspace object based on the parameters.
2532
2533B<Example:>
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
2544The colorspace model will automatically be chosen based on the first
2545colorspace specified.
2546
2547=cut
2548
2549sub colorspace_devicen {
2550    my ($self, $clrs, $samples) = @_;
2551    $samples ||= 2;
2552
2553    require PDF::Builder::Resource::ColorSpace::DeviceN;
2554    my $obj = PDF::Builder::Resource::ColorSpace::DeviceN->new($self->{'pdf'}, pdfkey(), $clrs, $samples);
2555    $self->{'pdf'}->out_obj($self->{'pages'});
2556
2557    return $obj;
2558}
2559
2560=back
2561
2562=head1 BARCODE METHODS
2563
2564These are glue routines to the actual barcode rendering routines found
2565elsewhere.
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
2579Creates 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
2586sub xo_code128 {
2587    my ($self, @options) = @_;
2588
2589    require PDF::Builder::Resource::XObject::Form::BarCode::code128;
2590    my $obj = PDF::Builder::Resource::XObject::Form::BarCode::code128->new($self->{'pdf'}, @options);
2591    $self->{'pdf'}->out_obj($self->{'pages'});
2592
2593    return $obj;
2594}
2595
2596sub xo_codabar {
2597    my ($self, @options) = @_;
2598
2599    require PDF::Builder::Resource::XObject::Form::BarCode::codabar;
2600    my $obj = PDF::Builder::Resource::XObject::Form::BarCode::codabar->new($self->{'pdf'}, @options);
2601    $self->{'pdf'}->out_obj($self->{'pages'});
2602
2603    return $obj;
2604}
2605
2606sub xo_2of5int {
2607    my ($self, @options) = @_;
2608
2609    require PDF::Builder::Resource::XObject::Form::BarCode::int2of5;
2610    my $obj = PDF::Builder::Resource::XObject::Form::BarCode::int2of5->new($self->{'pdf'}, @options);
2611    $self->{'pdf'}->out_obj($self->{'pages'});
2612
2613    return $obj;
2614}
2615
2616sub xo_3of9 {
2617    my ($self, @options) = @_;
2618
2619    require PDF::Builder::Resource::XObject::Form::BarCode::code3of9;
2620    my $obj = PDF::Builder::Resource::XObject::Form::BarCode::code3of9->new($self->{'pdf'}, @options);
2621    $self->{'pdf'}->out_obj($self->{'pages'});
2622
2623    return $obj;
2624}
2625
2626sub xo_ean13 {
2627    my ($self, @options) = @_;
2628
2629    require PDF::Builder::Resource::XObject::Form::BarCode::ean13;
2630    my $obj = PDF::Builder::Resource::XObject::Form::BarCode::ean13->new($self->{'pdf'}, @options);
2631    $self->{'pdf'}->out_obj($self->{'pages'});
2632
2633    return $obj;
2634}
2635
2636=back
2637
2638=head1 OTHER METHODS
2639
2640=over
2641
2642=item $xo = $pdf->xo_form()
2643
2644Returns a new form XObject.
2645
2646=cut
2647
2648sub xo_form {
2649    my $self = shift();
2650
2651    my $obj = PDF::Builder::Resource::XObject::Form::Hybrid->new($self->{'pdf'});
2652    $self->{'pdf'}->out_obj($self->{'pages'});
2653
2654    return $obj;
2655}
2656
2657=item $egs = $pdf->egstate()
2658
2659Returns a new extended graphics state object.
2660
2661=cut
2662
2663sub egstate {
2664    my $self = shift();
2665
2666    my $obj = PDF::Builder::Resource::ExtGState->new($self->{'pdf'}, pdfkey());
2667    $self->{'pdf'}->out_obj($self->{'pages'});
2668
2669    return $obj;
2670}
2671
2672=item $obj = $pdf->pattern(%options)
2673
2674=item $obj = $pdf->pattern()
2675
2676Returns a new pattern object.
2677
2678=cut
2679
2680sub pattern {
2681    my ($self, %options) = @_;
2682
2683    my $obj = PDF::Builder::Resource::Pattern->new($self->{'pdf'}, undef, %options);
2684    $self->{'pdf'}->out_obj($self->{'pages'});
2685
2686    return $obj;
2687}
2688
2689=item $obj = $pdf->shading(%options)
2690
2691=item $obj = $pdf->shading()
2692
2693Returns a new shading object.
2694
2695=cut
2696
2697sub shading {
2698    my ($self, %options) = @_;
2699
2700    my $obj = PDF::Builder::Resource::Shading->new($self->{'pdf'}, undef, %options);
2701    $self->{'pdf'}->out_obj($self->{'pages'});
2702
2703    return $obj;
2704}
2705
2706=item $otls = $pdf->outlines()
2707
2708Returns a new or existing outlines object.
2709
2710=cut
2711
2712sub outlines {
2713    my $self = shift();
2714
2715    require PDF::Builder::Outlines;
2716    $self->{'pdf'}->{'Root'}->{'Outlines'} ||= PDF::Builder::Outlines->new($self);
2717
2718    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    $self->{'pdf'}->new_obj($obj) unless $obj->is_obj($self->{'pdf'});
2726    $self->{'pdf'}->out_obj($obj);
2727    $self->{'pdf'}->out_obj($self->{'pdf'}->{'Root'});
2728
2729    return $obj;
2730}
2731
2732=item $ndest = $pdf->named_destination()
2733
2734Returns a new or existing named destination object.
2735
2736=cut
2737
2738sub named_destination {
2739    my ($self, $cat, $name, $obj) = @_;
2740    my $root = $self->{'catalog'};
2741
2742    $root->{'Names'} ||= PDFDict();
2743    $root->{'Names'}->{$cat} ||= PDFDict();
2744    $root->{'Names'}->{$cat}->{'-vals'}  ||= {};
2745    $root->{'Names'}->{$cat}->{'Limits'} ||= PDFArray();
2746    $root->{'Names'}->{$cat}->{'Names'}  ||= PDFArray();
2747
2748    unless (defined $obj) {
2749        $obj = PDF::Builder::NamedDestination->new($self->{'pdf'});
2750    }
2751    $root->{'Names'}->{$cat}->{'-vals'}->{$name} = $obj;
2752
2753    my @names = sort {$a cmp $b} keys %{$root->{'Names'}->{$cat}->{'-vals'}};
2754
2755    $root->{'Names'}->{$cat}->{'Limits'}->{' val'}->[0] = PDFString($names[0], 'n');
2756    $root->{'Names'}->{$cat}->{'Limits'}->{' val'}->[1] = PDFString($names[-1], 'n');
2757
2758    @{$root->{'Names'}->{$cat}->{'Names'}->{' val'}} = ();
2759
2760    foreach my $k (@names) {
2761        push @{$root->{'Names'}->{$cat}->{'Names'}->{' val'}},
2762        (   PDFString($k, 'n'),
2763            $root->{'Names'}->{$cat}->{'-vals'}->{$k}
2764        );
2765    }
2766
2767    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
2781sub IntegrityCheck {
2782    my ($self, $level, $string) = @_;
2783
2784    my $level_nodiag   = 0;
2785    my $level_error    = 1;
2786    my $level_warning  = 2;
2787    my $level_note     = 3;
2788    my $level_dump     = 4;
2789    my $level_dumpself = 5;
2790
2791    my $IC = "PDF Integrity Check:";
2792
2793   #print "$IC level $level\n" if $level >= $level_error;
2794    my $Version = undef;
2795    my ($Info, $Root, $str, $pos, $Parent, @Kids, @others);
2796
2797    my $idx_defined  = 0;  # has this object been explicitly defined?
2798    my $idx_refcount = 1;  # count of all pointing to this obj except as Kid
2799    my $idx_par_clmd = 2;  # other object claiming this object as Kid
2800    my $idx_parent   = 3;  # this object's /Parent entry
2801    my $idx_kid_cnt  = 4;  # size of kid_list
2802    my $idx_kid_list = 5;  # this object's /Kids list
2803    # intialize each element to [ 0 0 -1 -1 -1 [] ]
2804
2805    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    my @major = split /%%EOF/, $string; # typically [0] entire PDF [1] empty
2809    my %objList;
2810    my $update = -1;
2811    foreach (@major) {
2812	# update section number 0, 1, 2... with %%EOF in-between
2813	$update++;
2814	next if !length($_);
2815
2816	# split on "endobj"
2817	my @rawObjects = split /endobj/, $_;
2818	# each element contains an object plus leading stuff, not incl endobj
2819
2820	foreach my $rawObject (@rawObjects) {
2821	    next if !length($rawObject);
2822
2823	    # remove bulky and unwanted stream...endstream
2824	    if ($rawObject =~ m/^(.*)stream\s.*\sendstream(.*)$/s) {
2825	        $rawObject = $1.$2;
2826	    }
2827
2828            # trim off anything before obj clause. endobj already gone.
2829	    if ($rawObject =~ m/^(.*?)\s?(\d+) (\d+) obj\s(.*)$/s ||
2830	        $rawObject =~ m/^(.*?)\s?(\d+) (\d+) obj(.*)$/s) {
2831		$rawObject = $4;
2832
2833		# found an obj, full string is $rawObject. parse into
2834		# selected fields, build $objList{key} entry.
2835		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		if (defined $objList{$objKey} && $update > 0) {
2839		    $objList{$objKey}->[$idx_parent]   = -1;
2840		    $objList{$objKey}->[$idx_kid_cnt]  = -1;
2841		    $objList{$objKey}->[$idx_kid_list] = [];
2842		}
2843		# might have already created this object element as target
2844		#  from another object
2845		if (!defined $objList{$objKey}) {
2846		    $objList{$objKey} = [0, 0, -1, -1, -1, []];
2847		}
2848		# mark object as defined
2849		$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		if ($rawObject =~ m#/Parent(\s+)(\d+)(\s+)(\d+)(\s+)R#) {
2861		    $Parent = "$2.$4";
2862		    $str = "/Parent$1$2$3$4$5R";
2863		    $pos = index $rawObject, $str;
2864		    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		        $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		if ($rawObject =~ m#/Kids(\s+)\[(.*)\]#) {
2877		    $str = "/Kids$1\[$2\]";
2878		    $pos = index $rawObject, $str;
2879		    substr($rawObject, $pos, length($str)) = '';
2880
2881		    my $str2 = " $2"; # guarantee a leading \s
2882		    @Kids = ();
2883                    while (1) {
2884		        if ($str2 =~ m#(\s+)(\d+)(\s+)(\d+)(\s+)R#) {
2885			    $str = "$1$2$3$4$5R";
2886			    push @Kids, "$2.$4";
2887		            $pos = index $str2, $str;
2888		            substr($str2, $pos, length($str)) = '';
2889		        } else {
2890			    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		        @{$objList{$objKey}->[$idx_kid_list]} = @Kids;
2897			$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		if ($rawObject =~ m#/Type(\s+)/Catalog#) {
2908		    my $sp1 = $1;
2909		    if ($rawObject =~ m#/Version /(\d+)\.(\d+)#) {
2910			$Version = "$1.$2";
2911		        $str = "/Version$sp1/$Version";
2912		        $pos = index $rawObject, $str;
2913		        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		if ($rawObject =~ m#/Type(\s+)/XRef# ||
2921		    $rawObject =~ m#/Type/XRef#) {
2922		    if ($rawObject =~ m#/Root(\s+)(\d+)(\s+)(\d+)(\s+)R#) {
2923			$Root = "$2.$4";
2924		        $str = "/Root$1$2$3$4$5R";
2925		        $pos = index $rawObject, $str;
2926		        substr($rawObject, $pos, length($str)) = '';
2927		    }
2928		    if ($rawObject =~ m#/Info(\s+)(\d+)(\s+)(\d+)(\s+)R#) {
2929			$Info = "$2.$4";
2930		        $str = "/Info$1$2$3$4$5R";
2931		        $pos = index $rawObject, $str;
2932		        substr($rawObject, $pos, length($str)) = '';
2933		    }
2934		}
2935
2936		# all other x y R -> @others
2937                @others = ();
2938		while (1) {
2939		    if ($rawObject =~ m#(\d+)(\s+)(\d+)(\s+)R#) {
2940			$str = "$1$2$3$4R";
2941			push @others, "$1.$3";
2942		        $pos = index $rawObject, $str;
2943		        substr($rawObject, $pos, length($str)) = '';
2944		    } else {
2945			last;
2946		    }
2947		}
2948		# go through all other refs and create element if necessary,
2949		#   then increment its refcnt array element
2950		foreach (@others) {
2951                    if (!defined $objList{$_}) {
2952		        $objList{$_} = [0, 0, -1, -1, -1, []];
2953		    }
2954		    $objList{$_}->[$idx_refcount]++;
2955		}
2956		foreach (@Kids) {
2957                    if (!defined $objList{$_}) {
2958		        $objList{$_} = [0, 0, -1, -1, -1, []];
2959		    }
2960		    $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		if ($rawObject =~ m/trailer/) {
2967                    if ($rawObject =~ m#trailer(.*)/Info(\s+)(\d+)(\s+)(\d+)(\s+)R#s) {
2968			$Info = "$3.$5";
2969		    }
2970                    if ($rawObject =~ m#trailer(.*)/Root(\s+)(\d+)(\s+)(\d+)(\s+)R#s) {
2971			$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    if (!defined $Root) {
2981	print STDERR "$IC No Root object defined!\n" if $level >= $level_error;
2982    } else {
2983        if (!defined $objList{$Root}) {
2984	    $objList{$Root} = [1, 0, -1, -1, -1, []];
2985	    print STDERR "$IC Root object $Root not found!\n" if $level >= $level_error;
2986        }
2987        $objList{$Root}->[$idx_refcount]++;
2988    }
2989
2990    # Info is optional
2991    if (!defined $Info) {
2992	print STDERR "$IC No Info object defined!\n" if $level >= $level_note;
2993    } else {
2994        if (!defined $objList{$Info}) {
2995	    $objList{$Info} = [1, 0, -1, -1, -1, []];
2996	    print STDERR "$IC Info object $Info not found!\n" if $level >= $level_note;
2997	    # possibly in a deleted object (on free list)
2998        }
2999        $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    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	if ($objList{$thisObj}->[$idx_defined] == 0) {
3014	    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	if ($objList{$thisObj}[$idx_kid_cnt] > 0) {
3021	    # this object has children (/Kids), so explore them one level deep
3022	    for (my $kidObj=0; $kidObj<$objList{$thisObj}[$idx_kid_cnt]; $kidObj++) {
3023	        my $child = $objList{$thisObj}[$idx_kid_list]->[$kidObj];
3024		# child's claimed parent should be -1, set to thisObj
3025		if ($objList{$child}[$idx_par_clmd] == -1) {
3026		    # no one has claimed to be parent, so set to thisObj
3027		    $objList{$child}[$idx_par_clmd] = $thisObj;
3028		} else {
3029		    # someone else has already claimed to be parent
3030		    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		if ($objList{$child}[$idx_defined] == 1) {
3034		    # child should list thisObj as its Parent
3035		    if      ($objList{$child}[$idx_parent] == -1) {
3036		        print STDERR "$IC object $thisObj claims $child as a child (/Kids), but $child claims no Parent!\n" if $level >= $level_error;
3037		        $objList{$child}[$idx_parent] = $thisObj;
3038		    } elsif ($objList{$child}[$idx_parent] != $thisObj) {
3039		        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 	if ($objList{$thisObj}[$idx_parent] == -1 &&
3046 	    $objList{$thisObj}[$idx_refcount] == 0) {
3047 	    print STDERR "$IC Warning: object $thisObj appears to be unreachable.\n" if $level >= $level_note;
3048 	}
3049    }
3050
3051    if ($level >= $level_dump) {
3052	# dump analysis data
3053        use Data::Dumper;
3054        my $d = Data::Dumper->new([\%objList]);
3055	print "========= dump of $IC analysis data ===========\n";
3056        print $d->Dump();
3057    }
3058
3059    # if have entire processed PDF in $self
3060    if ($level >= $level_dumpself) {
3061    	# dump whole data
3062        use Data::Dumper;
3063        my $d = Data::Dumper->new([$self]);
3064	print "========= dump of $IC PDF (self) data ===========\n";
3065        print $d->Dump();
3066    }
3067
3068    return $Version;
3069}
3070
30711;
3072
3073__END__
3074
3075=back
3076
3077=cut
3078