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.00';
  12
  13 GetOptions(\my %opt,
  14         'verbose|v!',
  15 );
  16
  17 my ($ttfuri, $outfile) = @ARGV;
  18 $ttfuri or die "usage error\n";
  19
  20 my $fontinc = $ENV{FONTINC} // 'data/font,~/.fonts,/usr/share/fonts/truetype/*';
  21 if (!-e $ttfuri) {
  22         my $found = (grep {-e} glob "{$fontinc}/$ttfuri")[0] or do {
  23                 warn "font not found: $ttfuri\n";
  24                 exit 1;
  25         };
  26         $ttfuri = $found;
  27 }
  28
  29 for ($outfile || ()) {
  30         open my $output, '>', $_ or die "Cannot write to $outfile: $!\n";
  31         select $output;
  32 }
  33
  34 {
  35         my $ttf = Font::TTF::Font->open($ttfuri)
  36                 or die "Cannot open truetype in $ttfuri: $!";
  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