File Coverage

lib/PostScript/Font.pm

Criterion	Covered	Total	%
statement	121	291	41.5
branch	47	182	25.8
condition	4	12	33.3
subroutine	17	39	43.5
pod	18	18	100.0
total	207	542	38.1

# RCS Status      : $Id: Font.pm,v 1.23 2005-06-10 22:56:37+02 jv Exp jv $
# Author          : Johan Vromans
# Created On      : December 1998
# Last Modified By: Johan Vromans
# Last Modified On: Wed Dec  6 13:38:31 2006
# Update Count    : 466
# Status          : Released

################ Module Preamble ################

package PostScript::Font;

use strict;

BEGIN { require 5.005; }

use IO qw(File);
use File::Spec;
use PostScript::StandardEncoding;
use PostScript::ISOLatin1Encoding;

use vars qw($VERSION);
$VERSION = "1.04";

# If you have the t1disasm program, have $t1disasm point to it.
# This speeds up the glyph fetching.
use vars qw($t1disasm);

sub new {
    my $class = shift;
    my $font = shift;
    my (%atts) = (error => 'die',
		  format => 'ascii',
		  verbose => 0, trace => 0, debug => 0,
		  @_);
    my $self = { file => $font };
    bless $self, $class;

    return $self unless defined $font;

    $self->{debug}   = $atts{debug};
    $self->{trace}   = $self->{debug} || $atts{trace};
    $self->{verbose} = $self->{trace} || $atts{verbose};

    my $error = lc($atts{error});
    $self->{die} = sub {
	die(@_)     if $error eq "die";
	warn(@_)    if $error eq "warn";
    };

    $atts{format} = "ascii" if lc($atts{format}) eq "pfa";
    $atts{format} = "binary" if lc($atts{format}) eq "pfb";

    $t1disasm = $self->_getexec ("t1disasm") unless defined $t1disasm;

    eval {

	$self->_loadfont ();

	# Reformat if needed.
	$self->{format} = "ascii";
	if ( lc($atts{format}) eq "asm" ) {
	    print STDERR ($self->{file}, ": Converting to ASM format\n")
	      if $self->{verbose};
	    $self->{data} = $self->_pfa2asm;
	    $self->{format} = "asm";
	}
	elsif ( lc($atts{format}) eq "binary" ) {
	    print STDERR ($self->{file}, ": Converting to Binary format\n")
	      if $self->{verbose};
	    $self->{data} = $self->_pfa2pfb;
	    $self->{format} = "binary";
	}

    };

    if ( $@ ) {
	$self->_die($@);
	return undef;
    }

    $self;
}

sub FileName	{ $_[0]->{file};      }
sub FontName	{ $_[0]->{name};      }
sub FamilyName	{ $_[0]->{family};    }
sub FontType	{ $_[0]->{type};      }
sub Version	{ $_[0]->{version};   }
sub ItalicAngle	{ $_[0]->{italic};    }
sub isFixedPitch{ $_[0]->{fixed};     }
sub Weight	{ $_[0]->{weight};    }
sub FontMatrix	{ $_[0]->{fontmatrix};}
sub FontBBox	{ $_[0]->{fontbbox};  }
sub DataFormat  { $_[0]->{dataformat} }

sub FontData	{
    my ($self, $format) = @_;
    if ( defined $format ) {
	# Not yet supported!
	return ${$self->_cvtinternal($format)};
    }
    $self->{data} = $self->_cvtinternal unless exists $self->{data};
    ${$self->{data}};
}

sub FontGlyphs {
    my $self = shift;
    $self->{glyphs} = $self->_getglyphnames unless exists $self->{glyphs};
    $self->{glyphs};
}

sub Encoding {
    my $self = shift;
    $self->{encoding} = $self->_getencoding unless exists $self->{encoding};
    $self->{encoding};
}

sub EncodingVector {
    my $self = shift;
    my $enc = $self->{encoding};
    return $enc if ref($enc) eq "ARRAY";
    # Return private copy for the standard encodings.
    if ( $enc eq "StandardEncoding" ) {
	return scalar PostScript::StandardEncoding->array;
    }
    elsif ( $enc eq "ISOLatin1Encoding" ) {
	return scalar PostScript::ISOLatin1Encoding->array;
    }
    undef;
}

sub StandardEncoding {
    return scalar PostScript::StandardEncoding->array;
}

sub ISOLatin1Encoding {
    return scalar PostScript::ISOLatin1Encoding->array;
}

