File Coverage

blib/lib/PDF/API3/Compat/API2/Resource/BaseFont.pm

Criterion	Covered	Total	%
statement	26	261	9.9
branch	0	74	0.0
condition	0	56	0.0
subroutine	9	59	15.2
pod	45	50	90.0
total	80	500	16.0

#=======================================================================
#    ____  ____  _____              _    ____ ___   ____
#   |  _ \|  _ \|  ___|  _   _     / \  |  _ \_ _| |___ \
#   | |_) | | | | |_    (_) (_)   / _ \ | |_) | |    __) |
#   |  __/| |_| |  _|    _   _   / ___ \|  __/| |   / __/
#   |_|   |____/|_|     (_) (_) /_/   \_\_|  |___| |_____|
#
#   A Perl Module Chain to faciliate the Creation and Modification
#   of High-Quality "Portable Document Format (PDF)" Files.
#
#   Copyright 1999-2005 Alfred Reibenschuh .
#
#=======================================================================
#
#   This library is free software; you can redistribute it and/or
#   modify it under the terms of the GNU Lesser General Public
#   License as published by the Free Software Foundation; either
#   version 2 of the License, or (at your option) any later version.
#
#   This library 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 the GNU
#   Lesser General Public License for more details.
#
#   You should have received a copy of the GNU Lesser General Public
#   License along with this library; if not, write to the
#   Free Software Foundation, Inc., 59 Temple Place - Suite 330,
#   Boston, MA 02111-1307, USA.
#
#   $Id: BaseFont.pm,v 2.9 2007/10/16 20:08:19 areibens Exp $
#
#=======================================================================
package PDF::API3::Compat::API2::Resource::BaseFont;

BEGIN {

    use utf8;
    use Encode qw(:all);

    use PDF::API3::Compat::API2::Util;
    use PDF::API3::Compat::API2::Basic::PDF::Utils;
    use PDF::API3::Compat::API2::Resource;
    use Compress::Zlib;

    use vars qw(@ISA $VERSION);

    @ISA = qw( PDF::API3::Compat::API2::Resource );

    ( $VERSION ) = sprintf '%i.%03i', split(/\./,('$Revision: 2.9 $' =~ /Revision: (\S+)\s/)[0]); # $Date: 2007/10/16 20:08:19 $

}
no warnings qw[ deprecated recursion uninitialized ];

=item $font = PDF::API3::Compat::API2::Resource::BaseFont->new $pdf, $name

Returns a font resource object.

=cut

sub new {
    my ($class,$pdf,$name) = @_;
    my $self;

    $class = ref $class if ref $class;
    $self=$class->SUPER::new($pdf,$name);

    $pdf->new_obj($self) unless($self->is_obj($pdf));

    $self->{Type} = PDFName('Font');

    $self->{' apipdf'}=$pdf;
    return($self);
}

=item $font = PDF::API3::Compat::API2::Resource::BaseFont->new_api $api, $name

Returns a font resource object. This method is different from 'new' that
it needs an PDF::API3::Compat::API2-object rather than a Text::PDF::File-object.

=cut

sub new_api {
    my ($class,$api,@opts)=@_;

    my $obj=$class->new($api->{pdf},@opts);
    $obj->{' api'}=$api;

    return($obj);
}

sub data { return( $_[0]->{' data'} ); }

=item $descriptor = $font->descrByData()

Returns the fonts FontDescriptor key-structure based on the fonts data.

=cut

