File Coverage

blib/lib/Text/Layout/FontConfig.pm
Criterion Covered Total %
statement 126 199 63.3
branch 36 138 26.0
condition 14 26 53.8
subroutine 17 22 77.2
pod 8 11 72.7
total 201 396 50.7


line stmt bran cond sub pod time code
1             #! perl
2              
3 6     6   54554 use strict;
  6         9  
  6         146  
4 6     6   27 use warnings;
  6         10  
  6         122  
5 6     6   594 use utf8;
  6         22  
  6         45  
6              
7             package Text::Layout::FontConfig;
8              
9 6     6   202 use Carp;
  6         13  
  6         381  
10              
11              
12              
13             our $VERSION = "0.029";
14              
15 6     6   2202 use Text::Layout::FontDescriptor;
  6         14  
  6         10957  
16              
17             =head1 NAME
18              
19             Text::Layout::FontConfig - Pango style font description for Text::Layout
20              
21             =head1 SYNOPSIS
22              
23             Font descriptors are strings that identify the characteristics of the
24             desired font. For example, C.
25              
26             The PDF context deals with physical fonts, e.g. built-in fonts like
27             C and fonts loaded from font files like
28             C.
29              
30             To map font descriptions to physical fonts, these fonts must be
31             registered. This defines a font family, style, and weight for the
32             font.
33              
34             Note that Text::Layout::FontConfig is a singleton. Creating objects
35             with new() will always return the same object.
36              
37             =cut
38              
39             my %fonts;
40             my @dirs;
41             my $loader;
42             my $debug = 0;
43              
44             my $weights =
45             [ 100 => 'thin',
46             100 => 'hairline',
47             200 => 'extra light',
48             200 => 'ultra light',
49             300 => 'light', # supported
50             350 => 'book', # supported
51             400 => 'normal', # supported
52             400 => 'regular', # supported
53             500 => 'medium', # supported
54             600 => 'semi bold', # supported 'semi'
55             600 => 'demi bold',
56             700 => 'bold', # supported
57             800 => 'extra bold',
58             800 => 'ultra bold',
59             900 => 'black',
60             900 => 'heavy', # supported
61             950 => 'extra black',
62             950 => 'ultra black',
63             ];
64              
65             =head2 METHODS
66              
67             =over
68              
69             =item new( [ atts... ] )
70              
71             For convenience only. Text::Layout::FontConfig is a singleton.
72             Creating objects with new() will always return the same object.
73              
74             Attributes:
75              
76             =over
77              
78             =item corefonts
79              
80             If true, a predefined set of font names (the PDF corefonts) is registered.
81              
82             =back
83              
84             =back
85              
86             =cut
87              
88             sub new {
89 4     4 1 1251 my ( $pkg, %atts ) = @_;
90 4         15 my $self = bless \my $i => $pkg;
91 4 100       21 if ( $atts{corefonts} ) {
92 2         10 $self->register_corefonts;
93             }
94 4 50       17 if ( $atts{loader} ) {
95 0         0 $loader = $atts{loader};
96             }
97 4         26 return $self;
98             }
99              
100             sub reset {
101 2     2 0 5 my ( $self ) = @_;
102 2         4 %fonts = ();
103 2         8 @dirs = ();
104             }
105              
106             =over
107              
108             =item register_fonts( $font, $family, $style [ , $weight ] [ , $props ] )
109              
110             Registers a font fmaily, style and weight for the given font.
111              
112             $font can be the name of a built-in font, or the name of a TrueType or
113             OpenType font file.
114              
115             $family is a font family name such as C, C, C, or
116             C. It is possible to specify multiple family names, e.g.,
117             C.
118              
119             $style is the slant style, one of C, C, or C.
120              
121             $weight is the font weight, like C, or C.
122              
123             For convenience, style combinations like "bolditalic" are allowed.
124              
125             A final hash reference can be passed to specify additional properties
126             for this font. Recognized properties are:
127              
128             =over
129              
130             =item *
131              
132             C - If set to a true value, this font will require text
133             shaping. This is required for fonts that deal with complex glyph
134             rendering and ligature handling like Devanagari.
135              
136             Text shaping requires module L.
137              
138             =item *
139              
140             C - If set to a true value, an alternative way to determine
141             glyph height is used. This may improve results for some fonts.
142              
143             =item *
144              
145             C, C - Overrides the font
146             specified or calculated values for underline thickness and/or position.
147             This may improve results for some fonts.
148              
149             =item *
150              
151             C, C - Overrides the font
152             specified or calculated values for strikeline thickness and/or position.
153             This may improve results for some fonts.
154              
155             Note that strikeline thickness will default to underline thickness, if set.
156              
157             =item *
158              
159             C, C - Overrides the font
160             specified or calculated values for overline thickness and/or position.
161              
162             This may improve results for some fonts.
163              
164             Note that overline thickness will default to underline thickness, if
165             set.
166              
167             =back
168              
169             =back
170              
171             =cut
172              
173             sub register_font {
174 54 100   54 0 469 shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
175 54         61 my $props;
176 54 50       144 $props = pop(@_) if UNIVERSAL::isa( $_[-1], 'HASH' );
177 54         95 my ( $font, $family, $style, $weight ) = @_;
178              
179 54 100 66     244 if ( $style && !$weight && $style =~ s/^(heavy|bold|semi(?:bold)?|medium|book|light)//i ) {
      100        
180 24         49 $weight = $1;
181             }
182 54   100     142 $style = _norm_style( $style // "normal" );
183 54   100     141 $weight = _norm_weight( $weight // "normal" );
184 54         75 my $ff;
185 54 50       93 if ( $font =~ /\.[ot]tf$/ ) {
186 0 0       0 if ( $font =~ m;^/; ) {
187 0 0       0 $ff = $font if -r -s $font;
188             }
189             else {
190 0         0 foreach ( @dirs ) {
191 0 0       0 next unless -r -s "$_/$font";
192 0         0 $ff = "$_/$font";
193 0         0 last;
194             }
195             }
196             }
197             else {
198             # Assume corefont.
199 54         59 $ff = $font
200             }
201              
202 54 50       82 croak("Cannot find font: ", $font, "\n") unless $ff;
203              
204 54         124 foreach ( split(/\s*,\s*/, $family) ) {
205 54         175 $fonts{lc $_}->{$style}->{$weight}->{loader} = $loader;
206 54         99 $fonts{lc $_}->{$style}->{$weight}->{loader_data} = $ff;
207 54 50       119 next unless $props;
208 0         0 while ( my($k,$v) = each %$props ) {
209 0         0 $fonts{lc $_}->{$style}->{$weight}->{$k} = $v;
210             }
211             }
212              
213             }
214              
215             =over
216              
217             =item add_fontdirs( @dirs )
218              
219             Adds one or more file paths to be searched for font files.
220              
221             =back
222              
223             =cut
224              
225             sub add_fontdirs {
226 0 0   0 1 0 shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
227 0         0 my ( @d ) = @_;
228              
229 0         0 foreach ( @d ) {
230 0 0       0 unless ( -d -r -x ) {
231 0         0 carp("Skipped font dir: $_ [$!]");
232 0         0 next;
233             }
234 0         0 push( @dirs, $_ );
235             }
236             }
237              
238             =over
239              
240             =item register_aliases( $family, $aliases, ... )
241              
242             Adds aliases for existing font families.
243              
244             Multiple aliases can be specified, e.g.
245              
246             $layout->register_aliases( "times", "serif, default" );
247              
248             or
249              
250             $layout->register_aliases( "times", "serif", "default" );
251              
252             =back
253              
254             =cut
255              
256             sub register_aliases {
257 8 50   8 1 28 shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
258 8         19 my ( $family, @aliases ) = @_;
259             carp("Unknown font family: $family")
260 8 50       19 unless exists $fonts{lc $family};
261 8         14 foreach ( @aliases ) {
262 18         34 foreach ( split( /\s*,\s*/, $_ ) ) {
263 18         43 $fonts{lc $_} = $fonts{lc $family};
264             }
265             }
266             }
267              
268             =over
269              
270             =item register_corefonts( $noaliases )
271              
272             This is a convenience method that registers all built-in corefonts.
273              
274             Aliases for families C, C, and C are added
275             unless $noaliases is specified.
276              
277             You do not need to call this method if you provide your own font
278             registrations.
279              
280             =back
281              
282             =cut
283              
284             sub register_corefonts {
285 2 50   2 1 18 shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
286 2         7 my ( $noaliases ) = @_;
287              
288 2         6 register_font( "Times-Roman", "Times" );
289 2         8 register_font( "Times-Bold", "Times", "Bold" );
290 2         6 register_font( "Times-Italic", "Times", "Italic" );
291 2         6 register_font( "Times-BoldItalic", "Times", "BoldItalic" );
292              
293 2 50       21 register_aliases( "Times", "Serif" )
294             unless $noaliases;
295              
296 2         6 register_font( "Helvetica", "Helvetica" );
297 2         6 register_font( "Helvetica-Bold", "Helvetica", "Bold" );
298 2         6 register_font( "Helvetica-Oblique", "Helvetica", "Oblique" );
299 2         7 register_font( "Helvetica-BoldOblique", "Helvetica", "BoldOblique" );
300              
301 2 50       19 register_aliases( "Helvetica", "Sans", "Arial" )
302             unless $noaliases;
303              
304 2         5 register_font( "Courier", "Courier" );
305 2         6 register_font( "Courier-Bold", "Courier", "Bold" );
306 2         7 register_font( "Courier-Oblique", "Courier", "Italic" );
307 2         16 register_font( "Courier-BoldOblique", "Courier", "BoldItalic" );
308              
309 2 50       10 register_aliases( "Courier", "Mono", "Monospace", "fixed" )
310             unless $noaliases;
311 2 50       7 register_aliases( "Courier", "Mono", "Monospace", "fixed" )
312             unless $noaliases;
313              
314 2         5 register_font( "ZapfDingbats", "Dingbats" );
315              
316 2         7 register_font( "Georgia", "Georgia" );
317 2         6 register_font( "Georgia,Bold", "Georgia", "Bold" );
318 2         13 register_font( "Georgia,Italic", "Georgia", "Italic" );
319 2         6 register_font( "Georgia,BoldItalic", "Georgia", "BoldItalic" );
320              
321 2         5 register_font( "Verdana", "Verdana" );
322 2         6 register_font( "Verdana,Bold", "Verdana", "Bold" );
323 2         5 register_font( "Verdana,Italic", "Verdana", "Italic" );
324 2         15 register_font( "Verdana,BoldItalic", "Verdana", "BoldItalic" );
325              
326 2         5 register_font( "WebDings", "WebDings" );
327 2         5 register_font( "WingDings", "WingDings" );
328             }
329              
330             =over
331              
332             =item find_font( $family, $style, $weight )
333              
334             Returns a font descriptor based on the given family, style and weight.
335              
336             On Linux, fallback using fontconfig.
337              
338             =back
339              
340             =cut
341              
342             sub find_font {
343 21 100   21 1 88 shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
344 21         27 my $atts;
345 21 50       75 $atts = pop(@_) if UNIVERSAL::isa( $_[-1], 'HASH' );
346 21         48 my ( $family, $style, $weight ) = @_;
347              
348             my $try = sub {
349 21 50 33 21   164 if ( $fonts{$family}
      33        
350             && $fonts{$family}->{$style}
351             && $fonts{$family}->{$style}->{$weight} ) {
352              
353 21         45 my $ff = $fonts{$family}->{$style}->{$weight};
354 21         93 my %i = ( family => $family,
355             style => $style,
356             weight => $weight );
357             ;
358 21 50       87 if ( $ff->{font} ) {
    50          
359 0         0 $i{font} = $ff->{font};
360             }
361             elsif ( $ff->{loader_data} ) {
362 21         38 $i{loader_data} = $ff->{loader_data};
363 21         33 $i{loader} = $loader;
364 21         39 $i{cache} = $ff;
365             }
366             else {
367 0         0 return;
368             }
369              
370 21         44 for ( qw( shaping interline nosubset direction language
371             underline_thickness underline_position
372             strikeline_thickness strikeline_position
373             overline_thickness overline_position
374             ) ) {
375 231         399 $i{$_} = $ff->{$_};
376             }
377              
378 21         160 return Text::Layout::FontDescriptor->new(%i);
379             }
380 21         97 };
381              
382 21   50     64 $style = _norm_style( $style // "normal" );
383 21   50     76 $weight = _norm_weight( $weight // "normal" );
384 21         76 my $res = $try->();
385 21 50       151 return $res if $res;
386              
387             # TODO: Some form of font fallback.
388 0 0       0 if ( _fallback( $family, $style, $weight ) ) {
389 0         0 $res = $try->();
390 0 0       0 return $res if $res;
391             }
392              
393             # Nope.
394 0         0 croak("Cannot find font: $family $style $weight\n");
395             }
396              
397             =over
398              
399             =item from_string( $description )
400              
401             Returns a font descriptor using a Pango-style font description, e.g.
402             C.
403              
404             On Linux, fallback using fontconfig.
405              
406             =back
407              
408             =cut
409              
410             my $stylep = qr/^( (?:heavy|bold|semi(?:bold)?|medium|book|light)? (?:oblique|italic) )$/ix;
411             my $weightp = qr/^( (?:heavy|bold|semi(?:bold)?|medium|book|light) (?:oblique|italic)? )$/ix;
412              
413             sub from_string {
414 5 50   5 1 81 shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
415 5         21 my ( $description ) = @_;
416              
417 5         16 my $i = parse($description);
418              
419 5         51 my $res = find_font( $i->{family}, $i->{style}, $i->{weight} );
420 5 50 33     16 $res->set_size($i->{size}) if $res && $i->{size};
421 5         31 $res;
422             }
423              
424             =over
425              
426             =item parse( $description )
427              
428             Parses a Pango-style font description and returns a hash ref with keys
429             C, C