PDF::Core - Core Library for PDF library

  use PDF::Core;

  $pdf=PDF::Core->new ;
  $pdf=PDF->new(filename);

  $res= $pdf->GetObject($ref);

  $name = UnQuoteName($pdfname);							  
  $string = UnQuoteString($pdfstring);							  

  $pdfname = QuoteName($name);							  
  $pdfhexstring = QuoteHexString($string);
  $pdfstring = QuoteString($string);

  $obj = PDFGetPrimitive (filehandle, \$offset);
  $line = PDFGetLine (filehandle, \$offset);

  Copyright (c) 1998 - 2000 Antonio Rosella Italy antro@tiscalinet.it, Johannes Blach dw235@yahoo.com 

#
# PDF::Core.pm, version 1.11 February 2000 antro
#
# Copyright (c) 1998 - 2000 Antonio Rosella Italy antro@tiscalinet.it, Johannes Blach dw235@yahoo.com 
#
# Free usage under the same Perl Licence condition.
#

package PDF::Core;

$PDF::Core::VERSION = "1.11";

require 5.005;
use strict;
use Carp;
use Exporter ();

use vars qw(@ISA @EXPORT_OK $UseObjectCache);

@ISA = qw(Exporter);

@EXPORT_OK = qw( GetObject );

#
# Object caching
#
# If this variable is true, all processed objects will be added to the
# object cache. If only header information of a PDF are read or very
# big PDF are processed, turning off the cache reduces the memory usage.
#
$UseObjectCache = 1;


#################################################################
#
# Helper functions
#
#################################################################

#
# Modification by johi: 18.12.1999
#

#################################################################

sub UnQuoteName ($)
	{
	my $value = shift;
	$value =~ s/#([\da-f]{2})/chr(hex($1))/ige;
	return $value;
	}

#################################################################

sub UnQuoteString ($)
	{
#
# Translate quoted character. 
#
	my $param = shift;
	my $value;
	if (($value) = $param =~ m/^<(.*)>$/)
		{
		$value =~ tr/0-9A-Fa-f//cd;
		$value .= "0" if (length ($value) % 2);
		$value =~ s/([\da-f]{2})/chr(hex($1))/ige;
		}
	elsif (($value) = $param =~ m/^\((.*)\)$/)
		{
		my %quoted = ("n" => "\n", "r" => "\r",
					  "t" => "\t", "b" => "\b",
					  "f" => "\f", "\\" => "\\",
					  "(" => "(", ")" => ")");
		$value =~ s/\\([nrtbf\\()]|[0-7]{1,3})/
				defined ($quoted{$1}) ? $quoted{$1} : chr(oct($1))/gex;
		}
	else
		{
		$value = $param;
		}

	return $value;
	}

#################################################################

