bin/ttfcoverage

   1 #!/usr/bin/perl
   2 # a coverage script
   3 # depends on Unicode::UCD and Font::TTF
   4 # by Martin Hosken
   5 # small tweaks by Nicolas Spalinger
   6
   7 use Font::TTF::Font;
   8 use Unicode::UCD qw(charblocks charblock charscripts charscript);
   9 use Getopt::Std;
  10
  11 getopts('s');
  12
  13 my $blocks, $stats;
  14
  15 if ($opt_s)
  16 {
  17     $blocks = charscripts;
  18 }
  19 else
  20 {
  21     $blocks = charblocks;
  22 }
  23
  24 foreach (keys %{$blocks})
  25 {
  26     foreach $r (@{$blocks->{$_}})
  27     { $stats->{$_}[0] += ($r->[1] - $r->[0]) + 1; }
  28 }
  29
  30 $f = Font::TTF::Font->open($ARGV[0]) || die "Can't open font $ARGV[0]";
  31 $cmap = $f->{'cmap'}->read->find_ms->{'val'};
  32
  33 foreach $c (keys %{$cmap})
  34 {
  35     $r = $opt_s ? charscript($c) : charblock($c);
  36     $stats->{$r}[1]++;
  37 }
  38
  39 foreach (sort keys %{$stats})
  40 {
  41     next unless ($_ && $stats->{$_}[1]);
  42     printf "%s: %d/%d (%.2f%%)\n", $_, $stats->{$_}[1], $stats->{$_}[0], $stats->{$_}[1] / $stats->{$_}[0] * 100.;
  43 }
  44