File Coverage

blib/lib/Font/PCF.pm
Criterion Covered Total %
statement 23 164 14.0
branch 0 56 0.0
condition 0 9 0.0
subroutine 8 29 27.5
pod 2 8 25.0
total 33 266 12.4


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2019-2022 -- leonerd@leonerd.org.uk
5              
6 2     2   56378 use v5.26;
  2         22  
7 2     2   941 use Object::Pad 0.64 ':experimental(init_expr)';
  2         17139  
  2         7  
8 2     2   1012 use Syntax::Keyword::Match;
  2         1426  
  2         9  
9              
10             package Font::PCF 0.03;
11             class Font::PCF;
12              
13 2     2   570 use List::Util 1.33 qw( any first );
  2         33  
  2         217  
14 2     2   784 use PerlIO::gzip;
  2         960  
  2         64  
15              
16 2     2   792 use IO::Handle::Packable;
  2         16782  
  2         88  
17              
18 2     2   768 use Object::Pad::ClassAttr::Struct;
  2         869  
  2         10  
19              
20             =head1 NAME
21              
22             C - read an X11 PCF font file
23              
24             =head1 SYNOPSIS
25              
26             use Font::PCF;
27              
28             my $font = Font::PCF->open( "/usr/share/fonts/X11/misc/9x15.pcf.gz" );
29              
30             my $glyph = $font->get_glyph_for_char( "A" );
31              
32             sub printbits {
33             my ( $bits ) = @_;
34             while( $bits ) {
35             print +( $bits & (1<<31) ) ? '#' : ' ';
36             $bits <<= 1;
37             }
38             print "\n";
39             }
40              
41             printbits $_ for $glyph->bitmap->@*;
42              
43             =head1 DESCRIPTION
44              
45             Instances of this class provide read access to the "PCF" format font files
46             that are typically found as part of an X11 installation.
47              
48             This module was written just to be sufficient for generating font bitmaps to
49             encode in microcontroller programs for display on OLED panels. It is possibly
50             useful for other use-cases as well, but may required more methods adding.
51              
52             =cut
53              
54             # See also
55             # http://fileformats.archiveteam.org/wiki/PCF
56             # https://fontforge.github.io/en-US/documentation/reference/pcf-format/
57              
58             class Font::PCF::_Table :Struct {
59 0     0     has $type;
  0            
60 0     0     has $format;
  0            
61 0     0     has $size;
  0            
62 0     0     has $offset;
  0            
63             }
64              
65             class Font::PCF::_Glyph :Struct {
66 0     0     has $bitmap { [] };
  0            
67             has $left_side_bearing = undef;
68 0     0     has $right_side_bearing = undef;
  0            
69 0     0     has $width = undef;
  0            
70 0     0     has $ascent = undef;
  0            
71 0     0     has $descent = undef;
  0            
72 0     0     has $attrs = undef;
  0            
73 0     0     has $name = undef;
  0            
74 0     0     }
  0            
75              
76             use constant {
77             # Table types
78 2         5936 PCF_PROPERTIES => (1<<0),
79             PCF_ACCELERATORS => (1<<1),
80             PCF_METRICS => (1<<2),
81             PCF_BITMAPS => (1<<3),
82             PCF_INK_METRICS => (1<<4),
83             PCF_BDF_ENCODINGS => (1<<5),
84             PCF_SWIDTHS => (1<<6),
85             PCF_GLYPH_NAMES => (1<<7),
86             PCF_BDF_ACCELERATORS => (1<<8),
87              
88             # Format types
89             PCF_DEFAULT_FORMAT => 0x00000000,
90             PCF_INKBOUNDS => 0x00000200,
91             PCF_ACCEL_W_INKBOUNDS => 0x00000100,
92             PCF_COMPRESSED_METRICS => 0x00000100,
93              
94             PCF_FORMAT_MASK => 0xFFFFFF00,
95              
96             # Format modifiers
97             PCF_GLYPH_PAD_MASK => (3<<0), # See the bitmap table for explanation
98             PCF_BYTE_MASK => (1<<2), # If set then Most Sig Byte First
99             PCF_BIT_MASK => (1<<3), # If set then Most Sig Bit First
100             PCF_SCAN_UNIT_MASK => (3<<4), # See the bitmap table for explanation
101 2     2   2146 };
  2         4  
102              
103             =head1 CONSTRUCTOR
104              
105             =cut
106              
107             =head2 open
108              
109             $font = Font::PCF->open( $path )
110              
111             Opens the PCF file from the given path, and returns a new instance containing
112             the data from it. Throws an exception if an error occurs.
113              
114             =cut
115              
116             # class method
117 0           sub open ( $class, $path, %opts )
  0            
