—
—
—
—
—
—
—
—
—
—
—
—

              
#! perl
use strict;
use warnings;
use utf8;
package Text::Layout::FontConfig;
use Carp;
 our $VERSION = "0.039";
use Text::Layout::FontDescriptor;
HideShow 22 lines of Pod
=head1 NAME
Text::Layout::FontConfig - Pango style font description for Text::Layout
=head1 SYNOPSIS
Font descriptors are strings that identify the characteristics of the
desired font. For example, C<Sans Italic 20>.
The PDF context deals with physical fonts, e.g. built-in fonts like
C<Times-Bold> and fonts loaded from font files like
C</usr/share/fonts/dejavu/DejaVuSans.ttf>.
To map font descriptions to physical fonts, these fonts must be
registered. This defines a font family, style, and weight for the
font.
Note that Text::Layout::FontConfig is a singleton. Creating objects
with new() will always return the same object.
=cut
my %fonts;
my @dirs;
my %maps;
my $loader;
my $debug = 0;
my $weights =
  [ 100 => 'thin',
    100 => 'hairline',
    200 => 'extra light',
    200 => 'ultra light',
    300 => 'light',          # supported
    350 => 'book',           # supported
    400 => 'normal',         # supported
    400 => 'regular',                # supported
    500 => 'medium',         # supported
    600 => 'semi bold',              # supported 'semi'
    600 => 'demi bold',
    700 => 'bold',           # supported
    800 => 'extra bold',
    800 => 'ultra bold',
    900 => 'black',
    900 => 'heavy',          # supported
    950 => 'extra black',
    950 => 'ultra black',
  ];
