3198beed2d24984363dc57016dbc80ec5ce22c72
[librarian.git] / 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 }