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