afont.pm

PDF-API2-0.2.3.7_dev.tar.gz

package Text::PDF::AFont;

# $VERSION = "0.499"; # created before Text::PDF::API version 0.5 (final)
$VERSION = "0.5"; # created before PDF::API2 version 0.1.x (beta)

# use strict;
use vars qw(@ISA);
@ISA = qw(Text::PDF::Dict);

use POSIX;
use Text::PDF::Utils;
use Compress::Zlib;
use File::Find;

=head1 NAME

Text::PDF::AFont - Embedding of Adobe PFB/PFA + AFM format fonts. Inherits from
L<Text::PDF::Dict>

=head1 METHODS

=head2 Text::PDF::AFont->new $parent, $name, $psfile, $afmfile, $pdfname [ , $encoding [ , @glyphs ]]

Creates a new font object with given parent and name from pfb/pfa from psfile
and afm from afmfile.

The $pdfname is the name that this particular font object will be referenced
by throughout the PDF file. If you want to play silly games with naming, then
you can write the code to do it!

The $encoding is the name of one of the encoding schemes specified in the
pdf-specification (v1.3 2nd Ed.), 'latin1' or 'custom'. 'latin1' is a variant of 
the standard WinAnsiEncoding especially customized for iso-8859-1 (aka. iso-latin-1).
If you use 'custom' as encoding, you have to supply the @glyphs array which should
specify 256 glyph-names as defined by the "PostScript(R) Language Reference 3rd. Ed. -- Appendix E" 

If you do not give $encoding, than the afms internal encoding is used.

If you give an unknown $encoding, the encoding defaults to WinAnsiEncoding.

Returns the new font object.

=head2 Text::PDF::AFont->newNonEmbed $parent, $afmfile, $pdfname [ , $encoding [, @glyphs ]]

Creates a new font object with given parent and name from pfb/pfa from psfile
and afm from afmfile.

All the rules for Text::PDF::AFont->new apply here, but instead of having a embedded font
included in the pdf-file you only have a reference to the font included in the pdf-file.
This results in far smaller filesizes, but requires the viewing/printing application to
have the actual font properly installed at their platform.

Returns the new font object.

=head2 Text::PDF::AFont->newCore $parent, $fontname, $pdfname [, $encoding [, @glyphs ]]

Creates a new font object with given parent and fontname from one of the 14 Adobe Core Fonts
as supported by the Adobe PDF Reader applications versions 3.0 and up.

Valid values for fontname are:

	Courier-Bold
	Courier-BoldOblique
	Courier-Oblique
	Courier
	Helvetica-Bold
	Helvetica-BoldOblique
	Helvetica-Oblique
	Helvetica
	Symbol
	Times-Bold
	Times-BoldItalic
	Times-Italic
	Times-Roman
	ZapfDingbats

All the rules of Text::PDF::AFont->newNonEmbed apply here, but don't require you to specify an afm-file
since the fonts are internally supported by both the Adobe PDF Reader applications and this module.

Returns the new font object.

=cut

sub resolveFontFile {
        my $file=shift @_;
        my $fontfile=undef;
        if ( -e $file ) {
                $fontfile=$file;
        } else {
		map { my $f="$_/$file"; $fontfile=$f if(-e $f); } (map { ("$_/PDF/API2/fonts/t1", "$_/Text/PDF/fonts/t1"); }  @INC) ;
        }
	return $fontfile;
}

