librarian/font-optimizer/modify-names.pl

   1 #!/usr/bin/perl -CA
   2   # use the -CA flag so @ARGV is interpreted as UTF-8
   3
   4 use strict;
   5 use warnings;
   6
   7 binmode STDOUT, ':utf8';
   8
   9 use lib 'ext/Font-TTF/lib';
  10 use Font::TTF::Font;
  11
  12 my @name_strings = qw(
  13     copyright
  14     family
  15     subfamily
  16     unique-identifier
  17     full-name
  18     version
  19     postscript
  20     trademark
  21     manufacturer
  22     designer
  23     description
  24     vendor-url
  25     designer-url
  26     license
  27     license-url
  28     RESERVED
  29     preferred-family
  30     preferred-subfamily
  31     compatible-full
  32     sample-text
  33     postscript-cid
  34     wws-family
  35     wws-subfamily
  36 );
  37 my %name_strings;
  38 $name_strings{$name_strings[$_]} = $_ for 0..$#name_strings;
  39
  40 main();
  41
  42 sub help {
  43     print <<EOF;
  44 This tool provides a (relatively) simple way to manipulate the 'name' table of
  45 TrueType/OpenType fonts.
  46
  47 Usage:
  48   $0 [options] [commands] [inputfile.ttf] [outputfile.ttf]
  49
  50 Options:
  51   --verbose, -v         print various details about the modifications made
  52
  53 Any sequence of the following commands:
  54   --print                             print the font's current name strings
  55   --set [name] [string]               replace the name string's value
  56   --append [name] [string]            append to the name string's value
  57   --subst [name] [string1] [string2]  replace all occurrences of [string1]
  58                                       with [string2] in the name string's value
  59
  60 "[name]" can be any of the following: (see the Name ID table on
  61 http://www.microsoft.com/typography/otspec/name.htm for full explanations)
  62
  63     copyright, family, subfamily, unique-identifier, full-name, version,
  64     postscript, trademark, manufacturer, designer, description, vendor-url,
  65     designer-url, license, license-url, preferred-family, preferred-subfamily,
  66     compatible-full, sample-text, postscript-cid, wws-family, wws-subfamily
  67
  68 EOF
  69
  70     exit 1;
  71 }
  72
  73 sub modify_name {
  74     my ($font, $id, $sub) = @_;
  75     my $str = $font->{name}{strings}[$id];
  76     my $exists = 0;
  77     for my $plat (0..$#$str) {
  78         next unless $str->[$plat];
  79         for my $enc (0..$#{$str->[$plat]}) {
  80             next unless $str->[$plat][$enc];
  81             for my $lang (keys %{$str->[$plat][$enc]}) {
  82                 next unless exists $str->[$plat][$enc]{$lang};
  83                 my $val = $sub->($str->[$plat][$enc]{$lang}, $plat, $enc, $lang);
  84                 $str->[$plat][$enc]{$lang} = $val;
  85                 $exists = 1
  86             }
  87         }
  88     }
  89     if (not $exists) {
  90         warn "Can't find existing name string '$name_strings[$id]' ($id)\n";
  91     }
  92 }
  93
  94
  95 sub json_string {
  96     my ($str) = @_;
  97     $str =~ s/([\\"])/\\$1/g;
  98     $str =~ s/\r/\\r/g;
  99     $str =~ s/\n/\\n/g;
 100     $str =~ s/\t/\\t/g;
 101     $str =~ s/([\x00-\x1f])/sprintf '\u%04X', ord $1/eg;
 102     return qq{"$str"};
 103 }
 104
 105 sub print_names {
 106     my ($font) = @_;
 107     my @lines;
 108     for my $nid (0..$#name_strings) {
 109         my $name = $font->{name}->find_name($nid);
 110         if (length $name) {
 111             push @lines, json_string($name_strings[$nid]).': '.json_string($name);
 112         }
 113     }
 114
 115     print "{\n";
 116     print join ",\n\n", @lines;
 117     print "\n}\n";
 118 }
 119
 120 sub parse_id {
 121     my ($name) = @_;
 122     if ($name =~ /^\d+$/ and $name < @name_strings) {
 123         return int $name;
 124     }
 125     my $id = $name_strings{lc $name};
 126     return $id if defined $id;
 127     warn "Invalid name string identifier '$name'\n\n";
 128     help();
 129 }
 130
 131 sub main {
 132     my $verbose = 0;
 133     my $print = 0;
 134     my @commands;
 135
 136     my @args = @ARGV;
 137     my @rest;
 138     while (@args) {
 139         $_ = shift @args;
 140         if ($_ eq '-v' or $_ eq '--verbose') {
 141             $verbose = 1;
 142         } elsif ($_ eq '-p' or $_ eq '--print') {
 143             $print = 1;
 144             push @commands, [ 'print' ];
 145         } elsif ($_ eq '--set') {
 146             @args >= 2 or help();
 147             my $id = parse_id(shift @args);
 148             my $val = shift @args;
 149             push @commands, [ 'set', $id, $val ];
 150         } elsif ($_ eq '--append') {
 151             @args >= 2 or help();
 152             my $id = parse_id(shift @args);
 153             my $val = shift @args;
 154             push @commands, [ 'append', $id, $val ];
 155         } elsif ($_ eq '--subst') {
 156             @args >= 3 or help();
 157             my $id = parse_id(shift @args);
 158             my $val1 = shift @args;
 159             my $val2 = shift @args;
 160             push @commands, [ 'subst', $id, $val1, $val2 ];
 161         } else {
 162             push @rest, $_;
 163         }
 164     }
 165
 166     ($print and (@rest == 1 or @rest == 2)) or @rest == 2 or help();
 167
 168     my ($input_file, $output_file) = @rest;
 169
 170     my $font = Font::TTF::Font->open($input_file) or die "Error opening $input_file: $!";
 171
 172     $font->{name}->read;
 173
 174     for my $cmd (@commands) {
 175         if ($cmd->[0] eq 'print') {
 176             print_names($font);
 177         } elsif ($cmd->[0] eq 'set') {
 178             my $id = $cmd->[1];
 179             modify_name($font, $id, sub {
 180                 my ($val, $plat, $enc, $lang) = @_;
 181                 print "Setting string $id (platform=$plat encoding=$enc lang=$lang)\n" if $verbose;
 182                 return $cmd->[2];
 183             });
 184         } elsif ($cmd->[0] eq 'append') {
 185             my $id = $cmd->[1];
 186             modify_name($font, $id, sub {
 187                 my ($val, $plat, $enc, $lang) = @_;
 188                 print "Appending to string $id (platform=$plat encoding=$enc lang=$lang)\n" if $verbose;
 189                 return $val . $cmd->[2];
 190             });
 191         } elsif ($cmd->[0] eq 'subst') {
 192             my $id = $cmd->[1];
 193             modify_name($font, $id, sub {
 194                 my ($val, $plat, $enc, $lang) = @_;
 195                 my $pat = quotemeta($cmd->[2]);
 196                 my $n = ($val =~ s/$pat/$cmd->[3]/g) || 0;
 197                 print "Substituting string $id (platform=$plat encoding=$enc lang=$lang) - $n match(es)\n" if $verbose;
 198                 warn "No match found for substitution on string '$name_strings[$id]'\n" if not $n;
 199                 return $val;
 200             });
 201         } else {
 202             die;
 203         }
 204     }
 205
 206     $font->out($output_file) if $output_file;
 207
 208     $font->release;
 209 }