sub _loadfont ($) {

    my $self = shift;
    my $data;			# font data
    my $type;

    my $fn = $self->{file};
    my $fh = new IO::File;	# font file
    my $sz = -s $fn;	# file size

    $fh->open ($fn) || $self->_die("$fn: $!\n");
    print STDERR ("$fn: Loading font file\n") if $self->{verbose};

    # Read in the font data.
    binmode($fh);		# (Some?) Windows need this
    my $len = 0;
    while ( $fh->sysread ($data, 32768, $len) > 0 ) {
	$len = length ($data);
    }
    $fh->close;
    $self->_die("$fn: Expecting at least 4 bytes, got ",
		length($data), " bytes\n")
      unless length($data) >= 4;

    $self->{dataformat} = 'ps';
    if ( substr($data,0,4) eq "\0\1\0\0" || substr($data, 0, 4) eq "OTTO" ) {
	# For the time being, Font::TTF is optional. Be careful.
	eval {
	    require PostScript::Font::TTtoType42;
	};
	if ( $@ ) {
	    $self->_die("$fn: Cannot convert True Type font\n");
	    return undef;
	}
	my $wrapper =
	  new PostScript::Font::TTtoType42:: ($fn,
					      verbose => $self->{verbose},
					      trace   => $self->{trace},
					      debug   => $self->{debug},
					     );
	$type = "t";
	$data = $wrapper->as_string;
	$self->{t42wrapper} = $wrapper;
	$self->{dataformat} = "type42";
	$self->{encoding} = "StandardEncoding";
    }
    else {
	# Make ref.
	$data = \"$data";		#";
    }

    print STDERR ("Read $len bytes from $fn\n") if $self->{trace};
    $self->_die("$fn: Expecting $sz bytes, got $len bytes\n")
      if $sz > 0 && $sz != $len;

    # Convert .pfb encoded font data.
    if ( $$data =~ /^\200[\001-\003]/ ) {
	print STDERR ("$fn: Converting to ASCII format\n") if $self->{verbose};
	$data = $self->_pfb2pfa ($data);
	$self->{dataformat} = 'pfa';
    }
    # Otherwise, must be straight PostScript.
    elsif ( $$data !~ /^%!/ ) {
	$self->_die("$fn: Not a recognizable font file\n");
	return undef;
    }

    # Normalise line endings.
    $$data =~ s/\015\012?/\n/g;

    $self->{data} = $data;
    $self->{type} = $type if defined $type;

    if ( $$data =~ /^%!FontType(\d+)\n\/(\S+)\n/ ) {
	$self->{type} = $1 unless defined $self->{type};
	$self->{name} = $2;
    }
    elsif ( $$data =~ /\/FontName\s*\/(\S+)/ ) {
	$self->{name} = $1;
    }
    elsif ( $$data =~ /\/FontName\s*\(([^\051]+)\)/ ) {
	$self->{name} = $1;
    }
    if ( $$data =~ /\/FamilyName\s*\/(\S+)/ ) {
	$self->{family} = $1;
    }
    elsif ( $$data =~ /\/FamilyName\s*\(([^\051]+)\)/ ) {
	$self->{family} = $1;
    }
    unless ( defined $self->{type} ) {
	$self->{type} = $1 if $$data =~ /\/FontType\s+(\d+)/;
    }
    $self->{version} = $1 if $$data =~ /\/version\s*\(([^\051]+)\)/;
    $self->{italic} = $1 if $$data =~ /\/ItalicAngle\s+([-+]?\d+)/;
    $self->{fixed} = $1 eq "true"
      if $$data =~ /\/isFixedPitch\s+(true|false)/;
    if ( $$data =~ /\/Weight\s*\/(\S+)/ ) {
	$self->{weight} = $1;
    }
    elsif ( $$data =~ /\/Weight\s*\(([^\051]+)\)/ ) {
	$self->{weight} = $1;
    }
    if ( $$data =~ /\/FontMatrix\s*\[\s*(\d+(?:\.\d*)?)\s+(\d+(?:\.\d*)?)\s+(\d+(?:\.\d*)?)\s+(\d+(?:\.\d*)?)\s+(\d+(?:\.\d*)?)\s+(\d+(?:\.\d*)?)\s*\]/ ) {
	$self->{fontmatrix} = [$1,$2,$3,$4,$5,$6];
    }
    if ( $$data =~ /\/FontBBox\s*\{\s*(-?\d+(?:\.\d*)?)\s+(-?\d+(?:\.\d*)?)\s+(-?\d+(?:\.\d*)?)\s+(-?\d+(?:\.\d*)?)\s*\}/ ) {
	$self->{fontbbox} = [$1,$2,$3,$4];
    }
    $self;
}

