File Coverage

blib/lib/PDF/API2/Resource/Font/BdFont.pm
Criterion Covered Total %
statement 15 155 9.6
branch 0 22 0.0
condition 0 63 0.0
subroutine 5 7 71.4
pod 1 2 50.0
total 21 249 8.4


line stmt bran cond sub pod time code
1             package PDF::API2::Resource::Font::BdFont;
2              
3 1     1   1596 use base 'PDF::API2::Resource::Font';
  1         3  
  1         168  
4              
5 1     1   7 use strict;
  1         2  
  1         27  
6 1     1   6 use warnings;
  1         3  
  1         52  
7              
8             our $VERSION = '2.043'; # VERSION
9              
10 1     1   6 use PDF::API2::Util;
  1         2  
  1         154  
11 1     1   7 use PDF::API2::Basic::PDF::Utils;
  1         3  
  1         2404  
12              
13             our $BmpNum = 0;
14              
15             =head1 NAME
16              
17             PDF::API2::Resource::Font::BdFont - Module for using bitmapped Fonts.
18              
19             =head1 SYNOPSIS
20              
21             #
22             use PDF::API2;
23             #
24             $pdf = PDF::API2->new;
25             $sft = $pdf->bdfont($file);
26             #
27              
28             =head1 METHODS
29              
30             =over 4
31              
32             =cut
33              
34             =item $font = PDF::API2::Resource::Font::BdFont->new $pdf, $font, %options
35              
36             Returns a BmpFont object.
37              
38             =cut
39              
40             =pod
41              
42             Valid %options are:
43              
44             I<-encode>
45             ... changes the encoding of the font from its default.
46             See I for the supported values.
47              
48             I<-pdfname> ... changes the reference-name of the font from its default.
49             The reference-name is normally generated automatically and can be
50             retrieved via $pdfname=$font->name.
51              
52             =cut
53              
54             sub new {
55 0     0 1   my ($class, $pdf, $file, %opts) = @_;
56              
57 0 0         $class = ref($class) if ref($class);
58 0           my $name = sprintf('%s+Bdf%02i', pdfkey(), ++$BmpNum) . '~' . time();
59 0           my $self = $class->SUPER::new($pdf, $name);
60 0 0         $pdf->new_obj($self) unless $self->is_obj($pdf);
61              
62             # Adobe Bitmap Distribution Font
63 0           $self->{' data'} = $self->readBDF($file);
64              
65 0           my $first = 1;
66 0           my $last = 255;
67              
68 0           $self->{'Subtype'} = PDFName('Type3');
69 0           $self->{'FirstChar'} = PDFNum($first);
70 0           $self->{'LastChar'} = PDFNum($last);
71 0           $self->{'FontMatrix'} = PDFArray(map { PDFNum($_) } 0.001, 0, 0, 0.001, 0, 0);
  0            
72 0           $self->{'FontBBox'} = PDFArray(map { PDFNum($_) } $self->fontbbox());
  0            
73              
74 0           my $xo = PDFDict();
75 0           $self->{'Encoding'} = $xo;
76 0           $xo->{'Type'} = PDFName('Encoding');
77 0           $xo->{'BaseEncoding'} = PDFName('WinAnsiEncoding');
78             $xo->{'Differences'} = PDFArray(PDFNum('0'),
79 0   0       map { PDFName($_ or '.notdef') }
80 0           @{$self->data->{'char'}});
  0            
81              
82 0           my $procs = PDFDict();
83 0           $pdf->new_obj($procs);
84 0           $self->{'CharProcs'} = $procs;
85              
86 0           $self->{'Resources'} = PDFDict();
87 0           $self->{'Resources'}->{'ProcSet'} = PDFArray(map { PDFName($_) }
  0            
88             qw(PDF Text ImageB ImageC ImageI));
89 0           foreach my $w ($first .. $last) {
90 0           $self->data->{'uni'}->[$w] = uniByName($self->data->{'char'}->[$w]);
91 0           $self->data->{'u2e'}->{$self->data->{'uni'}->[$w]} = $w;
92             }
93 0           my @widths;
94 0           foreach my $w (@{$self->data->{'char2'}}) {
  0            
95 0           $widths[$w->{'ENCODING'}] = $self->data->{'wx'}->{$w->{'NAME'}};
96 0           my @bbx = @{$w->{'BBX'}};
  0            
97 0           my $stream = pack('H*', $w->{'hex'});
98 0           my $y = $bbx[1];
99 0           my $char = PDFDict();
100 0           $char->{'Filter'} = PDFArray(PDFName('FlateDecode'));
101             # $char->{' stream'} = $widths[$w->{'ENCODING'}] . ' 0 ' . join(' ', map { int($_) } $self->fontbbox()) . " d1\n";
102 0           $char->{' stream'} = $widths[$w->{'ENCODING'}] . " 0 d0\n";
103             $char->{'Comment'} = PDFStr(join(' ',
104             "N='" . $w->{'NAME'} . "'",
105 0           "C=(" . $w->{'ENCODING'} . ")"));
106 0           $procs->{$w->{'NAME'}} = $char;
107 0           @bbx = map { $_ * 1000 / $self->data->{'upm'} } @bbx;
  0            
108 0 0         if ($y == 0) {
109 0           $char->{' stream'} .= "q Q\n";
110             }
111             else {
112 0           my $x = 8 * length($stream) / $y; # q $x 0 0 $y 50 50 cm
113 0           my $dict = join('',
114             "/Interpolate true",
115             "/Mask[0 0.1]",
116             "/Decode[1 0]",
117             "/H $y",
118             "/W $x",
119             "/BPC 1",
120             "/CS /G");
121 0           my $img = qq|BI\n$dict\nID $stream\nEI\n|;
122 0           $procs->{$self->data->{'char'}->[$w]} = $char;
123 0           $char->{' stream'} .= "$bbx[0] 0 0 $bbx[1] $bbx[2] $bbx[3] cm\n";
124 0           $char->{' stream'} .= $img . "\n";
125             }
126 0           $pdf->new_obj($char);
127             }
128 0           $procs->{'.notdef'} = $procs->{$self->data->{'char'}->[32]};
129 0           delete $procs->{''};
130 0   0       $self->{'Widths'} = PDFArray(map { PDFNum($widths[$_] or 0) }
  0            
131             $first .. $last);
132 0           $self->data->{'e2n'} = $self->data->{'char'};
133 0           $self->data->{'e2u'} = $self->data->{'uni'};
134              
135 0           $self->data->{'u2c'} = {};
136 0           $self->data->{'u2e'} = {};
137 0           $self->data->{'u2n'} = {};
138 0           $self->data->{'n2c'} = {};
139 0           $self->data->{'n2e'} = {};
140 0           $self->data->{'n2u'} = {};
141              
142 0           my $data = $self->data();
143 0           foreach my $n (reverse 0 .. 255) {
144 0   0       $data->{'n2c'}->{$data->{'char'}->[$n] or '.notdef'} //= $n;
      0        
145 0   0       $data->{'n2e'}->{$data->{'e2n'}->[$n] or '.notdef'} //= $n;
      0        
146              
147 0   0       $data->{'n2u'}->{$data->{'e2n'}->[$n] or '.notdef'} //= $data->{'e2u'}->[$n];
      0        
148 0   0       $data->{'n2u'}->{$data->{'char'}->[$n] or '.notdef'} //= $data->{'uni'}->[$n];
      0        
149              
150 0   0       $data->{'u2c'}->{$data->{'uni'}->[$n]} //= $n;
151 0   0       $data->{'u2e'}->{$data->{'e2u'}->[$n]} //= $n;
152              
153 0   0       $data->{'u2n'}->{$data->{'e2u'}->[$n]} //= ($data->{'e2n'}->[$n] or '.notdef');
      0        
154 0   0       $data->{'u2n'}->{$data->{'uni'}->[$n]} //= ($data->{char}->[$n] or '.notdef');
      0        
155             }
156              
157 0           return $self;
158             }
159              
160             sub readBDF {
161 0     0 0   my ($self, $file) = @_;
162 0           my $data = {};
163 0           $data->{'char'} = [];
164 0           $data->{'char2'} = [];
165 0           $data->{'wx'} = {};
166              
167 0 0         die "file='$file' doesn't exist" unless -e $file;
168 0 0         open(my $afmf, '<', $file) or die "Can't find the BDF file for $file";
169              
170 0           local $/ = "\n"; # ensure correct $INPUT_RECORD_SEPARATOR
171 0           local $_ = undef;
172 0           while ($_ = <$afmf>) {
173 0           chomp($_);
174 0 0         if (/^STARTCHAR/ .. /^ENDCHAR/) {
175 0 0         if (/^STARTCHAR\s+(\S+)/) {
    0          
176 0           my $name = $1;
177 0           $name =~ s/^(\d+.*)$/X_$1/;
178 0           push @{$data->{'char2'}}, { 'NAME' => $name };
  0            
179             }
180             elsif (/^BITMAP/ .. /^ENDCHAR/) {
181 0 0         next if /^BITMAP/;
182 0 0         if (/^ENDCHAR/) {
183 0   0       $data->{'char2'}->[-1]->{'NAME'} ||= 'E_' . $data->{'char2'}->[-1]->{'ENCODING'};
184 0           $data->{'char'}->[$data->{'char2'}->[-1]->{'ENCODING'}] = $data->{'char2'}->[-1]->{'NAME'};
185 0           ($data->{'wx'}->{$data->{'char2'}->[-1]->{'NAME'}}) = split(/\s+/, $data->{'char2'}->[-1]->{'SWIDTH'});
186 0           $data->{'char2'}->[-1]->{'BBX'} = [split(/\s+/, $data->{'char2'}->[-1]->{'BBX'})];
187             }
188             else {
189 0           $data->{'char2'}->[-1]->{'hex'} .= $_;
190             }
191             }
192             else {
193 0           m/^(\S+)\s+(.+)$/;
194 0           $data->{'char2'}->[-1]->{uc($1)} .= $2;
195             }
196             # } elsif (/^STARTPROPERTIES/ .. /^ENDPROPERTIES/) {
197             }
198             else {
199 0           m/^(\S+)\s+(.+)$/;
200 0           $data->{uc($1)} .= $2;
201             }
202             }
203 0           close($afmf);
204 0 0         unless (exists $data->{'wx'}->{'.notdef'}) {
205 0           $data->{'wx'}->{'.notdef'} = 0;
206 0           $data->{'bbox'}{'.notdef'} = [0, 0, 0, 0];
207             }
208              
209 0           $data->{'fontname'} = pdfkey() . pdfkey() . '~' . time();
210 0           $data->{'apiname'} = $data->{'fontname'};
211 0           $data->{'flags'} = 34;
212 0           $data->{'fontbbox'} = [ split(/\s+/, $data->{'FONTBOUNDINGBOX'}) ];
213             $data->{'upm'} = ($data->{'PIXEL_SIZE'}
214 0   0       or ($data->{'fontbbox'}->[1] - $data->{'fontbbox'}->[3]));
215 0           @{$data->{'fontbbox'}} = (map { int($_ * 1000 / $data->{'upm'}) }
  0            
216 0           @{$data->{'fontbbox'}});
  0            
217              
218 0           foreach my $n (0 .. 255) {
219 0   0       $data->{'char'}->[$n] ||= '.notdef';
220             # $data->{'wx'}->{$data->{'char'}->[$n]}
221             # = int($data->{'wx'}->{$data->{'char'}->[$n]} * 1000 / $data->{'upm'});
222             }
223              
224 0   0       $data->{'uni'} ||= [];
225 0           foreach my $n (0 .. 255) {
226 0   0       $data->{'uni'}->[$n] = uniByName($data->{'char'}->[$n] or '.notdef') || 0;
227             }
228             $data->{'ascender'} = $data->{'RAW_ASCENT'}
229 0   0       || int($data->{'FONT_ASCENT'} * 1000 / $data->{'upm'});
230             $data->{'descender'} = $data->{'RAW_DESCENT'}
231 0   0       || int($data->{'FONT_DESCENT'} * 1000 / $data->{'upm'});
232              
233 0           $data->{'type'} = 'Type3';
234 0           $data->{'capheight'} = 1000;
235 0           $data->{'iscore'} = 0;
236 0           $data->{'issymbol'} = 0;
237 0           $data->{'isfixedpitch'} = 0;
238 0           $data->{'italicangle'} = 0;
239             $data->{'missingwidth'} = $data->{'AVERAGE_WIDTH'}
240             || int($data->{'FONT_AVERAGE_WIDTH'} * 1000 / $data->{'upm'})
241 0   0       || $data->{'RAW_AVERAGE_WIDTH'}
242             || 500;
243 0           $data->{'underlineposition'} = -200;
244 0           $data->{'underlinethickness'} = 10;
245             $data->{'xheight'} = $data->{'RAW_XHEIGHT'}
246             || int($data->{'FONT_XHEIGHT'} * 1000 / $data->{'upm'})
247 0   0       || int($data->{'ascender'} / 2);
248 0           $data->{'firstchar'} = 1;
249 0           $data->{'lastchar'} = 255;
250              
251 0           delete $data->{'wx'}->{''};
252              
253 0           return $data;
254             }
255              
256             =back
257              
258             =cut
259              
260             1;