1 #!/usr/local/bin/perl -w
3 require 5.005;
4 use strict;
6 # The glyps list can be downloaded from
7 # http://partners.adobe.com/asn/developer/type/glyphlist.txt
8 # This URL is from this page:
9 # http://partners.adobe.com/asn/developer/type/unicodegn.html
10 # which is refered from
11 # http://partners.adobe.com/asn/developer/technotes/fonts.html
13 my $onlyHelvetica = 0;
15 my %globalName2Unicode;
16 my %font_code = ();
18 my $indent0 = "";
19 my $indent1 = " ";
20 my $indent2 = $indent1 x 3;
22 my $q = 0;
23 my $qU = 0;
25 sub read_glyphlist
26 {
27 my $fn ="glyphlist.txt";
28 open(FH, $fn)
29 || die "Can't read $fn\n";
30 my %seen = ();
31 while (<FH>) {
32 next if /^\s*#/;
33 next unless /^([0-9A-F]{4});(\w+);/;
34 my $unicode = 0 + hex($1);
35 my $name = $2;
36 next if ($globalName2Unicode{$name});
37 $globalName2Unicode{$name} = $unicode;
38 }
39 close(FH);
40 }
42 sub process_all_fonts
43 {
44 my $dir = ".";
45 my $wc = "*.afm";
46 $wc = "Helvetica.afm" if $onlyHelvetica;
47 $wc = "ZapfDin.afm" if 0;
48 $wc = "Helve*.afm" if 0;
49 $wc = "Times-BoldItalic.afm" if 0;
50 foreach my $fn (glob("$dir/$wc")) {
51 process_font($fn);
52 }
53 }
55 sub process_font
56 {
57 my ($fn) = @_;
58 print STDERR "Compiling afm file: $fn\n";
59 my %fi = (); # font info
60 my $c = "";
61 $fi{C} = \$c;
62 $fi{ligaturesR} = {};
63 $fi{FontSpecificUnicodeNameToChar} = {};
64 $fi{filename} = $fn;
65 $fi{filename} =~ s/.*\///;
66 open(FH, $fn) || die "Can't open $fn\n";
67 print STDERR "Reads global font info\n" if $q;
68 while (<FH>) {
69 chomp;
70 next if /^\s*$/ || /^\s*#/;
71 last if /^StartCharMetrics/;
72 next unless (/^(\S+)\s+(\S(.*\S)?)/);
73 my $id = $1;
74 my $value = $2;
75 $value =~ s/\s+/ /g;
76 $fi{"Afm$id"} = $value;
77 }
78 my $fontName = $fi{AfmFontName};
79 $c .= "\n\n/* ". ("-" x 66) . "*/\n";
80 $c .= "/* FontName: $fontName */\n";
81 $c .= "/* FullName: $fi{AfmFullName} */\n";
82 $c .= "/* FamilyName: $fi{AfmFamilyName} */\n";
83 $fi{cName} = $fontName;
84 $fi{cName} =~ s/\W/_/g;
85 my %charMetrics = ();
86 my %kerning = ();
87 read_charmetrics(\%fi, \%charMetrics);
88 while (<FH>) {
89 read_kerning(\%fi, \%kerning) if /^StartKernPairs/;
90 }
91 if (0) {
92 my @names = keys %charMetrics;
93 print STDERR "Did read ", ($#names + 1), " font metrics\n";
94 }
95 write_font(\%fi, \%charMetrics, \%kerning);
96 }
98 sub read_charmetrics
99 {
100 my ($fiR, $charMetricsR) = @_;
101 print STDERR "Reads char metric info\n" if $q;
102 my $isZapfDingbats = $$fiR{AfmFontName} eq "ZapfDingbats";
103 my $ligaturesR = $$fiR{ligaturesR};
104 my %ligatures = ();
105 my %seenUnicodes = ();
106 while (<FH>) {
107 chomp;
108 next if /^\s*$/ || /^\s*#/;
109 last if /^EndCharMetrics/;
110 #next unless /N S / || /N comma /;
111 #next unless /N ([sfil]|fi) /;
112 #print "$_\n";
113 my $line = $_;
114 # C 102 ; WX 333 ; N f ; B -169 -205 446 698 ; L i fi ; L l fl ;
115 my ($width, $unicode, $name, @charLigatures);
116 foreach (split/\s*;\s*/, $line) {
117 if (/^C\s+(-?\d+)/) {
118 $unicode = 0 + $1;
119 } elsif (/^N\s+(\w+)/) {
120 $name = $1;
121 } elsif (/^WX?\s+(-?\d+)/) {
122 $width = normalize_width($1, 0);
123 } elsif (/^L\s+(\w+)\s+(\w+)/) {
124 push(@charLigatures, $1, $2);
125 }
126 }
127 if ($unicode < 0) {
128 unless (defined $name) {
129 print STDERR "Glyph missing name and code: $_\n";
130 next;
131 }
132 $unicode = name2uni($fiR, $name);
133 print STDERR "name2uni: $name -> $unicode\n" if $qU && 0;
134 } elsif (defined $name) {
135 my $std = $globalName2Unicode{$name};
136 if (!defined $std) {
137 print STDERR "Adds unicode mapping: ",
138 "$name -> $unicode\n" if $qU;
139 ${$$fiR{FontSpecificUnicodeNameToChar}}{$name} = $unicode;
140 } else {
141 $unicode = $std;
142 }
143 }
144 if (!defined($unicode) || $unicode <= 0) {
145 next if $isZapfDingbats && $name =~ /^a(\d+)$/;
146 next if $$fiR{AfmFontName} eq "Symbol" && $name eq "apple";
147 print STDERR "Glyph '$name' has unknown unicode: $_\n";
148 next;
149 }
150 unless (defined $width) {
151 print STDERR "Glyph '$name' missing width: $_\n";
152 next;
153 }
154 if ($seenUnicodes{$unicode}) {
155 print STDERR "Duplicate character: unicode = $unicode, ",
156 "$name and ", $seenUnicodes{$unicode},
157 " (might be due to Adobe charset remapping)\n";
158 next;
159 }
160 $seenUnicodes{$unicode} = $name;
161 my %c = ();
162 $c{name} = $name;
163 $c{unicode} = $unicode;
164 $c{width} = $width;
165 $$charMetricsR{$unicode} = \%c;
166 $ligatures{$unicode} = \@charLigatures if $#charLigatures >= 0;
167 }
168 foreach my $unicode (keys %ligatures) {
169 my $aR = $ligatures{$unicode};
170 my $unicode2 = name2uni($fiR, $$aR[0]);
171 my $unicode3 = name2uni($fiR, $$aR[1]);
172 unless ($unicode2) {
173 print STDERR "Missing ligature char 1: $$aR[0]\n";
174 next;
175 }
176 unless ($unicode3) {
177 print STDERR "Missing ligature char 2: $$aR[1]\n";
178 next;
179 }
180 my $key = sprintf("%04d;%04d", $unicode, $unicode2);
181 $$ligaturesR{$key} = $unicode3;
182 }
183 }
185 sub name2uni
186 {
187 my ($fiR, $name) = @_;
188 my $fontMapR = $$fiR{FontSpecificUnicodeNameToChar};
189 return $globalName2Unicode{$name} || $$fontMapR{$name};
190 }
192 sub read_kerning
193 {
194 my ($fiR, $kerningR) = @_;
195 print STDERR "Reads kerning info\n" if $q;
196 while (<FH>) {
197 chomp;
198 next if /^\s*$/ || /^\s*#/;
199 last if /^EndKernPairs/;
200 unless (/^KPX\s+(\w+)\s+(\w+)\s+(-?\d+)\s*$/) {
201 print STDERR "Can't parse kern spec: $_\n";
202 next;
203 }
204 my $name1 = $1;
205 my $name2 = $2;
206 my $delta = normalize_width($3, 1);
207 next unless $delta;
208 my $unicode1 = name2uni($fiR, $name1);
209 my $unicode2 = name2uni($fiR, $name2);
210 unless ($unicode1 && $unicode2) {
211 print "Unknown kern pair: $name1 and $name2\n";
212 next;
213 }
214 my $charR = $$kerningR{$unicode1};
215 unless (defined $charR) {
216 my %c = ();
217 $charR = \%c;
218 $$kerningR{$unicode1} = $charR;
219 }
220 $$charR{$unicode2} = $delta;
221 }
222 }
224 sub write_font
225 {
226 my ($fiR, $charMetricsR, $kerningR) = @_;
227 print STDERR "Writes font\n" if $q;
228 my $cR = $$fiR{C};
229 $$fiR{widthsA} = make_array();
230 $$fiR{kerning_indexA} = make_array();
231 $$fiR{kerning_dataA} = make_array();
232 $$fiR{highchars_indexA} = make_array();
233 $$fiR{ligaturesA} = make_array();
234 write_font_metrics($fiR, $charMetricsR, $kerningR);
235 write_ligatures($fiR);
236 my $widths_count = array_size($$fiR{widthsA});
237 my $kerning_index_count = array_size($$fiR{kerning_indexA});
238 my $kerning_data_count = array_size($$fiR{kerning_dataA});
239 my $highchars_count = array_size($$fiR{highchars_indexA});
240 my $ligatures_count = array_size($$fiR{ligaturesA}) / 3;
241 my $info_code = "";
242 my $i2 = $indent2;
243 my $packedSize = $widths_count + 2 * $kerning_index_count +
244 $kerning_data_count + 2 * $highchars_count +
245 3 * 2 * $ligatures_count;
246 $info_code .= $indent1 . "{ /* $$fiR{filename} $packedSize bytes */\n";
247 $info_code .= $i2 . "\"$$fiR{AfmFontName}\",";
248 $info_code .= " \"$$fiR{AfmFullName}\",\n";
249 $info_code .= $i2 . $$fiR{widthsACName} . ",\n";
250 $info_code .= $i2 . $$fiR{kerning_indexACName} . ",\n";
251 $info_code .= $i2 . $$fiR{kerning_dataACName} . ",\n";
252 $info_code .= $i2 . $$fiR{highchars_indexACName} . ", ";
253 $info_code .= $highchars_count . ",\n";
254 $info_code .= $i2 . $$fiR{ligaturesACName} . ", ";
255 $info_code .= $ligatures_count;
256 $info_code .= "},\n";
257 $font_code{$$fiR{AfmFullName}} = { TABLES => $$cR, INFO => $info_code};
258 }
260 sub write_font_metrics
261 {
262 my ($fiR, $charMetricsR, $kerningR) = @_;
263 print STDERR "Writes font metrics\n" if $q;
264 my $lastUnicode = 31;
265 my $cR = $$fiR{C};
266 my $widthsA = $$fiR{widthsA};
267 my $kerning_indexA = $$fiR{kerning_indexA};
268 my $kerning_dataA = $$fiR{kerning_dataA};
269 my $highchars_indexA = $$fiR{highchars_indexA};
270 my @uniArray = sort { $a <=> $b } keys %$charMetricsR;
271 my $highchars_count = 0;
272 my $had_kerning = 0;
273 while (1) {
274 my $fill = 0;
275 if ($#uniArray < 0) {
276 last if $lastUnicode > 126;
277 $fill = 1;
278 } elsif ($lastUnicode < 126 && $uniArray[0] > $lastUnicode + 1) {
279 $fill = 1;
280 }
281 if ($fill) {
282 $lastUnicode++;
283 #print STDERR "fill for $lastUnicode, $#uniArray, $uniArray[0]\n";
284 append_to_array($widthsA, 0);
285 append_to_array($kerning_indexA, 0);
286 next;
287 }
288 my $unicode = shift @uniArray;
289 next if $unicode < 32;
290 $lastUnicode = $unicode;
291 my $metricsR = $$charMetricsR{$unicode};
292 if ($unicode > 126) {
293 append_to_array($highchars_indexA, $unicode);
294 $highchars_count++;
295 }
296 my $m = $$metricsR{width};
297 $m = "/* ".array_size($widthsA)."=$unicode */". $m if 0;
298 append_to_array($widthsA, $m);
299 my $kerningInfoR = $$kerningR{$unicode};
300 my $kerning_index = 0;
301 if (defined $kerningInfoR) {
302 my @kerns = ();
303 foreach my $unicode2 (sort { $a <=> $b } keys %$kerningInfoR) {
304 my $delta = $$kerningInfoR{$unicode2};
305 append_escaped_16bit_int(\@kerns, $unicode2);
306 push(@kerns, $delta);
307 $had_kerning = 1;
308 }
309 $kerning_index = append_8bit_subarray($kerning_dataA, 2, @kerns);
310 }
311 append_to_array($kerning_indexA, $kerning_index);
312 }
313 $$fiR{kerning_indexA} = make_array() if !$had_kerning;
314 write_array($fiR, "widths", "afm_cuint8");
315 write_array($fiR, "kerning_index", "afm_sint16");
316 write_array($fiR, "kerning_data", "afm_cuint8");
317 write_array($fiR, "highchars_index", "afm_cuint16");
318 }
320 sub write_ligatures
321 {
322 my ($fiR) = @_;
323 print STDERR "Writes font ligatures\n" if $q;
324 my $ligaturesA = $$fiR{ligaturesA};
325 my $ligaturesR = $$fiR{ligaturesR};
326 foreach (sort keys %$ligaturesR) {
327 unless (/^(\w{4});(\w{4})$/) {
328 die "Invalid ligature key: $_";
329 }
330 append_to_array($ligaturesA, $1 + 0, $2 + 0, $$ligaturesR{$_});
331 }
332 write_array($fiR, "ligatures", "afm_cunicode");
333 }
335 sub indent
336 {
337 my ($num) = @_;
338 return " " x $num;
339 }
341 sub make_array
342 {
343 my @a = ();
344 return \@a;
345 }
347 sub append_to_array
348 {
349 my ($aR, @newElements) = @_;
350 my $z1 = array_size($aR);
351 push(@$aR, @newElements);
352 my $z2 = array_size($aR);
353 my $zz = $#newElements +1;
354 }
356 sub append_8bit_subarray
357 {
358 my ($aR, $elementsPerItem, @newElements) = @_;
359 push(@$aR, 42) if !array_size($aR); # initial dummy value
360 my $idx = $#{$aR} + 1;
361 #print "append_8bit_subarray ", ($#newElements+1), " = (", join(", ", @newElements), ") -> $idx\n";
362 append_escaped_16bit_int($aR, ($#newElements + 1) / $elementsPerItem);
363 push(@$aR, @newElements);
364 die "Can't handle that big sub array, sorry...\n" if $idx > 50000;
365 return $idx;
366 }
368 sub append_escaped_16bit_int
369 {
370 my ($aR, $count) = @_;
371 die "Invalid count = 0\n" unless $count;
372 if ($count >= 510) {
373 push(@$aR, 1, int($count / 256), int($count % 256));
374 print STDERR "full: $count\n" if 0;
375 } elsif ($count >= 254) {
376 push(@$aR, 0, $count - 254);
377 print STDERR "semi: $count\n" if 0;
378 } else {
379 push(@$aR, $count + 1);
380 }
381 }
383 sub array_size
384 {
385 my ($aR) = @_;
386 return $#{$aR} + 1;
387 }
389 sub write_array
390 {
391 my ($fiR, $name, $type) = @_;
392 my $aR = $$fiR{$name."A"};
393 my $cName = $$fiR{cName};
394 my $num = $#{$aR} + 1;
395 my $array_name_key = $name."ACName";
396 if ($num == 0) {
397 $$fiR{$array_name_key} = "NULL";
398 return;
399 }
400 my $cR = $$fiR{C};
401 my $array_name = "afm_" . $cName . "_" . $name;
402 $$fiR{$array_name_key} = $array_name;
403 $$cR .= "static $type $array_name" . "[] = { /* $num */\n";
404 my $line = $indent1;
405 for (my $i = 0; $i < $num; $i++) {
406 $line .= "," if $i > 0;
407 if (length($line) > 65) {
408 $line .= "\n";
409 $$cR .= $line;
410 $line = $indent1;
411 }
412 $line .= $$aR[$i];
413 }
414 $line .= "\n";
415 $$cR .= $line;
416 $$cR .= "};\n";
417 }
419 sub normalize_width
420 {
421 my ($w, $signed) = @_;
422 my $n = int(($w + 3) / 6);
423 if ($signed) {
424 $n = -128 if $n < -128;
425 $n = 127 if $n > 127;
426 $n = 256 + $n if $n < 0; # make unsigned.
427 } else {
428 $n = 0 if $n < 0;
429 $n = 255 if $n > 255;
430 }
431 return $n;
432 }
434 sub main
435 {
436 my $cfn = "../../src/rrd_afm_data.c";
437 read_glyphlist();
438 process_all_fonts();
439 my @fonts = sort keys %font_code;
440 unless ($#fonts >= 0) {
441 die "You must have at least 1 font.\n";
442 }
443 open(CFILE, ">$cfn") || die "Can't create $cfn\n";
444 print CFILE header($cfn);
445 print CFILE ${$font_code{$_}}{TABLES} foreach @fonts;
446 print CFILE "const afm_fontinfo afm_fontinfolist[] = {\n";
447 print CFILE ${$font_code{$_}}{INFO} foreach @fonts;
448 print CFILE $indent1 . "{ 0, 0, 0 }\n";
449 print CFILE $indent0 . "};\n";
450 print CFILE $indent0 . "const int afm_fontinfo_count = ",
451 ($#fonts + 1), ";\n";
452 close(CFILE);
453 print STDERR "Compiled ", ($#fonts+1), " fonts.\n";
454 }
456 sub header
457 {
458 my ($fn) = @_;
459 $fn =~ s/.*\///;
460 my $h = $fn;
461 $h =~ s/\.c$/.h/;
462 return <<"END";
463 /****************************************************************************
464 * RRDtool 1.1.x Copyright Tobias Oetiker, 1997 - 2002
465 ****************************************************************************
466 * $fn Encoded afm (Adobe Font Metrics) for selected fonts.
467 ****************************************************************************
468 *
469 * THIS FILE IS AUTOGENERATED BY PERL. DO NOT EDIT.
470 *
471 ****************************************************************************/
473 #include "$h"
474 #include <stdlib.h>
476 END
477 }
479 main();