File Coverage

blib/lib/PDF/Reuse.pm

Criterion	Covered	Total	%
statement	405	922	43.9
branch	74	354	20.9
condition	20	164	12.2
subroutine	58	88	65.9
pod	10	20	50.0
total	567	1548	36.6

package PDF::Reuse;

use 5.006;
use strict;
use warnings;

require    Exporter;
require    Digest::MD5;
use autouse 'Carp' => qw(carp
                         cluck
                         croak);

use Compress::Zlib qw(compress inflateInit);

use autouse 'Data::Dumper'   => qw(Dumper);
use AutoLoader qw(AUTOLOAD);

our $VERSION = '0.39';
our @ISA     = qw(Exporter);
our @EXPORT  = qw(prFile
                  prPage
                  prId
                  prIdType
                  prInitVars
                  prEnd
                  prExtract
                  prForm
                  prImage
                  prAltJpeg
                  prJpeg
                  prDoc
                  prDocForm
                  prFont
                  prFontSize
                  prGraphState
                  prGetLogBuffer
                  prAdd
                  prBar
                  prText
                  prDocDir
                  prLogDir
                  prLog
                  prVers
                  prCid
                  prJs
                  prInit
                  prField
                  prTouchUp
                  prCompress
                  prMbox
                  prBookmark
                  prStrWidth
                  prLink
                  prTTFont
                  prSinglePage);

our ($utfil, $slutNod, $formCont, $imSeq, $duplicateInits, $page, $sidObjNr, $sida,
    $interActive, $NamesSaved, $AARootSaved, $AAPageSaved, $root,
    $AcroFormSaved, $id, $ldir, $checkId, $formNr, $imageNr,
    $filnamn, $interAktivSida, $taInterAkt, $type, $runfil, $checkCs,
    $confuseObj, $compress, $pos, $fontNr, $objNr, $docProxy,
    $defGState, $gSNr, $pattern, $shading, $colorSpace, $totalCount);

our (@kids, @counts, @formBox, @objekt, @parents, @aktuellFont, @skapa,
    @jsfiler, @inits, @bookmarks, @annots);

our ( %old, %oldObject, %resurser, %form, %image, %objRef, %nyaFunk, %fontSource,
     %sidFont, %sidXObject, %sidExtGState, %font, %intAct, %fields, %script,
     %initScript, %sidPattern, %sidShading, %sidColorSpace, %knownToFile,
     %processed, %embedded, %dummy, %behandlad, %unZipped, %links, %prefs);

our $stream  = '';
our $idTyp   = '';
our $ddir    = '';
our $log     = '';

#########################
# Konstanter för objekt
#########################

use constant   oNR        => 0;
use constant   oPOS       => 1;
use constant   oSTREAMP   => 2;
use constant   oKIDS      => 3;
use constant   oFORM      => 4;
use constant   oIMAGENR   => 5;
use constant   oWIDTH     => 6;
use constant   oHEIGHT    => 7;
use constant   oTYPE      => 8;
use constant   oNAME      => 9;

###################################
# Konstanter för formulär
###################################

use constant   fOBJ       => 0;
use constant   fRESOURCE  => 1;
use constant   fBBOX      => 2;
use constant   fIMAGES    => 3;
use constant   fMAIN      => 4;
use constant   fKIDS      => 5;
use constant   fNOKIDS    => 6;
use constant   fID        => 7;
use constant   fVALID     => 8;

####################################
# Konstanter för images
####################################

use constant   imWIDTH     => 0;
use constant   imHEIGHT    => 1;
use constant   imXPOS      => 2;
use constant   imYPOS      => 3;
use constant   imXSCALE    => 4;
use constant   imYSCALE    => 5;
use constant   imIMAGENO   => 6;

#####################################
# Konstanter för interaktiva objekt
#####################################

use constant   iNAMES     => 1;
use constant   iACROFORM  => 2;
use constant   iAAROOT    => 3;
use constant   iANNOTS    => 4;
use constant   iSTARTSIDA => 5;
use constant   iAAPAGE    => 6;

#####################################
# Konstanter för fonter
#####################################

use constant   foREFOBJ     => 0;
use constant   foINTNAMN    => 1;
use constant   foEXTNAMN    => 2;
use constant   foORIGINALNR => 3;
use constant   foSOURCE     => 4;
use constant   foTYP        => 5;
use constant   foFONTOBJ    => 6;

##########
# Övrigt
##########

use constant IS_MODPERL => $ENV{MOD_PERL}; # For mod_perl 1.
                                           # For mod_perl 2 pass $r to prFile()
our $touchUp  = 1;