sub _qtfn ($) {
    my $f = shift;
    $f =~ s/([\\'])/'\\$1'/g;
    "'".$f."'";
}

sub _cvtinternal {
    my ($self, $format) = @_;
    return $self->{data} if $format eq $self->{format};
    undef;
}

sub _pfb2pfa ($;$) {
    my ($self, $data) = @_;	# NOTE: data is a ref!
    my $newdata = "";		# NOTE: will return a ref

    $data = $self->{data} unless defined $data;

    # Structure of .pfb font data:
    #
    #	( ASCII-segment | Binary-segment )+ EOF-indicator
    #
    #	ASCII-segment: \200 \001 length data
    #	Binary-sement: \200 \002 length data
    #	EOF-indicator: \200 \003
    #
    #	length is a 4-byte little endian 'long'.
    #	data   are length bytes of data.

    my $bin = "";		# accumulated unprocessed binary segments
    my $addbin = sub {		# binary segment processor
	print STDERR ("Processing binary segment, ",
		      length($bin), " bytes\n") if $self->{trace};
	($bin = uc (unpack ("H*", $bin))) =~ s/(.{64})/$1\n/g;
	$newdata .= $bin;
	$newdata .= "\n" unless $newdata =~ /\n$/;
	$bin = "";
    };

    while ( length($$data) > 0 ) {
	my ($type, $info, $seg);

	last if $$data =~ /^\200\003/; # EOF indicator

	# Get font segment.
	$self->_die($self->{file}, ": Invalid font segment format\n")
	  unless ($type, $info) = $$data =~ /^\200([\001-\002])(....)/s;

	my $len = unpack ("V", $info);
	# Can't use next statement since $len may be > 32766.
	# ($seg, $$data) = $$data =~ /^......(.{$len})(.*)/s;
	$seg = substr ($$data, 6, $len);
	$$data = substr ($$data, $len+6);

	if ( ord($type) == 1 ) {	# ASCII segment
	    $addbin->() if $bin ne "";
	    print STDERR ($self->{file}, ": ASCII segment, $len bytes\n")
	      if $self->{trace};
	    $newdata .= $seg;
	}
	else { # ord($type) == 2	# Binary segment
	    print STDERR ($self->{file}, ": Binary segment, $len bytes\n")
	      if $self->{trace};
	    $bin .= $seg;
	}
    }
    $addbin->() if $bin ne "";
    return \$newdata;
}

sub _pfa2pfb ($;$) {
    my ($self, $data) = @_;	# NOTE: data is a ref!

    $data = $self->{data} unless defined $data;

    return \do{"\200\001".pack("V",length($$data)).$$data."\200\003"}
      unless $$data =~ m{(^.*\beexec\s*\n+)
                         ([A-Fa-f0-9\n]+)
                         (\s*cleartomark.*$)}sx;

    my ($pre, $bin, $post) = ($1, $2, $3);
    $bin =~ tr/A-Fa-f0-9//cd;
    $bin = pack ("H*", $bin);
    my $nulls;
    ($bin, $nulls) = $bin =~ /(.*[^\0])(\0+)?$/s;
    $nulls = defined $nulls ? length($nulls) : 0;
    while ( $nulls > 0 ) {
	$post = ("00" x ($nulls > 32 ? 32 : $nulls)) . "\n" . $post;
	$nulls -= 32;
    }

    return \do{"\200\001".pack("V",length($pre)).$pre.
	       "\200\002".pack("V",length($bin)).$bin.
	       "\200\001".pack("V",length($post)).$post.
	       "\200\003" };
}

sub _pfa2asm ($;$) {
    my ($self, $data) = @_;	# NOTE: data is a ref!

    $data = $self->{data} unless defined $data;

    if ( $t1disasm ) {
	my $fn = _qtfn($self->{file});
	#### WARNING: This is Unix specific! ####
	my $cmd = "$t1disasm $fn";
	if ( $self->{type} eq 't' ) {
	    $self->_die($self->{file},
			": Logic error -- Cannot convert True Type font\n");
	}

	print STDERR ("+ $cmd |\n") if $self->{trace};
	my $fh = new IO::File ("$cmd |");
	local ($/);
	my $newdata = <$fh>;
	$fh->close or warn ($cmd, ": return ". sprintf("%x", $?), "\n");
	$newdata =~ s/\015\012?/\n/g;
	return \$newdata;
    }

    return $data
      unless $$data =~ m{(^.*\beexec\s*\n+)
                         ([A-Fa-f0-9\n]+)
                         (\n\s*cleartomark.*$)}sx;

    my ($pre, $bin, $post) = ($1, $2, $3);
    $bin =~ tr/A-Fa-f0-9//cd;
    $bin = pack ("H*", $bin);
    my $nulls;
    ($bin, $nulls) = $bin =~ /(.*[^\0])(\0+)?$/s;
    $nulls = defined $nulls ? length($nulls) : 0;
    while ( $nulls > 0 ) {
	$post = ("00" x ($nulls > 32 ? 32 : $nulls)) . "\n" . $post;
	$nulls -= 32;
    }

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

    # End conversion.

    # Cleanup (for display only).
    $newdata =~ s/ \-\| (.+?) (\|-?)\n/" -| <".unpack("H*",$1)."> $2\n"/ges;

    # Concatenate and return.
    $newdata = $pre . $newdata . $post;
    return \$newdata;
}

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

    print STDERR ($self->{file}, ": Getting glyph info\n") if $self->{verbose};

    $data = $self->{data} unless defined $data;

    if ( $self->{dataformat} eq "type42" ) {
	my $g = $self->{t42wrapper}->glyphnames;
	print STDERR ($self->{file}, ": Number of glyphs = ",
		      scalar(@$g), "\n")
	  if $self->{verbose};
	return $g;
    }

    if ( $self->{format} eq "binary" ) {
	$data = $self->_pfb2pfa ($data);
    }

    if ( $$data =~ m|/CharStrings\s.*\n((?s)(.*))| ) {
	$data = $2;
    }
    else {
	$data = $self->_pfa2asm ($data);
	if ( $$data =~ m|/CharStrings\s.*\n((?s)(.*))| ) {
	    $data = $2;
	}
	else {
	    return undef;
	}
    }

#    while ( $data =~ m;((^\d*\s*/([.\w]+))|(\bend\b)).*\n;mg ) {
    while ( $data =~ m;(/([.\w]+)\b|\bend\b);mg ) {
	last if $1 eq "end";
	push (@glyphs, $2);
    }

    print STDERR ($self->{file}, ": Number of glyphs = ",
		  scalar(@glyphs), "\n")
      if $self->{verbose};

    \@glyphs;
}

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

    print STDERR ($self->{file}, ": Getting encoding info\n")
      if $self->{verbose};

    $data = $self->{data} unless defined $data;
    $data = $$data;		# deref
    $data =~ s/\n\s*%.*$//mg;	# strip comments

    # Name -> standard encoding.
    return $1 if $data =~ m|/Encoding\s+(\S+)\s+def|;

    # Array -> explicit encoding.
    if ( $data =~ m;/Encoding[\n\s]+\[([^\]]+)\][\n\s]+def;m ) {
	my $enc = $1;
	$enc =~ s|\s*/| |g;
	$enc =~ s/^\s+//;
	$enc =~ s/\s+$//;
	$enc =~ s/\s+/ /g;
	if ( $enc eq PostScript::StandardEncoding->string ) {
	    $enc = "StandardEncoding"
	}
	elsif ( $enc eq PostScript::ISOLatin1Encoding->string ) {
	    $enc = "ISOLatin1Encoding"
	}
	else {
	    $enc = [split (' ', $enc)];
	}
	return $enc;
    }

    # Sparse array, probably custom encoding.
