File Coverage

blib/lib/Font/TFM.pm

Criterion	Covered	Total	%
statement	170	271	62.7
branch	80	156	51.2
condition	13	24	54.1
subroutine	13	22	59.0
pod	6	17	35.2
total	282	490	57.5

=head1 NAME

Font::TFM -- read information from TeX font metric files

=cut


package Font::TFM;
use strict;
use vars qw( $VERSION $DEBUG $TEXFONTSDIR $TEXFONTSUSELS
	$LSFILENAME $MULTIPLY $errstr );

# ################
# Global variables
#
$VERSION = '1.01';
$errstr = '';
$DEBUG = 0;
sub DEBUG ()	{ $DEBUG; }
sub Error {
	$errstr = join '', @_;
	print STDERR @_, "\n" if $DEBUG;
}

$TEXFONTSDIR = '.';
$TEXFONTSUSELS = 1;
$LSFILENAME = "ls-R";
$MULTIPLY = 65536;

# #####################
# Load new font at size
#
sub new_at {
	my ($class, $fontname, $size) = @_;
	new($class, 'name' => $fontname, 'at' => $size);
}

# ########################
# Load new font with scale
#
sub new {
	my $class = shift;
	my %opts = ();
	if (@_ > 2 or (@_ == 2 and $_[1] !~ /^(\d*\.)?\d+$/)) {
		if (@_ % 2) {
			$opts{name} = shift;
		}
		%opts = @_;
	} else {
		@opts{'name', 'scale'} = @_;
	}

	# make the object
	my $self = bless {}, $class;

	my ($file_handle);
	eval {
		$file_handle = $self->open_tfm(%opts);
	};
	if ($@) {
		Error($@); return;
	}

	# read header
	my $buffer = '';
	if (read($file_handle, $buffer, 24) != 24) {
		Error("Error reading TFM header: $!"); return;
	}

	# get 12 fields of the header
	@{$self}{ qw(length headerlength smallest largest numwidth
		numheight numdepth numic numligkern numkern numext numparam) }
			= unpack "n12", $buffer;
	$self->{numofchars} = $self->{largest} - $self->{smallest} + 1;
	$self->{'length'} = $self->{'length'} * 4 - 24;
	$self->{headerlength} *= 4;

	# read rest of the file
	if (read($file_handle, $buffer, $self->{'length'})
		!= $self->{'length'}) {
			Error("Error reading body: $!"); return;
	}
	close $file_handle;

	my $headerrestlength = $self->{headerlength} - 18 * 4;

	my ($face, $headerrest, @charinfo, @width, @height, @depth,
		@italic, @ligkern, @kern, @exten);

	# split the file into various arrays
	(@{$self}{ qw(checksum designsize codingschemestringlength
		codingscheme familystringlength family sevenbitsafe ) },
	undef, undef, $face,
	$headerrest,
	@charinfo[0 .. $self->{numofchars} - 1],
	@width[0 .. $self->{numwidth} - 1],
	@height[0 .. $self->{numheight} - 1],
	@depth[0 .. $self->{numdepth} - 1],
	@italic[0 .. $self->{numic} - 1],
	@ligkern[0 .. $self->{numligkern} - 1],
	@kern[0 .. $self->{numkern} - 1],
	@exten[0 .. $self->{numext} - 1],
	@{$self->{param}}[1 .. $self->{numparam}],
	)
		= unpack "NNCA39CA19C4a$headerrestlength" .
			"a4" x $self->{numofchars} .
			"N$self->{numwidth}N$self->{numheight}N$self->{numdepth}N$self->{numic}" .
			"a4" x $self->{numligkern} .
			"N$self->{numkern}" .
			"a4" x $self->{numext} .
			"N$self->{numparam}", $buffer;
	# the unpack above does all the work, isn't it neat?

	$self->{designsize} = getfixword($self->{designsize});

	my $fontsize = $self->{designsize};
	if (defined $opts{at}) {
		$fontsize = $opts{at};
	} elsif (defined $opts{scale}) {
		$fontsize *= $opts{scale};
	}
	$self->{fontsize} = $fontsize;
	my $multiplysize = $fontsize *
		( defined $opts{'multiply'} ? $opts{'multiply'} : $MULTIPLY );

	if ($self->{sevenbitsafe}) {
		$self->{sevenbitsafe} = 1;
	}

	$self->{face} = "";		# computation of face seems useless
	if ($face < 18) {
		my ($weight, $slope, $expansion) = ("M", "R", "R");
		if ($face - 12 >= 0) { $expansion = "E"; $face -= 12; }
		elsif ($face - 6 >= 0) { $expansion = "C"; $face -= 6; }
		if ($face - 4 >= 0) { $weight = "L"; $face -= 4; }
		elsif ($face - 2 >= 0) { $weight = "B"; $face -= 2; }
		if ($face > 0) { $slope = "I"; }
		$self->{face} = "$weight$slope$expansion";
	}

	@{$self->{headerrest}}[0 .. $headerrestlength] = split //, $headerrest;

	@width = map { getfixword($_) * $multiplysize } @width;
	@height = map { getfixword($_) * $multiplysize } @height;
	@depth = map { getfixword($_) * $multiplysize } @depth;
	@italic = map { getfixword($_) * $multiplysize } @italic;
	@kern = map { getfixword($_) * $multiplysize } @kern;
	$self->{param}[1] = getfixword($self->{param}[1]);
	@{$self->{param}}[2 .. $self->{numparam}] =
		map { getfixword($_) * $multiplysize }
			@{$self->{param}}[2 .. $self->{numparam}];
					# compute the actual dimensions

	if (@ligkern) {		# check for boundary char
		my ($skip, $next, $opbyte, $remainder);
		($skip, $next) = unpack "Ca1", $ligkern[0];
		if ($skip == 255) {
			$self->{"boundary"} = $next;
		}
		($skip, $next, $opbyte, $remainder) = unpack
			"Ca1CC", $ligkern[$#ligkern];
		if ($skip == 255) {
			process_lig_kern($self, "boundary", \@ligkern,
				256 * $opbyte + $remainder, \@kern);
		}
	}

	for (0 .. $self->{numofchars} - 1) {
		my $char = pack "C", $_ + $self->{smallest};
		my ($wid, $heidep, $italtag, $remainder)
			= unpack "C4", $charinfo[$_];
		next if ($wid == 0);
					# set up dimensions of the character
		($self->{width}{$char}, $self->{height}{$char},
			$self->{depth}{$char}, $self->{italic}{$char})
			= ($width[$wid], $height[$heidep >> 4],
			$depth[$heidep & 0x0f], $italic[$italtag >> 2]);

		my $tag = $italtag & 0x03;	# other info
		if ($tag == 1) {		# lig/kern program
			process_lig_kern($self, $char, \@ligkern, $remainder, \@kern);
		}
		elsif ($tag == 2) {		# larger character
			$self->{larger}{$char} = pack "C", $remainder;
		}
		elsif ($tag == 3) {		# extensible character
			my ($top, $mid, $bot, $rep) = unpack "C4", $exten[$remainder];
			$self->{extentop}{$char} = pack "C", $top if $top;
			$self->{extenmid}{$char} = pack "C", $mid if $mid;
			$self->{extenbot}{$char} = pack "C", $bot if $bot;
			$self->{extenrep}{$char} = $rep;
		}
	}
	$self;
}

# ###################################
# Open the file and return filehandle
#
sub open_tfm {
	my ($self, %opts) = @_;
	my $filename;
	if (defined $opts{file}) {
		$filename = $opts{file}
	} elsif (defined $opts{name}) {
		$filename = find_tfm_file(%opts) or
			die "No tfm file found for font $opts{name}";
	} else {
		die "Either font name or file name has to be specified";
	}

	# try to open the file
	print STDERR "Loading $filename\n" if DEBUG;
	open TFMFILE, $filename or
		die "Error opening $filename: $!";
	binmode TFMFILE;

	$self->{name} = $filename;
	$self->{name} =~ s/\.tfm$//i;
	$self->{name} =~ s!^.*/!!;

	return(\*TFMFILE);
}

# ###################################################
# Process the ligature/kerning program for a character
#
sub process_lig_kern {
	my ($self, $char, $ligkernref, $prognum, $kernref) = @_;
	my $firstinstr = 1;
	while (1) {
		my ($skipbyte, $nextchar, $opbyte, $remainder)
			= unpack "Ca1CC", $ligkernref->[$prognum];
		if ($firstinstr) {
			if ($skipbyte > 128) {
				$prognum = 256 * $opbyte + $remainder;
				($skipbyte, $nextchar, $opbyte, $remainder)
					= unpack "Ca1CC", $ligkernref->[$prognum];
			}
		}
		if ($opbyte >= 128
			and not exists $self->{kern}{$char .  $nextchar}) {
			$self->{kern}{$char . $nextchar}
				= $kernref->[ 256 * ($opbyte - 128)
							+ $remainder];
		}
		if ($opbyte < 128
			and not exists $self->{lig}{$char .  $nextchar}) {
			my ($a, $b, $c) = ($opbyte >> 2, ($opbyte >> 1) & 0x01, $opbyte & 0x01);
			my $out = "";
			$out .= $char if $b;
			$out .= pack "C", $remainder;
			$out .= $nextchar if $c;
			$self->{lig}{$char . $nextchar} = $out;
			$self->{ligpassover}{$char . $nextchar} = $a;
		}
		last if ($skipbyte >= 128);
		$prognum += $skipbyte + 1;
		$firstinstr = 0;
	}
}

# #################
# Find the TFM file
#
sub find_tfm_file {
	my %opts = @_;
	my $fontname = $opts{name};
	$fontname .= ".tfm" unless $fontname =~ /\.tfm$/i;
	print STDERR "Font::TFM::find_tfm_file: \$fontname = $fontname\n" if DEBUG;
	my $directory;
	for $directory (split /:/,
		(defined $opts{path} ? $opts{path} : $TEXFONTSDIR)) {
		print STDERR "Font::TFM::find_tfm_file: \$directory = $directory\n" if DEBUG;
		my $file = find_tfm_file_in_directory(%opts,
			name => $fontname, dir => $directory);
		return $file if defined $file;
	}
	return;
}
sub find_tfm_file_in_directory {
	my %opts = @_;
	my ($fontname, $directory) = ($opts{name}, $opts{dir});
	$directory .= '/' unless $directory eq '';
	my $tfmfile = "$directory$fontname";
	my $lsfile = "$directory$LSFILENAME";
	print STDERR "Font::TFM::find_tfm_file_in_directory: \$directory = $directory\n" if DEBUG;
	if (-f $tfmfile) {
		return $tfmfile;
	}
	my $usels = $TEXFONTSUSELS;
	if (defined $opts{usels}) {
		$usels = 1;
		$usels = 0 if $opts{usels} eq '0' or $opts{usels} eq 'no';
	}
	if (-f $lsfile and $usels) {
		my $file = find_tfm_file_in_ls($fontname, $lsfile);
		return $file if defined $file;
	}
	else {
		my $subdir;
		for $subdir (<$directory/*>) {
			next unless -d $subdir;
			my $file = find_tfm_file_in_directory(%opts,
							dir => $subdir);
			return $file if defined $file;
		}
	}
	return;
}
sub find_tfm_file_in_ls {
	my ($fontname, $lsfile) = @_;
	my $lsdir = $lsfile;
	$lsdir =~ s!/$LSFILENAME$!!;
	print STDERR "Font::TFM::find_tfm_file_in_ls: \$lsfile = $lsfile\n" if DEBUG;
	print STDERR "Font::TFM::find_tfm_file_in_ls: \$lsdir = $lsdir\n" if DEBUG;
	if (not open LSFILE, $lsfile) {
		Error("Error opening $lsfile: $!"); return;
	}
	local ($/) = "\n";
	while () {
		chomp;
		if (/:$/) {
			$lsdir = $_;
			$lsdir =~ s!:$!!;
			print STDERR "Font::TFM::find_tfm_file_in_ls: \$lsdir = $lsdir\n" if (DEBUG > 10);
		}
		elsif ($_ eq $fontname) {
			my $file = "$lsdir/$fontname";
			if (-f $file) {
				close LSFILE;
				print STDERR "file $fontname found in $lsfile\n" if DEBUG;
				return $file;
			}
		}
	}
	print STDERR "file $fontname not found in $lsfile\n" if DEBUG;
	return;
}
sub getfixword {
	my $val = $_[0];
	my $p = pack "L", $val;
	if ($val & 0x80000000) {
		$val = unpack "l", $p;
	}
	return ($val / (1 << 20));
}
sub kern {
	my ($self, $double, $second) = @_;
	$double .= $second if (defined $second);
	if (defined $self->{kern}{$double}) {
		return $self->{kern}{$double};
	}
	return 0;
}
sub lig {
	my ($self, $double, $second) = @_;
	$double .= $second if (defined $second);
	if (defined $self->{lig}{$double}) {
		return $self->{lig}{$double};
	}
	return undef;
}
sub ligpassover {
	my ($self, $double) = @_;
	$self->{ligpassover}{$double};
}
sub param {
	my ($self, $param) = @_;
	$self->{param}[$param];
}
sub word_dimensions {
	my ($self, $text) = @_;
	my @expanded = $self->expand($text);
	my ($width, $height, $depth) = (0, 0, 0);
	while (@expanded) {
		my $word = shift @expanded;
		while ($word =~ /./sg) {
			my $char = $&;
			$width += $self->width($char);
			my $newval = $self->height($char);
			$height = $newval if ($newval > $height);
			$newval = $self->depth($char);
			$depth = $newval if ($newval > $depth);
		}
                last if (not @expanded);
		$width += shift @expanded;
	}
	($width, $height, $depth);
}
sub expand {
	my ($self, $text) = @_;
	my $pos = 0;

	# ligature substitutions
	while ($pos < (length $text) - 1) {
		my $found;
		my $substr = substr $text, $pos, 2;
		$found = $self->lig(substr $text, $pos, 2);
		if (defined $found) {
			substr($text, $pos, 2) = $found;
			$pos += $self->ligpassover($substr);
		}
		else
			{ $pos++ }
	}

	# kerning processing
	my @out = ();
	my $currentstring = substr $text, 0, 1;
	while ($text =~ /(.)(?=(.))/gs) {
		if ($self->kern($1 . $2)) {
			push @out, $currentstring;
			$currentstring = '';
			push @out, $self->kern($1 . $2);
		}
		$currentstring .= $2
	}
	push @out, $currentstring;
	@out;
}


my %PARAM_NAMES = ( slant => 1, space => 2, spacestretch => 3,
	spaceshrink => 4, xheight => 5, emwidth => 6, quad => 6,
	extraspace => 7,
);
my @GENERAL_NAMES = qw( fontsize designsize name checksum codingscheme );
my @CHAR_NAMES = qw( width height depth italic );
my %WORD_NAMES = ( word_width => 0, word_height => 1, word_depth => 2 );
my %MATH_SY_NAMES = ( num1 => 8, num2 => 9, num3 => 10,
	denom1 => 11, denom2 => 12,
	sup1 => 13, sup2 => 14, sup3 => 15,
	sub1 => 16, sub2 => 17,
	supdrop => 18,
	subdrop => 19,
	delim1 => 20, delim2 => 21,
	axisheight => 22,
);
my %MATH_EX_NAMES = (
	defaultrulethickness => 8,
	bigopspacing1 => 9,
	bigopspacing2 => 10,
	bigopspacing3 => 11,
	bigopspacing4 => 12,
	bigopspacing5 => 13,
);

use vars qw( $AUTOLOAD );
sub AUTOLOAD {
	my $self = shift;
	my $function = $AUTOLOAD;
	local ($_);
	$function =~ s/^.*:://;
	$function =~ s/_//g;
	print STDERR "Autoloading $function\n" if DEBUG;
	return ($self->word_dimensions(shift))[$WORD_NAMES{$function}]
		if defined $WORD_NAMES{$function};
	return $self->{'param'}[$PARAM_NAMES{$function}]
		if (defined $PARAM_NAMES{$function});
	return $self->{$function}{$_[0]}
		if grep { $_ eq $function } @CHAR_NAMES;
	return $self->{$function}
		if grep { $_ eq $function } @GENERAL_NAMES;
	if ($self->{codingscheme} eq 'TeX math symbols'
		and defined $MATH_SY_NAMES{$function}) {
		return $self->{'param'}[$MATH_SY_NAMES{$function}]
	}
	if ($self->{codingscheme} eq 'TeX math extension'
		and defined $MATH_EX_NAMES{$function}) {
		return $self->{'param'}[$MATH_EX_NAMES{$function}]
	}
	die "Method $function not defined for $self";
}

sub Version	{ $VERSION; }
sub DESTROY {}
1;

__END__