tools/mkttfinfo

   1 #!/usr/bin/env perl
   2 use 5.014;
   3 use strict;
   4 use warnings;
   5
   6 use Data::Dump 'pp';
   7 use Font::TTF::Font;
   8 use Getopt::Long;
   9 use Cwd 'abs_path';
  10
  11 our $VERSION = '1.01';
  12
  13 GetOptions(\my %opt,
  14         'verbose|v!',
  15 );
  16
  17 my ($ttfuri, $outfile) = @ARGV;
  18 $ttfuri or do {
  19         warn "usage error: input font not specified\n";
  20         exit 64; # EX_USAGE
  21 };
  22 -e $ttfuri or do {
  23         warn "font not found: $ttfuri\n";
  24         exit 66; # EX_NOINPUT
  25 };
  26
  27 for ($outfile || ()) {
  28         open my $output, '>', $_ or die "Cannot write to $outfile: $!\n";
  29         select $output;
  30 }
  31
  32 {
  33         my $ttf = Font::TTF::Font->open($ttfuri) or do {
  34                 warn "Cannot open truetype in $ttfuri: $!";
  35                 exit 65; # EX_DATAERR
  36         };
  37
  38         my $ttfname = ($ttfuri =~ m{([^/.]+) (?:[.]ttf)? \z}msx)[0];
  39         my $ttfmeta = $ttf->{name}->read;
  40         my %meta = (
  41                 source   => abs_path($ttfuri) =~ m{(^/usr/.+ | [^/]+) \z}msx,
  42                 name     => $ttfmeta->find_name(4) || $ttfname,
  43                 revision => sprintf('%g', $ttf->{head}->{fontRevision}),
  44                 version  => $ttfmeta->find_name(5) =~ s/\Aversion //ri =~ s/\s+\z//r,
  45                 copyright=> scalar $ttfmeta->find_name(0),
  46                 license  => $ttfmeta->find_name(14) || undef,
  47                 date     => (map {
  48                         $_ && eval {
  49                                 require Time::Piece;
  50                                 Time::Piece->new($_)->datetime;
  51                         }
  52                 } $ttf->{head}->getdate),
  53         );
  54         $meta{abbr} = lc join '', $meta{name} =~ s/ MS$//r =~ m{
  55                 (?!Sans) (?<! [0-9]) ([[:upper:]0-9])
  56         }gx;
  57
  58         say "# automatically generated by $0";
  59         say '+', pp(\%meta), ',';
  60
  61         my $support = $ttf->{cmap}->find_ms->{val};
  62         warn scalar keys %$support, " characters read from $ttfname\n"
  63                 if $opt{verbose};
  64         say pp(sort { $a <=> $b } keys %$support);
  65 }
  66
  67 __END__
  68
  69 =head1 NAME
  70
  71 mkttfinfo - Extract character coverage and metadata in TrueType font
  72
  73 =head1 SYNOPSIS
  74
  75     mkttfinfo [-v] <font.ttf> [<output.inc.pl>]
  76
  77 =head1 AUTHOR
  78
  79 Mischa POSLAWSKY <perl@shiar.org>
  80
  81 =head1 LICENSE
  82
  83 Licensed under the GNU Affero General Public License version 3.
  84