File Coverage

blib/lib/PDF/Builder/Resource/Font/SynFont.pm

Criterion	Covered	Total	%
statement	21	196	10.7
branch	0	94	0.0
condition	0	109	0.0
subroutine	7	8	87.5
pod	1	1	100.0
total	29	408	7.1

package PDF::Builder::Resource::Font::SynFont;

use base 'PDF::Builder::Resource::Font';

use strict;
use warnings;

our $VERSION = '3.028'; # VERSION
our $LAST_UPDATE = '3.028'; # manually update whenever code is changed

use Math::Trig;    # CAUTION: deg2rad(0) = deg2rad(360) = 0!
use Unicode::UCD 'charinfo';

use PDF::Builder::Util;
use PDF::Builder::Basic::PDF::Utils;

# for noncompatible options, consider '-entry_point' = 'synfont' or
# 'synthetic_font' to be picked up and processed correctly per entry point

=head1 NAME

PDF::Builder::Resource::Font::SynFont - Module for creating temporary synthetic Fonts

Inherits from L<PDF::Builder::Resource::Font>

=head1 SYNOPSIS

This module permits you to create a "new" font (loaded temporarily, but not
permanently stored) based on an existing font, where you can modify certain
attributes in the original font, such as:

    * slant/obliqueness
    * extra weight/boldness (by drawing glyph outlines at various line
      thicknesses, rather than just filling enclosed areas)
    * condense/expand (narrower or wider characters) a.k.a. B<stretch>
    * extra space between characters
    * small caps (synthesized, not using any provided with a font)
    * change the encoding

    $pdf = PDF::Builder->new();
    $cft = $pdf->font('Times-Roman');  # corefont, ttfont, etc. also works
    $sft = $pdf->synfont($cft, 'condense' => .75);  # condense by 25%

This works for I<corefonts>, I<PS fonts>, and I<TTF/OTF fonts>; but does not
work for I<CJK fonts> or I<bitmapped fonts>.
See also L<PDF::Builder::Docs/Synthetic Fonts>.

B<Alternate name:> C<synthetic_font>

This is for compatibility with recent changes to PDF::API2.

=head1 METHODS

=head2 new

    $font = PDF::Builder::Resource::Font::SynFont->new($pdf, $fontobj, %opts)

=over

Returns a synfont object. C<$fontobj> is a normal font object read in from
a file, and C<$font> is the modified output.

Valid options %opts are:

=over

=item I<encode>

Changes the encoding of the font from its default.
See I<Perl's Encode> for the supported values. B<Warning:> only single byte
encodings are supported. Multibyte encodings such as UTF-8 are invalid.

=item I<pdfname>

Changes the reference-name of the font from its default.
The reference-name is normally generated automatically and can be
retrieved via $pdfname=$font->name().

B<Alternate name:> C<name> (for PDF::API2 compatibility)

=item I<condense>

Character width condense/expand factor (0.1-0.9 = condense, 1 = normal/default,
1.1+ = expand). It is the multiplier to apply to the width of each character.

In some font systems, this aspect or axis is known as I<stretch>.

B<Alternate names:> C<hscale> and C<slant> (for PDF::API2 compatibility)

The I<slant> option is a deprecated name in both PDF::Builder and PDF::API2.
Its value is the same as I<condense> value (1 = normal, unchanged scale).
For the I<hscale> option, the value is percentage (%), with 100 being normal,
and other values 100 times the I<condense> value.
B<Use only one (at most) of these three option names.>

=item I<oblique>

Italic or slanted text angle (+/-) in degrees, where the character box is
skewed (sheared), top to the right. While it's unlikely that anyone will want
to slant characters at +/-360 degrees, they should be aware that these will be
treated as an angle of 0 degrees (deg2rad() wraps around). 0 degrees of italic
slant (obliqueness) is the default.

Note that a font management system may have separate axes for normal/italic
fonts, and the degree of I<slant>. Italic is a different (but related) face
to the regular (e.g., Roman) face, sometimes made to resemble handwritten
characters, and is usually a binary selection (it's either italic or it's not).
Slant, on the other hand, can be in arbitrary amounts, and may be applied to either
normal (originally Roman posture) or italics (which are often themselves
slightly slanted). Finally, what many fonts call "italic" others may call
"slanted" or "oblique", and in these cases the coordinate system is merely
sheared to slant the character box.

B<Alternate name:> C<angle> (for PDF::API2 compatibility)