118 0     0 1   {
  0            
  0            
119 0 0         $opts{gzip} = 1 if $path =~ m/\.gz$/;
120              
121 0 0         open my $fh, $opts{gzip} ? "<:gzip" : "<", $path or
    0          
122             die "Cannot open font at $path - $!";
123 0           bless $fh, "IO::Handle::Packable";
124              
125 0           my $self = $class->new( fh => $fh );
126              
127 0           $self->read_data;
128              
129 0           return $self;
130             }
131              
132             has $_fh :param;
133              
134             =head1 METHODS
135              
136             =cut
137              
138 0           method read_data ()
  0            
139 0     0 0   {
140 0           my ( $signature, $table_count ) = $_fh->unpack( "a4 i<" );
141 0 0         $signature eq "\x01fcp" or die "Invalid signature";
142              
143             my @tables = map {
144 0           my @v = $_fh->unpack( "i< i< i< i<" );
  0            
145 0           Font::PCF::_Table->new(
146             type => $v[0], format => $v[1], size => $v[2], offset => $v[3],
147             )
148             } 1 .. $table_count;
149              
150 0           foreach my $table ( @tables ) {
151 0           my $type = $table->type;
152             match ( $type : == ) {
153             case( PCF_METRICS ) {
154 0           $self->read_metrics_table( $table );
155             }
156             case( PCF_BITMAPS ) {
157 0           $self->read_bitmaps_table( $table );
158             }
159             case( PCF_BDF_ENCODINGS ) {
160 0           $self->read_encodings_table( $table );
161             }
162             case( PCF_GLYPH_NAMES ) {
163 0           $self->read_glyph_names_table( $table );
164             }
165 0 0         default {
    0          
    0          
    0          
166 0           my $size = 4 * int( ( $table->size + 3 ) / 4 );
167             print STDERR "TODO: Skipping table type $type of $size bytes\n" unless
168 0 0   0     any { $type == $_ } PCF_PROPERTIES, PCF_ACCELERATORS, PCF_INK_METRICS,
  0            
169             PCF_SWIDTHS, PCF_BDF_ACCELERATORS;
170 0           $_fh->read( my $tmp, $table->size );
171             }
172             }
173             }
174             }
175              
176 0           method read_metrics_table ( $table )
  0            
  0            
177 0     0 0   {
178 0           my ( $format ) = $_fh->unpack( "i<" );
179 0 0         $format == $table->format or die "Expected format repeated\n";
180              
181 0 0         my $end = $table->format & PCF_BYTE_MASK ? ">" : "<";
182 0           my $compressed = ( $format & PCF_COMPRESSED_METRICS );
183              
184 0 0         my $count = $_fh->unpack( $compressed ? "s${end}" : "i${end}" );
185              
186 0           foreach my $index ( 0 .. $count-1 ) {
187 0           my @fields;
188 0 0         if( $compressed ) {
189 0           @fields = $_fh->unpack( "C5" );
190 0           $_ -= 0x80 for @fields;
191 0           push @fields, 0;
192             }
193             else {
194 0           @fields = $_fh->unpack( "s${end}5 S${end}" );
195             }
196              
197 0           my $glyph = $self->get_glyph( $index );
198              
199 0           $glyph->left_side_bearing = shift @fields;
200 0           $glyph->right_side_bearing = shift @fields;
201 0           $glyph->width = shift @fields;
202 0           $glyph->ascent = shift @fields;
203 0           $glyph->descent = shift @fields;
204 0           $glyph->attrs = shift @fields;
205             }
206              
207             # Pad to a multiple of 4 bytes
208 0 0         my $total = $compressed ? 2 + $count * 5 : 4 + $count * 10;
209 0 0         $_fh->read( my $tmp, 4 - ( $total % 4 ) ) if $total % 4;
210             }
211              
212 0           method read_bitmaps_table ( $table )
  0            
  0            
213 0     0 0   {
214 0 0         ( $table->format & PCF_FORMAT_MASK ) == PCF_DEFAULT_FORMAT or
215             die "Expected PCF_BITMAPS to be in PCF_DEFAULT_FORMAT\n";
216              
217 0 0         my $end = $table->format & PCF_BYTE_MASK ? ">" : "<";
218              
219 0           my ( $format, $glyph_count ) = $_fh->unpack( "i< i${end}");
220 0 0         $format == $table->format or die "Expected format repeated\n";
221             # offsets
222 0           my @offsets = $_fh->unpack( "i${end}${glyph_count}" );
223              
224 0           my @sizes = $_fh->unpack( "i${end}4" );
225 0           my $size = $sizes[ $table->format & PCF_GLYPH_PAD_MASK ];
226              
227 0           my $scanunits = ( $table->format & PCF_SCAN_UNIT_MASK ) >> 4;
228              
229             # Continue reading chunks of data until we reach the next offset, add
230             # data so far to the previous glyph
231 0           my $offset = 0;
232 0           my $index = 0;
233 0           my $bitmap;
234 0           while( $offset < $size ) {
235 0 0 0       if( @offsets and $offset == $offsets[0] ) {
236 0           my $glyph = $self->get_glyph( $index++ );
237 0           $bitmap = $glyph->bitmap;
238 0           shift @offsets;
239             }
240              
241 0           push @$bitmap, $_fh->unpack( "I${end}" );
242 0           $offset += 4;
243             }
244             }
245              
246             has @_encoding_to_glyph;
247              
248 0           method read_encodings_table ( $table )
  0            
  0            
