#
# 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";

=pod

=head1 NAME

PDF::Core - Core Library for PDF library

=head1 SYNOPSIS

  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);
  

=head1 DESCRIPTION

The main purpose of the PDF::Core library is to provide the data structure
and the constructor for the more general PDF library.

=cut

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
#
#################################################################

=pod

=head1 Helper functions

This functions are not part of the class, but perform useful services.

=cut

#
# Modification by johi: 18.12.1999
#

#################################################################
=pod

=head2 UnQuoteName ( string )

This function processes quoted characters in a PDF-name. PDF-names returned by
B<GetObject> are already processed by this function.

Returns a string.

=cut

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

#################################################################
=pod

=head2 UnQuoteString ( string )

This function extracts the text from PDF-strings and PDF-hexstrings.
It will process all quoted characters and remove the enclosing braces.

WARNING: The current version doesn't handle unicode strings properly.

Returns a string.

=cut

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;
	}

#################################################################
=pod

=head2 QuoteName ( string )

This function quotes problematic characters in a PDF-name. This
function should be used before writing a PDF-name back to a PDF-file.

Returns a string.

=cut

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

#################################################################
=pod

=head2 QuoteHexString ( string )

This function translates a string into a PDF-hexstring. 

Returns a string.

=cut

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

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

#################################################################
=pod

=head2 QuoteString ( string )

This function translates a string into a PDF-string. Problematic
character will be quoted.

WARNING: The current version doesn't handle unicode strings properly.

Returns a string.

=cut

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 . ")");
	}

#################################################################
=pod

=head2 PDFGetPrimitive ( filehandle, offset )

This internal function is used while parsing a PDF-file. If you are
not writing extentions for this library and are parsing some special
parts of the PDF-file, stay away and use B<GetObject> instead.

This function has many quirks and limitations. Check the source for details.

=cut

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;
	}

#################################################################
=pod

=head2 PDFGetline ( filehandle, offset )

This internal function was used to read a line from a PDF-file. It has
many limitations and you should stay away from it, if you don't know
what you are doing. Use B<GetObject> or B<PDFGetPrimitive> instead.

=cut

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
#
#################################################################

=pod

=head1 Constructor

=cut

#################################################################
=pod

=head2 new ( [ filename ] )

This is the constructor of a new PDF object. If the filename is
missing, it returns an empty PDF descriptor ( can be filled with
$pdf->TargetFile). Otherwise, It acts as the B<PDF::Parse::TargetFile>
method.

=cut

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
#
#################################################################

=pod

=head1 Methods

The available methods are:

=cut

#################################################################
=pod

=head2 GetObject (reference)

This methods returns the PDF-object for B<reference>. The string
B<reference> must match the regular expression /^\d+ \d+ R$/,
where the first number is the object number, the second number the
generation number.

The return value is a PDF-primitive, the type depends on the content
of the object:

=over

=item B<undef>

The object could not be found or an error. Not all referenced objects
need to be present in a PDF-file. This value can be ignored.

=item B<Hash Reference>

If (UNIVERSAL::isa ($retval, "HASH") is true, the object is a
PDF-dictionary. The keys of the hash should be either a PDF name (eg:
/MediaBox) or a generated value like Stream_Offset. Everything else is
an error.

The values of the hash can be any PDF-primitive, including PDF-arrays
and other dictionaries.

This is the most common value returned by GetObject. If the key
Stream_Offset exists, the dictionary is followed by stream data,
starting at the file offeset indicated by this value.

=item B<Array Reference>

If (UNIVERSAL::isa ($retval, "ARRAY") is true, the object is a
PDF-array. Each element may be of a different type, and may contain
further references to arrays or any other PDF-primitive.

=item B<String matching /^\d+ \d+ R$/>

This is a reference to another PDF-Object. This value can be passed to
GetObject. This kind of value may appear instead of most other types.
Some PDF-writing programs seem to have special fun writing references
when a simple number is expected. If the final number is need, use
code like this to resolve references:

while ($len =~ m/^\d+ \d+ R$/) {$len = $self->GetObject ($len);	}

Example: 22 0 R

=item B<String matching /^\//>

This is a Name in a PDF dictionary. This string is already processed
by B<UnQuotName> and may differ from the value in the PDF-file. In
some very old andstrange non-standard PDF-files, this may lead to
confusion.

Example: /MediaBox

=item B<String matching /^\(.*\)$/>

This is a string. It may contain newlines, quoted characters und other
strange stuff. Use PDF::UnQuoteString to extract the text.

Example: (This is\na string with two \(2\) lines.)

=item B<String matching /^E<lt>.*E<gt>$/>

This is a hex encoded string. Use PDF::UnQuoteString to extract the text.

Example: E<lt>48 45 4c4C4 F1cE<gt>

=item B<String matching /^[\d.\+\-]+$/>

This is probably a number.

Example: 611

=item B<String matching none of the above>

this is either a PDF bareword (eg. true, false, ...) or a value
generated by this method like Stream_Offset.

Example: true

=back

To improve performance GetObject uses an internal cache for objects.
Repeated requests for the same objects are not read form the file but
satisfied from the cache. With the Variable B<$PDF::Core::UseObjectCache>,
the caching mechanism can be turned off.

B<WARNING>

Special care must be taken, when returned objects are modified. If the
object contains sub-objects, the sub-objects are not duplicated and
all changes affect all other copies of this object. Use your own copy,
if you need to modify those values.

=cut

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__

=pod

=head1 Variables

Available variables are:

=over 4

=item B<$PDF::Core::VERSION>

Contains the version of the library installed

=item B<$PDF::Core::UseObjectCache>

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.

=back 4

=head1 Copyright

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

This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=head1 Availability

The latest version of this library is likely to be available from:

http://www.geocities.com/CapeCanaveral/Hangar/4794/

=cut