our %stdFont =
       ('Times-Roman'           => 'Times-Roman',
        'Times-Bold'            => 'Times-Bold',
        'Times-Italic'          => 'Times-Italic',
        'Times-BoldItalic'      => 'Times-BoldItalic',
        'Courier'               => 'Courier',
        'Courier-Bold'          => 'Courier-Bold',
        'Courier-Oblique'       => 'Courier-Oblique',
        'Courier-BoldOblique'   => 'Courier-BoldOblique',
        'Helvetica'             => 'Helvetica',
        'Helvetica-Bold'        => 'Helvetica-Bold',
        'Helvetica-Oblique'     => 'Helvetica-Oblique',
        'Helvetica-BoldOblique' => 'Helvetica-BoldOblique',
        'Symbol'                => 'Symbol',
        'ZapfDingbats'          => 'ZapfDingbats',
        'TR'  => 'Times-Roman',
        'TB'  => 'Times-Bold',
        'TI'  => 'Times-Italic',
        'TBI' => 'Times-BoldItalic',
        'C'   => 'Courier',
        'CB'  => 'Courier-Bold',
        'CO'  => 'Courier-Oblique',
        'CBO' => 'Courier-BoldOblique',
        'H'   => 'Helvetica',
        'HB'  => 'Helvetica-Bold',
        'HO'  => 'Helvetica-Oblique',
        'HBO' => 'Helvetica-BoldOblique',
        'S'   => 'Symbol',
        'Z'   => 'ZapfDingbats');

our $genLowerX    = 0;
our $genLowerY    = 0;
our $genUpperX    = 595,
our $genUpperY    = 842;
our $genFont      = 'Helvetica';
our $fontSize     = 12;

keys(%resurser)  = 10;

sub prFont
{   my $nyFont = shift;
    my ($intnamn, $extnamn, $objektnr, $oldIntNamn, $oldExtNamn);

    if (! $pos)
    {  errLog("No output file, you have to call prFile first");
    }
    $oldIntNamn = $aktuellFont[foINTNAMN];
    $oldExtNamn = $aktuellFont[foEXTNAMN];
    if ($nyFont)
    {  ($intnamn, $extnamn, $objektnr) = findFont($nyFont);
    }
    else
    {   $intnamn = $aktuellFont[foINTNAMN];
        $extnamn = $aktuellFont[foEXTNAMN];
    }
    if ($runfil)
    {  $log .= "Font~$nyFont\n";
    }
    if (wantarray)
    {  return ($intnamn, $extnamn, $oldIntNamn, $oldExtNamn, \%font);
    }
    else
    {  return $intnamn;
    }
}

sub prFontSize
{   my $fSize = shift || 12;
    my $oldFontSize = $fontSize;
    if ($fSize =~ m'\d+\.?\d*'o)
    { $fontSize = $fSize;
      if ($runfil)
      {  $log .= "FontSize~$fontSize\n";
      }
    }
    if (! $pos)
    {  errLog("No output file, you have to call prFile first");
    }

    return ($fontSize, $oldFontSize);
}

