File Coverage

blib/lib/PostScript/PrinterFontMetrics.pm

Criterion	Covered	Total	%
statement	128	168	76.1
branch	17	44	38.6
condition	13	30	43.3
subroutine	27	43	62.7
pod	6	15	40.0
total	191	300	63.6

# RCS Status      : $Id: PrinterFontMetrics.pm,v 1.7 2003-10-23 14:12:04+02 jv Exp $
# Author          : Andrew Ford
# Created On      : March 2001
# Last Modified By: Johan Vromans
# Last Modified On: Thu Oct 23 14:12:02 2003
# Update Count    : 45
# Status          : Development

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

package PostScript::PrinterFontMetrics;

use strict;
use Carp;
use Data::Dumper;

BEGIN { require 5.005; }

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

use vars qw($VERSION @ISA $AUTOLOAD);
$VERSION = "0.08";

use PostScript::FontMetrics;
use PostScript::StandardEncoding;

@ISA = qw(PostScript::FontMetrics);

# Definitions of the PFM file layout

use constant PFM_HEADER_LENGTH   => 117;
use constant PFM_HEADER_TEMPLATE => 'vVa60vvvvvvvCCCvCvvCvvCCCCvVVVV';
my @pfm_header_fields
  = (
     'dfVersion',
     'dfSize',
     'dfCopyright',
     'dfType',
     'dfPoint',
     'dfVertRes',
     'dfHorisRes',
     'dfAscent',                # ATM FontBBox (fourth element)
     'dfInternalLeading',
     'dfExternalLeading',
     'dfItalic',
     'dfUnderline',
     'dfStrikeOut',
     'dfWeight',
     'dfCharSet',
     'dfPixWidth',
     'dfPixHeight',
     'dfPitchAndFamily',
     'dfAvgWidth',
     'dfMaxWidth',
     'dfFirstChar',
     'dfLastChar',
     'dfBreakChar',
     'dfWidthBytes',
     'dfDevice',
     'dfFace',
     'dfBitsPointer',
     'dfBitsOffset',
  );

# The PFM Extension table just contains offsets of other structures
# and so its members are not entered into the data hash

use constant PFM_EXTENSION_OFFSET     => PFM_HEADER_LENGTH;
use constant PFM_EXTENSION_LENGTH     => 30;
use constant PFM_EXTENSION_TEMPLATE   => 'vVVVVVVV';
my @pfm_extension_fields
  = (
     'dfSizeFields',                    # size of this section
     'dfExtMetricsOffset',              # offset of the Extended Text Metrics section
     'dfExtentTable',                   # offset of the Extent table
     'dfOriginTable',
     'dfPairKernTable',                 # offset of the kern pair table
     'dfTrackKernTable',
     'dfDriverInfo',
     'dfReserved'
    );

use constant PFM_EXT_METRICS_OFFSET   => PFM_EXTENSION_OFFSET + PFM_EXTENSION_LENGTH;
use constant PFM_EXT_METRICS_LENGTH   => 52;
use constant PFM_EXT_METRICS_TEMPLATE => 'v' x 26;
my @pfm_ext_metrics_fields
  = (
     'etmSize',
     'etmPointSize',
     'etmOrientation',
     'etmMasterHeight',
     'etmMinScale',
     'etmMaxScale',
     'etmMasterUnits',
     'etmCapHeight',                    # AFM CapHeight
     'etmXHeight',                      # AFM XHeight
     'etmLowerCaseAscent',              # AFM Ascender
     'etmLowerCaseDescent',             # AFM -Descender
     'etmSlant',
     'etmSuperScript',
     'etmSubScript',
     'etmSuperScriptSize',
     'etmSubScriptSize',
     'etmUnderlineOffset',              # AFM -UnderlinePostition
     'etmUnderlineWidth',               # AFM UnderlineThickness
     'etmDoubleUpperUnderlineOffset',
     'etmDoubleLowerUnderlineOffset',
     'etmDoubleUpperUnderlineWidth',
     'etmDoubleLowerUnderlineWidth',
     'etmStrikeOutOffset',
     'etmStrikeOutWidth',
     'etmKernPairs',                    # number of kern pairs
     'etmKernTracks',
    );

