File Coverage

blib/lib/Text/Layout/FontConfig.pm
Criterion Covered Total %
statement 129 205 62.9
branch 38 144 26.3
condition 14 26 53.8
subroutine 17 23 73.9
pod 8 12 66.6
total 206 410 50.2


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