File Coverage

blib/lib/Text/Layout/FontConfig.pm
Criterion Covered Total %
statement 134 243 55.1
branch 48 188 25.5
condition 15 33 45.4
subroutine 19 25 76.0
pod 9 13 69.2
total 225 502 44.8


line stmt bran cond sub pod time code
1             #! perl
2              
3 8     8   147395 use strict;
  8         17  
  8         332  
4 8     8   76 use warnings;
  8         16  
  8         486  
5 8     8   840 use utf8;
  8         388  
  8         52  
6              
7             package Text::Layout::FontConfig;
8              
9 8     8   383 use Carp;
  8         15  
  8         828  
10              
11             our $VERSION = "0.045";
12              
13 8     8   18796 use Text::Layout::FontDescriptor;
  8         24  
  8         10062  
14              
15             =head1 NAME
16              
17             Text::Layout::FontConfig - Pango style font description for Text::Layout
18              
19             =head1 SYNOPSIS
20              
21             Font descriptors are strings that identify the characteristics of the
22             desired font. For example, C.
23              
24             The PDF context deals with physical fonts, e.g. built-in fonts like
25             C and fonts loaded from font files like
26             C.
27              
28             To map font descriptions to physical fonts, these fonts must be
29             registered. This defines a font family, style, and weight for the
30             font.
31              
32             Note that Text::Layout::FontConfig is a singleton. Creating objects
33             with new() will always return the same object.
34              
35             =cut
36              
37             my %fonts;
38             my @dirs;
39             my %maps;
40             my $loader;
41             my $debug = 0;
42              
43             my $weights =
44             [ 100 => 'thin',
45             100 => 'hairline',
46             200 => 'extra light',
47             200 => 'ultra light',
48             300 => 'light', # supported
49             350 => 'book', # supported
50             400 => 'normal', # supported
51             400 => 'regular', # supported
52             500 => 'medium', # supported
53             600 => 'semi bold', # supported 'semi'
54             600 => 'demi bold',
55             700 => 'bold', # supported
56             800 => 'extra bold',
57             800 => 'ultra bold',
58             900 => 'black',
59             900 => 'heavy', # supported
60             950 => 'extra black',
61             950 => 'ultra black',
62             ];
63              
64             =head2 METHODS
65              
66             =over
67              
68             =item new( [ atts... ] )
69              
70             For convenience only. Text::Layout::FontConfig is a singleton.
71             Creating objects with new() will always return the same object.
72              
73             Attributes:
74              
75             =over
76              
77             =item corefonts
78              
79             If true, a predefined set of font names (the PDF corefonts) is registered.
80              
81             =back
82              
83             =back
84              
85             =cut
86              
87             sub new {
88 7     7 1 1264 my ( $pkg, %atts ) = @_;
89 7         27 my $self = bless {} => $pkg;
90 7         63 $debug = $self->{debug} = $atts{debug};
91 7 100       37 if ( $atts{corefonts} ) {
92 5         29 $self->register_corefonts;
93             }
94 7 50       46 if ( $atts{loader} ) {
95 0         0 $loader = $atts{loader};
96             }
97 7         31 return $self;
98             }
99              
100             sub reset {
101 3     3 0 11 my ( $self ) = @_;
102 3 50       12 warn("FC: Reset\n") if $debug;
103 3         57 %fonts = ();
104 3         9 @dirs = ();
105 3         10 %maps = ();
106             }
107              
108 0     0 0 0 sub debug { shift->{debug} }
109              
110             =over
111              
112             =item register_fonts( $font, $family, $style [ , $weight ] [ , $props ] )
113              
114             Registers a font fmaily, style and weight for the given font.
115              
116             $font can be the name of a built-in font, or the name of a TrueType or
117             OpenType font file.
118              
119             $family is a font family name such as C, C, C, or
120             C. It is possible to specify multiple family names, e.g.,
121             C.
122              
123             $style is the slant style, one of C, C, or C.
124              
125             $weight is the font weight, like C, or C.
126              
127             For convenience, style combinations like "bolditalic" are allowed.
128              
129             A final hash reference can be passed to specify additional properties
130             for this font. Recognized properties are:
131              
132             =over
133              
134             =item *
135              
136             C - If set to a true value, this font will require text
137             shaping. This is required for fonts that deal with complex glyph
138             rendering and ligature handling like Devanagari.
139              
140             Text shaping requires module L.
141              
142             =item *
143              
144             C - If set overrides the font ascender.
145             This may be necessary to improve results for some fonts.
146             The value is expressed in 1/1000th of an em.
147              
148             C - If set overrides the font descender.
149             This may be necessary to improve results for some fonts.
150             The value is expressed in 1/1000th of an em.
151              
152             =item *
153              
154             C, C - Overrides the font
155             specified or calculated values for underline thickness and/or position.
156             This may improve results for some fonts.
157              
158             =item *
159              
160             C, C - Overrides the font
161             specified or calculated values for strikeline thickness and/or position.
162             This may improve results for some fonts.
163              
164             Note that strikeline thickness will default to underline thickness, if set.
165              
166             =item *
167              
168             C, C - Overrides the font
169             specified or calculated values for overline thickness and/or position.
170              
171             This may improve results for some fonts.
172              
173             Note that overline thickness will default to underline thickness, if
174             set.
175              
176             =back
177              
178             =back
179              
180             =cut
181              
182             sub register_font {
183 73 100   73 0 577 shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
184 73         106 my $props;
185 73 50       288 $props = pop(@_) if UNIVERSAL::isa( $_[-1], 'HASH' );
186 73         165 my ( $font, $family, $style, $weight ) = @_;
187              
188 73 100 66     403 if ( $style && !$weight && $style =~ s/^(heavy|bold|semi(?:bold)?|medium|book|light)//i ) {
      100        
189 34         96 $weight = $1;
190             }
191 73   100     239 $style = _norm_style( $style // "normal" );
192 73   100     246 $weight = _norm_weight( $weight // "normal" );
193 73         118 my $ff;
194 73 50       160 if ( $font =~ /\.[ot]tf$/ ) {
195 0 0       0 if ( $font =~ m;^/; ) {
196 0 0       0 $ff = $font if -r -s $font;
197             }
198             else {
199 0         0 foreach ( @dirs ) {
200 0 0       0 next unless -r -s "$_/$font";
201 0         0 $ff = "$_/$font";
202 0         0 last;
203             }
204             }
205             }
206             else {
207             # Assume corefont.
208 73         130 $ff = $font
209             }
210              
211 73 50       163 croak("Cannot find font: ", $font, "\n") unless $ff;
212              
213 73         212 foreach ( split(/\s*,\s*/, $family) ) {
214 73         278 $fonts{lc $_}->{$style}->{$weight}->{loader} = $loader;
215 73         186 $fonts{lc $_}->{$style}->{$weight}->{loader_data} = $ff;
216 73 50       144 warn("FC: Registered: $ff for ", lc($_), "-$style-$weight\n") if $debug;
217 73 50       219 next unless $props;
218 0         0 while ( my($k,$v) = each %$props ) {
219 0         0 $fonts{lc $_}->{$style}->{$weight}->{$k} = $v;
220             }
221             }
222              
223             }
224              
225             =over
226              
227             =item add_fontdirs( @dirs )
228              
229             Adds one or more file paths to be searched for font files.
230              
231             =back
232              
233             =cut
234              
235             sub add_fontdirs {
236 0 0   0 1 0 shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
237 0         0 my ( @d ) = @_;
238              
239 0         0 foreach ( @d ) {
240 0 0       0 unless ( -d -r -x ) {
241 0         0 carp("Skipped font dir: $_ [$!]");
242 0         0 next;
243             }
244 0         0 push( @dirs, $_ );
245             }
246             }
247              
248             =over
249              
250             =item register_aliases( $family, $aliases, ... )
251              
252             Adds aliases for existing font families.
253              
254             Multiple aliases can be specified, e.g.
255              
256             $layout->register_aliases( "times", "serif, default" );
257              
258             or
259              
260             $layout->register_aliases( "times", "serif", "default" );
261              
262             =back
263              
264             =cut
265              
266             sub register_aliases {
267 8     8   4640 use Storable qw(dclone);
  8         52155  
  8         35690  
268 20 50   20 1 102 shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
269 20         86 my ( $family, @aliases ) = @_;
270             carp("Unknown font family: $family")
271 20 50       56 unless exists $fonts{lc $family};
272 20         48 foreach ( @aliases ) {
273 45         123 foreach ( split( /\s*,\s*/, $_ ) ) {
274 45         1689 $fonts{lc $_} = dclone( $fonts{lc $family} );
275             }
276             }
277             }
278              
279             =over
280              
281             =item register_corefonts( %options )
282              
283             This is a convenience method that registers all built-in corefonts.
284              
285             Aliases for families C, C, and C are added
286             unless $noaliases is specified.
287              
288             You do not need to call this method if you provide your own font
289             registrations.
290              
291             Options:
292              
293             =over
294              
295             =item aliases
296              
297             If true, register Serif, Sans and Mono as aliases for Times,
298             Helvetica and Courier.
299              
300             This is enabled by default and can be cancelled with C.
301              
302             =item noaliases
303              
304             If true, do not register Serif, Sans and Mono as aliases for Times,
305             Helvetica and Courier.
306              
307             =item remap
308              
309             Remap the core fonts to real TrueType or OpenType font files.
310              
311             Supported values are C or C to use the GNU Free Fonts
312             (http://ftp.gnu.org/gnu/freefont/) and C or C for the
313             TeX Gyre fonts (https://www.gust.org.pl/projects/e-foundry/tex-gyre/).
314              
315             =back
316              
317             =back
318              
319             =cut
320              
321             sub register_corefonts {
322 5 50   5 1 31 shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
323              
324 5         12 my %options;
325 5 50       25 if ( @_ == 1 ) {
326 0         0 $options{noaliases} = shift;
327             }
328             else {
329 5         16 %options = @_;
330             }
331 5 50       24 my $noaliases = defined($options{aliases}) ? !$options{aliases} : $options{noaliases};
332              
333 5 50       15 warn("FC: Registering corefonts\n") if $debug;
334              
335 5         26 register_font( "Times-Roman", "Times" );
336 5         20 register_font( "Times-Bold", "Times", "Bold" );
337 5         37 register_font( "Times-Italic", "Times", "Italic" );
338 5         16 register_font( "Times-BoldItalic", "Times", "BoldItalic" );
339              
340 5 50       87 register_aliases( "Times", "Serif" )
341             unless $noaliases;
342              
343 5         55 register_font( "Helvetica", "Helvetica" );
344 5         16 register_font( "Helvetica-Bold", "Helvetica", "Bold" );
345 5         16 register_font( "Helvetica-Oblique", "Helvetica", "Oblique" );
346 5         28 register_font( "Helvetica-BoldOblique", "Helvetica", "BoldOblique" );
347              
348 5 50       26 register_aliases( "Helvetica", "Sans", "Arial" )
349             unless $noaliases;
350              
351 5         16 register_font( "Courier", "Courier" );
352 5         13 register_font( "Courier-Bold", "Courier", "Bold" );
353 5         14 register_font( "Courier-Oblique", "Courier", "Italic" );
354 5         16 register_font( "Courier-BoldOblique", "Courier", "BoldItalic" );
355              
356 5 50       28 register_aliases( "Courier", "Mono", "Monospace", "fixed" )
357             unless $noaliases;
358 5 50       30 register_aliases( "Courier", "Mono", "Monospace", "fixed" )
359             unless $noaliases;
360              
361 5         17 register_font( "ZapfDingbats", "Dingbats" );
362              
363 5         9 if ( 0 ) {
364             register_font( "Georgia", "Georgia" );
365             register_font( "Georgia,Bold", "Georgia", "Bold" );
366             register_font( "Georgia,Italic", "Georgia", "Italic" );
367             register_font( "Georgia,BoldItalic", "Georgia", "BoldItalic" );
368              
369             register_font( "Verdana", "Verdana" );
370             register_font( "Verdana,Bold", "Verdana", "Bold" );
371             register_font( "Verdana,Italic", "Verdana", "Italic" );
372             register_font( "Verdana,BoldItalic", "Verdana", "BoldItalic" );
373              
374             register_font( "WebDings", "WebDings" );
375             register_font( "WingDings", "WingDings" );
376             }
377              
378             # Corefont remapping to real font files.
379             # Biggest problem is to make sure the fonts are installed, and with
380             # the file names used here...
381 5   50     56 $options{remap} //= "";
382              
383             # GNU Free Fonts.
384             # http://ftp.gnu.org/gnu/freefont/freefont-ttf-20120503.zip
385 5 50       41 if ( $options{remap} =~ /^(?:gnu[-_]?)?free(?:[-_]?fonts)?$/i ) {
    50          
    50          
386 0         0 remap( 'Times-Roman' => "FreeSerif.ttf",
387             'Times-BoldItalic' => "FreeSerifBoldItalic.ttf",
388             'Times-Bold' => "FreeSerifBold.ttf",
389             'Times-Italic' => "FreeSerifItalic.ttf",
390             'Helvetica' => "FreeSans.ttf",
391             'Helvetica-BoldOblique' => "FreeSansBoldOblique.ttf",
392             'Helvetica-Bold' => "FreeSansBold.ttf",
393             'Helvetica-Oblique' => "FreeSansOblique.ttf",
394             'Courier' => "FreeMono.ttf",
395             'Courier-BoldOblique' => "FreeMonoBoldOblique.ttf",
396             'Courier-Bold' => "FreeMonoBold.ttf",
397             'Courier-Oblique' => "FreeMonoOblique.ttf",
398             );
399             }
400              
401             # TeX Gyre fonts.
402             # https://www.gust.org.pl/projects/e-foundry/tex-gyre/whole/tg2_501otf.zip
403             elsif ( $options{remap} =~ /^tex(?:[-_]?gyre)?$/i ) {
404 0         0 remap( 'Times-Roman' => "texgyretermes-regular.otf",
405             'Times-BoldItalic' => "texgyretermes-bolditalic.otf",
406             'Times-Bold' => "texgyretermes-bold.otf",
407             'Times-Italic' => "texgyretermes-italic.otf",
408             'Helvetica' => "texgyreheros-regular.otf",
409             'Helvetica-BoldOblique' => "texgyreheros-bolditalic.otf",
410             'Helvetica-Bold' => "texgyreheros-bold.otf",
411             'Helvetica-Oblique' => "texgyreheros-italic.otf",
412             'Courier' => "texgyrecursor-regular.otf",
413             'Courier-BoldOblique' => "texgyrecursor-bolditalic.otf",
414             'Courier-Bold' => "texgyrecursor-bold.otf",
415             'Courier-Oblique' => "texgyrecursor-italic.otf",
416             );
417             }
418             elsif ( $options{remap} ) {
419 0         0 croak("Unrecognized core remap set");
420             }
421             }
422              
423             =over
424              
425             =item remap($font)
426              
427             =item remap( $src => $dst, ... )
428              
429             Handles font remapping. The main purpose is to remap corefonts to real
430             fonts.
431              
432             With a single argument, returns the remapped value, or undef if none.
433              
434             With a hash argument, maps each of the targets (keys) to a font file
435             (value). This file must be present in one of the font directories.
436              
437             Alternatively, the key may be one of C, C and
438             C and the value an already registered family.
439              
440             =back
441              
442             =cut
443              
444             sub remap {
445 3 50   3 1 14 shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
446              
447 3 50       32 return $maps{$_[0]} if @_ == 1;
448              
449 0         0 my %m = @_;
450 0         0 while ( my ($k, $v ) = each %m ) {
451              
452             # Check for family map.
453 0 0 0     0 if ( $k =~ /^(Courier|Times|Helvetica)$/
454             && defined $fonts{lc $v} ) {
455 0 0       0 if ( $k eq 'Courier' ) {
    0          
    0          
456 0         0 $maps{'Courier'} = $fonts{lc $v}{normal}{normal}{loader_data};
457 0         0 $maps{'Courier-Bold'} = $fonts{lc $v}{normal}{bold}{loader_data};
458 0         0 $maps{'Courier-Oblique'} = $fonts{lc $v}{italic}{normal}{loader_data};
459 0         0 $maps{'Courier-BoldOblique'} = $fonts{lc $v}{italic}{bold}{loader_data};
460             }
461             elsif ( $k eq 'Helvetica' ) {
462 0         0 $maps{'Helvetica'} = $fonts{lc $v}{normal}{normal}{loader_data};
463 0         0 $maps{'Helvetica-Bold'} = $fonts{lc $v}{normal}{bold}{loader_data};
464 0         0 $maps{'Helvetica-Oblique'} = $fonts{lc $v}{italic}{normal}{loader_data};
465 0         0 $maps{'Helvetica-BoldOblique'} = $fonts{lc $v}{italic}{bold}{loader_data};
466             }
467             elsif ( $k eq 'Times' ) {
468 0         0 $maps{'Times-Roman'} = $fonts{lc $v}{normal}{normal}{loader_data};
469 0         0 $maps{'Times-Bold'} = $fonts{lc $v}{normal}{bold}{loader_data};
470 0         0 $maps{'Times-Italic'} = $fonts{lc $v}{italic}{normal}{loader_data};
471 0         0 $maps{'Times-BoldItalic'} = $fonts{lc $v}{italic}{bold}{loader_data};
472             }
473 0         0 next;
474             }
475              
476             # Map font to corefont.
477 0         0 my $ff;
478 0 0       0 if ( $v =~ m;^/; ) {
479 0 0       0 $ff = $v if -r -s $v;
480             }
481             else {
482 0         0 foreach ( @dirs ) {
483 0 0       0 next unless -r -s "$_/$v";
484 0         0 $ff = "$_/$v";
485 0         0 last;
486             }
487             }
488              
489 0 0       0 $maps{$k} = $ff
490             or carp("Invalid font mapping ($v: $!)")
491              
492             }
493              
494 0         0 1;
495             }
496              
497             =over
498              
499             =item find_font( $family, $style, $weight )
500              
501             Returns a font descriptor based on the given family, style and weight.
502              
503             On Linux, fallback using fontconfig.
504              
505             =back
506              
507             =cut
508              
509             sub find_font {
510 27 100   27 1 108 shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
511 27         40 my $atts;
512 27 50       116 $atts = pop(@_) if UNIVERSAL::isa( $_[-1], 'HASH' );
513 27         64 my ( $family, $style, $weight ) = @_;
514 27 50       83 warn("FC: find_font( $family, $style, $weight )\n") if $debug;
515              
516             my $try = sub {
517 27 50 33 27   211 if ( $fonts{$family}
      33        
518             && $fonts{$family}->{$style}
519             && $fonts{$family}->{$style}->{$weight} ) {
520              
521 27         55 my $ff = $fonts{$family}->{$style}->{$weight};
522 27         143 my %i = ( family => $family,
523             style => $style,
524             weight => $weight );
525             ;
526 27 50       89 if ( $ff->{font} ) {
    50          
527 0         0 $i{font} = $ff->{font};
528             }
529             elsif ( $ff->{loader_data} ) {
530 27         91 $i{loader_data} = $ff->{loader_data};
531 27         61 $i{loader} = $loader;
532 27         54 $i{cache} = $ff;
533             }
534             else {
535 0         0 return;
536             }
537              
538 27         58 for ( qw( shaping ascender descender nosubset direction language
539             underline_thickness underline_position
540             strikeline_thickness strikeline_position
541             overline_thickness overline_position
542             ) ) {
543 324         589 $i{$_} = $ff->{$_};
544             }
545              
546 27 50       56 if ( $debug ) {
547             warn("FC: found( $i{family}, $i{style}, $i{weight} ) -> ",
548 0         0 $i{loader_data}, "\n");
549             }
550 27         187 return Text::Layout::FontDescriptor->new(%i);
551             }
552 27         134 };
553              
554 27   50     91 $style = _norm_style( $style // "normal" );
555 27   50     80 $weight = _norm_weight( $weight // "normal" );
556 27         56 my $res = $try->();
557 27 50       252 return $res if $res;
558              
559             # TODO: Some form of font fallback.
560 0 0       0 if ( _fallback( $family, $style, $weight ) ) {
561 0         0 $res = $try->();
562 0 0       0 return $res if $res;
563             }
564              
565             # Nope.
566 0         0 croak("Cannot find font: $family $style $weight\n");
567             }
568              
569             =over
570              
571             =item from_string( $description )
572              
573             Returns a font descriptor using a Pango-style font description, e.g.
574             C.
575              
576             On Linux, fallback using fontconfig.
577              
578             =back
579              
580             =cut
581              
582             my $stylep = qr/^(?:heavy|bold|semi(?:bold)?|medium|book|light)? (oblique|italic)$/ix;
583             my $weightp = qr/^(heavy|bold|semi(?:bold)?|medium|book|light) (?:oblique|italic)?$/ix;
584              
585             sub from_string {
586 7 50   7 1 50 shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
587 7         20 my ( $description ) = @_;
588              
589 7         47 my $i = parse($description);
590              
591 7         51 my $res = find_font( $i->{family}, $i->{style}, $i->{weight} );
592 7 50 33     23 $res->set_size($i->{size}) if $res && $i->{size};
593 7         64 $res;
594             }
595              
596             =over
597              
598             =item parse( $description )
599              
600             Parses a Pango-style font description and returns a hash ref with keys
601             C, C