use constant PFM_PSINFO_OFFSET   => PFM_EXT_METRICS_OFFSET + PFM_EXT_METRICS_LENGTH;
my @pfm_postscript_info_fields
  = (
     'DeviceType',
     'WindowsName',
     'PostScriptName',          # AFM FontName
    );

my %pfm_field_map = ( map { $_ => \&_pfm_header }         @pfm_header_fields,
                      map { $_ => \&_pfm_extension }      @pfm_extension_fields,
                      map { $_ => \&_pfm_ext_metrics }    @pfm_ext_metrics_fields,
                      map { $_ => \&_pfm_device_section } @pfm_postscript_info_fields );

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

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

    $self;
}

sub FileName  { return $_[0]->{file};    }
sub FontName  { return $_[0]->_pfm_device_section->{PostScriptName}; }
sub CapHeight { return $_[0]->_pfm_extended_text_metrics->{etmCapHeight}; }
sub XHeight   { return $_[0]->_pfm_extended_text_metrics->{etmXHeight}; }
sub Ascender  { return $_[0]->_pfm_extended_text_metrics->{etmLowerCaseAscent}; }
sub Descender { return -$_[0]->_pfm_extended_text_metrics->{etmLowerCaseDescent}; }
sub MetricsData { return $_[0]->{_rawdata}; }

sub HeaderFields     { return @pfm_header_fields; }
sub ExtensionFields  { return @pfm_extension_fields; }
sub ExtMetricsFields { return @pfm_ext_metrics_fields; }
sub DeviceInfoFields { return @pfm_postscript_info_fields; }

sub CharWidthData {
    my $self = shift;
    my $char = $self->_pfm_header->{dfFirstChar};
    my $encoding =
      $self->{encodingvector} ||= PostScript::StandardEncoding->array;
    my $widthdata = {};
    foreach my $width (@{$self->_pfm_extent_table}) {
        my $char = $encoding->[$char++];
        $widthdata->{$char} = $width if $char and $char ne '.notdef';
    }
    $widthdata;
}

sub EncodingVector {
    my $self = shift;
    $self->{encodingvector} ||= PostScript::StandardEncoding->array;
}

sub KernData {
    my $self = shift;
    my $raw_kerndata = $self->_pfm_kerndata;
    my %enc_kerndata;

    my $encoding =
      $self->{encodingvector} ||= PostScript::StandardEncoding->array;
    while (my($pair, $kern) = each(%$raw_kerndata)) {
        my($c1,$c2) = unpack("aa", $pair);
        $enc_kerndata{$encoding->[ord $c1], $encoding->[ord $c2]} = $kern;
    }
    return \%enc_kerndata;
}

# _loadpfm just reads the PFM file into memory (as the _rawdata element)
# The individual file sections are only unpacked as and when they are needed.

sub _loadpfm ($) {
    my($self) = @_;

    my $fn = $self->{file};
    local *FH;					# font file
    my $sz = $self->{filesize} = -s $fn;        # file size

    open(FH, $fn) || $self->_die("$fn: $!\n");
    print STDERR ("$fn: Loading PFM file\n") if $self->{verbose};
    binmode(FH);		# requires a file handle, yuck

    # Read in the pfm data.
    my $len = 0;

    unless ( ($len = sysread (FH, $self->{_rawdata}, $sz, 0)) == $sz ) {
        $self->_die("$fn: Expecting $sz bytes, got $len bytes\n");
    }
}

# Return the PFM file Header section (unpacking if necessary)

sub _pfm_header {
    my $self = shift;
    my $header = $self->{_pfm_header} ||= {};

    if (! keys %$header) {
        @$header{@pfm_header_fields}
          = unpack(PFM_HEADER_TEMPLATE,
                   substr($self->{_rawdata}, 0, PFM_HEADER_LENGTH));
        $header->{dfCopyright} =~ s/\0.*//;

        die "$self->{file}: file size is $self->{filesize} but dfSize = $header->{dfsize}"
          unless $header->{dfSize} == $self->{filesize};
    }
    $header;
}