sub readAFM {
	my ($self,$file)=@_;
	$self->{' AFM'}={};
	if(! -e $file) {die "file='$file' not existant.";}
	open(AFMF, $file) or die "Can't find the AFM file for $file";
	local($/, $_) = ("\n", undef);  # ensure correct $INPUT_RECORD_SEPARATOR
	while ($_=<AFMF>) {
		next if /^StartKernData/ .. /^EndKernData/;  # kern data not parsed yet
		next if /^StartComposites/ .. /^EndComposites/; # same for composites
		if (/^StartCharMetrics/ .. /^EndCharMetrics/) {
		# only lines that start with "C" or "CH" are parsed
			next unless $_=~/^CH?\s/;
			my($ch)   = $_=~/^CH?\s+(\d+)\s*;/;
			$ch=$ch||0;
			my($name) = $_=~/\bN\s+(\.?\w+)\s*;/;
			my($wx)   = $_=~/\bWX\s+(\d+)\s*;/;
			my($bbox)    = $_=~/\bB\s+([^;]+);/;
			$bbox =~ s/\s+$//;
			# Should also parse lingature data (format: L successor lignature)
			$self->{' AFM'}->{'wx'}{$name} = $wx ;
			$self->{' AFM'}->{'bbox'}{$name} = $bbox ;
			if($ch>0) {
				$self->{' AFM'}->{'char'}[$ch]=$name ;
			} 
			next;
		}
		last if $_=~/^EndFontMetrics/;
		if (/(^\w+)\s+(.*)/) {
			my($key,$val) = ($1, $2);
			$key = lc $key;
			if (defined $self->{' AFM'}->{$key}) {
			#	$self->{' AFM'}->{$key} = [ $self->{' AFM'}->{$key} ] unless ref $self->{' AFM'}->{$key};
			#	push(@{$self->{' AFM'}->{$key}}, $val);
			} else {
				$val=~s/[\x00\x1f]+//g;
				$self->{' AFM'}->{$key} = $val;
			}
		} else {
           		print STDERR "Can't parse: $_";
		}
	}
	close(AFMF);
	unless (exists $self->{' AFM'}->{wx}->{'.notdef'}) {
		$self->{' AFM'}->{wx}->{'.notdef'} = 0;
		$self->{' AFM'}->{bbox}{'.notdef'} = "0 0 0 0";
	}
	$self->{' AFM'}->{'fontname'}=~s/[\x00-\x1f]+//cg;

}