sub descrByData {
    my $self=shift @_;

    my $des=PDFDict();
    $self->{' apipdf'}->new_obj($des);

    ### $self->{'FontDescriptor'}=$des;

    $des->{'Type'}=PDFName('FontDescriptor');
    $des->{'FontName'}=PDFName($self->fontname);

    my @w = map { PDFNum($_ || 0) } $self->fontbbox;
    $des->{'FontBBox'}=PDFArray(@w);

 #   unless($self->issymbol) {
        $des->{'Ascent'}=PDFNum($self->ascender || 0);
        $des->{'Descent'}=PDFNum($self->descender || 0);
        $des->{'ItalicAngle'}=PDFNum($self->italicangle || 0.0);
        $des->{'XHeight'}=PDFNum($self->xheight || (($self->fontbbox)[3]*0.5) || 500);
        $des->{'CapHeight'}=PDFNum($self->capheight || ($self->fontbbox)[3] || 800);
        $des->{'StemV'}=PDFNum($self->stemv || 0);
        $des->{'StemH'}=PDFNum($self->stemh || 0);
        $des->{'AvgWidth'}=PDFNum($self->avgwidth || 300);
        $des->{'MissingWidth'}=PDFNum($self->missingwidth || 300);
        $des->{'MaxWidth'}=PDFNum($self->maxwidth || $self->missingwidth || ($self->fontbbox)[2]);
        $des->{'Flags'}=PDFNum($self->flags || 0) unless($self->data->{iscore});
        if(defined $self->data->{panose}) {
            $des->{Style}=PDFDict();
            $des->{Style}->{Panose}=PDFStrHex($self->data->{panose});
        }
        $des->{FontFamily}=PDFStr($self->data->{fontfamily})
            if(defined $self->data->{fontfamily});
        $des->{FontWeight}=PDFNum($self->data->{fontweight})
            if(defined $self->data->{fontweight});
        $des->{FontStretch}=PDFName($self->data->{fontstretch})
            if(defined $self->data->{fontstretch});
 #   }

    return($des);
}

sub tounicodemap {
    my $self=shift @_;

    return($self) if(defined $self->{ToUnicode});

    my $cmap=qq|\%\% Custom\n\%\% CMap\n\%\%\n/CIDInit /ProcSet findresource begin\n|;
    $cmap.=qq|12 dict begin begincmap\n|;
    $cmap.=qq|/CIDSystemInfo <<\n|;
    $cmap.=sprintf(qq|   /Registry (%s)\n|,$self->name);
    $cmap.=qq|   /Ordering (XYZ)\n|;
    $cmap.=qq|   /Supplement 0\n|;
    $cmap.=qq|>> def\n|;
    $cmap.=sprintf(qq|/CMapName /pdfapi2-%s+0 def\n|,$self->name);
    if(UNIVERSAL::can($self,'uniByCId') && UNIVERSAL::can($self,'glyphNum')) {
        # this is a type0 font
        $cmap.=sprintf(qq|1 begincodespacerange <0000> <%04X> endcodespacerange\n|,$self->glyphNum-1);
        for(my $j=0;$j<$self->glyphNum;$j++) {
            my $i = $self->glyphNum - $j > 100 ? 100 : $self->glyphNum - $j;
            if($j==0) {
                $cmap.=qq|$i beginbfrange\n|;
            } elsif($j%100 == 0) {
                $cmap.=qq|endbfrange\n|;
                $cmap.=qq|$i beginbfrange\n|;
            }
            $cmap.=sprintf(qq|<%04x> <%04x> <%04x>\n|,$j,$j,$self->uniByCId($j));
        }
        $cmap.="endbfrange\n";
    } else {
        # everything else is single byte font
        $cmap.=qq|1 begincodespacerange\n<00> \nendcodespacerange\n|;
        $cmap.=qq|256 beginbfchar\n|;
        for(my $j=0; $j<256;$j++) {
            $cmap.=sprintf(qq|<%02X> <%04X>\n|,$j,$self->uniByEnc($j));
        }
        $cmap.=qq|endbfchar\n|;
    }
    $cmap.=qq|endcmap CMapName currendict /CMap defineresource pop end end\n|;

    my $tuni=PDFDict();
    $tuni->{Type}=PDFName('CMap');
    $tuni->{CMapName}=PDFName(sprintf(qq|pdfapi2-%s+0|,$self->name));
    $tuni->{CIDSystemInfo}=PDFDict();
    $tuni->{CIDSystemInfo}->{Registry}=PDFStr($self->name);
    $tuni->{CIDSystemInfo}->{Ordering}=PDFStr('XYZ');
    $tuni->{CIDSystemInfo}->{Supplement}=PDFNum(0);

    $self->{' apipdf'}->new_obj($tuni);
    $tuni->{' nofilt'}=1;
    $tuni->{' stream'}=Compress::Zlib::compress($cmap);
    $tuni->{Filter}=PDFArray(PDFName('FlateDecode'));
    $self->{ToUnicode}=$tuni;
    return($self);
}