B<Use only one (at most) of these two option names.>

=item I<bold>

Embolding factor (0.1+, bold=1, heavy=2, ...). It is additional outline
B<thickness> (B<linewidth>), which expands the character (glyph) outwards (as
well as shrinking unfilled enclosed areas such as bowls and counters).
Normally, the glyph's outline is not drawn (it is only filled); this adds
a thick outline. The units are in 1/100ths of a text unit.

If used with the C<synthetic_font> alternate entry name, the unit is 1/1000th
of a text unit, so you will need a value 10 times larger than with the
C<synfont> entry to get the same effect.

=item I<space>

Additional charspacing in thousandths of an em.

=item I<caps>

Create synthetic small-caps. 0 = no, 1 = yes. These are capitals of
lowercase letters, at 80% height and 88% width. Note that this is guaranteed
to cover ASCII lowercase letters only -- single byte encoded accented
characters I<usually> work, but we can make no promises on accented characters
in general, as well as ligatures!

B<Alternate name:> C<smallcaps> (for PDF::API2 compatibility)

B<Use only one (at most) of these two option names.>

Note that only lower case letters which appear in the "standard" font (plane 0
for core fonts and PS fonts) will be small-capped. This may include eszett
(German sharp s), which becomes SS, and dotless i and j which become I and J
respectively. There are many other accented Latin alphabet letters which I<may>
show up in planes 1 and higher. Ligatures (e.g., ij and ffl) do not have
uppercase equivalents, nor does a long s. If you have text which includes such
characters, you may want to consider preprocessing it to replace them with
Latin character expansions (e.g., i+j and f+f+l) before small-capping.

=back

=back

=cut

# TBD 'name' as alt to 'pdfname'... other font types or just here?

