1# This -*- perl -*-  module is a simple parser for Adobe Font Metrics files.
2
3package Font::AFM;
4
5=head1 NAME
6
7Font::AFM - Interface to Adobe Font Metrics files
8
9=head1 SYNOPSIS
10
11 use Font::AFM;
12 $h = new Font::AFM "Helvetica";
13 $copyright = $h->Notice;
14 $w = $h->Wx->{"aring"};
15 $w = $h->stringwidth("Gisle", 10);
16 $h->dump;  # for debugging
17
18=head1 DESCRIPTION
19
20This module implements the Font::AFM class. Objects of this class are
21initialised from an AFM (Adobe Font Metrics) file and allow you to obtain information
22about the font and the metrics of the various glyphs in the font.
23
24All measurements in AFM files are given in terms of units equal to
251/1000 of the scale factor of the font being used. To compute actual
26sizes in a document, these amounts should be multiplied by (scale
27factor of font)/1000.
28
29The following methods are available:
30
31=over 3
32
33=item $afm = Font::AFM->new($fontname)
34
35Object constructor. Takes the name of the font as argument.
36Croaks if the font can not be found.
37
38=item $afm->latin1_wx_table()
39
40Returns a 256-element array, where each element contains the width
41of the corresponding character in the iso-8859-1 character set.
42
43=item $afm->stringwidth($string, [$fontsize])
44
45Returns the width of the argument string. The string is
46assumed to be encoded in the iso-8859-1 character set.  A second
47argument can be used to scale the width according to the font size.
48
49=item $afm->FontName
50
51The name of the font as presented to the PostScript language
52C<findfont> operator, for instance "Times-Roman".
53
54=item $afm->FullName
55
56Unique, human-readable name for an individual font, for instance
57"Times Roman".
58
59=item $afm->FamilyName
60
61Human-readable name for a group of fonts that are stylistic variants
62of a single design. All fonts that are members of such a group should
63have exactly the same C<FamilyName>. Example of a family name is
64"Times".
65
66=item $afm->Weight
67
68Human-readable name for the weight, or "boldness", attribute of a font.
69Examples are C<Roman>, C<Bold>, C<Light>.
70
71=item $afm->ItalicAngle
72
73Angle in degrees counterclockwise from the vertical of the dominant
74vertical strokes of the font.
75
76=item $afm->IsFixedPitch
77
78If C<true>, the font is a fixed-pitch
79(monospaced) font.
80
81=item $afm->FontBBox
82
83A string of four numbers giving the lower-left x, lower-left y,
84upper-right x, and upper-right y of the font bounding box. The font
85bounding box is the smallest rectangle enclosing the shape that would
86result if all the characters of the font were placed with their
87origins coincident, and then painted.
88
89=item $afm->UnderlinePosition
90
91Recommended distance from the baseline for positioning underline
92strokes. This number is the y coordinate of the center of the stroke.
93
94=item $afm->UnderlineThickness
95
96Recommended stroke width for underlining.
97
98=item $afm->Version
99
100Version number of the font.
101
102=item $afm->Notice
103
104Trademark or copyright notice, if applicable.
105
106=item $afm->Comment
107
108Comments found in the AFM file.
109
110=item $afm->EncodingScheme
111
112The name of the standard encoding scheme for the font. Most Adobe
113fonts use the C<AdobeStandardEncoding>. Special fonts might state
114C<FontSpecific>.
115
116=item $afm->CapHeight
117
118Usually the y-value of the top of the capital H.
119
120=item $afm->XHeight
121
122Typically the y-value of the top of the lowercase x.
123
124=item $afm->Ascender
125
126Typically the y-value of the top of the lowercase d.
127
128=item $afm->Descender
129
130Typically the y-value of the bottom of the lowercase p.
131
132=item $afm->Wx
133
134Returns a hash table that maps from glyph names to the width of that glyph.
135
136=item $afm->BBox
137
138Returns a hash table that maps from glyph names to bounding box information.
139The bounding box consist of four numbers: llx, lly, urx, ury.
140
141=item $afm->dump
142
143Dumps the content of the Font::AFM object to STDOUT.  Might sometimes
144be useful for debugging.
145
146=back
147
148
149The AFM specification can be found at:
150
151   http://partners.adobe.com/asn/developer/pdfs/tn/5004.AFM_Spec.pdf
152
153
154=head1 ENVIRONMENT
155
156=over 10
157
158=item METRICS
159
160Contains the path to search for AFM-files.  Format is as for the PATH
161environment variable. The default path built into this library is:
162
163 /usr/lib/afm:/usr/local/lib/afm:/usr/openwin/lib/fonts/afm/:.
164
165=back
166
167
168=head1 BUGS
169
170Kerning data and composite character data are not yet parsed.
171Ligature data is not parsed.
172
173
174=head1 COPYRIGHT
175
176Copyright 1995-1998 Gisle Aas. All rights reserved.
177
178This program is free software; you can redistribute it and/or modify
179it under the same terms as Perl itself.
180
181=cut
182
183#-------perl resumes here--------------------------------------------
184
185use Carp;
186use strict;
187use vars qw($VERSION @ISOLatin1Encoding);
188
189$VERSION = "1.20";
190
191
192# The metrics_path is used to locate metrics files
193#
194my $metrics_path = $ENV{METRICS} ||
195    "/usr/lib/afm:/usr/local/lib/afm:/usr/openwin/lib/fonts/afm/:.";
196my @metrics_path = split(/:/, $metrics_path);
197foreach (@metrics_path) { s,/$,, }    # reove trailing slashes
198
199@ISOLatin1Encoding = qw(
200 .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef
201 .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef
202 .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef
203 .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef space
204 exclam quotedbl numbersign dollar percent ampersand quoteright
205 parenleft parenright asterisk plus comma minus period slash zero one
206 two three four five six seven eight nine colon semicolon less equal
207 greater question at A B C D E F G H I J K L M N O P Q R S
208 T U V W X Y Z bracketleft backslash bracketright asciicircum
209 underscore quoteleft a b c d e f g h i j k l m n o p q r s
210 t u v w x y z braceleft bar braceright asciitilde .notdef .notdef
211 .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef
212 .notdef .notdef .notdef .notdef .notdef .notdef .notdef dotlessi grave
213 acute circumflex tilde macron breve dotaccent dieresis .notdef ring
214 cedilla .notdef hungarumlaut ogonek caron space exclamdown cent
215 sterling currency yen brokenbar section dieresis copyright ordfeminine
216 guillemotleft logicalnot hyphen registered macron degree plusminus
217 twosuperior threesuperior acute mu paragraph periodcentered cedilla
218 onesuperior ordmasculine guillemotright onequarter onehalf threequarters
219 questiondown Agrave Aacute Acircumflex Atilde Adieresis Aring AE
220 Ccedilla Egrave Eacute Ecircumflex Edieresis Igrave Iacute Icircumflex
221 Idieresis Eth Ntilde Ograve Oacute Ocircumflex Otilde Odieresis
222 multiply Oslash Ugrave Uacute Ucircumflex Udieresis Yacute Thorn
223 germandbls agrave aacute acircumflex atilde adieresis aring ae
224 ccedilla egrave eacute ecircumflex edieresis igrave iacute icircumflex
225 idieresis eth ntilde ograve oacute ocircumflex otilde odieresis divide
226 oslash ugrave uacute ucircumflex udieresis yacute thorn ydieresis
227);
228
229
230# Creates a new Font::AFM object.  Pass it the name of the font as parameter.
231# Synopisis:
232#
233#    $h = new Font::AFM "Helvetica";
234#
235
236sub new
237{
238   my($class, $fontname) = @_;
239   my $file;
240   $fontname =~ s/\.afm$//;
241   if ($^O eq 'VMS') {
242       $file = "sys\$ps_font_metrics:$fontname.afm";
243   } else {
244       $file = "$fontname.afm";
245       unless ($file =~ m,^/,) {
246	   # not absolute, search the metrics path for the file
247	   foreach (@metrics_path) {
248	       if (-f "$_/$file") {
249		   $file = "$_/$file";
250		   last;
251	       }
252	   }
253       }
254   }
255   open(AFM, $file) or croak "Can't find the AFM file for $fontname";
256   my $self = bless { }, $class;
257   local($/, $_) = ("\n", undef);  # ensure correct $INPUT_RECORD_SEPARATOR
258   while (<AFM>) {
259       next if /^StartKernData/ .. /^EndKernData/;  # kern data not parsed yet
260       next if /^StartComposites/ .. /^EndComposites/; # same for composites
261       if (/^StartCharMetrics/ .. /^EndCharMetrics/) {
262	   # only lines that start with "C" or "CH" are parsed
263	   next unless /^CH?\s/;
264	   my($name) = /\bN\s+(\.?\w+)\s*;/;
265	   my($wx)   = /\bWX\s+(\d+)\s*;/;
266	   my($bbox)    = /\bB\s+([^;]+);/;
267	   $bbox =~ s/\s+$//;
268	   # Should also parse lingature data (format: L successor lignature)
269	   $self->{'wx'}{$name} = $wx;
270	   $self->{'bbox'}{$name} = $bbox;
271	   next;
272       }
273       last if /^EndFontMetrics/;
274       if (/(^\w+)\s+(.*)/) {
275	   my($key,$val) = ($1, $2);
276	   $key = lc $key;
277	   if (defined $self->{$key}) {
278	       $self->{$key} = [ $self->{$key} ] unless ref $self->{$key};
279	       push(@{$self->{$key}}, $val);
280	   } else {
281	       $self->{$key} = $val;
282	   }
283       } else {
284	   print STDERR "Can't parse: $_";
285       }
286   }
287   close(AFM);
288   unless (exists $self->{wx}->{'.notdef'}) {
289       $self->{wx}->{'.notdef'} = 0;
290       $self->{bbox}{'.notdef'} = "0 0 0 0";
291   }
292   $self;
293}
294
295# Returns an 256 element array that maps from characters to width
296sub latin1_wx_table
297{
298    my($self) = @_;
299    unless ($self->{'_wx_table'}) {
300	my @wx;
301	for (0..255) {
302	    my $name = $ISOLatin1Encoding[$_];
303	    if (exists $self->{wx}->{$name}) {
304		push(@wx, $self->{wx}->{$name})
305	    } else {
306		push(@wx, $self->{wx}->{'.notdef'});
307	    }
308	}
309	$self->{'_wx_table'} = \@wx;
310    }
311    wantarray ? @{ $self->{'_wx_table'} } : $self->{'_wx_table'};
312}
313
314sub stringwidth
315{
316    my($self, $string, $pointsize) = @_;
317    return 0.0 unless defined $string;
318    return 0.0 unless length $string;
319
320    my @wx = $self->latin1_wx_table;
321    my $width = 0.0;
322    for (unpack("C*", $string)) {
323	$width += $wx[$_];
324    }
325    if ($pointsize) {
326	$width *= $pointsize / 1000;
327    }
328    $width;
329}
330
331sub FontName;
332sub FullName;
333sub FamilyName;
334sub Weight;
335sub ItalicAngle;
336sub IsFixedPitch;
337sub FontBBox;
338sub UnderlinePosition;
339sub UnderlineThickness;
340sub Version;
341sub Notice;
342sub Comment;
343sub EncodingScheme;
344sub CapHeight;
345sub XHeight;
346sub Ascender;
347sub Descender;
348sub Wx;
349sub BBox;
350
351# We implement all the access functions within this simple autoload
352# function.
353
354sub AUTOLOAD
355{
356    no strict 'vars';  # don't want to declare $AUTOLOAD
357
358    #print "AUTOLOAD: $AUTOLOAD\n";
359    if ($AUTOLOAD =~ /::DESTROY$/) {
360	eval "sub $AUTOLOAD {}";
361	goto &$AUTOLOAD;
362    } else {
363	my $name = $AUTOLOAD;
364	$name =~ s/^.*:://;
365	croak "Attribute $name not defined for AFM object"
366	    unless defined $_[0]->{lc $name};
367	return $_[0]->{lc $name};
368    }
369}
370
371
372# Dumping might be useful for debugging
373
374sub dump
375{
376    my($self) = @_;
377    my($key, $val);
378    foreach $key (sort keys %$self) {
379	if (ref $self->{$key}) {
380	    if (ref $self->{$key} eq "ARRAY") {
381		print "$key = [\n\t", join("\n\t", @{$self->{$key}}), "\n]\n";
382	    } elsif (ref $self->{$key} eq "HASH") {
383		print "$key = {\n";
384		my $key2;
385		foreach $key2 (sort keys %{$self->{$key}}) {
386		    print "\t$key2 => $self->{$key}{$key2},\n";
387		}
388		print "}\n";
389	    } else {
390		print "$key = $self->{$key}\n";
391	    }
392	} else {
393	    print "$key = $self->{$key}\n";
394	}
395    }
396}
397
3981;
399