=back

=head1 FONT-MANAGEMENT RELATED METHODS

=over 4

=item $name = $font->fontname()

Returns the fonts name (aka. display-name).

=cut

sub fontname { return( $_[0]->data->{fontname} ); }

=item $name = $font->altname()

Returns the fonts alternative-name (aka. windows-name for a postscript font).

=cut

sub altname { return( $_[0]->data->{altname} ); }

=item $name = $font->subname()

Returns the fonts subname (aka. font-variant, schriftschnitt).

=cut

sub subname { return( $_[0]->data->{subname} ); }

=item $name = $font->apiname()

Returns the fonts name to be used internally (should be equal to $font->name).

=cut

sub apiname { return( $_[0]->data->{apiname} ); }

=item $issymbol = $font->issymbol()

Returns the fonts symbol flag.

=cut

sub issymbol { return( $_[0]->data->{issymbol} ); }

=item $iscff = $font->iscff()

Returns the fonts compact-font-format flag.

=cut

sub iscff { return( $_[0]->data->{iscff} ); }

=back

=head1 TYPOGRAPHY RELATED METHODS

=over 4

=item ($llx, $lly, $urx, $ury) = $font->fontbbox()

Returns the fonts bounding-box.

=cut

sub fontbbox { return( @{$_[0]->data->{fontbbox}} ); }

=item $capheight = $font->capheight()

Returns the fonts capheight value.

=cut

sub capheight { return( $_[0]->data->{capheight} ); }

=item $xheight = $font->xheight()

Returns the fonts xheight value.

=cut

sub xheight { return( $_[0]->data->{xheight} ); }

=item $missingwidth = $font->missingwidth()

Returns the fonts missingwidth value.

=cut

sub missingwidth { return( $_[0]->data->{missingwidth} ); }

=item $maxwidth = $font->maxwidth()

Returns the fonts maxwidth value.

=cut

sub maxwidth { return( $_[0]->data->{maxwidth} ); }

=item $avgwidth = $font->avgwidth()

Returns the fonts avgwidth value.

=cut