# Unpack the PFM Extension

sub _pfm_extension {
    my $self = shift;
    my $extension = $self->{_pfm_extension} ||= {};

    if (! keys %$extension) {
        @$extension{@pfm_extension_fields}
          = unpack(PFM_EXTENSION_TEMPLATE,
                   substr($self->{_rawdata}, PFM_EXTENSION_OFFSET, PFM_EXTENSION_LENGTH));
    }
    $extension;
}

# Unpack PFM extended text metrics

sub _pfm_extended_text_metrics {
    my $self = shift;
    my $ext_metrics = $self->{_ext_metrics} = {};
    if (! keys %$ext_metrics) {
        my $extension = $self->_pfm_extension;
        my $ext_metrics_offset = $extension->{dfExtMetricsOffset}
          || PFM_EXT_METRICS_OFFSET;
        die "$self->{file}: dfDriverInfo points outside file"
          if $ext_metrics_offset > $self->{filesize};

        @$ext_metrics{@pfm_ext_metrics_fields}
          = unpack(PFM_EXT_METRICS_TEMPLATE,
                   substr($self->{_rawdata}, $ext_metrics_offset, PFM_EXT_METRICS_LENGTH));
        delete($extension->{dfExtMetricsOffset})
          unless $self->{_keep_raw_data};
        # delete($self->{_rawdata}) unless keys $self->{_pfm_extension}
    }
    $ext_metrics
}

# Unpack the PFM Device Section

sub _pfm_device_section {
    my $self = shift;
    my $psinfo = $self->{_pfm_device} = {};
    if (! keys %$psinfo) {
        my $header = $self->_pfm_header;
        my $psinfo_offset = $header->{dfDevice} || PFM_PSINFO_OFFSET;
        die "$self->{file}: dfDevice points outside file ($psinfo_offset > $self->{filesize})"
          if $psinfo_offset > $self->{filesize};
        @$psinfo{@pfm_postscript_info_fields}
          = split(/\0/, substr($self->{_rawdata}, $psinfo_offset), 4);
    }
    $psinfo;
}

# Extent table (2 bytes x (1 + dfLastChar - dfFirstChar))
# location is defined by dfExtentTable field in extension table

sub _pfm_extent_table {
    my $self = shift;
    my $extent_table = $self->{_pfm_extent_table} ||= [];
    if (! @$extent_table) {
        my $header    = $self->_pfm_header;
        my $extension = $self->_pfm_extension;
        my $extent_offset = $extension->{dfExtentTable};
        my $extent_entries = 1 + $header->{dfLastChar} - $header->{dfFirstChar};
        @$extent_table = unpack('v' x $extent_entries,
                                substr($self->{_rawdata}, $extent_offset));
    }
    $extent_table;
}

# Return the raw kern data (unpacking if necessary)

sub _pfm_kerndata {
    my $self = shift;
    my $kerndata = $self->{_pfm_kerndata} ||= {};
    if (! keys %$kerndata) {
        my $extension = $self->_pfm_extension;
        my $kerntable_offset = $extension->{dfPairKernTable};
        if ($kerntable_offset) {
            my($kerntable_len) = unpack('v', substr($self->{_rawdata},
                                                    $kerntable_offset, 2));
            foreach (unpack('a4' x $kerntable_len,
                            substr($self->{_rawdata},
                                   $kerntable_offset + 2,
                                   4 * $kerntable_len))) {
                my($pair, $kern) = unpack('a2v', $_);
                $kern -= 65536 if $kern > 32768;
                $kerndata->{$pair} = int $kern;
            }
        }
    }
    $kerndata;
}

sub AUTOLOAD {
    return if $AUTOLOAD =~ /::DESTROY$/;
    die "Undefined subroutine $AUTOLOAD"
      unless exists $pfm_field_map{$AUTOLOAD};
    my $struct = &{$pfm_field_map{$AUTOLOAD}};
    $struct->{$AUTOLOAD};
}

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

1;

__END__