sub prFile
{  if ($pos)
   {  prEnd();
      close UTFIL;
   }
   %prefs = ();
   my $param = shift;
   if (ref($param) eq 'HASH')
   {  $filnamn  = '-';
      for (keys %{$param})
      {   my $key = lc($_);
          if ($key eq 'name')
          {  $filnamn = $param->{$_}; }
          elsif (($key eq 'hidetoolbar')
          ||     ($key eq 'hidemenubar')
          ||     ($key eq 'hidewindowui')
          ||     ($key eq 'fitwindow')
          ||     ($key eq 'centerwindow'))
          {  $prefs{$key} = $param->{$_};
          }
      }
   }
   else
   {  $filnamn  = $param || '-';
      $prefs{hidetoolbar}  = $_[1]  if defined $_[1];
      $prefs{hidemenubar}  = $_[2]  if defined $_[2];
      $prefs{hidewindowui} = $_[3]  if defined $_[3];
      $prefs{fitwindow}    = $_[4]  if defined $_[4];
      $prefs{centerwindow} = $_[5]  if defined $_[5];
   }
   my $kortNamn;
   if ($filnamn ne '-')
   {   my $ri  = rindex($filnamn,'/');
       if ($ri > 0)
       {  $kortNamn = substr($filnamn, ($ri + 1));
          $utfil = $ddir ? $ddir . $kortNamn : $filnamn;
       }
       else
       {  $utfil = $ddir ? $ddir . $filnamn : $filnamn;
       }
       $ri = rindex($utfil,'/');
       if ($ri > 0)
       {   my $dirdel = substr($utfil,0,$ri);
           if (! -e $dirdel)
           {  mkdir $dirdel || errLog("Couldn't create dir $dirdel, $!");
           }
       }
       else
       {  $ri = rindex($utfil,'\\');
          if ($ri > 0)
          {   my $dirdel = substr($utfil,0,$ri);
              if (! -e $dirdel)
              {  mkdir $dirdel || errLog("Couldn't create dir $dirdel, $!");
              }
          }
       }
   }
   else
   {   $utfil = $filnamn;
   }

   my $utfil_ref = ref $utfil;
   if ($utfil_ref and ($utfil_ref eq 'Apache2::RequestRec') or
                      ($utfil_ref eq 'Apache::RequestRec') ) # mod_perl 2
   { tie *UTFIL, $utfil;
   }
   elsif (IS_MODPERL && $utfil eq '-')     # mod_perl 1
   { tie *UTFIL, 'Apache';
   }
   elsif ($utfil_ref and $utfil_ref eq 'IO::String')
   { tie *UTFIL, $utfil;
   }
   else
   { open (UTFIL, ">$utfil") || errLog("Couldn't open file $utfil, $!");
   }
   binmode UTFIL;
   my $utrad = "\%PDF-1.4\n\%\â\ã\Ï\Ó\n";

   $pos   = syswrite UTFIL, $utrad;

   if (defined $ldir)
   {   if ($utfil eq '-')
       {   $kortNamn = 'stdout';
       }
       if ($kortNamn)
       {  $runfil = $ldir . $kortNamn  . '.dat';
       }
       else
       {  $runfil = $ldir . $filnamn  . '.dat';
       }
       open (RUNFIL, ">>$runfil") || errLog("Couldn't open logfile $runfil, $!");
       $log .= "Vers~$VERSION\n";
   }


   @parents     = ();
   @kids        = ();
   @counts      = ();
   @objekt      = ();
   $objNr       = 2; # Reserverat objekt 1 för root och 2 för initial sidnod
   $parents[0]  = 2;
   $page        = 0;
   $formNr      = 0;
   $imageNr     = 0;
   $fontNr      = 0;
   $gSNr        = 0;
   $pattern     = 0;
   $shading     = 0;
   $colorSpace  = 0;
   $sida        = 0;
   %font        = ();
   %resurser    = ();
   %fields      = ();
   @jsfiler     = ();
   @inits       = ();
   %nyaFunk     = ();
   %objRef      = ();
   %knownToFile = ();
   @aktuellFont = ();
   %old         = ();
   %behandlad   = ();
   @bookmarks   = ();
   %links       = ();
   undef $defGState;
   undef $interActive;
   undef $NamesSaved;
   undef $AARootSaved;
   undef $AcroFormSaved;
   $checkId    = '';
   undef $duplicateInits;
   undef $confuseObj;
   $fontSize  = 12;
   $genLowerX = 0;
   $genLowerY = 0;
   $genUpperX = 595,
   $genUpperY = 842;

   prPage(1);
   $stream = ' ';
   if ($runfil)
   {  $filnamn = prep($filnamn);
      $log .= "File~$filnamn";
      $log .= (exists $prefs{hidetoolbar}) ? "~$prefs{hidetoolbar}" : '~';
      $log .= (exists $prefs{hidemenubar}) ? "~$prefs{hidemenubar}" : '~';
      $log .= (exists $prefs{hidewindowui}) ? "~$prefs{hidewindowui}" : '~';
      $log .= (exists $prefs{fitwindow}) ? "~$prefs{fitwindow}" : '~';
      $log .= (exists $prefs{centerwindow}) ? "~$prefs{centerwindow}" : "~\n";
   }
   1;
}


sub prPage
{  my $noLogg = shift;
   if ((defined $stream) && (length($stream) > 0))
   { skrivSida();
   }

   $page++;
   $objNr++;
   $sidObjNr = $objNr;

   #
   # Resurserna nollställs
   #

   %sidXObject    = ();
   %sidExtGState  = ();
   %sidFont       = ();
   %sidPattern    = ();
   %sidShading    = ();
   %sidColorSpace = ();
   @annots        = ();

   undef $interAktivSida;
   undef $checkCs;
   if (($runfil) && (! $noLogg))
   {  $log .= "Page~\n";
       print RUNFIL $log;
       $log = '';
   }
   if (! $pos)
   {  errLog("No output file, you have to call prFile first");
   }
   1;

}