sub avgwidth {
    my ($self) = @_;
    my $aw=$self->data->{avgwidth};
    $aw||=((
        $self->wxByGlyph('a')*64  +
        $self->wxByGlyph('b')*14  +
        $self->wxByGlyph('c')*27  +
        $self->wxByGlyph('d')*35  +
        $self->wxByGlyph('e')*100 +
        $self->wxByGlyph('f')*20  +
        $self->wxByGlyph('g')*14  +
        $self->wxByGlyph('h')*42  +
        $self->wxByGlyph('i')*63  +
        $self->wxByGlyph('j')* 3  +
        $self->wxByGlyph('k')* 6  +
        $self->wxByGlyph('l')*35  +
        $self->wxByGlyph('m')*20  +
        $self->wxByGlyph('n')*56  +
        $self->wxByGlyph('o')*56  +
        $self->wxByGlyph('p')*17  +
        $self->wxByGlyph('q')* 4  +
        $self->wxByGlyph('r')*49  +
        $self->wxByGlyph('s')*56  +
        $self->wxByGlyph('t')*71  +
        $self->wxByGlyph('u')*31  +
        $self->wxByGlyph('v')*10  +
        $self->wxByGlyph('w')*18  +
        $self->wxByGlyph('x')* 3  +
        $self->wxByGlyph('y')*18  +
        $self->wxByGlyph('z')* 2  +
        $self->wxByGlyph('A')*64  +
        $self->wxByGlyph('B')*14  +
        $self->wxByGlyph('C')*27  +
        $self->wxByGlyph('D')*35  +
        $self->wxByGlyph('E')*100 +
        $self->wxByGlyph('F')*20  +
        $self->wxByGlyph('G')*14  +
        $self->wxByGlyph('H')*42  +
        $self->wxByGlyph('I')*63  +
        $self->wxByGlyph('J')* 3  +
        $self->wxByGlyph('K')* 6  +
        $self->wxByGlyph('L')*35  +
        $self->wxByGlyph('M')*20  +
        $self->wxByGlyph('N')*56  +
        $self->wxByGlyph('O')*56  +
        $self->wxByGlyph('P')*17  +
        $self->wxByGlyph('Q')* 4  +
        $self->wxByGlyph('R')*49  +
        $self->wxByGlyph('S')*56  +
        $self->wxByGlyph('T')*71  +
        $self->wxByGlyph('U')*31  +
        $self->wxByGlyph('V')*10  +
        $self->wxByGlyph('W')*18  +
        $self->wxByGlyph('X')* 3  +
        $self->wxByGlyph('Y')*18  +
        $self->wxByGlyph('Z')* 2  +
        $self->wxByGlyph('space')*332
    ) / 2000);
    return( int($aw) );
}

=item $flags = $font->flags()

Returns the fonts flags value.

=cut

sub flags { return( $_[0]->data->{flags} ); }

=item $stemv = $font->stemv()

Returns the fonts stemv value.

=cut

sub stemv { return( $_[0]->data->{stemv} ); }

=item $stemh = $font->stemh()

Returns the fonts stemh value.

=cut

sub stemh { return( $_[0]->data->{stemh} ); }

=item $italicangle = $font->italicangle()

Returns the fonts italicangle value.

=cut

sub italicangle { return( $_[0]->data->{italicangle} ); }

=item $isfixedpitch = $font->isfixedpitch()

Returns the fonts isfixedpitch flag.

=cut

sub isfixedpitch { return( $_[0]->data->{isfixedpitch} ); }

=item $underlineposition = $font->underlineposition()

Returns the fonts underlineposition value.

=cut

sub underlineposition { return( $_[0]->data->{underlineposition} ); }

=item $underlinethickness = $font->underlinethickness()

Returns the fonts underlinethickness value.

=cut

sub underlinethickness { return( $_[0]->data->{underlinethickness} ); }

=item $ascender = $font->ascender()

Returns the fonts ascender value.

=cut

sub ascender { return( $_[0]->data->{ascender} ); }

=item $descender = $font->descender()

Returns the fonts descender value.

=cut

sub descender { return( $_[0]->data->{descender} ); }

=back

=head1 GLYPH RELATED METHODS

=over 4

=item @names = $font->glyphNames()

Returns the defined glyph-names of the font.

=cut

sub glyphNames { return ( keys %{$_[0]->data->{wx}} ); }

=item $glNum = $font->glyphNum()

Returns the number of defined glyph-names of the font.

=cut

sub glyphNum { return ( scalar keys %{$_[0]->data->{wx}} ); }

=item $uni = $font->uniByGlyph $char

Returns the unicode by glyph-name.

=cut

sub uniByGlyph { return( $_[0]->data->{n2u}->{$_[1]} ); }

=item $uni = $font->uniByEnc $char

Returns the unicode by the fonts encoding map.

=cut

sub uniByEnc { return($_[0]->data->{e2u}->[$_[1]] ); }

=item $uni = $font->uniByMap $char

Returns the unicode by the fonts default map.

=cut

sub uniByMap { return($_[0]->data->{uni}->[$_[1]]); }

=item $char = $font->encByGlyph $glyph

Returns the character by the given glyph-name of the fonts encoding map.

=cut

sub encByGlyph { return( $_[0]->data->{n2e}->{$_[1]} || 0 ); }

