summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Changes209
-rw-r--r--MANIFEST11
-rw-r--r--META.yml22
-rw-r--r--Makefile.PL60
-rw-r--r--README84
-rw-r--r--debian/changelog (renamed from changelog)0
-rw-r--r--debian/control (renamed from control)0
-rw-r--r--debian/copyright (renamed from copyright)0
-rwxr-xr-xdebian/rules (renamed from rules)0
-rw-r--r--debian/source/format (renamed from source/format)0
-rw-r--r--debian/upstream/metadata (renamed from upstream/metadata)0
-rw-r--r--debian/watch (renamed from watch)0
-rw-r--r--lib/PDF/Reuse.pm6943
-rw-r--r--lib/PDF/Reuse/Util.pm357
-rw-r--r--lib/PDF/Util/graphObj_pl512
-rw-r--r--lib/PDF/Util/reuseComponent_pl212
-rw-r--r--t/Reuse.t116
-rw-r--r--t/test.t24
18 files changed, 8550 insertions, 0 deletions
diff --git a/Changes b/Changes
new file mode 100644
index 0000000..0863aea
--- /dev/null
+++ b/Changes
@@ -0,0 +1,209 @@
+Revision history for Perl extension PDF::Reuse
+
+0.39 Tues Sept 26 2016
+ This release simply corrects the rev number
+
+0.38 Mon Sept 26 2016
+ 118069: MYMETA must not be included
+
+0.37 Fri Sept 23 2016
+ 101145 Add support for IO::String and "in memory" files
+ 107301 prStrWidth returns undef when string is '0'
+ 41287 It seems that filehandles of TTF files are not closed
+ 79703 Allow a handle to be provided instead of a file name
+ 107299 Warnings on empty strings in prStrWidth/prText
+ 117892 Could not open 'Reuse.pm' (0.36_02)
+ 93049 PDF::Reuse Bookmarks bug and fix
+ 97290 fix for uninitialized value $param{"Index"} when reading PDF version 1.5 file
+ 43232 Wrong prototype for findFont()
+ 46202 PDF-Reuse 0.35 prDoc/xrefSection problem
+ 48804 Bad PDF Spins CPU
+ 59359 qQ imbalance in Reuse.pm
+ 104874 prMbox() not dealing with 0 ux/uy
+
+ Thanks to all who contributed patches for these fixes!
+
+0.36 Wed Dec 10 2014
+ Added binary blob handling to prJpeg
+ Added prAltJpeg to allow for insertion of alternate low-res images for display
+ Added support for grayscale images to prJpeg after suggestions from Ingo Lachmann
+ Removing depricated define(@array) syntax per suggestion from Nigel Gourlay
+ Updating copyright notices
+
+0.35 Mon Jul 3 2008
+ Thanks to Yunliang Yu Outlines mode is turned on, if bookmarks are added
+ and a minor bug with bookmarks and another one with the creation of pages
+ are corrected.
+
+0.34 June 2008
+ Thanks to Grant McLean prTTFont method is added to support embedding
+ TrueType fonts and using UTF8 text with prText (only works if Font::TTF and
+ Text::PDF are installed)
+
+0.33 Tue Nov 15 2005
+ Corrected a "bug" with prField. Changed the documentation a little.
+ The address to the mailing list is given.
+
+0.32 Fri Jul 22 2005
+ prText has 1 more parameter, rotation, parameter 4 now only handles alignment.
+ prDoc has new functionality. If there are "contents" available, it is added to
+ the array of streams of the first included page. (This was developed for a specific
+ task with support from the Electoral Enrolment Centre, Wellington, New Zealand.)
+ prSinglePage is a new function. It is a variant of prDoc for one page. It also
+ has a counter of pages and last page extracted from a document, so it has more or
+ less the ability to loop through a document if necessary.
+ A new output definition for Apache2, thanks to Matisse Enzer.
+
+0.30 Thu Jun 3
+ Changes to the documentation. Fonts are handled a little differently.
+ If prFont is called in list context, a reference to all fonts known to
+ the current program is also returned.
+
+0.29 Mon May 10
+ A bug with fonts corrected, minor changes to the documentation.
+
+0.28 Fri Apr 23 2004
+ New annotations, which are repeated on many pages, are defined only once.
+ You can tie the request object to the output file, thanks to Matisse Enzer.
+ Compress::Zlib is included in the code with 'use'. There was some problem with
+ 'autouse', and I couldn't solve it. Minor changes to the the code to improve
+ performance a little.
+
+0.27 Fri Apr 16 2004
+ A potential bug with links removed. Repeated links are stored only once.
+ Unnecessary line feeds removed.
+
+0.26 Thu Apr 15 2004
+ Bugs fixed. When an image was imported, the program could become confused
+ about standard fonts. Importing of JavaScripts failed. Corrected.
+
+0.25 Sat Apr 10 2004
+ -"prLink" added, to add and merge hyper links into a document
+ -prStrWidth added. You get string width calculated for some predefined fonts.
+ -A new parameter to prText added, so you can center, right adjust and rotate
+ texts.
+ If the text is not rotated you can get from- and to- positions of text strings
+ -New parameters to prFile to control how a document is initially displayed
+ -MediaBox is defined at the top of the page tree also.
+ -Special characters in values to prField are hex-encoded when they are
+ transferred to the new document, and unescaped from within JavaScript.
+ So special characters might be handled in a new way !
+
+0.24 Tue Mar 9 2004
+ Corrected a warning about when JavaScripts can be added to a document
+
+0.23 Tue Feb 3 2004
+ Added warnings in the documentation about JavaScript and webpdf.api
+
+0.22 Sun Jan 11 2004
+ Corrected an error introduced in version 0.15. Resources were not inherited
+ the way they should.
+ Changes to the documentation. The examples have been moved from this
+ distribution to PDF::Reuse::Tutorial.
+
+0.21 Fri Dec 26 2003
+ -prFontSize will accept sizes with decimal point.
+ -The constant IS_MODPERL has been added. It is taken from $ENV{MOD_PERL}.
+ If it is set, STDOUT can be tied to Apache.
+
+0.20 Sun Dec 14 2003
+ -You can extract pages or split documents with the help of two
+ new parameters to prDoc.
+ -prField can have a snippet of JavaScript code instead of a value.
+ -Bugs removed. Internal changes.
+
+0.19 Fri Nov 21 2003
+ Code produced for prField is now prepared with "extra" backslashes for
+ \n \r and \'. Improved precision in the "formula" for rotation.
+
+0.18 Tue Nov 11 2003
+ Several new parameters for forms and images, so they can be resized, moved
+ and rotated.
+
+0.17 Sat Nov 1 2003
+ A bug removed. The module sometimes got confused when it was reconstructing
+ forms and was switching between different files. This was an error
+ introduced with version 0.15
+
+0.16 Tue Oct 21 2003
+ Added backslashes to the 4 special characters in the comment line, which is
+ written to every file produced by PDF::Reuse. If not escaped,
+ they caused Red Hat (8.0) Linux to terminate the run with the error message:
+ "Wide character in syswrite ... PDF/Reuse.pm line 268".
+ A changed regex to find object references. Some global variables
+ have been removed. If you use the function prCompress(1), new JavaScripts
+ are also compressed.
+ You can have a new parameter with prInit, so the initiation code is shown
+ at document level. By default (now, but not before) it is not shown.
+
+
+0.15 Fri Oct 10 2003
+ First steps to adjust the module to PDF-1.5 (Acrobat 6.0). Lots of changes to
+ the code.
+ If you try to update a field with prField and the field can't be found, the
+ field is just ignored. Before the change, you had a JavaScript error and a
+ subsequent interruption.
+
+0.14 Mon Sep 15 2003
+ The added parameter for prInit from version 0.12 had to be withdrawn.
+ Sometimes it caused Acrobat/Acrobat Reader to crash.
+
+0.12 Tue Sep 9 2003
+ Corrected a "bug". The "typeof info.moddate" can give another result than
+ 1 year ago, so an important test at initiation had to be changed.
+ You can have a new parameter with prInit, so the initiation code is shown
+ at document level. By default (now, but not before) it is not shown.
+
+0.11 Wed Sep 3 2003
+ You can have your bookmarks closed with a new parameter.
+ Changes to the documentation.
+
+0.10 Tue Aug 26 2003
+ Added a function to define bookmarks.
+ Corrected a bug with object numbers.
+ Sometimes the module reserved an object number and didn't need it. Subsequent
+ procedures continued with new object numbers and there was a gap ..
+ Changes to the documentation. "Experimental" has been removed from the
+ interactive functions.
+
+0.09 Mon Jul 21 2003
+ If no file name is given to the function prFile, output is written to STDOUT.
+
+0.08 Sun Jun 29
+ Corrected bugs which occurred when a font was going to be reused. The function
+ prInitVars has been added. changes to the documentation.
+
+0.07 Tue Jun 17
+ You can add JavaScripts as strings, not only as files. Corrected bugs which
+ occurred 1) when JavaScripts were added and 2) when the log for prAdd was
+ produced.
+
+0.06 Mon Jun 2
+ Corrected a bug in prText: when you tried to print '0' it was transformed
+ to ''. Minor changes to the barcode font. Changed documentation referring
+ to GD::Barcode and the modules in that group
+
+0.05 Wed May 21 15:45
+ Tried to make the module backwards compatible with Perl 5.6.1
+ Changed use 5.008 to use 5.006, constants are individually defined and
+ AutoLoader is used instead of SelfLoader.
+
+0.03 Tue Apr 29 16:50:00 2003
+ - Corrected an error that occurred when a form was used many times in different
+ documents. (Translation of old => new object number)
+ - Some preparations for using PDF::Reuse as an COM-object (ActiveX object)
+ (In version 0.02 of PDF::Reuse::Tutorial there will be examples)
+
+0.02 Fri Apr 25 20:49:50 2003
+ - I had to put all PDF documents and generated modules used in the examples
+ in a zip file, to hide them from the normal processing around the upload to CPAN.
+
+0.01 Thu Apr 3 12:21:26 2003
+ - original version; created by h2xs 1.22 with options
+ -AX -n PDF::Reuse
+
+
+
+
+
+
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..4a76ba7
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,11 @@
+Changes
+Makefile.PL
+MANIFEST
+README
+lib/PDF/Reuse.pm
+t/test.t
+t/Reuse.t
+lib/PDF/Util/reuseComponent_pl
+lib/PDF/Util/graphObj_pl
+lib/PDF/Reuse/Util.pm
+META.yml Module meta-data (added by MakeMaker)
diff --git a/META.yml b/META.yml
new file mode 100644
index 0000000..872336e
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,22 @@
+--- #YAML:1.0
+name: PDF-Reuse
+version: 0.39
+abstract: Reuse and mass produce PDF documents
+license: perl
+author:
+ - Lars Lundberg LARSLUND@CPAN.ORG
+ - Chris Nighswonger CNIGHS@CPAN.ORG
+generated_by: ExtUtils::MakeMaker version 6.42_02
+distribution_type: module
+requires:
+ AutoLoader: 0
+ Carp: 0
+ Compress::Zlib: 0
+ Data::Dumper: 0
+ Digest::MD5: 0
+ Exporter: 0
+ Font::TTF: 0
+ Text::PDF::TTFont0: 0
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.3.html
+ version: 1.3
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..a4ab9b6
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,60 @@
+use 5.006;
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile1(
+ 'NAME' => 'PDF::Reuse',
+ 'VERSION_FROM' => 'lib/PDF/Reuse.pm',
+ 'PREREQ_PM' => { Digest::MD5 => 0,
+ Compress::Zlib => 0,
+ Carp => 0,
+ Exporter => 0,
+ AutoLoader => 0,
+ Data::Dumper => 0,
+ Text::PDF::TTFont0 => 0,
+ Font::TTF => 0},
+ LICENSE => 'perl',
+ MIN_PERL_VERSION => '5.006',
+ META_MERGE => {
+ resources => {
+ repository => 'https://github.com/cnighswonger/PDF-Reuse',
+ },
+ },
+ TEST_REQUIRES => {
+ 'Test' => 0,
+ 'Test::More' => 0,
+ 'Test::Deep' => 0,
+ },
+ ABSTRACT_FROM => 'lib/PDF/Reuse.pm',
+ AUTHOR => [ 'Lars Lundberg LARSLUND@CPAN.ORG',
+ 'Chris Nighswonger CNIGHS@CPAN.ORG',
+ ],
+);
+
+sub WriteMakefile1 { #Compatibility code for old versions of EU::MM. Written by Alexandr Ciornii, version 0.23. Added by eumm-upgrade.
+ my %params=@_;
+ my $eumm_version=$ExtUtils::MakeMaker::VERSION;
+ $eumm_version=eval $eumm_version;
+ die "EXTRA_META is deprecated" if exists $params{EXTRA_META};
+ die "License not specified" if not exists $params{LICENSE};
+ if ($params{AUTHOR} and ref($params{AUTHOR}) eq 'ARRAY' and $eumm_version < 6.5705) {
+ $params{META_ADD}->{author}=$params{AUTHOR};
+ $params{AUTHOR}=join(', ',@{$params{AUTHOR}});
+ }
+ if ($params{TEST_REQUIRES} and $eumm_version < 6.64) {
+ $params{BUILD_REQUIRES}={ %{$params{BUILD_REQUIRES} || {}} , %{$params{TEST_REQUIRES}} };
+ delete $params{TEST_REQUIRES};
+ }
+ if ($params{BUILD_REQUIRES} and $eumm_version < 6.5503) {
+ #EUMM 6.5502 has problems with BUILD_REQUIRES
+ $params{PREREQ_PM}={ %{$params{PREREQ_PM} || {}} , %{$params{BUILD_REQUIRES}} };
+ delete $params{BUILD_REQUIRES};
+ }
+ delete $params{CONFIGURE_REQUIRES} if $eumm_version < 6.52;
+ delete $params{MIN_PERL_VERSION} if $eumm_version < 6.48;
+ delete $params{META_MERGE} if $eumm_version < 6.46;
+ delete $params{META_ADD} if $eumm_version < 6.46;
+ delete $params{LICENSE} if $eumm_version < 6.31;
+
+ WriteMakefile(%params);
+}
diff --git a/README b/README
new file mode 100644
index 0000000..4e67069
--- /dev/null
+++ b/README
@@ -0,0 +1,84 @@
+PDF/Reuse version 0.39
+======================
+
+This module gives you a possibility to reuse PDF-files. You can use pages,
+images, fonts and Acrobat JavaScript from old PDF-files (if they
+were not encrypted), and rearrange the components, and add new graphics,
+texts etc.
+
+There is also support for graphics. In the tutorial there is a description of
+how to transform simple PDF-pages to graphic Perl objects with the help of
+programs based on this module.
+
+The module is fairly fast, so it should be possible to used it for mass
+production.
+
+Usage e.g. for a long list:
+
+ use PDF::Reuse;
+ use strict;
+
+ # Getting customer data in some way ...
+
+ my @custData = ( { firstName => 'Anders',
+ lastName => 'Wallberg' },
+ { firstName => 'Nils',
+ lastName => 'Versen' },
+ { firstName => 'Niclas',
+ lastName => 'Lindberg' },
+
+ # and 10000 more records
+
+ { firstName => 'Sten',
+ lastName => 'Wernlund' } );
+
+ prFile('myFile.pdf');
+
+ for my $customer (@custData)
+ { prForm('letter.pdf');
+ prText(50, 750, "Dear $customer->{'firstName'}");
+ # ...
+ prPage();
+ }
+ prEnd();
+
+
+
+INSTALLATION
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+In a Windows environment you will probably meed nmake or dmake instead of make.
+(If you haven't got nmake, try to download it from Microsoft )
+
+DEPENDENCIES
+
+This module requires these other modules:
+
+ Carp
+ Compress::Zlib
+ Digest::MD5
+ Exporter
+ AutoLoader
+
+If you want to use true type fonts and non-Latin1 Unicode characters you also
+need theese optional modules
+
+ Font::TTF
+ Text::PDF::TTFont0 (Part of Text::PDF distribution)
+
+
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2003 - 2004 Lars Lundberg, Solidez HB.
+Copyright (C) 2005 - 2007 Karin Lundberg. All rights reserved.
+Copyright (C) 2008 - 2010 Lars Lundberg, Solidez HB.
+Copyright (C) 2010 - 2016 Chris Nighswonger.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
diff --git a/changelog b/debian/changelog
index 07e7991..07e7991 100644
--- a/changelog
+++ b/debian/changelog
diff --git a/control b/debian/control
index c17e2e2..c17e2e2 100644
--- a/control
+++ b/debian/control
diff --git a/copyright b/debian/copyright
index 3b60302..3b60302 100644
--- a/copyright
+++ b/debian/copyright
diff --git a/rules b/debian/rules
index fb9336d..fb9336d 100755
--- a/rules
+++ b/debian/rules
diff --git a/source/format b/debian/source/format
index 163aaf8..163aaf8 100644
--- a/source/format
+++ b/debian/source/format
diff --git a/upstream/metadata b/debian/upstream/metadata
index 00ef059..00ef059 100644
--- a/upstream/metadata
+++ b/debian/upstream/metadata
diff --git a/watch b/debian/watch
index 20f5e83..20f5e83 100644
--- a/watch
+++ b/debian/watch
diff --git a/lib/PDF/Reuse.pm b/lib/PDF/Reuse.pm
new file mode 100644
index 0000000..542086b
--- /dev/null
+++ b/lib/PDF/Reuse.pm
@@ -0,0 +1,6943 @@
+package PDF::Reuse;
+
+use 5.006;
+use strict;
+use warnings;
+
+require Exporter;
+require Digest::MD5;
+use autouse 'Carp' => qw(carp
+ cluck
+ croak);
+
+use Compress::Zlib qw(compress inflateInit);
+
+use autouse 'Data::Dumper' => qw(Dumper);
+use AutoLoader qw(AUTOLOAD);
+
+our $VERSION = '0.39';
+our @ISA = qw(Exporter);
+our @EXPORT = qw(prFile
+ prPage
+ prId
+ prIdType
+ prInitVars
+ prEnd
+ prExtract
+ prForm
+ prImage
+ prAltJpeg
+ prJpeg
+ prDoc
+ prDocForm
+ prFont
+ prFontSize
+ prGraphState
+ prGetLogBuffer
+ prAdd
+ prBar
+ prText
+ prDocDir
+ prLogDir
+ prLog
+ prVers
+ prCid
+ prJs
+ prInit
+ prField
+ prTouchUp
+ prCompress
+ prMbox
+ prBookmark
+ prStrWidth
+ prLink
+ prTTFont
+ prSinglePage);
+
+our ($utfil, $slutNod, $formCont, $imSeq, $duplicateInits, $page, $sidObjNr, $sida,
+ $interActive, $NamesSaved, $AARootSaved, $AAPageSaved, $root,
+ $AcroFormSaved, $id, $ldir, $checkId, $formNr, $imageNr,
+ $filnamn, $interAktivSida, $taInterAkt, $type, $runfil, $checkCs,
+ $confuseObj, $compress, $pos, $fontNr, $objNr, $docProxy,
+ $defGState, $gSNr, $pattern, $shading, $colorSpace, $totalCount);
+
+our (@kids, @counts, @formBox, @objekt, @parents, @aktuellFont, @skapa,
+ @jsfiler, @inits, @bookmarks, @annots);
+
+our ( %old, %oldObject, %resurser, %form, %image, %objRef, %nyaFunk, %fontSource,
+ %sidFont, %sidXObject, %sidExtGState, %font, %intAct, %fields, %script,
+ %initScript, %sidPattern, %sidShading, %sidColorSpace, %knownToFile,
+ %processed, %embedded, %dummy, %behandlad, %unZipped, %links, %prefs);
+
+our $stream = '';
+our $idTyp = '';
+our $ddir = '';
+our $log = '';
+
+#########################
+# Konstanter för objekt
+#########################
+
+use constant oNR => 0;
+use constant oPOS => 1;
+use constant oSTREAMP => 2;
+use constant oKIDS => 3;
+use constant oFORM => 4;
+use constant oIMAGENR => 5;
+use constant oWIDTH => 6;
+use constant oHEIGHT => 7;
+use constant oTYPE => 8;
+use constant oNAME => 9;
+
+###################################
+# Konstanter för formulär
+###################################
+
+use constant fOBJ => 0;
+use constant fRESOURCE => 1;
+use constant fBBOX => 2;
+use constant fIMAGES => 3;
+use constant fMAIN => 4;
+use constant fKIDS => 5;
+use constant fNOKIDS => 6;
+use constant fID => 7;
+use constant fVALID => 8;
+
+####################################
+# Konstanter för images
+####################################
+
+use constant imWIDTH => 0;
+use constant imHEIGHT => 1;
+use constant imXPOS => 2;
+use constant imYPOS => 3;
+use constant imXSCALE => 4;
+use constant imYSCALE => 5;
+use constant imIMAGENO => 6;
+
+#####################################
+# Konstanter för interaktiva objekt
+#####################################
+
+use constant iNAMES => 1;
+use constant iACROFORM => 2;
+use constant iAAROOT => 3;
+use constant iANNOTS => 4;
+use constant iSTARTSIDA => 5;
+use constant iAAPAGE => 6;
+
+#####################################
+# Konstanter för fonter
+#####################################
+
+use constant foREFOBJ => 0;
+use constant foINTNAMN => 1;
+use constant foEXTNAMN => 2;
+use constant foORIGINALNR => 3;
+use constant foSOURCE => 4;
+use constant foTYP => 5;
+use constant foFONTOBJ => 6;
+
+##########
+# Övrigt
+##########
+
+use constant IS_MODPERL => $ENV{MOD_PERL}; # For mod_perl 1.
+ # For mod_perl 2 pass $r to prFile()
+our $touchUp = 1;
+
+our %stdFont =
+ ('Times-Roman' => 'Times-Roman',
+ 'Times-Bold' => 'Times-Bold',
+ 'Times-Italic' => 'Times-Italic',
+ 'Times-BoldItalic' => 'Times-BoldItalic',
+ 'Courier' => 'Courier',
+ 'Courier-Bold' => 'Courier-Bold',
+ 'Courier-Oblique' => 'Courier-Oblique',
+ 'Courier-BoldOblique' => 'Courier-BoldOblique',
+ 'Helvetica' => 'Helvetica',
+ 'Helvetica-Bold' => 'Helvetica-Bold',
+ 'Helvetica-Oblique' => 'Helvetica-Oblique',
+ 'Helvetica-BoldOblique' => 'Helvetica-BoldOblique',
+ 'Symbol' => 'Symbol',
+ 'ZapfDingbats' => 'ZapfDingbats',
+ 'TR' => 'Times-Roman',
+ 'TB' => 'Times-Bold',
+ 'TI' => 'Times-Italic',
+ 'TBI' => 'Times-BoldItalic',
+ 'C' => 'Courier',
+ 'CB' => 'Courier-Bold',
+ 'CO' => 'Courier-Oblique',
+ 'CBO' => 'Courier-BoldOblique',
+ 'H' => 'Helvetica',
+ 'HB' => 'Helvetica-Bold',
+ 'HO' => 'Helvetica-Oblique',
+ 'HBO' => 'Helvetica-BoldOblique',
+ 'S' => 'Symbol',
+ 'Z' => 'ZapfDingbats');
+
+our $genLowerX = 0;
+our $genLowerY = 0;
+our $genUpperX = 595,
+our $genUpperY = 842;
+our $genFont = 'Helvetica';
+our $fontSize = 12;
+
+keys(%resurser) = 10;
+
+sub prFont
+{ my $nyFont = shift;
+ my ($intnamn, $extnamn, $objektnr, $oldIntNamn, $oldExtNamn);
+
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+ $oldIntNamn = $aktuellFont[foINTNAMN];
+ $oldExtNamn = $aktuellFont[foEXTNAMN];
+ if ($nyFont)
+ { ($intnamn, $extnamn, $objektnr) = findFont($nyFont);
+ }
+ else
+ { $intnamn = $aktuellFont[foINTNAMN];
+ $extnamn = $aktuellFont[foEXTNAMN];
+ }
+ if ($runfil)
+ { $log .= "Font~$nyFont\n";
+ }
+ if (wantarray)
+ { return ($intnamn, $extnamn, $oldIntNamn, $oldExtNamn, \%font);
+ }
+ else
+ { return $intnamn;
+ }
+}
+
+sub prFontSize
+{ my $fSize = shift || 12;
+ my $oldFontSize = $fontSize;
+ if ($fSize =~ m'\d+\.?\d*'o)
+ { $fontSize = $fSize;
+ if ($runfil)
+ { $log .= "FontSize~$fontSize\n";
+ }
+ }
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+
+ return ($fontSize, $oldFontSize);
+}
+
+sub prFile
+{ if ($pos)
+ { prEnd();
+ close UTFIL;
+ }
+ %prefs = ();
+ my $param = shift;
+ if (ref($param) eq 'HASH')
+ { $filnamn = '-';
+ for (keys %{$param})
+ { my $key = lc($_);
+ if ($key eq 'name')
+ { $filnamn = $param->{$_}; }
+ elsif (($key eq 'hidetoolbar')
+ || ($key eq 'hidemenubar')
+ || ($key eq 'hidewindowui')
+ || ($key eq 'fitwindow')
+ || ($key eq 'centerwindow'))
+ { $prefs{$key} = $param->{$_};
+ }
+ }
+ }
+ else
+ { $filnamn = $param || '-';
+ $prefs{hidetoolbar} = $_[1] if defined $_[1];
+ $prefs{hidemenubar} = $_[2] if defined $_[2];
+ $prefs{hidewindowui} = $_[3] if defined $_[3];
+ $prefs{fitwindow} = $_[4] if defined $_[4];
+ $prefs{centerwindow} = $_[5] if defined $_[5];
+ }
+ my $kortNamn;
+ if ($filnamn ne '-')
+ { my $ri = rindex($filnamn,'/');
+ if ($ri > 0)
+ { $kortNamn = substr($filnamn, ($ri + 1));
+ $utfil = $ddir ? $ddir . $kortNamn : $filnamn;
+ }
+ else
+ { $utfil = $ddir ? $ddir . $filnamn : $filnamn;
+ }
+ $ri = rindex($utfil,'/');
+ if ($ri > 0)
+ { my $dirdel = substr($utfil,0,$ri);
+ if (! -e $dirdel)
+ { mkdir $dirdel || errLog("Couldn't create dir $dirdel, $!");
+ }
+ }
+ else
+ { $ri = rindex($utfil,'\\');
+ if ($ri > 0)
+ { my $dirdel = substr($utfil,0,$ri);
+ if (! -e $dirdel)
+ { mkdir $dirdel || errLog("Couldn't create dir $dirdel, $!");
+ }
+ }
+ }
+ }
+ else
+ { $utfil = $filnamn;
+ }
+
+ my $utfil_ref = ref $utfil;
+ if ($utfil_ref and ($utfil_ref eq 'Apache2::RequestRec') or
+ ($utfil_ref eq 'Apache::RequestRec') ) # mod_perl 2
+ { tie *UTFIL, $utfil;
+ }
+ elsif (IS_MODPERL && $utfil eq '-') # mod_perl 1
+ { tie *UTFIL, 'Apache';
+ }
+ elsif ($utfil_ref and $utfil_ref eq 'IO::String')
+ { tie *UTFIL, $utfil;
+ }
+ else
+ { open (UTFIL, ">$utfil") || errLog("Couldn't open file $utfil, $!");
+ }
+ binmode UTFIL;
+ my $utrad = "\%PDF-1.4\n\%\â\ã\Ï\Ó\n";
+
+ $pos = syswrite UTFIL, $utrad;
+
+ if (defined $ldir)
+ { if ($utfil eq '-')
+ { $kortNamn = 'stdout';
+ }
+ if ($kortNamn)
+ { $runfil = $ldir . $kortNamn . '.dat';
+ }
+ else
+ { $runfil = $ldir . $filnamn . '.dat';
+ }
+ open (RUNFIL, ">>$runfil") || errLog("Couldn't open logfile $runfil, $!");
+ $log .= "Vers~$VERSION\n";
+ }
+
+
+ @parents = ();
+ @kids = ();
+ @counts = ();
+ @objekt = ();
+ $objNr = 2; # Reserverat objekt 1 för root och 2 för initial sidnod
+ $parents[0] = 2;
+ $page = 0;
+ $formNr = 0;
+ $imageNr = 0;
+ $fontNr = 0;
+ $gSNr = 0;
+ $pattern = 0;
+ $shading = 0;
+ $colorSpace = 0;
+ $sida = 0;
+ %font = ();
+ %resurser = ();
+ %fields = ();
+ @jsfiler = ();
+ @inits = ();
+ %nyaFunk = ();
+ %objRef = ();
+ %knownToFile = ();
+ @aktuellFont = ();
+ %old = ();
+ %behandlad = ();
+ @bookmarks = ();
+ %links = ();
+ undef $defGState;
+ undef $interActive;
+ undef $NamesSaved;
+ undef $AARootSaved;
+ undef $AcroFormSaved;
+ $checkId = '';
+ undef $duplicateInits;
+ undef $confuseObj;
+ $fontSize = 12;
+ $genLowerX = 0;
+ $genLowerY = 0;
+ $genUpperX = 595,
+ $genUpperY = 842;
+
+ prPage(1);
+ $stream = ' ';
+ if ($runfil)
+ { $filnamn = prep($filnamn);
+ $log .= "File~$filnamn";
+ $log .= (exists $prefs{hidetoolbar}) ? "~$prefs{hidetoolbar}" : '~';
+ $log .= (exists $prefs{hidemenubar}) ? "~$prefs{hidemenubar}" : '~';
+ $log .= (exists $prefs{hidewindowui}) ? "~$prefs{hidewindowui}" : '~';
+ $log .= (exists $prefs{fitwindow}) ? "~$prefs{fitwindow}" : '~';
+ $log .= (exists $prefs{centerwindow}) ? "~$prefs{centerwindow}" : "~\n";
+ }
+ 1;
+}
+
+
+sub prPage
+{ my $noLogg = shift;
+ if ((defined $stream) && (length($stream) > 0))
+ { skrivSida();
+ }
+
+ $page++;
+ $objNr++;
+ $sidObjNr = $objNr;
+
+ #
+ # Resurserna nollställs
+ #
+
+ %sidXObject = ();
+ %sidExtGState = ();
+ %sidFont = ();
+ %sidPattern = ();
+ %sidShading = ();
+ %sidColorSpace = ();
+ @annots = ();
+
+ undef $interAktivSida;
+ undef $checkCs;
+ if (($runfil) && (! $noLogg))
+ { $log .= "Page~\n";
+ print RUNFIL $log;
+ $log = '';
+ }
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+ 1;
+
+}
+
+sub prText
+{ my $xPos = shift;
+ my $yPos = shift;
+ my $TxT = shift;
+ my $align = shift || 'left';
+ my $rot = shift || '0';
+
+ my $width = 0;
+ my $x_align_offset = 0;
+
+ if (! defined $TxT)
+ { $TxT = '';
+ }
+
+ if (($xPos !~ m'\-?[\d\.]+'o) || (! defined $xPos))
+ { errLog("Illegal x-position for text: $xPos");
+ }
+ if (($yPos !~ m'\-?[\d\.]+'o) || (! defined $yPos))
+ { errLog("Illegal y-position for text: $yPos");
+ }
+
+ if ($runfil)
+ { my $Texten = prep($TxT);
+ $log .= "Text~$xPos~$yPos~$Texten~$align~$rot\n";
+ }
+
+ if (length($stream) < 3)
+ { $stream = "0 0 0 rg\n 0 g\nf\n";
+ }
+
+
+ if (! $aktuellFont[foINTNAMN])
+ { findFont();
+ }
+ my $Font = $aktuellFont[foINTNAMN]; # Namn i strömmen
+ $sidFont{$Font} = $aktuellFont[foREFOBJ];
+ my $fontname = $aktuellFont[foEXTNAMN];
+ my $ttfont = $font{$fontname} ? $font{$fontname}[foFONTOBJ] : undef;
+
+
+ # define what the offset for alignment is
+
+ if ((wantarray)
+ || ($align ne 'left'))
+ { $width = prStrWidth($TxT, $aktuellFont[foEXTNAMN], $fontSize);
+ if($align eq 'right')
+ { $x_align_offset = - $width;
+ }
+ elsif ($align eq 'center')
+ { $x_align_offset = -$width / 2;
+ }
+ }
+
+ $TxT =~ s|\(|\\(|gos;
+ $TxT =~ s|\)|\\)|gos;
+
+
+ unless($rot)
+ { $stream .= "\nBT /$Font $fontSize Tf ";
+ if($ttfont)
+ { $TxT = $ttfont->encode_text($TxT);
+ $stream .= $xPos+$x_align_offset . " $yPos Td $TxT Tj ET\n";
+ }
+ elsif (!$aktuellFont[foTYP])
+ { $stream .= $xPos+$x_align_offset . " $yPos Td \($TxT\) Tj ET\n";
+ }
+ else
+ { my $text;
+ $TxT =~ s/\\(\d\d\d)/chr(oct($1))/eg;
+ for (unpack ('C*', $TxT))
+ { $text .= sprintf("%04x", ($_ - 29));
+ }
+ $stream .= $xPos+$x_align_offset . " $yPos Td \<$text\> Tj ET\n";
+ }
+ }
+ else
+ { if ($rot =~ m'q(\d)'oi)
+ { if ($1 eq '1')
+ { $rot = 270;
+ }
+ elsif ($1 eq '2')
+ { $rot = 180;
+ }
+ else
+ { $rot = 90;
+ }
+ }
+
+ my $radian = sprintf("%.6f", $rot / 57.2957795); # approx.
+ my $Cos = sprintf("%.6f", cos($radian));
+ my $Sin = sprintf("%.6f", sin($radian));
+ my $negSin = $Sin * -1;
+
+ my $encText = $ttfont ? $ttfont->encode_text($TxT) : "\($TxT\)";
+ $stream .= "\nq\n" # enter a new stack frame
+ # . "/Gs0 gs\n" # reset graphic mode
+ . "$Cos $Sin $negSin $Cos $xPos $yPos cm\n" # rotation/translation in the CM
+ . "\nBT /$Font $fontSize Tf "
+ . "$x_align_offset 0 Td $encText Tj ET\n" # text @ 0,0
+ . "Q\n"; # close the stack frame
+ }
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+
+
+ if (wantarray)
+ { # return a new "cursor" position...
+
+ if($rot==0)
+ { if($align eq 'left')
+ { return ($xPos, $xPos + $width);
+ }
+ elsif($align eq 'center')
+ { return ($xPos - $x_align_offset, $xPos + $x_align_offset);
+ }
+ elsif($align eq 'right')
+ { return ($xPos - $width, $xPos);
+ }
+
+ }
+ else
+ { # todo
+ # we could some trigonometry to return an x/y point
+ return 1;
+ }
+ }
+ else
+ { return 1;
+ }
+
+}
+
+
+sub prAdd
+{ my $contents = shift;
+ $stream .= "\n$contents\n";
+ if ($runfil)
+ { $contents = prep($contents);
+ $log .= "Add~$contents\n";
+ }
+ $checkCs = 1;
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+ 1;
+}
+
+##########################
+# Ett grafiskt "formulär"
+##########################
+
+sub prForm
+{ my ($sidnr, $adjust, $effect, $tolerant, $infil, $x, $y, $size, $xsize,
+ $ysize, $rotate);
+ my $param = shift;
+ if (ref($param) eq 'HASH')
+ { $infil = $param->{'file'};
+ $sidnr = $param->{'page'} || 1;
+ $adjust = $param->{'adjust'} || '';
+ $effect = $param->{'effect'} || 'print';
+ $tolerant = $param->{'tolerant'} || '';
+ $x = $param->{'x'} || 0;
+ $y = $param->{'y'} || 0;
+ $rotate = $param->{'rotate'} || 0;
+ $size = $param->{'size'} || 1;
+ $xsize = $param->{'xsize'} || 1;
+ $ysize = $param->{'ysize'} || 1;
+ }
+ else
+ { $infil = $param;
+ $sidnr = shift || 1;
+ $adjust = shift || '';
+ $effect = shift || 'print';
+ $tolerant = shift || '';
+ $x = shift || 0;
+ $y = shift || 0;
+ $rotate = shift || 0;
+ $size = shift || 1;
+ $xsize = shift || 1;
+ $ysize = shift || 1;
+ }
+
+ my $refNr;
+ my $namn;
+ $type = 'form';
+ my $fSource = $infil . '_' . $sidnr;
+ if (! exists $form{$fSource})
+ { $formNr++;
+ $namn = 'Fm' . $formNr;
+ $knownToFile{$fSource} = $namn;
+ my $action;
+ if ($effect eq 'load')
+ { $action = 'load'
+ }
+ else
+ { $action = 'print'
+ }
+ $refNr = getPage($infil, $sidnr, $action);
+ if ($refNr)
+ { $objRef{$namn} = $refNr;
+ }
+ else
+ { if ($tolerant)
+ { if ((defined $refNr) && ($refNr eq '0')) # Sidnumret existerar inte, men ok
+ { $namn = '0';
+ }
+ else
+ { undef $namn; # Sidan kan inte användas som form
+ }
+ }
+ elsif (! defined $refNr)
+ { my $mess = "$fSource can't be used as a form. See the documentation\n"
+ . "under prForm how to concatenate streams\n";
+ errLog($mess);
+ }
+ else
+ { errLog("File : $infil Page: $sidnr doesn't exist");
+ }
+ }
+ }
+ else
+ { if (exists $knownToFile{$fSource})
+ { $namn = $knownToFile{$fSource};
+ }
+ else
+ { $formNr++;
+ $namn = 'Fm' . $formNr;
+ $knownToFile{$fSource} = $namn;
+ }
+ if (exists $objRef{$namn})
+ { $refNr = $objRef{$namn};
+ }
+ else
+ { if (! $form{$fSource}[fVALID])
+ { my $mess = "$fSource can't be used as a form. See the documentation\n"
+ . "under prForm how to concatenate streams\n";
+ if ($tolerant)
+ { cluck $mess;
+ undef $namn;
+ }
+ else
+ { errLog($mess);
+ }
+ }
+ elsif ($effect ne 'load')
+ { $refNr = byggForm($infil, $sidnr);
+ $objRef{$namn} = $refNr;
+ }
+ }
+ }
+ my @BBox = @{$form{$fSource}[fBBOX]} if ($refNr);
+ if (($effect eq 'print') && ($form{$fSource}[fVALID]) && ($refNr))
+ { if (! defined $defGState)
+ { prDefaultGrState();
+ }
+
+ if ($adjust)
+ { $stream .= "q\n";
+ $stream .= fillTheForm(@BBox, $adjust);
+ $stream .= "\n/Gs0 gs\n";
+ $stream .= "/$namn Do\n";
+ $stream .= "Q\n";
+ }
+ elsif (($x) || ($y) || ($rotate) || ($size != 1)
+ || ($xsize != 1) || ($ysize != 1))
+ { $stream .= "q\n";
+ $stream .= calcMatrix($x, $y, $rotate, $size,
+ $xsize, $ysize, $BBox[2], $BBox[3]);
+ $stream .= "\n/Gs0 gs\n";
+ $stream .= "/$namn Do\n";
+ $stream .= "Q\n";
+ }
+ else
+ { $stream .= "\n/Gs0 gs\n";
+ $stream .= "/$namn Do\n";
+
+ }
+ $sidXObject{$namn} = $refNr;
+ $sidExtGState{'Gs0'} = $defGState;
+ }
+ if ($runfil)
+ { $infil = prep($infil);
+ $log .= "Form~$infil~$sidnr~$adjust~$effect~$tolerant";
+ $log .= "~$x~$y~$rotate~$size~$xsize~$ysize\n";
+ }
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+ if (($effect ne 'print') && ($effect ne 'add'))
+ { undef $namn;
+ }
+ if (wantarray)
+ { my $images = 0;
+ if (exists $form{$fSource}[fIMAGES])
+ { $images = scalar(@{$form{$fSource}[fIMAGES]});
+ }
+ return ($namn, $BBox[0], $BBox[1], $BBox[2],
+ $BBox[3], $images);
+ }
+ else
+ { return $namn;
+ }
+}
+
+
+
+##########################################################
+sub prDefaultGrState
+##########################################################
+{ $objNr++;
+ $defGState = $objNr;
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+
+ $objekt[$objNr] = $pos;
+ my $utrad = "$objNr 0 obj" . '<</Type/ExtGState/SA false/SM 0.02/TR2 /Default'
+ . ">>endobj\n";
+ $pos += syswrite UTFIL, $utrad;
+ $objRef{'Gs0'} = $objNr;
+ return ('Gs0', $defGState);
+}
+
+######################################################
+# En font lokaliseras och fontobjektet skrivs ev. ut
+######################################################
+
+sub findFont
+{ no warnings;
+ my $Font = shift || '';
+
+ if (! (exists $fontSource{$Font})) # Fonten måste skapas
+ { if (exists $stdFont{$Font})
+ { $Font = $stdFont{$Font};}
+ else
+ { $Font = $genFont; } # Helvetica sätts om inget annat finns
+ if (! (exists $font{$Font}))
+ { $objNr++;
+ $fontNr++;
+ my $fontAbbr = 'Ft' . $fontNr;
+ my $fontObjekt = "$objNr 0 obj<</Type/Font/Subtype/Type1" .
+ "/BaseFont/$Font/Encoding/WinAnsiEncoding>>endobj\n";
+ $font{$Font}[foINTNAMN] = $fontAbbr;
+ $font{$Font}[foREFOBJ] = $objNr;
+ $objRef{$fontAbbr} = $objNr;
+ $fontSource{$Font}[foSOURCE] = 'Standard';
+ $objekt[$objNr] = $pos;
+ $pos += syswrite UTFIL, $fontObjekt;
+ }
+ }
+ else
+ { if (defined $font{$Font}[foREFOBJ]) # Finns redan i filen
+ { ; }
+ else
+ { if ($fontSource{$Font}[foSOURCE] eq 'Standard')
+ { $objNr++;
+ $fontNr++;
+ my $fontAbbr = 'Ft' . $fontNr;
+ my $fontObjekt = "$objNr 0 obj<</Type/Font/Subtype/Type1" .
+ "/BaseFont/$Font/Encoding/WinAnsiEncoding>>endobj\n";
+ $font{$Font}[foINTNAMN] = $fontAbbr;
+ $font{$Font}[foREFOBJ] = $objNr;
+ $objRef{$fontAbbr} = $objNr;
+ $objekt[$objNr] = $pos;
+ $pos += syswrite UTFIL, $fontObjekt;
+ }
+ else
+ { my $fSource = $fontSource{$Font}[foSOURCE];
+ my $ri = rindex($fSource, '_');
+ my $Source = substr($fSource, 0, $ri);
+ my $Page = substr($fSource, ($ri + 1));
+
+ if (! $fontSource{$Font}[foORIGINALNR])
+ { errLog("Couldn't find $Font, aborts");
+ }
+ else
+ { my $namn = extractObject($Source, $Page,
+ $fontSource{$Font}[foORIGINALNR], 'Font');
+ }
+ }
+ }
+ }
+
+ $aktuellFont[foEXTNAMN] = $Font;
+ $aktuellFont[foREFOBJ] = $font{$Font}[foREFOBJ];
+ $aktuellFont[foINTNAMN] = $font{$Font}[foINTNAMN];
+ $aktuellFont[foTYP] = $font{$Font}[foTYP];
+
+ $sidFont{$aktuellFont[foINTNAMN]} = $aktuellFont[foREFOBJ];
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+
+ return ($aktuellFont[foINTNAMN], $aktuellFont[foEXTNAMN], $aktuellFont[foREFOBJ]);
+}
+
+sub skrivSida
+{ my ($compressFlag, $streamObjekt, @extObj);
+ if ($checkCs)
+ { @extObj = ($stream =~ m'/(\S+)\s*'gso);
+ checkContentStream(@extObj);
+ }
+ if (( $compress ) && ( length($stream) > 99 ))
+ { my $output = compress($stream);
+ if ((length($output) > 25) && (length($output) < (length($stream))))
+ { $stream = $output;
+ $compressFlag = 1;
+ }
+ }
+
+ if (! $parents[0])
+ { $objNr++;
+ $parents[0] = $objNr;
+ }
+ my $parent = $parents[0];
+
+ ##########################################
+ # Interaktiva funktioner läggs ev. till
+ ##########################################
+
+ if ($interAktivSida)
+ { my ($infil, $sidnr) = split(/\s+/, $interActive);
+ ($NamesSaved, $AARootSaved, $AAPageSaved, $AcroFormSaved)
+ = AcroFormsEtc($infil, $sidnr);
+ }
+
+ ##########################
+ # Skapa resursdictionary
+ ##########################
+ my $resursDict = "/ProcSet[/PDF/Text]";
+ if (scalar %sidFont)
+ { $resursDict .= '/Font << ';
+ my $i = 0;
+ for (sort keys %sidFont)
+ { $resursDict .= "/$_ $sidFont{$_} 0 R";
+ }
+
+ $resursDict .= " >>";
+ }
+ if (scalar %sidXObject)
+ { $resursDict .= '/XObject<<';
+ for (sort keys %sidXObject)
+ { $resursDict .= "/$_ $sidXObject{$_} 0 R";
+ }
+ $resursDict .= ">>";
+ }
+ if (scalar %sidExtGState)
+ { $resursDict .= '/ExtGState<<';
+ for (sort keys %sidExtGState)
+ { $resursDict .= "\/$_ $sidExtGState{$_} 0 R";
+ }
+ $resursDict .= ">>";
+ }
+ if (scalar %sidPattern)
+ { $resursDict .= '/Pattern<<';
+ for (sort keys %sidPattern)
+ { $resursDict .= "/$_ $sidPattern{$_} 0 R";
+ }
+ $resursDict .= ">>";
+ }
+ if (scalar %sidShading)
+ { $resursDict .= '/Shading<<';
+ for (sort keys %sidShading)
+ { $resursDict .= "/$_ $sidShading{$_} 0 R";
+ }
+ $resursDict .= ">>";
+ }
+ if (scalar %sidColorSpace)
+ { $resursDict .= '/ColorSpace<<';
+ for (sort keys %sidColorSpace)
+ { $resursDict .= "/$_ $sidColorSpace{$_} 0 R";
+ }
+ $resursDict .= ">>";
+ }
+
+
+ my $resursObjekt;
+
+ if (exists $resurser{$resursDict})
+ { $resursObjekt = $resurser{$resursDict}; # Fanns ett identiskt,
+ } # använd det
+ else
+ { $objNr++;
+ if ( keys(%resurser) < 10)
+ { $resurser{$resursDict} = $objNr; # Spara 10 första resursobjekten
+ }
+ $resursObjekt = $objNr;
+ $objekt[$objNr] = $pos;
+ $resursDict = "$objNr 0 obj<<$resursDict>>endobj\n";
+ $pos += syswrite UTFIL, $resursDict ;
+ }
+ my $sidObjekt;
+
+ if (! $touchUp)
+ { #
+ # Contents objektet skapas
+ #
+
+ my $devX = "900";
+ my $devY = "900";
+
+ my $mellanObjekt = '<</Type/XObject/Subtype/Form/FormType 1';
+ if (defined $resursObjekt)
+ { $mellanObjekt .= "/Resources $resursObjekt 0 R";
+ }
+ $mellanObjekt .= "/BBox \[$genLowerX $genLowerY $genUpperX $genUpperY\]" .
+ "/Matrix \[ 1 0 0 1 -$devX -$devY \]";
+
+ my $langd = length($stream);
+
+ $objNr++;
+ $objekt[$objNr] = $pos;
+ if (! $compressFlag)
+ { $mellanObjekt = "$objNr 0 obj\n$mellanObjekt/Length $langd>>stream\n"
+ . $stream;
+ $mellanObjekt .= "endstream\nendobj\n";
+ }
+ else
+ { $stream = "\n" . $stream . "\n";
+ $langd++;
+ $mellanObjekt = "$objNr 0 obj\n$mellanObjekt/Filter/FlateDecode"
+ . "/Length $langd>>stream" . $stream;
+ $mellanObjekt .= "endstream\nendobj\n";
+ }
+
+ $pos += syswrite UTFIL, $mellanObjekt;
+ $mellanObjekt = $objNr;
+
+ if (! defined $confuseObj)
+ { $objNr++;
+ $objekt[$objNr] = $pos;
+
+ $stream = "\nq\n1 0 0 1 $devX $devY cm\n/Xwq Do\nQ\n";
+ $langd = length($stream);
+ $confuseObj = $objNr;
+ $stream = "$objNr 0 obj<</Length $langd>>stream\n" . "$stream";
+ $stream .= "\nendstream\nendobj\n";
+ $pos += syswrite UTFIL, $stream;
+ }
+ $sidObjekt = "$sidObjNr 0 obj\n<</Type/Page/Parent $parent 0 R/Contents $confuseObj 0 R"
+ . "/MediaBox \[$genLowerX $genLowerY $genUpperX $genUpperY\]"
+ . "/Resources <</ProcSet[/PDF/Text]/XObject<</Xwq $mellanObjekt 0 R>>>>";
+ }
+ else
+ { my $langd = length($stream);
+
+ $objNr++;
+ $objekt[$objNr] = $pos;
+ if (! $compressFlag)
+ { $streamObjekt = "$objNr 0 obj<</Length $langd>>stream\n" . $stream;
+ $streamObjekt .= "\nendstream\nendobj\n";
+ }
+ else
+ { $stream = "\n" . $stream . "\n";
+ $langd++;
+
+ $streamObjekt = "$objNr 0 obj<</Filter/FlateDecode"
+ . "/Length $langd>>stream" . $stream;
+ $streamObjekt .= "endstream\nendobj\n";
+ }
+
+ $pos += syswrite UTFIL, $streamObjekt;
+ $streamObjekt = $objNr;
+ ##################################
+ # Så skapas och skrivs sidobjektet
+ ##################################
+
+ $sidObjekt = "$sidObjNr 0 obj<</Type/Page/Parent $parent 0 R/Contents $streamObjekt 0 R"
+ . "/MediaBox \[$genLowerX $genLowerY $genUpperX $genUpperY\]"
+ . "/Resources $resursObjekt 0 R";
+ }
+
+ $stream = '';
+
+ my $tSida = $sida + 1;
+ if ((@annots)
+ || (%links && @{$links{'-1'}})
+ || (%links && @{$links{$tSida}}))
+ { $sidObjekt .= '/Annots ' . mergeLinks() . ' 0 R';
+ }
+ if (defined $AAPageSaved)
+ { $sidObjekt .= "/AA $AAPageSaved";
+ undef $AAPageSaved;
+ }
+ $sidObjekt .= ">>endobj\n";
+ $objekt[$sidObjNr] = $pos;
+ $pos += syswrite UTFIL, $sidObjekt;
+ push @{$kids[0]}, $sidObjNr;
+ $sida++;
+ $counts[0]++;
+ if ($counts[0] > 9)
+ { ordnaNoder(8); }
+}
+
+
+sub prEnd
+{ if (! $pos)
+ { return;
+ }
+ if ($stream)
+ { skrivSida(); }
+ skrivUtNoder();
+
+ if($docProxy)
+ { $docProxy->write_objects;
+ undef $docProxy; # Break circular refs
+ }
+
+ ###################
+ # Skriv root
+ ###################
+
+ if (! defined $objekt[$objNr])
+ { $objNr--; # reserverat sidobjektnr utnyttjades aldrig
+ }
+
+ my $utrad = "1 0 obj<</Type/Catalog/Pages $slutNod 0 R";
+ if (defined $NamesSaved)
+ { $utrad .= "\/Names $NamesSaved 0 R\n";
+ }
+ elsif ((scalar %fields) || (scalar @jsfiler))
+ { $utrad .= "\/Names " . behandlaNames() . " 0 R\n";
+ }
+ if (defined $AARootSaved)
+ { $utrad .= "/AA $AARootSaved\n";
+ }
+ if ((scalar @inits) || (scalar %fields))
+ { my $nyttANr = skrivKedja();
+ $utrad .= "/OpenAction $nyttANr 0 R";
+ }
+
+ if (defined $AcroFormSaved)
+ { $utrad .= "/AcroForm $AcroFormSaved\n";
+ }
+
+ if (scalar @bookmarks)
+ { my $outLine = ordnaBookmarks();
+ $utrad .= "/Outlines $outLine 0 R/PageMode /UseOutlines\n";
+ }
+ if (scalar %prefs)
+ { $utrad .= '/ViewerPreferences << ';
+ if (exists $prefs{hidetoolbar})
+ { $utrad .= ($prefs{hidetoolbar}) ? '/HideToolbar true'
+ : '/HideToolbar false';
+ }
+ if (exists $prefs{hidemenubar})
+ { $utrad .= ($prefs{hidemenubar}) ? '/HideMenubar true'
+ : '/HideMenubar false';
+ }
+ if (exists $prefs{hidewindowui})
+ { $utrad .= ($prefs{hidewindowui}) ? '/HideWindowUI true'
+ : '/HideWindowUI false';
+ }
+ if (exists $prefs{fitwindow})
+ { $utrad .= ($prefs{fitwindow}) ? '/FitWindow true'
+ : '/FitWindow false';
+ }
+ if (exists $prefs{centerwindow})
+ { $utrad .= ($prefs{centerwindow}) ? '/CenterWindow true'
+ : '/CenterWindow false';
+ }
+ $utrad .= '>> ';
+ }
+
+ $utrad .= ">>endobj\n";
+
+ $objekt[1] = $pos;
+ $pos += syswrite UTFIL, $utrad;
+ my $antal = $#objekt;
+ my $startxref = $pos;
+ my $xrefAntal = $antal + 1;
+ $pos += syswrite UTFIL, "xref\n";
+ $pos += syswrite UTFIL, "0 $xrefAntal\n";
+ $pos += syswrite UTFIL, "0000000000 65535 f \n";
+
+ for (my $i = 1; $i <= $antal; $i++)
+ { $utrad = sprintf "%.10d 00000 n \n", $objekt[$i];
+ $pos += syswrite UTFIL, $utrad;
+ }
+
+ $utrad = "trailer\n<<\n/Size $xrefAntal\n/Root 1 0 R\n";
+ if ($idTyp ne 'None')
+ { my ($id1, $id2) = definieraId();
+ $utrad .= "/ID [<$id1><$id2>]\n";
+ $log .= "IdType~rep\n";
+ $log .= "Id~$id1\n";
+ }
+ $utrad .= ">>\nstartxref\n$startxref\n";
+ $pos += syswrite UTFIL, $utrad;
+ $pos += syswrite UTFIL, "%%EOF\n";
+ close UTFIL;
+
+ if ($runfil)
+ { if ($log)
+ { print RUNFIL $log;
+ }
+ close RUNFIL;
+ }
+ $log = '';
+ $runfil = '';
+ $pos = 0;
+ 1;
+}
+
+sub ordnaNoder
+{ my $antBarn = shift;
+ my $i = 0;
+ my $j = 1;
+ my $vektor;
+
+ while ($antBarn < $#{$kids[$i]})
+ { #
+ # Skriv ut aktuell förälder
+ # flytta till nästa nivå
+ #
+ $vektor = '[';
+
+ for (@{$kids[$i]})
+ { $vektor .= "$_ 0 R "; }
+ $vektor .= ']';
+
+ if (! $parents[$j])
+ { $objNr++;
+ $parents[$j] = $objNr;
+ }
+
+ my $nodObjekt;
+ $nodObjekt = "$parents[$i] 0 obj<</Type/Pages/Parent $parents[$j] 0 R\n/Kids $vektor\n/Count $counts[$i]>>endobj\n";
+
+ $objekt[$parents[$i]] = $pos;
+ $pos += syswrite UTFIL, $nodObjekt;
+ $counts[$j] += $counts[$i];
+ $counts[$i] = 0;
+ $kids[$i] = [];
+ push @{$kids[$j]}, $parents[$i];
+ undef $parents[$i];
+ $i++;
+ $j++;
+ }
+}
+
+sub skrivUtNoder
+{ no warnings;
+ my ($i, $j, $vektor, $nodObjekt);
+ my $si = -1;
+ #
+ # Hitta slutnoden
+ #
+ for (@parents)
+ { $slutNod = $_;
+ $si++;
+ }
+
+ for ($i = 0; $parents[$i] ne $slutNod; $i++)
+ { if (defined $parents[$i]) # Bara definierat om det finns kids
+ { $vektor = '[';
+ for (@{$kids[$i]})
+ { $vektor .= "$_ 0 R "; }
+ $vektor .= ']';
+ ########################################
+ # Hitta förälder till aktuell förälder
+ ########################################
+ my $nod;
+ for ($j = $i + 1; (! $nod); $j++)
+ { if ($parents[$j])
+ { $nod = $parents[$j];
+ $counts[$j] += $counts[$i];
+ push @{$kids[$j]}, $parents[$i];
+ }
+ }
+
+ $nodObjekt = "$parents[$i] 0 obj<</Type/Pages/Parent $nod 0 R\n/Kids $vektor/Count $counts[$i]>>endobj\n";
+
+ $objekt[$parents[$i]] = $pos;
+ $pos += syswrite UTFIL, $nodObjekt;
+ }
+ }
+ #####################################
+ # Så ordnas och skrivs slutnoden ut
+ #####################################
+ $vektor = '[';
+ for (@{$kids[$si]})
+ { $vektor .= "$_ 0 R "; }
+ $vektor .= ']';
+ $nodObjekt = "$slutNod 0 obj<</Type/Pages/Kids $vektor/Count $counts[$si]";
+ # $nodObjekt .= "/MediaBox \[$genLowerX $genLowerY $genUpperX $genUpperY\]";
+ $nodObjekt .= " >>endobj\n";
+ $objekt[$slutNod] = $pos;
+ $pos += syswrite UTFIL, $nodObjekt;
+
+}
+
+sub findGet
+{ my ($fil, $cid) = @_;
+ $fil =~ s|\s+$||o;
+ my ($req, $extFil, $tempFil, $fil2, $tStamp, $res);
+
+ if (-e $fil)
+ { $tStamp = (stat($fil))[9];
+ if ($cid)
+ {
+ if ($cid eq $tStamp)
+ { return ($fil, $cid);
+ }
+ }
+ else
+ { return ($fil, $tStamp);
+ }
+ }
+ if ($cid)
+ { $fil2 = $fil . $cid;
+ if (-e $fil2)
+ { return ($fil2, $cid);
+ }
+ }
+ errLog("The file $fil can't be found, aborts");
+}
+
+sub definieraId
+{ if ($idTyp eq 'rep')
+ { if (! defined $id)
+ { errLog("Can't replicate the id if is missing, aborting");
+ }
+ my $tempId = $id;
+ undef $id;
+ return ($tempId, $tempId);
+ }
+ elsif ($idTyp eq 'add')
+ { $id++;
+ return ($id, $id);
+ }
+ else
+ { my $str = time();
+ $str .= $filnamn . $pos;
+ $str = Digest::MD5::md5_hex($str);
+ return ($str, $str);
+ }
+}
+
+sub prStrWidth
+{ require PDF::Reuse::Util;
+ my $string = shift;
+ my $Font = shift;
+ my $FontSize = shift || $fontSize;
+ my $w = 0;
+
+ # there's no use continuing if no string is passed in
+ if (! defined($string))
+ { errLog("undefined value passed to prStrWidth");
+ }
+
+ if (length($string) == 0)
+ { return 0;
+ }
+
+ if(my($width) = ttfStrWidth($string, $Font, $FontSize))
+ { return $width;
+ }
+
+ if (! $Font)
+ { if (! $aktuellFont[foEXTNAMN])
+ { findFont();
+ }
+ $Font = $aktuellFont[foEXTNAMN];
+ }
+
+ if (! exists $PDF::Reuse::Util::font_widths{$Font})
+ { if (exists $stdFont{$Font})
+ { $Font = $stdFont{$Font};
+ }
+ if (! exists $PDF::Reuse::Util::font_widths{$Font})
+ { $Font = 'Helvetica';
+ }
+ }
+
+ if (ref($PDF::Reuse::Util::font_widths{$Font}) eq 'ARRAY')
+ { my @font_table = @{ $PDF::Reuse::Util::font_widths{$Font} };
+ for (unpack ("C*", $string))
+ { $w += $font_table[$_];
+ }
+ }
+ else
+ { $w = length($string) * $PDF::Reuse::Util::font_widths{$Font};
+ }
+ $w = $w / 1000 * $FontSize;
+
+ return $w;
+}
+
+sub prTTFont
+{ return prFont() if ! @_;
+ my($selector, $fontname) = @_;
+
+ # Have we loaded this font already?
+ my $ttfont = findTTFont($selector);
+ if (! $ttfont and $font{$selector} )
+ { return prFont($selector);
+ }
+ $fontname = $ttfont->fontname if $ttfont;
+
+ # Create a new TTFont object if we haven't loaded this one before
+ if (! $ttfont)
+ { $docProxy ||= PDF::Reuse::DocProxy->new(
+ next_obj => sub { ++$objNr },
+ prObj => \&prObj,
+ );
+
+ my $ttfont = PDF::Reuse::TTFont->new(
+ filename => $selector,
+ fontname => $fontname,
+ fontAbbr => 'Ft' . ++$fontNr,
+ docProxy => $docProxy,
+ );
+ $fontname = $ttfont->fontname;
+
+ $font{$fontname}[foINTNAMN] = $ttfont->fontAbbr;
+ $font{$fontname}[foREFOBJ] = $ttfont->obj_num;
+ $font{$fontname}[foFONTOBJ] = $ttfont;
+ $objRef{$ttfont->fontAbbr} = $ttfont->obj_num;
+ $fontSource{$fontname}[foSOURCE] = 'Standard';
+ }
+
+ my $oldIntNamn = $aktuellFont[foINTNAMN];
+ my $oldExtNamn = $aktuellFont[foEXTNAMN];
+
+ $aktuellFont[foEXTNAMN] = $fontname;
+ $aktuellFont[foREFOBJ] = $font{$fontname}[foREFOBJ];
+ $aktuellFont[foINTNAMN] = $font{$fontname}[foINTNAMN];
+ $aktuellFont[foTYP] = $font{$fontname}[foTYP];
+
+ $sidFont{$aktuellFont[foINTNAMN]} = $aktuellFont[foREFOBJ];
+
+ if (wantarray)
+ { return ($aktuellFont[foINTNAMN], $aktuellFont[foEXTNAMN], $oldIntNamn, $oldExtNamn, \%font);
+ }
+ else
+ { return $aktuellFont[foINTNAMN];
+ }
+}
+
+
+sub prObj
+{ my($objNr, $data) = @_;
+
+ $objekt[$objNr] = $pos;
+ $pos += syswrite UTFIL, $data;
+}
+
+
+sub findTTFont
+{ my $selector = shift || $aktuellFont[foEXTNAMN];
+
+ return $font{$selector}[foFONTOBJ] if $font{$selector};
+ foreach my $name (keys %font)
+ { if ( $font{$name}[foINTNAMN] eq $selector
+ or $font{$name}[foFONTOBJ] && $font{$name}[foFONTOBJ]->filename eq $selector
+ )
+ { return $font{$name}[foFONTOBJ];
+ }
+ }
+ return;
+}
+
+
+sub ttfStrWidth
+{ my($string, $selector, $fontsize) = @_;
+
+ my $ttfont = findTTFont($selector) or return;
+ return $ttfont->text_width($string, $fontsize);
+}
+
+
+# This 'glue' package emulates the bits of the Text::PDF::File API that are
+# needed by Text::PDF::TTFont0 (below) and ties them in to the PDF::Reuse API.
+
+package PDF::Reuse::DocProxy;
+
+sub new
+{ my $class = shift;
+
+ my $self = bless { ' version' => 3, @_, '>buffer' => '', }, $class;
+}
+
+
+sub new_obj
+{ my $self = shift;
+ my $obj = shift or die 'No base for new_obj';
+
+ my $num = $self->{next_obj}->();
+ my $gen = 0;
+
+ $self->{' objcache'}{$num, $gen} = $obj;
+ $self->{' objects'}{$obj->uid} = [ $num, $gen ];
+ return $obj;
+}
+
+
+sub object_number
+{ my($self, $obj) = @_;
+ my $num = $self->{' objects'}{$obj->uid} || return;
+ return $num->[0];
+}
+
+
+sub print
+{ my($self, $data) = @_;
+
+ if(my($tail, $rest) = $data =~ m{\A(.*?\nendobj\n)(.*)\z}s)
+ { my($obj_num) = $self->{'>buffer'} =~ /(\d+)/;
+ # Pass serialised object back to PDF::Reuse
+ $self->{prObj}->($obj_num, $self->{'>buffer'} . $tail);
+ $self->{'>buffer'} = $rest;
+ }
+ else
+ { $self->{'>buffer'} .= $data;
+ }
+}
+
+
+sub printf
+{ my($self, $format, @args) = @_;;
+ $self->print(sprintf($format, @args));
+}
+
+
+sub out_obj
+{ my($self, $obj) = @_;
+ return $self->new_obj($obj) unless defined $self->{' objects'}{$obj->uid};
+ push @{ $self->{'>todo'} }, $obj->uid;
+}
+
+
+sub tell
+{ return length shift->{'>buffer'};
+}
+
+
+sub write_objects
+{ my($self) = @_;
+
+ $self->{'>done'} = {};
+ $self->{'>todo'} = [ sort map { $_->uid } values %{ $self->{' objcache'} } ];
+ while(my $id = shift @{ $self->{'>todo'} }) {
+ next if $self->{'>done'}{$id};
+ my($num, $gen) = @{ $self->{' objects'}{$id} };
+ $self->printf("%d %d obj\n", $num, $gen);
+ $self->{' objcache'}{$num, $gen}->outobjdeep($self, $self);
+ $self->print("\nendobj\n");
+ $self->{'>done'}{$id}++;
+ }
+}
+
+
+# This is a wrapper around Text::PDF::TTFont0, which provides support for
+# embedding TrueType fonts
+
+package PDF::Reuse::TTFont;
+
+sub new
+{ my $class = shift;
+
+ require Text::PDF::TTFont0;
+
+ my $self = bless { 'subset' => 1, @_, }, $class;
+
+ $self->{ttfont} = Text::PDF::TTFont0->new(
+ $self->{docProxy},
+ $self->{filename},
+ $self->{fontAbbr},
+ -subset => $self->{subset},
+ );
+ $self->{ttfont}->{' subvec'} = '';
+
+ $self->{obj_num} = $self->{docProxy}->object_number($self->{ttfont});
+
+ $self->{fontname} ||= $self->find_name();
+
+ return $self;
+}
+
+sub filename { return $_[0]->{filename}; }
+sub fontname { return $_[0]->{fontname}; }
+sub obj_num { return $_[0]->{obj_num}; }
+sub fontAbbr { return $_[0]->{fontAbbr}; }
+sub docProxy { return $_[0]->{docProxy}; }
+
+sub find_name
+{ my $self = shift;
+ my($filebase) = $self->filename =~ m{.*[\\/](.*)\.};
+ my $font = $self->{ttfont}->{' font'} or return $filebase;
+ my $obj = $font->{'name'} or return $filebase;
+ my $name = $obj->read->find_name(4) or return $filebase;
+ $name =~ s{\W}{}g;
+ return $name;
+}
+
+sub encode_text
+{ my($self, $text) = @_;
+ $text =~ s|\\\(|(|gos;
+ $text =~ s|\\\)|)|gos;
+ return $self->{ttfont}->out_text($text);
+}
+
+sub text_width
+{ my($self, $text, $size) = @_;
+ return $self->{ttfont}->width($text) * $size;
+}
+
+sub DESTROY
+{ my $self = shift;
+ if(my $ttfont = $self->{ttfont})
+ { if(my $font = delete $ttfont->{' font'})
+ { $font->release();
+ }
+ $ttfont->release();
+ }
+ %$self = ();
+}
+
+
+package PDF::Reuse; # Applies to the autoloaded methods below (?)
+
+1;
+
+__END__
+
+=head1 NAME
+
+PDF::Reuse - Reuse and mass produce PDF documents
+
+=head1 SYNOPSIS
+
+=for SYNOPSIS.pl begin
+
+ use PDF::Reuse;
+ prFile('myFile.pdf');
+ prText(100, 500, 'Hello World !');
+ prEnd();
+
+=for end
+
+=head1 DESCRIPTION
+
+This module could be used when you want to mass produce similar (but not identical)
+PDF documents and reuse templates, JavaScripts and some other components. It is
+functional to be fast, and to give your programs capacity to produce many pages
+per second and very big PDF documents if necessary.
+
+The module produces PDF-1.4 files. Some features of PDF-1.5, like "object streams"
+and "cross reference streams", are supported, but only at an experimental level. More
+testing is needed. (If you get problems with a new document from Acrobat 6 or higher, try to
+save it or recreate it as a PDF-1.4 document first, before using it together with
+this module.)
+
+=over 2
+
+=item Templates
+
+Use your favorite program, probably a commercial visual tool, to produce single
+PDF-files to be used as templates, and then use this module to B<mass produce> files
+from them.
+
+(If you want small PDF-files or want special graphics, you can use this module also,
+but visual tools are often most practical.)
+
+=item Lists
+
+The module uses "XObjects" extensively. This is a format that makes it possible
+create big lists, which are compact at the same time.
+
+
+=item PDF-operators
+
+The module gives you a good possibility to program at a "low level" with the basic
+graphic operators of PDF, if that is what you want to do. You can build your
+own libraries of low level routines, with PDF-directives "controlled" by Perl.
+
+=item Archive-format
+
+If you want, you get your new documents logged in a format suitable for archiving
+or transfer.
+
+
+PDF::Reuse::Tutorial might show you best what you can do with this module.
+
+=item JavaScript
+
+You can attach JavaScripts to your PDF-files.
+
+You can have libraries of JavaScripts. No cutting or pasting, and those who include
+the scripts in documents only need to know how to initiate them. (Of course those
+who write the scripts have to know Acrobat JavaScript well.)
+
+=back
+
+=head2 Remarks about JavaScript
+
+Some of the functions handling JavaScript have to be rewritten for Acrobat 7.
+
+There are many limitations with Acrobat JavaScript, and the rules often change.
+So what works for one version of Acrobat/Reader, might not work for another.
+Another complication is this:
+When documents are downloaded via the net by Acrobat, they are most often
+converted (!) and necessary JavaScripts are lost.
+
+
+=head1 FUNCTIONS
+
+All functions which are successful return specified values or 1.
+
+The module doesn't make any attempt to import anything from encrypted files.
+
+=head1 Overview
+
+To write a program with PDF::Reuse, you need these components:
+
+=begin html
+
+<style>
+ pre span.comment {
+ color:AA0000 ;
+ font-style: italic;
+}
+</style>
+
+
+<TABLE border=1 cellpadding="7">
+ <THEAD bgcolor="lightblue">
+ <TH title="Mandatory">First</TH>
+ <TH title="Slightly deprecated functions for your output">Perhaps*</TH>
+ <TH title="Mandatory">Always</TH>
+ <TH title="If you want to add someting">Any or None</TH>
+ <TH title="Often you need to indicate that you need a new page and possibly from where">Probably**</TH>
+ <TH title="Mandatory">Finally</TH>
+ </THEAD>
+ <TR valign="top" bgcolor="lightgreen">
+ <TD title="To include the module"><B>use PDF::Reuse</B></TD>
+ <TD></TD>
+ <TD title="Finish an old document and direct output for a new document"><B>prFile</B></TD>
+ <TD title="To add new contents, JavaScript, links and so on..">prInitVars<BR>
+ prExtract<BR>
+ prForm<BR>
+ prInit<BR>
+ prField<BR>
+ prImage<BR>
+ prAltJpeg<BR>
+ prJpeg<BR>
+ prFont<BR>
+ prFontSize<BR>
+ prTTFont<BR>
+ prGraphState<BR>
+ prAdd<BR>
+ prText<BR>
+ prJs<BR>
+ prCompress<BR>
+ prMbox<BR>
+ prBookmark<BR>
+ prStrWidth<BR>
+ prLink</TD>
+ <TD title="These functions collect available contents and create the pages">prDoc<BR>
+ prPage<BR>
+ prSinglePage</TD>
+ <TD title="To finish last document and clean up"><B>prEnd</B></TD>
+ <TR valign="top" bgcolor="lightyellow">
+ <TD></TD>
+ <TD>prDocDir*<BR>
+ prLogDir*</TD>
+ <TD></TD>
+ <TD>prDocForm*<BR>
+ prGetLogBuffer*<BR>
+ prBar*<BR>
+ prLog*<BR>
+ prTouchUp*<BR>
+ prVers*<BR>
+ prCid*<BR>
+ prId*<BR>
+ prIdType*<BR></TD>
+ <TD></TD>
+ <TD></TD>
+ </TR>
+ <TR bgcolor="lightgrey">
+ <TD colspan=6> * = internal/ deprecated function</TD>
+ </TR>
+ <TR bgcolor="lightgrey">
+ <TD colspan=6> ** = not needed before prEnd or a new prFile<BR>
+ In those cases prPage is automatically inserted </TD>
+ </TR>
+ </TABLE>
+
+
+
+=end html
+
+=head1 Mandatory Functions
+
+=head2 prFile - define output
+
+Alternative 1:
+
+ prFile ( $fileName );
+
+Alternative 2 with parameters in an anonymous hash:
+
+ prFile ( { Name => $fileName,
+ HideToolbar => 1, # 1 or 0
+ HideMenubar => 1, # 1 or 0
+ HideWindowUI => 1, # 1 or 0
+ FitWindow => 1, # 1 or 0
+ CenterWindow => 1 } ); # 1 or 0
+
+Alternative 3:
+
+ prFile ( $r ); # For mod_perl 2 pass the request object
+
+$fileName is optional, just like the rest of the parameters.
+File to create. If another file is current when this function is called, the first
+one is written and closed. Only one file is processed at a single moment. If
+$fileName is undefined, output is written to STDOUT.
+
+HideToolbar, HideMenubar, HideWindowUI, FitWindow and CenterWindow control the
+way the document is initially displayed.
+
+Look at any program in this documentation for examples. prInitVars() shows how
+this function could be used together with a web server.
+
+=head2 prEnd - end/flush buffers
+
+ prEnd ()
+
+When the processing is going to end, the buffers of the B<last> file has to be written to the disc.
+If this function is not called, the page structure, xref part and so on will be
+lost.
+
+Look at any program in this documentation for an example.
+
+=head1 Optional Functions
+
+=head2 prAdd - add "low level" instructions
+
+ prAdd ( $string )
+
+With this command you can add whatever you want to the current content stream.
+No syntactical checks are made, but if you use an internal name, the module tries
+to add the resource of the "name object" to the "Resources" of current page.
+"Name objects" always begin with a '/'.
+
+(In this documentation I often use talk about an "internal name". It denotes a
+"name object". When PDF::Reuse creates these objects, it assigns Ft1, Ft2, Ft3 ...
+for fonts, Ig1, Ig2, Ig3 for images, Fo1 .. for forms, Cs1 .. for Color spaces,
+Pt1 .. for patterns, Sh1 .. for shading directories, Gs0 .. for graphic state
+parameter dictionaries. These names are kept until the program finishes,
+and my ambition is also to keep the resources available in internal tables.)
+
+This is a simple and very powerful function. You should study the examples and
+the "PDF-reference manual", if you want to use it.(When this text is written,
+a possible link to download it is:
+http://partners.adobe.com/asn/developer/acrosdk/docs.html)
+
+This function is intended to give you detail control at a low level.
+
+ use PDF::Reuse;
+ use strict;
+
+ prFile('myFile.pdf');
+ my $string = "150 600 100 50 re\n"; # a rectangle
+ $string .= "0 0 1 rg\n"; # blue (to fill)
+ $string .= "b\n"; # fill and stroke
+ prAdd($string);
+ prEnd();
+
+
+=head2 prBookmark - define bookmarks
+
+ prBookmark($reference)
+
+Defines a "bookmark". $reference refers to a hash or array of hashes which looks
+something like this:
+
+ { text => 'Document',
+ act => 'this.pageNum = 0; this.scroll(40, 500);',
+ kids => [ { text => 'Chapter 1',
+ act => '1, 40, 600'
+ },
+ { text => 'Chapter 2',
+ act => '10, 40, 600'
+ }
+ ]
+ }
+
+Each hash can have these components:
+
+ text the text shown beside the bookmark
+ act the action to be triggered. Has to be a JavaScript action.
+ (Three simple numbers are translated to page, x and y in the
+ sentences: this.pageNum = page; this.scroll(x, y); )
+ kids will have a reference to another hash or array of hashes
+ close if this component is present, the bookmark will be closed
+ when the document is opened
+ color 3 numbers, RGB-colors e.g. '0.5 0.5 1' for light blue
+ style 0, 1, 2, or 3. 0 = Normal, 1 = Italic, 2 = Bold, 3 = Bold Italic
+
+Creating bookmarks for a document:
+
+ use PDF::Reuse;
+ use strict;
+
+ my @pageMarks;
+
+ prFile('myDoc.pdf');
+
+ for (my $i = 0; $i < 100; $i++)
+ { prText(40, 600, 'Something is written');
+ # ...
+ my $page = $i + 1;
+ my $bookMark = { text => "Page $page",
+ act => "$i, 40, 700" };
+ push @pageMarks, $bookMark;
+ prPage();
+ }
+ prBookmark( { text => 'Document',
+ close => 1,
+ kids => \@pageMarks } );
+ prEnd();
+
+
+Traditionally bookmarks have mainly been used for navigation within a document,
+but they can be used for many more things. You can e.g. use them to navigate within
+your data. You can let your users go to external links also, so they can "drill down"
+to other documents.
+
+B<See "Remarks about JavaScript">
+
+=head2 prCompress - compress/zip added streams
+
+ prCompress (1)
+
+'1' here is a directive to compress all B<new> streams of the current file. Streams
+which are included with prForm, prDocForm, prDoc or prSinglePage are not changed. New
+JavaScripts are also created as streams and compressed, if they are at least 100
+bytes long. The streams are compressed in memory, so probably there is a limit of
+how big they can be.
+
+prCompress(); is a directive not to compress. This is default.
+
+See e.g. "Starting to reuse" in the tutorial for an example.
+
+=head2 prDoc - include pages from a document
+
+ prDoc ( $documentName, $firstPage, $lastPage )
+
+or with the parameters in an anonymous hash:
+
+ prDoc ( { file => $documentName,
+ first => $firstPage,
+ last => $lastPage } );
+
+Returns number of extracted pages.
+
+If "first" is not given, 1 is assumed. If "last" is not given, you don't have any upper
+limit. N.B. The numbering of the pages differs from Acrobat JavaScript. In JavaScript
+the first page has index 0.
+
+Adds pages from a document to the one you are creating.
+N.B. From version 0.32 of this module:
+If there are contents created with with prText, prImage,prAdd, prForm and so on,
+prDoc tries to put the contents on the first extracted page
+from the old document.
+
+
+If it is the first interactive
+component ( prDoc() or prDocForm() ) the interactive functions are kept and also merged
+with JavaScripts you have added, if any. But, if you specify a first page different than 1
+or a last page, no JavaScript are extracted from the document, because then there is a
+risk that an included JavaScript function might refer to something not included.
+
+ use PDF::Reuse;
+ use strict;
+
+ prFile('myFile.pdf'); # file to make
+ prJs('customerResponse.js'); # include a JavaScript file
+ prInit('nameAddress(12, 150, 600);'); # init a JavaScript function
+ prForm('best.pdf'); # page 1 from best.pdf
+ prPage();
+ prDoc('long.pdf'); # a document with 11 pages
+ prForm('best.pdf'); # page 1 from best.pdf
+ prText(150, 700, 'Customer Data'); # a line of text
+ prEnd();
+
+To extract pages 2-3 and 5-7 from a document and create a new document:
+
+ use PDF::Reuse;
+ use strict;
+
+ prFile('new.pdf');
+ prDoc( { file => 'old.pdf',
+ first => 2,
+ last => 3 });
+ prDoc( { file => 'old.pdf',
+ first => 5,
+ last => 7 });
+ prEnd();
+
+
+To add a form, image and page number to each page of an 16 pages long document
+(The document Battery.pdf is cropped so each page is fairly small) You could also have
+used prSinglePage, look at a very similar example under that function.
+
+ use PDF::Reuse;
+ use PDF::Reuse::Util;
+ use strict;
+
+ prFile('test.pdf');
+
+ my $pageNumber = 0;
+
+ for (my $page = 1; $page < 17; $page++)
+ { $pageNumber++;
+ prForm( { file =>'Words.pdf',
+ page => 5,
+ x => 150,
+ y => 150} );
+
+ prImage( { file =>'Media.pdf',
+ page => 6,
+ imageNo => 1,
+ x => 450,
+ y => 450 } );
+ blackText();
+ prText( 360, 250, $pageNumber);
+ prDoc('Battery.pdf', $pageNumber, $pageNumber);
+ }
+ prEnd;
+
+
+=head2 prDocDir - set directory for produced documents
+
+ prDocDir ( $directoryName )
+
+Sets directory for produced documents
+
+ use PDF::Reuse;
+ use strict;
+
+ prDocDir('C:/temp/doc');
+ prFile('myFile.pdf'); # writes to C:\temp\doc\myFile.pdf
+ prForm('myFile.pdf'); # page 1 from ..\myFile.pdf
+ prText(200, 600, 'New text');
+ prEnd();
+
+=head2 prDocForm - use an interactive page as a form
+
+Alternative 1) You put your parameters in an anonymous hash (only B<file> is really
+necessary, the others get default values if not given).
+
+ prDocForm ( { file => $pdfFile, # template file
+ page => $page, # page number (of imported template)
+ adjust => $adjust, # try to fill the media box
+ effect => $effect, # action to be taken
+ tolerant => $tolerant, # continue even with an invalid form
+ x => $x, # $x points from the left
+ y => $y, # $y points from the bottom
+ rotate => $degree, # rotate
+ size => $size, # multiply everything by $size
+ xsize => $xsize, # multiply horizontally by $xsize
+ ysize => $ysize } ) # multiply vertically by $ysize
+Ex.:
+ my $internalName = prDocForm ( {file => 'myFile.pdf',
+ page => 2 } );
+
+Alternative 2) You put your parameters in this order
+
+ prDocForm ( $pdfFile, [$page, $adjust, $effect, $tolerant, $x, $y, $degree,
+ $size, $xsize, $ysize] )
+
+
+Anyway the function returns in list context: B<$intName, @BoundingBox,
+$numberOfImages>, in scalar context: B<$internalName> of the form.
+
+Look at prForm() for an explanation of the parameters.
+
+N.B. Usually you shouldn't adjust or change size and proportions of an interactive
+page. The graphic and interactive components are independent of each other and there
+is a great risk that any coordination is lost.
+
+This function redefines a page to an "XObject" (the graphic parts), then the
+page can be reused in a much better way. Unfortunately there is an important
+limitation here. "XObjects" can only have single streams. If the page consists
+of many streams, you should concatenate them first. Adobe Acrobat can do that.
+(If it is an important file, take a copy of it first. Sometimes the procedure fails.)
+Open the document with Acrobat. Then choose the the "TouchUp Text" tool (icon or
+from the tools menu). Select a line of text somewhere on the page. Right-click the
+mouse. Choose "Attributes".Change font size or anything else, and then you change
+it back to the old value. Save the document.
+If there was no text on the page, use some other "Touch Up" tool.
+
+
+ use PDF::Reuse;
+ use strict;
+
+ prDocDir('C:/temp/doc');
+ prFile('newForm.pdf');
+ prField('Mr/Ms', 'Mr');
+ prField('First_Name', 'Lars');
+ prDocForm('myFile.pdf');
+ prFontSize(24);
+ prText(75, 790, 'This text is added');
+ prEnd();
+
+(You can use the output from the example in prJs() as input to this example.
+Remember to save that file before closing it.)
+
+B<See Remarks about JavaScript>
+
+=head2 prExtract - extract an object group
+
+ prExtract ( $pdfFile, $pageNo, $oldInternalName )
+
+B<oldInternalName>, a "name"-object. This is the internal name you find in the original file.
+Returns a B<$newInternalName> which can be used for "low level" programming. You
+have better look at graphObj_pl and modules it has generated for the tutorial,
+e.g. thermometer.pm, to see how this function can be used.
+
+When you call this function, the necessary objects will be copied to your new
+PDF-file, and you can refer to them with the new name you receive.
+
+
+=head2 prField - assign a value to an interactive field
+
+ prField ( $fieldName, $value )
+
+B<$fieldName> is an interactive field in the document you are creating.
+It has to be spelled exactly the same way here as it spelled in the document.
+B<$value> is what you want to assigned to the field.
+Put all your sentences with prField early in your script. After prFile and B<before>
+prDoc or prDocForm and of course before prEnd. Each sentence with prField is
+translated to JavaScript and merged with old JavaScript
+
+See prDocForm() for an example
+
+If you are going to assign a value to a field consisting of several lines, you
+can write like this:
+
+ my $string = "This is the first line \r second line \n 3:rd line";
+ prField('fieldName', $string);
+
+You can also let '$value' be a snippet of JavaScript-code that assigns something
+to the field. Then you have to put 'js:' first in "$value" like this:
+
+ my $sentence = encrypt('This will be decrypted by "unPack"(JavaScript) ');
+ prField('Interest_9', "js: unPack('$sentence')");
+
+If you refer to a JavaScript function, it has to be included with prJs first. (The
+JavaScript interpreter will simply not be aware of old functions in the PDF-document,
+when the initiation is done.)
+
+
+=head2 prFont - set current font
+
+ prFont ( $fontName )
+
+$fontName is an "external" font name. The parameter is optional.
+In list context returns B<$internalName, $externalName, $oldInternalName,
+$oldExternalname> The first two variables refer to the current font, the two later
+to the font before the change. In scalar context returns b<$internalName>
+
+If a font wasn't found, Helvetica will be set.
+These names are always recognized:
+B<Times-Roman, Times-Bold, Times-Italic, Times-BoldItalic, Courier, Courier-Bold,
+Courier-Oblique, Courier-BoldOblique, Helvetica, Helvetica-Bold, Helvetica-Oblique,
+Helvetica-BoldOblique> or abbreviated
+B<TR, TB, TI, TBI, C, CB, CO, CBO, H, HB, HO, HBO>.
+(B<Symbol and ZapfDingbats> or abbreviated B<S, Z>, also belong to the predefined
+fonts, but there is something with them that I really don't understand. You should
+print them first on a page, and then use other fonts, otherwise they are not displayed.)
+
+You can also use a font name from an included page. It has to be spelled exactly as
+it is done there. Look in the file and search for "/BaseFont" and the font
+name. But take care, e.g. the PDFMaker which converts to PDF from different
+Microsoft programs, only defines exactly those letters you can see on the page. You
+can use the font, but perhaps some of your letters were not defined.
+
+In the distribution there is an utility program, 'reuseComponent_pl', which displays
+included fonts in a PDF-file and prints some letters. Run it to see the name of the
+font and if it is worth extracting.
+
+ use PDF::Reuse;
+ use strict;
+ prFile('myFile.pdf');
+
+ ####### One possibility #########
+
+ prFont('Times-Roman'); # Just setting a font
+ prFontSize(20);
+ prText(180, 790, "This is a heading");
+
+ ####### Another possibility #######
+
+ my $font = prFont('C'); # Setting a font, getting an
+ # internal name
+ prAdd("BT /$font 12 Tf 25 760 Td (This is some other text)Tj ET");
+ prEnd();
+
+The example above shows you two ways of setting and using a font. One simple, and
+one complicated with a possibility to detail control.
+
+
+=head2 prFontSize - set current font size
+
+ prFontSize ( $size )
+
+Returns B<$actualSize, $fontSizeBeforetheChange>. Without parameters
+prFontSize() sets the size to 12 points, which is default.
+
+=head2 prForm - use a page from an old document as a form/background
+
+Alternative 1) You put your parameters in an anonymous hash (only B<file> is really
+necessary, the others get default values if not given).
+
+ prForm ( { file => $pdfFile, # template file
+ page => $page, # page number (of imported template)
+ adjust => $adjust, # try to fill the media box
+ effect => $effect, # action to be taken
+ tolerant => $tolerant, # continue even with an invalid form
+ x => $x, # $x points from the left
+ y => $y, # $y points from the bottom
+ rotate => $degree, # rotate
+ size => $size, # multiply everything by $size
+ xsize => $xsize, # multiply horizontally by $xsize
+ ysize => $ysize } ) # multiply vertically by $ysize
+Ex.:
+ my $internalName = prForm ( {file => 'myFile.pdf',
+ page => 2 } );
+
+Alternative 2) You put your parameters in this order
+
+ prForm ( $pdfFile, $page, $adjust, $effect, $tolerant, $x, $y, $degree,
+ $size, $xsize, $ysize )
+
+
+Anyway the function returns in list context: B<$intName, @BoundingBox,
+$numberOfImages>, in scalar context: B<$internalName> of the form.
+
+if B<page> is excluded 1 is assumed.
+
+B<adjust>, could be 1, 2 or 0/nothing. If it is 1, the program tries to adjust the
+form to the current media box (paper size) and keeps the proportions unchanged.
+If it is 2, the program tries to fill as much of the media box as possible, without
+regards to the original proportions.
+If this parameter is given, "x", "y", "rotate", "size", "xsize" and "ysize"
+will be ignored.
+
+B<effect> can have 3 values: B<'print'>, which is default, loads the page in an internal
+table, adds it to the document and prints it to the current page. B<'add'>, loads the
+page and adds it to the document. (Now you can "manually" manage the way you want to
+print it to different pages within the document.) B<'load'> just loads the page in an
+internal table. (You can now take I<parts> of a page like fonts and objects and manage
+them, without adding all the page to the document.)You don't get any defined
+internal name of the form, if you let this parameter be 'load'.
+
+B<tolerant> can be nothing or something. If it is undefined, you will get an error if your program tries to load
+a page which the system cannot really handle, if it e.g. consists of many streams.
+If it is set to something, you have to test the first return value $internalName to
+know if the function was successful. Look at the program 'reuseComponent_pl' for an
+example of usage.
+
+B<x> where to start along the x-axis (cannot be combined with "adjust")
+
+B<y> where to start along the y-axis (cannot be combined with "adjust")
+
+B<rotate> A degree 0-360 to rotate the form counter-clockwise. (cannot be combined
+with "adjust") Often the form disappears out of the media box if degree >= 90.
+Then you can move it back with the x and y-parameters. If degree == 90, you can
+add the width of the form to x, If degree == 180 add both width and height to x
+and y, and if degree == 270 you can add the height to y.
+
+B<rotate> can also by one of 'q1', 'q2' or 'q3'. Then the system rotates the form
+clockwise 90, 180 or 270 degrees and tries to keep the form within the media box.
+
+The rotation takes place after the form has been resized or moved.
+
+ Ex. To rotate from portrait (595 x 842 pt) to landscape (842 x 595 pt)
+
+ use PDF::Reuse;
+ use strict;
+
+ prFile('New_Report.pdf');
+ prMbox(0, 0, 842, 595);
+
+ prForm({file => 'cert1.pdf',
+ rotate => 'q1' } );
+ prEnd();
+
+The same rotation can be achieved like this:
+
+ use PDF::Reuse;
+ use strict;
+
+ prFile('New_Report.pdf');
+ prMbox(0, 0, 842, 595);
+
+ prForm({file => 'cert1.pdf',
+ rotate => 270,
+ y => 595 } );
+ prEnd();
+
+B<size> multiply every measure by this value (cannot be combined with "adjust")
+
+B<xsize> multiply horizontally by this value (cannot be combined with "adjust")
+
+B<ysize> multiply vertically by $ysize (cannot be combined with "adjust")
+
+This function redefines a page to an "XObject" (the graphic parts), then the
+page can be reused and referred to as a unit. Unfortunately there is an important
+limitation here. "XObjects" can only have single streams. If the page consists
+of many streams, you should concatenate them first. Adobe Acrobat can do that.
+(If it is an important file, take a copy of it first. Sometimes the procedure fails.)
+Open the document with Acrobat. Then choose the "TouchUp Text" tool.
+Select a line of text somewhere. Right-click the mouse. Choose "Attributes".
+Change font size or anything else, and then you change it back to the old value.
+Save the document. You could alternatively save the file as Postscript and redistill
+it with the distiller or with Ghost script, but this is a little more risky. You
+might loose fonts or something else. Another alternative could be to use prSinglePage().
+
+
+ use PDF::Reuse;
+ use strict;
+
+ prFile('myFile.pdf');
+ prForm('best.pdf'); # Takes page No 1
+ prText(75, 790, 'Dear Mr Gates');
+ # ...
+ prPage();
+ prMbox(0, 0, 900, 960);
+ my @vec = prForm( { file => 'EUSA.pdf',
+ adjust => 1 } );
+ prPage();
+ prMbox();
+ prText(35, 760, 'This is the final page');
+
+ # More text ..
+
+ #################################################################
+ # We want to put a miniature of EUSA.pdf, 35 points from the left
+ # 85 points up, and in the format 250 X 200 points
+ #################################################################
+
+ my $xScale = 250 / ($vec[3] - $vec[1]);
+ my $yScale = 200 / ($vec[4] - $vec[2]);
+
+ prForm ({ file => 'EUSA.pdf',
+ xsize => $xScale,
+ ysize => $yScale,
+ x => 35,
+ y => 85 });
+
+ prEnd();
+
+The first prForm(), in the code, is a simple and "normal" way of using the
+the function. The second time it is used, the size of the imported page is
+changed. It is adjusted to the media box which is current at that moment.
+Also data about the form is taken, so you can control more in detail how it
+will be displayed.
+
+=head2 prGetLogBuffer - get the log buffer.
+
+prGetLogBuffer ()
+
+returns a B<$buffer> of the log of the current page. (It could be used
+e.g. to calculate a MD5-digest of what has been registered that far, instead of
+accumulating the single values) A log has to be active, see prLogDir() below
+
+Look at "Using the template" and "Restoring a document from the log" in the
+tutorial for examples of usage.
+
+=head2 prGraphState - define a graphic state parameter dictionary
+
+ prGraphState ( $string )
+
+This is a "low level" function. Returns B<$internalName>. The B<$string> has to
+be a complete dictionary with initial "<<" and terminating ">>". No syntactical
+checks are made. Perhaps you will never have to use this function.
+
+ use PDF::Reuse;
+ use strict;
+
+ prFile('myFile.pdf');
+
+ ###################################################
+ # Draw a triangle with Gs0 (automatically defined)
+ ###################################################
+
+ my $str = "q\n";
+ $str .= "/Gs0 gs\n";
+ $str .= "150 700 m\n";
+ $str .= "225 800 l\n";
+ $str .= "300 700 l\n";
+ $str .= "150 700 l\n";
+ $str .= "S\n";
+ $str .= "Q\n";
+ prAdd($str);
+
+ ########################################################
+ # Define a new graph. state param. dic. and draw a new
+ # triangle further down
+ ########################################################
+
+ $str = '<</Type/ExtGState/SA false/SM 0.02/TR2 /Default'
+ . '/LW 15/LJ 1/ML 1>>';
+ my $gState = prGraphState($str);
+ $str = "q\n";
+ $str .= "/$gState gs\n";
+ $str .= "150 500 m\n";
+ $str .= "225 600 l\n";
+ $str .= "300 500 l\n";
+ $str .= "150 500 l\n";
+ $str .= "S\n";
+ $str .= "Q\n";
+ prAdd($str);
+
+ prEnd();
+
+
+=head2 prImage - reuse an image from an old PDF document
+
+Alternative 1) You put your parameters in an anonymous hash (only B<file> is really
+necessary, the others get default values if not given).
+
+ prImage( { file => $pdfFile, # template file
+ page => $page, # page number
+ imageNo => $imageNo # image number
+ adjust => $adjust, # try to fill the media box
+ effect => $effect, # action to be taken
+ x => $x, # $x points from the left
+ y => $y, # $y points from the bottom
+ rotate => $degree, # rotate
+ size => $size, # multiply everything by $size
+ xsize => $xsize, # multiply horizontally by $xsize
+ ysize => $ysize } ) # multiply vertically by $ysize
+Ex.:
+ prImage( { file => 'myFile.pdf',
+ page => 10,
+ imageNo => 2 } );
+
+Alternative 2) You put your parameters in this order
+
+ prImage ( $pdfFile, [$page, $imageNo, $effect, $adjust, $x, $y, $degree,
+ $size, $xsize, $ysize] )
+
+Returns in scalar context B<$internalName> As a list B<$internalName, $width,
+$height>
+
+Assumes that $pageNo and $imageNo are 1, if not specified. If $effect is given and
+anything else then 'print', the image will be defined in the document,
+but not shown at this moment.
+
+For all other parameters, look at prForm().
+
+ use PDF::Reuse;
+ use strict;
+
+ prFile('myFile.pdf');
+ my @vec = prImage({ file => 'best.pdf',
+ x => 10,
+ y => 400,
+ xsize => 0.9,
+ ysize => 0.8 } );
+ prText(35, 760, 'This is some text');
+ # ...
+ prPage();
+ my @vec2 = prImage( { file => 'destiny.pdf',
+ page => 1,
+ imageNo => 1,
+ effect => 'add' } );
+ prText(25, 760, "There shouldn't be any image on this page");
+ prPage();
+ ########################################################
+ # Now we make both images so that they could fit into
+ # a box 300 X 300 points, and they are displayed
+ ########################################################
+
+ prText(25, 800, 'This is the first image :');
+
+ my $xScale = 300 / $vec[1];
+ my $yScale = 300 / $vec[2];
+ if ($xScale < $yScale)
+ { $yScale = $xScale;
+ }
+ else
+ { $xScale = $yScale;
+ }
+ prImage({ file => 'best.pdf',
+ x => 25,
+ y => 450,
+ xsize => $xScale,
+ ysize => $yScale} );
+
+ prText(25, 400, 'This is the second image :');
+
+ $xScale = 300 / $vec2[1];
+ $yScale = 300 / $vec2[2];
+ if ($xScale < $yScale)
+ { $yScale = $xScale;
+ }
+ else
+ { $xScale = $yScale;
+ }
+ prImage({ file => 'destiny.pdf',
+ x => 25,
+ y => 25,
+ xsize => $xScale,
+ ysize => $yScale} );
+
+ prEnd();
+
+On the first page an image is displayed in a simple way. While the second page
+is processed, prImage(), loads an image, but it is not shown here. On the 3:rd
+page, the two images are scaled and shown.
+
+In the distribution there is an utility program, 'reuseComponent_pl', which displays
+included images in a PDF-file and their "names".
+
+=head2 prInit - add JavaScript to be executed at initiation
+
+ prInit ( $string, $duplicateCode )
+
+B<$string> can be any JavaScript code, but you can only refer to functions included
+with prJs. The JavaScript interpreter will not know other functions in the document.
+Often you can add new things, but you can't remove or change interactive fields,
+because the interpreter hasn't come that far, when initiation is done.
+
+B<$duplicateCode> is undefined or anything. It duplicates the JavaScript code
+which has been used at initiation, so you can look at it from within Acrobat and
+debug it. It makes the document bigger. This parameter is B<deprecated>.
+
+ use PDF::Reuse;
+ use strict;
+
+ prFile('myFile.pdf');
+ prInit('app.alert("This is displayed when opening the document");');
+
+ prEnd();
+
+
+Remark: Avoid to use "return" in the code you use at initiation. If your user has
+downloaded a page with Web Capture, and after that opens a PDF-document where a
+JavaScript is run at initiation and that JavaScript contains a return-statement,
+a bug occurs. The JavaScript interpreter "exits" instead of returning, the execution
+of the JavaScript might finish to early. This is a bug in Acrobat/Reader 5.
+
+
+=head2 prInitVars - initiate global variables and internal tables
+
+ prInitVars(1)
+
+If you run programs with PDF::Reuse as persistent procedures, you probably need to
+initiate global variables. If you have '1' or anything as parameter, internal tables for forms, images, fonts
+and interactive functions are B<not> initiated. The module "learns" offset and sizes of
+used objects, and can process them faster, but at the same time the size of the
+program grows.
+
+ use PDF::Reuse;
+ use strict;
+ prInitVars(); # To initiate ALL global variables and tables
+ # prInitVars(1); # To make it faster, but more memory consuming
+
+ $| = 1;
+ print STDOUT "Content-Type: application/pdf \n\n";
+
+ prFile(); # To send the document uncatalogued to STDOUT
+
+ prForm('best.pdf');
+ prText(25, 790, 'Dear Mr. Anders Persson');
+ # ...
+ prEnd();
+
+If you call this function without parameters all global variables, including the
+internal tables, are initiated.
+
+
+=head2 prAltJpeg - import a low-res jpeg-image for display and a high-res jpeg-image for printing
+
+ prAltJpeg ( $imageData, $width, $height, $format, $altImageData, $altWidth, $altHeight, $altFormat )
+
+B<$imageData> contains 1 single jpeg-image. B<$width> and B<$height>
+also have to be specified. B<$format> indicates the format the image
+data takes: 0 for file, 1 for binary string. B<$altImageData> etc.
+follows the same foramt. Returns the B<$internalName>
+
+ use PDF::Reuse;
+ use Image::Info qw(image_info dim);
+ use strict;
+
+ my $file = 'myImage.jpg';
+ my $info = image_info($file);
+ my ($width, $height) = dim($info); # Get the dimensions
+ my $colortype = $info->{color_type}; # get color space
+
+ my $alt_file = 'myImage.jpg';
+ my $alt_info = image_info($alt_file);
+ my ($alt_width, $alt_height) = dim($alt_info);
+
+ prFile('myFile.pdf');
+ my $intName = prAltJpeg("$file", # Define the image
+ $width, # in the document
+ $height,
+ 0,
+ "$alt_file",
+ $alt_width,
+ $alt_height,
+ 0);
+
+ my $str = "q\n";
+ $str .= "$width 0 0 $height 10 10 cm\n";
+ $str .= "/$intName Do\n";
+ $str .= "Q\n";
+ prAdd($str);
+ prEnd();
+
+
+=head2 prJpeg - import a jpeg-image
+
+ prJpeg ( $imageData, $width, $height, $format )
+
+B<$imageData> contains 1 single jpeg-image. B<$width> and B<$height>
+also have to be specified. B<$format> indicates the format the image
+data takes: 0 for file, 1 for binary string. Returns the B<$internalName>
+
+ use PDF::Reuse;
+ use Image::Info qw(image_info dim);
+ use strict;
+
+ my $file = 'myImage.jpg';
+ my $info = image_info($file);
+ my ($width, $height) = dim($info); # Get the dimensions
+
+ prFile('myFile.pdf');
+ my $intName = prJpeg("$file", # Define the image
+ $width, # in the document
+ $height,
+ 0);
+
+ my $str = "q\n";
+ $str .= "$width 0 0 $height 10 10 cm\n";
+ $str .= "/$intName Do\n";
+ $str .= "Q\n";
+ prAdd($str);
+ prEnd();
+
+This is a little like an extra or reserve routine to add images to the document.
+The most simple way is to use prImage()
+
+=head2 prJs - add JavaScript
+
+ prJs ( $string|$fileName )
+
+To add JavaScript to your new document. B<$string> has to consist only of
+JavaScript functions: function a (..){ ... } function b (..) { ...} and so on
+If B<$string> doesn't contain '{', B<$string> is interpreted as a filename.
+In that case the file has to consist only of JavaScript functions.
+
+B<See "Remarks about JavaScript">
+
+=head2 prLink - add a hyper link
+
+ prLink( { page => $pageNo, # Starting with 1 !
+ x => $x,
+ y => $y,
+ width => $width,
+ height => $height,
+ URI => $URI } );
+
+You can also call prLink like this:
+
+ prLink($page, $x, $y, $width, $height, $URI);
+
+You have to put prLink B<after prFile and before the sentences where its' page
+is created>. The links are created at the page-breaks. If the page is already
+created, no new link will be inserted.
+
+Here is an example where the links of a 4 page document are preserved, and a link is
+added at the end of the document. We assume that there is some suitable text at that
+place (x = 400, y = 350):
+
+ use strict;
+ use PDF::Reuse;
+
+ prFile('test.pdf');
+
+ prLink( {page => 4,
+ x => 400,
+ y => 350,
+ width => 105,
+ height => 15,
+ URI => 'http://www.purelyInvented.com/info.html' } );
+
+ prDoc('fourPages.pdf');
+
+ prEnd();
+
+( If you are creating each page of a document separately, you can also use 'hyperLink'
+from PDF::Reuse::Util. Then you get an external text in Helvetica-Oblique, underlined
+and in blue.
+
+ use strict;
+ use PDF::Reuse;
+ use PDF::Reuse::Util;
+
+ prFile('test.pdf');
+ prForm('template.pdf', 5);
+ my ($from, $pos) = prText(25, 700, 'To get more information ');
+
+ $pos = hyperLink( $pos, 700, 'Press this link',
+ 'http://www.purelyInvented.com/info.html' );
+ ($from, $pos) = prText( $pos, 700, ' And get connected');
+ prEnd();
+
+'hyperLink' has a few parameters: $x, $y, $textToBeShown, $hyperLink and
+$fontSize (not shown in the example). It returns current x-position. )
+
+=head2 prLog - add a string to the log
+
+ prLog ( $string )
+
+Adds whatever you want to the current log (a reference No, a commentary, a tag ?)
+A log has to be active see prLogDir()
+
+Look at "Using the template" and "Restoring the document from the log" in
+the tutorial for an example.
+
+=head2 prLogDir - set directory for the log
+
+ prLogDir ( $directory )
+
+Sets a directory for the logs and activates the logging.
+A little log file is created for each PDF-file. Normally it should be much, much
+more compact then the PDF-file, and it should be possible to restore or verify
+a document with the help of it. (Of course you could compress or store the logs in a
+database to save even more space.)
+
+ use PDF::Reuse;
+ use strict;
+
+ prDocDir('C:/temp/doc');
+ prLogDir('C:/run');
+
+ prFile('myFile.pdf');
+ prForm('best.pdf');
+ prText(25, 790, 'Dear Mr. Anders Persson');
+ # ...
+ prEnd();
+
+In this example a log file with the name 'myFile.pdf.dat' is created in the
+directory 'C:\run'. If that directory doesn't exist, the system tries to create it.
+(But, just as mkdir does, it only creates the last level in a directory tree.)
+
+=head2 prMbox - define the format (MediaBox) for a new page.
+
+ prMbox ( $lowerLeftX, $lowerLeftY, $upperRightX, $upperRightY )
+
+If the function or the parameters are missing, they are set to 0, 0, 595, 842 points respectively.
+Only for new pages. Pages created with prDoc and prSinglePage keep their media boxes unchanged.
+
+See prForm() for an example.
+
+
+=head2 prPage - create/insert a page
+
+ prPage ($noLog)
+
+Don't use the optional parameter, it is only used internally, not to clutter the log,
+when automatic page breaks are made.
+
+
+See prForm() for an example.
+
+=head2 prSinglePage - take single pages, one by one, from an old document
+
+ prSinglePage($file, $pageNumber)
+
+$pageNumber is optional. If not given, next page is assumed
+Returns number of remaining pages.
+This function is a variant of prDoc for single pages, with the addition that it
+has a counter of last page read, and total number of pages of the old document,
+so it can be used to loop through a document.
+
+
+To add a form, image and page number to each page of a document
+(The document Battery.pdf is cropped so each page is fairly small) You could also have
+used prDoc, but only if you knew in advance the number of pages of the old document
+
+ use PDF::Reuse;
+ use PDF::Reuse::Util;
+ use strict;
+
+ prFile('test.pdf');
+
+ my $pageNumber = 0;
+ my $left = 1; # Every valid PDF-document has at least 1 page,
+ # so that can be assumed
+
+ while ($left)
+ { $pageNumber++;
+ prForm( { file =>'Words.pdf',
+ page => 5,
+ x => 150,
+ y => 150} );
+
+ prImage( { file =>'Media.pdf',
+ page => 6,
+ imageNo => 1,
+ x => 450,
+ y => 450 } );
+ blackText();
+ prText( 360, 250, $pageNumber);
+ $left = prSinglePage('Battery.pdf');
+ }
+
+ prEnd;
+
+prSinglePage creates a new page from an old document and adds new content (to the array of
+streams of that page). Most often you can add new contents to the page like the example above,
+and it works fine, but sometimes you get surprises. There can e.g. be instructions in the earlier
+contents to make filling color white, and then you will probably not see added new text. That
+is why PDF::Reuse::Util::blackText() is used in the example. There can be other instructions
+like moving or rotating the user space. Also new contents can end up outside the crop-box.
+Of course all new programs should be tested. If prSinglePage can't be used, try to use prForm
+followed by prPage instead.
+
+
+=head2 prStrWidth - calculate the string width
+
+ prStrWidth($string, $font, $fontSize)
+
+Returns string width in points.
+Should be used in conjunction with one of these predefined fonts of Acrobat/Reader:
+Times-Roman, Times-Bold, Times-Italic, Times-BoldItalic, Courier, Courier-Bold, Courier-Oblique,
+Courier-BoldOblique, Helvetica, Helvetica-Bold, Helvetica-Oblique,
+Helvetica-BoldOblique or with a TrueType font embedded with prTTFont. If some other font is
+given, Helvetica is used, and the returned value will at the best be approximate.
+
+=head2 prText - add a text-string
+
+ prText ( $x, $y, $string, $align, $rotation )
+
+Puts B<$string> at position B<$x, $y>
+Returns 1 in scalar context. Returns ($xFrom, $xTo) in list context. $xTo will not
+be defined together with a rotation. prStrWidth() is used to calculate the length of the
+strings, so only the predefined fonts together with Acrobat/Reader, or embedded TrueType
+fonts will give reliable values for $xTo.
+
+$align can be 'left' (= default), 'center' or 'right'. The parameter is optional.
+
+$rotation can be a degree 0 - 360, 'q1', 'q2' or 'q3'. Also optional.
+
+Current font and font size are used. (If you use prAdd() before this function,
+many other things could also influence the text.)
+
+ use strict;
+ use PDF::Reuse;
+
+ prFile('test.pdf');
+
+ #####################################
+ # Use a "curser" ($pos) along a line
+ #####################################
+
+ my ($from, $pos) = prText(25, 800, 'First write this. ');
+ ($from, $pos) = prText($pos, 800, 'Then write this. ');
+ prText($pos, 800, 'Finally write this.');
+
+ #####################################
+ # Right adjust and center sentences
+ #####################################
+
+ prText( 200, 750, 'A short sentence', 'right');
+ prText( 200, 735, 'This is a longer sentence', 'right');
+ prText( 200, 720, 'A word', 'right');
+
+ prText( 200, 705, 'Centered around a point 200 points from the left', 'center');
+ prText( 200, 690, 'The same center', 'center');
+ prText( 200, 675, '->.<-', 'center');
+
+ ############
+ # Rotation
+ ############
+
+ prText( 200, 550, ' Rotate 0 degrees','', 0);
+ prText( 200, 550, ' Rotate 60 degrees','', 60);
+ prText( 200, 550, ' Rotate 120 degrees','', 120);
+ prText( 200, 550, ' Rotate 180 degrees','', 180);
+ prText( 200, 550, ' Rotate 240 degrees','', 240);
+ prText( 200, 550, ' Rotate 300 degrees','', 300);
+
+ prText( 400, 430, 'Rotate 90 degrees clock-wise','','q1');
+ prText( 400, 430, 'Rotate 180 degrees clock-wise','', 'q2');
+ prText( 400, 430, 'Rotate 270 degrees clock-wise','', 'q3');
+
+ ##########################
+ # Rotate and right adjust
+ ##########################
+
+ prText( 200, 230, 'Rotate 90 degrees clock-wise ra->','right','q1');
+ prText( 200, 230, 'Rotate 180 degrees clock-wise ra->','right', 'q2');
+ prText( 200, 230, 'Rotate 270 degrees clock-wise ra->','right', 'q3');
+
+ prEnd();
+
+=head2 prTTFont - select and embed a TrueType font
+
+ prTTFont ( "/path/to/font/file.ttf" )
+
+This function is equivalent to C<prFont> except that rather than restricting
+you to the list of core built-in fonts, it allows you to select an external
+TrueType font file and have it embedded in your PDF document. Using TrueType
+fonts also enables the C<prText> function to accept UTF-8 strings, which allows
+you to use characters outside the Mac-Roman/Win-ANSI character sets used by the
+built-in fonts.
+
+You can specify the same font path multiple times in one document and only one
+copy will be embedded. Alternatively, C<prTTFont> returns an identifier which
+can be used to select the same font again:
+
+ my $arial = prTTFont('/path/to/Arial.ttf');
+ prFontSize(20);
+ prText(20, 700, 'Some text in Arial');
+ #
+ # ... later ...
+ #
+ prPage();
+ prTTFont($arial);
+ prFontSize(12);
+ prText(20, 700, 'Some more text in Arial');
+ #
+ # to pass a UTF8 string to prText
+ #
+ prText(20, 675, "T\x{113}n\x{101} koutou"); # T?n? Koutou
+
+In list context this function returns C<$internalName>, C<$externalName>,
+C<$oldInternalName>, C<$oldExternalname>. The first two variables refer to the
+current font, the last two refer to the font before the change. In scalar
+context only C<$internalName> is returned.
+
+Note: To use this function, you must have the L<Font::TTF> and L<Text::PDF>
+modules installed.
+
+
+=head1 INTERNAL OR DEPRECATED FUNCTIONS
+
+=over 2
+
+=item prBar - define and paint bars for bar fonts
+
+ prBar ($x, $y, $string)
+
+Prints a bar font pattern at the current page.
+Returns $internalName for the font.
+$x and $y are coordinates in points and $string should consist of the characters
+'0', '1' and '2' (or 'G'). '0' is a white bar, '1' is a dark bar. '2' and 'G' are
+dark, slightly longer bars, guard bars.
+You can use e.g. GD::Barcode or one module in that group to calculate the bar code
+pattern. prBar "translates" the pattern to white and black bars.
+
+ use PDF::Reuse;
+ use GD::Barcode::Code39;
+ use strict;
+
+ prFile('myFile.pdf');
+ my $oGdB = GD::Barcode::Code39->new('JOHN DOE');
+ my $sPtn = $oGdB->barcode();
+ prBar(100, 600, $sPtn);
+ prEnd();
+
+Internally the module uses a font for the bars, so you might want to change the font size before calling
+this function. In that case, use prFontSize() .
+If you call this function without arguments it defines the bar font but does
+not write anything to the current page.
+
+B<An easier and often better way to produce bar codes is to use PDF::Reuse::Barcode.>
+Look at that module!
+
+=item prCid - define time stamp/check id
+
+ prCid ( $timeStamp )
+
+An internal function. Don't bother about it. It is used in automatic
+routines when you want to restore a document. It gives modification time of
+the next PDF-file or JavaScript.
+See "Restoring a document from the log" in the tutorial for more about the
+time stamp
+
+
+
+=item prId - define id-string of a PDF document
+
+ prId ( $string )
+
+An internal function. Don't bother about it. It is used e.g. when a document is
+restored and an id has to be set, not calculated.
+
+=item prIdType - define id-type
+
+ prIdType ( $string )
+
+An internal function. Avoid using it. B<$string> could be "Rep" for replace or
+"None" to avoid calculating an id.
+
+Normally you don't use this function. Then an id is calculated with the help of
+Digest::MD5::md5_hex and some data from the run.
+
+
+=item prTouchUp - make changes and reuse more difficult
+
+ prTouchUp (1);
+
+By default and after you have issued prTouchUp(1), you can change the document
+with the TouchUp tool from within Acrobat.
+If you want to switch off this possibility, you use prTouchUp() without any
+parameter. Then the user shouldn't be able to change anything graphic by mistake.
+He has to do something premeditated and perhaps with a little effort.
+He could still save it as Postscript and redistill, or he could remove or add single pages.
+(Here is a strong reason why the log files, and perhaps also check sums, are needed.
+It would be very difficult to forge a document unless the forger also has access to your
+computer and knows how the check sums are calculated.)
+
+B<Avoid to switch off the TouchUp tool for your templates.> It creates an
+extra level within the PDF-documents . Use this function for your final documents.
+
+See "Using the template" in the tutorial for an example.
+
+This function works for pages created with prPage, but mot with prDoc and prSinglePage,
+So it is more or less deprecated as these function have developed.
+
+(To encrypt your documents: use the batch utility within Acrobat)
+
+
+=item prVers - check version of log and program
+
+ prVers ( $versionNo )
+
+To check version of this module in case a document has to be
+restored.
+
+=back
+
+=head1 SEE ALSO
+
+ PDF::Reuse::Tutorial
+ PDF::Reuse::Barcode
+ PDF::Reuse::OverlayChart
+
+To program with PDF-operators, look at "The PDF-reference Manual" which probably
+is possible to download from http://partners.adobe.com/asn/tech/pdf/specifications.jsp
+Look especially at chapter 4 and 5, Graphics and Text, and the Operator summary.
+
+Technical Note # 5186 contains the "Acrobat JavaScript Object Specification". I
+downloaded it from http://partners.adobe.com/asn/developer/technotes/acrobatpdf.html
+
+If you are serious about producing PDF-files, you probably need Adobe Acrobat sooner
+or later. It has a price tag. Other good programs are GhostScript and GSview.
+I got them via http://www.cs.wisc.edu/~ghost/index.html Sometimes they can replace Acrobat.
+A nice little detail is e.g. that GSview shows the x- and y-coordinates better then Acrobat. If you need to convert HTML-files to PDF, HTMLDOC is a possible tool. Download it from
+http://www.easysw.com . A simple tool for vector graphics is Mayura Draw 2.04, download
+it from http://www.mayura.com. It is free. I have used it to produce the graphic
+OO-code in the tutorial. It produces postscript which the Acrobat Distiller (you get it together with Acrobat)
+or Ghostscript can convert to PDF.(The commercial product, Mayura Draw 4.01 or something
+higher can produce PDF-files straight away)
+
+If you want to import jpeg-images, you might need
+
+ Image::Info
+
+To get definitions for e.g. colors, take them from
+
+ PDF::API2::Util
+
+=head1 LIMITATIONS
+
+Meta data, info and many other features of the PDF-format have not been
+implemented in this module.
+
+Many things can be added afterwards, after creating the files. If you e.g. need
+files to be encrypted, you can use a standard batch routine within Adobe Acrobat.
+
+=head1 THANKS TO
+
+Martin Langhoff, Matisse Enzer, Yunliang Yu and others who have contributed with code, suggestions and error
+reports.
+
+Grant McLean has implemented font embedding by grafting Font::TTF and
+Text::PDF::TTFont0 onto the PDF::Reuse API. He has written the embedded packages PDF::Reuse::DocProxy
+and PDF::Reuse::TTFont.
+
+The functionality of prDoc and prSinglePage to include new contents was developed for a
+specific task with support from the Electoral Enrolment Centre, Wellington, New Zealand
+
+=head1 MAILING LIST
+
+ http://groups.google.com/group/PDF-Reuse
+
+=head1 AUTHOR
+
+Lars Lundberg larslund@cpan.org
+Chris Nighswonger cnighs@cpan.org
+
+=head1 COPYRIGHT
+
+Copyright (C) 2003 - 2004 Lars Lundberg, Solidez HB.
+Copyright (C) 2005 Karin Lundberg.
+Copyright (C) 2006 - 2010 Lars Lundberg, Solidez HB.
+Copyright (C) 2010 - 2014 Chris Nighswonger
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 DISCLAIMER
+
+You get this module free as it is, but nothing is guaranteed to work, whatever
+implicitly or explicitly stated in this document, and everything you do,
+you do at your own risk - I will not take responsibility
+for any damage, loss of money and/or health that may arise from the use of this module.
+
+=cut
+
+sub prSinglePage
+{ my $infil = shift;
+ my $pageNumber = shift;
+
+ if (! defined $pageNumber)
+ { $behandlad{$infil}->{pageNumber} = 0
+ unless (defined $behandlad{$infil}->{pageNumber});
+ $pageNumber = $behandlad{$infil}->{pageNumber} + 1;
+ }
+
+ my ($sida, $Names, $AARoot, $AcroForm) = analysera($infil, $pageNumber, $pageNumber, 1);
+ if (($Names) || ($AARoot) || ($AcroForm))
+ { $NamesSaved = $Names;
+ $AARootSaved = $AARoot;
+ $AcroFormSaved = $AcroForm;
+ $interActive = 1;
+ }
+ if (defined $sida)
+ { $behandlad{$infil}->{pageNumber} = $pageNumber;
+ }
+ if ($runfil)
+ { $infil = prep($infil);
+ $log .= "prSinglePage~$infil~$pageNumber\n";
+ }
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+ return $sida;
+
+}
+
+
+
+sub prLink
+{ my %link;
+ my $param = shift;
+ if (ref($param) eq 'HASH')
+ { $link{page} = $param->{'page'} || -1;
+ $link{x} = $param->{'x'} || 100;
+ $link{y} = $param->{'y'} || 100;
+ $link{width} = $param->{width} || 75;
+ $link{height} = $param->{height} || 15;
+ $link{v} = $param->{URI};
+ $link{s} = $param->{s} || "URI";
+ }
+ else
+ { $link{page} = $param || -1;
+ $link{x} = shift || 100;
+ $link{y} = shift || 100;
+ $link{width} = shift || 75;
+ $link{height} = shift || 15;
+ $link{v} = shift;
+ $link{s} = shift || "URI";
+ }
+
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+
+ if ($runfil)
+ { $log .= "Link~$link{page}~$link{x}~$link{y}~$link{width}~"
+ . "$link{height}~$link{v}~$link{s}\n";
+ }
+
+ if ($link{v})
+ { push @{$links{$link{page}}}, \%link;
+ }
+ 1;
+}
+
+sub mergeLinks
+{ my $tSida = $sida + 1;
+ my $rad;
+ my ($linkObject, $linkObjectNo);
+ for my $link (@{$links{'-1'}}, @{$links{$tSida}} )
+ { my $x2 = $link->{x} + $link->{width};
+ my $y2 = $link->{y} + $link->{height};
+ if (exists $links{$link->{v}})
+ { $linkObjectNo = $links{$link->{v}};
+ }
+ else
+ { $objNr++;
+ $objekt[$objNr] = $pos;
+ my $v_n;
+ my $v_v = '('.$link->{v}.')';
+ if ($link->{s} eq 'GoTo')
+ { $v_n = "D";
+ }
+ elsif ($link->{s} eq 'GoToA')
+ { $link->{s} = 'GoTo';
+ $v_n = 'D';
+ $v_v = $link->{v};
+ }
+ elsif ($link->{s} eq 'Launch') {$v_n = 'F';}
+ elsif ($link->{s} eq 'SubmitForm') {$v_n = 'F';}
+ elsif ($link->{s} eq 'Named')
+ { $v_n = 'N';
+ $v_v = $link->{v};
+ }
+ elsif ($link->{s} eq 'JavaScript') {$v_n = "JS";}
+ else
+ { $v_n = $link->{s};
+ }
+ $rad = "$objNr 0 obj<</S/$link->{s}/$v_n$v_v>>endobj\n";
+ $linkObjectNo = $objNr;
+ $links{$link->{v}} = $objNr;
+ $pos += syswrite UTFIL, $rad;
+ }
+ $rad = "/Subtype/Link/Rect[$link->{x} $link->{y} "
+ . "$x2 $y2]/A $linkObjectNo 0 R/Border[0 0 0]";
+ if (exists $links{$rad})
+ { push @annots, $links{$rad};
+ }
+ else
+ { $objNr++;
+ $objekt[$objNr] = $pos;
+ $links{$rad} = $objNr;
+ $rad = "$objNr 0 obj<<$rad>>endobj\n";
+ $pos += syswrite UTFIL, $rad;
+ push @annots, $objNr;
+ }
+ }
+ @{$links{'-1'}} = ();
+ @{$links{$tSida}} = ();
+ $objNr++;
+ $objekt[$objNr] = $pos;
+ $rad = "$objNr 0 obj[\n";
+ for (@annots)
+ { $rad .= "$_ 0 R\n";
+ }
+ $rad .= "]endobj\n";
+ $pos += syswrite UTFIL, $rad;
+ @annots = ();
+ return $objNr;
+}
+
+
+sub prBookmark
+{ my $param = shift;
+ if (! ref($param))
+ { $param = eval ($param);
+ }
+ if (! ref($param))
+ { return undef;
+ }
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+ if (ref($param) eq 'HASH')
+ { push @bookmarks, $param;
+ }
+ else
+ { push @bookmarks, (@$param);
+ }
+ if ($runfil)
+ { local $Data::Dumper::Indent = 0;
+ $param = Dumper($param);
+ $param =~ s/^\$VAR1 = //;
+ $param = prep($param);
+ $log .= "Bookmark~$param\n";
+ }
+ return 1;
+}
+
+sub ordnaBookmarks
+{ my ($first, $last, $me, $entry, $rad);
+ $totalCount = 0;
+ if (defined $objekt[$objNr])
+ { $objNr++;
+ }
+ $me = $objNr;
+
+ my $number = $#bookmarks;
+ for (my $i = 0; $i <= $number ; $i++)
+ { my %hash = %{$bookmarks[$i]};
+ $objNr++;
+ $hash{'this'} = $objNr;
+ if ($i == 0)
+ { $first = $objNr;
+ }
+ if ($i == $number)
+ { $last = $objNr;
+ }
+ if ($i < $number)
+ { $hash{'next'} = $objNr + 1;
+ }
+ if ($i > 0)
+ { $hash{'previous'} = $objNr - 1;
+ }
+ $bookmarks[$i] = \%hash;
+ }
+
+ for $entry (@bookmarks)
+ { my %hash = %{$entry};
+ descend ($me, %hash);
+ }
+
+ $objekt[$me] = $pos;
+
+ $rad = "$me 0 obj<<";
+ $rad .= "/Type/Outlines";
+ $rad .= "/Count $totalCount";
+ if (defined $first)
+ { $rad .= "/First $first 0 R";
+ }
+ if (defined $last)
+ { $rad .= "/Last $last 0 R";
+ }
+ $rad .= ">>endobj\n";
+ $pos += syswrite UTFIL, $rad;
+
+ return $me;
+
+}
+
+sub descend
+{ my ($parent, %entry) = @_;
+ my ($first, $last, $count, $me, $rad, $jsObj);
+ if (! exists $entry{'close'})
+ { $totalCount++; }
+ $count = $totalCount;
+ $me = $entry{'this'};
+ if (exists $entry{'kids'})
+ { if (ref($entry{'kids'}) eq 'ARRAY')
+ { my @array = @{$entry{'kids'}};
+ my $number = $#array;
+ for (my $i = 0; $i <= $number ; $i++)
+ { $objNr++;
+ $array[$i]->{'this'} = $objNr;
+ if ($i == 0)
+ { $first = $objNr;
+ }
+ if ($i == $number)
+ { $last = $objNr;
+ }
+
+ if ($i < $number)
+ { $array[$i]->{'next'} = $objNr + 1;
+ }
+ if ($i > 0)
+ { $array[$i]->{'previous'} = $objNr - 1;
+ }
+ if (exists $entry{'close'})
+ { $array[$i]->{'close'} = 1;
+ }
+ }
+
+ for my $element (@array)
+ { descend($me, %{$element})
+ }
+ }
+ else # a hash
+ { my %hash = %{$entry{'kids'}};
+ $objNr++;
+ $hash{'this'} = $objNr;
+ $first = $objNr;
+ $last = $objNr;
+ descend($me, %hash)
+ }
+ }
+
+
+ $objekt[$me] = $pos;
+ $rad = "$me 0 obj<<";
+ if (exists $entry{'text'})
+ { $rad .= "/Title ($entry{'text'})";
+ }
+ $rad .= "/Parent $parent 0 R";
+ if (defined $jsObj)
+ { $rad .= "/A $jsObj 0 R";
+ }
+ if (exists $entry{'act'})
+ { my $code = $entry{'act'};
+ if ($code =~ m/(\d+)/os)
+ {
+ $code = $1;
+ }
+ $rad .= "/Dest [$code /XYZ null null null] ";
+ }
+ if (exists $entry{'previous'})
+ { $rad .= "/Prev $entry{'previous'} 0 R";
+ }
+ if (exists $entry{'next'})
+ { $rad .= "/Next $entry{'next'} 0 R";
+ }
+ if (defined $first)
+ { $rad .= "/First $first 0 R";
+ }
+ if (defined $last)
+ { $rad .= "/Last $last 0 R";
+ }
+ if ($count != $totalCount)
+ { $count = $totalCount - $count;
+ $rad .= "/Count $count";
+ }
+ if (exists $entry{'color'})
+ { $rad .= "/C [$entry{'color'}]";
+ }
+ if (exists $entry{'style'})
+ { $rad .= "/F $entry{'style'}";
+ }
+
+ $rad .= ">>endobj\n";
+ $pos += syswrite UTFIL, $rad;
+}
+
+sub prInitVars
+{ my $exit = shift;
+ $genLowerX = 0;
+ $genLowerY = 0;
+ $genUpperX = 595,
+ $genUpperY = 842;
+ $fontSize = 12;
+ ($utfil, $slutNod, $formCont, $imSeq,
+ $page, $sidObjNr, $interActive, $NamesSaved, $AARootSaved, $AAPageSaved,
+ $root, $AcroFormSaved, $id, $ldir, $checkId, $formNr, $imageNr,
+ $filnamn, $interAktivSida, $taInterAkt, $type, $runfil, $checkCs,
+ $confuseObj, $compress,$pos, $fontNr, $objNr,
+ $defGState, $gSNr, $pattern, $shading, $colorSpace) = '';
+
+ (@kids, @counts, @formBox, @objekt, @parents, @aktuellFont, @skapa,
+ @jsfiler, @inits, @bookmarks, @annots) = ();
+
+ ( %resurser, %objRef, %nyaFunk,%oldObject, %unZipped,
+ %sidFont, %sidXObject, %sidExtGState, %font, %fields, %script,
+ %initScript, %sidPattern, %sidShading, %sidColorSpace, %knownToFile,
+ %processed, %dummy) = ();
+
+ $stream = '';
+ $idTyp = '';
+ $ddir = '';
+ $log = '';
+
+ if ($exit)
+ { return 1;
+ }
+
+ ( %form, %image, %fontSource, %intAct) = ();
+
+ return 1;
+}
+
+####################
+# Behandla en bild
+####################
+
+sub prImage
+{ my $param = shift;
+ my ($infil, $sidnr, $bildnr, $effect, $adjust, $x, $y, $size, $xsize,
+ $ysize, $rotate);
+
+ if (ref($param) eq 'HASH')
+ { $infil = $param->{'file'};
+ $sidnr = $param->{'page'} || 1;
+ $bildnr = $param->{'imageNo'} || 1;
+ $effect = $param->{'effect'} || 'print';
+ $adjust = $param->{'adjust'} || '';
+ $x = $param->{'x'} || 0;
+ $y = $param->{'y'} || 0;
+ $rotate = $param->{'rotate'} || 0;
+ $size = $param->{'size'} || 1;
+ $xsize = $param->{'xsize'} || 1;
+ $ysize = $param->{'ysize'} || 1;
+ }
+ else
+ { $infil = $param;
+ $sidnr = shift || 1;
+ $bildnr = shift || 1;
+ $effect = shift || 'print';
+ $adjust = shift || '';
+ $x = shift || 0;
+ $y = shift || 0;
+ $rotate = shift || 0;
+ $size = shift || 1;
+ $xsize = shift || 1;
+ $ysize = shift || 1;
+ }
+
+ my ($refNr, $inamn, $bildIndex, $xc, $yc, $xs, $ys);
+ $type = 'image';
+
+ $bildIndex = $bildnr - 1;
+ my $fSource = $infil . '_' . $sidnr;
+ my $iSource = $fSource . '_' . $bildnr;
+ if (! exists $image{$iSource})
+ { $imageNr++;
+ $inamn = 'Ig' . $imageNr;
+ $knownToFile{'Ig:' . $iSource} = $inamn;
+ $image{$iSource}[imXPOS] = 0;
+ $image{$iSource}[imYPOS] = 0;
+ $image{$iSource}[imXSCALE] = 1;
+ $image{$iSource}[imYSCALE] = 1;
+ if (! exists $form{$fSource} )
+ { $refNr = getPage($infil, $sidnr, '');
+ if ($refNr)
+ { $formNr++;
+ my $namn = 'Fm' . $formNr;
+ $knownToFile{$fSource} = $namn;
+ }
+ elsif ((defined $refNr) && ($refNr eq '0'))
+ { errLog("File: $infil Page: $sidnr can't be found");
+ }
+ }
+ my $in = $form{$fSource}[fIMAGES][$bildIndex];
+ $image{$iSource}[imWIDTH] = $form{$fSource}->[fOBJ]->{$in}->[oWIDTH];
+ $image{$iSource}[imHEIGHT] = $form{$fSource}->[fOBJ]->{$in}->[oHEIGHT];
+ $image{$iSource}[imIMAGENO] = $form{$fSource}[fIMAGES][$bildIndex];
+ }
+ if (exists $knownToFile{'Ig:' . $iSource})
+ { $inamn = $knownToFile{'Ig:' . $iSource};
+ }
+ else
+ { $imageNr++;
+ $inamn = 'Ig' . $imageNr;
+ $knownToFile{'Ig:' . $iSource} = $inamn;
+ }
+ if (! exists $objRef{$inamn})
+ { $refNr = getImage($infil, $sidnr,
+ $bildnr, $image{$iSource}[imIMAGENO]);
+ $objRef{$inamn} = $refNr;
+ }
+ else
+ { $refNr = $objRef{$inamn};
+ }
+
+ my @iData = @{$image{$iSource}};
+
+ if (($effect eq 'print') && ($refNr))
+ { if (! defined $defGState)
+ { prDefaultGrState();}
+ $stream .= "\n/Gs0 gs\n";
+ $stream .= "q\n";
+
+ if ($adjust)
+ { $stream .= fillTheForm(0, 0, $iData[imWIDTH], $iData[imHEIGHT],$adjust);
+ }
+ else
+ { my $tX = ($x + $iData[imXPOS]);
+ my $tY = ($y + $iData[imYPOS]);
+ $stream .= calcMatrix($tX, $tY, $rotate, $size,
+ $xsize, $ysize, $iData[imWIDTH], $iData[imHEIGHT]);
+ }
+ $stream .= "$iData[imWIDTH] 0 0 $iData[imHEIGHT] 0 0 cm\n";
+ $stream .= "/$inamn Do\n";
+ $sidXObject{$inamn} = $refNr;
+ $stream .= "Q\n";
+ $sidExtGState{'Gs0'} = $defGState;
+ }
+ if ($runfil)
+ { $infil = prep($infil);
+ $log .= "Image~$infil~$sidnr~$bildnr~$effect~$adjust";
+ $log .= "$x~$y~$size~$xsize~$ysize~$rotate\n";
+ }
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+
+ if (wantarray)
+ { return ($inamn, $iData[imWIDTH], $iData[imHEIGHT]);
+ }
+ else
+ { return $inamn;
+ }
+}
+
+
+
+sub prMbox
+{ my $lx = defined($_[0]) ? shift : 0;
+ my $ly = defined($_[0]) ? shift : 0;
+ my $ux = defined($_[0]) ? shift : 595;
+ my $uy = defined($_[0]) ? shift : 842;
+
+ if ((defined $lx) && ($lx =~ m'^[\d\-\.]+$'o))
+ { $genLowerX = $lx; }
+ if ((defined $ly) && ($ly =~ m'^[\d\-\.]+$'o))
+ { $genLowerY = $ly; }
+ if ((defined $ux) && ($ux =~ m'^[\d\-\.]+$'o))
+ { $genUpperX = $ux; }
+ if ((defined $uy) && ($uy =~ m'^[\d\-\.]+$'o))
+ { $genUpperY = $uy; }
+ if ($runfil)
+ { $log .= "Mbox~$lx~$ly~$ux~$uy\n";
+ }
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+ 1;
+}
+
+sub prField
+{ my ($fieldName, $fieldValue) = @_;
+ if (($interAktivSida) || ($interActive))
+ { errLog("Too late, has already tried to INITIATE FIELDS within an interactive page");
+ }
+ elsif (! $pos)
+ { errLog("Too early INITIATE FIELDS, create a file first");
+ }
+ $fields{$fieldName} = $fieldValue;
+ if ($fieldValue =~ m'^\s*js\s*\:(.*)'oi)
+ { my $code = $1;
+ my @fall = ($code =~ m'([\w\d\_\$]+)\s*\(.*?\)'gs);
+ for (@fall)
+ { if (! exists $initScript{$_})
+ { $initScript{$_} = 0;
+ }
+ }
+ }
+ if ($runfil)
+ { $fieldName = prep($fieldName);
+ $fieldValue = prep($fieldValue);
+ $log .= "Field~$fieldName~$fieldValue\n";
+ }
+ 1;
+}
+############################################################
+sub prBar
+{ my ($xPos, $yPos, $TxT) = @_;
+
+ $TxT =~ tr/G/2/;
+
+ my @fontSpar = @aktuellFont;
+
+ findBarFont();
+
+ my $Font = $aktuellFont[foINTNAMN]; # Namn i strömmen
+
+ if (($xPos) && ($yPos))
+ { $stream .= "\nBT /$Font $fontSize Tf ";
+ $stream .= "$xPos $yPos Td \($TxT\) Tj ET\n";
+ }
+ if ($runfil)
+ { $log .= "Bar~$xPos~$yPos~$TxT\n";
+ }
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+ @aktuellFont = @fontSpar;
+ return $Font;
+
+}
+
+
+sub prExtract
+{ my $name = shift;
+ my $form = shift;
+ my $page = shift || 1;
+ if ($name =~ m'^/(\w+)'o)
+ { $name = $1;
+ }
+ my $fullName = "$name~$form~$page";
+ if (exists $knownToFile{$fullName})
+ { return $knownToFile{$fullName};
+ }
+ else
+ { if ($runfil)
+ { $log = "Extract~$fullName\n";
+ }
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+
+ if (! exists $form{$form . '_' . $page})
+ { prForm($form, $page, undef, 'load', 1);
+ }
+ $name = extractName($form, $page, $name);
+ if ($name)
+ { $knownToFile{$fullName} = $name;
+ }
+ return $name;
+ }
+}
+
+
+########## Extrahera ett dokument ####################
+sub prDoc
+{ my ($infil, $first, $last);
+ my $param = shift;
+ if (ref($param) eq 'HASH')
+ { $infil = $param->{'file'};
+ $first = $param->{'first'} || 1;
+ $last = $param->{'last'} || '';
+ }
+ else
+ { $infil = $param;
+ $first = shift || 1;
+ $last = shift || '';
+ }
+
+
+ my ($sidor, $Names, $AARoot, $AcroForm) = analysera($infil, $first, $last);
+ if (($Names) || ($AARoot) || ($AcroForm))
+ { $NamesSaved = $Names;
+ $AARootSaved = $AARoot;
+ $AcroFormSaved = $AcroForm;
+ $interActive = 1;
+ }
+ if ($runfil)
+ { $infil = prep($infil);
+ $log .= "Doc~$infil~$first~$last\n";
+ }
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+ return $sidor;
+}
+
+############# Ett interaktivt + grafiskt "formulär" ##########
+
+sub prDocForm
+{my ($sidnr, $adjust, $effect, $tolerant, $infil, $x, $y, $size, $xsize,
+ $ysize, $rotate);
+ my $param = shift;
+ if (ref($param) eq 'HASH')
+ { $infil = $param->{'file'};
+ $sidnr = $param->{'page'} || 1;
+ $adjust = $param->{'adjust'} || '';
+ $effect = $param->{'effect'} || 'print';
+ $tolerant = $param->{'tolerant'} || '';
+ $x = $param->{'x'} || 0;
+ $y = $param->{'y'} || 0;
+ $rotate = $param->{'rotate'} || 0;
+ $size = $param->{'size'} || 1;
+ $xsize = $param->{'xsize'} || 1;
+ $ysize = $param->{'ysize'} || 1;
+ }
+ else
+ { $infil = $param;
+ $sidnr = shift || 1;
+ $adjust = shift || '';
+ $effect = shift || 'print';
+ $tolerant = shift || '';
+ $x = shift || 0;
+ $y = shift || 0;
+ $rotate = shift || 0;
+ $size = shift || 1;
+ $xsize = shift || 1;
+ $ysize = shift || 1;
+ }
+ my $namn;
+ my $refNr;
+ $type = 'docform';
+ my $fSource = $infil . '_' . $sidnr;
+ my $action;
+ if (! exists $form{$fSource})
+ { $formNr++;
+ $namn = 'Fm' . $formNr;
+ $knownToFile{$fSource} = $namn;
+ if ($effect eq 'load')
+ { $action = 'load'
+ }
+ else
+ { $action = 'print'
+ }
+ $refNr = getPage($infil, $sidnr, $action);
+ if ($refNr)
+ { $objRef{$namn} = $refNr;
+ }
+ else
+ { if ($tolerant)
+ { if ((defined $refNr) && ($refNr eq '0')) # Sidnumret existerar inte, men ok
+ { $namn = '0';
+ }
+ else
+ { undef $namn; # Sidan kan inte användas som form
+ }
+ }
+ elsif (! defined $refNr)
+ { my $mess = "$fSource can't be used as a form. See the documentation\n"
+ . "under prForm how to concatenate streams\n";
+ errLog($mess);
+ }
+ else
+ { errLog("File : $infil Page: $sidnr doesn't exist");
+ }
+ }
+ }
+ else
+ { if (exists $knownToFile{$fSource})
+ { $namn = $knownToFile{$fSource};
+ }
+ else
+ { $formNr++;
+ $namn = 'Fm' . $formNr;
+ $knownToFile{$fSource} = $namn;
+ }
+ if (exists $objRef{$namn})
+ { $refNr = $objRef{$namn};
+ }
+ else
+ { if (! $form{$fSource}[fVALID])
+ { my $mess = "$fSource can't be used as a form. See the documentation\n"
+ . "under prForm how to concatenate streams\n";
+ if ($tolerant)
+ { cluck $mess;
+ undef $namn;
+ }
+ else
+ { errLog($mess);
+ }
+ }
+ elsif ($effect ne 'load')
+ { $refNr = byggForm($infil, $sidnr);
+ $objRef{$namn} = $refNr;
+ }
+ }
+ }
+ my @BBox = @{$form{$fSource}[fBBOX]} if ($refNr);
+ if (($effect eq 'print') && ($form{$fSource}[fVALID]) && ($refNr))
+ { if ((! defined $interActive)
+ && ($sidnr == 1)
+ && (defined %{$intAct{$fSource}[0]}) )
+ { $interActive = $infil . ' ' . $sidnr;
+ $interAktivSida = 1;
+ }
+ if (! defined $defGState)
+ { prDefaultGrState();
+ }
+ if ($adjust)
+ { $stream .= "q\n";
+ $stream .= fillTheForm(@BBox, $adjust);
+ $stream .= "\n/Gs0 gs\n";
+ $stream .= "/$namn Do\n";
+ $stream .= "Q\n";
+ }
+ elsif (($x) || ($y) || ($rotate) || ($size != 1)
+ || ($xsize != 1) || ($ysize != 1))
+ { $stream .= "q\n";
+ $stream .= calcMatrix($x, $y, $rotate, $size,
+ $xsize, $ysize, $BBox[2], $BBox[3]);
+ $stream .= "\n/Gs0 gs\n";
+ $stream .= "/$namn Do\n";
+ $stream .= "Q\n";
+ }
+ else
+ { $stream .= "\n/Gs0 gs\n";
+ $stream .= "/$namn Do\n";
+ }
+ $sidXObject{$namn} = $refNr;
+ $sidExtGState{'Gs0'} = $defGState;
+ }
+ if ($runfil)
+ { $infil = prep($infil);
+ $log .= "Form~$infil~$sidnr~$adjust~$effect~$tolerant";
+ $log .= "~$x~$y~$rotate~$size~$xsize~$ysize\n";
+ }
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+ if (($effect ne 'print') && ($effect ne 'add'))
+ { undef $namn;
+ }
+ if (wantarray)
+ { my $images = 0;
+ if (exists $form{$fSource}[fIMAGES])
+ { $images = scalar(@{$form{$fSource}[fIMAGES]});
+ }
+ return ($namn, $BBox[0], $BBox[1], $BBox[2],
+ $BBox[3], $images);
+ }
+ else
+ { return $namn;
+ }
+}
+
+sub calcMatrix
+{ my ($x, $y, $rotate, $size, $xsize, $ysize, $upperX, $upperY) = @_;
+ my ($str, $xSize, $ySize);
+ $size = 1 if ($size == 0);
+ $xsize = 1 if ($xsize == 0);
+ $ysize = 1 if ($ysize == 0);
+ $xSize = $xsize * $size;
+ $ySize = $ysize * $size;
+ $str = "$xSize 0 0 $ySize $x $y cm\n";
+ if ($rotate)
+ { if ($rotate =~ m'q(\d)'oi)
+ { my $tal = $1;
+ if ($tal == 1)
+ { $upperY = $upperX;
+ $upperX = 0;
+ $rotate = 270;
+ }
+ elsif ($tal == 2)
+ { $rotate = 180;
+ }
+ else
+ { $rotate = 90;
+ $upperX = $upperY;
+ $upperY = 0;
+ }
+ }
+ else
+ { $upperX = 0;
+ $upperY = 0;
+ }
+ my $radian = sprintf("%.6f", $rotate / 57.2957795); # approx.
+ my $Cos = sprintf("%.6f", cos($radian));
+ my $Sin = sprintf("%.6f", sin($radian));
+ my $negSin = $Sin * -1;
+ $str .= "$Cos $Sin $negSin $Cos $upperX $upperY cm\n";
+ }
+ return $str;
+}
+
+sub fillTheForm
+{ my $left = shift || 0;
+ my $bottom = shift || 0;
+ my $right = shift || 0;
+ my $top = shift || 0;
+ my $how = shift || 1;
+ my $image = shift;
+ my $str;
+ my $scaleX = 1;
+ my $scaleY = 1;
+
+ my $xDim = $genUpperX - $genLowerX;
+ my $yDim = $genUpperY - $genLowerY;
+ my $xNy = $right - $left;
+ my $yNy = $top - $bottom;
+ $scaleX = $xDim / $xNy;
+ $scaleY = $yDim / $yNy;
+ if ($how == 1)
+ { if ($scaleX < $scaleY)
+ { $scaleY = $scaleX;
+ }
+ else
+ { $scaleX = $scaleY;
+ }
+ }
+ $str = "$scaleX 0 0 $scaleY $left $bottom cm\n";
+ return $str;
+}
+
+sub prAltJpeg
+{ my ($iData, $iWidth, $iHeight, $iFormat,$aiData, $aiWidth, $aiHeight, $aiFormat) = @_;
+ if (! $pos) # If no output is active, it is no use to continue
+ { return undef;
+ }
+ prJpeg($aiData, $aiWidth, $aiHeight, $aiFormat);
+ my $altObjNr = $objNr;
+ $imageNr++;
+ $objNr++;
+ $objekt[$objNr] = $pos;
+ $utrad = "$objNr 0 obj\n" .
+ "[ << /Image $altObjNr 0 R\n" .
+ "/DefaultForPrinting true\n" .
+ ">>\n" .
+ "]\n" .
+ "endobj\n";
+ $pos += syswrite UTFIL, $utrad;
+ if ($runfil)
+ { $log .= "Jpeg~AltImage\n";
+ }
+ $objRef{$namnet} = $objNr;
+ my $namnet = prJpeg($iData, $iWidth, $iHeight, $iFormat, $objNr);
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+ return $namnet;
+}
+
+sub prJpeg
+{ my ($iData, $iWidth, $iHeight, $iFormat, $iColorType, $altArrayObjNr) = @_;
+ if ($iColorType =~ /Gray/i)
+ { $iColorType = 'DeviceGray';
+ }
+ else
+ { $iColorType = 'DeviceRGB';
+ }
+ my ($iLangd, $namnet, $utrad);
+ if (! $pos) # If no output is active, it is no use to continue
+ { return undef;
+ }
+ my $checkidOld = $checkId;
+ if (!$iFormat)
+ { ($iFile, $checkId) = findGet($iData, $checkidOld);
+ if ($iFile)
+ { $iLangd = (stat($iFile))[7];
+ $imageNr++;
+ $namnet = 'Ig' . $imageNr;
+ $objNr++;
+ $objekt[$objNr] = $pos;
+ open (BILDFIL, "<$iFile") || errLog("Couldn't open $iFile, $!, aborts");
+ binmode BILDFIL;
+ my $iStream;
+ sysread BILDFIL, $iStream, $iLangd;
+ $utrad = "$objNr 0 obj\n<</Type/XObject/Subtype/Image/Name/$namnet" .
+ "/Width $iWidth /Height $iHeight /BitsPerComponent 8 " .
+ ($altArrayObjNr ? "/Alternates $altArrayObjNr 0 R " : "") .
+ "/Filter/DCTDecode/ColorSpace/$iColorType"
+ . "/Length $iLangd >>stream\n$iStream\nendstream\nendobj\n";
+ close BILDFIL;
+ $pos += syswrite UTFIL, $utrad;
+ if ($runfil)
+ { $log .= "Cid~$checkId\n";
+ $log .= "Jpeg~$iFile~$iWidth~$iHeight\n";
+ }
+ $objRef{$namnet} = $objNr;
+ }
+ }
+ elsif ($iFormat == 1)
+ { my $iBlob = $iData;
+ $iLangd = length($iBlob);
+ $imageNr++;
+ $namnet = 'Ig' . $imageNr;
+ $objNr++;
+ $objekt[$objNr] = $pos;
+ $utrad = "$objNr 0 obj\n<</Type/XObject/Subtype/Image/Name/$namnet" .
+ "/Width $iWidth /Height $iHeight /BitsPerComponent 8 " .
+ ($altArrayObjNr ? "/Alternates $altArrayObjNr 0 R " : "") .
+ "/Filter/DCTDecode/ColorSpace/$iColorType"
+ . "/Length $iLangd >>stream\n$iBlob\nendstream\nendobj\n";
+ $pos += syswrite UTFIL, $utrad;
+ if ($runfil)
+ { $log .= "Cid~$checkId\n";
+ $log .= "Jpeg~$iFile~$iWidth~$iHeight\n" if !$iFormat;
+ $log .= "Jpeg~Blob~$iWidth~$iHeight\n" if $iFormat == 1;
+ }
+ $objRef{$namnet} = $objNr;
+ }
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+ undef $checkId;
+ return $namnet;
+}
+
+sub checkContentStream
+{ for (@_)
+ { if (my $value = $objRef{$_})
+ { my $typ = substr($_, 0, 2);
+ if ($typ eq 'Ft')
+ { $sidFont{$_} = $value;
+ }
+ elsif ($typ eq 'Gs')
+ { $sidExtGState{$_} = $value;
+ }
+ elsif ($typ eq 'Pt')
+ { $sidPattern{$_} = $value;
+ }
+ elsif ($typ eq 'Sh')
+ { $sidShading{$_} = $value;
+ }
+ elsif ($typ eq 'Cs')
+ { $sidColorSpace{$_} = $value;
+ }
+ else
+ { $sidXObject{$_} = $value;
+ }
+ }
+ elsif (($_ eq 'Gs0') && (! defined $defGState))
+ { my ($dummy, $oNr) = prDefaultGrState();
+ $sidExtGState{'Gs0'} = $oNr;
+ }
+ }
+}
+
+sub prGraphState
+{ my $string = shift;
+ $gSNr++;
+ my $name = 'Gs' . $gSNr ;
+ $objNr++;
+ $objekt[$objNr] = $pos;
+ my $utrad = "$objNr 0 obj\n" . $string . "\nendobj\n";
+ $pos += syswrite UTFIL, $utrad;
+ $objRef{$name} = $objNr;
+ if ($runfil)
+ { $log .= "GraphStat~$string\n";
+ }
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+ return $name;
+}
+
+##############################################################
+# Streckkods fonten lokaliseras och objekten skrivs ev. ut
+##############################################################
+
+sub findBarFont()
+{ my $Font = 'Bar';
+
+ if (exists $font{$Font}) # Objekt är redan definierat
+ { $aktuellFont[foEXTNAMN] = $Font;
+ $aktuellFont[foREFOBJ] = $font{$Font}[foREFOBJ];
+ $aktuellFont[foINTNAMN] = $font{$Font}[foINTNAMN];
+ }
+ else
+ { $objNr++;
+ $objekt[$objNr] = $pos;
+ my $encodObj = $objNr;
+ my $fontObjekt = "$objNr 0 obj\n<< /Type /Encoding\n" .
+ '/Differences [48 /tomt /streck /lstreck]' . "\n>>\nendobj\n";
+ $pos += syswrite UTFIL, $fontObjekt;
+ my $charProcsObj = createCharProcs();
+ $objNr++;
+ $objekt[$objNr] = $pos;
+ $fontNr++;
+ my $fontAbbr = 'Ft' . $fontNr;
+ $fontObjekt = "$objNr 0 obj\n<</Type/Font/Subtype/Type3\n" .
+ '/FontBBox [0 -250 75 2000]' . "\n" .
+ '/FontMatrix [0.001 0 0 0.001 0 0]' . "\n" .
+ "\/CharProcs $charProcsObj 0 R\n" .
+ "\/Encoding $encodObj 0 R\n" .
+ '/FirstChar 48' . "\n" .
+ '/LastChar 50' . "\n" .
+ '/Widths [75 75 75]' . "\n>>\nendobj\n";
+
+ $font{$Font}[foINTNAMN] = $fontAbbr;
+ $font{$Font}[foREFOBJ] = $objNr;
+ $objRef{$fontAbbr} = $objNr;
+ $objekt[$objNr] = $pos;
+ $aktuellFont[foEXTNAMN] = $Font;
+ $aktuellFont[foREFOBJ] = $objNr;
+ $aktuellFont[foINTNAMN] = $fontAbbr;
+ $pos += syswrite UTFIL, $fontObjekt;
+ }
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+
+ $sidFont{$aktuellFont[foINTNAMN]} = $aktuellFont[foREFOBJ];
+}
+
+sub createCharProcs()
+{ #################################
+ # Fonten (objektet) för 0 skapas
+ #################################
+
+ $objNr++;
+ $objekt[$objNr] = $pos;
+ my $tomtObj = $objNr;
+ my $str = "\n75 0 d0\n6 0 69 2000 re\n1.0 g\nf\n";
+ my $strLength = length($str);
+ my $obj = "$objNr 0 obj\n<< /Length $strLength >>\nstream" .
+ $str . "\nendstream\nendobj\n";
+ $pos += syswrite UTFIL, $obj;
+
+ #################################
+ # Fonten (objektet) för 1 skapas
+ #################################
+
+ $objNr++;
+ $objekt[$objNr] = $pos;
+ my $streckObj = $objNr;
+ $str = "\n75 0 d0\n4 0 71 2000 re\n0.0 g\nf\n";
+ $strLength = length($str);
+ $obj = "$objNr 0 obj\n<< /Length $strLength >>\nstream" .
+ $str . "\nendstream\nendobj\n";
+ $pos += syswrite UTFIL, $obj;
+
+ ###################################################
+ # Fonten (objektet) för 2, ett långt streck skapas
+ ###################################################
+
+ $objNr++;
+ $objekt[$objNr] = $pos;
+ my $lStreckObj = $objNr;
+ $str = "\n75 0 d0\n4 -250 71 2250 re\n0.0 g\nf\n";
+ $strLength = length($str);
+ $obj = "$objNr 0 obj\n<< /Length $strLength >>\nstream" .
+ $str . "\nendstream\nendobj\n";
+ $pos += syswrite UTFIL, $obj;
+
+ #####################################################
+ # Objektet för "CharProcs" skapas
+ #####################################################
+
+ $objNr++;
+ $objekt[$objNr] = $pos;
+ my $charProcsObj = $objNr;
+ $obj = "$objNr 0 obj\n<</tomt $tomtObj 0 R\n/streck $streckObj 0 R\n" .
+ "/lstreck $lStreckObj 0 R>>\nendobj\n";
+ $pos += syswrite UTFIL, $obj;
+ return $charProcsObj;
+}
+
+
+
+sub prCid
+{ $checkId = shift;
+ if ($runfil)
+ { $log .= "Cid~$checkId\n";
+ }
+ 1;
+}
+
+sub prIdType
+{ $idTyp = shift;
+ if ($runfil)
+ { $log .= "IdType~rep\n";
+ }
+ 1;
+}
+
+
+sub prId
+{ $id = shift;
+ if ($runfil)
+ { $log .= "Id~$id\n";
+ }
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+ 1;
+}
+
+sub prJs
+{ my $filNamnIn = shift;
+ my $filNamn;
+ if ($filNamnIn !~ m'\{'os)
+ { my $checkIdOld = $checkId;
+ ($filNamn, $checkId) = findGet($filNamnIn, $checkIdOld);
+ if (($runfil) && ($checkId) && ($checkId ne $checkIdOld))
+ { $log .= "Cid~$checkId\n";
+ }
+ $checkId = '';
+ }
+ else
+ { $filNamn = $filNamnIn;
+ }
+ if ($runfil)
+ { my $filnamn = prep($filNamn);
+ $log .= "Js~$filnamn\n";
+ }
+ if (($interAktivSida) || ($interActive))
+ { errLog("Too late, has already tried to merge JAVA SCRIPTS within an interactive page");
+ }
+ elsif (! $pos)
+ { errLog("Too early for JAVA SCRIPTS, create a file first");
+ }
+ push @jsfiler, $filNamn;
+ 1;
+}
+
+sub prInit
+{ my $initText = shift;
+ my $duplicate = shift || '';
+ my @fall = ($initText =~ m'([\w\d\_\$]+)\s*\(.*?\)'gs);
+ for (@fall)
+ { if (! exists $initScript{$_})
+ { $initScript{$_} = 0;
+ }
+ }
+ if ($duplicate)
+ { $duplicateInits = 1;
+ }
+ push @inits, $initText;
+ if ($runfil)
+ { $initText = prep($initText);
+ $log .= "Init~$initText~$duplicate\n";
+ }
+ if (($interAktivSida) || ($interActive))
+ { errLog("Too late, has already tried to create INITIAL JAVA SCRIPTS within an interactive page");
+ }
+ elsif (! $pos)
+ { errLog("Too early for INITIAL JAVA SCRIPTS, create a file first");
+ }
+ 1;
+
+}
+
+sub prVers
+{ my $vers = shift;
+ ############################################################
+ # Om programmet körs om så kontrolleras VERSION
+ ############################################################
+ if ($vers ne $VERSION)
+ { warn "$vers \<\> $VERSION might give different results, if comparing two runs \n";
+ return undef;
+ }
+ else
+ { return 1;
+ }
+}
+
+sub prDocDir
+{ $ddir = findDir(shift);
+ 1;
+}
+
+sub prLogDir
+{ $ldir = findDir(shift);
+ 1;
+}
+
+sub prLog
+{ my $mess = shift;
+ if ($runfil)
+ { $mess = prep($mess);
+ $log .= "Log~$mess\n";
+ return 1;
+ }
+ else
+ { errLog("You have to give a directory for the logfiles first : prLogDir <dir> , aborts");
+ }
+
+}
+
+sub prGetLogBuffer
+{
+ return $log;
+}
+
+sub findDir
+{ my $dir = shift;
+ if ($dir eq '.')
+ { return undef; }
+ if (! -e $dir)
+ { mkdir $dir || errLog("Couldn't create directory $dir, $!");
+ }
+
+ if ((-e $dir) && (-d $dir))
+ { if (substr($dir, length($dir), 1) eq '/')
+ { return $dir; }
+ else
+ { return ($dir . '/');
+ }
+ }
+ else
+ { errLog("Error finding/creating directory $dir, $!");
+ }
+}
+
+sub prTouchUp
+{ $touchUp = shift;
+ if ($runfil)
+ { $log .= "TouchUp~$touchUp\n";
+ }
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+ 1;
+}
+
+sub prCompress
+{ $compress = shift;
+ if ($runfil)
+ { $log .= "Compress~$compress\n";
+ }
+ if (! $pos)
+ { errLog("No output file, you have to call prFile first");
+ }
+ 1;
+
+}
+
+sub prep
+{ my $indata = shift;
+ $indata =~ s/[\n\r]+/ /sgo;
+ $indata =~ s/~/<tilde>/sgo;
+ return $indata;
+}
+
+
+sub xRefs
+{ my ($bytes, $infil) = @_;
+ my ($j, $nr, $xref, $i, $antal, $inrad, $Root, $tempRoot, $referens);
+ my $buf = '';
+ %embedded =();
+
+ my $res = sysseek INFIL, -50, 2;
+ if ($res)
+ { sysread INFIL, $buf, 100;
+ if ($buf =~ m'Encrypt'o)
+ { errLog("The file $infil is encrypted, cannot be used, aborts");
+ }
+ if ($buf =~ m'\bstartxref\s+(\d+)'o)
+ { $xref = $1;
+ if ($xref <= $bytes)
+ {
+ while ($xref)
+ { $res = sysseek INFIL, $xref, 0;
+ $res = sysread INFIL, $buf, 200;
+ if ($buf =~ m '^\d+\s\d+\sobj'os)
+ { ($xref, $tempRoot, $nr) = crossrefObj($nr, $xref);
+ }
+ else
+ { ($xref, $tempRoot, $nr) = xrefSection($nr, $xref, $infil);
+ }
+ if (($tempRoot) && (! $Root))
+ { $Root = $tempRoot;
+ }
+ }
+ }
+ else
+ { errLog("Invalid XREF, aborting");
+ }
+ }
+ }
+
+ ($Root) || errLog("The Root object in $infil couldn't be found, aborting");
+
+ ##############################################################
+ # Objekten sorteras i fallande ordning (efter offset i filen)
+ ##############################################################
+
+ my @offset = sort { $oldObject{$b} <=> $oldObject{$a} } keys %oldObject;
+
+ my $saved;
+
+ for (@offset)
+ { $saved = $oldObject{$_};
+ $bytes -= $saved;
+
+ if ($_ !~ m'^xref'o)
+ { if ($saved == 0)
+ { $oldObject{$_} = [ 0, 0, $embedded{$_}];
+ }
+ else
+ { $oldObject{$_} = [ $saved, $bytes];
+ }
+ }
+ $bytes = $saved;
+ }
+ %embedded = ();
+ return $Root;
+}
+
+sub crossrefObj
+{ my ($nr, $xref) = @_;
+ my ($buf, %param, $len, $tempRoot);
+ my $from = $xref;
+ sysseek INFIL, $xref, 0;
+ sysread INFIL, $buf, 400;
+ my $str;
+ if ($buf =~ m'^(.+>>\s*)stream'os)
+ { $str = $1;
+ $from = length($str) + 7;
+ if (substr($buf, $from, 1) eq "\n")
+ { $from++;
+ }
+ $from += $xref;
+ }
+
+ for (split('/',$str))
+ { if ($_ =~ m'^(\w+)(.*)'o)
+ { $param{$1} = $2 || ' ';
+ }
+ }
+ if (!exists $param{'Index'})
+ { $param{'Index'} = "[0 $param{'Size'}]";
+ }
+ if ((exists $param{'Root'}) && ($param{'Root'} =~ m'^\s*(\d+)'o))
+ { $tempRoot = $1;
+ }
+ my @keys = ($param{'W'} =~ m'(\d+)'og);
+ my $keyLength = 0;
+ for (@keys)
+ { $keyLength += $_;
+ }
+ my $recLength = $keyLength + 1;
+ my $upTo = 1 + $keys[0] + $keys[1];
+ if ((exists $param{'Length'}) && ($param{'Length'} =~ m'(\d+)'o))
+ { $len = $1;
+ sysseek INFIL, $from, 0;
+ sysread INFIL, $buf, $len;
+ my $x = inflateInit()
+ || die "Cannot create an inflation stream\n" ;
+ my ($output, $status) = $x->inflate(\$buf) ;
+ die "inflation failed\n"
+ unless $status == 1;
+
+ my $i = 0;
+ my @last = (0, 0, 0, 0, 0, 0, 0);
+ my @word = ('0', '0', '0', '0', '0', '0', '0');
+ my $recTyp;
+ my @intervall = ($param{'Index'} =~ m'(\d+)\D'osg);
+ my $m = 0;
+ my $currObj = $intervall[$m];
+ $m++;
+ my $max = $currObj + $intervall[$m];
+
+ for (unpack ("C*", $output))
+ { if (($_ != 0) && ($i > 0) && ($i < $upTo))
+ { my $tal = $_ + $last[$i] ;
+ if ($tal > 255)
+ {$tal -= 256;
+ }
+
+ $last[$i] = $tal;
+ $word[$i] = sprintf("%x", $tal);
+ if (length($word[$i]) == 1)
+ { $word[$i] = '0' . $word[$i];
+ }
+ }
+ $i++;
+ if ($i == $recLength)
+ { $i = 0;
+ my $j = 0;
+ my $offsObj; # offset or object
+ if ($keys[0] == 0)
+ { $recTyp = 1;
+ $j = 1;
+ }
+ else
+ { $recTyp = $word[1];
+ $j = 2;
+ }
+ my $k = 0;
+ while ($k < $keys[1])
+ { $offsObj .= $word[$j];
+ $k++;
+ $j++;
+ }
+
+ if ($recTyp == 1)
+ { if (! (exists $oldObject{$currObj}))
+ { $oldObject{$currObj} = hex($offsObj); }
+ else
+ { $nr++;
+ $oldObject{'xref' . "$nr"} = hex($offsObj);
+ }
+ }
+ elsif ($recTyp == 2)
+ { if (! (exists $oldObject{$currObj}))
+ { $oldObject{$currObj} = 0;
+ }
+ $embedded{$currObj} = hex($offsObj);
+ }
+ if ($currObj < $max)
+ { $currObj++;
+ }
+ else
+ { $m++;
+ $currObj = $intervall[$m];
+ $m++;
+ $max = $currObj + $intervall[$m];
+ }
+ }
+ }
+ }
+ return ($param{'Prev'}, $tempRoot, $nr);
+}
+
+sub xrefSection
+{ my ($nr, $xref, $infil) = @_;
+ my ($i, $root, $antal);
+ $nr++;
+ $oldObject{('xref' . "$nr")} = $xref; # Offset för xref sparas
+ $xref += 5;
+ sysseek INFIL, $xref, 0;
+ $xref = 0;
+ my $inrad = '';
+ my $buf = '';
+ my $c;
+ sysread INFIL, $c, 1;
+ while ($c =~ m!\s!s)
+ { sysread INFIL, $c, 1; }
+
+ while ( (defined $c)
+ && ($c ne "\n")
+ && ($c ne "\r") )
+ { $inrad .= $c;
+ sysread INFIL, $c, 1;
+ }
+
+ if ($inrad =~ m'^(\d+)\s+(\d+)'o)
+ { $i = $1;
+ $antal = $2;
+ }
+
+ while ($antal)
+ { for (my $l = 1; $l <= $antal; $l++)
+ { sysread INFIL, $inrad, 20;
+ if ($inrad =~ m'^\s?(\d+) \d+ (\w)\s*'o)
+ { if ($2 eq 'n')
+ { if (! (exists $oldObject{$i}))
+ { $oldObject{$i} = int($1); }
+ else
+ { $nr++;
+ $oldObject{'xref' . "$nr"} = int($1);
+ }
+ }
+ }
+ $i++;
+ }
+ undef $antal;
+ undef $inrad;
+ sysread INFIL, $c, 1;
+ while ($c =~ m!\s!s)
+ { sysread INFIL, $c, 1; }
+
+ while ( (defined $c)
+ && ($c ne "\n")
+ && ($c ne "\r") )
+ { $inrad .= $c;
+ sysread INFIL, $c, 1;
+ }
+ if ($inrad =~ m'^(\d+)\s+(\d+)'o)
+ { $i = $1;
+ $antal = $2;
+ }
+
+ }
+
+ while ($inrad)
+ { $buf .= $inrad;
+ if ($buf =~ m'Encrypt'o)
+ { errLog("The file $infil is encrypted, cannot be used, aborts");
+ }
+ if ((! $root) && ($buf =~ m'\/Root\s+(\d+)\s{1,2}\d+\s{1,2}R'so))
+ { $root = $1;
+ if ($xref)
+ { last; }
+ }
+
+ if ((! $xref) && ($buf =~ m'\/Prev\s+(\d+)\D'so))
+ { $xref = $1;
+ if ($root)
+ { last; }
+ }
+
+ if ($buf =~ m'xref'so)
+ { last; }
+
+ sysread INFIL, $inrad, 30;
+ }
+ return ($xref, $root, $nr);
+}
+
+sub getObject
+{ my ($nr, $noId, $noEnd) = @_;
+
+ my $buf;
+ my ($offs, $siz, $embedded) = @{$oldObject{$nr}};
+
+ if ($offs)
+ { sysseek INFIL, $offs, 0;
+ sysread INFIL, $buf, $siz;
+ if (($noId) && ($noEnd))
+ { if ($buf =~ m'^\d+ \d+ obj\s*(.*)endobj'os)
+ { if (wantarray)
+ { return ($1, $offs, $siz, $embedded);
+ }
+ else
+ { return $1;
+ }
+ }
+ }
+ elsif ($noId)
+ { if ($buf =~ m'^\d+ \d+ obj\s*(.*)'os)
+ { if (wantarray)
+ { return ($1, $offs, $siz, $embedded);
+ }
+ else
+ { return $1;
+ }
+ }
+ }
+ if (wantarray)
+ { return ($buf, $offs, $siz, $embedded)
+ }
+ else
+ { return $buf;
+ }
+ }
+ elsif (exists $unZipped{$nr})
+ { ;
+ }
+ elsif ($embedded)
+ { unZipPrepare($embedded);
+ }
+ if ($noEnd)
+ { if (wantarray)
+ { return ($unZipped{$nr}, $offs, $siz, $embedded)
+ }
+ else
+ { return $unZipped{$nr};
+ }
+ }
+ else
+ { if (wantarray)
+ { return ("$unZipped{$nr}endobj\n", $offs, $siz, $embedded)
+ }
+ else
+ { return "$unZipped{$nr}endobj\n";
+ }
+ }
+}
+
+sub getKnown
+{ my ($p, $nr) = @_;
+ my ($del1, $del2);
+ my @objData = @{$$$p[0]->{$nr}};
+ if (defined $objData[oSTREAMP])
+ { sysseek INFIL, ($objData[oNR][0] + $objData[oPOS]), 0;
+ sysread INFIL, $del1, ($objData[oSTREAMP] - $objData[oPOS]);
+ sysread INFIL, $del2, ($objData[oNR][1] - $objData[oSTREAMP]);
+ }
+ else
+ { my $buf;
+ my ($offs, $siz, $embedded) = @{$objData[oNR]};
+ if ($offs)
+ { sysseek INFIL, $offs, 0;
+ sysread INFIL, $buf, $siz;
+ if ($buf =~ m'^\d+ \d+ obj\s*(.*)'os)
+ { $del1 = $1;
+ }
+ }
+ elsif (exists $unZipped{$nr})
+ { $del1 = "$unZipped{$nr} endobj";
+ }
+ elsif ($embedded)
+ { @objData = @{$$$p[0]->{$embedded}};
+ unZipPrepare($embedded, $objData[oNR][0], $objData[oNR][1]);
+ $del1 = "$unZipped{$nr} endobj";
+ }
+ }
+ return (\$del1, \$del2, $objData[oKIDS], $objData[oTYPE]);
+}
+
+
+sub unZipPrepare
+{ my ($nr, $offs, $size) = @_;
+ my $buf;
+ if ($offs)
+ { sysseek INFIL, $offs, 0;
+ sysread INFIL, $buf, $size;
+ }
+ else
+ { $buf = getObject($nr);
+ }
+ my (%param, $stream, $str);
+
+ if ($buf =~ m'^(\d+ \d+ obj\s*<<[\w\d\/\s\[\]<>]+)stream\b'os)
+ { $str = $1;
+ $offs = length($str) + 7;
+ if (substr($buf, $offs, 1) eq "\n")
+ { $offs++;
+ }
+
+ for (split('/',$str))
+ { if ($_ =~ m'^(\w+)(.*)'o)
+ { $param{$1} = $2 || ' ';
+ }
+ }
+ $stream = substr($buf, $offs, $param{'Length'});
+ my $x = inflateInit()
+ || die "Cannot create an inflation stream\n";
+ my ($output, $status) = $x->inflate($stream);
+ die "inflation failed\n"
+ unless $status == 1;
+
+ my $first = $param{'First'};
+ my @oOffsets = (substr($output, 0, $first) =~ m'(\d+)\b'osg);
+ my $i = 0;
+ my $j = 1;
+ my $bytes;
+ while ($oOffsets[$i])
+ { my $k = $j + 2;
+ if ($oOffsets[$k])
+ { $bytes = $oOffsets[$k] - $oOffsets[$j];
+ }
+ else
+ { $bytes = length($output) - $first - $oOffsets[$j];
+ }
+ $unZipped{$oOffsets[$i]} = substr($output,($first + $oOffsets[$j]), $bytes);
+ $i += 2;
+ $j += 2;
+ }
+ }
+}
+
+############################################
+# En definitionerna för en sida extraheras
+############################################
+
+sub getPage
+{ my ($infil, $sidnr, $action) = @_;
+
+ my ($res, $i, $referens,$objNrSaved,$validStream, $formRes, @objData,
+ @underObjekt, @sidObj, $strPos, $startSida, $sidor, $filId, $del1, $del2,
+ $offs, $siz, $embedded, $vektor, $utrad, $robj, $valid, $Annots, $Names,
+ $AcroForm, $AARoot, $AAPage);
+
+ my $sidAcc = 0;
+ my $seq = 0;
+ $imSeq = 0;
+ @skapa = ();
+ undef $formCont;
+
+
+ $objNrSaved = $objNr;
+ my $fSource = $infil . '_' . $sidnr;
+ my $checkidOld = $checkId;
+ ($infil, $checkId) = findGet($infil, $checkidOld);
+ if (($ldir) && ($checkId) && ($checkId ne $checkidOld))
+ { $log .= "Cid~$checkId\n";
+ }
+ $form{$fSource}[fID] = $checkId;
+ $checkId = '';
+ $behandlad{$infil}->{old} = {}
+ unless (defined $behandlad{$infil}->{old});
+ $processed{$infil}->{oldObject} = {}
+ unless (defined $processed{$infil}->{oldObject});
+ $processed{$infil}->{unZipped} = {}
+ unless (defined $processed{$infil}->{unZipped});
+
+ if ($action eq 'print')
+ { *old = $behandlad{$infil}->{old};
+ }
+ else
+ { $behandlad{$infil}->{dummy} = {};
+ *old = $behandlad{$infil}->{dummy};
+ }
+
+ *oldObject = $processed{$infil}->{oldObject};
+ *unZipped = $processed{$infil}->{unZipped};
+ $root = (exists $processed{$infil}->{root})
+ ? $processed{$infil}->{root} : 0;
+
+
+ my @stati = stat($infil);
+ open (INFIL, "<$infil") || errLog("Couldn't open $infil, $!");
+ binmode INFIL;
+
+ if (! $root)
+ { $root = xRefs($stati[7], $infil);
+ }
+
+ #############
+ # Hitta root
+ #############
+
+ my $objektet = getObject($root);;
+
+ if ($sidnr == 1)
+ { if ($objektet =~ m'/AcroForm(\s+\d+\s{1,2}\d+\s{1,2}R)'so)
+ { $AcroForm = $1;
+ }
+ if ($objektet =~ m'/Names\s+(\d+)\s{1,2}\d+\s{1,2}R'so)
+ { $Names = $1;
+ }
+ #################################################
+ # Finns ett dictionary för Additional Actions ?
+ #################################################
+ if ($objektet =~ m'/AA\s*\<\<\s*[^\>]+[^\>]+'so) # AA är ett dictionary
+ { my $k;
+ my ($dummy, $obj) = split /\/AA/, $objektet;
+ $obj =~ s/\<\</\#\<\</gs;
+ $obj =~ s/\>\>/\>\>\#/gs;
+ my @ord = split /\#/, $obj;
+ for ($i = 0; $i <= $#ord; $i++)
+ { $AARoot .= $ord[$i];
+ if ($ord[$i] =~ m'\S+'os)
+ { if ($ord[$i] =~ m'<<'os)
+ { $k++; }
+ if ($ord[$i] =~ m'>>'os)
+ { $k--; }
+ if ($k == 0)
+ { last; }
+ }
+ }
+ }
+ }
+
+ #
+ # Hitta pages
+ #
+
+ if ($objektet =~ m'/Pages\s+(\d+)\s{1,2}\d+\s{1,2}R'os)
+ { $objektet = getObject($1);
+ if ($objektet =~ m'/Count\s+(\d+)'os)
+ { $sidor = $1;
+ if ($sidnr <= $sidor)
+ { ($formRes, $valid) = kolla($objektet);
+ }
+ else
+ { return 0;
+ }
+ if ($sidor > 1)
+ { undef $AcroForm;
+ undef $Names;
+ undef $AARoot;
+ if ($type eq 'docform')
+ { errLog("prDocForm can only be used for single page documents - try prDoc or reformat $infil");
+ }
+ }
+ }
+ }
+ else
+ { errLog("Didn't find Pages in $infil - aborting"); }
+
+ if ($objektet =~ m'/Kids\s*\[([^\]]+)'os)
+ { $vektor = $1; }
+ while ($vektor =~ m'(\d+)\s{1,2}\d+\s{1,2}R'go)
+ { push @sidObj, $1;
+ }
+
+ my $bryt1 = -20; # Hängslen
+ my $bryt2 = -20; # Svångrem för att undvika oändliga loopar
+
+ while ($sidAcc < $sidnr)
+ { @underObjekt = @sidObj;
+ @sidObj = ();
+ $bryt1++;
+ for my $uO (@underObjekt)
+ { $objektet = getObject($uO);
+ if ($objektet =~ m'/Count\s+(\d+)'os)
+ { if (($sidAcc + $1) < $sidnr)
+ { $sidAcc += $1; }
+ else
+ { ($formRes, $valid) = kolla($objektet, $formRes);
+ if ($objektet =~ m'/Kids\s*\[([^\]]+)'os)
+ { $vektor = $1; }
+ while ($vektor =~ m'(\d+)\s{1,2}\d+\s{1,2}R'gso)
+ { push @sidObj, $1; }
+ last;
+ }
+ }
+ else
+ { $sidAcc++; }
+ if ($sidAcc == $sidnr)
+ { $seq = $uO;
+ last; }
+ $bryt2++;
+ }
+ if (($bryt1 > $sidnr) || ($bryt2 > $sidnr)) # Bryt oändliga loopar
+ { last; }
+ }
+
+ ($formRes, $validStream) = kolla($objektet, $formRes);
+ $startSida = $seq;
+
+ if ($sidor == 1)
+ { #################################################
+ # Kontrollera Page-objektet för annoteringar
+ #################################################
+
+ if ($objektet =~ m'/Annots\s*([^\/]+)'so)
+ { $Annots = $1;
+ }
+ #################################################
+ # Finns ett dictionary för Additional Actions ?
+ #################################################
+ if ($objektet =~ m'/AA\s*\<\<\s*[^\>]+[^\>]+'so) # AA är ett dictionary. Hela kopieras
+ { my $k;
+ my ($dummy, $obj) = split /\/AA/, $objektet;
+ $obj =~ s/\<\</\#\<\</gs;
+ $obj =~ s/\>\>/\>\>\#/gs;
+ my @ord = split /\#/, $obj;
+ for ($i = 0; $i <= $#ord; $i++)
+ { $AAPage .= $ord[$i];
+ if ($ord[$i] =~ m'\S+'s)
+ { if ($ord[$i] =~ m'<<'s)
+ { $k++; }
+ if ($ord[$i] =~ m'>>'s)
+ { $k--; }
+ if ($k == 0)
+ { last; }
+ }
+ }
+ }
+ }
+
+ my $rform = \$form{$fSource};
+ @$$rform[fRESOURCE] = $formRes;
+ my @BBox;
+ if (defined $formBox[0])
+ { $BBox[0] = $formBox[0]; }
+ else
+ { $BBox[0] = $genLowerX; }
+
+ if (defined $formBox[1])
+ { $BBox[1] = $formBox[1]; }
+ else
+ { $BBox[1] = $genLowerY; }
+
+ if (defined $formBox[2])
+ { $BBox[2] = $formBox[2]; }
+ else
+ { $BBox[2] = $genUpperX; }
+
+ if (defined $formBox[3])
+ { $BBox[3] = $formBox[3]; }
+ else
+ { $BBox[3] = $genUpperY; }
+
+ @{$form{$fSource}[fBBOX]} = @BBox;
+
+ if ($formCont)
+ { $seq = $formCont;
+ ($objektet, $offs, $siz, $embedded) = getObject($seq);
+
+ $robj = \$$$rform[fOBJ]->{$seq};
+ @{$$$robj[oNR]} = ($offs, $siz, $embedded);
+ $$$robj[oFORM] = 'Y';
+ $form{$fSource}[fMAIN] = $seq;
+ if ($objektet =~ m'^(\d+ \d+ obj\s*<<)(.+)(>>\s*stream)'so)
+ { $del1 = $2;
+ $strPos = length($1) + length($2) + length($3);
+ $$$robj[oPOS] = length($1);
+ $$$robj[oSTREAMP] = $strPos;
+ my $nyDel1;
+ $nyDel1 = '<</Type/XObject/Subtype/Form/FormType 1';
+ $nyDel1 .= "/Resources $formRes" .
+ "/BBox \[ $BBox[0] $BBox[1] $BBox[2] $BBox[3]\]" .
+ # "/Matrix \[ 1 0 0 1 0 0 \]" .
+ $del1;
+ if ($action eq 'print')
+ { $objNr++;
+ $objekt[$objNr] = $pos;
+ }
+ $referens = $objNr;
+
+ $res = ($nyDel1 =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs);
+ if ($res)
+ { $$$robj[oKIDS] = 1; }
+ if ($action eq 'print')
+ { $utrad = "$referens 0 obj\n" . "$nyDel1" . ">>\nstream";
+ $del2 = substr($objektet, $strPos);
+ $utrad .= $del2;
+ $pos += syswrite UTFIL, $utrad;
+ }
+ $form{$fSource}[fVALID] = $validStream;
+ }
+ else # Endast resurserna kan behandlas
+ { $formRes =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs;
+ }
+ }
+ else # Endast resurserna kan behandlas
+ { $formRes =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs;
+ }
+
+ my $preLength;
+ while (scalar @skapa)
+ { my @process = @skapa;
+ @skapa = ();
+ for (@process)
+ { my $Font;
+ my $gammal = $$_[0];
+ my $ny = $$_[1];
+ ($objektet, $offs, $siz, $embedded) = getObject($gammal);
+ $robj = \$$$rform[fOBJ]->{$gammal};
+ @{$$$robj[oNR]} = ($offs, $siz, $embedded);
+ if ($objektet =~ m'^(\d+ \d+ obj\s*<<)(.+)(>>\s*stream)'os)
+ { $del1 = $2;
+ $strPos = length ($1) + length($2) + length($3);
+ $$$robj[oPOS] = length($1);
+ $$$robj[oSTREAMP] = $strPos;
+
+ ######## En bild ########
+ if ($del1 =~ m'/Subtype\s*/Image'so)
+ { $imSeq++;
+ $$$robj[oIMAGENR] = $imSeq;
+ push @{$$$rform[fIMAGES]}, $gammal;
+
+ if ($del1 =~ m'/Width\s+(\d+)'os)
+ { $$$robj[oWIDTH] = $1; }
+ if ($del1 =~ m'/Height\s+(\d+)'os)
+ { $$$robj[oHEIGHT] = $1; }
+ }
+ $res = ($del1 =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs);
+ if ($res)
+ { $$$robj[oKIDS] = 1; }
+ if ($action eq 'print')
+ { $objekt[$ny] = $pos;
+ $utrad = "$ny 0 obj\n<<" . "$del1" . '>>stream';
+ $del2 = substr($objektet, $strPos);
+ $utrad .= $del2;
+ }
+ }
+ else
+ { if ($objektet =~ m'^(\d+ \d+ obj\s*)'os)
+ { $preLength = length($1);
+ $$$robj[oPOS] = $preLength;
+ $objektet = substr($objektet, $preLength);
+ }
+ else
+ { $$$robj[oPOS] = 0;
+ }
+ $res = ($objektet =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs);
+ if ($res)
+ { $$$robj[oKIDS] = 1; }
+ if ($objektet =~ m'/Subtype\s*/Image'so)
+ { $imSeq++;
+ $$$robj[oIMAGENR] = $imSeq;
+ push @{$$$rform[fIMAGES]}, $gammal;
+ ###################################
+ # Sparar dimensionerna för bilden
+ ###################################
+ if ($del1 =~ m'/Width\s+(\d+)'os)
+ { $$$robj[oWIDTH] = $1; }
+
+ if ($del1 =~ m'/Height\s+(\d+)'os)
+ { $$$robj[oHEIGHT] = $1; }
+ }
+ elsif ($objektet =~ m'/BaseFont\s*/([^\s\/]+)'os)
+ { $Font = $1;
+ $$$robj[oTYPE] = 'Font';
+ $$$robj[oNAME] = $Font;
+ if ((! exists $font{$Font})
+ && ($action))
+ { $fontNr++;
+ $font{$Font}[foINTNAMN] = 'Ft' . $fontNr;
+ $font{$Font}[foORIGINALNR] = $gammal;
+ $fontSource{$Font}[foSOURCE] = $fSource;
+ $fontSource{$Font}[foORIGINALNR] = $gammal;
+ if ($objektet =~ m'/Subtype\s*/Type0'os)
+ { $font{$Font}[foTYP] = 1;
+ }
+ if ($action eq 'print')
+ { $font{$Font}[foREFOBJ] = $ny;
+ $objRef{'Ft' . $fontNr} = $ny;
+ }
+ }
+ }
+
+ if ($action eq 'print')
+ { $objekt[$ny] = $pos;
+ $utrad = "$ny 0 obj $objektet";
+ }
+ }
+ if ($action eq 'print')
+ { $pos += syswrite UTFIL, $utrad;
+ }
+ }
+ }
+
+ my $ref = \$form{$fSource};
+ my @kids;
+ my @nokids;
+
+ #################################################################
+ # lägg upp vektorer över vilka objekt som har KIDS eller NOKIDS
+ #################################################################
+
+ for my $key (keys %{$$$ref[fOBJ]})
+ { $robj = \$$$ref[fOBJ]->{$key};
+ if (! defined $$$robj[oFORM])
+ { if (defined $$$robj[oKIDS])
+ { push @kids, $key; }
+ else
+ { push @nokids, $key; }
+ }
+ if ((defined $$$robj[0]->[2]) && (! exists $$$ref[fOBJ]->{$$$robj[0]->[2]}))
+ { $$$ref[fOBJ]->{$$$robj[0]->[2]}->[0] = $oldObject{$$$robj[0]->[2]};
+ }
+ }
+ if (scalar @kids)
+ { $form{$fSource}[fKIDS] = \@kids;
+ }
+ if (scalar @nokids)
+ { $form{$fSource}[fNOKIDS] = \@nokids;
+ }
+
+ if ($action ne 'print')
+ { $objNr = $objNrSaved; # Restore objNo if nothing was printed
+ }
+
+ $behandlad{$infil}->{dummy} = {};
+ *old = $behandlad{$infil}->{dummy};
+
+ $objNrSaved = $objNr; # Save objNo
+
+ if ($sidor == 1)
+ { @skapa = ();
+ $old{$startSida} = $sidObjNr;
+ my $ref = \$intAct{$fSource};
+ @$$ref[iSTARTSIDA] = $startSida;
+ if (defined $Names)
+ { @$$ref[iNAMES] = $Names;
+ quickxform($Names);
+ }
+ if (defined $AcroForm)
+ { @$$ref[iACROFORM] = $AcroForm;
+ $AcroForm =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs;
+ }
+ if (defined $AARoot)
+ { @$$ref[iAAROOT] = $AARoot;
+ $AARoot =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs;
+ }
+ if (defined $AAPage)
+ { @$$ref[iAAPAGE] = $AAPage;
+ $AAPage =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs;
+ }
+ if (defined $Annots)
+ { my @array;
+ if ($Annots =~ m'\[([^\[\]]*)\]'os)
+ { $Annots = $1;
+ @array = ($Annots =~ m'\b(\d+)\s{1,2}\d+\s{1,2}R\b'ogs);
+ }
+ else
+ { if ($Annots =~ m'\b(\d+)\s{1,2}\d+\s{1,2}R\b'os)
+ { $Annots = getObject($1);
+ @array = ($Annots =~ m'\b(\d+)\s{1,2}\d+\s{1,2}R\b'ogs);
+ }
+ }
+ @$$ref[iANNOTS] = \@array;
+ $Annots =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs;
+ }
+
+ while (scalar @skapa)
+ { my @process = @skapa;
+ @skapa = ();
+ for (@process)
+ { my $gammal = $$_[0];
+ my $ny = $$_[1];
+ ($objektet, $offs, $siz, $embedded) = getObject($gammal);
+ $robj = \$$$ref[fOBJ]->{$gammal};
+ @{$$$robj[oNR]} = ($offs, $siz, $embedded);
+ if ($objektet =~ m'^(\d+ \d+ obj\s*<<)(.+)(>>\s*stream)'os)
+ { $del1 = $2;
+ $$$robj[oPOS] = length($1);
+ $$$robj[oSTREAMP] = length($1) + length($2) + length($3);
+
+ $res = ($del1 =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs);
+ if ($res)
+ { $$$robj[oKIDS] = 1; }
+ }
+ else
+ { if ($objektet =~ m'^(\d+ \d+ obj)'os)
+ { my $preLength = length($1);
+ $$$robj[oPOS] = $preLength;
+ $objektet = substr($objektet, $preLength);
+
+ $res = ($objektet =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs);
+ if ($res)
+ { $$$robj[oKIDS] = 1; }
+ }
+ }
+ }
+ }
+ for my $key (keys %{$$$ref[fOBJ]})
+ { $robj = \$$$ref[fOBJ]->{$key};
+ if ((defined $$$robj[0]->[2]) && (! exists $$$ref[fOBJ]->{$$$robj[0]->[2]}))
+ { $$$ref[fOBJ]->{$$$robj[0]->[2]}->[0] = $oldObject{$$$robj[0]->[2]};
+ }
+ }
+ }
+
+ $objNr = $objNrSaved;
+ $processed{$infil}->{root} = $root;
+ close INFIL;
+ return $referens;
+}
+
+##################################################
+# Översätter ett gammalt objektnr till ett nytt
+# och sparar en tabell med vad som skall skapas
+##################################################
+
+sub xform
+{ if (exists $old{$1})
+ { $old{$1};
+ }
+ else
+ { push @skapa, [$1, ++$objNr];
+ $old{$1} = $objNr;
+ }
+}
+
+sub kolla
+{ #
+ # Resurser
+ #
+ my $obj = shift;
+ my $resources = shift;
+ my $valid;
+
+ if ($obj =~ m'MediaBox\s*\[\s*([\-\.\d]+)\s+([\-\.\d]+)\s+([\-\.\d]+)\s+([\-\.\d]+)'os)
+ { $formBox[0] = $1;
+ $formBox[1] = $2;
+ $formBox[2] = $3;
+ $formBox[3] = $4;
+ }
+
+ if ($obj =~ m'/Contents\s+(\d+)'so)
+ { $formCont = $1;
+ my $cObj = getObject($formCont, 1, 1);
+ if ($cObj =~ m'^\s*\[[^\]]+\]\s*$'os)
+ { $valid = 0;
+ undef $formCont;
+ }
+ else
+ { $valid = 1;
+ }
+ }
+ elsif ($obj =~ m'/Contents\s*\[\s*(\d+)\s{1,2}\d+\s{1,2}R\s*\]'so)
+ { $formCont = $1;
+ $valid = 1;
+ }
+
+ if ($obj =~ m'^(.+/Resources)'so)
+ { if ($obj =~ m'Resources(\s+\d+\s{1,2}\d+\s{1,2}R)'os) # Hänvisning
+ { $resources = $1; }
+ else # Resurserna är ett dictionary. Hela kopieras
+ { my $dummy;
+ my $i;
+ my $k;
+ undef $resources;
+ ($dummy, $obj) = split /\/Resources/, $obj;
+ $obj =~ s/\<\</\#\<\</gs;
+ $obj =~ s/\>\>/\>\>\#/gs;
+ my @ord = split /\#/, $obj;
+ for ($i = 0; $i <= $#ord; $i++)
+ { $resources .= $ord[$i];
+ if ($ord[$i] =~ m'\S+'s)
+ { if ($ord[$i] =~ m'<<'s)
+ { $k++; }
+ if ($ord[$i] =~ m'>>'s)
+ { $k--; }
+ if ($k == 0)
+ { last; }
+ }
+ }
+ }
+ }
+ return ($resources, $valid);
+}
+
+##############################
+# Ett formulär (åter)skapas
+##############################
+
+sub byggForm
+{ no warnings;
+ my ($infil, $sidnr) = @_;
+
+ my ($res, $corr, $nyDel1, $formRes, $del1, $del2, $kids, $typ, $nr,
+ $utrad);
+
+ my $fSource = $infil . '_' . $sidnr;
+ my @stati = stat($infil);
+
+ $behandlad{$infil}->{old} = {}
+ unless (defined $behandlad{$infil}->{old});
+ $processed{$infil}->{oldObject} = {}
+ unless (defined $processed{$infil}->{oldObject});
+ $processed{$infil}->{unZipped} = {}
+ unless (defined $processed{$infil}->{unZipped});
+
+ *old = $behandlad{$infil}->{old};
+ *oldObject = $processed{$infil}->{oldObject};
+ *unZipped = $processed{$infil}->{unZipped};
+
+ if ($form{$fSource}[fID] != $stati[9])
+ { errLog("$stati[9] ne $form{$fSource}[fID] aborts");
+ }
+ if ($checkId)
+ { if ($checkId ne $stati[9])
+ { my $mess = "$checkId \<\> $stati[9] \n"
+ . "The Pdf-file $fSource has not the correct modification time. \n"
+ . "The program is aborted";
+ errLog($mess);
+ }
+ undef $checkId;
+ }
+ if ($ldir)
+ { $log .= "Cid~$stati[9]\n";
+ }
+
+ open (INFIL, "<$infil") || errLog("The file $infil couldn't be opened, aborting $!");
+ binmode INFIL;
+
+ ####################################################
+ # Objekt utan referenser kopieras och skrivs
+ ####################################################
+
+ for my $key (@{$form{$fSource}->[fNOKIDS]})
+ { if ((defined $old{$key}) && ($objekt[$old{$key}])) # already processed
+ { next;
+ }
+
+ if (! defined $old{$key})
+ { $old{$key} = ++$objNr;
+ }
+ $nr = $old{$key};
+ $objekt[$nr] = $pos;
+
+ ($del1, $del2, $kids, $typ) = getKnown(\$form{$fSource},$key);
+
+ if ($typ eq 'Font')
+ { my $Font = ${$form{$fSource}}[0]->{$key}->[oNAME];
+ if (! defined $font{$Font}[foINTNAMN])
+ { $fontNr++;
+ $font{$Font}[foINTNAMN] = 'Ft' . $fontNr;
+ $font{$Font}[foREFOBJ] = $nr;
+ $objRef{'Ft' . $fontNr} = $nr;
+ }
+ }
+ if (! defined $$del2)
+ { $utrad = "$nr 0 obj " . $$del1;
+ }
+ else
+ { $utrad = "$nr 0 obj\n<<" . $$del1 . $$del2;
+ }
+ $pos += syswrite UTFIL, $utrad;
+ }
+
+ #######################################################
+ # Objekt med referenser kopieras, behandlas och skrivs
+ #######################################################
+ for my $key (@{$form{$fSource}->[fKIDS]})
+ { if ((defined $old{$key}) && ($objekt[$old{$key}])) # already processed
+ { next;
+ }
+
+ if (! defined $old{$key})
+ { $old{$key} = ++$objNr;
+ }
+ $nr = $old{$key};
+
+ $objekt[$nr] = $pos;
+
+ ($del1, $del2, $kids, $typ) = getKnown(\$form{$fSource},$key);
+
+ $$del1 =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/translate() . ' 0 R'/oegs;
+
+ if (defined $$del2)
+ { $utrad = "$nr 0 obj\n<<" . $$del1 . $$del2;
+ }
+ else
+ { $utrad = "$nr 0 obj " . $$del1;
+ }
+
+ if (($typ) && ($typ eq 'Font'))
+ { my $Font = $form{$fSource}[0]->{$key}->[oNAME];
+ if (! defined $font{$Font}[foINTNAMN])
+ { $fontNr++;
+ $font{$Font}[foINTNAMN] = 'Ft' . $fontNr;
+ $font{$Font}[foREFOBJ] = $nr;
+ $objRef{'Ft' . $fontNr} = $nr;
+ }
+ }
+
+ $pos += syswrite UTFIL, $utrad;
+ }
+
+ #################################
+ # Formulärobjektet behandlas
+ #################################
+
+ my $key = $form{$fSource}->[fMAIN];
+ if (! defined $key)
+ { return undef;
+ }
+
+ if (exists $old{$key}) # already processed
+ { close INFIL;
+ return $old{$key};
+ }
+
+ $nr = ++$objNr;
+
+ $objekt[$nr] = $pos;
+
+ $formRes = $form{$fSource}->[fRESOURCE];
+
+ ($del1, $del2) = getKnown(\$form{$fSource}, $key);
+
+ $nyDel1 = '<</Type/XObject/Subtype/Form/FormType 1';
+ $nyDel1 .= "/Resources $formRes" .
+ '/BBox [' .
+ $form{$fSource}->[fBBOX]->[0] . ' ' .
+ $form{$fSource}->[fBBOX]->[1] . ' ' .
+ $form{$fSource}->[fBBOX]->[2] . ' ' .
+ $form{$fSource}->[fBBOX]->[3] . ' ]' .
+ # "\]/Matrix \[ $sX 0 0 $sX $tX $tY \]" .
+ $$del1;
+ $nyDel1 =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/translate() . ' 0 R'/oegs;
+
+ $utrad = "$nr 0 obj" . $nyDel1 . $$del2;
+
+ $pos += syswrite UTFIL, $utrad;
+ close INFIL;
+
+ return $nr;
+}
+
+##################
+# En bild läses
+##################
+
+sub getImage
+{ my ($infil, $sidnr, $bildnr, $key) = @_;
+ if (! defined $key)
+ { errLog("Can't find image $bildnr on page $sidnr in file $infil, aborts");
+ }
+
+ @skapa = ();
+ my ($res, $corr, $nyDel1, $del1, $del2, $nr, $utrad);
+ my $fSource = $infil . '_' . $sidnr;
+ my $iSource = $fSource . '_' . $bildnr;
+
+ $behandlad{$infil}->{old} = {}
+ unless (defined $behandlad{$infil}->{old});
+ $processed{$infil}->{oldObject} = {}
+ unless (defined $processed{$infil}->{oldObject});
+ $processed{$infil}->{unZipped} = {}
+ unless (defined $processed{$infil}->{unZipped});
+
+ *old = $behandlad{$infil}->{old};
+ *oldObject = $processed{$infil}->{oldObject};
+ *unZipped = $processed{$infil}->{unZipped};
+
+ my @stati = stat($infil);
+
+ if ($form{$fSource}[fID] != $stati[9])
+ { errLog("$stati[9] ne $form{$fSource}[fID], modification time has changed, aborting");
+ }
+
+ if (exists $old{$key})
+ { return $old{$key};
+ }
+
+ open (INFIL, "<$infil") || errLog("The file $infil couldn't be opened, $!");
+ binmode INFIL;
+
+ #########################################################
+ # En bild med referenser kopieras, behandlas och skrivs
+ #########################################################
+
+ $nr = ++$objNr;
+ $old{$key} = $nr;
+
+ $objekt[$nr] = $pos;
+
+ ($del1, $del2) = getKnown(\$form{$fSource}, $key);
+
+ $$del1 =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs;
+ if (defined $$del2)
+ { $utrad = "$nr 0 obj\n<<" . $$del1 . $$del2;
+ }
+ else
+ { $utrad = "$nr 0 obj " . $$del1;
+ }
+ $pos += syswrite UTFIL, $utrad;
+ ##################################
+ # Skriv ut underordnade objekt
+ ##################################
+ while (scalar @skapa)
+ { my @process = @skapa;
+ @skapa = ();
+ for (@process)
+ { my $gammal = $$_[0];
+ my $ny = $$_[1];
+
+ ($del1, $del2) = getKnown(\$form{$fSource}, $gammal);
+
+ $$del1 =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs;
+ if (defined $$del2)
+ { $utrad = "$ny 0 obj\n<<" . $$del1 . $$del2;
+ }
+ else
+ { $utrad = "$ny 0 obj " . $$del1;
+ }
+ $objekt[$ny] = $pos;
+ $pos += syswrite UTFIL, $utrad;
+ }
+ }
+
+ close INFIL;
+ return $nr;
+
+}
+
+##############################################################
+# Interaktiva funktioner knutna till ett formulär återskapas
+##############################################################
+
+sub AcroFormsEtc
+{ my ($infil, $sidnr) = @_;
+
+ my ($Names, $AARoot, $AAPage, $AcroForm);
+ @skapa = ();
+
+ my ($res, $corr, $nyDel1, @objData, $del1, $del2, $utrad);
+ my $fSource = $infil . '_' . $sidnr;
+
+ $behandlad{$infil}->{old} = {}
+ unless (defined $behandlad{$infil}->{old});
+ $processed{$infil}->{oldObject} = {}
+ unless (defined $processed{$infil}->{oldObject});
+ $processed{$infil}->{unZipped} = {}
+ unless (defined $processed{$infil}->{unZipped});
+
+ *old = $behandlad{$infil}->{old};
+ *oldObject = $processed{$infil}->{oldObject};
+ *unZipped = $processed{$infil}->{unZipped};
+
+ my @stati = stat($infil);
+ if ($form{$fSource}[fID] != $stati[9])
+ { print "$stati[9] ne $form{$fSource}[fID]\n";
+ errLog("Modification time for $fSource has changed, aborting");
+ }
+
+ open (INFIL, "<$infil") || errLog("The file $infil couldn't be opened, aborting $!");
+ binmode INFIL;
+
+ my $fdSidnr = $intAct{$fSource}[iSTARTSIDA];
+ $old{$fdSidnr} = $sidObjNr;
+
+ if (($intAct{$fSource}[iNAMES]) ||(scalar @jsfiler) || (scalar @inits) || (scalar %fields))
+ { $Names = behandlaNames($intAct{$fSource}[iNAMES], $fSource);
+ }
+
+ ##################################
+ # Referenser behandlas och skrivs
+ ##################################
+
+ if (defined $intAct{$fSource}[iACROFORM])
+ { $AcroForm = $intAct{$fSource}[iACROFORM];
+ $AcroForm =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs;
+ }
+ if (defined $intAct{$fSource}[iAAROOT])
+ { $AARoot = $intAct{$fSource}[iAAROOT];
+ $AARoot =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs;
+ }
+
+ if (defined $intAct{$fSource}[iAAPAGE])
+ { $AAPage = $intAct{$fSource}[iAAPAGE];
+ $AAPage =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs;
+ }
+ if (defined $intAct{$fSource}[iANNOTS])
+ { for (@{$intAct{$fSource}[iANNOTS]})
+ { push @annots, quickxform($_);
+ }
+ }
+
+ ##################################
+ # Skriv ut underordnade objekt
+ ##################################
+ while (scalar @skapa)
+ { my @process = @skapa;
+ @skapa = ();
+ for (@process)
+ { my $gammal = $$_[0];
+ my $ny = $$_[1];
+
+ my $oD = \@{$intAct{$fSource}[0]->{$gammal}};
+ @objData = @{$$oD[oNR]};
+
+ if (defined $$oD[oSTREAMP])
+ { $res = sysseek INFIL, ($objData[0] + $$oD[oPOS]), 0;
+ $corr = sysread INFIL, $del1, ($$oD[oSTREAMP] - $$oD[oPOS]) ;
+ if (defined $$oD[oKIDS])
+ { $del1 =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs;
+ }
+ $res = sysread INFIL, $del2, ($objData[1] - $corr);
+ $utrad = "$ny 0 obj\n<<" . $del1 . $del2;
+ }
+ else
+ { $del1 = getObject($gammal);
+ $del1 = substr($del1, $$oD[oPOS]);
+ if (defined $$oD[oKIDS])
+ { $del1 =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs;
+ }
+ $utrad = "$ny 0 obj " . $del1;
+ }
+
+ $objekt[$ny] = $pos;
+ $pos += syswrite UTFIL, $utrad;
+ }
+ }
+
+ close INFIL;
+ return ($Names, $AARoot, $AAPage, $AcroForm);
+}
+
+##############################
+# Ett namnobjekt extraheras
+##############################
+
+sub extractName
+{ my ($infil, $sidnr, $namn) = @_;
+
+ my ($res, $del1, $resType, $key, $corr, $formRes, $kids, $nr, $utrad);
+ my $del2 = '';
+ @skapa = ();
+
+ $behandlad{$infil}->{old} = {}
+ unless (defined $behandlad{$infil}->{old});
+ $processed{$infil}->{oldObject} = {}
+ unless (defined $processed{$infil}->{oldObject});
+ $processed{$infil}->{unZipped} = {}
+ unless (defined $processed{$infil}->{unZipped});
+
+ *old = $behandlad{$infil}->{old};
+ *oldObject = $processed{$infil}->{oldObject};
+ *unZipped = $processed{$infil}->{unZipped};
+
+ my $fSource = $infil . '_' . $sidnr;
+
+ my @stati = stat($infil);
+
+ if ($form{$fSource}[fID] != $stati[9])
+ { errLog("$stati[9] ne $form{$fSource}[fID] aborts");
+ }
+ if ($checkId)
+ { if ($checkId ne $stati[9])
+ { my $mess = "$checkId \<\> $stati[9] \n"
+ . "The Pdf-file $fSource has not the correct modification time. \n"
+ . "The program is aborted";
+ errLog($mess);
+ }
+ undef $checkId;
+ }
+ if ($ldir)
+ { $log .= "Cid~$stati[9]\n";
+ }
+
+ open (INFIL, "<$infil") || errLog("The file $infil couldn't be opened, aborting $!");
+ binmode INFIL;
+
+ #################################
+ # Resurserna läses
+ #################################
+
+ $formRes = $form{$fSource}->[fRESOURCE];
+
+ if ($formRes !~ m'<<.*>>'os) # If not a directory, get it
+ { if ($formRes =~ m'\b(\d+)\s{1,2}\d+\s{1,2}R'o)
+ { $key = $1;
+ $formRes = getKnown(\$form{$fSource}, $key);
+ }
+ else
+ { return undef;
+ }
+ }
+ undef $key;
+ while ($formRes =~ m'\/(\w+)\s*\<\<([^>]+)\>\>'osg)
+ { $resType = $1;
+ my $str = $2;
+ if ($str =~ m|$namn\s+(\d+)\s{1,2}\d+\s{1,2}R|s)
+ { $key = $1;
+ last;
+ }
+ }
+ if (! defined $key) # Try to expand the references
+ { my ($str, $del1, $del2);
+ while ($formRes =~ m'(\/\w+)\s+(\d+)\s{1,2}\d+\s{1,2}R'ogs)
+ { $str .= $1 . ' ';
+ ($del1, $del2) = getKnown(\$form{$fSource}, $2);
+ my $string = $$del1;
+ $str .= $string . ' ';
+ }
+ $formRes = $str;
+ while ($formRes =~ m'\/(\w+)\s*\<\<([^>]+)\>\>'osg)
+ { $resType = $1;
+ my $str = $2;
+ if ($str =~ m|$namn (\d+)\s{1,2}\d+\s{1,2}R|s)
+ { $key = $1;
+ last;
+ }
+ }
+ return undef unless $key;
+ }
+
+ ########################################
+ # Read the top object of the hierarchy
+ ########################################
+
+ ($del1, $del2) = getKnown(\$form{$fSource}, $key);
+
+ $objNr++;
+ $nr = $objNr;
+
+ if ($resType eq 'Font')
+ { my ($Font, $extNamn);
+ if ($$del1 =~ m'/BaseFont\s*/([^\s\/]+)'os)
+ { $extNamn = $1;
+ if (! exists $font{$extNamn})
+ { $fontNr++;
+ $Font = 'Ft' . $fontNr;
+ $font{$extNamn}[foINTNAMN] = $Font;
+ $font{$extNamn}[foORIGINALNR] = $nr;
+ if ($del1 =~ m'/Subtype\s*/Type0'os)
+ { $font{$extNamn}[foTYP] = 1;
+ }
+ $fontSource{$Font}[foSOURCE] = $fSource;
+ $fontSource{$Font}[foORIGINALNR] = $nr;
+ }
+ $font{$extNamn}[foREFOBJ] = $nr;
+ $Font = $font{$extNamn}[foINTNAMN];
+ $namn = $Font;
+ $objRef{$Font} = $nr;
+ }
+ else
+ { errLog("Inconsitency in $fSource, font $namn can't be found, aborting");
+ }
+ }
+ elsif ($resType eq 'ColorSpace')
+ { $colorSpace++;
+ $namn = 'Cs' . $colorSpace;
+ $objRef{$namn} = $nr;
+ }
+ elsif ($resType eq 'Pattern')
+ { $pattern++;
+ $namn = 'Pt' . $pattern;
+ $objRef{$namn} = $nr;
+ }
+ elsif ($resType eq 'Shading')
+ { $shading++;
+ $namn = 'Sh' . $shading;
+ $objRef{$namn} = $nr;
+ }
+ elsif ($resType eq 'ExtGState')
+ { $gSNr++;
+ $namn = 'Gs' . $gSNr;
+ $objRef{$namn} = $nr;
+ }
+ elsif ($resType eq 'XObject')
+ { if (defined $form{$fSource}->[0]->{$nr}->[oIMAGENR])
+ { $namn = 'Ig' . $form{$fSource}->[0]->{$nr}->[oIMAGENR];
+ }
+ else
+ { $formNr++;
+ $namn = 'Fo' . $formNr;
+ }
+
+ $objRef{$namn} = $nr;
+ }
+
+ $$del1 =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs;
+
+ if (defined $$del2)
+ { $utrad = "$nr 0 obj\n<<" . $$del1 . $$del2;
+ }
+ else
+ { $utrad = "$nr 0 obj " . $$del1;
+ }
+ $objekt[$nr] = $pos;
+ $pos += syswrite UTFIL, $utrad;
+
+ ##################################
+ # Skriv ut underordnade objekt
+ ##################################
+
+ while (scalar @skapa)
+ { my @process = @skapa;
+ @skapa = ();
+ for (@process)
+ { my $gammal = $$_[0];
+ my $ny = $$_[1];
+
+ ($del1, $del2, $kids) = getKnown(\$form{$fSource}, $gammal);
+
+ $$del1 =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs
+ unless (! defined $kids);
+ if (defined $$del2)
+ { $utrad = "$ny 0 obj\n<<" . $$del1 . $$del2;
+ }
+ else
+ { $utrad = "$ny 0 obj " . $$del1;
+ }
+ $objekt[$ny] = $pos;
+ $pos += syswrite UTFIL, $utrad;
+ }
+ }
+ close INFIL;
+
+ return $namn;
+
+}
+
+########################
+# Ett objekt extraheras
+########################
+
+sub extractObject
+{ no warnings;
+ my ($infil, $sidnr, $key, $typ) = @_;
+
+ my ($res, $del1, $corr, $namn, $kids, $nr, $utrad);
+ my $del2 = '';
+ @skapa = ();
+
+ $behandlad{$infil}->{old} = {}
+ unless (defined $behandlad{$infil}->{old});
+ $processed{$infil}->{oldObject} = {}
+ unless (defined $processed{$infil}->{oldObject});
+ $processed{$infil}->{unZipped} = {}
+ unless (defined $processed{$infil}->{unZipped});
+
+ *old = $behandlad{$infil}->{old};
+ *oldObject = $processed{$infil}->{oldObject};
+ *unZipped = $processed{$infil}->{unZipped};
+
+ my $fSource = $infil . '_' . $sidnr;
+ my @stati = stat($infil);
+
+ if ($form{$fSource}[fID] != $stati[9])
+ { errLog("$stati[9] ne $form{$fSource}[fID] aborts");
+ }
+ if ($checkId)
+ { if ($checkId ne $stati[9])
+ { my $mess = "$checkId \<\> $stati[9] \n"
+ . "The Pdf-file $fSource has not the correct modification time. \n"
+ . "The program is aborted";
+ errLog($mess);
+ }
+ undef $checkId;
+ }
+ if ($ldir)
+ { $log .= "Cid~$stati[9]\n";
+ my $indata = prep($infil);
+ $log .= "Form~$indata~$sidnr~~load~1\n";
+ }
+
+ open (INFIL, "<$infil") || errLog("The file $infil couldn't be opened, aborting $!");
+ binmode INFIL;
+
+ ########################################
+ # Read the top object of the hierarchy
+ ########################################
+
+ ($del1, $del2, $kids) = getKnown(\$form{$fSource}, $key);
+
+ if (exists $old{$key})
+ { $nr = $old{$key}; }
+ else
+ { $old{$key} = ++$objNr;
+ $nr = $objNr;
+ }
+
+ if ($typ eq 'Font')
+ { my ($Font, $extNamn);
+ if ($$del1 =~ m'/BaseFont\s*/([^\s\/]+)'os)
+ { $extNamn = $1;
+ $fontNr++;
+ $Font = 'Ft' . $fontNr;
+ $font{$extNamn}[foINTNAMN] = $Font;
+ $font{$extNamn}[foORIGINALNR] = $key;
+ if ($del1 =~ m'/Subtype\s*/Type0'os)
+ { $font{$extNamn}[foTYP] = 1;
+ }
+ if ( ! defined $fontSource{$extNamn}[foSOURCE])
+ { $fontSource{$extNamn}[foSOURCE] = $fSource;
+ $fontSource{$extNamn}[foORIGINALNR] = $key;
+ }
+ $font{$extNamn}[foREFOBJ] = $nr;
+ $Font = $font{$extNamn}[foINTNAMN];
+ $namn = $Font;
+ $objRef{$Font} = $nr;
+ }
+ else
+ { errLog("Error in $fSource, $key is not a font, aborting");
+ }
+ }
+ elsif ($typ eq 'ColorSpace')
+ { $colorSpace++;
+ $namn = 'Cs' . $colorSpace;
+ $objRef{$namn} = $nr;
+ }
+ elsif ($typ eq 'Pattern')
+ { $pattern++;
+ $namn = 'Pt' . $pattern;
+ $objRef{$namn} = $nr;
+ }
+ elsif ($typ eq 'Shading')
+ { $shading++;
+ $namn = 'Sh' . $shading;
+ $objRef{$namn} = $nr;
+ }
+ elsif ($typ eq 'ExtGState')
+ { $gSNr++;
+ $namn = 'Gs' . $gSNr;
+ $objRef{$namn} = $nr;
+ }
+ elsif ($typ eq 'XObject')
+ { if (defined $form{$fSource}->[0]->{$nr}->[oIMAGENR])
+ { $namn = 'Ig' . $form{$fSource}->[0]->{$nr}->[oIMAGENR];
+ }
+ else
+ { $formNr++;
+ $namn = 'Fo' . $formNr;
+ }
+
+ $objRef{$namn} = $nr;
+ }
+
+ $$del1 =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs
+ unless (! defined $kids);
+ if (defined $$del2)
+ { $utrad = "$nr 0 obj\n<<" . $$del1 . $$del2;
+ }
+ else
+ { $utrad = "$nr 0 obj " . $$del1;
+ }
+
+ $objekt[$nr] = $pos;
+ $pos += syswrite UTFIL, $utrad;
+
+ ##################################
+ # Skriv ut underordnade objekt
+ ##################################
+
+ while (scalar @skapa)
+ { my @process = @skapa;
+ @skapa = ();
+ for (@process)
+ { my $gammal = $$_[0];
+ my $ny = $$_[1];
+
+ ($del1, $del2, $kids) = getKnown(\$form{$fSource}, $gammal);
+
+ $$del1 =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs
+ unless (! defined $kids);
+
+ if (defined $$del2)
+ { $utrad = "$ny 0 obj<<" . $$del1 . $$del2;
+ }
+ else
+ { $utrad = "$ny 0 obj " . $$del1;
+ }
+
+ $objekt[$ny] = $pos;
+ $pos += syswrite UTFIL, $utrad;
+ }
+ }
+ close INFIL;
+ return $namn;
+}
+
+
+##########################################
+# En fil analyseras och sidorna kopieras
+##########################################
+
+sub analysera
+{ my $infil = shift;
+ my $from = shift || 1;
+ my $to = shift || 0;
+ my $singlePage = shift;
+ my ($i, $res, @underObjekt, @sidObj, $vektor, $resources, $valid,
+ $strPos, $sidor, $filId, $Root, $del1, $del2, $utrad);
+
+ my $extraherade = 0;
+ my $sidAcc = 0;
+ @skapa = ();
+
+ $behandlad{$infil}->{old} = {}
+ unless (defined $behandlad{$infil}->{old});
+ $processed{$infil}->{oldObject} = {}
+ unless (defined $processed{$infil}->{oldObject});
+ $processed{$infil}->{unZipped} = {}
+ unless (defined $processed{$infil}->{unZipped});
+ *old = $behandlad{$infil}->{old};
+ *oldObject = $processed{$infil}->{oldObject};
+ *unZipped = $processed{$infil}->{unZipped};
+
+ $root = (exists $processed{$infil}->{root})
+ ? $processed{$infil}->{root} : 0;
+
+ my ($AcroForm, $Annots, $Names, $AARoot);
+ undef $taInterAkt;
+ undef %script;
+
+ my $checkIdOld = $checkId;
+ ($infil, $checkId) = findGet($infil, $checkIdOld);
+ if (($ldir) && ($checkId) && ($checkId ne $checkIdOld))
+ { $log .= "Cid~$checkId\n";
+ }
+ undef $checkId;
+ my @stati = stat($infil);
+ open (INFIL, "<$infil") || errLog("Couldn't open $infil,aborting. $!");
+ binmode INFIL;
+
+ if (! $root)
+ { $root = xRefs($stati[7], $infil);
+ }
+ #############
+ # Hitta root
+ #############
+
+ my $offSet;
+ my $bytes;
+ my $objektet = getObject($root);
+
+ if ((! $interActive) && ( ! $to) && ($from == 1))
+ { if ($objektet =~ m'/AcroForm(\s+\d+\s{1,2}\d+\s{1,2}R)'so)
+ { $AcroForm = $1;
+ }
+ if ($objektet =~ m'/Names\s+(\d+)\s{1,2}\d+\s{1,2}R'so)
+ { $Names = $1;
+ }
+ if ((scalar %fields) || (scalar @jsfiler) || (scalar @inits))
+ { $Names = behandlaNames($Names);
+ }
+ elsif ($Names)
+ { $Names = quickxform($Names);
+ }
+
+ #################################################
+ # Finns ett dictionary för Additional Actions ?
+ #################################################
+ if ($objektet =~ m'/AA(\s+\d+\s{1,2}\d+\s{1,2}R)'os) # Hänvisning
+ { $AARoot = $1; }
+ elsif ($objektet =~ m'/AA\s*\<\<\s*[^\>]+[^\>]+'so) # AA är ett dictionary
+ { my $k;
+ my ($dummy, $obj) = split /\/AA/, $objektet;
+ $obj =~ s/\<\</\#\<\</gs;
+ $obj =~ s/\>\>/\>\>\#/gs;
+ my @ord = split /\#/, $obj;
+ for ($i = 0; $i <= $#ord; $i++)
+ { $AARoot .= $ord[$i];
+ if ($ord[$i] =~ m'\S+'os)
+ { if ($ord[$i] =~ m'<<'os)
+ { $k++; }
+ if ($ord[$i] =~ m'>>'os)
+ { $k--; }
+ if ($k == 0)
+ { last; }
+ }
+ }
+ }
+ $taInterAkt = 1; # Flagga att ta med interaktiva funktioner
+ }
+
+ #
+ # Hitta pages
+ #
+
+ if ($objektet =~ m'/Pages\s+(\d+)\s{1,2}\d+\s{1,2}R'os)
+ { $objektet = getObject($1);
+ $resources = checkResources($objektet, $resources);
+ if ($objektet =~ m'/Count\s+(\d+)'os)
+ { $sidor = $1;
+ $behandlad{$infil}->{sidor} = $sidor;
+ }
+ }
+ else
+ { errLog("Didn't find pages "); }
+
+ my @levels; my %kids;
+ my $li = -1;
+
+ if ($objektet =~ m'/Kids\s*\[([^\]]+)'os)
+ { $vektor = $1;
+ while ($vektor =~ m'(\d+)\s{1,2}\d+\s{1,2}R'go)
+ { push @sidObj, $1;
+ }
+ $li++;
+ $levels[$li] = \@sidObj;
+ }
+
+ while (($li > -1) && ($sidAcc < $sidor))
+ { if (scalar @{$levels[$li]})
+ { my $j = shift @{$levels[$li]};
+ $objektet = getObject($j);
+ if ($objektet =~ m'/Kids\s*\[([^\]]+)'os)
+ { $resources = checkResources($objektet, $resources);
+ $vektor = $1;
+ my @sObj;
+ while ($vektor =~ m'(\d+)\s{1,2}\d+\s{1,2}R'go)
+ { push @sObj, $1 if !$kids{$1}; $kids{$1}=1;
+ }
+ if(@sObj)
+ { $li++;
+ $levels[$li] = \@sObj;
+ }
+ }
+ else
+ { $sidAcc++;
+ if ($sidAcc >= $from)
+ { if ($to)
+ { if ($sidAcc <= $to)
+ { sidAnalys($j, $objektet, $resources);
+ $extraherade++;
+ $sida++;
+ }
+ else
+ { $sidAcc = $sidor;
+ }
+ }
+ else
+ { sidAnalys($j, $objektet, $resources);
+ $extraherade++;
+ $sida++;
+ }
+ }
+ }
+ }
+ else
+ { $li--;
+ }
+ }
+
+ if (defined $AcroForm)
+ { $AcroForm =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs;
+ }
+ if (defined $AARoot)
+ { $AARoot =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs;
+ }
+
+ while (scalar @skapa)
+ { my @process = @skapa;
+ @skapa = ();
+ for (@process)
+ { my $gammal = $$_[0];
+ my $ny = $$_[1];
+ $objektet = getObject($gammal);
+
+ if ($objektet =~ m'^(\d+ \d+ obj\s*<<)(.+)(>>\s*stream)'os)
+ { $del1 = $2;
+ $strPos = length($2) + length($3) + length($1);
+ $del1 =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs;
+ $objekt[$ny] = $pos;
+ $utrad = "$ny 0 obj<<" . "$del1" . '>>stream';
+ $del2 = substr($objektet, $strPos);
+ $utrad .= $del2;
+
+ $pos += syswrite UTFIL, $utrad;
+ }
+ else
+ { if ($objektet =~ m'^(\d+ \d+ obj)'os)
+ { my $preLength = length($1);
+ $objektet = substr($objektet, $preLength);
+ }
+ $objektet =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs;
+ $objekt[$ny] = $pos;
+ $utrad = "$ny 0 obj$objektet";
+ $pos += syswrite UTFIL, $utrad;
+ }
+ }
+ }
+ close INFIL;
+ $processed{$infil}->{root} = $root;
+
+ if (! $singlePage)
+ { return ($extraherade, $Names, $AARoot, $AcroForm);
+ }
+ else
+ { if ($extraherade)
+ { my $kvar = $behandlad{$infil}->{sidor} - $from;
+ return ($kvar, $Names, $AARoot, $AcroForm);
+ }
+ else
+ { return (undef, undef, undef, undef);
+ }
+ }
+}
+
+sub sidAnalys
+{ my ($oNr, $obj, $resources) = @_;
+ my ($ny, $strPos, $spar, $closeProc, $del1, $del2, $utrad, $Annots,
+ $resursObjekt, $streamObjekt, @extObj, $langd);
+
+ if ((defined $stream) && (length($stream) > 0))
+ {
+ if ($checkCs)
+ { @extObj = ($stream =~ m'/(\S+)\s*'gso);
+ checkContentStream(@extObj);
+ }
+
+ $objNr++;
+ $objekt[$objNr] = $pos;
+
+ if (( $compress ) && ( length($stream) > 99 ))
+ { my $output = compress($stream);
+ if ((length($output) > 25) && (length($output) < (length($stream))))
+ { $stream = $output;
+ }
+ $langd = length($stream);
+ $stream = "\n" . $stream . "\n";
+ $langd++;
+ $streamObjekt = "$objNr 0 obj<</Filter/FlateDecode"
+ . "/Length $langd>>stream" . $stream;
+ $streamObjekt .= "endstream\nendobj\n";
+
+ }
+ else
+ { $langd = length($stream);
+ $streamObjekt = "$objNr 0 obj<</Length $langd>>stream\n" . $stream;
+ $streamObjekt .= "\nendstream\nendobj\n";
+ }
+ $pos += syswrite UTFIL, $streamObjekt;
+ $streamObjekt = "$objNr 0 R ";
+
+ ########################################################################
+ # Sometimes the contents reference is a ref to an object which
+ # contains an array of content streams. Replace the ref with the array
+ ########################################################################
+
+ if ($obj =~ m'/Contents\s+(\d+)\s{1,2}\d+\s{1,2}R'os)
+ { my $cObj = getObject($1, 1, 1);
+ if ($cObj =~ m'^\s*\[[^\]]+\]\s*$'os)
+ { $obj =~ s|/Contents\s+\d+\s{1,2}\d+\s{1,2}R|'/Contents ' . $cObj|oes;
+ }
+ }
+
+ my ($from, $to);
+
+ ($resources, $from, $to) = checkResources ($obj, $resources);
+ if ($from && $to)
+ { $obj = substr($obj, 0, $from) . substr($obj, $to);
+ }
+
+
+ ##########################
+ # Hitta resursdictionary
+ ##########################
+ my $i = 0;
+ while (($resources !~ m'\/'os) && ($i < 10))
+ { $i++;
+ if ($resources =~ m'\s+(\d+)\s{1,2}\d+\s{1,2}R'os)
+ { $resources = getObject($1, 1, 1);
+ }
+ }
+ if ($i > 7)
+ { errLog("Couldn't find resources to merge");
+ }
+ if ($resources =~ m'\s*\<\<(.*)\>\>'os)
+ { $resources = $1;
+ }
+
+ if ($resources !~ m'/ProcSet')
+ { $resources = '/ProcSet[/PDF/Text] ' . $resources;
+ }
+
+ ###############################################################
+ # Läsa ev. referenser och skapa ett resursobjekt bestående av
+ # dictionaries (för utvalda resurser)
+ ###############################################################
+
+ if (scalar %sidFont)
+ { if ($resources =~ m'/Font\s+(\d+)\s{1,2}\d+\s{1,2}R'os)
+ { my $dict = getObject($1, 1, 1);
+ $resources =~ s"/Font\s+\d+\s{1,2}\d+\s{1,2}R"'/Font' . $dict"ose;
+ }
+ }
+
+ if (scalar %sidXObject)
+ { if ($resources =~ m'/XObject\s+(\d+)\s{1,2}\d+\s{1,2}R'os)
+ { my $dict = getObject($1, 1, 1);
+ $resources =~ s"/XObject\s+\d+\s{1,2}\d+\s{1,2}R"'/XObject' . $dict"ose;
+ }
+ }
+
+ if (scalar %sidExtGState)
+ { if ($resources =~ m'/ExtGState\s+(\d+)\s{1,2}\d+\s{1,2}R'os)
+ { my $dict = getObject($1, 1, 1);
+ $resources =~ s"/ExtGState\s+\d+\s{1,2}\d+\s{1,2}R"'/ExtGState' . $dict"ose;
+ }
+ }
+
+ if (scalar %sidPattern)
+ { if ($resources =~ m'/Pattern\s+(\d+)\s{1,2}\d+\s{1,2}R'os)
+ { my $dict = getObject($1, 1, 1);
+ $resources =~ s"/Pattern\s+\d+\s{1,2}\d+\s{1,2}R"'/Pattern' . $dict"ose;
+ }
+ }
+
+ if (scalar %sidShading)
+ { if ($resources =~ m'/Shading\s+(\d+)\s{1,2}\d+\s{1,2}R'os)
+ { my $dict = getObject($1, 1, 1);
+ $resources =~ s"/Shading\s+\d+\s{1,2}\d+\s{1,2}R"'/Shading' . $dict"ose;
+ }
+ }
+
+ if (scalar %sidColorSpace)
+ { if ($resources =~ m'/ColorSpace\s+(\d+)\s{1,2}\d+\s{1,2}R'os)
+ { my $dict = getObject($1, 1, 1);
+ $resources =~ s"/ColorSpace\s+\d+\s{1,2}\d+\s{1,2}R"'/ColorSpace' . $dict"ose;
+ }
+ }
+ ####################################################
+ # Nu är resurserna "normaliserade" med ursprungliga
+ # värden. Spara värden för "översättning"
+ ####################################################
+
+ $resources =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs;
+
+ ###############################
+ # Komplettera med nya resurser
+ ###############################
+
+ if (scalar %sidFont)
+ { my $str = '';
+ for (sort keys %sidFont)
+ { $str .= "/$_ $sidFont{$_} 0 R";
+ }
+ if ($resources !~ m'\/Font'os)
+ { $resources = "/Font << $str >> " . $resources;
+ }
+ else
+ { $resources =~ s"/Font\s*<<"'/Font<<' . $str"oges;
+ }
+ }
+
+ if (scalar %sidXObject)
+ { my $str = '';
+ for (sort keys %sidXObject)
+ { $str .= "/$_ $sidXObject{$_} 0 R";
+ }
+ if ($resources !~ m'\/XObject'os)
+ { $resources = "/XObject << $str >> " . $resources;
+ }
+ else
+ { $resources =~ s"/XObject\s*<<"'/XObject<<' . $str"oges;
+ }
+ }
+
+ if (scalar %sidExtGState)
+ { my $str = '';
+ for (sort keys %sidExtGState)
+ { $str .= "/$_ $sidExtGState{$_} 0 R";
+ }
+ if ($resources !~ m'\/ExtGState'os)
+ { $resources = "/ExtGState << $str >> " . $resources;
+ }
+ else
+ { $resources =~ s"/ExtGState\s*<<"'/ExtGState<<' . $str"oges;
+ }
+ }
+
+ if (scalar %sidPattern)
+ { my $str = '';
+ for (sort keys %sidPattern)
+ { $str .= "/$_ $sidPattern{$_} 0 R";
+ }
+ if ($resources !~ m'\/Pattern'os)
+ { $resources = "/Pattern << $str >> " . $resources;
+ }
+ else
+ { $resources =~ s"/Pattern\s*<<"'/Pattern<<' . $str"oges;
+ }
+ }
+
+ if (scalar %sidShading)
+ { my $str = '';
+ for (sort keys %sidShading)
+ { $str .= "/$_ $sidShading{$_} 0 R";
+ }
+ if ($resources !~ m'\/Shading'os)
+ { $resources = "/Shading << $str >> " . $resources;
+ }
+ else
+ { $resources =~ s"/Shading\s*<<"'/Shading<<' . $str"oges;
+ }
+ }
+
+ if (scalar %sidColorSpace)
+ { my $str = '';
+ for (sort keys %sidColorSpace)
+ { $str .= "/$_ $sidColorSpace{$_} 0 R";
+ }
+ if ($resources !~ m'\/ColorSpace'os)
+ { $resources = "/ColorSpace << $str >> " . $resources;
+ }
+ else
+ { $resources =~ s"/ColorSpace\s*<<"'/ColorSpace<<' . $str"oges;
+ }
+ }
+
+ if (exists $resurser{$resources})
+ { $resources = "$resurser{$resources} 0 R\n"; # Fanns ett identiskt,
+ } # använd det
+ else
+ { $objNr++;
+ if ( keys(%resurser) < 10)
+ { $resurser{$resources} = $objNr; # Spara 10 första resursobjekten
+ }
+ $objekt[$objNr] = $pos;
+ $resursObjekt = "$objNr 0 obj<<$resources>>endobj\n";
+ $pos += syswrite UTFIL, $resursObjekt ;
+ $resources = "$objNr 0 R\n";
+ }
+
+ %sidXObject = ();
+ %sidExtGState = ();
+ %sidFont = ();
+ %sidPattern = ();
+ %sidShading = ();
+ %sidColorSpace = ();
+ undef $checkCs;
+
+ $stream = '';
+ }
+
+ if (! $parents[0])
+ { $objNr++;
+ $parents[0] = $objNr;
+ }
+ my $parent = $parents[0];
+
+ if (($sidObjNr) && (! defined $objekt[$sidObjNr]))
+ { $ny = $sidObjNr;
+ }
+ else
+ { $objNr++;
+ $ny = $objNr;
+ }
+
+ $old{$oNr} = $ny;
+
+ if ($obj =~ m'/Parent\s+(\d+)\s{1,2}\d+\s{1,2}R\b'os)
+ { $old{$1} = $parent;
+ }
+
+ if ($obj =~ m'^\d+ \d+ obj\s*<<(.+)>>\s*endobj'os)
+ { $del1 = $1;
+ }
+
+ if (%links)
+ { my $tSida = $sida + 1;
+ if ((%links && @{$links{'-1'}}) || (%links && @{$links{$tSida}}))
+ { if ($del1 =~ m'/Annots\s*([^\/\<\>]+)'os)
+ { $Annots = $1;
+ @annots = ();
+ if ($Annots =~ m'\[([^\[\]]*)\]'os)
+ { ; }
+ else
+ { if ($Annots =~ m'\b(\d+)\s{1,2}\d+\s{1,2}R\b'os)
+ { $Annots = getObject($1);
+ }
+ }
+ while ($Annots =~ m'\b(\d+)\s{1,2}\d+\s{1,2}R\b'ogs)
+ { push @annots, xform();
+ }
+ $del1 =~ s?/Annots\s*([^\/\<\>]+)??os;
+ }
+ $Annots = '/Annots ' . mergeLinks() . ' 0 R';
+ }
+ }
+
+ if (! $taInterAkt)
+ { $del1 =~ s?\s*/AA\s*<<[^>]*>>??os;
+ }
+
+ $del1 =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs;
+
+ if ($del1 !~ m'/Resources'o)
+ { $del1 .= "/Resources $resources";
+ }
+
+ if (defined $streamObjekt) # En ny ström ska läggas till
+ { if ($del1 =~ m'/Contents\s+(\d+)\s{1,2}\d+\s{1,2}R'os)
+ { my $oldCont = $1;
+ $del1 =~ s|/Contents\s+(\d+)\s{1,2}\d+\s{1,2}R|'/Contents [' . "$oldCont 0 R $streamObjekt" . ']'|oes;
+ }
+ elsif ($del1 =~ m'/Contents\s*\['os)
+ { $del1 =~ s|/Contents\s*\[([^\]]+)|'/Contents [' . $1 ." $streamObjekt"|oes;
+ }
+ else
+ { $del1 .= "/Contents $streamObjekt\n";
+ }
+ }
+
+ if ($Annots)
+ { $del1 .= $Annots;
+ }
+
+ $utrad = "$ny 0 obj<<$del1>>";
+ if (defined $del2)
+ { $utrad .= "stream\n$del2";
+ }
+ else
+ { $utrad .= "endobj\n";
+ }
+
+ $objekt[$ny] = $pos;
+ $pos += syswrite UTFIL, $utrad;
+
+ push @{$kids[0]}, $ny;
+ $counts[0]++;
+ if ($counts[0] > 9)
+ { ordnaNoder(8);
+ }
+}
+
+
+sub checkResources
+{ my $pObj = shift;
+ my $reStr = shift;
+ my $to;
+
+ my $p = index($pObj, '/Resources');
+ if ( $p < 0)
+ { ;
+ }
+ elsif ($pObj =~ m'/Resources(\s+\d+\s{1,2}\d+\s{1,2}R)'os)
+ { $reStr = $1;
+ $to = $p + 10 + length($reStr);
+ }
+ else
+ { my $t = length($pObj);
+ my $i = $p + 10;
+ my $j = $i;
+ my $k = 0;
+ my $c;
+ while ($i < $t)
+ { $c = substr($pObj,$i,1);
+ if (($c eq '<' )
+ || ($c eq '>'))
+ { if ($c eq '<' )
+ { $k++;
+ }
+ else
+ { $k--;
+ }
+ last if ($k == 0);
+ }
+ $i++;
+ }
+ if ($i != $t)
+ { $i++;
+ $reStr = substr($pObj, $j, ($i - $j));
+ $to = $i;
+ }
+ }
+
+ if (wantarray)
+ { return ($reStr, $p, $to);
+ }
+ else
+ { return $reStr;
+ }
+}
+
+
+sub translate
+{ if (exists $old{$1})
+ { $old{$1}; }
+ else
+ { $old{$1} = ++$objNr;
+ }
+}
+
+sub behandlaNames
+{ my ($namnObj, $iForm) = @_;
+
+ my ($low, $high, $antNod0, $entry, $nyttNr, $ny, $obj,
+ $fObjnr, $offSet, $bytes, $res, $key, $func, $corr, @objData);
+ my (@nod0, @nodUpp, @kid, @soek, %nytt);
+
+ my $objektet = '';
+ my $vektor = '';
+ my $antal = 0;
+ my $antNodUpp = 0;
+ if ($namnObj)
+ { if ($iForm) # Läsning via interntabell
+ { $objektet = getObject($namnObj, 1);
+
+ if ($objektet =~ m'<<(.+)>>'ogs)
+ { $objektet = $1; }
+ if ($objektet =~ s'/JavaScript\s+(\d+)\s{1,2}\d+\s{1,2}R''os)
+ { my $byt = $1;
+ push @kid, $1;
+ while (scalar @kid)
+ { @soek = @kid;
+ @kid = ();
+ for my $sObj (@soek)
+ { $obj = getObject($sObj, 1);
+ if ($obj =~ m'/Kids\s*\[([^]]+)'ogs)
+ { $vektor = $1;
+ }
+ while ($vektor =~ m'\b(\d+)\s{1,2}\d+\s{1,2}R\b'ogs)
+ { push @kid, $1;
+ }
+ $vektor = '';
+ if ($obj =~ m'/Names\s*\[([^]]+)'ogs)
+ { $vektor = $1;
+ }
+ while ($vektor =~ m'\(([^\)]+)\)\s*(\d+) \d R'gos)
+ { $script{$1} = $2;
+ }
+ }
+ }
+ }
+ }
+ else # Läsning av ett "doc"
+ { $objektet = getObject($namnObj);
+ if ($objektet =~ m'<<(.+)>>'ogs)
+ { $objektet = $1; }
+ if ($objektet =~ s'/JavaScript\s+(\d+)\s{1,2}\d+\s{1,2}R''os)
+ { my $byt = $1;
+ push @kid, $1;
+ while (scalar @kid)
+ { @soek = @kid;
+ @kid = ();
+ for my $sObj (@soek)
+ { $obj = getObject($sObj);
+ if ($obj =~ m'/Kids\s*\[([^]]+)'ogs)
+ { $vektor = $1;
+ }
+ while ($vektor =~ m'\b(\d+)\s{1,2}\d+\s{1,2}R\b'ogs)
+ { push @kid, $1;
+ }
+ undef $vektor;
+ if ($obj =~ m'/Names\s*\[([^]]+)'ogs)
+ { $vektor = $1;
+ }
+ while ($vektor =~ m'\(([^\)]+)\)\s*(\d+) \d R'gos)
+ { $script{$1} = $2;
+ }
+ }
+ }
+ }
+ }
+ }
+ for my $filnamn (@jsfiler)
+ { inkludera($filnamn);
+ }
+ my @nya = (keys %nyaFunk);
+ while (scalar @nya)
+ { my @behandla = @nya;
+ @nya = ();
+ for $key (@behandla)
+ { if (exists $initScript{$key})
+ { if (exists $nyaFunk{$key})
+ { $initScript{$key} = $nyaFunk{$key};
+ }
+ if (exists $script{$key}) # företräde för nya funktioner !
+ { delete $script{$key}; # gammalt script m samma namn plockas bort
+ }
+ my @fall = ($initScript{$key} =~ m'([\w\d\_\$]+)\s*\('ogs);
+ for (@fall)
+ { if (($_ ne $key) && (exists $nyaFunk{$_}))
+ { $initScript{$_} = $nyaFunk{$_};
+ push @nya, $_;
+ }
+ }
+ }
+ }
+ }
+ while (($key, $func) = each %nyaFunk)
+ { $fObjnr = skrivJS($func);
+ $script{$key} = $fObjnr;
+ $nytt{$key} = $fObjnr;
+ }
+
+ if (scalar %fields)
+ { push @inits, 'Ladda();';
+ $fObjnr = defLadda();
+ if ($duplicateInits)
+ { $script{'Ladda'} = $fObjnr;
+ $nytt{'Ladda'} = $fObjnr;
+ }
+ }
+
+ if ((scalar @inits) && ($duplicateInits))
+ { $fObjnr = defInit();
+ $script{'Init'} = $fObjnr;
+ $nytt{'Init'} = $fObjnr;
+ }
+ undef @jsfiler;
+
+ for my $key (sort (keys %script))
+ { if (! defined $low)
+ { $objNr++;
+ $ny = $objNr;
+ $objekt[$ny] = $pos;
+ $obj = "$ny 0 obj\n";
+ $low = $key;
+ $obj .= '<< /Names [';
+ }
+ $high = $key;
+ $obj .= '(' . "$key" . ')';
+ if (! exists $nytt{$key})
+ { $nyttNr = quickxform($script{$key});
+ }
+ else
+ { $nyttNr = $script{$key};
+ }
+ $obj .= "$nyttNr 0 R\n";
+ $antal++;
+ if ($antal > 9)
+ { $obj .= ' ]/Limits [(' . "$low" . ')(' . "$high" . ')] >>' . "endobj\n";
+ $pos += syswrite UTFIL, $obj;
+ push @nod0, \[$ny, $low, $high];
+ $antNod0++;
+ undef $low;
+ $antal = 0;
+ }
+ }
+ if ($antal)
+ { $obj .= ']/Limits [(' . $low . ')(' . $high . ')]>>' . "endobj\n";
+ $pos += syswrite UTFIL, $obj;
+ push @nod0, \[$ny, $low, $high];
+ $antNod0++;
+ }
+ $antal = 0;
+
+ while (scalar @nod0)
+ { for $entry (@nod0)
+ { if ($antal == 0)
+ { $objNr++;
+ $objekt[$objNr] = $pos;
+ $obj = "$objNr 0 obj\n";
+ $low = $$entry->[1];
+ $obj .= '<</Kids [';
+ }
+ $high = $$entry->[2];
+ $obj .= " $$entry->[0] 0 R";
+ $antal++;
+ if ($antal > 9)
+ { $obj .= ']/Limits [(' . $low . ')(' . $high . ')]>>' . "endobj\n";
+ $pos += syswrite UTFIL, $obj;
+ push @nodUpp, \[$objNr, $low, $high];
+ $antNodUpp++;
+ undef $low;
+ $antal = 0;
+ }
+ }
+ if ($antal > 0)
+ { if ($antNodUpp == 0) # inget i noderna över
+ { $obj .= ']>>' . "endobj\n";
+ $pos += syswrite UTFIL, $obj;
+ }
+ else
+ { $obj .= ']/Limits [(' . "$low" . ')(' . "$high" . ')]>>' . "endobj\n";
+ $pos += syswrite UTFIL, $obj;
+ push @nodUpp, \[$objNr, $low, $high];
+ $antNodUpp++;
+ undef $low;
+ $antal = 0;
+ }
+ }
+ @nod0 = @nodUpp;
+ $antNod0 = $antNodUpp;
+ undef @nodUpp;
+ $antNodUpp = 0;
+ }
+
+
+ $ny = $objNr;
+ $objektet =~ s|\s*/JavaScript\s*\d+\s{1,2}\d+\s{1,2}R||os;
+ $objektet =~ s/\b(\d+)\s{1,2}\d+\s{1,2}R\b/xform() . ' 0 R'/oegs;
+ if (scalar %script)
+ { $objektet .= "\n/JavaScript $ny 0 R\n";
+ }
+ $objNr++;
+ $ny = $objNr;
+ $objekt[$ny] = $pos;
+ $objektet = "$ny 0 obj<<" . $objektet . ">>endobj\n";
+ $pos += syswrite UTFIL, $objektet;
+ return $ny;
+}
+
+
+sub quickxform
+{ my $inNr = shift;
+ if (exists $old{$inNr})
+ { $old{$inNr}; }
+ else
+ { push @skapa, [$inNr, ++$objNr];
+ $old{$inNr} = $objNr;
+ }
+}
+
+
+sub skrivKedja
+{ my $code = ' ';
+
+ for (values %initScript)
+ { $code .= $_ . "\n";
+ }
+ $code .= "function Init() { ";
+ $code .= 'if (typeof this.info.ModDate == "object")' . " { return true; }";
+ for (@inits)
+ { $code .= $_ . "\n";
+ }
+ $code .= "} Init(); ";
+
+ my $spar = skrivJS($code);
+ undef @inits;
+ undef %initScript;
+ return $spar;
+}
+
+
+
+sub skrivJS
+{ my $kod = shift;
+ my $obj;
+ if (($compress) && (length($kod) > 99))
+ { $objNr++;
+ $objekt[$objNr] = $pos;
+ my $spar = $objNr;
+ $kod = compress($kod);
+ my $langd = length($kod);
+ $obj = "$objNr 0 obj<</Filter/FlateDecode"
+ . "/Length $langd>>stream\n" . $kod
+ . "\nendstream\nendobj\n";
+ $pos += syswrite UTFIL, $obj;
+ $objNr++;
+ $objekt[$objNr] = $pos;
+ $obj = "$objNr 0 obj<</S/JavaScript/JS $spar 0 R >>endobj\n";
+ }
+ else
+ { $kod =~ s'\('\\('gso;
+ $kod =~ s'\)'\\)'gso;
+ $objNr++;
+ $objekt[$objNr] = $pos;
+ $obj = "$objNr 0 obj<</S/JavaScript/JS " . '(' . $kod . ')';
+ $obj .= ">>endobj\n";
+ }
+ $pos += syswrite UTFIL, $obj;
+ return $objNr;
+}
+
+sub inkludera
+{ my $jsfil = shift;
+ my $fil;
+ if ($jsfil !~ m'\{'os)
+ { open (JSFIL, "<$jsfil") || return;
+ while (<JSFIL>)
+ { $fil .= $_;}
+
+ close JSFIL;
+ }
+ else
+ { $fil = $jsfil;
+ }
+ $fil =~ s|function\s+([\w\_\d\$]+)\s*\(|"zXyZcUt function $1 ("|sge;
+ my @funcs = split/zXyZcUt /, $fil;
+ for my $kod (@funcs)
+ { if ($kod =~ m'^function ([\w\_\d\$]+)'os)
+ { $nyaFunk{$1} = $kod;
+ }
+ }
+}
+
+
+sub defLadda
+{ my $code = "function Ladda() {";
+ for (keys %fields)
+ { my $val = $fields{$_};
+ if ($val =~ m'\s*js\s*\:(.+)'oi)
+ { $val = $1;
+ $code .= "if (this.getField('$_')) this.getField('$_').value = $val; ";
+ }
+ else
+ { $val =~ s/([^A-Za-z0-9\-_.!* ])/sprintf("%%%02X", ord($1))/ge;
+ $code .= "if (this.getField('$_')) this.getField('$_').value = unescape('$val'); ";
+ }
+
+ }
+ $code .= " 1;} ";
+
+
+ $initScript{'Ladda'} = $code;
+ if ($duplicateInits)
+ { my $ny = skrivJS($code);
+ return $ny;
+ }
+ else
+ { return 1;
+ }
+}
+
+sub defInit
+{ my $code = "function Init() { ";
+ $code .= 'if (typeof this.info.ModDate == "object")' . " { return true; } ";
+ for (@inits)
+ { $code .= $_ . "\n";
+ }
+ $code .= '}';
+
+ my $ny = skrivJS($code);
+ return $ny;
+
+}
+
+
+
+sub errLog
+{ no strict 'refs';
+ my $mess = shift;
+ my $endMess = " $mess \n More information might be found in";
+ if ($runfil)
+ { $log .= "Log~Err: $mess\n";
+ $endMess .= "\n $runfil";
+ if (! $pos)
+ { $log .= "Log~Err: No pdf-file has been initiated\n";
+ }
+ elsif ($pos > 15000000)
+ { $log .= "Log~Err: Current pdf-file is very big: $pos bytes, will not try to finish it\n";
+ }
+ else
+ { $log .= "Log~Err: Will try to finish current pdf-file\n";
+ $endMess .= "\n $utfil";
+ }
+ }
+ my $errLog = 'error.log';
+ my $now = localtime();
+ my $lpos = $pos || 'undef';
+ my $lobjNr = $objNr || 'undef';
+ my $lutfil = $utfil || 'undef';
+
+ my $lrunfil = $runfil || 'undef';
+ open (ERRLOG, ">$errLog") || croak "$mess can't open an error log, $!";
+ print ERRLOG "\n$mess\n\n";
+ print ERRLOG Carp::longmess("The error occurred when executing:\n");
+ print ERRLOG "\nSituation when the error occurred\n\n";
+ print ERRLOG " Bytes written to the current pdf-file, pos = $lpos\n";
+ print ERRLOG " Object processed, not necessarily written objNr = $lobjNr\n";
+ print ERRLOG " Current pdf-file, utfil = $lutfil\n";
+ print ERRLOG " File logging the run, runfil = $lrunfil\n";
+ print ERRLOG " Local time = $now\n";
+ print ERRLOG "\n\n";
+ close ERRLOG;
+ $endMess .= "\n $errLog";
+ if (($pos) && ($pos < 15000000))
+ { prEnd();
+ }
+ print STDERR Carp::shortmess("An error occurred \n");
+ croak "$endMess\n";
+}
diff --git a/lib/PDF/Reuse/Util.pm b/lib/PDF/Reuse/Util.pm
new file mode 100644
index 0000000..2d603a9
--- /dev/null
+++ b/lib/PDF/Reuse/Util.pm
@@ -0,0 +1,357 @@
+package PDF::Reuse::Util;
+
+use warnings;
+use strict;
+
+use PDF::Reuse;
+
+require Exporter;
+
+our @ISA = qw(Exporter);
+our @EXPORT = qw(hyperLink blackText);
+
+our %font_widths = (
+ 'Courier' => 600,
+ 'Courier-Bold' => 600,
+ 'Courier-BoldOblique' => 600,
+ 'Courier-Oblique' => 600,
+ 'Times-Roman' =>
+ [000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 250, 333, 408, 500, 500, 833, 778, 180,
+ 333, 333, 500, 564, 250, 333, 250, 278,
+ 500, 500, 500, 500, 500, 500, 500, 500,
+ 500, 500, 278, 278, 564, 564, 564, 444,
+ 921, 722, 667, 667, 722, 611, 556, 722,
+ 722, 333, 389, 722, 611, 889, 722, 722,
+ 556, 722, 667, 556, 611, 722, 722, 944,
+ 722, 722, 611, 333, 278, 333, 469, 500,
+ 333, 444, 500, 444, 500, 444, 333, 500,
+ 500, 278, 278, 500, 278, 778, 500, 500,
+ 500, 500, 333, 389, 278, 500, 500, 722,
+ 500, 500, 444, 480, 200, 480, 541, 350,
+ 500, 350, 333, 500, 443, 1000, 500, 500,
+ 333, 1000, 555, 333, 889, 350, 611, 350,
+ 350, 333, 333, 443, 443, 350, 500, 1000,
+ 333, 980, 388, 333, 722, 350, 444, 721,
+ 250, 333, 500, 500, 500, 500, 200, 500,
+ 333, 760, 276, 500, 564, 333, 760, 333,
+ 400, 564, 300, 300, 333, 510, 453, 250,
+ 333, 300, 310, 500, 750, 750, 750, 444,
+ 722, 722, 722, 722, 722, 722, 889, 667,
+ 611, 611, 611, 611, 333, 333, 333, 333,
+ 722, 722, 722, 722, 722, 722, 722, 564,
+ 722, 722, 722, 722, 722, 722, 556, 500,
+ 444, 444, 444, 444, 444, 444, 667, 444,
+ 444, 444, 444, 444, 278, 278, 278, 278,
+ 500, 500, 500, 500, 500, 500, 500, 564,
+ 500, 500, 500, 500, 500, 500, 500, 500],
+ 'Times-Bold' =>
+ [000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 250, 333, 555, 500, 500, 1000, 833, 278,
+ 333, 333, 500, 570, 250, 333, 250, 278,
+ 500, 500, 500, 500, 500, 500, 500, 500,
+ 500, 500, 333, 333, 570, 570, 570, 500,
+ 930, 722, 667, 722, 722, 667, 611, 778,
+ 778, 389, 500, 778, 667, 944, 722, 778,
+ 611, 778, 722, 556, 667, 722, 722, 1000,
+ 722, 722, 667, 333, 278, 333, 581, 500,
+ 333, 500, 556, 444, 556, 444, 333, 500,
+ 556, 278, 333, 556, 278, 833, 556, 500,
+ 556, 556, 444, 389, 333, 556, 500, 722,
+ 500, 500, 444, 394, 220, 394, 520, 350,
+ 500, 350, 333, 500, 500, 1000, 500, 500,
+ 333, 1000, 556, 333, 1000, 350, 667, 350,
+ 350, 333, 333, 500, 500, 350, 500, 1000,
+ 333, 1000, 389, 333, 723, 350, 444, 722,
+ 250, 333, 500, 500, 500, 500, 220, 500,
+ 333, 747, 300, 500, 570, 333, 747, 333,
+ 400, 570, 300, 300, 333, 601, 540, 250,
+ 333, 300, 330, 500, 750, 750, 750, 500,
+ 722, 722, 722, 722, 722, 722, 1000, 722,
+ 667, 667, 667, 667, 389, 389, 389, 389,
+ 722, 722, 778, 778, 778, 778, 778, 570,
+ 778, 722, 722, 722, 722, 722, 611, 556,
+ 500, 500, 500, 500, 500, 500, 722, 444,
+ 444, 444, 444, 444, 278, 278, 278, 278,
+ 500, 556, 500, 500, 500, 500, 500, 570,
+ 500, 556, 556, 556, 556, 500, 556, 500],
+ 'Times-Italic' =>
+ [000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 250, 333, 420, 500, 500, 833, 778, 214, #39
+ 333, 333, 500, 675, 250, 333, 250, 278, #47
+ 500, 500, 500, 500, 500, 500, 500, 500, #55
+ 500, 500, 333, 333, 675, 675, 675, 500, #63
+ 920, 611, 611, 667, 722, 611, 611, 722, #71
+ 722, 333, 444, 667, 556, 833, 667, 722, #79
+ 611, 722, 611, 500, 556, 722, 611, 833, #87
+ 611, 556, 556, 389, 278, 389, 422, 500, #95
+ 333, 500, 500, 444, 500, 444, 278, 500, #103
+ 500, 278, 278, 444, 278, 722, 500, 500, #111
+ 500, 500, 389, 389, 278, 500, 444, 667, #119
+ 444, 444, 389, 400, 275, 400, 541, 350, # 127
+ 500, 350, 333, 500, 556, 889, 500, 500, # 135
+ 333, 1000, 500, 333, 944, 350, 556, 350, # 143
+ 350, 333, 333, 556, 556, 350, 500, 890, # 151
+ 333, 980, 389, 333, 668, 350, 390, 557, # 159
+ 250, 389, 500, 500, 500, 500, 275, 500, # 167
+ 333, 760, 276, 500, 675, 333, 760, 333, # 175
+ 400, 675, 300, 300, 333, 514, 523, 250, # 183
+ 333, 300, 310, 500, 750, 750, 750, 500, # 191
+ 611, 611, 611, 611, 611, 611, 889, 667,
+ 611, 611, 611, 611, 333, 333, 333, 333,
+ 722, 667, 722, 722, 722, 722, 722, 675,
+ 722, 722, 722, 722, 722, 556, 611, 500,
+ 500, 500, 500, 500, 500, 500, 667, 444,
+ 444, 444, 444, 444, 278, 278, 278, 278,
+ 500, 500, 500, 500, 500, 500, 500, 675,
+ 500, 500, 500, 500, 500, 444, 500, 444],
+
+ 'Times-BoldItalic' =>
+ [000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 250, 389, 555, 500, 500, 833, 778, 278,
+ 333, 333, 500, 570, 250, 333, 250, 278,
+ 500, 500, 500, 500, 500, 500, 500, 500,
+ 500, 500, 333, 333, 570, 570, 570, 500,
+ 832, 667, 667, 667, 722, 667, 667, 722,
+ 778, 389, 500, 667, 611, 889, 722, 722,
+ 611, 722, 667, 556, 611, 722, 667, 889,
+ 667, 611, 611, 333, 278, 333, 570, 500,
+ 333, 500, 500, 444, 500, 444, 333, 500,
+ 556, 278, 278, 500, 278, 778, 556, 500,
+ 500, 500, 389, 389, 278, 556, 444, 667,
+ 500, 444, 389, 348, 220, 348, 570, 350, # 127
+ 500, 350, 333, 500, 502, 1000, 500, 500, # 135
+ 333, 1000, 555, 333, 944, 350, 610, 350, # 143
+ 350, 333, 333, 500, 500, 350, 500, 1000, # 151
+ 333, 1000, 389, 333, 721, 350, 390, 610, # 159
+ 250, 389, 500, 500, 500, 500, 220, 500, #167
+ 333, 747, 266, 500, 606, 333, 747, 333, #175
+ 400, 570, 300, 300, 333, 532, 500, 250, #183
+ 333, 300, 300, 500, 750, 750, 750, 500,
+ 667, 667, 667, 667, 667, 667, 944, 667,
+ 667, 667, 667, 667, 389, 389, 389, 389,
+ 722, 722, 722, 722, 722, 722, 722, 570,
+ 722, 722, 722, 722, 722, 611, 611, 500,
+ 500, 500, 500, 500, 500, 500, 722, 444,
+ 444, 444, 444, 444, 278, 278, 278, 278,
+ 500, 556, 500, 500, 500, 500, 500, 570,
+ 500, 556, 556, 556, 556, 444, 500, 444],
+
+ 'Helvetica' =>
+ [000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 278, 278, 355, 556, 556, 889, 667, 192,
+ 333, 333, 389, 584, 278, 333, 278, 278,
+ 556, 556, 556, 556, 556, 556, 556, 556,
+ 556, 556, 278, 278, 584, 584, 584, 556,
+ 1015, 667, 667, 722, 722, 667, 611, 778,
+ 722, 278, 500, 667, 556, 833, 722, 778,
+ 667, 778, 722, 667, 611, 722, 667, 944,
+ 667, 667, 611, 278, 278, 278, 469, 557,
+ 334, 556, 556, 500, 556, 556, 278, 556,
+ 556, 222, 222, 500, 222, 833, 556, 556,
+ 556, 556, 333, 500, 278, 556, 500, 722,
+ 500, 500, 500, 334, 260, 334, 584, 350, # 127
+ 556, 350, 222, 556, 333, 1000, 556, 556, # 135
+ 333, 1000, 667, 333, 1000, 351, 611, 350, # 143
+ 350, 223, 222, 333, 333, 351, 557, 1000, # 151
+ 333, 1000, 500, 333, 945, 350, 500, 667, # 159
+ 278, 333, 556, 556, 556, 556, 260, 556, # 167
+ 333, 737, 370, 556, 584, 333, 737, 333, # 175
+ 400, 584, 333, 333, 333, 578, 537, 278, # 183
+ 333, 333, 365, 556, 835, 835, 835, 611, # 191
+ 667, 667, 667, 667, 667, 667, 1000, 722,
+ 667, 667, 667, 667, 278, 278, 278, 278,
+ 722, 722, 778, 778, 778, 778, 778, 584,
+ 778, 722, 722, 722, 722, 667, 667, 611,
+ 556, 556, 556, 556, 556, 556, 889, 500,
+ 556, 556, 556, 556, 278, 278, 278, 278,
+ 556, 556, 556, 556, 556, 556, 556, 584,
+ 611, 556, 556, 556, 556, 500, 556, 500],
+
+ 'Helvetica-Bold' =>
+ [000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000, #31
+ 278, 333, 474, 556, 556, 889, 722, 238, #39
+ 333, 333, 389, 584, 278, 333, 278, 278, #47
+ 556, 556, 556, 556, 556, 556, 556, 556, #55
+ 556, 556, 333, 333, 584, 584, 584, 611, #63
+ 975, 722, 722, 722, 722, 667, 611, 778, #71
+ 722, 278, 556, 722, 611, 833, 722, 778, #79
+ 667, 778, 722, 667, 611, 722, 667, 944, #87
+ 667, 667, 611, 333, 278, 333, 584, 556, #95
+ 333, 556, 611, 556, 611, 556, 333, 611, #103
+ 611, 278, 278, 556, 278, 889, 611, 611, #111
+ 611, 611, 389, 556, 333, 611, 556, 778, #119
+ 556, 556, 500, 389, 280, 389, 584, 350, # 127
+ 556, 350, 278, 556, 500, 1000, 556, 556, # 135
+ 333, 1000, 667, 333, 1000, 350, 611, 350, # 143
+ 350, 278, 278, 500, 500, 350, 556, 1000, # 151
+ 333, 1000, 556, 333, 944, 350, 500, 667, # 159
+ 278, 333, 556, 556, 556, 556, 280, 556, #167
+ 333, 737, 370, 556, 584, 333, 737, 333,
+ 400, 584, 333, 333, 333, 611, 556, 278,
+ 333, 333, 365, 556, 834, 834, 834, 611,
+ 722, 722, 722, 722, 722, 722, 1000, 722,
+ 667, 667, 667, 667, 278, 278, 278, 278,
+ 722, 722, 778, 778, 778, 778, 778, 584,
+ 778, 722, 722, 722, 722, 667, 667, 611,
+ 556, 556, 556, 556, 556, 556, 889, 556,
+ 556, 556, 556, 556, 278, 278, 278, 278,
+ 611, 611, 611, 611, 611, 611, 611, 584,
+ 611, 611, 611, 611, 611, 556, 611, 556],
+
+ 'Helvetica-Oblique' =>
+ [000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 278, 278, 355, 556, 556, 889, 667, 191,
+ 333, 333, 389, 584, 278, 333, 278, 278,
+ 556, 556, 556, 556, 556, 556, 556, 556,
+ 556, 556, 278, 278, 584, 584, 584, 556,
+ 1015, 667, 667, 722, 722, 667, 611, 778,
+ 722, 278, 500, 667, 556, 833, 722, 778,
+ 667, 778, 722, 667, 611, 722, 667, 944,
+ 667, 667, 611, 278, 278, 278, 469, 556,
+ 333, 556, 556, 500, 556, 556, 278, 556,
+ 556, 222, 222, 500, 222, 833, 556, 556,
+ 556, 556, 333, 500, 278, 556, 500, 722,
+ 500, 500, 500, 334, 260, 334, 584, 350, # 127
+ 556, 350, 222, 556, 333, 1000, 556, 556, # 135
+ 333, 1000, 667, 333, 1000, 351, 611, 350, # 143
+ 350, 223, 222, 333, 333, 351, 557, 1000, # 151
+ 333, 1000, 500, 333, 945, 350, 500, 667, # 159
+ 278, 333, 556, 556, 556, 556, 260, 556, # 167
+ 333, 737, 370, 556, 584, 333, 737, 333, # 175
+ 400, 584, 333, 333, 333, 578, 537, 278, # 183
+ 333, 333, 365, 556, 834, 834, 834, 611, # 191
+ 667, 667, 667, 667, 667, 667, 1000, 722,
+ 667, 667, 667, 667, 278, 278, 278, 278,
+ 722, 722, 778, 778, 778, 778, 778, 584,
+ 778, 722, 722, 722, 722, 667, 667, 611,
+ 556, 556, 556, 556, 556, 556, 889, 500,
+ 556, 556, 556, 556, 278, 278, 278, 278,
+ 556, 556, 556, 556, 556, 556, 556, 584,
+ 611, 556, 556, 556, 556, 500, 556, 500],
+
+ 'Helvetica-BoldOblique' =>
+ [000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 000, 000, 000, 000, 000, 000, 000, 000,
+ 278, 333, 474, 556, 556, 889, 722, 238, #39
+ 333, 333, 389, 584, 278, 333, 278, 278, #47
+ 556, 556, 556, 556, 556, 556, 556, 556, #55
+ 556, 556, 333, 333, 584, 584, 584, 611, #63
+ 975, 722, 722, 722, 722, 667, 611, 778, #71
+ 722, 278, 556, 722, 611, 833, 722, 778, #79
+ 667, 778, 722, 667, 611, 722, 667, 944, #87
+ 667, 667, 611, 333, 278, 333, 584, 556, #95
+ 333, 556, 611, 556, 611, 556, 333, 611, #103
+ 611, 278, 278, 556, 278, 889, 611, 611, #111
+ 611, 611, 389, 556, 333, 611, 556, 778, #119
+ 556, 556, 500, 389, 280, 389, 584, 350, # 127
+ 556, 350, 278, 556, 500, 1000, 556, 556, # 135
+ 333, 1000, 667, 333, 1000, 350, 611, 350, # 143
+ 350, 278, 278, 500, 500, 350, 556, 1000, # 151
+ 333, 1000, 556, 333, 944, 350, 500, 667, # 159
+ 278, 333, 556, 556, 556, 556, 280, 556,
+ 333, 737, 370, 556, 584, 333, 737, 333,
+ 400, 584, 333, 333, 333, 611, 556, 278,
+ 333, 333, 365, 556, 834, 834, 834, 611,
+ 722, 722, 722, 722, 722, 722, 1000, 722,
+ 667, 667, 667, 667, 278, 278, 278, 278,
+ 722, 722, 778, 778, 778, 778, 778, 584,
+ 778, 722, 722, 722, 722, 667, 667, 611,
+ 556, 556, 556, 556, 556, 556, 889, 556,
+ 556, 556, 556, 556, 278, 278, 278, 278,
+ 611, 611, 611, 611, 611, 611, 611, 584,
+ 611, 611, 611, 611, 611, 556, 611, 556]
+ );
+
+sub hyperLink
+{ my $x = shift;
+ my $y = shift;
+ my $text = shift || ' ';
+ my $URI = shift;
+ my $fontSize = shift;
+ my $s = shift || 'URI';
+
+ my ($actualSize, $fontSizeBeforetheChange, $height, $x2, $y2);
+ if ((! defined $x) || (! defined $y) || (! defined $URI))
+ { return undef;
+ }
+ my ($internalName, $externalName, $oldInternalName, $oldExternalname) =
+ PDF::Reuse::prFont('HO');
+ if (! defined $fontSize)
+ { ($actualSize, $fontSizeBeforetheChange) = PDF::Reuse::prFontSize();
+ $fontSize = $fontSizeBeforetheChange;
+ PDF::Reuse::prFontSize($fontSize) if ($actualSize != $fontSizeBeforetheChange);
+ }
+ else
+ { ($actualSize, $fontSizeBeforetheChange) = PDF::Reuse::prFontSize($fontSize);
+ }
+ $height = $fontSize + 2.5;
+ my $width = PDF::Reuse::prStrWidth($text);
+ $y2 = $y - 2;
+ $x2 = $x + $width;
+ PDF::Reuse::prAdd("q\n 0.3 0.3 1 RG 0.3 0.3 1 rg\n$x $y2 m\n$x2 $y2 l\n B*\n");
+ $y2 -= 1;
+ PDF::Reuse::prText($x, $y, $text);
+ PDF::Reuse::prLink( { x => $x,
+ y => $y2,
+ width => $width,
+ height => $height,
+ URI => $URI,
+ s => $s} );
+
+ PDF::Reuse::prAdd("0 0 0 RG 0 0 0 rg\nQ\n");
+ PDF::Reuse::prFont($oldExternalname)
+ if ($oldExternalname ne $externalName);
+ PDF::Reuse::prFontSize($fontSizeBeforetheChange)
+ if ($fontSizeBeforetheChange != $fontSize);
+ return $x2;
+}
+
+sub blackText
+{ PDF::Reuse::prAdd("0 0 0 rg\n0 g\nf\n");
+}
+
+1;
+
+__END__
+
+=head1 AUTHOR
+
+Lars Lundberg larslund@cpan.org
+Chris Nighswonger cnighs@cpan.org
+
+=head1 COPYRIGHT
+
+Copyright (C) 2003 - 2004 Lars Lundberg, Solidez HB.
+Copyright (C) 2005 Karin Lundberg.
+Copyright (C) 2006 - 2010 Lars Lundberg, Solidez HB.
+Copyright (C) 2010 - 2014 Chris Nighswonger
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/lib/PDF/Util/graphObj_pl b/lib/PDF/Util/graphObj_pl
new file mode 100644
index 0000000..83b7998
--- /dev/null
+++ b/lib/PDF/Util/graphObj_pl
@@ -0,0 +1,512 @@
+use warnings;
+use strict;
+
+my $infile = shift || die "You have to give a pdf-file as an argument, aborts\n";
+my $outfile = shift;
+my $valFile;
+
+my ($line, @lines, $yes, $xCounter, $yCounter, %xPos, %yPos, $declare,
+ $stream, $xMin, $yMin, $colors, %color, $xMax, $yMax, $long, @words,
+ $packName, %extObj, $xObject, $var, %initValues, %seen, $string, @seq);
+
+my $round = 1;
+
+##############################
+# Counters for PDF operators
+##############################
+
+my %graphOp = (c => 0,
+ cm => 0,
+ CS => 0,
+ cs => 0,
+ d => 0,
+ Do => 0,
+ G => 0,
+ g => 0,
+ gs => 0,
+ i => 0,
+ j => 0,
+ J => 0,
+ k => 0,
+ K => 0,
+ l => 0,
+ m => 0,
+ M => 0,
+ re => 0,
+ rg => 0,
+ RG => 0,
+ sc => 0,
+ SC => 0,
+ scn => 0,
+ SCN => 0,
+ sh => 0,
+ Tf => 0,
+ Tm => 0,
+ Tj => 0,
+ y => 0,
+ v => 0,
+ w => 0);
+
+#####################################
+# Descriptions of PDF operators
+#####################################
+
+my %descr = (c => 'curv',
+ cm => 'matrix',
+ CS => 'strokeColSpace',
+ cs => 'fillColSpace',
+ d => 'dash',
+ Do => 'invoke',
+ G => 'greyStroke',
+ g => 'greyFill',
+ gs => 'graphState',
+ i => 'flatness',
+ j => 'join',
+ J => 'cap',
+ k => 'fillCMYK',
+ K => 'strokeCMYK',
+ l => 'line',
+ m => 'moveTo',
+ M => 'miter',
+ re => 'rectangle',
+ rg => 'fillRGB',
+ RG => 'strokeRGB',
+ sc => 'fillCol',
+ SC => 'strokeCol',
+ scn => 'fillICC',
+ SCN => 'strokeICC',
+ sh => 'shade',
+ Tf => 'font',
+ Tm => 'tMatrix',
+ Tj => 'text',
+ Tr => 'textRender',
+ y => 'curvFrom',
+ v => 'curvTo',
+ w => 'lineWidth');
+
+
+
+if ($outfile =~ m'(\w+)\.*.*'o)
+{ $packName = $1;
+ $valFile = $1 . '.dat';
+}
+else
+{ if ($infile =~ m'(\w+)\.*.*'o)
+ { $packName = $1;
+ $outfile = $1 . '.pm';
+ $valFile = $1 . '.dat';
+ }
+ else
+ { $packName = 'shape';
+ $outfile = 'shape.pm';
+ $valFile = 'shape.dat';
+ }
+}
+open (infile, "<$infile") || die "Couldn't open $infile, aborts, $!";
+open (VALFILE, ">$valFile") || die "Couldn't open $valFile, aborts, $!";
+
+
+while ($line = <infile>)
+{ if ($yes)
+ { if ($line =~ m'\bendstream\b'o)
+ { last;
+ }
+ else
+ {
+ $long .= $line;
+ }
+ }
+ elsif ($line =~ m'\bstream\b'o)
+ { $yes = 1;
+ }
+}
+close infile;
+
+
+@words = split(/\s+/,$long);
+undef $line;
+
+for my $word (@words)
+{ if (($word =~ m'^[a-zA-Z\*]+$'o)
+ || ($word =~ m'.+\)Tj'o)
+ || ($word =~ m'.+\]TJ'o))
+ { $line .= $word;
+ push @lines, $line;
+ undef $line;
+ }
+ else
+ { $line .= "$word ";
+ }
+}
+
+######################
+# Process the lines
+######################
+
+$stream = 'sub init' . "\n" .
+ '{ my $self = shift;' . "\n" .
+ ' my @array;' . "\n";
+
+for $line (@lines)
+{ chomp($line);
+ my ($x1, $x2, $x3, $y1, $y2, $y3, $extFound, $name, @list);
+ if ($line =~ m'^([\d\.\-]+)\s+([\d\.\-]+)\s+([ml])\s*$'o)
+ { $x1 = examineX($1);
+ $y1 = examineY($2);
+ $graphOp{$3}++;
+ $name = $descr{$3} . $graphOp{$3};
+ print VALFILE "$name => '$x1 $y1',\n";
+ $stream .= ' $self->{\'' . $name . '\'} = ' . "'$x1 $y1';\n";
+ @list = ($name, $3);
+
+ }
+ elsif ($line =~ m'^([\d\.\-]+)\s+([\d\.\-]+)\s+([\d\.\-]+)\s+([\d\.\-]+)\s+([vy])$'o)
+ { $x1 = examineX($1);
+ $y1 = examineY($2);
+ $x2 = examineX($3);
+ $y2 = examineY($4);
+ $graphOp{$5}++;
+ $name = $descr{$5} . $graphOp{$5};
+ print VALFILE "$name => '$x1 $y1 $x2 $y2',\n";
+ $stream .= ' $self->{\'' . $name . '\'} = ' . "'$x1 $y1 $x2 $y2';\n";
+ @list = ($name, $5);
+ }
+ elsif ($line =~ m'^([\d\.\-]+)\s+([\d\.\-]+)\s+([\d\.\-]+)\s+([\d\.\-]+)\s+([\d\.\-]+)\s+([\d\.\-]+)\s+c\s*$'o)
+ { $x1 = examineX($1);
+ $y1 = examineY($2);
+ $x2 = examineX($3);
+ $y2 = examineY($4);
+ $x3 = examineX($5);
+ $y3 = examineY($6);
+ $graphOp{'c'}++;
+ $name = $descr{'c'} . $graphOp{'c'};
+ print VALFILE "$name => '$x1 $y1 $x2 $y2 $x3 $y3',\n";
+ $stream .= ' $self->{\'' . $name . '\'} = ' . "'$x1 $y1 $x2 $y2 $x3 $y3';\n";
+ @list = ($name, 'c');
+ }
+ elsif ($line =~ m'^([\d\.\-]+)\s+([\d\.\-]+)\s+([\d\.\-]+)\s+([\d\.\-]+)\s+re$'o)
+ { $x1 = examineX($1);
+ $y1 = examineY($2);
+ $graphOp{'re'}++;
+ $name = $descr{'re'} . $graphOp{'re'};
+ print VALFILE "$name => '$x1 $y1 $3 $4',\n";
+ $stream .= ' $self->{\'' . $name . '\'} = ' . "'$x1 $y1 $3 $4';\n";
+ @list = ($name, 're');
+ }
+ elsif ($line =~ m'^([\d\.\-]+)\s+([\d\.\-]+)\s+([\d\.\-]+)\s+([\d\.\-]+)\s+([\d\.\-]+)\s+([\d\.\-]+)\s+Tm\s*$'o)
+ { $x1 = examineX($5);
+ $y1 = examineY($6);
+ $graphOp{'Tm'}++;
+ $name = $descr{'Tm'} . $graphOp{'Tm'};
+ print VALFILE "$name => '$1 $2 $3 $4 $x1 $y1',\n";
+ $stream .= ' $self->{\'' . $name . '\'} = ' . "'$1 $2 $3 $4 $x1 $y1';\n";
+ @list = ($name, 'Tm');
+ }
+ elsif ($line =~ m'\((.*)\)\s*Tj'o)
+ { $name = entry($1, 'Tj');
+ $stream .= ' $self->{\'' . $name . '\'} = ' . "'$1';\n";
+ @list = ($name, 'Tj');
+
+ }
+ elsif ($line =~ m'^/(.+)\s+(\w+)$'o)
+ { if ($2 eq 'ri')
+ { @list = ('x', $line);
+ }
+ else
+ { my $op = $2;
+ my $obj = $1;
+ my $num;
+ if ($obj =~ m'(\w+)\s+(\d+)'o)
+ { $obj = $1;
+ $num = $2;
+ }
+ $name = entry($obj, $op);
+ $extObj{$name} = { oldName => $obj,
+ file => $infile,
+ page => 1,
+ type => $op};
+ @list = ($name," $num $op");
+ }
+ }
+ else
+ { if ($line =~ m'^(.+)\s+(\w+)$'o)
+ { if (exists $graphOp{$2})
+ { $name = entry($1, $2);
+ $stream .= ' $self->{\'' . $name . '\'} = ' . "'$1';\n";
+ @list = ($name, $2);
+ }
+ else
+ { @list = ('x', $line);
+ }
+ }
+ else
+ { @list = ('x', $line);
+ }
+ }
+ push @seq, ["'$list[0]'", "'$list[1]'"];
+}
+
+my $i = 0;
+for my $rad (@seq)
+{ # $stream .= ' $self->{\'sequence\'}->[' . $i . '] = [' . $rad->[0] .
+ # ',' . $rad->[1] . "];\n";
+ $stream .= ' push @array, ['. $rad->[0] . ',' . $rad->[1] . "];\n";
+
+ print VALFILE "$i => \[$rad->[0], $rad->[1]\],\n";
+ $i++;
+}
+
+$stream .= ' $self->{\'sequence\'} = \\@array;' . "\n" .
+ ' 1;' . "\n" .
+ '}' . "\n\n";
+
+
+$declare = "package $packName;\n" .
+ 'require PDF::Reuse;' . "\n" .
+ 'use strict;' . "\n\n";
+
+$xMax -= $xMin;
+$yMax -= $yMin;
+
+$declare .= "sub new\n" .
+ '{ my $class = shift;' . "\n" .
+ ' my $model = shift;' . "\n" .
+ ' my $self = {};' . "\n" .
+ ' bless $self, $class;' . "\n" .
+ ' $self->{\'x\'} = 0;' . "\n" .
+ ' $self->{\'y\'} = 0;' . "\n" .
+ ' $self->{\'rotate\'} = 0;' . "\n" .
+ ' $self->{\'skewX\'} = 0;' . "\n" .
+ ' $self->{\'skewY\'} = 0;' . "\n" .
+ ' $self->{\'minX\'} = 0;' . "\n" .
+ ' $self->{\'minY\'} = 0;' . "\n" .
+ ' $self->{\'maxX\'} = ' . $xMax . ";\n" .
+ ' $self->{\'maxY\'} = ' . $yMax . ";\n" .
+ ' $self->init();' . "\n";
+
+if (scalar %extObj)
+{
+ for my $key (keys %extObj)
+ { $declare .= ' $self->{\'' . "$key'}->{'oldName'} = '$extObj{$key}->{'oldName'}';\n" .
+ ' $self->{\'' . "$key'}->{'file'} = '$extObj{$key}->{'file'}';\n" .
+ ' $self->{\'' . "$key'}->{'page'} = $extObj{$key}->{'page'};\n";
+ }
+
+}
+$declare .= ' if (defined $model)' . "\n" .
+ ' { for (keys %$model)' . "\n" .
+ ' { $self->{$_} = $model->{$_};' . "\n" .
+ ' }' . "\n" .
+ ' }' . "\n" .
+ ' return $self;' . "\n" .
+ '}' . "\n\n";
+
+
+$declare .= "sub draw\n" .
+ '{ my $self = shift;' . "\n" .
+ ' my %param = @_;' . "\n" .
+ ' for (keys %param)' . "\n" .
+ ' { if ($_ =~ m/^\d+$/o)' . "\n" .
+ ' { $self->{\'sequence\'}->[$_] = $param{$_}; }' . "\n" .
+ ' else' . "\n" .
+ ' { $self->{$_} = $param{$_}; }' . "\n" .
+ ' }' . "\n" .
+ ' my ($str, $xSize, $ySize);' . "\n" .
+ ' my $x = $self->{\'x\'} - ' . $xMin . ";\n" .
+ ' my $y = $self->{\'y\'} - ' . $yMin . ";\n";
+if (scalar %extObj)
+{ $declare .= ' $self->resources();' . "\n";
+}
+$declare .= ' $self->{\'xSize\'} = 1 unless ($self->{\'xSize\'} != 0);' . "\n";
+$declare .= ' $self->{\'ySize\'} = 1 unless ($self->{\'ySize\'} != 0);' . "\n";
+$declare .= ' $self->{\'size\'} = 1 unless ($self->{\'size\'} != 0);' . "\n";
+
+$declare .= ' $xSize = $self->{\'xSize\'} * $self->{\'size\'};' . "\n";
+$declare .= ' $ySize = $self->{\'ySize\'} * $self->{\'size\'};' . "\n";
+$declare .= ' $str .= "q\n";' . "\n" .
+ ' $str .= ' . '"$xSize 0 0 $ySize $x $y cm\n";' . "\n";
+$declare .= ' if ($self->{\'rotate\'} != 0)' . "\n" .
+ ' { my $radian = sprintf("%.6f", $self->{\'rotate\'} / 57.296);' . "\n" .
+ ' my $Cos = sprintf("%.6f", cos($radian));' . "\n" .
+ ' my $Sin = sprintf("%.6f", sin($radian));' . "\n" .
+ ' my $negSin = $Sin * -1;' . "\n" .
+ ' $str .= "$Cos $Sin $negSin $Cos 0 0 cm\n";' . "\n" .
+ ' }' . "\n";
+$declare .= ' if (($self->{\'skewX\'} != 0) || ($self->{\'skewY\'} != 0))' . "\n" .
+ ' { my $tanX = tan($self->{\'skewX\'});' . "\n" .
+ ' my $tanY = tan($self->{\'skewY\'});' . "\n" .
+ ' my $negTanY = $tanY * -1;' . "\n" .
+ ' $str .= ' . '"1 $tanX $negTanY 1 0 0 cm\n";' . "\n" .
+ ' }' . "\n" .
+ ' my @array = @{$self->{\'sequence\'}};' . "\n";
+$declare .= ' for my $rad (@array)' . "\n" .
+ ' { if ($rad->[0] eq \'x\')' . "\n" .
+ ' { if ($rad->[1] ne \' \')' . "\n" .
+ ' { $str .= "$rad->[1]\n";' . "\n" .
+ ' }' . "\n" .
+ ' }' . "\n" .
+ ' elsif (defined $rad->[1])' . "\n" .
+ ' { $str .= "$self->{$rad->[0]} $rad->[1]\n"; }' . "\n" .
+ ' }' . "\n" .
+ ' $str .= "Q\n";' . "\n";
+$declare .= ' PDF::Reuse::prAdd($str);' . "\n" .
+ '}' . "\n\n";
+
+
+open (outfile, ">$outfile") || die "Couldn't open $outfile, aborts $!\n";
+
+syswrite outfile, $declare;
+syswrite outfile, $stream;
+
+$stream = "sub resources\n" .
+ '{ my $self = shift;' . "\n" .
+ ' my $answer;' . "\n";
+for my $key (keys %extObj)
+{ if ($extObj{$key}->{'type'} eq 'Tf') # A font
+ { $stream .= ' if (exists $self->{\'font\'})' . "\n" .
+ ' { $self->{\'' . "$key\'\}->{'newName'} = PDF::Reuse::prFont("
+ . '$self->{\'' . "font'});\n" .
+ ' }' . "\n" .
+ ' else' . "\n" .
+ ' { $answer = PDF::Reuse::prExtract(' .
+ '$self->{\'' . "$key\'\}->{'oldName'}," .
+ '$self->{\'' . "$key\'\}->{'file'}," .
+ '$self->{\'' . "$key\'\}->{'page'});\n" .
+ ' if ($answer)' . "\n" .
+ ' { $self->{\'' . "$key\'\}->{'newName'} = " . '$answer;' . "\n" .
+ " }\n" .
+ " else\n" .
+ ' { $self->{\'font\'} = \'H\';' . "\n" .
+ ' $self->{\'' . "$key\'\}->{'newName'} = PDF::Reuse::prFont('H');\n" .
+ " }\n" .
+ " }\n";
+ }
+ elsif ($extObj{$key}->{'type'} eq 'gs') # A graphical state dictionary
+ { $stream .= ' if ((exists $self->{\'defaultGraphState\'})' . "\n" .
+ ' || ($self->{\'' . "$key\'\}->{'newName'} eq 'Gs0'))\n" .
+ ' { $self->{\'' . "$key\'\}->{'newName'} = 'Gs0';\n" .
+ ' }' . "\n" .
+ ' else' . "\n" .
+ ' { $answer = PDF::Reuse::prExtract(' .
+ '$self->{\'' . "$key\'\}->{'oldName'}," .
+ '$self->{\'' . "$key\'\}->{'file'}," .
+ '$self->{\'' . "$key\'\}->{'page'});\n" .
+ ' if ($answer)' . "\n" .
+ ' { $self->{\'' . "$key\'\}->{'newName'} = " . '$answer;' . "\n" .
+ " }\n" .
+ " else\n" .
+ ' { $self->{\'' . "$key\'\}->{'newName'} = 'Gs0';\n" .
+ " }\n" .
+ " }\n";
+ }
+ else
+ { $stream .= ' $answer = PDF::Reuse::prExtract(' .
+ '$self->{\'' . "$key\'\}->{'oldName'}," .
+ '$self->{\'' . "$key\'\}->{'file'}," .
+ '$self->{\'' . "$key\'\}->{'page'});\n" .
+ ' if ($answer)' . "\n" .
+ ' { $self->{\'' . "$key\'\}->{'newName'} = " . '$answer;' . "\n" .
+ " }\n" .
+ " else\n" .
+ ' { die "Couldn\'t find $self->{\'' . "$key'}->{'oldName'}," .
+ '$self->{\'' . "$key'}->{'file'}," .
+ '$self->{\'' . "$key'}->{'page'}, aborts " . '"' . ";\n" .
+ " }\n";
+ }
+
+}
+
+$stream .= '}' . "\n\n";
+
+$stream .= "sub originalDim\n" .
+ '{ my $self = shift;' . "\n" .
+ ' return ($self->{\'minX\'}, $self->{\'minY\'}, $self->{\'maxX\'}, $self->{\'maxY\'});' . "\n" .
+ '}' . "\n\n";
+
+$stream .= "sub tan\n" .
+ '{ my $tal = shift;' . "\n" .
+ ' return (sin($tal) / cos($tal));' . "\n" .
+ '}' . "\n\n";
+
+$stream .= "sub resourcesFrom\n" .
+ '{ my $self = shift;' . "\n";
+$stream .= ' my $donor = shift;' . "\n" .
+ ' for (keys %$donor)' . "\n" .
+ ' { if ((exists $self->{$_})' . "\n" .
+ ' && (ref($donor->{$_}) eq \'HASH\')' . "\n" .
+ ' && (defined $donor->{$_}->{\'newName\'})' . "\n" .
+ ' && (defined $donor->{$_}->{\'file\'})' . "\n" .
+ ' && (defined $donor->{$_}->{\'page\'}))' . "\n" .
+ ' { $self->{$_} = $donor->{$_};' . "\n" .
+ ' }' . "\n" .
+ ' }' . "\n" .
+ '}' . "\n1;\n";
+
+syswrite outfile, $stream;
+
+close outfile;
+close VALFILE;
+
+
+sub examineX
+{ my $x = shift;
+ if (($x < $xMin) || (! defined $xMin))
+ { $xMin = $x;
+ }
+ if ($round)
+ { $x = sprintf("%.1f", $x);
+ }
+ if ($x > $xMax)
+ { $xMax = $x;
+ }
+ return $x;
+
+}
+
+sub examineY
+{ my $y = shift;
+ if (($y < $yMin) || (! defined $yMin))
+ { $yMin = $y;
+ }
+ if ($round)
+ { $y = sprintf("%.1f", $y);
+ }
+ if ($y > $yMax)
+ { $yMax = $y;
+ }
+ return $y;
+
+}
+
+sub entry
+{ my $value = shift;
+ my $operator = shift;
+ my $combination = $operator . $value;
+ my $name;
+ if (! exists $seen{$combination})
+ { my $name = $descr{$operator} . ++$graphOp{$operator};
+ $seen{$combination} = $name;
+ print VALFILE "$name => '$value',\n";
+ }
+ return $seen{$combination};
+}
+
+__END__
+
+=head1 AUTHOR
+
+Lars Lundberg larslund@cpan.org
+Chris Nighswonger cnighs@cpan.org
+
+=head1 COPYRIGHT
+
+Copyright (C) 2003 - 2004 Lars Lundberg, Solidez HB.
+Copyright (C) 2005 Karin Lundberg.
+Copyright (C) 2006 - 2010 Lars Lundberg, Solidez HB.
+Copyright (C) 2010 - 2014 Chris Nighswonger
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/lib/PDF/Util/reuseComponent_pl b/lib/PDF/Util/reuseComponent_pl
new file mode 100644
index 0000000..fe87598
--- /dev/null
+++ b/lib/PDF/Util/reuseComponent_pl
@@ -0,0 +1,212 @@
+use warnings;
+use strict;
+
+use PDF::Reuse;
+
+my %stdFont =
+ ( 'Times-Roman' => 'Times-Roman',
+ 'Times-Bold' => 'Times-Bold',
+ 'Times-Italic' => 'Times-Italic',
+ 'Times-BoldItalic' => 'Times-BoldItalic',
+ 'Courier' => 'Courier',
+ 'Courier-Bold' => 'Courier-Bold',
+ 'Courier-Oblique' => 'Courier-Oblique',
+ 'Courier-BoldOblique' => 'Courier-BoldOblique',
+ 'Helvetica' => 'Helvetica',
+ 'Helvetica-Bold' => 'Helvetica-Bold',
+ 'Helvetica-Oblique' => 'Helvetica-Oblique',
+ 'Helvetica-BoldOblique' => 'Helvetica-BoldOblique',
+ 'Symbol' => 'Symbol',
+ 'ZapfDingbats' => 'ZapfDingbats',
+ 'TR' => 'Times-Roman',
+ 'TB' => 'Times-Bold',
+ 'TI' => 'Times-Italic',
+ 'TBI' => 'Times-BoldItalic',
+ 'C' => 'Courier',
+ 'CB' => 'Courier-Bold',
+ 'CO' => 'Courier-Oblique',
+ 'CBO' => 'Courier-BoldOblique',
+ 'H' => 'Helvetica',
+ 'HB' => 'Helvetica-Bold',
+ 'HO' => 'Helvetica-Oblique',
+ 'HBO' => 'Helvetica-BoldOblique',
+ 'S' => 'Symbol',
+ 'Z' => 'ZapfDingbats');
+
+my ($line, $string);
+
+my $x = 25;
+my $y = 710;
+
+my ($xDim, $yDim, $xScale, $yScale, $pdf);
+
+my $file = shift;
+
+my $i = 1;
+
+prFile('myFile.pdf');
+prFontSize(7);
+
+while (1)
+{ my @vec = prForm( { file => $file,
+ page => $i,
+ effect => 'add',
+ tolerant => 1 });
+ my $form = $vec[0];
+ if ($form eq '0')
+ { last;
+ }
+ if ($form)
+ { $xDim = $vec[3] - $vec[1];
+ $yDim = $vec[4] - $vec[2];
+ $xScale = 100 / $xDim;
+ $yScale = 100 / $yDim;
+ if ($xScale < $yScale)
+ { $yScale = $xScale;
+ }
+ else
+ { $xScale = $yScale;
+ }
+ $string = "q\n";
+ $string .= "$xScale 0 0 $yScale $x $y cm\n"; # scale and "move to"
+ $string .= "/$form Do\n";
+ $string .= "Q\n";
+ prAdd($string);
+ }
+ else
+ { prText($x, ($y + 70), 'Can\'t be used by prForm.');
+ prText($x, ($y + 60), 'Concatenate the streams.');
+ prText($x, ($y + 50), 'Look at the documentation');
+ prText($x, ($y + 40), 'for "prForm" how that can');
+ prText($x, ($y + 30), 'be done ! Or use prDoc or');
+ prText($x, ($y + 20), 'prSinglePage');
+ $xDim = 0;
+ $yDim = 0;
+ }
+ $line = 'Form : ' . $file . ' ' . $i . ' D: ' . $xDim . ' X ' . $yDim;
+ prText($x, ($y - 15), $line);
+ move();
+ my $j = 0;
+ my $images = $vec[5];
+ while ($j < $images)
+ { $j++;
+ my ($iName, $width, $height) = prImage({ file => $file,
+ page => $i,
+ imageNo => $j,
+ effect => 'add' } );
+
+ if (($width < 101) && ($height < 101))
+ { $xDim = $width;
+ $yDim = $height;
+ }
+ else
+ {
+ $xScale = 100 / $width;
+ $yScale = 100 / $height;
+
+
+ if ($xScale < $yScale)
+ { $yScale = $xScale;
+ }
+ else
+ { $xScale = $yScale;
+ }
+ $xDim = $xScale * $width;
+ $yDim = $yScale * $height;
+
+ }
+ $string = "q\n";
+ $string .= "$xDim 0 0 $yDim $x $y cm\n"; # scale and "move to"
+ $string .= "/$iName Do\n";
+ $string .= "Q\n";
+ prAdd($string);
+ $line = 'Image :' . $file . ' ' . $i . ' ' . $j . ' D: '
+ . $width . ' X ' . $height;
+ prText($x, ($y - 15), $line);
+ move();
+ }
+ $i++;
+
+}
+
+$x = 25;
+$y -= 40;
+
+if ($y < 100)
+{ prPage();
+ $y = 710;
+}
+prFontSize(20);
+prFont('TR');
+prText($x, $y, 'Found "non-standard" fonts: ');
+
+$y -= 40;
+
+my ($intnamn, $extnamn, $oldIntNamn, $oldExtNamn, $f) = prFont();
+
+my %font;
+for my $font (keys %{$f})
+{ if (exists $font{$font})
+ { next;
+ }
+ if ($y < 100)
+ { prPage();
+ $y = 710;
+ }
+
+ if (! exists $stdFont{$font})
+ { my @list = prFont($font);
+ if ($list[1] eq $font)
+ { prFontSize(18);
+ prFont('TR');
+ prText($x, $y, "$font :");
+ $y -= 25;
+ prFontSize(10);
+ prFont($font);
+ prText($x, $y, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ!"#$%&\'()*+-./0123456789:;<=>?@');
+ $y -= 14;
+ prText($x, $y, 'abcdefghijklmnopqrstuvwxyz{|}~\305\304\326\345\344\366[\]^_´`');
+ $y -= 40;
+ }
+ }
+ # $font{$font}++;
+}
+
+prEnd();
+
+
+sub move
+{ if ($x > 400)
+ { $x = 25;
+ $y -= 120;
+ }
+ else
+ { $x += 200;
+ }
+ if ($y < 0)
+ { prPage();
+ $x = 25;
+ $y = 710;
+ }
+}
+
+__END__
+
+=head1 AUTHOR
+
+Lars Lundberg larslund@cpan.org
+Chris Nighswonger cnighs@cpan.org
+
+=head1 COPYRIGHT
+
+Copyright (C) 2003 - 2004 Lars Lundberg, Solidez HB.
+Copyright (C) 2005 Karin Lundberg.
+Copyright (C) 2006 - 2010 Lars Lundberg, Solidez HB.
+Copyright (C) 2010 - 2014 Chris Nighswonger
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+
diff --git a/t/Reuse.t b/t/Reuse.t
new file mode 100644
index 0000000..f7c38cb
--- /dev/null
+++ b/t/Reuse.t
@@ -0,0 +1,116 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 6;
+use Test::Deep;
+
+BEGIN {
+ use_ok('PDF::Reuse') or BAIL_OUT "Can't load PDF::Reuse";
+}
+
+### NOTE: Any changes in the module code which result in a change to the contents of test.pdf
+### will require a corresponding change in the expected contents as listed below the __DATA__
+### tag at the end of this test file.
+
+my $built_in_fonts = {
+ 'TR' => 'Times-Roman',
+ 'TB' => 'Times-Bold',
+ 'TI' => 'Times-Italic',
+ 'TBI' => 'Times-BoldItalic',
+ 'C' => 'Courier',
+ 'CB' => 'Courier-Bold',
+ 'CO' => 'Courier-Oblique',
+ 'CBO' => 'Courier-BoldOblique',
+ 'H' => 'Helvetica',
+ 'HB' => 'Helvetica-Bold',
+ 'HO' => 'Helvetica-Oblique',
+ 'HBO' => 'Helvetica-BoldOblique',
+ 'S' => 'Symbol',
+ 'Z' => 'ZapfDingbats',
+};
+
+prFile('./test.pdf');
+
+my $f_flag = 1 if -e './test.pdf';
+is ($f_flag, 1, "PDF file created successfully");
+
+# Test findFont
+$PDF::Reuse::font = 'H';
+my ($foINTNAME, $foEXTNAME, $foREFOBJ) = PDF::Reuse::findFont();
+subtest 'PDF::Reuse::findFont successfully locates fonts' => sub{
+ plan tests => 3;
+ is ($foINTNAME, 'Ft1', "Internal font name is correct");
+ is ($foEXTNAME, 'Helvetica', "External font name is correct");
+ is ($foREFOBJ, '4', "PDF reference object for this font is correct");
+};
+
+# Test prText
+prText(250, 650, 'Hello World !');
+is ($PDF::Reuse::stream, '0 0 0 rg
+ 0 g
+f
+
+BT /Ft1 12 Tf 250 650 Td (Hello World !) Tj ET
+', "PDF Stream is created correctly");
+
+# Test prFont
+is (prFont("Times-Roman"),'Ft2', 'prFont returns the correct internal font name');
+
+
+
+prEnd();
+
+# Test newly created PDF file
+open (my $pdf, "<", "test.pdf") or BAIL_OUT "Can't open test.pdf: $!";
+binmode $pdf;
+my @pdf_got = <$pdf>;
+close $pdf;
+
+binmode main::DATA, ':encoding(UTF-8)';
+my @pdf_expected = <main::DATA>;
+# Line 29 contains two MD% hashes which are time-based and change with every new
+# PDF file created, so we will ignore it while testing the resulting file.
+$pdf_expected[31] = ignore();
+close main::DATA;
+
+cmp_deeply(\@pdf_got, \@pdf_expected, "PDF file successfully written");
+
+__DATA__
+%PDF-1.4
+%âãÃÓ
+4 0 obj<</Type/Font/Subtype/Type1/BaseFont/Helvetica/Encoding/WinAnsiEncoding>>endobj
+5 0 obj<</Type/Font/Subtype/Type1/BaseFont/Times-Roman/Encoding/WinAnsiEncoding>>endobj
+6 0 obj<</ProcSet[/PDF/Text]/Font << /Ft1 4 0 R/Ft2 5 0 R >>>>endobj
+7 0 obj<</Length 64>>stream
+0 0 0 rg
+ 0 g
+f
+
+BT /Ft1 12 Tf 250 650 Td (Hello World !) Tj ET
+
+endstream
+endobj
+3 0 obj<</Type/Page/Parent 2 0 R/Contents 7 0 R/MediaBox [0 0 595 842]/Resources 6 0 R>>endobj
+2 0 obj<</Type/Pages/Kids [3 0 R ]/Count 1 >>endobj
+1 0 obj<</Type/Catalog/Pages 2 0 R>>endobj
+xref
+0 8
+0000000000 65535 f
+0000000515 00000 n
+0000000463 00000 n
+0000000368 00000 n
+0000000015 00000 n
+0000000101 00000 n
+0000000189 00000 n
+0000000258 00000 n
+trailer
+<<
+/Size 8
+/Root 1 0 R
+/ID [<d29e8d34f9ec01330a2b6e4e8a6640f7><d29e8d34f9ec01330a2b6e4e8a6640f7>]
+>>
+startxref
+558
+%%EOF
diff --git a/t/test.t b/t/test.t
new file mode 100644
index 0000000..37dbe5b
--- /dev/null
+++ b/t/test.t
@@ -0,0 +1,24 @@
+
+use Test;
+BEGIN { plan tests => 8 };
+
+ok(sub { eval { require Carp;}; });
+
+ok(sub { eval { require Compress::Zlib;}; });
+
+ok(sub { eval { require Digest::MD5;}; });
+
+ok(sub { eval { require Exporter;}; });
+
+ok(sub { eval { require Data::Dumper;}; });
+
+use PDF::Reuse;
+ok(6);
+
+print "\n\nIf you have ok for everything this far, PDF::Reuse can be used\n";
+print "Will test the optional requirements for True Type Fonts and UTF8 characters\n\n\n";
+
+ok ( sub { eval { require Text::PDF::TTFont0;}; } );
+
+ok ( sub { eval { require Font::TTF;}; } );
+
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-11 17:27:05 +0000