File Coverage

blib/lib/PDF/API2/Resource/Font/Postscript.pm
Criterion Covered Total %
statement 21 254 8.2
branch 0 102 0.0
condition 0 34 0.0
subroutine 7 12 58.3
pod 1 5 20.0
total 29 407 7.1


line stmt bran cond sub pod time code
1             package PDF::API2::Resource::Font::Postscript;
2              
3 1     1   1654 use base 'PDF::API2::Resource::Font';
  1         2  
  1         112  
4              
5 1     1   8 use strict;
  1         2  
  1         29  
6 1     1   6 no warnings qw[ deprecated recursion uninitialized ];
  1         3  
  1         56  
7              
8             our $VERSION = '2.044'; # VERSION
9              
10 1     1   6 use Encode qw(:all);
  1         2  
  1         271  
11 1     1   17 use IO::File qw();
  1         2  
  1         17  
12              
13 1     1   5 use PDF::API2::Util;
  1         2  
  1         175  
14 1     1   8 use PDF::API2::Basic::PDF::Utils;
  1         2  
  1         3932  
15              
16             sub new {
17 0     0 1   my ($class, $pdf, $psfile, %opts) = @_;
18 0           my ($self,$encoding);
19 0           my (@w,$data);
20              
21 0 0         if(defined $opts{-afmfile}) {
    0          
    0          
22 0           $data = $class->readAFM($opts{-afmfile});
23             } elsif(defined $opts{-pfmfile}) {
24 0           $data = $class->readPFM($opts{-pfmfile});
25             } elsif(defined $opts{-xfmfile}) {
26 0           $data = $class->readXFM($opts{-xfmfile});
27             } else {
28 0           die "no proper font-metrics file specified for '$psfile'.";
29             }
30              
31 0 0         $class = ref $class if ref $class;
32 0           $self = $class->SUPER::new($pdf, $data->{apiname}.pdfkey().'~'.time());
33 0 0         $pdf->new_obj($self) unless($self->is_obj($pdf));
34 0           $self->{' data'}=$data;
35              
36 0 0         if($opts{-pdfname}) {
37 0           $self->name($opts{-pdfname});
38             }
39              
40 0           $self->{'Subtype'} = PDFName("Type1");
41 0           $self->{'FontDescriptor'}=$self->descrByData();
42 0 0         if(-f $psfile)
43             {
44 0           $self->{'BaseFont'} = PDFName(pdfkey().'+'.($self->fontname).'~'.time());
45              
46 0           my ($l1,$l2,$l3,$stream)=$self->readPFAPFB($psfile);
47              
48 0           my $s = PDFDict();
49 0           $self->{'FontDescriptor'}->{'FontFile'} = $s;
50 0           $s->{'Length1'} = PDFNum($l1);
51 0           $s->{'Length2'} = PDFNum($l2);
52 0           $s->{'Length3'} = PDFNum($l3);
53 0           $s->{'Filter'} = PDFArray(PDFName("FlateDecode"));
54 0           $s->{' stream'} = $stream;
55 0 0         if(defined $pdf) {
56 0           $pdf->new_obj($s);
57             }
58             }
59             else
60             {
61 0           $self->{'BaseFont'} = PDFName($self->fontname);
62             }
63              
64 0           $self->encodeByData($opts{-encode});
65              
66 0 0         $self->{-nocomps}=1 if($opts{-nocomps});
67 0 0         $self->{-dokern}=1 if($opts{-dokern});
68              
69 0           return($self);
70             }
71              
72             sub readPFAPFB {
73 0     0 0   my ($self,$file) = @_;
74 0           my ($l1,$l2,$l3,$stream,$t1stream,@lines,$line,$head,$body,$tail);
75              
76 0 0         die "cannot find font '$file' ..." unless(-f $file);
77              
78 0           my $l=-s $file;
79              
80 0 0         open(my $inf, "<", $file) or die "$!: $file";
81 0           binmode($inf,':raw');
82 0           read($inf,$line,2);
83 0           @lines=unpack('C*',$line);
84 0 0 0       if(($lines[0]==0x80) && ($lines[1]==1)) {
    0          
85 0           read($inf,$line,4);
86 0           $l1=unpack('V',$line);
87 0           seek($inf,$l1,1);
88 0           read($inf,$line,2);
89 0           @lines=unpack('C*',$line);
90 0 0 0       if(($lines[0]==0x80) && ($lines[1]==2)) {
91 0           read($inf,$line,4);
92 0           $l2=unpack('V',$line);
93             } else {
94 0           die "corrupt pfb in file '$file' at marker='2'.";
95             }
96 0           seek($inf,$l2,1);
97 0           read($inf,$line,2);
98 0           @lines=unpack('C*',$line);
99 0 0 0       if(($lines[0]==0x80) && ($lines[1]==1)) {
100 0           read($inf,$line,4);
101 0           $l3=unpack('V',$line);
102             } else {
103 0           die "corrupt pfb in file '$file' at marker='3'.";
104             }
105 0           seek($inf,0,0);
106 0           @lines=<$inf>;
107 0           $stream=join('',@lines);
108 0           $t1stream=substr($stream,6,$l1);
109 0           $t1stream.=substr($stream,12+$l1,$l2);
110 0           $t1stream.=substr($stream,18+$l1+$l2,$l3);
111             } elsif($line eq '%!') {
112 0           seek($inf,0,0);
113 0           while($line=<$inf>) {
114 0 0         if(!$l1) {
    0          
115 0           $head.=$line;
116 0 0         if($line=~/eexec$/){
117 0           chomp($head);
118 0           $head.="\x0d";
119 0           $l1=length($head);
120             }
121             } elsif(!$l2) {
122 0 0         if($line=~/^0+$/) {
123 0           $l2=length($body);
124 0           $tail=$line;
125             } else {
126 0           chomp($line);
127 0           $body.=pack('H*',$line);
128             }
129             } else {
130 0           $tail.=$line;
131             }
132             }
133 0           $l3=length($tail);
134 0           $t1stream="$head$body$tail";
135             } else {
136 0           die "unsupported font-format in file '$file' at marker='1'.";
137             }
138 0           close($inf);
139              
140 0           return($l1,$l2,$l3,$t1stream);
141             }
142              
143              
144             # $datahashref = $self->readAFM( $afmfile );
145              
146             sub readAFM
147             {
148 0     0 0   my ($self,$file)=@_;
149 0           my $data={};
150 0           $data->{wx}={};
151 0           $data->{bbox}={};
152 0           $data->{char}=[];
153 0           $data->{firstchar}=255;
154 0           $data->{lastchar}=0;
155              
156 0 0         if(! -e $file) {die "file='$file' not existant.";}
  0            
157 0 0         open(my $afmf, "<", $file) or die "Can't find the AFM file for $file";
158 0           local($/, $_) = ("\n", undef); # ensure correct $INPUT_RECORD_SEPARATOR
159 0           while ($_=<$afmf>)
160             {
161 0 0         if (/^StartCharMetrics/ .. /^EndCharMetrics/)
    0          
    0          
162             {
163             # only lines that start with "C" or "CH" are parsed
164 0 0         next unless $_=~/^CH?\s/;
165 0           my($ch) = $_=~/^CH?\s+(\d+)\s*;/;
166 0   0       $ch=$ch||0;
167 0           my($name) = $_=~/\bN\s+(\.?\w+)\s*;/;
168 0           my($wx) = $_=~/\bWX\s+(\d+)\s*;/;
169 0           my($bbox) = $_=~/\bB\s+([^;]+);/;
170 0           $bbox =~ s/\s+$//;
171             # Should also parse lingature data (format: L successor lignature)
172 0           $data->{avgwidth2} += $wx ;
173 0 0         $data->{maxwidth} = $data->{maxwidth}<$wx ? $wx : $data->{maxwidth};
174 0           $data->{wx}->{$name} = $wx ;
175 0           $data->{bbox}->{$name} = [split(/\s+/,$bbox)];
176 0 0         if($ch>0) {
177 0           $data->{'char'}->[$ch]=$name ;
178             }
179 0 0         $data->{lastchar} = $data->{lastchar}<$ch ? $ch : $data->{lastchar};
180 0 0         $data->{firstchar} = $data->{firstchar}>$ch ? $ch : $data->{firstchar};
181 0           next;
182             }
183             elsif(/^StartKernData/ .. /^EndKernData/)
184             {
185 0   0       $data->{kern}||={};
186 0 0         if($_=~m|^KPX\s+(\S+)\s+(\S+)\s+(\S+)\s*$|i)
187             {
188 0           $data->{kern}->{"$1:$2"}=$3;
189             }
190             }
191             elsif(/^StartComposites/ .. /^EndComposites/)
192             {
193 0   0       $data->{comps}||={};
194 0 0         if($_=~m|^CC\s+(\S+)\s+(\S+)\s+;|i)
195             {
196 0           my ($name,$comp)=($1,$2);
197 0           my @cv=split(/;/,$_);
198 0           shift @cv;
199 0           my $rng=[];
200 0           foreach (1..$comp)
201             {
202 0           my @c1=split(/\s+/,shift @cv);
203 0           push @{$rng},$c1[1],$c1[2],$c1[3];
  0            
204             }
205 0           $data->{comps}->{$name}=$rng;
206             }
207             }
208 0 0         last if $_=~/^EndFontMetrics/;
209 0 0         if (/(^\w+)\s+(.*)/)
210             {
211 0           my($key,$val) = ($1, $2);
212 0           $key = lc $key;
213 0 0         if (defined $data->{$key})
214             {
215             # $data->{$key} = [ $data->{$key} ] unless ref $data->{$key};
216             # push(@{$data->{$key}}, $val);
217             }
218             else
219             {
220 0           $val=~s/[\x00\x1f]+//g;
221 0           $data->{$key} = $val;
222             }
223             }
224             else
225             {
226             ## print STDERR "Can't parse: $_";
227             }
228             }
229 0           close($afmf);
230 0 0         unless (exists $data->{wx}->{'.notdef'})
231             {
232 0           $data->{wx}->{'.notdef'} = 0;
233 0           $data->{bbox}{'.notdef'} = [0, 0, 0, 0];
234             }
235              
236 0           $data->{avgwidth2} /= scalar keys %{$data->{bbox}} ;
  0            
237 0           $data->{avgwidth2} = int($data->{avgwidth2});
238              
239 0           $data->{fontname}=~s/[\x00-\x20]+//og;
240             ## $data->{fontname}=~s/[^A-Za-z0-9]+//og;
241              
242 0 0         if(defined $data->{fullname})
243             {
244 0           $data->{altname}=$data->{fullname};
245             }
246             else
247             {
248 0           $data->{altname}=$data->{familyname};
249 0 0         $data->{altname}.=' Italic' if($data->{italicangle}<0);
250 0 0         $data->{altname}.=' Oblique' if($data->{italicangle}>0);
251 0           $data->{altname}.=' '.$data->{weight};
252             }
253 0           $data->{apiname}=$data->{altname};
254 0           $data->{altname}=~s/[^A-Za-z0-9]+//og;
255              
256 0           $data->{subname}=$data->{weight};
257 0 0         $data->{subname}.=' Italic' if($data->{italicangle}<0);
258 0 0         $data->{subname}.=' Oblique' if($data->{italicangle}>0);
259 0           $data->{subname}=~s/[^A-Za-z0-9]+//og;
260              
261 0   0       $data->{missingwidth}||=$data->{avgwidth2};
262              
263 0           $data->{issymbol} = 0;
264 0           $data->{fontbbox} = [ split(/\s+/,$data->{fontbbox}) ];
265              
266 0           $data->{apiname}=join('', map { ucfirst(lc(substr($_, 0, 2))) } split m/[^A-Za-z0-9\s]+/, $data->{apiname});
  0            
267              
268 0           $data->{flags} = 34;
269              
270 0   0       $data->{uni}||=[];
271 0           foreach my $n (0..255)
272             {
273 0   0       $data->{uni}->[$n]=uniByName($data->{char}->[$n] || '.notdef') || 0;
274             }
275 0           delete $data->{bbox};
276              
277 0           return($data);
278             }
279              
280             sub readPFM {
281 0     0 0   my ($self,$file)=@_;
282 0 0         if(! -e $file) {die "pfmfile='$file' not existant.";}
  0            
283 0           my $fh=IO::File->new();
284 0           my $data={};
285              
286 0           $data->{issymbol} = 0;
287              
288 0           $data->{wx}={};
289 0           $data->{bbox}={};
290 0           $data->{kern}={};
291 0           $data->{char}=[];
292              
293 0           my $buf;
294 0 0         open($fh, "<", $file) || return;
295 0           binmode($fh,':raw');
296 0           read($fh,$buf,117 + 30);
297              
298 0           my %df;
299             # Packing structure for PFM Header
300             ( $df{Version},
301             $df{Size},
302             $df{Copyright},
303             $df{Type},
304             $df{Point},
305             $df{VertRes},
306             $df{HorizRes},
307             $df{Ascent},
308             $df{InternalLeading},
309             $df{ExternalLeading},
310             $df{Italic},
311             $df{Underline},
312             $df{StrikeOut},
313             $df{Weight},
314             #define FW_DONTCARE 0
315             #define FW_THIN 100
316             #define FW_EXTRALIGHT 200
317             #define FW_ULTRALIGHT FW_EXTRALIGHT
318             #define FW_LIGHT 300
319             #define FW_NORMAL 400
320             #define FW_REGULAR 400
321             #define FW_MEDIUM 500
322             #define FW_SEMIBOLD 600
323             #define FW_DEMIBOLD FW_SEMIBOLD
324             #define FW_BOLD 700
325             #define FW_EXTRABOLD 800
326             #define FW_ULTRABOLD FW_EXTRABOLD
327             #define FW_HEAVY 900
328             #define FW_BLACK FW_HEAVY
329             $df{CharSet},
330             #define ANSI_CHARSET 0
331             #define DEFAULT_CHARSET 1
332             #define SYMBOL_CHARSET 2
333             #define SHIFTJIS_CHARSET 128
334             #define HANGEUL_CHARSET 129
335             #define HANGUL_CHARSET 129
336             #define GB2312_CHARSET 134
337             #define CHINESEBIG5_CHARSET 136
338             #define GREEK_CHARSET 161
339             #define TURKISH_CHARSET 162
340             #define HEBREW_CHARSET 177
341             #define ARABIC_CHARSET 178
342             #define BALTIC_CHARSET 186
343             #define RUSSIAN_CHARSET 204
344             #define THAI_CHARSET 222
345             #define EASTEUROPE_CHARSET 238
346             #define OEM_CHARSET 255
347             #define JOHAB_CHARSET 130
348             #define VIETNAMESE_CHARSET 163
349             #define MAC_CHARSET 77
350             #define BALTIC_CHARSET 186
351             #define JOHAB_CHARSET 130
352             #define VIETNAMESE_CHARSET 163
353             $df{PixWidth},
354             $df{PixHeight},
355             $df{PitchAndFamily},
356             #define DEFAULT_PITCH 0
357             #define FIXED_PITCH 1
358             #define VARIABLE_PITCH 2
359             #define MONO_FONT 8
360             #define FF_DECORATIVE 80
361             #define FF_DONTCARE 0
362             #define FF_MODERN 48
363             #define FF_ROMAN 16
364             #define FF_SCRIPT 64
365             #define FF_SWISS 32
366             $df{AvgWidth},
367             $df{MaxWidth},
368             $df{FirstChar},
369             $df{LastChar},
370             $df{DefaultChar},
371             $df{BreakChar},
372             $df{WidthBytes},
373             $df{Device},
374             $df{Face},
375             $df{BitsPointer},
376             $df{BitsOffset},
377             $df{SizeFields}, # Two bytes, the size of extension section
378             $df{ExtMetricsOffset}, # Four bytes, offset value to the 'Extended Text Metrics' section
379             $df{ExtentTable}, # Four bytes Offset value to the Extent Table
380             $df{OriginTable}, # Four bytes 0
381             $df{PairKernTable}, # Four bytes 0
382             $df{TrackKernTable}, # Four bytes 0
383             $df{DriverInfo}, # Four bytes Offset value to the PostScript font name string
384             $df{Reserved}, # Four bytes 0
385 0           ) = unpack("vVa60vvvvvvvCCCvCvvCvvCCCCvVVVV vVVVVVVV",$buf); # PFM Header + Ext
386              
387 0           seek($fh,$df{Device},0);
388 0           read($fh,$buf,250);
389              
390 0           ($df{postScript}) = unpack("Z*",$buf);
391 0           $buf=substr($buf,length($df{postScript})+1,250);
392 0           ($df{windowsName}) = unpack("Z*",$buf);
393 0           $buf=substr($buf,length($df{windowsName})+1,250);
394 0           ($df{psName}) = unpack("Z*",$buf);
395              
396 0           seek($fh,$df{ExtMetricsOffset},0);
397 0           read($fh,$buf,52);
398              
399             ( $df{etmSize},
400             $df{PointSize},
401             $df{Orientation},
402             $df{MasterHeight},
403             $df{MinScale},
404             $df{MaxScale},
405             $df{MasterUnits},
406             $df{CapHeight},
407             $df{xHeight},
408             $df{LowerCaseAscent},
409             $df{LowerCaseDescent},
410             $df{Slant},
411             $df{SuperScript},
412             $df{SubScript},
413             $df{SuperScriptSize},
414             $df{SubScriptSize},
415             $df{UnderlineOffset},
416             $df{UnderlineWidth},
417             $df{DoubleUpperUnderlineOffset},
418             $df{DoubleLowerUnderlineOffset},
419             $df{DoubleUpperUnderlineWidth},
420             $df{DoubleLowerUnderlineWidth},
421             $df{StrikeOutOffset},
422             $df{StrikeOutWidth},
423             $df{KernPairs},
424 0           $df{KernTracks} ) = unpack('v*',$buf);
425              
426 0           $data->{fontname}=$df{psName};
427 0           $data->{fontname}=~s/[^A-Za-z0-9]+//og;
428 0           $data->{apiname}=join('', map { ucfirst(lc(substr($_, 0, 2))) } split m/[^A-Za-z0-9\s]+/, $df{windowsName});
  0            
429              
430 0           $data->{upem}=1000;
431              
432 0           $data->{fontbbox}=[-100,-100,$df{MaxWidth},$df{Ascent}];
433              
434 0           $data->{stemv}=0;
435 0           $data->{stemh}=0;
436              
437 0           $data->{lastchar}=$df{LastChar};
438 0           $data->{firstchar}=$df{FirstChar};
439              
440 0           $data->{missingwidth}=$df{AvgWidth};
441 0           $data->{maxwidth}=$df{MaxWidth};
442 0           $data->{ascender}=$df{Ascent};
443 0           $data->{descender}=-$df{LowerCaseDescent};
444              
445 0           $data->{flags} = 0;
446             # FixedPitch 1
447 0 0 0       $data->{flags} |= 1 if((($df{PitchAndFamily} & 1) || ($df{PitchAndFamily} & 8)) && !($df{PitchAndFamily} & 2));
      0        
448             # Serif 2
449 0 0 0       $data->{flags} |= 2 if(($df{PitchAndFamily} & 16) && !($df{PitchAndFamily} & 32));
450             # Symbolic 4
451 0 0         $data->{flags} |= 4 if($df{PitchAndFamily} & 80);
452             # Script 8
453 0 0         $data->{flags} |= 8 if($df{PitchAndFamily} & 64);
454             # Nonsymbolic 32
455 0 0         $data->{flags} |= 32 unless($df{PitchAndFamily} & 80);
456             # Italic 64
457 0 0         $data->{flags} |= 64 if($df{Italic});
458              
459             #bit 17 AllCap
460             #bit 18 SmallCap
461             #bit 19 ForceBold
462              
463 0           $data->{capheight}=$df{CapHeight};
464 0           $data->{xheight}=$df{xHeight};
465              
466 0           $data->{uni}=[ unpack('U*',decode('cp1252',pack('C*',(0..255)))) ];
467 0 0         $data->{char}=[ map { nameByUni($_) || '.notdef' } @{$data->{uni}} ];
  0            
  0            
468              
469 0           $data->{italicangle}=-12*$df{Italic};
470 0   0       $data->{isfixedpitch}=(($df{PitchAndFamily} & 8) || ($df{PitchAndFamily} & 1));
471 0           $data->{underlineposition}=-$df{UnderlineOffset};
472 0           $data->{underlinethickness}=$df{UnderlineWidth};
473              
474 0           seek($fh,$df{ExtentTable},0);
475              
476 0           foreach my $k ($df{FirstChar} .. $df{LastChar}) {
477 0           read($fh,$buf,2);
478 0           my ($wx)=unpack('v',$buf);
479 0           $data->{wx}->{$data->{char}->[$k]}=$wx;
480             # print STDERR "e: c=$k n='".$data->{char}->[$k]."' wx='$wx'\n";
481             }
482 0           $data->{pfm}=\%df;
483 0           close($fh);
484              
485 0           return($data);
486             }
487              
488             sub readXFM {
489 0     0 0   my ($class,$xfmfile) = @_;
490 0 0         die "cannot find font '$xfmfile' ..." unless(-f $xfmfile);
491              
492 0           my $data={};
493              
494 0           return($data);
495             }
496              
497             1;