sub prText
{ my $xPos  = shift;
  my $yPos  = shift;
  my $TxT   = shift;
  my $align = shift || 'left';
  my $rot   = shift || '0';

  my $width = 0;
  my $x_align_offset = 0;

  if (! defined $TxT)
  {  $TxT = '';
  }

  if (($xPos !~ m'\-?[\d\.]+'o) || (! defined $xPos))
  { errLog("Illegal x-position for text: $xPos");
  }
  if (($yPos !~ m'\-?[\d\.]+'o) || (! defined $yPos))
  { errLog("Illegal y-position for text: $yPos");
  }

  if ($runfil)
  {   my $Texten   = prep($TxT);
      $log .= "Text~$xPos~$yPos~$Texten~$align~$rot\n";
  }

  if (length($stream) < 3)
  {  $stream = "0 0 0 rg\n 0 g\nf\n";
  }


  if (! $aktuellFont[foINTNAMN])
  {  findFont();
  }
  my $Font        = $aktuellFont[foINTNAMN];        # Namn i strömmen
  $sidFont{$Font} = $aktuellFont[foREFOBJ];
  my $fontname    = $aktuellFont[foEXTNAMN];
  my $ttfont      = $font{$fontname} ? $font{$fontname}[foFONTOBJ] : undef;


  # define what the offset for alignment is

  if ((wantarray)
  || ($align ne 'left'))
  {  $width = prStrWidth($TxT, $aktuellFont[foEXTNAMN], $fontSize);
     if($align eq 'right')
     {  $x_align_offset = - $width;
     }
     elsif ($align eq 'center')
     {  $x_align_offset = -$width / 2;
     }
  }

  $TxT =~ s|\(|\\(|gos;
  $TxT =~ s|\)|\\)|gos;


  unless($rot)
  {  $stream .= "\nBT /$Font $fontSize Tf ";
     if($ttfont)
     {   $TxT = $ttfont->encode_text($TxT);
         $stream .= $xPos+$x_align_offset . " $yPos Td $TxT Tj ET\n";
     }
     elsif (!$aktuellFont[foTYP])
     {   $stream .= $xPos+$x_align_offset . " $yPos Td \($TxT\) Tj ET\n";
     }
     else
     {   my $text;
         $TxT =~ s/\\(\d\d\d)/chr(oct($1))/eg;
         for (unpack ('C*', $TxT))
         {  $text .= sprintf("%04x", ($_ - 29));
         }
         $stream .= $xPos+$x_align_offset . " $yPos Td \<$text\> Tj ET\n";
     }
  }
  else
  {  if ($rot =~ m'q(\d)'oi)
      {  if ($1 eq '1')
         {  $rot = 270;
         }
         elsif ($1 eq '2')
         {  $rot = 180;
         }
         else
         {  $rot = 90;
         }
      }

     my $radian = sprintf("%.6f", $rot / 57.2957795);    # approx.
     my $Cos    = sprintf("%.6f", cos($radian));
     my $Sin    = sprintf("%.6f", sin($radian));
     my $negSin = $Sin * -1;

     my $encText = $ttfont ? $ttfont->encode_text($TxT) : "\($TxT\)";
     $stream .=   "\nq\n"                           # enter a new stack frame
                # . "/Gs0 gs\n"                             # reset graphic mode
                . "$Cos $Sin $negSin $Cos $xPos $yPos cm\n" # rotation/translation in the CM
                . "\nBT /$Font $fontSize Tf "
                . "$x_align_offset 0 Td $encText Tj ET\n"   # text @ 0,0
                . "Q\n";                                    # close the stack frame
  }
  if (! $pos)
  {  errLog("No output file, you have to call prFile first");
  }


  if (wantarray)
  {  # return a new "cursor" position...

     if($rot==0)
     {  if($align eq 'left')
        {   return ($xPos, $xPos + $width);
        }
        elsif($align eq 'center')
        { return ($xPos - $x_align_offset, $xPos + $x_align_offset);
        }
        elsif($align eq 'right')
        {   return ($xPos - $width, $xPos);
        }

     }
     else
     {   # todo
         # we could some trigonometry to return an x/y point
         return 1;
     }
  }
  else
  {  return 1;
  }

}


sub prAdd
{  my $contents = shift;
   $stream .= "\n$contents\n";
   if ($runfil)
   {   $contents = prep($contents);
       $log .= "Add~$contents\n";
   }
   $checkCs = 1;
   if (! $pos)
   {  errLog("No output file, you have to call prFile first");
   }
   1;
}

##########################
# Ett grafiskt "formulär"
##########################

