diff options
author | Florian Schlichting <fsfs@debian.org> | 2016-10-11 22:00:40 +0200 |
---|---|---|
committer | Florian Schlichting <fsfs@debian.org> | 2016-10-11 22:00:40 +0200 |
commit | 48168bf062f22625d42910ce593f550826c466b7 (patch) | |
tree | a0170c0e55426c31737215d473c48b424e258a5b |
Import libpdf-reuse-perl_0.39.orig.tar.gz
[dgit import orig libpdf-reuse-perl_0.39.orig.tar.gz]
-rw-r--r-- | Changes | 209 | ||||
-rw-r--r-- | MANIFEST | 11 | ||||
-rw-r--r-- | META.yml | 22 | ||||
-rw-r--r-- | Makefile.PL | 60 | ||||
-rw-r--r-- | README | 84 | ||||
-rw-r--r-- | lib/PDF/Reuse.pm | 6943 | ||||
-rw-r--r-- | lib/PDF/Reuse/Util.pm | 357 | ||||
-rw-r--r-- | lib/PDF/Util/graphObj_pl | 512 | ||||
-rw-r--r-- | lib/PDF/Util/reuseComponent_pl | 212 | ||||
-rw-r--r-- | t/Reuse.t | 116 | ||||
-rw-r--r-- | t/test.t | 24 |
11 files changed, 8550 insertions, 0 deletions
@@ -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); +} @@ -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/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;}; } ); + |