sub readPSF {
	my ($self,$ascii,$bin)=@_;
	my (@asci,%h,$x);
	
	@asci=split(/[\x0d\x0a]+/,$ascii);
	foreach my $line (@asci){
		$h{lc($1)}=$2 if($line=~/^\/(\w+)([^\w].*)def$/) ;
	}	

	foreach my $x (keys %h) {
		$h{$x}=~s/^\s*[\(\[\{](.+)[\}\]\)]\s*readonly\s*$/$1/ci if($h{$x}=~/readonly/);	
		$h{$x}=~s/^\s+//cgi;
		$h{$x}=~s/\s+$//cgi;
	}
	$h{'fontname'}=~s|/||cgi;

	($x,$x,$x,$wy)=split(/\s+/,$h{'fontbbx'});


    my $newdata = "";

    # Conversion based on an C-program marked as follows:
    # /* Written by Carsten Wiethoff 1989 */
    # /* You may do what you want with this code,
    #    as long as this notice stays in it */

    my $input;
    my $output;
    my $ignore = 4;
    my $buffer = 0xd971;

    while ( length($bin) > 0 ) {
	($input, $bin) = $bin =~ /^(.)(.*)$/s;
	$input = ord ($input);
	$output = $input ^ ($buffer >> 8);
	$buffer = (($input + $buffer) * 0xce6d + 0x58bf) & 0xffff;
	next if $ignore-- > 0;
	$newdata .= pack ("C", $output);
    }

#	print $newdata;
    # End conversion.

	@asci=split(/[\x0d\x0a]/,$newdata);
        map {
                my($s,$t)=$_=~/^\/(\w+)\s(.+)\sdef$/;
                $t=~s|[\/\(\)\[\]\{\}]||cgi;
                $t=~s|^\s+||cgi;
                $t=~s|\s+$||cgi;
                $t=~s|\s+noaccess$||cgi;
                $h{lc($s)}=$t;
        } grep(/^\/(\w+)\s(.+)\sdef$/,@asci);
	@asci=grep(/^\/\w+\s\d+\sRD\s/,@asci);
	
	$h{'wx'}=();	
	$h{'bbx'}=();	
	foreach my $line (@asci) {
		my($ch,$num,$bin)=($line=~/^\/(\w+)\s+(\d+)\s+RD\s+(.+)$/);
	#	if($num>length($bin)){
	#		($ch,$num,$bin)=($newdata=~/\/($ch)\s+($num)\s+RD\s+(.+)ND/gm);
	#	}
		my @values;
		$input='';
		$output='';
		$ignore=4;
		$buffer=0x10ea; # =4330;
		# print "values1='".join('.',map { sprintf('%02X',unpack('C',$_)) } split(//,$bin))."'\n";
		# print "values1='".pack('H*',unpack('C*',split(//,$bin)))."'\n";
		while ( length($bin) > 0 ) {
			($input, $bin) = $bin =~ /^(.)(.*)$/s;
			$input = ord ($input);
			$output = $input ^ ($buffer >> 8);
			$buffer = (($input + $buffer) * 0xce6d + 0x58bf) & 0xffff;
			next if $ignore-- > 0;
			push(@values,$output);
		}
		# print "values2='".join(':',@values)."'\n";
		my @v2;
		while($input=shift @values) {
			if($input<32){
				push(@v2,$input);
				last;
			} elsif($input<247) {
				push(@v2,$input-139);
			} elsif($input<251) {
				my $w=shift @values;
				push(@v2,(($input-247)*256)+$w+108);
			} elsif($input<255) {
				my $w=shift @values;
				push(@v2,(-($input-251)*256)-$w-108);
			} else { # == 255
				#
				$output=pack('C',shift @values);
				$output.=pack('C',shift @values);
				$output.=pack('C',shift @values);
				$output.=pack('C',shift @values);
				$output=unpack('N',$output);
				push(@v2,$output);
			}
		}
		$input=pop(@v2);
		if($input==12){
			# print "unknown bbx command at glyph='$ch' stack='".join(',',@v2)."' command='$input'\n";
			$h{'wx'}{$ch}=$v2[2];
			$h{'bbx'}{$ch}=sprintf("%d %d %d %d",$v2[0],$v2[1],$v2[2]-$v2[0],$v2[3]-$v2[1]);
			# print "G='$ch' WX='$v2[2]' BBX='".$h{'bbx'}{$ch}."'\n";
		} elsif($input==13) {
			# print "unknown bbx command at glyph='$ch' stack='".join(',',@v2)."' command='$input'\n";
			$h{'wx'}{$ch}=$v2[1];
			$h{'bbx'}{$ch}=sprintf("%d %d %d %d",$v2[0],0,$v2[1]-$v2[0],$wy);
			# print "G='$ch' WX='$v2[1]' BBX='".$h{'bbx'}{$ch}."'\n";
		} else {
			# print "unknown bbx command at glyph='$ch' stack='".join(',',@v2)."' command='$input'\n";
			$h{'wx'}{$ch}=0;
			$h{'bbx'}{$ch}="0 0 0 0";
		}
	}
	my($llx,$lly,$urx,$ury,$l,$delta);
	# now we get the rest of the required parameters
	my @blue_val=split(/\s+/,$h{'bluevalues'});
	my @bbx=split(/\s+/,$h{'fontbbx'});
	#
	#capheight 
	# get ury from H or bbx and adjust per delta blue
	($llx,$lly,$urx,$ury)=split(/\s+/,$h{'bbx'}{'H'});
	$l=$ury||$bbx[3];
	$delta=10000;
	foreach my $b (@blue_val) {
		if($delta>abs($b-$l)){
			$delta=abs($b-$l);
		} else {
			$h{'capheight'}=$b;
			last;
		}
	}

	#xheight 
	# get ury from x or bbx/2 and adjust per delta blue
	($llx,$lly,$urx,$ury)=split(/\s+/,$h{'bbx'}{'x'});
	$l=$ury||POSIX::ceil($bbx[3]/2);
	$delta=10000;
	foreach my $b (@blue_val) {
		if($delta>abs($b-$l)){
			$delta=abs($b-$l);
		} else {
			$h{'xheight'}=$b;
			last;
		}
	}

	$h{'ascender'}=0;
	$h{'descender'}=0;

	$self->{' AFM'}={%h};
	$self->{' AFM'}->{fontname}=~s/[\x00-\x1f]+//cg;
	return(%h);
}

sub parsePS {
	my ($self,$file,$noFM)=@_;
	my ($l,$l1,$l2,$l3,$stream,@lines,$line,$head,$body,$tail);
	if(! -e $file) {die "file='$file' not existant.";}
	$l=-s $file;
	open(INF,$file);
	binmode(INF);
	read(INF,$line,2);
	@lines=unpack('C*',$line);
	if(($lines[0]==0x80) && ($lines[1]==1)) {
		read(INF,$line,4);
		$l1=unpack('V',$line);
		seek(INF,$l1,1);
		read(INF,$line,2);
		@lines=unpack('C*',$line);
		if(($lines[0]==0x80) && ($lines[1]==2)) {
			read(INF,$line,4);
			$l2=unpack('V',$line);
		} else {
			die "corrupt pfb in file '$file' at marker='2'.";