249 0     0 0   {
250 0 0         ( $table->format & PCF_FORMAT_MASK ) == PCF_DEFAULT_FORMAT or
251             die "Expected PCF_BITMAPS to be in PCF_DEFAULT_FORMAT\n";
252              
253 0 0         my $end = $table->format & PCF_BYTE_MASK ? ">" : "<";
254              
255 0           my ( $format, $min2, $max2, $min1, $max1, $default ) =
256             $_fh->unpack( "i< s$end s$end s$end s$end s$end" );
257 0 0         $format == $table->format or die "Expected format repeated\n";
258              
259 0           my $indices_count = ( $max2 - $min2 + 1 ) * ( $max1 - $min1 + 1 );
260              
261 0           my @indices = $_fh->unpack( "s${end}${indices_count}" );
262              
263 0           @_encoding_to_glyph = @indices;
264              
265             # Pad to a multiple of 4 bytes
266             # Header was 2 bytes over so we're 2 off if even number of indices
267 0 0         $_fh->read( my $tmp, 2 ) if ( $indices_count % 2 ) == 0;
268             }
269              
270 0           method read_glyph_names_table ( $table )
  0            
  0            
271 0     0 0   {
272 0 0         ( $table->format & PCF_FORMAT_MASK ) == PCF_DEFAULT_FORMAT or
273             die "Expected PCF_BITMAPS to be in PCF_DEFAULT_FORMAT\n";
274              
275 0 0         my $end = $table->format & PCF_BYTE_MASK ? ">" : "<";
276              
277 0           my ( $format, $glyph_count ) = $_fh->unpack( "i< i${end}");
278 0 0         $format == $table->format or die "Expected format repeated\n";
279              
280 0           my @offsets = $_fh->unpack( "i${end}${glyph_count}" );
281              
282 0           my $strlen = $_fh->unpack( "i${end}" );
283              
284             # Read this as one big string and cut it by @offsets
285 0           $_fh->read( my $names, $strlen );
286              
287 0           foreach my $index ( 0 .. $#offsets ) {
288 0           my $offset = $offsets[$index];
289 0   0       my $next_offset = $offsets[$index + 1] // $strlen;
290              
291             # Each glyph name ends with a \0 in the string data
292              
293 0           $self->get_glyph( $index )->name = substr( $names, $offset, $next_offset - $offset - 1 );
294             }
295              
296             # Pad to a multiple of 4 bytes
297 0 0         $_fh->read( my $tmp, 4 - ( $strlen % 4 ) ) if $strlen % 4;
298             }
299              
300             =head2 get_glyph_for_char
301              
302             $glyph = $font->get_glyph_for_char( $char )
303              
304             Returns a Glyph struct representing the unicode character; given as a
305             character string.
306              
307             =cut
308              
309 0           method get_glyph_for_char ( $char )
  0            
  0            
310 0     0 1   {
311 0           my $index = $_encoding_to_glyph[ ord $char ];
312 0 0         $index == -1 and
313             die "Unmapped character\n";
314              
315 0           return $self->get_glyph( $index );
316             }
317              
318             has @_glyphs;
319              
320 0           method get_glyph ( $index )
  0            
  0            
321 0     0 0   {
322 0   0       return $_glyphs[$index] //= Font::PCF::_Glyph->new;
323             }
324              
325             =head1 GLYPH STRUCTURE
326              
327             Each glyph structure returned by L has the following
328             methods:
329              
330             =head2 bitmap
331              
332             @bits = $glyph->bitmap->@*
333              
334             Returns a reference to the array containing lines of the bitmap for this
335             character. Each line is represented by an integer, where high bits represent
336             set pixels. The MSB is the leftmost pixel of the character.
337              
338             =head2 width
339              
340             $pixels = $glyph->width
341              
342             The total number of pixels per line stored in the bitmaps.
343              
344             =head2 left_side_bearing
345              
346             =head2 right_side_bearing
347              
348             $pixels = $glyph->left_side_bearing
349              
350             $pixels = $glyph->right_side_bearing
351              
352             The number of pixels of bearing (that is, blank pixels of space) to either
353             side of the character data.
354              
355             =head2 ascent
356              
357             =head2 descent
358              
359             $pixels = $glyph->ascent
360              
361             $pixels = $glyph->descent
362              
363             The number of pixels above and below the glyph.
364              
365             =head2 name
366              
367             $str = $glyph->name
368              
369             The PostScript name for the glyph
370              
371             =cut
372              
373             =head1 AUTHOR
374              
375             Paul Evans
376              
377             =cut
378              
379             0x55AA;