File Coverage

lib/PostScript/FontMetrics.pm

Criterion	Covered	Total	%
statement	205	283	72.4
branch	77	144	53.4
condition	20	38	52.6
subroutine	20	27	74.0
pod	12	12	100.0
total	334	504	66.2

# RCS Status      : $Id: FontMetrics.pm,v 1.25 2005-06-10 22:56:21+02 jv Exp $
# Author          : Johan Vromans
# Created On      : December 1998
# Last Modified By: Johan Vromans
# Last Modified On: Fri Jun 10 19:00:43 2005
# Update Count    : 479
# Status          : Released

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

package PostScript::FontMetrics;

use strict;
use Carp;

BEGIN { require 5.005; }

use IO qw(File);
use File::Spec;

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

use constant FONTSCALE => 1000;		# normal value for font design

sub new {
    my $class = shift;
    my $font = shift;
    my (%atts) = (error => 'die',
		  verbose => 0, trace => 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";
    };

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

    $self;
}

sub FileName	{ my $self = shift; $self->{file};    }

sub MetricsData { my $self = shift; $self->{data};    }

sub CharWidthData {
    my $self = shift;
    $self->_getwidthdata() unless defined $self->{Wx};
    $self->{Wx};
}

sub EncodingVector {
    my $self = shift;
    $self->_getwidthdata() unless defined $self->{encodingvector};
    $self->{encodingvector};
}

sub CharBBoxData {
    my $self = shift;
    $self->_getbboxdata() unless defined $self->{BBox};
    $self->{BBox};
}

sub KernData {
    my $self = shift;
    $self->_getkerndata() unless defined $self->{Kern};
    $self->{Kern};
}

sub _loadafm ($) {

    my ($self) = shift;

    my $data;			# afm data

    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 AFM file\n") if $self->{verbose};

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

    $self->{origdataformat} = 'afm';
    if ( $data eq "\0\1\0\0" ) {
	$fh->close;
	# 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");
	}
	my $wrapper =
	  new PostScript::Font::TTtoType42:: ($fn,
					      verbose => $self->{verbose},
					      trace   => $self->{trace},
					      debug   => $self->{debug});
	$data = ${$wrapper->afm_as_string};
	$self->{t42wrapper} = $wrapper;
	$self->{origdataformat} = 'ttf';
    }
    else {
	while ( $fh->sysread ($data, 32768, $len) > 0 ) {
	    $len = length ($data);
	}
	$fh->close;
	print STDERR ("Read $len bytes from $fn\n") if $self->{trace};
	$self->_die("$fn: Expecting $sz bytes, got $len bytes\n")
	  unless $sz == -1 || $sz == $len;
    }

    # Normalise line endings. Get rid of trailing space as well.
    $data =~ s/\s*\015\012?/\n/g;

    if ( $data !~ /StartFontMetrics/ || $data !~ /EndFontMetrics/ ) {
	$self->_die("$fn: Not a recognizable AFM file\n");
    }
    $self->{data} = $data;

    # Initially, we only load the "global" info from the AFM data.
    # Other parts are parsed when required.
    local ($_);
    foreach ( split (/\n/, $self->{data}) ) {
	next if /^StartKernData/ .. /^EndKernData/;
	next if /^StartComposites/ .. /^EndComposites/;
	next if /^StartCharMetrics/ .. /^EndCharMetrics/;
	last if /^EndFontMetrics/;
	if ( /^FontBBox\s+(-?\d+)\s+(-?\d+)\s+(-?\d+)\s+(-?\d+)\s*$/ ) {
	    $self->{fontbbox} = [$1,$2,$3,$4];
	}
	elsif ( /(^\w+)\s+(.*)/ ) {
	    my ($key, $val) = ($1, $2);
	    $key = lc ($key);
	    if ( defined $self->{$key}) {
		$self->{$key} = [ $self->{$key} ] unless ref $self->{$key};
		push (@{$self->{$key}}, $val);
	    }
	    else {
		$self->{$key} = $val;
	    }
	}
    }

    $self;
}

