#======================================================================= # ____ ____ _____ _ ____ ___ ____ # | _ \| _ \| ___| _ _ / \ | _ \_ _| |___ \ # | |_) | | | | |_ (_) (_) / _ \ | |_) | | __) | # | __/| |_| | _| _ _ / ___ \| __/| | / __/ # |_| |____/|_| (_) (_) /_/ \_\_| |___| |_____| # # 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: UniFont.pm,v 2.1 2007/01/04 16:02:28 areibens Exp $ # #======================================================================= package PDF::API2::Resource::UniFont; BEGIN { use utf8; use Encode qw(:all); use PDF::API2::Util; use POSIX; use vars qw($VERSION); ( $VERSION ) = sprintf '%i.%03i', split(/\./,('$Revision: 2.1 $' =~ /Revision: (\S+)\s/)[0]); # $Date: 2007/01/04 16:02:28 $ } no warnings qw[ deprecated recursion uninitialized ]; =item $font = PDF::API2::Resource::UniFont->new $pdf, @fontspecs, %options Returns a uni-font object. =cut =pod B fonts can be registered using the following hash-ref: { font => $fontobj, # the font to be registered blocks => $blockspec, # the unicode blocks, the font is being registered for codes => $codespec, # the unicode codepoints, -"- } B [ $block1, $block3, # register font for block 1 + 3 [$blockA,$blockZ], # register font for blocks A .. Z ] B [ $cp1, $cp3, # register font for codepoint 1 + 3 [$cpA,$cpZ], # register font for codepoints A .. Z ] B if you want to register a font for the entire unicode space (ie. U+0000 .. U+FFFF), then simply specify a font-object without the hash-ref. Valid %options are: '-encode' ... changes the encoding of the font from its default. (see "perldoc Encode" for a list of valid tags) =cut sub new { my ($class,$pdf,@fonts) = @_; $class = ref $class if ref $class; my $self={ fonts=>[], block=>{}, code=>{}, }; bless $self,$class; $self->{pdf}=$pdf; # look at all fonts my $fn=0; while (ref $fonts[0]) { my $font=shift @fonts; if(ref($font) eq 'ARRAY') { push @{$self->{fonts}},$font->[0]; shift @{$font}; while(defined $font->[0]) { my $r0=shift @{$font}; if(ref $r0) { foreach my $b ($r0->[0]..$r0->[-1]) { $self->{block}->{$b}=$fn; } } else { $self->{block}->{$r0}=$fn; } } } elsif(ref($font) eq 'HASH') { push @{$self->{fonts}},$font->{font}; if(defined $font->{blocks} && ref($font->{blocks}) eq 'ARRAY') { foreach my $r0 (@{$font->{blocks}}) { if(ref $r0) { foreach my $b ($r0->[0]..$r0->[-1]) { $self->{block}->{$b}=$fn; } } else { $self->{block}->{$r0}=$fn; } } } if(defined $font->{codes} && ref($font->{codes}) eq 'ARRAY') { foreach my $r0 (@{$font->{codes}}) { if(ref $r0) { foreach my $b ($r0->[0]..$r0->[-1]) { $self->{code}->{$b}=$fn; } } else { $self->{code}->{$r0}=$fn; } } } } else { push @{$self->{fonts}},$font; foreach my $b (0..255) { $self->{block}->{$b}=$fn; } } $fn++; } my %opts=@fonts; $self->{encode}=$opts{-encode} if(defined $opts{-encode}); return($self); } =item $font = PDF::API2::Resource::UniFont->new_api $api, $name, %options Returns a uni-font object. This method is different from 'new' that it needs an PDF::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 isvirtual { return(1); } sub fontlist { my ($self)=@_; return [@{$self->{fonts}}]; } sub width { my ($self,$text)=@_; $text=decode($self->{encode},$text) unless(is_utf8($text)); my $width=0; if(1) { my @blks=(); foreach my $u (unpack('U*',$text)) { my $fn=0; if(defined $self->{code}->{$u}) { $fn=$self->{code}->{$u}; } elsif(defined $self->{block}->{($u>>8)}) { $fn=$self->{block}->{($u>>8)}; } else { $fn=0; } if(scalar @blks==0 || $blks[-1]->[0]!=$fn) { push @blks,[$fn,pack('U',$u)]; } else { $blks[-1]->[1].=pack('U',$u); } } foreach my $blk (@blks) { $width+=$self->fontlist->[$blk->[0]]->width($blk->[1]); } } else { foreach my $u (unpack('U*',$text)) { if(defined $self->{code}->{$u}) { $width+=$self->fontlist->[$self->{code}->{$u}]->width(pack('U',$u)); } elsif(defined $self->{block}->{($u>>8)}) { $width+=$self->fontlist->[$self->{block}->{($u>>8)}]->width(pack('U',$u)); } else { $width+=$self->fontlist->[0]->width(pack('U',$u)); } } } return($width); } sub text { my ($self,$text,$size,$ident)=@_; $text=decode($self->{encode},$text) unless(is_utf8($text)); die 'textsize not specified' unless(defined $size); my $newtext=''; my $lastfont=-1; my @codes=(); foreach my $u (unpack('U*',$text)) { my $thisfont=0; if(defined $self->{code}->{$u}) { $thisfont=$self->{code}->{$u}; } elsif(defined $self->{block}->{($u>>8)}) { $thisfont=$self->{block}->{($u>>8)}; } if($thisfont!=$lastfont && $lastfont!=-1) { my $f=$self->fontlist->[$lastfont]; if(defined($ident) && $ident!=0) { $newtext.='/'.$f->name.' '.$size.' Tf ['.$ident.' '.$f->text(pack('U*',@codes)).'] TJ '; $ident=undef; } else { $newtext.='/'.$f->name.' '.$size.' Tf '.$f->text(pack('U*',@codes)).' Tj '; } @codes=(); } push(@codes,$u); $lastfont=$thisfont; } if(scalar @codes > 0) { my $f=$self->fontlist->[$lastfont]; $newtext.='/'.$f->name.' '.$size.' Tf '.$f->text(pack('U*',@codes),$size).' '; } return($newtext); } 1; __END__