sub prForm
{ my ($sidnr, $adjust, $effect, $tolerant, $infil, $x, $y, $size, $xsize,
      $ysize, $rotate);
  my $param = shift;
  if (ref($param) eq 'HASH')
  {  $infil    = $param->{'file'};
     $sidnr    = $param->{'page'} || 1;
     $adjust   = $param->{'adjust'} || '';
     $effect   = $param->{'effect'} || 'print';
     $tolerant = $param->{'tolerant'} || '';
     $x        = $param->{'x'} || 0;
     $y        = $param->{'y'} || 0;
     $rotate   = $param->{'rotate'} || 0;
     $size     = $param->{'size'} || 1;
     $xsize    = $param->{'xsize'} || 1;
     $ysize    = $param->{'ysize'} || 1;
  }
  else
  {  $infil    = $param;
     $sidnr    = shift || 1;
     $adjust   = shift || '';
     $effect   = shift || 'print';
     $tolerant = shift || '';
     $x        = shift || 0;
     $y        = shift || 0;
     $rotate   = shift || 0;
     $size     = shift || 1;
     $xsize    = shift || 1;
     $ysize    = shift || 1;
  }

  my $refNr;
  my $namn;
  $type = 'form';
  my $fSource = $infil . '_' . $sidnr;
  if (! exists $form{$fSource})
  {  $formNr++;
     $namn = 'Fm' . $formNr;
     $knownToFile{$fSource} = $namn;
     my $action;
     if ($effect eq 'load')
     {  $action = 'load'
     }
     else
     {  $action = 'print'
     }
     $refNr         = getPage($infil, $sidnr, $action);
     if ($refNr)
     {  $objRef{$namn} = $refNr;
     }
     else
     {  if ($tolerant)
        {  if ((defined $refNr) && ($refNr eq '0'))   # Sidnumret existerar inte, men ok
           {   $namn = '0';
           }
           else
           {   undef $namn;   # Sidan kan inte användas som form
           }
        }
        elsif (! defined $refNr)
        {  my $mess = "$fSource can't be used as a form. See the documentation\n"
                    . "under prForm how to concatenate streams\n";
           errLog($mess);
        }
        else
        {  errLog("File : $infil  Page: $sidnr  doesn't exist");
        }
     }
  }
  else
  {  if (exists $knownToFile{$fSource})
     {  $namn = $knownToFile{$fSource};
     }
     else
     {  $formNr++;
        $namn = 'Fm' . $formNr;
        $knownToFile{$fSource} = $namn;
     }
     if (exists $objRef{$namn})
     {  $refNr = $objRef{$namn};
     }
     else
     {  if (! $form{$fSource}[fVALID])
        {  my $mess = "$fSource can't be used as a form. See the documentation\n"
                    . "under prForm how to concatenate streams\n";
           if ($tolerant)
           {  cluck $mess;
              undef $namn;
           }
           else
           {  errLog($mess);
           }
        }
        elsif ($effect ne 'load')
        {  $refNr         =  byggForm($infil, $sidnr);
           $objRef{$namn} =  $refNr;
        }
     }
  }
  my @BBox = @{$form{$fSource}[fBBOX]} if ($refNr);
  if (($effect eq 'print') && ($form{$fSource}[fVALID]) && ($refNr))
  {   if (! defined $defGState)
      { prDefaultGrState();
      }

      if ($adjust)
      {   $stream .= "q\n";
          $stream .= fillTheForm(@BBox, $adjust);
          $stream .= "\n/Gs0 gs\n";
          $stream .= "/$namn Do\n";
          $stream .= "Q\n";
      }
      elsif (($x) || ($y) || ($rotate) || ($size != 1)
                  || ($xsize != 1)     || ($ysize != 1))
      {   $stream .= "q\n";
          $stream .= calcMatrix($x, $y, $rotate, $size,
                     $xsize, $ysize, $BBox[2], $BBox[3]);
          $stream .= "\n/Gs0 gs\n";
          $stream .= "/$namn Do\n";
          $stream .= "Q\n";
      }
      else
      {   $stream .= "\n/Gs0 gs\n";
          $stream .= "/$namn Do\n";

      }
      $sidXObject{$namn}   = $refNr;
      $sidExtGState{'Gs0'} = $defGState;
  }
  if ($runfil)
  {  $infil = prep($infil);
     $log .= "Form~$infil~$sidnr~$adjust~$effect~$tolerant";
     $log .= "~$x~$y~$rotate~$size~$xsize~$ysize\n";
  }
  if (! $pos)
  {  errLog("No output file, you have to call prFile first");
  }
  if (($effect ne 'print') && ($effect ne 'add'))
  {  undef $namn;
  }
  if (wantarray)
  {  my $images = 0;
     if (exists $form{$fSource}[fIMAGES])
     {  $images = scalar(@{$form{$fSource}[fIMAGES]});
     }
     return ($namn, $BBox[0], $BBox[1], $BBox[2],
             $BBox[3], $images);
  }
  else
  {  return $namn;
  }
}



##########################################################
sub prDefaultGrState
##########################################################
{  $objNr++;
   $defGState = $objNr;
   if (! $pos)
   {  errLog("No output file, you have to call prFile first");
   }

   $objekt[$objNr] = $pos;
   my $utrad = "$objNr 0 obj" . '<
           . ">>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<
                               "/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<
                                      "/BaseFont/$Font/Encoding/WinAnsiEncoding>>endobj\n";
             $font{$Font}[foINTNAMN]    = $fontAbbr;
             $font{$Font}[foREFOBJ]     = $objNr;
             $objRef{$fontAbbr}         = $objNr;
             $objekt[$objNr]            = $pos;
             $pos += syswrite UTFIL, $fontObjekt;
         }
         else
         {  my $fSource = $fontSource{$Font}[foSOURCE];
            my $ri      = rindex($fSource, '_');
            my $Source  = substr($fSource, 0, $ri);
            my $Page    = substr($fSource, ($ri + 1));

            if (! $fontSource{$Font}[foORIGINALNR])
            {  errLog("Couldn't find $Font, aborts");
            }
            else
            {  my $namn = extractObject($Source, $Page,
                                        $fontSource{$Font}[foORIGINALNR], 'Font');
            }
         }
      }
   }

   $aktuellFont[foEXTNAMN]   = $Font;
   $aktuellFont[foREFOBJ]    = $font{$Font}[foREFOBJ];
   $aktuellFont[foINTNAMN]   = $font{$Font}[foINTNAMN];
   $aktuellFont[foTYP]       = $font{$Font}[foTYP];

   $sidFont{$aktuellFont[foINTNAMN]} = $aktuellFont[foREFOBJ];
   if (! $pos)
   {  errLog("No output file, you have to call prFile first");
   }

   return ($aktuellFont[foINTNAMN], $aktuellFont[foEXTNAMN], $aktuellFont[foREFOBJ]);
}