HideShow 23 lines of Pod
=head2 METHODS
=over
=item new( [ atts... ] )
For convenience only. Text::Layout::FontConfig is a singleton.
Creating objects with new() will always return the same object.
Attributes:
=over
=item corefonts
If true, a predefined set of font names (the PDF corefonts) is registered.
=back
=back
=cut
sub new {
    my ( $pkg, %atts ) = @_;
    my $self = bless {} => $pkg;
    $debug = $self->{debug} = $atts{debug};
    if ( $atts{corefonts} ) {
        $self->register_corefonts;
    }
    if ( $atts{loader} ) {
        $loader = $atts{loader};
    }
    return $self;
}
sub reset {
    my ( $self ) = @_;
    warn("FC: Reset\n") if $debug;
    %fonts = ();
    @dirs = ();
    %maps = ();
}
sub debug { shift->{debug} }
HideShow 72 lines of Pod
=over
=item register_fonts( $font, $family, $style [ , $weight ] [ , $props ] )
Registers a font fmaily, style and weight for the given font.
$font can be the name of a built-in font, or the name of a TrueType or
OpenType font file.
$family is a font family name such as C<normal>, C<sans>, C<serif>, or
C<monospace>. It is possible to specify multiple family names, e.g.,
C<times, serif>.
$style is the slant style, one of C<normal>, C<oblique>, or C<italic>.
$weight is the font weight, like C<normal>, or C<bold>.
For convenience, style combinations like "bolditalic" are allowed.
A final hash reference can be passed to specify additional properties
for this font. Recognized properties are:
=over
=item *
C<shaping> - If set to a true value, this font will require text
shaping. This is required for fonts that deal with complex glyph
rendering and ligature handling like Devanagari.
Text shaping requires module L<HarfBuzz::Shaper>.
=item *
C<ascender> - If set overrides the font ascender.
This may be necessary to improve results for some fonts.
The value is expressed in 1/1000th of an em.
C<descender> - If set overrides the font descender.
This may be necessary to improve results for some fonts.
The value is expressed in 1/1000th of an em.
=item *
C<underline_thickness>, C<underline_position> - Overrides the font
specified or calculated values for underline thickness and/or position.
This may improve results for some fonts.
=item *
C<strikeline_thickness>, C<strikeline_position> - Overrides the font
specified or calculated values for strikeline thickness and/or position.
This may improve results for some fonts.
Note that strikeline thickness will default to underline thickness, if set.
=item *
C<overline_thickness>, C<overline_position> - Overrides the font
specified or calculated values for overline thickness and/or position.
This may improve results for some fonts.
Note that overline thickness will default to underline thickness, if
set.
=back
=back
=cut
sub register_font {
    shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
    my $props;
    $props = pop(@_) if UNIVERSAL::isa( $_[-1], 'HASH' );
    my ( $font, $family, $style, $weight ) = @_;
    if ( $style && !$weight && $style =~ s/^(heavy|bold|semi(?:bold)?|medium|book|light)//i ) {
        $weight = $1;
    }
    $style  = _norm_style( $style   // "normal" );
    $weight = _norm_weight( $weight // "normal" );
    my $ff;
    if ( $font =~ /\.[ot]tf$/ ) {
        if ( $font =~ m;^/; ) {
            $ff = $font if -r -s $font;
        }
        else {
            foreach ( @dirs ) {
                next unless -r -s "$_/$font";
                $ff = "$_/$font";
                last;
            }
        }
    }
    else {
        # Assume corefont.
        $ff = $font
    }
    croak("Cannot find font: ", $font, "\n") unless $ff;
    foreach ( split(/\s*,\s*/, $family) ) {
        $fonts{lc $_}->{$style}->{$weight}->{loader} = $loader;
        $fonts{lc $_}->{$style}->{$weight}->{loader_data} = $ff;
        warn("FC: Registered: $ff for ", lc($_), "-$style-$weight\n") if $debug;
        next unless $props;
        while ( my($k,$v) = each %$props ) {
            $fonts{lc $_}->{$style}->{$weight}->{$k} = $v;
        }
    }
}
HideShow 10 lines of Pod
=over
=item add_fontdirs( @dirs )
Adds one or more file paths to be searched for font files.
=back
=cut
sub add_fontdirs {
    shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
    my ( @d ) = @_;
    foreach ( @d ) {
        unless ( -d -r -x ) {
            carp("Skipped font dir: $_ [$!]");
            next;
        }
        push( @dirs, $_ );
    }
}
HideShow 18 lines of Pod
=over
=item register_aliases( $family, $aliases, ... )
Adds aliases for existing font families.
Multiple aliases can be specified, e.g.
    $layout->register_aliases( "times", "serif, default" );
or
    $layout->register_aliases( "times", "serif", "default" );
=back
=cut
sub register_aliases {
    use Storable qw(dclone);
    shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
    my ( $family, @aliases ) = @_;
    carp("Unknown font family: $family")
      unless exists $fonts{lc $family};
    foreach ( @aliases ) {
        foreach ( split( /\s*,\s*/, $_ ) ) {
            $fonts{lc $_} = dclone( $fonts{lc $family} );
        }
    }
}
HideShow 42 lines of Pod
=over
=item register_corefonts( %options )
This is a convenience method that registers all built-in corefonts.
Aliases for families C<serif>, C<sans>, and C<monospace> are added
unless $noaliases is specified.
You do not need to call this method if you provide your own font
registrations.
Options:
=over
=item aliases
If true, register Serif, Sans and Mono as aliases for Times,
Helvetica and Courier.
This is enabled by default and can be cancelled with C<noaliases>.
=item noaliases
If true, do not register Serif, Sans and Mono as aliases for Times,
Helvetica and Courier.
=item remap
Remap the core fonts to real TrueType or OpenType font files.
Supported values are C<GNU_Free_Fonts> or C<free> to use the GNU Free Fonts
(http://ftp.gnu.org/gnu/freefont/) and C<tex> or C<tex-gyre> for the
TeX Gyre fonts (https://www.gust.org.pl/projects/e-foundry/tex-gyre/).
=back
=back
=cut
sub register_corefonts {
    shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
    my %options;
    if ( @_ == 1 ) {
        $options{noaliases} = shift;
    }
    else {
        %options = @_;
    }
    my $noaliases = defined($options{aliases}) ? !$options{aliases} : $options{noaliases};
    warn("FC: Registering corefonts\n") if $debug;
    register_font( "Times-Roman",           "Times"                );
    register_font( "Times-Bold",            "Times", "Bold"        );
    register_font( "Times-Italic",          "Times", "Italic"      );
    register_font( "Times-BoldItalic",      "Times", "BoldItalic"  );
    register_aliases( "Times", "Serif" )
      unless $noaliases;
    register_font( "Helvetica",             "Helvetica"                 );
    register_font( "Helvetica-Bold",        "Helvetica",  "Bold"        );
    register_font( "Helvetica-Oblique",     "Helvetica",  "Oblique"     );
    register_font( "Helvetica-BoldOblique", "Helvetica",  "BoldOblique" );
    register_aliases( "Helvetica", "Sans", "Arial" )
      unless $noaliases;
    register_font( "Courier",               "Courier"                 );
    register_font( "Courier-Bold",          "Courier",  "Bold"        );
    register_font( "Courier-Oblique",       "Courier",  "Italic"      );
    register_font( "Courier-BoldOblique",   "Courier",  "BoldItalic"  );
    register_aliases( "Courier", "Mono", "Monospace", "fixed" )
      unless $noaliases;
    register_aliases( "Courier", "Mono", "Monospace", "fixed" )
      unless $noaliases;
    register_font( "ZapfDingbats",          "Dingbats"                );
    if ( 0 ) {
    register_font( "Georgia",               "Georgia"                );
    register_font( "Georgia,Bold",          "Georgia",  "Bold"        );
    register_font( "Georgia,Italic",        "Georgia",  "Italic"      );
    register_font( "Georgia,BoldItalic",    "Georgia",  "BoldItalic"  );
    register_font( "Verdana",               "Verdana"                );
    register_font( "Verdana,Bold",          "Verdana",  "Bold"        );
    register_font( "Verdana,Italic",        "Verdana",  "Italic"      );
    register_font( "Verdana,BoldItalic",    "Verdana",  "BoldItalic"  );
    register_font( "WebDings",              "WebDings"                );
    register_font( "WingDings",             "WingDings"               );
    }
    # Corefont remapping to real font files.
    # Biggest problem is to make sure the fonts are installed, and with
    # the file names used here...
    $options{remap} //= "";
    # GNU Free Fonts.
    # http://ftp.gnu.org/gnu/freefont/freefont-ttf-20120503.zip
    if ( $options{remap} =~ /^(?:gnu[-_]?)?free(?:[-_]?fonts)?$/i ) {
        remap( 'Times-Roman'             => "FreeSerif.ttf",
               'Times-BoldItalic'        => "FreeSerifBoldItalic.ttf",
               'Times-Bold'              => "FreeSerifBold.ttf",
               'Times-Italic'            => "FreeSerifItalic.ttf",
               'Helvetica'               => "FreeSans.ttf",
               'Helvetica-BoldOblique'   => "FreeSansBoldOblique.ttf",
               'Helvetica-Bold'          => "FreeSansBold.ttf",
               'Helvetica-Oblique'       => "FreeSansOblique.ttf",
               'Courier'                 => "FreeMono.ttf",
               'Courier-BoldOblique'     => "FreeMonoBoldOblique.ttf",
               'Courier-Bold'            => "FreeMonoBold.ttf",
               'Courier-Oblique'         => "FreeMonoOblique.ttf",
             );
    }
    # TeX Gyre fonts.
    # https://www.gust.org.pl/projects/e-foundry/tex-gyre/whole/tg2_501otf.zip
    elsif ( $options{remap} =~ /^tex(?:[-_]?gyre)?$/i ) {
        remap( 'Times-Roman'             => "texgyretermes-regular.otf",
               'Times-BoldItalic'        => "texgyretermes-bolditalic.otf",
               'Times-Bold'              => "texgyretermes-bold.otf",
               'Times-Italic'            => "texgyretermes-italic.otf",
               'Helvetica'               => "texgyreheros-regular.otf",
               'Helvetica-BoldOblique'   => "texgyreheros-bolditalic.otf",
               'Helvetica-Bold'          => "texgyreheros-bold.otf",
               'Helvetica-Oblique'       => "texgyreheros-italic.otf",
               'Courier'                 => "texgyrecursor-regular.otf",
               'Courier-BoldOblique'     => "texgyrecursor-bolditalic.otf",
               'Courier-Bold'            => "texgyrecursor-bold.otf",
               'Courier-Oblique'         => "texgyrecursor-italic.otf",
             );
    }
    elsif ( $options{remap} ) {
        croak("Unrecognized core remap set");
    }
}
HideShow 21 lines of Pod
=over
=item remap($font)
=item remap( $src => $dst, ... )
Handles font remapping. The main purpose is to remap corefonts to real
fonts.
With a single argument, returns the remapped value, or undef if none.
With a hash argument, maps each of the targets (keys) to a font file
(value). This file must be present in one of the font directories.
Alternatively, the key may be one of C<Times>, C<Helvetica> and
C<Courier> and the value an already registered family.
=back
=cut
sub remap {
    shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
    return $maps{$_[0]} if @_ == 1;
    my %m = @_;
    while ( my ($k, $v ) = each %m ) {
        # Check for family map.
        if ( $k =~ /^(Courier|Times|Helvetica)$/
             && defined $fonts{lc $v} ) {
            if ( $k eq 'Courier' ) {
                $maps{'Courier'}               = $fonts{lc $v}{normal}{normal}{loader_data};
                $maps{'Courier-Bold'}          = $fonts{lc $v}{normal}{bold}{loader_data};
                $maps{'Courier-Oblique'}       = $fonts{lc $v}{italic}{normal}{loader_data};
                $maps{'Courier-BoldOblique'}   = $fonts{lc $v}{italic}{bold}{loader_data};
            }
            elsif ( $k eq 'Helvetica' ) {
                $maps{'Helvetica'}             = $fonts{lc $v}{normal}{normal}{loader_data};
                $maps{'Helvetica-Bold'}        = $fonts{lc $v}{normal}{bold}{loader_data};
                $maps{'Helvetica-Oblique'}     = $fonts{lc $v}{italic}{normal}{loader_data};
                $maps{'Helvetica-BoldOblique'} = $fonts{lc $v}{italic}{bold}{loader_data};
            }
            elsif ( $k eq 'Times' ) {
                $maps{'Times-Roman'}           = $fonts{lc $v}{normal}{normal}{loader_data};
                $maps{'Times-Bold'}            = $fonts{lc $v}{normal}{bold}{loader_data};
                $maps{'Times-Italic'}          = $fonts{lc $v}{italic}{normal}{loader_data};
                $maps{'Times-BoldItalic'}      = $fonts{lc $v}{italic}{bold}{loader_data};
            }
            next;
        }
        # Map font to corefont.
        my $ff;
        if ( $v =~ m;^/; ) {
            $ff = $v if -r -s $v;
        }
        else {
            foreach ( @dirs ) {
                next unless -r -s "$_/$v";
                $ff = "$_/$v";
                last;
            }
        }
        $maps{$k} = $ff
          or carp("Invalid font mapping ($v: $!)")
      }
    1;
}
HideShow 12 lines of Pod
=over
=item find_font( $family, $style, $weight )
Returns a font descriptor based on the given family, style and weight.
On Linux, fallback using fontconfig.
=back
=cut
sub find_font {
    shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
    my $atts;
    $atts = pop(@_) if UNIVERSAL::isa( $_[-1], 'HASH' );
    my ( $family, $style, $weight ) = @_;
    warn("FC: find_font( $family, $style, $weight )\n") if $debug;
    my $try = sub {
        if ( $fonts{$family}
             && $fonts{$family}->{$style}
             && $fonts{$family}->{$style}->{$weight} ) {
            my $ff = $fonts{$family}->{$style}->{$weight};
            my %i = ( family => $family,
                      style  => $style,
                      weight => $weight );
;
            if ( $ff->{font} ) {
                $i{font} = $ff->{font};
            }
            elsif ( $ff->{loader_data} ) {
                $i{loader_data} = $ff->{loader_data};
                $i{loader}      = $loader;
                $i{cache}       = $ff;
            }
            else {
                return;
            }
            for ( qw( shaping ascender descender nosubset direction language
                      underline_thickness underline_position
                      strikeline_thickness strikeline_position
                      overline_thickness overline_position
                   ) ) {
                $i{$_} = $ff->{$_};
            }
            if ( $debug ) {
                warn("FC: found( $i{family}, $i{style}, $i{weight} ) -> ",
                     $i{loader_data}, "\n");
            }
            return Text::Layout::FontDescriptor->new(%i);
        }
    };
    $style  = _norm_style( $style   // "normal" );
    $weight = _norm_weight( $weight // "normal" );
    my $res = $try->();
    return $res if $res;
    # TODO: Some form of font fallback.
    if ( _fallback( $family, $style, $weight ) ) {
        $res = $try->();
        return $res if $res;
    }
    # Nope.
    croak("Cannot find font: $family $style $weight\n");
}
HideShow 13 lines of Pod
=over
=item from_string( $description )
Returns a font descriptor using a Pango-style font description, e.g.
C<Sans Italic 14>.
On Linux, fallback using fontconfig.
=back
=cut
my $stylep  = qr/^(?:heavy|bold|semi(?:bold)?|medium|book|light)? (oblique|italic)$/ix;
my $weightp = qr/^(heavy|bold|semi(?:bold)?|medium|book|light) (?:oblique|italic)?$/ix;
sub from_string {
    shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
    my ( $description ) = @_;
    my $i = parse($description);
    my $res = find_font( $i->{family}, $i->{style}, $i->{weight} );
    $res->set_size($i->{size}) if $res && $i->{size};
    $res;
}
HideShow 14 lines of Pod
=over
=item parse( $description )
Parses a Pango-style font description and returns a hash ref with keys
C<family>, C<style>, C<weight>, and C<size>.
Unspecified items are returned as empty strings or, in the case of
C<size>, zero.
=back
=cut
sub parse {
    shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
    my ( $description ) = @_;
    my $family = "";
    my $style  = "";
    my $weight = "";
    my $size   = 0;
    my @p = split( ' ', $description );
    $size = pop(@p) if $p[-1] =~ /^\d+(?:\.\d+)?$/;
    for ( @p ) {
        my $t = lc;
        if ( ! $family ) {
            $family = $t;
        }
        elsif ( $t =~ $stylep ) {
            $style = "italic";
            $weight = $1 if $t =~ $weightp;
        }
        elsif ( $t =~ $weightp ) {
            $weight = $1;
            $style = $1 if $t =~ $stylep;
        }
        elsif ( $t eq "normal" ) {
            $style = $weight = "";
        }
        else {
            carp("Unknown font property: $t");
            $family .= " " . $_;
        }
    }
    return { family => $family,
             style  => $style,
             weight => $weight,
             size   => $size,
           };
}
HideShow 11 lines of Pod
=over
=item from_filename( $filename )
Returns a font descriptor from a filename. Tries to infer Pango data
from the name.
=back
=cut
use File::Basename;
sub from_filename {
    shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
    my ( $file, $size ) = @_;
    my $b;
    ( $b, undef, undef ) = fileparse( $file, qr/\.\w+/ );
    my ( $family, $style, $weight ) = ( $b, "normal", "normal" );
    if ( lc($b) =~ m/^
                 ( .*? )
                 -?
                 (roman?|normal|regular)?
                 (light|book|medium|semi(?:bold)?|bold|heavy)?
                 (italic|ital|oblique|obli)?
                 $/ix ) {
        $family = $1       if $1;
        $style  = "italic" if $4;
        $weight = $3       if $3;
    }
    my $fd = Text::Layout::FontDescriptor->new
      ( loader_data => $file,
        loader => $loader,
        family => $family,
        style  => $style,
        weight => $weight,
        $size ? ( size => $size ) : (),
      );
    $fonts{$family}{$style}{$weight} //= $fd;
    return $fd;
}
################ Helper Routines ################
sub set_loader {
    shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
    $loader = shift;
    croak("Font loader must be a code reference")
      unless UNIVERSAL::isa( $loader, "CODE" );
}
# Normalize (and check) a style specification.
sub _norm_style {
    my ( $style ) = @_;
    $style = lc $style;
    return "italic" if $style =~ $stylep;
    carp("Unhandled font style: $style\n")
      unless $style =~ /^(regular|normal)?$/;
    return "normal";
}
# Normalize (and check) a weight specification.
sub _norm_weight {
    my ( $weight ) = @_;
    $weight = lc $weight;
    return $1 if $weight =~ $weightp;
    carp("Unhandled font weight: $weight\n")
      unless $weight =~ /^(regular|normal)?$/;
    return "normal";
}
my $fallback;
sub _fallback {
    unless ( defined $fallback ) {
        $fallback = '';
        foreach ( split( /:/, $ENV{PATH} ) ) {
            next unless -f -x "$_/fc-match";
            $fallback = "$_/fc-match";
            last;
        }
    }
    return unless $fallback;
    my ( $family, $style, $weight ) = @_;
    warn("FC: fallback( $family, $style, $weight )\n") if $debug;
    my $pattern = $family;
    $pattern .= ":$style" if $style;
    $pattern .= ":$weight" if $weight;
    open( my $fd, '-|',
          $fallback, '-s', '--format=%{file}\n', $pattern )
      or do { $fallback = ''; return };
    my $res;
    local $_;
    while ( <$fd> ) {
        chomp;
        next unless -f -r $_;
        next unless /\.[ot]tf$/i;
        $res = $_;
        last;
    }
    close($fd);
    register_font( $res, $family, $style, $weight ) if $res;
    warn("FC: Lookup $pattern -> $res\n") if $debug;
    return $res;
}
HideShow 28 lines of Pod
=head1 SEE ALSO
L<Text::Layout>, L<Text::Layout::FontDescriptor>.
=head1 AUTHOR
Johan Vromans, C<< <JV at CPAN dot org> >>
=head1 SUPPORT
This module is part of <Text::Layout>.
Development takes place on GitHub:
L<https://github.com/sciurius/perl-Text-Layout>.
You can find documentation for this module with the perldoc command.
  perldoc Text::Layout::FontConfig
Please report any bugs or feature requests using the issue tracker for
Text::Layout on GitHub.
=head1 LICENSE
See L<Text::Layout>, L<Text::Layout::FontDescriptor>, L<HarfBuzz::Shaper>.
=cut
sub _dump {
    foreach my $family ( sort keys %fonts ) {
        foreach my $style ( qw( normal italic ) ) {
            foreach my $weight ( qw( normal light book medium semi semibold bold heavy ) ) {
                my $f = $fonts{$family}{$style}{$weight};
                next unless $f;
                printf STDERR ( "%-13s %s%s%s%s%s %s\n",
                                $family,
                                $style eq 'normal' ? "-" : "i",
                                $weight eq 'bold' ? "b"
                                : $weight eq 'light' ? "l"
                                : $weight eq 'book' ? "k"
                                : $weight eq 'medium' ? "m"
                                : $weight eq 'semi' ? "s"
                                : $weight eq 'semibold' ? "s"
                                : $weight eq 'heavy' ? "h"
                                : "-",
                                $f->{shaping} ? "s" : "-",
                                $f->{interline} ? "l" : "-",
                                $f->{font} ? "+" : " ",
                                $f->{loader_data},
                              );
            }
        }
    }
}
# END { _dump }
1;