tools/mkttfinfo

   1 #!/usr/bin/env perl
   2 use 5.010;
   3 use strict;
   4 use warnings;
   5
   6 use Data::Dump 'pp';
   7 use Font::TTF::Font;
   8
   9 my ($ttfuri, $outfile) = @ARGV;
  10 $ttfuri or die "usage error\n";
  11
  12 my $fontinc = $ENV{FONTINC} // '~/.fonts,/usr/share/fonts/truetype/*';
  13 if (!-e $ttfuri) {
  14         my $found = (grep {-e} glob "{$fontinc}/$ttfuri")[0] or do {
  15                 warn "font not found: $ttfuri\n";
  16                 exit 1;
  17         };
  18         $ttfuri = $found;
  19 }
  20
  21 for ($outfile || ()) {
  22         open my $output, '>', $_ or die "Cannot write to $outfile: $!\n";
  23         select $output;
  24 }
  25
  26 my %FONTID = (
  27         'Times New Roman' => 'times',
  28         'DejaVu Sans'     => 'dv ss',
  29         'DejaVu Serif'    => 'dv serif',
  30         'DejaVu Sans Mono'=> 'dv mono',
  31         'Code2000'        => 'c2k',
  32         'GNU Unifont'     => 'guf',
  33         'Droid Sans'      => 'droid',
  34         'Droid Serif'     => 'droid serif',
  35         'Droid Sans Mono' => 'droid mono',
  36 );
  37
  38 {
  39         my $ttf = Font::TTF::Font->open($ttfuri)
  40                 or die "Cannot open truetype in $ttfuri: $!";
  41
  42         my $ttfname = ($ttfuri =~ m{([^/.]+) (?:[.]ttf)? \z}msx)[0];
  43         my $ttfmeta = $ttf->{name}->read;
  44         my %meta = (
  45                 source   => $ttfuri =~ m{(^/usr/.+ | [^/]+) \z}msx,
  46                 name     => $ttfmeta->find_name(4) || $ttfname,
  47                 revision => $ttf->{head}->{fontRevision},
  48                 version  => scalar $ttfmeta->find_name(5),
  49                 copyright=> scalar $ttfmeta->find_name(0),
  50                 license  => $ttfmeta->find_name(14) || undef,
  51                 date     => (map {
  52                         $_ && eval {
  53                                 require Time::Piece;
  54                                 Time::Piece->new($_)->datetime;
  55                         }
  56                 } $ttf->{head}->getdate),
  57         );
  58         $meta{id} = $FONTID{ $meta{name} } // lc $ttfname;
  59         say pp(\%meta), ',';
  60
  61         my $support = $ttf->{cmap}->find_ms->{val};
  62         warn scalar keys %$support, " characters read from $ttfname\n";
  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 <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