File Coverage

blib/lib/PDF/Builder/Resource/CIDFont.pm
Criterion Covered Total %
statement 39 160 24.3
branch 3 70 4.2
condition 1 62 1.6
subroutine 8 30 26.6
pod 9 23 39.1
total 60 345 17.3


line stmt bran cond sub pod time code
1             package PDF::Builder::Resource::CIDFont;
2              
3 2     2   1071 use base 'PDF::Builder::Resource::BaseFont';
  2         4  
  2         665  
4              
5 2     2   16 use strict;
  2         5  
  2         51  
6 2     2   11 use warnings;
  2         7  
  2         131  
7             #no warnings qw[ deprecated recursion uninitialized ];
8              
9             our $VERSION = '3.023'; # VERSION
10             our $LAST_UPDATE = '3.021'; # manually update whenever code is changed
11              
12 2     2   13 use Encode qw(:all);
  2         5  
  2         824  
13              
14 2     2   17 use PDF::Builder::Basic::PDF::Utils;
  2         4  
  2         204  
15 2     2   15 use PDF::Builder::Util;
  2         4  
  2         5051  
16              
17             =head1 NAME
18              
19             PDF::Builder::Resource::CIDFont - Base class for CID fonts
20              
21             =head1 METHODS
22              
23             =over
24              
25             =item $font = PDF::Builder::Resource::CIDFont->new($pdf, $name)
26              
27             Returns a cid-font object, base class for all CID-based fonts.
28              
29             =cut
30              
31             sub new {
32 1     1 1 6 my ($class, $pdf, $name, @opts) = @_;
33              
34 1         4 my %opts = ();
35 1 50       8 %opts = @opts if (scalar @opts)%2 == 0;
36              
37 1 50       4 $class = ref $class if ref $class;
38 1         13 my $self = $class->SUPER::new($pdf, $name);
39 1 50 33     9 $pdf->new_obj($self) if defined($pdf) && !$self->is_obj($pdf);
40              
41 1         4 $self->{'Type'} = PDFName('Font');
42 1         5 $self->{'Subtype'} = PDFName('Type0');
43 1         4 $self->{'Encoding'} = PDFName('Identity-H');
44              
45 1         5 my $de = PDFDict();
46 1         8 $pdf->new_obj($de);
47 1         5 $self->{'DescendantFonts'} = PDFArray($de);
48              
49 1         4 $de->{'Type'} = PDFName('Font');
50 1         3 $de->{'CIDSystemInfo'} = PDFDict();
51 1         5 $de->{'CIDSystemInfo'}->{'Registry'} = PDFString('Adobe', 'x');
52 1         4 $de->{'CIDSystemInfo'}->{'Ordering'} = PDFString('Identity', 'x');
53 1         5 $de->{'CIDSystemInfo'}->{'Supplement'} = PDFNum(0);
54 1         5 $de->{'CIDToGIDMap'} = PDFName('Identity');
55              
56 1         4 $self->{' de'} = $de;
57              
58 1         5 return $self;
59             }
60              
61             sub glyphByCId {
62 0     0 0 0 return $_[0]->data()->{'g2n'}->[$_[1]];
63             }
64              
65             sub uniByCId {
66 0     0 0 0 my ($self, $gid) = @_;
67 0         0 my $uni = $self->data()->{'g2u'}->[$gid];
68             # fallback to U+0000 if no match
69 0 0       0 $uni = 0 unless defined $uni;
70 0         0 return $uni;
71             }
72              
73             # note that cidByUni has been seen returning 'undef' in some cases. be sure
74             # to handle this!
75             sub cidByUni {
76 53     53 0 105 return $_[0]->data()->{'u2g'}->{$_[1]};
77             }
78              
79             sub cidByEnc {
80 0     0 0   return $_[0]->data()->{'e2g'}->[$_[1]];
81             }
82              
83             sub wxByCId {
84 0     0 0   my $self = shift;
85 0           my $g = shift;
86              
87 0           my $w;
88              
89 0 0 0       if (ref($self->data()->{'wx'}) eq 'ARRAY' &&
    0 0        
90             defined $self->data()->{'wx'}->[$g]) {
91 0           $w = int($self->data()->{'wx'}->[$g]);
92             } elsif (ref($self->data()->{'wx'}) eq 'HASH' &&
93             defined $self->data()->{'wx'}->{$g}) {
94 0           $w = int($self->data()->{'wx'}->{$g});
95             } else {
96 0           $w = $self->missingwidth();
97             }
98              
99 0           return $w;
100             }
101              
102             sub wxByUni {
103 0     0 1   return $_[0]->wxByCId($_[0]->data()->{'u2g'}->{$_[1]});
104             }
105              
106             sub wxByEnc {
107 0     0 1   return $_[0]->wxByCId($_[0]->data()->{'e2g'}->[$_[1]]);
108             }
109              
110             sub width {
111 0     0 1   my ($self, $text) = @_;
112              
113 0           return $self->width_cid($self->cidsByStr($text));
114             }
115              
116             sub width_cid {
117 0     0 0   my ($self, $text) = @_;
118              
119 0           my $width = 0;
120 0           my $lastglyph = 0;
121 0           foreach my $n (unpack('n*', $text)) {
122 0           $width += $self->wxByCId($n);
123 0 0 0       if ($self->{'-dokern'} && $self->haveKernPairs()) {
124 0 0         if ($self->kernPairCid($lastglyph, $n)) {
125 0           $width -= $self->kernPairCid($lastglyph, $n);
126             }
127             }
128 0           $lastglyph = $n;
129             }
130 0           $width /= 1000;
131 0           return $width;
132             }
133              
134             =item $cidstring = $font->cidsByStr($string)
135              
136             Returns the cid-string from string based on the font's encoding map.
137              
138             =cut
139              
140             sub _cidsByStr {
141 0     0     my ($self, $s) = @_;
142              
143 0           $s = pack('n*', map { $self->cidByEnc($_) } unpack('C*', $s));
  0            
144 0           return $s;
145             }
146              
147             sub cidsByStr {
148 0     0 1   my ($self, $text) = @_;
149              
150 0 0 0       if (utf8::is_utf8($text) &&
    0 0        
    0 0        
    0 0        
      0        
      0        
      0        
      0        
151             defined $self->data()->{'decode'} &&
152             $self->data()->{'decode'} ne 'ident') {
153 0           $text = encode($self->data()->{'decode'}, $text);
154             } elsif (utf8::is_utf8($text) && $self->data()->{'decode'} eq 'ident') {
155 0           $text = $self->cidsByUtf($text);
156             } elsif (!utf8::is_utf8($text) &&
157             defined $self->data()->{'encode'} &&
158             $self->data()->{'decode'} eq 'ident') {
159 0           $text = $self->cidsByUtf(decode($self->data()->{'encode'}, $text));
160             } elsif (!utf8::is_utf8($text) &&
161             $self->can('issymbol') &&
162             $self->issymbol() &&
163             $self->data()->{'decode'} eq 'ident') {
164 0           $text = pack('U*', (map { $_+0xf000 } unpack('C*', $text)));
  0            
165 0           $text = $self->cidsByUtf($text);
166             } else {
167 0           $text = $self->_cidsByStr($text);
168             }
169 0           return $text;
170             }
171              
172             =item $cidstring = $font->cidsByUtf($utf8string)
173              
174             Returns the CID-encoded string from utf8-string.
175              
176             =cut
177              
178             sub cidsByUtf {
179 0     0 1   my ($self, $s) = @_;
180              
181 0 0 0       $s = pack('n*', map { $self->cidByUni($_)||0 } (map { $_>0x7f && $_<0xA0? uniByName(nameByUni($_)): $_ } unpack('U*', $s)));
  0 0          
  0            
182 0           utf8::downgrade($s);
183 0           return $s;
184             }
185              
186             sub textByStr {
187 0     0 1   my ($self, $text) = @_;
188              
189 0           return $self->text_cid($self->cidsByStr($text));
190             }
191              
192             sub textByStrKern {
193 0     0 1   my ($self, $text, $size, $indent) = @_;
194              
195 0           return $self->text_cid_kern($self->cidsByStr($text), $size, $indent);
196             }
197              
198             sub text {
199 0     0 0   my ($self, $text, $size, $indent) = @_;
200              
201 0           my $newtext = $self->textByStr($text);
202 0 0 0       if (defined $size && $self->{'-dokern'}) {
    0          
203 0           $newtext = $self->textByStrKern($text, $size, $indent);
204 0           return $newtext;
205             } elsif (defined $size) {
206 0 0 0       if (defined($indent) && $indent!=0) {
207 0           return("[ $indent $newtext ] TJ");
208             } else {
209 0           return "$newtext Tj";
210             }
211             } else {
212 0           return $newtext;
213             }
214             }
215              
216             sub text_cid {
217 0     0 0   my ($self, $text, $size) = @_;
218              
219 0 0         if ($self->can('fontfile')) {
220 0           foreach my $g (unpack('n*', $text)) {
221 0           $self->fontfile()->subsetByCId($g);
222             }
223             }
224 0           my $newtext = unpack('H*', $text);
225 0 0         if (defined $size) {
226 0           return "<$newtext> Tj";
227             } else {
228 0           return "<$newtext>";
229             }
230             }
231              
232             sub text_cid_kern {
233 0     0 0   my ($self, $text, $size, $indent) = @_;
234              
235 0 0         if ($self->can('fontfile')) {
236 0           foreach my $g (unpack('n*', $text)) {
237 0           $self->fontfile()->subsetByCId($g);
238             }
239             }
240 0 0 0       if (defined $size && $self->{'-dokern'} && $self->haveKernPairs()) {
    0 0        
241 0           my $newtext = ' ';
242 0           my $lastglyph = 0;
243 0           my $tBefore = 0;
244 0           foreach my $n (unpack('n*', $text)) {
245 0 0         if ($self->kernPairCid($lastglyph, $n)) {
246 0 0         $newtext .= '> ' if $tBefore;
247 0           $newtext .= sprintf('%i ', $self->kernPairCid($lastglyph, $n));
248 0           $tBefore = 0;
249             }
250 0           $lastglyph = $n;
251 0           my $t = sprintf('%04X', $n);
252 0 0         $newtext .= '<' if !$tBefore;
253 0           $newtext .= $t;
254 0           $tBefore = 1;
255             }
256 0 0         $newtext .= '> ' if $tBefore;
257 0 0 0       if (defined($indent) && $indent != 0) {
258 0           return "[ $indent $newtext ] TJ";
259             } else {
260 0           return "[ $newtext ] TJ";
261             }
262             } elsif (defined $size) {
263 0           my $newtext = unpack('H*', $text);
264 0 0 0       if (defined($indent) && $indent != 0) {
265 0           return "[ $indent <$newtext> ] TJ";
266             } else {
267 0           return "<$newtext> Tj";
268             }
269             } else {
270 0           my $newtext = unpack('H*', $text);
271 0           return "<$newtext>";
272             }
273             }
274              
275             sub kernPairCid {
276 0     0 0   return 0;
277             }
278              
279             sub haveKernPairs {
280 0     0 0   return 0;
281             }
282              
283             sub encodeByName {
284 0     0 0   my ($self, $enc) = @_;
285              
286 0 0         return if $self->issymbol();
287              
288 0 0 0       $self->data()->{'e2u'} = [ map { $_>0x7f && $_<0xA0? uniByName(nameByUni($_)): $_ } unpack('U*', decode($enc, pack('C*', 0..255))) ] if defined $enc;
  0 0          
289 0 0 0       $self->data()->{'e2n'} = [ map { $self->data()->{'g2n'}->[$self->data()->{'u2g'}->{$_} || 0] || '.notdef' } @{$self->data()->{'e2u'}} ];
  0            
  0            
290 0 0         $self->data()->{'e2g'} = [ map { $self->data()->{'u2g'}->{$_} || 0 } @{$self->data()->{'e2u'}} ];
  0            
  0            
291              
292 0           $self->data()->{'u2e'} = {};
293 0           foreach my $n (reverse 0..255) {
294             $self->data()->{'u2e'}->{$self->data()->{'e2u'}->[$n]} = $n
295 0 0         unless defined $self->data()->{'u2e'}->{$self->data()->{'e2u'}->[$n]};
296             }
297              
298 0           return $self;
299             }
300              
301             sub subsetByCId {
302 0     0 0   return 1;
303             }
304              
305             sub subvec {
306 0     0 0   return 1;
307             }
308              
309             sub glyphNum {
310 0     0 1   my $self = shift;
311              
312 0 0         if (defined $self->data()->{'glyphs'}) {
313 0           return $self->data()->{'glyphs'};
314             }
315 0           return scalar @{$self->data()->{'wx'}};
  0            
316             }
317              
318             #sub outobjdeep {
319             # my ($self, $fh, $pdf, %opts) = @_;
320             #
321             # return $self->SUPER::outobjdeep($fh, $pdf, %opts);
322             #}
323              
324             =back
325              
326             =cut
327              
328             1;