File Coverage

blib/lib/PostScript/File/Metrics.pm

Criterion	Covered	Total	%
statement	113	151	74.8
branch	42	76	55.2
condition	18	37	48.6
subroutine	14	29	48.2
pod	20	20	100.0
total	207	313	66.1

#---------------------------------------------------------------------
package PostScript::File::Metrics;
#
# Copyright 2009 Christopher J. Madsen
#
# Author: Christopher J. Madsen
# Created: 29 Oct 2009
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either the
# GNU General Public License or the Artistic License for more details.
#
# ABSTRACT: Metrics for PostScript fonts
#---------------------------------------------------------------------

use 5.008;
our $VERSION = '2.11';          ## no critic
# This file is part of PostScript-File 2.23 (October 10, 2015)

use strict;
use warnings;
use Carp qw(carp croak);
use Encode qw(find_encoding);

use PostScript::File ':metrics_methods'; # Import some methods

our (%Info, %Metrics);

#=====================================================================
# Generate accessor methods:

BEGIN {
  my ($code, $error, $success) = '';
  foreach my $attribute (qw(
    full_name
    family
    weight
    fixed_pitch
    italic_angle
    version
  )) {
    $code .= "sub $attribute { shift->{info}{$attribute} };\n";
  }

  foreach my $attribute (qw(
    underline_position
    underline_thickness
    cap_height
    x_height
    ascender
    descender
  )) {
    $code .= <<"END SUB";
      sub $attribute {
        my \$self = shift;
        my \$v = \$self->{info}{$attribute};
        defined \$v ? \$v * \$self->{factor} : \$v;
      }
END SUB
  }

  { local $@;
    $success = eval "$code ; 'OK'"; ## no critic ProhibitStringyEval
    $error   = $@;
  } # end local $@

  unless ($success and $success eq 'OK') {
    $error ||= 'eval died with false $@';
    die "$code\n$error";
  }
} # end BEGIN

#---------------------------------------------------------------------
sub font_bbox
{
  my $self = shift;

  my $bbox = $self->{info}{font_bbox};

  if (1 != (my $f = $self->{factor})) {
    [ map { $_ * $f } @$bbox ];
  } else {
    $bbox;
  }
} # end font_bbox

#---------------------------------------------------------------------
sub auto_hyphen { shift->{auto_hyphen} }
sub size { shift->{size} }

#=====================================================================


sub new
{
  my ($class, $font, $size, $encoding) = @_;

  $encoding ||= ($font eq 'Symbol' ? 'sym' : 'std');

  # Load the metrics if necessary:
  unless ($Metrics{$font}{$encoding}) {
    # First, try to load a pre-compiled package:
    my $package = _get_package_name($font, $encoding);

    ## no critic (ProhibitStringyEval)
    unless (do { local $@; eval "require $package; 1" }
            and $Metrics{$font}{$encoding}) {
      # No pre-compiled package, we'll have to read the AFM file:
      ## use critic
      require PostScript::File::Metrics::Loader;

      PostScript::File::Metrics::Loader::load($font, [$encoding]);
    } # end unless metrics have been pre-generated
  } # end unless the metrics are loaded

  # Create the Metrics object:
  my $self = bless {
    info     => $Info{$font},
    metrics  => $Metrics{$font}{$encoding}
      || croak "Failed to load metrics for $font in encoding $encoding",
  }, $class;

  $self->{encoding} = find_encoding($encoding)
      or croak "Unknown encoding $encoding"
          unless $encoding =~ /^(?:std|sym)$/;
  $self->set_auto_hyphen(1);
  $self->set_size($size);
  $self->set_wrap_chars;
} # end new
#---------------------------------------------------------------------


sub set_size
{
  my ($self, $size) = @_;

  $self->{size} = $size || 1000;

  $self->{factor} = ($size ? $size/1000.0 : 1);

  $self;
} # end set_size
#---------------------------------------------------------------------


sub width
{
  my $self = shift; # $string

  return 0.0 unless defined $_[0] and length $_[0];

  my $wx = $self->{metrics};

  my $string = $_[1] ? $_[0] : $self->encode_text(
    $self->{auto_hyphen} ? $self->convert_hyphens($_[0]) : $_[0]
  );

  my $width = 0;
  $width += $wx->[$_] for unpack("C*", $string);

  $width * $self->{factor};
} # end width
#---------------------------------------------------------------------


