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.36';
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';
}
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 loggfile $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 (keys %sidFont)
{ $resursDict .= "/$_ $sidFont{$_} 0 R";
}
$resursDict .= " >>";
}
if (scalar %sidXObject)
{ $resursDict .= '/XObject<<';
for (keys %sidXObject)
{ $resursDict .= "/$_ $sidXObject{$_} 0 R";
}
$resursDict .= ">>";
}
if (scalar %sidExtGState)
{ $resursDict .= '/ExtGState<<';
for (keys %sidExtGState)
{ $resursDict .= "\/$_ $sidExtGState{$_} 0 R";
}
$resursDict .= ">>";
}
if (scalar %sidPattern)
{ $resursDict .= '/Pattern<<';
for (keys %sidPattern)
{ $resursDict .= "/$_ $sidPattern{$_} 0 R";
}
$resursDict .= ">>";
}
if (scalar %sidShading)
{ $resursDict .= '/Shading<<';
for (keys %sidShading)
{ $resursDict .= "/$_ $sidShading{$_} 0 R";
}
$resursDict .= ">>";
}
if (scalar %sidColorSpace)
{ $resursDict .= '/ColorSpace<<';
for (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;
#FIXME: We need to have more robust error trapping and communication of that back to the caller
return unless $string; # there's no use continuing if no string is passed in
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;
}
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<$imageFile> 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<$altImageFile> 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<$imageFile> 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)
}
}
if (exists $entry{'act'})
{ my $code = $entry{'act'};
if ($code =~ m/^\s*(\d+)\s*,\s*(\d+)\s*,\s*(\d+)\s*$/os)
{ # $code = "this.pageNum = $1; this.scroll($2, $3);";
$code = "this.pageNum = $1;".($3?" this.scroll($2, $3);":"");
}
$jsObj = skrivJS($code);
}
$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{'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 = shift || 0;
my $ly = shift || 0;
my $ux = shift || 595;
my $uy = 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;
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;
}
}
}
}
($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{'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)
{ 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;
$buf .= $inrad;
}
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 (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 (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 (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 (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 (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 (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 logg, $!";
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";
}