sub skrivSida
{  my ($compressFlag, $streamObjekt, @extObj);
   if ($checkCs)
   {  @extObj = ($stream =~ m'/(\S+)\s*'gso);
      checkContentStream(@extObj);
   }
   if (( $compress ) && ( length($stream)  > 99 ))
   {   my $output = compress($stream);
       if ((length($output) > 25) && (length($output) < (length($stream))))
       {  $stream = $output;
          $compressFlag = 1;
       }
   }

   if (! $parents[0])
   { $objNr++;
     $parents[0] = $objNr;
   }
   my $parent = $parents[0];

   ##########################################
   #  Interaktiva funktioner läggs ev. till
   ##########################################

   if ($interAktivSida)
   {  my ($infil, $sidnr) = split(/\s+/, $interActive);
      ($NamesSaved, $AARootSaved, $AAPageSaved, $AcroFormSaved)
            = AcroFormsEtc($infil, $sidnr);
   }

   ##########################
   # Skapa resursdictionary
   ##########################
   my $resursDict = "/ProcSet[/PDF/Text]";
   if (scalar %sidFont)
   {  $resursDict .= '/Font << ';
      my $i = 0;
      for (sort keys %sidFont)
      {  $resursDict .= "/$_ $sidFont{$_} 0 R";
      }

      $resursDict .= " >>";
   }
   if (scalar %sidXObject)
   {  $resursDict .= '/XObject<<';
      for (sort keys %sidXObject)
      {  $resursDict .= "/$_ $sidXObject{$_} 0 R";
      }
      $resursDict .= ">>";
   }
   if (scalar %sidExtGState)
   {  $resursDict .= '/ExtGState<<';
      for (sort keys %sidExtGState)
      {  $resursDict .= "\/$_ $sidExtGState{$_} 0 R";
      }
      $resursDict .= ">>";
   }
   if (scalar %sidPattern)
   {  $resursDict .= '/Pattern<<';
      for (sort keys %sidPattern)
      {  $resursDict .= "/$_ $sidPattern{$_} 0 R";
      }
      $resursDict .= ">>";
   }
   if (scalar %sidShading)
   {  $resursDict .= '/Shading<<';
      for (sort keys %sidShading)
      {  $resursDict .= "/$_ $sidShading{$_} 0 R";
      }
      $resursDict .= ">>";
   }
   if (scalar %sidColorSpace)
   {  $resursDict .= '/ColorSpace<<';
      for (sort keys %sidColorSpace)
      {  $resursDict .= "/$_ $sidColorSpace{$_} 0 R";
      }
      $resursDict .= ">>";
   }


   my $resursObjekt;

   if (exists $resurser{$resursDict})
   {  $resursObjekt = $resurser{$resursDict};  # Fanns ett identiskt,
   }                                           # använd det
   else
   {   $objNr++;
       if ( keys(%resurser) < 10)
       {  $resurser{$resursDict} = $objNr;  # Spara 10 första resursobjekten
       }
       $resursObjekt   = $objNr;
       $objekt[$objNr] = $pos;
       $resursDict     = "$objNr 0 obj<<$resursDict>>endobj\n";
       $pos += syswrite UTFIL, $resursDict ;
    }
    my $sidObjekt;

    if (! $touchUp)
    {   #
        # Contents objektet skapas
        #

        my $devX = "900";
        my $devY = "900";

        my $mellanObjekt = '<
        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<>stream\n" . "$stream";
           $stream .= "\nendstream\nendobj\n";
           $pos += syswrite UTFIL, $stream;
        }
        $sidObjekt = "$sidObjNr 0 obj\n<
                      . "/MediaBox \[$genLowerX $genLowerY $genUpperX $genUpperY\]"
                      . "/Resources <>>>";
    }
    else
    {   my $langd = length($stream);

        $objNr++;
        $objekt[$objNr] = $pos;
        if (! $compressFlag)
        {  $streamObjekt  = "$objNr 0 obj<>stream\n" . $stream;
           $streamObjekt .= "\nendstream\nendobj\n";
        }
        else
        {  $stream = "\n" . $stream . "\n";
           $langd++;

           $streamObjekt  = "$objNr 0 obj<
                             . "/Length $langd>>stream" . $stream;
           $streamObjekt .= "endstream\nendobj\n";
        }

        $pos += syswrite UTFIL, $streamObjekt;
        $streamObjekt = $objNr;
        ##################################
        # Så skapas och skrivs sidobjektet
        ##################################

        $sidObjekt = "$sidObjNr 0 obj<
                      . "/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<
    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<>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<>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<
   # $nodObjekt .= "/MediaBox \[$genLowerX $genLowerY $genUpperX $genUpperY\]";
   $nodObjekt .= " >>endobj\n";
   $objekt[$slutNod] = $pos;
   $pos += syswrite UTFIL, $nodObjekt;

}