=item $char = $font->encByUni $uni

Returns the character by the given unicode of the fonts encoding map.

=cut

sub encByUni { return( $_[0]->data->{u2e}->{$_[1]} || $_[0]->data->{u2c}->{$_[1]} || 0 ); }

=item $char = $font->mapByGlyph $glyph

Returns the character by the given glyph-name of the fonts default map.

=cut

sub mapByGlyph { return( $_[0]->data->{n2c}->{$_[1]} || 0 ); }

=item $char = $font->mapByUni $uni

Returns the character by the given unicode of the fonts default map.

=cut

sub mapByUni { return( $_[0]->data->{u2c}->{$_[1]} || 0 ); }

=item $name = $font->glyphByUni $unicode

Returns the glyphs name by the fonts unicode map.
B non-standard glyph-names are mapped onto
the ms-symbol area (0xF000).

=cut

sub glyphByUni { return ( $_[0]->data->{u2n}->{$_[1]} || '.notdef' ); }

=item $name = $font->glyphByEnc $char

Returns the glyphs name by the fonts encoding map.

=cut

sub glyphByEnc {
    my ($self,$e)=@_;
    my $g=$self->data->{e2n}->[$e];
    return( $g );
}

=item $name = $font->glyphByMap $char

Returns the glyphs name by the fonts default map.

=cut

sub glyphByMap { return ( $_[0]->data->{char}->[$_[1]] ); }

=item $width = $font->wxByGlyph $glyph

Returns the glyphs width.

=cut

sub wxByGlyph
{
    my $self=shift;
    my $val=shift;
    my $ret=undef;
    if(ref($self->data->{wx}) eq 'HASH')
    {
    	$ret=$self->data->{wx}->{$val};
    	if(!defined($ret))
    	{
    		$ret=$self->missingwidth;
    	}
    	if(!defined($ret))
    	{
    		$ret=300;
    	}
    }
    else
    {
    	my $cid=$self->cidByUni(uniByName($val));
    	$ret=$self->data->{wx}->[$cid];
    	if(!defined($ret))
    	{
    		$ret=$self->missingwidth;
    	}
    	if(!defined($ret))
    	{
    		$ret=300;
    	}
    }
    return $ret;
}

=item $width = $font->wxByUni $uni

Returns the unicodes width.

=cut

sub wxByUni
{
    my $self=shift;
    my $val=shift;
    my $gid=$self->glyphByUni($val);
    my $ret=$self->data->{wx}->{$gid};
   	if(!defined($ret))
   	{
   		$ret=$self->missingwidth;
   	}
   	if(!defined($ret))
   	{
   		$ret=300;
   	}
    return $ret;
}

=item $width = $font->wxByEnc $char

Returns the characters width based on the current encoding.

=cut

sub wxByEnc
{
    my ($self,$e)=@_;
    my $g=$self->glyphByEnc($e);
    my $ret=$self->data->{wx}->{$g};
   	if(!defined($ret))
   	{
   		$ret=$self->missingwidth;
   	}
   	if(!defined($ret))
   	{
   		$ret=300;
   	}
    return $ret;
}

=item $width = $font->wxByMap $char

Returns the characters width based on the fonts default encoding.

=cut

sub wxByMap
{
    my ($self,$m)=@_;
    my $g=$self->glyphByMap($m);
    my $ret=$self->data->{wx}->{$g};
   	if(!defined($ret))
   	{
   		$ret=$self->missingwidth;
   	}
   	if(!defined($ret))
   	{
   		$ret=300;
   	}
    return $ret;
}

=item $wd = $font->width $text

Returns the width of $text as if it were at size 1.
B works only correctly if a proper perl-string
is used either in native or utf8 format (check utf8-flag).

=cut

