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 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 my %FONTID = (
  34         'Times New Roman' => 'times',
  35         'DejaVu Sans'     => 'dv ss',
  36         'DejaVu Serif'    => 'dv serif',
  37         'DejaVu Sans Mono'=> 'dv mono',
  38         'Code2000'        => 'c2k',
  39         'GNU Unifont'     => 'guf',
  40         'Droid Sans'      => 'droid',
  41         'Droid Serif'     => 'droid serif',
  42         'Droid Sans Mono' => 'droid mono',
  43 );
  44
  45 {
  46         my $ttf = Font::TTF::Font->open($ttfuri)
  47                 or die "Cannot open truetype in $ttfuri: $!";
  48
  49         my $ttfname = ($ttfuri =~ m{([^/.]+) (?:[.]ttf)? \z}msx)[0];
  50         my $ttfmeta = $ttf->{name}->read;
  51         my %meta = (
  52                 source   => $ttfuri =~ m{(^/usr/.+ | [^/]+) \z}msx,
  53                 name     => $ttfmeta->find_name(4) || $ttfname,
  54                 revision => $ttf->{head}->{fontRevision},
  55                 version  => scalar $ttfmeta->find_name(5),
  56                 copyright=> scalar $ttfmeta->find_name(0),
  57                 license  => $ttfmeta->find_name(14) || undef,
  58                 date     => (map {
  59                         $_ && eval {
  60                                 require Time::Piece;
  61                                 Time::Piece->new($_)->datetime;
  62                         }
  63                 } $ttf->{head}->getdate),
  64         );
  65         $meta{id} = $FONTID{ $meta{name} } // lc $ttfname;
  66         say "# automatically generated by $0";
  67         say '+', pp(\%meta), ',';
  68
  69         my $support = $ttf->{cmap}->find_ms->{val};
  70         warn scalar keys %$support, " characters read from $ttfname\n"
  71                 if $opt{verbose};
  72         say pp(sort { $a <=> $b } keys %$support);
  73 }
  74
  75 __END__
  76
  77 =head1 NAME
  78
  79 mkttfinfo - Extract character coverage and metadata in TrueType font
  80
  81 =head1 SYNOPSIS
  82
  83     mkttfinfo [-v] <font.ttf> [<output.inc.pl>]
  84
  85 =head1 AUTHOR
  86
  87 Mischa POSLAWSKY <perl@shiar.org>
  88
  89 =head1 LICENSE
  90
  91 Licensed under the GNU Affero General Public License version 3.
  92