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