Index: Reuse.pm
===================================================================
RCS file: /var/lib/cvs/mike/pkg/misc/PDF-Reuse/Reuse.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- Reuse.pm	6 Jun 2008 03:11:50 -0000	1.1
+++ Reuse.pm	6 Jun 2008 03:33:02 -0000	1.2
@@ -15,7 +15,7 @@
 use autouse 'Data::Dumper'   => qw(Dumper);
 use AutoLoader qw(AUTOLOAD);
 
-our $VERSION = '0.33';
+our $VERSION = '0.34';
 our @ISA     = qw(Exporter);
 our @EXPORT  = qw(prFile
                   prPage
@@ -50,13 +50,14 @@
                   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,
+    $confuseObj, $compress, $pos, $fontNr, $objNr, $docProxy,
     $defGState, $gSNr, $pattern, $shading, $colorSpace, $totalCount);
  
 our (@kids, @counts, @formBox, @objekt, @parents, @aktuellFont, @skapa,
@@ -134,6 +135,7 @@
 use constant   foORIGINALNR => 3;
 use constant   foSOURCE     => 4;
 use constant   foTYP        => 5;
+use constant   foFONTOBJ    => 6;
 
 ##########
 # Övrigt
@@ -446,6 +448,8 @@
   }
   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 
@@ -467,7 +471,11 @@
   
   unless($rot)
   {  $stream .= "\nBT /$Font $fontSize Tf ";
-     unless ($aktuellFont[foTYP])
+     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
@@ -497,11 +505,12 @@
      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 \($TxT\) Tj ET\n"   # text @ 0,0
+                . "$x_align_offset 0 Td $encText Tj ET\n"   # text @ 0,0
                 . "Q\n";                                    # close the stack frame
   }
   if (! $pos)
@@ -1006,7 +1015,12 @@
     if ($stream)
     { skrivSida(); }
     skrivUtNoder();
-   
+
+    if($docProxy)
+    {  $docProxy->write_objects;
+       undef $docProxy;             # Break circular refs
+    }
+
     ###################
     # Skriv root 
     ###################
@@ -1237,6 +1251,270 @@
       return ($str, $str);
    }     
 }
+
+sub prStrWidth 
+{  require PDF::Reuse::Util;
+   my $string   = shift;
+   my $Font     = shift;
+   my $FontSize = shift || $fontSize;
+   my $w = 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;
+}
+
+
+package PDF::Reuse;  # Applies to the autoloaded methods below (?)
+
 1;
 
 __END__
@@ -1355,6 +1633,7 @@
         prJpeg<BR>
         prFont<BR>
         prFontSize<BR>
+        prTTFont<BR>
         prGraphState<BR>
         prAdd<BR>
         prText<BR>
@@ -2400,8 +2679,8 @@
 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. If some other font is given, Helvetica is used, and the
-returned value will at the best be approximate.
+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 
 
@@ -2410,8 +2689,8 @@
 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 will give
-reliable values for $xTo.      
+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.
 
@@ -2470,6 +2749,39 @@
    
    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('Some text in Arial');
+  #
+  # ... later ...
+  #
+  prTTFont($arial);
+  prFontSize(12);
+  prText('Some more text in Arial');
+
+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
 
@@ -2809,43 +3121,6 @@
     return $objNr;
 }
 
-sub prStrWidth 
-{  require PDF::Reuse::Util;
-   my $string   = shift;
-   my $Font     = shift;
-   my $FontSize = shift || $fontSize;
-   my $w = 0;
-    
-  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 prBookmark
 {   my $param = shift;