sub new {
    my ($class, $pdf, $font, %opts) = @_;
    # copy dashed named options to preferred undashed names
    if (defined $opts{'-encode'} && !defined $opts{'encode'}) { $opts{'encode'} = delete($opts{'-encode'}); }
    if (defined $opts{'-pdfname'} && !defined $opts{'pdfname'}) { $opts{'pdfname'} = delete($opts{'-pdfname'}); }
        if (defined $opts{'-name'} && !defined $opts{'name'}) { $opts{'name'} = delete($opts{'-name'}); }
    if (defined $opts{'-condense'} && !defined $opts{'condense'}) { $opts{'condense'} = delete($opts{'-condense'}); }
        if (defined $opts{'-slant'} && !defined $opts{'slant'}) { $opts{'slant'} = delete($opts{'-slant'}); }
        if (defined $opts{'-hscale'} && !defined $opts{'hscale'}) { $opts{'hscale'} = delete($opts{'-hscale'}); }
    if (defined $opts{'-oblique'} && !defined $opts{'oblique'}) { $opts{'oblique'} = delete($opts{'-oblique'}); }
        if (defined $opts{'-angle'} && !defined $opts{'angle'}) { $opts{'angle'} = delete($opts{'-angle'}); }
    if (defined $opts{'-bold'} && !defined $opts{'bold'}) { $opts{'bold'} = delete($opts{'-bold'}); }
    if (defined $opts{'-space'} && !defined $opts{'space'}) { $opts{'space'} = delete($opts{'-space'}); }
    if (defined $opts{'-caps'} && !defined $opts{'caps'}) { $opts{'caps'} = delete($opts{'-caps'}); }
        if (defined $opts{'-smallcaps'} && !defined $opts{'smallcaps'}) { $opts{'smallcaps'} = delete($opts{'-smallcaps'}); }

    my $entry = "synfont";  # synfont or synthetic_font
    if (defined $opts{'-entry_point'}) { $entry = $opts{'-entry_point'}; }

    # deal with simple aliases
    if (defined $opts{'slant'} && !defined $opts{'condense'}) { $opts{'condense'} = delete($opts{'slant'}); }
    if (defined $opts{'angle'} && !defined $opts{'oblique'}) { $opts{'oblique'} = delete($opts{'angle'}); }
    if (defined $opts{'smallcaps'} && !defined $opts{'caps'}) { $opts{'caps'} = delete($opts{'smallcaps'}); }
    if (defined $opts{'name'} && !defined $opts{'pdfname'}) { $opts{'pdfname'} = delete($opts{'name'}); }
    # deal with semi-aliases
    if (defined $opts{'hscale'} && !defined $opts{'condense'}) { $opts{'condense'} = delete($opts{'hscale'})/100; }
    # deal with entry point differences
    if (defined $opts{'bold'} && $entry eq 'synthetic_font') { $opts{'bold'} /= 10; }

    my ($self);
    my $first = 1;
    my $last = 255;
    my $cond = $opts{'condense'} || 1;
    my $oblique = $opts{'oblique'} || 0;
    my $space = $opts{'space'} || '0';
    my $bold = ($opts{'bold'} || 0)*10; # convert to em
   #   caps

    # 5 elements apparently not used anywhere
   #$self->{' cond'} = $cond;
   #$self->{' oblique'} = $oblique;
   #$self->{' bold'} = $bold;
   #$self->{' boldmove'} = 0.001;
   #$self->{' space'} = $space;
    # only available in TT fonts. besides, multibyte encodings not supported
    if (defined $opts{'encode'}) {
        if ($opts{'encode'} =~ m/^utf/i) {
	    die "Invalid multibyte encoding for synfont: $opts{'encode'}\n";
	    # TBD probably more multibyte encodings to check
        }
        $font->encodeByName($opts{'encode'});
    }

    $class = ref $class if ref $class;
    $self = $class->SUPER::new($pdf,
   #    pdfkey()
   #    .('+' . $font->name())
   #    .($opts{'caps'} ? '+Caps' : '')
   #    .($opts{'pdfname'} ? '+'.$opts{'pdfname'} : '')
        $opts{'pdfname'}? $opts{'pdfname'}: 'Syn' . $font->name() . pdfkey()
    );
    $pdf->new_obj($self) unless $self->is_obj($pdf);
    $self->{' font'} = $font;
    $self->{' data'} = {
        'type' => 'Type3',
        'ascender' => $font->ascender(),
        'capheight' => $font->capheight(),
        'descender' => $font->descender(),
        'iscore' => '0',
        'isfixedpitch' => $font->isfixedpitch(),
        'italicangle' => $font->italicangle() + $oblique,
        'missingwidth' => ($font->missingwidth()||300) * $cond,
        'underlineposition' => $font->underlineposition(),
        'underlinethickness' => $font->underlinethickness(),
        'xheight' => $font->xheight(),
        'firstchar' => $first,
        'lastchar' => $last,
        'char' => [ '.notdef' ],
        'uni' => [ 0 ],
        'u2e' => { 0 => 0 },
        'fontbbox' => '',
        'wx' => { 'space' => '600' },
    };

    my $data = $self->data();
    if (ref($font->fontbbox())) {
        $data->{'fontbbox'} = [ @{$font->fontbbox()} ];
    } else {
        $data->{'fontbbox'} = [ $font->fontbbox() ];
    }
    $data->{'fontbbox'}->[0] *= $cond;
    $data->{'fontbbox'}->[2] *= $cond;

    $self->{'Subtype'} = PDFName('Type3');
    $self->{'FirstChar'} = PDFNum($first);
    $self->{'LastChar'} = PDFNum($last);
    $self->{'FontMatrix'} = PDFArray(map { PDFNum($_) } (0.001, 0, 0, 0.001, 0, 0));
    $self->{'FontBBox'} = PDFArray(map { PDFNum($_) } $self->fontbbox());

    my $procs = PDFDict();
    $pdf->new_obj($procs);
    $self->{'CharProcs'} = $procs;

    $self->{'Resources'} = PDFDict();
    $self->{'Resources'}->{'ProcSet'} = PDFArray(map { PDFName($_) }
	                                qw(PDF Text ImageB ImageC ImageI));
    my $xo = PDFDict();
    $self->{'Resources'}->{'Font'} = $xo;
    $self->{'Resources'}->{'Font'}->{'FSN'} = $font;
    foreach my $w ($first .. $last) {
        $data->{'char'}->[$w] = $font->glyphByEnc($w);
	# possible non-standard name... use $w as Unicode value
        $data->{'uni'}->[$w] = (uniByName($data->{'char'}->[$w])) || $w;
	if (defined $data->{'uni'}->[$w]) {
            $data->{'u2e'}->{$data->{'uni'}->[$w]} = $w;
	}
    }

    if ($font->isa('PDF::Builder::Resource::CIDFont')) {
        $self->{'Encoding'} = PDFDict();
        $self->{'Encoding'}->{'Type'} = PDFName('Encoding');
        $self->{'Encoding'}->{'Differences'} = PDFArray();
        foreach my $w ($first .. $last) {
	    my $char = $data->{'char'}->[$w];
            if (defined $char && $char ne '.notdef') {
                $self->{'Encoding'}->{'Differences'}->add_elements(PDFNum($w),
			                                       PDFName($char));
            }
        }
    } else {
        $self->{'Encoding'} = $font->{'Encoding'};
    }

    my @widths;
    foreach my $w ($first .. $last) {
	# $w is the "standard encoding" (similar to Windows-1252) PDF
	# single byte encoding. first 32 .notdef, 255 = U+00FF ydieresis
        if ($data->{'char'}->[$w] eq '.notdef') {
            push @widths, $self->missingwidth();
            next;
        }
        my $char = PDFDict();

       #my $wth = int($font->width(chr($w)) * 1000 * $cond + 2 * $space);
        my $uni = $data->{'uni'}->[$w];
	my $wth = int($font->width(chr($uni)) * 1000 * $cond + 2*$space);

        $procs->{$font->glyphByEnc($w)} = $char;
       #$char->{'Filter'} = PDFArray(PDFName('FlateDecode'));
        $char->{' stream'} = $wth." 0 ".join(' ',map { int($_) } $self->fontbbox())." d1\n";
        $char->{' stream'} .= "BT\n";
        $char->{' stream'} .= join(' ', (1, 0, tan(deg2rad($oblique)), 1, 0, 0))." Tm\n" if $oblique;
        $char->{' stream'} .= "2 Tr $bold w\n" if $bold;
       #my $ci = charinfo($data->{'uni'}->[$w]);
        my $ci = {};
  	if ($data->{'uni'}->[$w] ne '') {
    	    $ci = charinfo($data->{'uni'}->[$w]);
  	}

        # Small Caps
	#
        # Most Unicode characters simply don't appear in the synthetic
	# font, which is limited to 255 "standard" encoding points. encode
	# still will be single byte.
	#
	# SynFont seems to have trouble with some accented characters, even
	# though 'upper' is correct and they are in the standard encoding,
	# particularly if the string is decoded to UTF-8. Keep in mind that
	# synfont() only creates a 255 character "standard" encoding font, so
	# you need to apply it to each "plane" of the original font.
	#
	# Some single characters (eszett within the standard encoding, long s
	# outside it) don't have 'upper' defined and are left as-is (or
	# skipped entirely, if outside the encoding) unless first replaced by
	# ASCII lowercase ('ss' and 's' respectively). While we're at it,
	# replace certain Unicode ligatures with ASCII equivalents so they
	# will be small-capped correctly instead of ignored. Don't forget to
	# set proper width for multi-letter replacements.
	#
	my $hasUpper = 0; # if no small caps, still need to output something
        if ($opts{'caps'}) {
	    # not all characters have an 'upper' equivalent code point. Some
	    # have U+0000 (dummy entry).
	    my $ch;
	    my $multiChar = 0;
	    $hasUpper = 1 if defined $ci->{'upper'} && $ci->{'upper'};

	    if ($hasUpper) {
	        # standard upper case character and width spec'd by font
                $ch = $self->encByUni(hex($ci->{'upper'}));
                $wth = int($font->width(chr($ch)) * 800 * $cond * 1.1 + 2* $space);
	    }
	    # let's handle some special cases where !$hasUpper
	    # ($hasUpper set to 1)
	    # only characters to be substituted here, unless there is something
	    # in other encodings to deal with
	    # TBD it does not seem to be possible on non-base planes (plane 1+)
	    #     to access ASCII letters to build a substitute for ligatures
	    #     (e.g., replace U+FB01 fi ligature with F+I)
	    if      ($uni == 0xDF) {  # eszett (German sharp s)
	        $hasUpper = 1;
	        $multiChar = 1;
	        # actually, some fonts have a U+1E9E uppercase Eszett, but
	        # since that won't be in any single byte encoding, we use SS
	        $wth = 2*(int($font->width('S') * 800 * $cond*1.1 + 2*$space));
		$ch = $font->text('S').$font->text('S');
            } elsif ($uni == 0x0131) {  # dotless i
		# standard encoding doesn't see Unicode point
	        $hasUpper = 1;
	        $multiChar = 1;
	        $wth = int($font->width('I') * 800 * $cond*1.1 + 2*$space);
		$ch = $font->text('I');
            } elsif ($uni == 0x0237) {  # dotless j
		# standard encoding doesn't see Unicode point
	        $hasUpper = 1;
	        $multiChar = 1;
	        $wth = int($font->width('J') * 800 * $cond*1.1 + 2*$space);
		$ch = $font->text('J');
            }

	    if ($hasUpper) {
	        # this is a lowercase letter, etc. that has an uppercase version
	        # 80% height x 88% (110% aspect ratio @ 80% font size) width.
		# slightly wider to thicken stems and make look better.
		# $ch and $wth already set, either default or special case
                $char->{' stream'} .= "/FSN 800 Tf\n";
                $char->{' stream'} .= ($cond * 110)." Tz\n";
                $char->{' stream'} .= " [ -$space ] TJ\n" if $space;
		if ($multiChar) {
		    $ch =~ s/><//g;
		    $ch =~ s/\)\(//g;
                    $char->{' stream'} .= "$ch";
		} else {
                    $char->{' stream'} .= $font->text(chr($ch));
		}
	        # uc chr($uni) supposed to be always equivalent to
	        # chr hex($ci->{'upper'}), according to "futuramedium"
	        # HOWEVER, uc doesn't seem to know what to do with non-ASCII chars
	        #$wth = int($font->width(uc chr($uni)) * 800 * $cond * 1.1 + 2* $space);
	        #$char->{' stream'} .= $font->text(uc chr($uni));
                #$wth = int($font->width(chr(hex($ci->{'upper'}))) * 800 * $cond * 1.1 + 2* $space);
                #$char->{' stream'} .= $font->text(chr(hex($ci->{'upper'})));
            } # else fall through to standard handling below
	} # small caps requested

	if (!$hasUpper) {
	    # Applies to all not small-caps too!
	    # does not have an uppercase ('upper') equivalent, so
	    # output at standard height and aspect ratio
            $char->{' stream'} .= "/FSN 1000 Tf\n";
            $char->{' stream'} .= ($cond * 100)." Tz\n" if $cond != 1;
            $char->{' stream'} .= " [ -$space ] TJ\n" if $space;
           #$char->{' stream'} .= $font->text(chr($w));
            $char->{' stream'} .= $font->text(chr($uni));
        }

	# finale... all modifications to font have been done
        $char->{' stream'} .= " Tj\nET ";
        push @widths, $wth;
        $data->{'wx'}->{$font->glyphByEnc($w)} = $wth;
        $pdf->new_obj($char);
    } # loop through 255 standard encoding points

#  the array as 0 elements at this point! 'space' (among others) IS defined,
#  so copy that, but TBD what kind of fallback if no such element exists?
#   $procs->{'.notdef'} = $procs->{$font->data()->{'char'}->[32]};
    $procs->{'.notdef'} = $procs->{'space'};

    $self->{'Widths'} = PDFArray(map { PDFNum($_) } @widths);
    $data->{'e2n'} = $data->{'char'};
    $data->{'e2u'} = $data->{'uni'};

    $data->{'u2c'} = {};
    $data->{'u2e'} = {};
    $data->{'u2n'} = {};
    $data->{'n2c'} = {};
    $data->{'n2e'} = {};
    $data->{'n2u'} = {};

    foreach my $n (reverse 0 .. 255) {
        $data->{'n2c'}->{$data->{'char'}->[$n] // '.notdef'} //= $n;
        $data->{'n2e'}->{$data->{'e2n'}->[$n] // '.notdef'} //= $n;

        $data->{'n2u'}->{$data->{'e2n'}->[$n] // '.notdef'} //= $data->{'e2u'}->[$n];
        $data->{'n2u'}->{$data->{'char'}->[$n] // '.notdef'} //= $data->{'uni'}->[$n];

 	if (defined $data->{'uni'}->[$n]) {
            $data->{'u2c'}->{$data->{'uni'}->[$n]} //= $n
	}
	if (defined $data->{'e2u'}->[$n]) {
            $data->{'u2e'}->{$data->{'e2u'}->[$n]} //= $n;
	    my $value = $data->{'e2n'}->[$n] // '.notdef';
            $data->{'u2n'}->{$data->{'e2u'}->[$n]} //= $value;
	}
 	if (defined $data->{'uni'}->[$n]) {
	    my $value = $data->{'char'}->[$n] // '.notdef';
            $data->{'u2n'}->{$data->{'uni'}->[$n]} //= $value;
	}
    }

    return $self;
}

1;