sub _getwidthdata {
    # This is adapted from Gisle Aas' Font-AFM 1.17
    my $self = shift;
    local ($_);
    my %wx;
    my $dontencode = 1;
    unless ( defined $self->{encodingvector} ) {
	$dontencode = 0;
	if ( defined $self->{encodingscheme} ) {
	    if ( $self->{encodingscheme} eq "AdobeStandardEncoding" ) {
		require PostScript::StandardEncoding;
		$self->{encodingvector} =
		  [ @{PostScript::StandardEncoding->array} ];
		$dontencode = 1;
	    }
	    elsif ( $self->{encodingscheme} eq "ISOLatin1Encoding" ) {
		require PostScript::ISOLatin1Encoding;
		$self->{encodingvector} =
		  [ @{PostScript::ISOLatin1Encoding->array} ];
		$dontencode = 1;
	    }
	    else {
		$self->{encodingvector} = [];
	    }
	}
	else {
	    $self->{encodingvector} = [];
	}
    }
    my $enc = $self->{encodingvector};
    my $nglyphs = 0;
    my $nenc = 0;
    foreach ( split (/\n/, $self->{data}) ) {
	if ( /^StartCharMetrics/ .. /^EndCharMetrics/ ) {
	    # Only lines that start with "C" or "CH" are parsed.
	    # C nn, C -1 or C  (two hexits).
	    next unless /^CH?\s+(-?\d+|<[0-9a-f]+>)\s*;/i;
	    my $ix = $1;
	    $ix = hex($1) if $1 =~ /^<(.+)>$/;
	    my ($name) = /\bN\s+(\.?\w+(?:-\w+)?)\s*;/;
	    my ($wx)   = /\bWX\s+(\d+)\s*;/;
	    $wx{$name} = $wx;
	    $nglyphs++;
	    $enc->[$ix] = $name, $nenc++ unless $dontencode || $ix < 0;
	    next;
	}
	last if /^EndFontMetrics/;
    }
    unless ( exists $wx{'.notdef'} ) {
	$wx{'.notdef'} = 0;
    }
    print STDERR ($self->FileName, ": Number of glyphs = $nglyphs, ",
		  "encoded = $nenc\n") if $self->{verbose};
    $self->{Wx} = \%wx;
    $self;
}

sub _getbboxdata {
    # This is adapted from Gisle Aas' Font-AFM 1.17
    my $self = shift;
    local ($_);
    my %bbox;
    foreach ( split (/\n/, $self->{data}) ) {
	if ( /^StartCharMetrics/ .. /^EndCharMetrics/ ) {
	    # Only lines that start with "C" or "CH" are parsed.
	    next unless /^CH?\s/;
	    my ($name) = /\bN\s+(\.?\w+)\s*;/;
	    my (@bbox) = /\bB\s+(-?\d+)\s+(-?\d+)\s+(-?\d+)\s+(-?\d+)\s*;/;
	    $bbox{$name} = \@bbox;
	    next;
	}
	last if /^EndFontMetrics/;
    }
    unless ( exists $bbox{'.notdef'} ) {
	$bbox{'.notdef'} = [0, 0, 0, 0];
    }
    $self->{BBox} = \%bbox;
    $self;
}

sub _getkerndata {
    my $self = shift;
    local ($_);
    my $k = 0;
    my %kern;
    foreach ( split (/\n/, $self->{data}) ) {
	if ( /^StartKern(Data|Pairs)/ .. /^EndKern(Data|Pairs)/ ) {
	    next unless /^KPX\s+(\S+)\s+(\S+)\s+(-?\d+)/;
	    $kern{$1,$2} = $3;
	    $k++;
	}
	last if /^EndFontMetrics/;
    }
    ${kern}{'.notdef','.notdef'} = 0 unless %kern;
    print STDERR ($self->FileName, ": Number of kern pairs = $k\n")
      if $self->{verbose};
    $self->{Kern} = \%kern;
    $self;
}

sub setEncoding {
    my ($self, $enc) = @_;
    if ( ref($enc) && UNIVERSAL::isa($enc,'ARRAY') && scalar(@$enc) == 256 ) {
	# Array ref is okay.
    }
    elsif ( $enc eq "StandardEncoding" ) {
	require PostScript::StandardEncoding;
	$enc = [ @{PostScript::StandardEncoding->array} ];
    }
    elsif ( $enc eq "ISOLatin1Encoding" ) {
	require PostScript::ISOLatin1Encoding;
	$enc = [ @{PostScript::ISOLatin1Encoding->array} ];
    }
    elsif ( $enc eq "ISOLatin9Encoding" ) {
	require PostScript::ISOLatin9Encoding;
	$enc = [ @{PostScript::ISOLatin9Encoding->array} ];
    }
    else {
	croak ("Invalid encoding vector");
    }
    $self->{encodingvector} = $enc;
    delete $self->{_charcache};
    $self;
}

sub stringwidth {
    my ($self, $string, $pt) = @_;

    my $wx = $self->CharWidthData;
    my $ev = $self->EncodingVector;
    if ( scalar(@{$self->{encodingvector}}) <= 0 ) {
	$self->_die($self->FileName . ": Missing Encoding\n");
    }
    my $wd = 0;
    foreach ( unpack ("C*", $string) ) {
	$wd += $wx->{$ev->[$_]||'.undef'};
    }

    if ( defined $pt ) {
	carp ("Using a PointSize argument to stringwidth is deprecated")
	  if $^W;
	$wd *= $pt / FONTSCALE;
    }
    $wd;
}

