File Coverage

blib/lib/PDF/Builder/Resource/UniFont.pm
Criterion Covered Total %
statement 79 99 79.8
branch 22 42 52.3
condition 6 12 50.0
subroutine 9 9 100.0
pod 1 5 20.0
total 117 167 70.0


line stmt bran cond sub pod time code
1             package PDF::Builder::Resource::UniFont;
2              
3 2     2   2065 use strict;
  2         5  
  2         68  
4 2     2   10 use warnings;
  2         6  
  2         122  
5              
6             our $VERSION = '3.023'; # VERSION
7             our $LAST_UPDATE = '3.016'; # manually update whenever code is changed
8              
9 2     2   13 use Carp;
  2         4  
  2         155  
10 2     2   16 use Encode qw(:all);
  2         5  
  2         2832  
11              
12             =head1 NAME
13              
14             PDF::Builder::Resource::UniFont - Unicode Font Support
15              
16             =head1 METHODS
17              
18             =over
19              
20             =item $font = PDF::Builder::Resource::UniFont->new($pdf, @fontspecs, %options)
21              
22             Returns a uni-font object.
23              
24             =cut
25              
26             =pod
27              
28             B fonts can be registered using the following hash-ref:
29              
30             {
31             font => $fontobj, # the font to be registered
32             blocks => $blockspec, # the unicode blocks the font is being registered for
33             codes => $codespec, # the unicode codepoints, -"-
34             }
35              
36             B
37              
38             [
39             $block1, $block3, # register font for block 1 + 3
40             [$blockA, $blockZ], # register font for blocks A .. Z
41             ]
42              
43             B
44              
45             [
46             $cp1, $cp3, # register font for codepoint 1 + 3
47             [$cpA, $cpZ], # register font for codepoints A .. Z
48             ]
49              
50             B if you want to register a font for the entire unicode space
51             (ie. U+0000 .. U+FFFF), then simply specify a font-object without the hash-ref.
52              
53             Valid %options are:
54              
55             '-encode' ... changes the encoding of the font from its default.
56             (see "perldoc Encode" for a list of valid tags)
57              
58             =cut
59              
60             sub new {
61 1     1 1 3 my $class = shift();
62 1 50       5 $class = ref($class) if ref($class);
63              
64 1         6 my $self = {
65             'fonts' => [],
66             'block' => {},
67             'code' => {},
68             'pdf' => shift(),
69             };
70 1         3 bless $self, $class;
71              
72 1         2 my @fonts;
73 1         7 push @fonts, shift() while ref($_[0]);
74              
75 1         4 my %options = @_;
76 1 50       10 $self->{'encode'} = $options{'-encode'} if defined $options{'-encode'};
77             # note that self->encode is undefined if -encode not given!
78              
79 1         2 my $font_number = 0;
80 1         2 foreach my $font (@fonts) {
81 2 100       8 if (ref($font) eq 'ARRAY') {
    50          
82 1         2 push @{$self->{'fonts'}}, shift(@$font);
  1         3  
83            
84 1         4 while (defined $font->[0]) {
85 1         3 my $blockspec = shift @$font;
86 1 50       4 if (ref($blockspec)) {
87 1         3 foreach my $block ($blockspec->[0] .. $blockspec->[-1]) {
88 1         4 $self->{'block'}->{$block} = $font_number;
89             }
90             } else {
91 0         0 $self->{'block'}->{$blockspec} = $font_number;
92             }
93             }
94             } elsif (ref($font) eq 'HASH') {
95 0         0 push @{$self->{'fonts'}}, $font->{'font'};
  0         0  
96              
97 0 0 0     0 if (defined $font->{'blocks'} and
98             ref($font->{'blocks'}) eq 'ARRAY') {
99 0         0 foreach my $blockspec (@{$font->{'blocks'}}) {
  0         0  
100 0 0       0 if (ref($blockspec)) {
101 0         0 foreach my $block($blockspec->[0] .. $blockspec->[-1]) {
102 0         0 $self->{'block'}->{$block} = $font_number;
103             }
104             } else {
105 0         0 $self->{'block'}->{$blockspec} = $font_number;
106             }
107             }
108             }
109              
110 0 0 0     0 if (defined $font->{'codes'} and
111             ref($font->{'codes'}) eq 'ARRAY') {
112 0         0 foreach my $codespec (@{$font->{'codes'}}) {
  0         0  
113 0 0       0 if (ref($codespec)) {
114 0         0 foreach my $code ($codespec->[0] .. $codespec->[-1]) {
115 0         0 $self->{'code'}->{$code} = $font_number;
116             }
117             } else {
118 0         0 $self->{'code'}->{$codespec} = $font_number;
119             }
120             }
121             }
122             } else {
123 1         3 push @{$self->{'fonts'}}, $font;
  1         2  
124 1         4 foreach my $block (0 .. 255) {
125 256         446 $self->{'block'}->{$block} = $font_number;
126             }
127             }
128 2         7 $font_number++;
129             }
130              
131 1         4 return $self;
132             }
133              
134             sub isvirtual {
135 2     2 0 10 return 1;
136             }
137              
138             sub fontlist {
139 11     11 0 20 my ($self) = @_;
140              
141 11         17 return [@{$self->{'fonts'}}];
  11         53  
142             }
143              
144             sub width {
145 4     4 0 11 my ($self, $text) = @_;
146              
147 4 50       12 if (defined $self->{'encode'}) { # is self->encode guaranteed set?
148 4 100       16 $text = decode($self->{'encode'}, $text) unless utf8::is_utf8($text);
149             }
150 4         283 my $width = 0;
151 4         9 my @blocks = ();
152              
153 4         20 foreach my $u (unpack('U*', $text)) {
154 18         31 my $font_number = 0;
155 18 50       49 if (defined $self->{'code'}->{$u}) {
    50          
156 0         0 $font_number = $self->{'code'}->{$u};
157             } elsif (defined $self->{'block'}->{($u >> 8)}) {
158 18         32 $font_number = $self->{'block'}->{($u >> 8)};
159             } else {
160 0         0 $font_number = 0;
161             }
162 18 100 100     55 if (scalar @blocks == 0 or $blocks[-1]->[0] != $font_number) {
163 6         25 push @blocks, [$font_number, pack('U', $u)];
164             } else {
165 12         27 $blocks[-1]->[1] .= pack('U', $u);
166             }
167             }
168 4         10 foreach my $block (@blocks) {
169 6         12 my ($font_number, $string) = @$block;
170 6         13 $width += $self->fontlist()->[$font_number]->width($string);
171             }
172              
173 4         16 return $width;
174             }
175              
176             sub text {
177 2     2 0 17 my ($self, $text, $size, $indent) = @_;
178              
179 2 50       8 if (defined $self->{'encode'}) { # is self->encode guaranteed to be defined?
180 2 100       9 $text = decode($self->{'encode'}, $text) unless utf8::is_utf8($text);
181             }
182 2 50       57 croak 'Font size not specified' unless defined $size;
183              
184 2         5 my $newtext = '';
185 2         3 my $last_font_number;
186             my @codes;
187              
188 2         8 foreach my $u (unpack('U*', $text)) {
189 9         12 my $font_number = 0;
190 9 50       31 if (defined $self->{'code'}->{$u}) {
    50          
191 0         0 $font_number = $self->{'code'}->{$u};
192             } elsif (defined $self->{'block'}->{($u >> 8)}) {
193 9         13 $font_number = $self->{'block'}->{($u >> 8)};
194             }
195              
196 9 100 100     32 if (defined $last_font_number and
197             $font_number != $last_font_number) {
198 1         4 my $font = $self->fontlist()->[$last_font_number];
199 1         5 $newtext .= '/' . $font->name() . ' ' . $size. ' Tf ';
200 1         6 $newtext .= $font->text(pack('U*', @codes), $size, $indent) . ' ';
201 1         3 $indent = undef;
202 1         3 @codes = ();
203             }
204              
205 9         21 push @codes, $u;
206 9         17 $last_font_number = $font_number;
207             }
208              
209 2 50       8 if (scalar @codes > 0) {
210 2         6 my $font = $self->fontlist()->[$last_font_number];
211 2         7 $newtext .= '/' . $font->name() . ' ' . $size . ' Tf ';
212 2         18 $newtext .= $font->text(pack('U*', @codes), $size, $indent);
213             }
214              
215 2         12 return $newtext;
216             }
217              
218             =back
219              
220             =cut
221              
222             1;