sub findGet
{  my ($fil, $cid) = @_;
   $fil =~ s|\s+$||o;
   my ($req, $extFil, $tempFil, $fil2, $tStamp, $res);

   if (-e $fil)
   {  $tStamp = (stat($fil))[9];
      if ($cid)
      {
        if ($cid eq $tStamp)
        {  return ($fil, $cid);
        }
      }
      else
      {  return ($fil, $tStamp);
      }
   }
   if ($cid)
   {  $fil2 = $fil . $cid;
      if (-e $fil2)
      {  return ($fil2, $cid);
      }
   }
   errLog("The file $fil can't be found, aborts");
}

sub definieraId
{  if ($idTyp eq 'rep')
   {  if (! defined $id)
      {  errLog("Can't replicate the id if is missing, aborting");
      }
      my $tempId = $id;
      undef $id;
      return ($tempId, $tempId);
   }
   elsif ($idTyp eq 'add')
   {  $id++;
      return ($id, $id);
   }
   else
   {  my $str = time();
      $str .= $filnamn . $pos;
      $str  = Digest::MD5::md5_hex($str);
      return ($str, $str);
   }
}

sub prStrWidth
{  require PDF::Reuse::Util;
   my $string   = shift;
   my $Font     = shift;
   my $FontSize = shift || $fontSize;
   my $w = 0;

   # there's no use continuing if no string is passed in
   if (! defined($string))
   {  errLog("undefined value passed to prStrWidth");
   }

   if (length($string) == 0)
   {  return 0;
   }

   if(my($width) = ttfStrWidth($string, $Font, $FontSize))
   {  return $width;
   }

   if (! $Font)
   {  if (! $aktuellFont[foEXTNAMN])
      {  findFont();
      }
      $Font = $aktuellFont[foEXTNAMN];
   }

   if (! exists $PDF::Reuse::Util::font_widths{$Font})
   {  if (exists $stdFont{$Font})
      {  $Font = $stdFont{$Font};
      }
      if (! exists $PDF::Reuse::Util::font_widths{$Font})
      {   $Font = 'Helvetica';
      }
   }

   if (ref($PDF::Reuse::Util::font_widths{$Font}) eq 'ARRAY')
   {   my @font_table = @{ $PDF::Reuse::Util::font_widths{$Font} };
       for (unpack ("C*", $string))
       {  $w += $font_table[$_];
       }
   }
   else
   {   $w = length($string) * $PDF::Reuse::Util::font_widths{$Font};
   }
   $w = $w / 1000 * $FontSize;

   return $w;
}

sub prTTFont
{  return prFont() if ! @_;
   my($selector, $fontname) = @_;

   # Have we loaded this font already?
   my $ttfont = findTTFont($selector);
   if (! $ttfont  and  $font{$selector} )
   {  return prFont($selector);
   }
   $fontname = $ttfont->fontname if $ttfont;

   # Create a new TTFont object if we haven't loaded this one before
   if (! $ttfont)
   {  $docProxy ||= PDF::Reuse::DocProxy->new(
         next_obj => sub { ++$objNr },
         prObj    => \&prObj,
      );

      my $ttfont = PDF::Reuse::TTFont->new(
         filename => $selector,
         fontname => $fontname,
         fontAbbr => 'Ft' . ++$fontNr,
         docProxy => $docProxy,
      );
      $fontname = $ttfont->fontname;

      $font{$fontname}[foINTNAMN]      = $ttfont->fontAbbr;
      $font{$fontname}[foREFOBJ]       = $ttfont->obj_num;
      $font{$fontname}[foFONTOBJ]      = $ttfont;
      $objRef{$ttfont->fontAbbr}       = $ttfont->obj_num;
      $fontSource{$fontname}[foSOURCE] = 'Standard';
   }

   my $oldIntNamn = $aktuellFont[foINTNAMN];
   my $oldExtNamn = $aktuellFont[foEXTNAMN];

   $aktuellFont[foEXTNAMN]   = $fontname;
   $aktuellFont[foREFOBJ]    = $font{$fontname}[foREFOBJ];
   $aktuellFont[foINTNAMN]   = $font{$fontname}[foINTNAMN];
   $aktuellFont[foTYP]       = $font{$fontname}[foTYP];

   $sidFont{$aktuellFont[foINTNAMN]} = $aktuellFont[foREFOBJ];

   if (wantarray)
   { return ($aktuellFont[foINTNAMN], $aktuellFont[foEXTNAMN], $oldIntNamn, $oldExtNamn, \%font);
   }
   else
   { return $aktuellFont[foINTNAMN];
   }
}


sub prObj
{  my($objNr, $data) = @_;

   $objekt[$objNr] = $pos;
   $pos += syswrite UTFIL, $data;
}