sub QuoteName ($)
	{
	my $value = shift;
	$value =~ s/(?<!\A)([\x00-\x20\x7f-\xff%()\[\]<>\/{}#])/
						 						 sprintf ("#%2.2X", ord($1))/gex;
	return $value;
	}

#################################################################

sub QuoteHexString ($)
	{
	my $value = shift;

	$value =~ s/(.)/sprintf ("%2.2X", ord($1))/ge;
	return ("<" . $value . ">");
	}

#################################################################

sub QuoteString ($)
	{
	#
	# Only \character style quotes will be added. The really important
	# characters to quote are: ()\
	# 
	my $value = shift;

	my %quote = ("\n" => "\\n", "\r" => "\\r",
				  "\t" => "\\t", "\b" => "\\b",
				  "\f" => "\\f", "\\" => "\\\\",
				  "(" => "\\(", ")" => "\\)");
	$value =~ s/([\n\r\t\b\f\\()])/$quote{$1}/g;
	return ("(" . $value . ")");
	}

#################################################################

sub PDFGetPrimitive (*\$)
	{
	my $fd = shift;
	my $offset = shift;

	binmode $fd;
	seek $fd, $$offset, 0;

	my $state = 0;
	my $buffer;
	my @collector;
	my $lastchar;

	while ()
		{
		# File offset is positioned on start of stream.
		last if ($state == -4);

		$state = 0;

		# Process last element
		if ($#collector >= 0)
			{
			my $lastvalue = $collector[$#collector];
			
			if ($lastvalue eq "R")
				{
				# Process references
				if ($#collector >= 2
					&& $collector[$#collector - 1] =~ m/\d+/
					&& $collector[$#collector - 2] =~ m/\d+/)
					{
					$collector[$#collector - 2] .= join (" ", 
						"", @collector[$#collector - 1, $#collector]);
					$#collector -= 2; 
					}
				else
					{
					carp "Bad reference at offset ", $$offset;
					}
				}
			elsif ($lastvalue eq "endobj")
				{
				# End of object
				last;
				}
			elsif ($lastvalue eq "stream")
				{
				# End of object
				$state = -4;
				}
			}
		
		# Set state for next element
		if ($buffer eq "[") 
			{
			# Read array
			$buffer = "";
			push @collector, [ PDFGetPrimitive ($fd, $offset) ];
			}
		elsif ($buffer eq "<<")
			{
			# Read dictionary
			$buffer = "";
			push @collector, { PDFGetPrimitive ($fd, $offset) };
			}
		elsif ($buffer eq "(") 
			{
			# Here comes a string
			$state = 1;
			$lastchar = "";
			}
		elsif ($buffer eq "<") 
			{
			# Here comes a hex string
			$state = -1;
			}
		elsif ($buffer eq ">")
			{
			# Wait for next > to terminate dictionary
			$state = -2;
			}
		elsif ($buffer eq "%")
			{
			# Skip comments
			$state = -3;
			$buffer = "";
			}
		elsif ($buffer eq "]")
			{
			last;
			}
		elsif ($buffer eq ">>")
			{
			last;
			}

		# Read next item
		while (read ($fd, $_, 1))
			{
			$$offset++;

			if ($state == 0)
				{
				# Normal mode
				if (m/[^\x00-\x20\x7f-\xff%()\[\]<>\/]/)
					{
					# Normal character inside a name or number
					$buffer .= $_;
					}
				elsif (m/[\/\(\[\]\<\>%]/)
					{
					if ($buffer ne "")
						{
						# A new item starts
						if ($buffer =~ m/^\//)
							{
							push @collector, UnQuoteName ($buffer);
							}
						else
							{
							push @collector, $buffer;
							}
						}
					$buffer = $_;
					last;
					}
				elsif (m/\s/)
					{
					# All kind of whitespaces are ignored
					if ($buffer ne "")
						{
						# The old item is done starts
						if ($buffer =~ m/^\//)
							{
							push @collector, UnQuoteName ($buffer);
							}
						else
							{
							push @collector, $buffer;
							}
						$buffer = "";
						last;
						}
					}
				else
					{
					# Strange character. Should not exist.
					# Complain and move on.
					carp "Strange character '", $_, "' at offset ",
					$$offset, " in mode ", $state, " detected";
					$buffer .= $_;
					}
				}
			elsif ($state > 0)
				{
				# We have a string

				if ($lastchar =~ m/\\[\r\n]+/ && m/[^\r\n]/)
					{
					# Clean up after line continuation
					$lastchar = "";
					}

				if ($lastchar =~ m/\\[\r\n]*/)
					{
					# Process character after backslash
					if (m/[\r\n]/)
						{
						# end of line
						$lastchar .= $_;
						}
					else
						{
						# Just a quote
						$buffer .= $lastchar . $_;
						$lastchar = "";
						}
					}
				else
					{
					if ($_ eq "\\")
						{
						# Quoted string starts
						$lastchar = $_;
						}
					elsif ($_ eq "(")
						{
						# Count braces
						$buffer .= $_;
						$state ++;
						}
					elsif ($_ eq ")")
						{
						# End of string
						$buffer .= $_;
						unless (-- $state)
							{
							push @collector, $buffer;
							$buffer = "";
							last;
							}
						}
					else
						{
						$buffer .= $_;
						}
					}
				}
			elsif ($state == -1)
				{
				if (m/[0-9a-f\s]/i)
					{
					# Hex character
					$buffer .= $_;
					}
				elsif ($_ eq ">")
					{
					# End of string
					$buffer .= $_;
					push @collector, $buffer;
					$buffer = "";
					last;
					}
				elsif ($_ eq "<" && $buffer eq "<")
					{
					# This is not a string, but a dictionary instead
					$buffer .= $_;
					last;
					}
				else
					{
					# Should not be there. Complain and add it to the $buffer
					carp "Bad character '", $_ , "' in hex string";
					$buffer .= $_;
					}
				}
			elsif ($state == -2)
				{
				# Wait for second > to terminate dictionary

				# Some sanity checks
				carp "Character '", $_, "' appeared while waiting for '>'" 
				if ($_ ne ">");
				carp "Buffer contains '", $buffer, "' and not '>'" 
				if ($buffer ne ">");

				$buffer = ">>";
				last;
				}
			elsif ($state == -3)
				{
				# Skip comments;
				last if (m/[\r\n]/);
				}
			elsif ($state == -4)
				{
				# Wait for newline to start stream

				if ($_ eq "\n")
					{
					# Some sanity checks
					carp "Text '", $buffer, 
					"' appeared while waiting for start of stream" 
					if ($buffer ne "");

					$buffer = "";
					last;
					}
				elsif (m/\S/)
					{
					$buffer .= $_;
					}
				}
			else
				{
				# Unhandled status. Complain and reset
				carp "Unhandled status ", $state;
				}
			}
		if ($_ eq "")
			{
			# Unhandled status. Complain and reset
			carp "Premature end of file reached";
			
			if ($buffer ne "")
				{
				push @collector, $buffer;
				$buffer = "";
				}
			last;
			}
		}

	return @collector;
	}

#################################################################

sub PDFGetline {
#
# BUG WARNING:
#
# This function returns only one line, which doesn't mean anything most of the
# time. Except for the fileheader and the xref-table, linebreaks can (and will!)
# occur everywhere in a PDF and are just whitespace. You may find only part of a
# PDF-primitve on one line, or more than one of them.
#
# If you want to read PDF-Primitves, use the function PDFGetPrimitive instead.
#
    my $fd = shift;
    my $offset=shift;

    my $buffer;
    my $endflag=1;

    binmode $fd;
    seek $fd, $$offset, 0;

    read($fd,$buffer,2);
    $buffer =~ s/^\r?\n?// ;

    $$offset +=2;

    while ($endflag) {
      read($fd,$_,1);
      $$offset++;
      $endflag = 0 if ( $_ eq "\r" || $_ eq "\n");
      $buffer = $buffer . $_ ;
    }
    return $buffer;
	}

#################################################################
#
# Constructors
#
#################################################################

#################################################################

sub new {

	my %PDF_Fields = (
		  File_Name => undef, # Name of file
		  File_Handler => undef, # Open handle to file
		  Header => undef, # Identification string

		  Objects => [], # Offset of objects
		  Gen_Num => [], # Genereation number of objects
		  Object_Length => [],	# Length of processed objects
		  Object_Cache => {}, # Cache for objects.
		  Page => [], # Information about all pages. Useful.

		  Updated => 0,	# Is the PDF updated 
		  Last_XRef_Offset => undef, # File offset of active Xref table
		  Trailer => {}, # Content of active trailer
		  Info => {}, # Content of active info object
		  Catalog => {}, # Content of catalog
		  PageTree => {}, # Content of root page
		  );
my $that = shift;
my $class=ref($that) || $that ;
  my $self = \%PDF_Fields ;
  my $buf2=bless $self, $class;
  if ( @_ ) { 			# I have the filename
    $buf2->TargetFile($_[0]) ; 
  }
  return bless $self, $class;
};

#################################################################
sub DESTROY {
#
# Close the file if not empty
#
  my $self = shift;
  close ( $self->{File_Handler} ) if $self->{File_Handler} ;
}

#################################################################
#
# Methods
#
#################################################################

#################################################################

sub GetObject (\*$;$)
	{
	my $self = shift;
	my $ref = shift;
	my $force = shift;

#
# Is PDF file open?
#
	croak "PDF-file not open." unless ($self->{"File_Handler"});

#
# Check reference
#
	my ($ind, $gen);
	unless (($ind,$gen) = $ref =~ m/^(\d+) (\d+) R$/)
		{
		carp "Bad object reference '", $_, "'";
		return undef;
		}
	if ($ind > $#{$self->{"Gen_Num"}} || $self->{"Gen_Num"}[$ind] != $gen)
		{
		#
		# The page does not exist. According to the PDF specification,
		# this is not an error.
		#
		return undef;
		}

	# Remove leading zero for cache key.
	$ind += 0;
	# Check cache
	if ($UseObjectCache && ! $force
		&& defined($self->{"Object_Cache"}{$ind}))
		{
		return $self->{"Object_Cache"}{$ind};
		}

	my $offset = $self->{"Objects"}[$ind];
	my @data = PDFGetPrimitive ($self->{"File_Handler"}, $offset);

	unless ($#data == 4  && $data[0] == $ind 
		&& $data[1] == $gen && $data[2] eq "obj")
		{
		carp "Object mismatch: Got '", join (" ", @data[0..2]),
		"' instead of '", join (" ", $ind, $gen, "obj"), "'";
		return;
		}

	#
	# An object is not always a dictionary. In such cases,
	# adding additional keys breaks the content.
	#
	if (UNIVERSAL::isa ($data[3], "HASH"))
		{
		if ($data[4] eq "stream")
			{
			#
			# Find end of a stream object
			#
			$data[3]{"Stream_Offset"} = $offset;
			my $len = $data[3]{"/Length"};

			# Length can be a reference to another object. 
			# Resolve references in this case till something else appears.
			while ($len =~ m/^\d+ \d+ R$/)
				{
				$len = $self->GetObject ($len);
				}

			# Skip stream
			if ($len =~ m/^\d+$/)
				{
				$offset += $len;
				}
			else
				{
				carp "Strange: /Length resolves to '", $len, "' in object ", 
				join (" ", @data[0..2]);
				}

			my @enddata = PDFGetPrimitive ($self->{"File_Handler"}, $offset);
			$data[4] = $enddata[$#enddata];
			}
		}

	#
	# Save length of object.
	#
	$self->{"Object_Length"}[$ind] = $offset - $self->{"Objects"}[$ind];

	carp "Bad object termination '", $data[4], "' in object ", 
	join (" ", @data[0..2]) if ($data[4] ne "endobj");
	

	# Update cache
	$self->{"Object_Cache"}{$ind} = $data[3] if ($UseObjectCache);

	return $data[3];
	}

#
# End of Modification by johi: 18.12.1999
#
#################################################################


1;
__END__