sub wrap
{
  my $self  = shift;
  my $width = shift;
  my $text  = shift;
  my %param = @_ ? %{+shift} : ();

  my $maxlines = delete $param{maxlines};
  my $quiet    = delete $param{quiet};
  my $warnings = delete $param{warnings};
  my $re       = (exists($param{chars})
                  ? $self->_build_wrap_re(delete $param{chars})
                  : $self->{wrap_re});

  carp "Unknown wrap parameter(s) @{[ keys %param ]}" if %param;

  # Remove CRs; convert ZWSP to CR:
  $text =~ s/\r//g;
  $text =~ s/\x{200B}/\r/g if Encode::is_utf8($text);

  $text  = $self->encode_text(
    $self->{auto_hyphen} ? $self->convert_hyphens($text) : $text
  );

  # Do word wrapping:
  my @lines = '';

  for ($text) {
    if (m/\G[ \t\r]*\n/gc) {
      push @lines, '';
    } else {
      m/\G($re)/g or last;
      my $word = $1;
    check_word:
      if ($self->width($lines[-1] . $word, 1) <= $width) {
        $lines[-1] .= $word;
      } elsif ($lines[-1] eq '') {
        $lines[-1] = $word;
        my $w = sprintf("%s is too wide (%g) for field width %g",
                        $word, $self->width($word, 1), $width);
        push @$warnings, $w if $warnings;
        carp $w unless $quiet;
      } else {
        push @lines, '';
        $word =~ s/^[ \t\r]+//;
        goto check_word;
      }
    } # end else not at LF

    if (defined $maxlines and @lines >= $maxlines) {
      $lines[-1] .= $1 if m/\G(.*[^ \t\r\n])/sg;
      if (($warnings or not $quiet) and
          (my $linewidth = $self->width($lines[-1], 1)) > $width) {
        my $w = sprintf("'%s' is too wide (%g) for field width %g",
                        $lines[-1], $linewidth, $width);
        push @$warnings, $w if $warnings;
        carp $w unless $quiet;
      } # end if issuing warning about last line
      last;
    } # end if reached maximum number of lines

    redo;                   # Only the "last" statement above can exit
  } # end for $text

  # Remove any remaining CR (ZWSP) chars:
  s/\r//g for @lines;

  # Remove the last line if it's blank ($text ended with newline):
  pop @lines unless @lines == 1 or length $lines[-1];

  if ($self->{auto_hyphen}) {
    # At this point, any hyphen-minus characters are unambiguously
    # MINUS SIGN.  Protect them from further processing:
    map { $self->decode_text($_, 1) } @lines;
  } else {
    @lines;
  }
} # end wrap
#---------------------------------------------------------------------


sub set_wrap_chars
{
  my $self = shift;

  $self->{wrap_re} = $self->_build_wrap_re(@_);

  $self;
} # end set_wrap_chars

#---------------------------------------------------------------------
our %_wrap_re_cache;

sub _build_wrap_re
{
  my ($self, $chars) = @_;

  if (not defined $chars) {
    $chars = '-/';
    if ($self->{encoding}) {
      $chars .= "\xAD";
      # Only cp1252 has en dash & em dash:
      $chars .= "\x{2013}\x{2014}" if $self->{encoding}->name eq 'cp1252';
    }
  } # end if $chars not supplied (use default)

  $chars = $self->encode_text($chars);

  return $_wrap_re_cache{$chars} ||= do {
    if (length $chars) {
      $chars =~ s/(.)/ sprintf '\x%02X', ord $1 /seg;

      qr(
        [ \t\r]*
        (?: [^$chars \t\r\n]+ |
            [$chars]+ [^$chars \t\r\n]* )
        [$chars]*
      )x;
    } else {
      qr( [ \t\r]*  [^ \t\r\n]+ )x;
    }
  };
} # end _build_wrap_re

#---------------------------------------------------------------------
# Return the package in which the font's metrics are stored:

sub _get_package_name
{
  my ($font, $encoding) = @_;

  my $package = $encoding;
  $package =~ s/-/_/g;
  $package .= " $font";
  $package =~ s/\W+/::/g;

  "PostScript::File::Metrics::$package";
} # end _get_package_name

#=====================================================================
# Package Return Value:

1;

__END__