#    if ( $data =~ m;/Encoding \d+ array\n(0 1 .*for\n)?((dup \d+\s*/\S+ put(\s*%.*)?\n)+); ) {
    if ( $data =~ m;/Encoding \d+ array\n(0 1 .*for\n)?((dup \d+\s*/\S+ put(.*)\n)+); ) {
	my $enc = $2;
	my @enc = (".notdef") x 256;
	while ( $enc =~ m;dup (\d+)\s*/(\S+) put;g ) {
	    $enc[$1] = $2;
	}
	if ( "@enc" eq PostScript::StandardEncoding->string ) {
	    $enc = "StandardEncoding"
	}
	elsif ( "@enc" eq PostScript::ISOLatin1Encoding->string ) {
	    $enc = "ISOLatin1Encoding"
	}
	else {
	    $enc = \@enc;
	}
	return $enc;
    }

    undef;
}

sub _getexec ($) {
    my ($self, $exec) = @_;
    foreach ( File::Spec->path ) {
	if ( -x "$_/$exec" ) {
	    print STDERR ("Using $_/$exec\n") if $self->{verbose};
	    return "$_/$exec";
	}
	elsif ( -x "$_/$exec.exe" ) {
	    print STDERR ("Using $_/$exec.exe\n") if $self->{verbose};
	    return "$_/$exec.exe";
	}
    }
    ''
}

sub _die {
    my ($self, @msg) = @_;
    $self->{die}->(@msg);
}

# PostScript::TTtoType42 is actually an Font::TTF::Font object.
# Font::TTF::Font uses cyclic structures, so we need this.
sub DESTROY {
    my $self = shift;
    $self->{t42wrapper}->DESTROY if $self->{t42wrapper};
}

1;

__END__