1 files changed, 90 insertions, 0 deletions
diff --git a/FONTVER.pl b/FONTVER.pl
new file mode 100755
index 000000000000..36a91d14225e
--- /dev/null
+++ b/FONTVER.pl
@@ -0,0 +1,90 @@
+#!/usr/bin/perl
+
+# Extract from ttf: Version 0.00 Font Name Bold
+# Extract from ttc: Version 0.00 Batang; Batang Bold(0.01)
+# This program is slow
+use warnings;
+#http://www.perlmonks.org/bare/?node_id=224506
+use strict;
+use Font::TTF::Font;
+use Font::TTF::Ttc;
+
+my $rv=1;
+if ( $#ARGV >= 0 ) {
+  my $f = $ARGV[0];
+  my $ttc = Font::TTF::Ttc->open($f); # hash ref
+  if (ref $ttc) {
+    my $firstsp=''; # Version 0.00 or '; '
+    my $firstvershort=''; # 0.00 or blank if same as first
+    my $langs='x';
+    my $ttf;
+    foreach $ttf (@{$ttc->{directs}}) {
+      my $fnar;
+      if ($fnar = $ttf->{name}) {
+        my $fr=$fnar->read();
+        my $verlong=$fr->find_name(5);
+        $firstsp=$verlong.' ' if (length($firstsp)==0);
+        my $vershort=$verlong;
+        if ($verlong =~ m/Version ([0-9\.]+)/ ) {
+          $vershort=$1;
+        }
+        $firstvershort=$vershort if (length($firstvershort)==0);
+        if ($vershort eq $firstvershort) {
+          $vershort='';
+        } else {
+          $vershort='('.$vershort.')'; # Show (version) on each font if different
+        }
+        my @neid=$fr->find_name(4);
+        if (length($langs) != 0) {
+             $langs='';
+          my $langsfirst='';
+          foreach (keys %{$fnar->{'strings'}[5][3][1]}) {
+            if ($_ != 0x409) {
+              $langs .= $langsfirst.$fnar->get_lang($neid[1], $_);
+              $langsfirst=',';
+            }
+          }
+          $langs=$fnar->get_lang($neid[1],0x409) if (length($langs)==0);
+          $langs .= ' ';
+        }
+        print $langs.$firstsp.$neid[0].$vershort;
+        $firstsp='; ';
+        $langs='';
+        $rv=0;
+      }
+    }
+    print "\n" if ($rv eq 0);
+    $ttc->DESTROY();
+  } else {
+    my $ttf = Font::TTF::Font->open($f);
+    if (ref $ttf) {
+      my $fnar;
+      if ($fnar = $ttf->{name}) {
+        my $fr=$fnar->read();
+        #for(my $test=0; $test<200; $test++) { my @testar=$fr->find_name($test); print STDERR $test,",",$testar[3],'-',$testar[0],"\n"; }
+        #foreach ($fr) { print STDERR $_[3],'-',$_[0],"\n"; }
+# http://www.microsoft.com/typography/otspec/name.htm Name IDs
+        my @neid=$fr->find_name(4);
+
+        #foreach (keys %{$fnar->{'strings'}[5][3][1]}) { printf STDERR "lang=%04X %s\n",$_,$fnar->get_lang($neid[1], $_); }
+        my $langs='';
+        my $langsfirst='';
+        foreach (keys %{$fnar->{'strings'}[5][3][1]}) {
+          if ($_ != 0x409) {
+            $langs .= $langsfirst.$fnar->get_lang($neid[1], $_);
+            $langsfirst=',';
+          }
+        }
+        $langs=$fnar->get_lang($neid[1],0x409) if (length($langs)==0);
+
+        print $langs.' '.$fr->find_name(5)." ".$neid[0],"\n";
+        $rv=0;
+      }
+      $ttf->release();
+    }
+  }
+} else {
+  print "Usage: $0 foo.tt[fc]\n";
+  print "Result: Version 1.05 Foo Narrow Bold Italic FB ITC\n";
+}
+exit($rv);