sub width {
    my ($self,$text)=@_;
    my $width=0;
    if(is_utf8($text)) {
        $text=$self->strByUtf($text)
    }
    my $lastglyph='';
    foreach my $n (unpack('C*',$text))
    {
        $width+=$self->wxByEnc($n);
        if($self->{-dokern} && ref($self->data->{kern}))
        {
            $width+=$self->data->{kern}->{$lastglyph.':'.$self->data->{e2n}->[$n]};
            $lastglyph=$self->data->{e2n}->[$n];
        }
    }
    $width/=1000;
    return($width);
}

=item @widths = $font->width_array $text

Returns the widths of the words in $text as if they were at size 1.

=cut

sub width_array {
    my ($self,$text)=@_;
    if(!is_utf8($text)) {
        $text=$self->utfByStr($text);
    }
    my @text=split(/\s+/,$text);
    my @widths=map { $self->width($_) } @text;
    return(@widths);
}

=back

=head1 STRING METHODS

=over 4

=item $utf8string = $font->utfByStr $string

Returns the utf8-string from string based on the fonts encoding map.

=cut

sub utfByStr {
    my ($self,$s)=@_;
    $s=pack('U*',map { $self->uniByEnc($_) } unpack('C*',$s));
    utf8::upgrade($s);
    return($s);
}

=item $string = $font->strByUtf $utf8string

Returns the encoded string from utf8-string based on the fonts encoding map.

=cut

sub strByUtf {
    my ($self,$s)=@_;
    $s=pack('C*',map { $self->encByUni($_) & 0xFF } unpack('U*',$s));
    utf8::downgrade($s);
    return($s);
}

=item $pdfstring = $font->textByStr $text

Returns a properly formatted representation of $text for use in the PDF.

=cut

sub textByStr
{
    my ($self,$text)=@_;
    my $newtext='';
    if(is_utf8($text))
    {
        $text=$self->strByUtf($text);
    }
    $newtext=$text;
    $newtext=~s/\\/\\\\/go;
    $newtext=~s/([\x00-\x1f])/sprintf('\%03lo',ord($1))/ge;
    $newtext=~s/([\{\}\[\]\(\)])/\\$1/g;
    return($newtext);
}

sub textByStrKern
{
    my ($self,$text)=@_;
    if($self->{-dokern} && ref($self->data->{kern}))
    {
        my $newtext=' ';
        if(is_utf8($text))
        {
            $text=$self->strByUtf($text);
        }

        my $lastglyph='';
        my $tBefore=0;
        foreach my $n (unpack('C*',$text))
        {
            if(defined $self->data->{kern}->{$lastglyph.':'.$self->data->{e2n}->[$n]})
            {
                $newtext.=') ' if($tBefore);
                $newtext.=sprintf('%i ',-($self->data->{kern}->{$lastglyph.':'.$self->data->{e2n}->[$n]}));
                $tBefore=0;
            }
            $lastglyph=$self->data->{e2n}->[$n];
            my $t=pack('C',$n);
            $t=~s/\\/\\\\/go;
            $t=~s/([\x00-\x1f])/sprintf('\%03lo',ord($1))/ge;
            $t=~s/([\{\}\[\]\(\)])/\\$1/g;
            $newtext.='(' if(!$tBefore);
            $newtext.="$t";
            $tBefore=1;
        }
        $newtext.=') ' if($tBefore);
        return($newtext);
    }
    else
    {
        return('('.$self->textByStr($text).')');
    }
}

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

    my $newtext=$self->textByStr($text);

    if(defined $size && $self->{-dokern})
    {
        $newtext=$self->textByStrKern($text);
        if(defined($ident) && $ident!=0)
        {
	        return("[ $ident $newtext ] TJ");
        }
        else
        {
	        return("[ $newtext ] TJ");
        }
    }
    elsif(defined $size)
    {
        if(defined($ident) && $ident!=0)
        {
	        return("[ $ident ($newtext) ] TJ");
        }
        else
        {
	        return("[ ($newtext) ] TJ");
        }
    }
    else
    {
        return("($newtext)");
    }
}

sub isvirtual { return(0); }

1;

__END__