sub kstringwidth {
    my ($self, $string, $pt) = @_;
    my $wx = $self->CharWidthData;
    my $ev = $self->EncodingVector;
    if ( scalar(@{$self->{encodingvector}}) <= 0 ) {
	croak ($self->FileName . ": Missing Encoding\n");
    }
    my $kr = $self->KernData;
    my $wd = 0;
    my $prev;
    foreach ( unpack ("C*", $string) ) {
	my $this = $ev->[$_] || '.notdef';
	$wd += $wx->{$this};
	if ( defined $prev ) {
	    my $kw = $kr->{$prev,$this};
	    $wd += $kw if defined $kw;
	}
	$prev = $this;
    }
    if ( defined $pt ) {
	carp ("Using a PointSize argument to kstringwidth is deprecated")
	  if $^W;
	$wd *= $pt / FONTSCALE;
    }
    $wd;
}

sub kstring {
    my ($self, $string, $ext) = @_;
    return (wantarray ? () : []) unless length ($string);

    my $wx = $self->CharWidthData;
    my $ev = $self->EncodingVector;
    if ( scalar(@{$self->{encodingvector}}) <= 0 ) {
	croak ($self->FileName . ": Missing Encoding\n");
    }
    my $kr = $self->KernData;
    my $wd = (defined $ext ? $wx->{'space'}+$ext : 0);
    my @res = ();
    my $prev = '.undef';

    foreach ( split ('', $string) ) {

	# Check for flex space.
	if ( defined $ext && $_ eq " " ) {
	    # If we have something, accumulate.
	    if ( @res ) {
		# Add to displacement.
		if ( $prev eq 'space' ) {
		    $res[$#res] += $wd;
		}
		# Turn last item into string, and push the displacement.
		else {
		    $res[$#res] =~ s/([()\\]|[^\040-\176])/sprintf("\\%03o",ord($1))/eg;
		    $res[$#res] = "(".$res[$#res].")";
		    push (@res, $wd);
		}
	    }
	    else {
		# First item, push.
		push (@res, $wd);
	    }
	    $prev = 'space';
	    next;
	}

	# Get the glyph name and kern value.
	my $this = $ev->[ord($_)] || '.undef';
	my $kw = $kr->{$prev,$this} || 0;
	{ local ($^W) = 0;
	  print STDERR ("$prev $this $kw :$res[-3]:$res[-2]:$res[-1]:\n")
	    if $self->{debug};
        }
	# Nothing to kern?
	if ( defined $ext && $prev eq 'space' ) {
	    # Accumulate displacement.
	    $res[$#res] += $kw;
	    push (@res, $_);
	}
	elsif ( $kw == 0 ) {
	    if ( $prev eq '.undef' ) {
		# New item.
		push (@res, $_);
	    }
	    else {
		# Accumulate text.
		$res[$#res] .= $_;
	    }
	}
	else {
	    # Turn previous into string.
	    $res[$#res] =~ s/([()\\]|[^\040-\176])/sprintf("\\%03o",ord($1))/eg;
	    $res[$#res] = "(".$res[$#res].")";
	    # Add kerning value and the new item.
	    push (@res, $kw, $_);
	}
	$prev = $this;
    }

    # Turn the last item into string, if needed.
    if ( !(defined $ext && $prev eq 'space') ) {
	$res[$#res] =~ s/([()\\]|[^\040-\176])/sprintf("\\%03o",ord($1))/eg;
	$res[$#res] = "(".$res[$#res].")";
    }

    # Return.
    wantarray ? @res : \@res;
}

sub char {
    my ($self, $glyph) = @_;

    # Return from cache if possible.
    my $char = $self->{_charcache}->{$glyph};
    return $char if defined $char;

    # Look it up.
    $char = -1;
    foreach ( @{$self->EncodingVector} ) {
	$char++;
	next unless $_ eq $glyph;
	return $self->{_charcache}->{$glyph} = pack("C",$char);
    }
    undef;
}

sub AUTOLOAD {
    # This is adapted from Gisle Aas' Font-AFM 1.17
    no strict 'vars';

    if ( $AUTOLOAD =~ /::DESTROY$/ ) {
	# Prevent the eval from clobbering outer eval error status.
	local ($@);
	# Define a dummy destoyer, and jump tp it.
	eval "sub $AUTOLOAD {}";
	goto &$AUTOLOAD;
    }
    else {
	my $name = $AUTOLOAD;
	$name =~ s/^.*:://;
	return $_[0]->{lc $name};
    }
}

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

1;

__END__