sub findTTFont
{  my $selector = shift || $aktuellFont[foEXTNAMN];

   return $font{$selector}[foFONTOBJ] if $font{$selector};
   foreach my $name (keys %font)
   {  if (  $font{$name}[foINTNAMN] eq $selector
         or $font{$name}[foFONTOBJ] && $font{$name}[foFONTOBJ]->filename eq $selector
      )
      {  return $font{$name}[foFONTOBJ];
      }
   }
   return;
}


sub ttfStrWidth
{  my($string, $selector, $fontsize) = @_;

   my $ttfont = findTTFont($selector) or return;
   return $ttfont->text_width($string, $fontsize);
}


# This 'glue' package emulates the bits of the Text::PDF::File API that are
# needed by Text::PDF::TTFont0 (below) and ties them in to the PDF::Reuse API.

package PDF::Reuse::DocProxy;

sub new
{  my $class = shift;

   my $self = bless { ' version' => 3, @_, '>buffer'  => '', }, $class;
}


sub new_obj
{  my $self = shift;
   my $obj  = shift  or die 'No base for new_obj';

   my $num = $self->{next_obj}->();
   my $gen = 0;

   $self->{' objcache'}{$num, $gen} = $obj;
   $self->{' objects'}{$obj->uid}   = [ $num, $gen ];
   return $obj;
}


sub object_number
{  my($self, $obj) = @_;
   my $num = $self->{' objects'}{$obj->uid} || return;
   return $num->[0];
}


sub print
{  my($self, $data) = @_;

   if(my($tail, $rest) = $data =~ m{\A(.*?\nendobj\n)(.*)\z}s)
   {  my($obj_num) = $self->{'>buffer'} =~ /(\d+)/;
      # Pass serialised object back to PDF::Reuse
      $self->{prObj}->($obj_num, $self->{'>buffer'} . $tail);
      $self->{'>buffer'} = $rest;
   }
   else
   {  $self->{'>buffer'} .= $data;
   }
}


sub printf
{  my($self, $format, @args) = @_;;
   $self->print(sprintf($format, @args));
}


sub out_obj
{  my($self, $obj) = @_;
   return $self->new_obj($obj) unless defined $self->{' objects'}{$obj->uid};
   push @{ $self->{'>todo'} }, $obj->uid;
}


sub tell
{  return length shift->{'>buffer'};
}


sub write_objects
{  my($self) = @_;

   $self->{'>done'} = {};
   $self->{'>todo'} = [ sort map { $_->uid } values %{ $self->{' objcache'} } ];
   while(my $id = shift @{ $self->{'>todo'} }) {
      next if $self->{'>done'}{$id};
      my($num, $gen) = @{ $self->{' objects'}{$id} };
      $self->printf("%d %d obj\n", $num, $gen);
      $self->{' objcache'}{$num, $gen}->outobjdeep($self, $self);
      $self->print("\nendobj\n");
      $self->{'>done'}{$id}++;
   }
}


# This is a wrapper around Text::PDF::TTFont0, which provides support for
# embedding TrueType fonts

package PDF::Reuse::TTFont;

sub new
{  my $class = shift;

   require Text::PDF::TTFont0;

   my $self = bless { 'subset'   => 1, @_, }, $class;

   $self->{ttfont} = Text::PDF::TTFont0->new(
      $self->{docProxy},
      $self->{filename},
      $self->{fontAbbr},
      -subset => $self->{subset},
   );
   $self->{ttfont}->{' subvec'} = '';

   $self->{obj_num} = $self->{docProxy}->object_number($self->{ttfont});

   $self->{fontname} ||= $self->find_name();

   return $self;
}

sub filename  { return $_[0]->{filename};     }
sub fontname  { return $_[0]->{fontname};     }
sub obj_num   { return $_[0]->{obj_num};      }
sub fontAbbr  { return $_[0]->{fontAbbr};     }
sub docProxy  { return $_[0]->{docProxy};     }

sub find_name
{  my $self = shift;
   my($filebase) = $self->filename =~ m{.*[\\/](.*)\.};
   my $font = $self->{ttfont}->{' font'} or return $filebase;
   my $obj  = $font->{'name'}            or return $filebase;
   my $name = $obj->read->find_name(4)   or return $filebase;
   $name =~ s{\W}{}g;
   return $name;
}

sub encode_text
{  my($self, $text) = @_;
   $text =~ s|\\\(|(|gos;
   $text =~ s|\\\)|)|gos;
   return $self->{ttfont}->out_text($text);
}

sub text_width
{  my($self, $text, $size) = @_;
   return $self->{ttfont}->width($text) * $size;
}

sub DESTROY
{  my $self = shift;
   if(my $ttfont = $self->{ttfont})
   {  if(my $font = delete $ttfont->{' font'})
      { $font->release();
      }
      $ttfont->release();
   }
   %$self = ();
}


package PDF::Reuse;  # Applies to the autoloaded methods below (?)

1;

__END__