--- /dev/null
+#!/usr/bin/perl -CA
+ # use the -CA flag so @ARGV is interpreted as UTF-8
+
+use strict;
+use warnings;
+
+binmode STDOUT, ':utf8';
+
+use lib 'ext/Font-TTF/lib';
+use Font::TTF::Font;
+
+my @name_strings = qw(
+ copyright
+ family
+ subfamily
+ unique-identifier
+ full-name
+ version
+ postscript
+ trademark
+ manufacturer
+ designer
+ description
+ vendor-url
+ designer-url
+ license
+ license-url
+ RESERVED
+ preferred-family
+ preferred-subfamily
+ compatible-full
+ sample-text
+ postscript-cid
+ wws-family
+ wws-subfamily
+);
+my %name_strings;
+$name_strings{$name_strings[$_]} = $_ for 0..$#name_strings;
+
+main();
+
+sub help {
+ print <<EOF;
+This tool provides a (relatively) simple way to manipulate the 'name' table of
+TrueType/OpenType fonts.
+
+Usage:
+ $0 [options] [commands] [inputfile.ttf] [outputfile.ttf]
+
+Options:
+ --verbose, -v print various details about the modifications made
+
+Any sequence of the following commands:
+ --print print the font's current name strings
+ --set [name] [string] replace the name string's value
+ --append [name] [string] append to the name string's value
+ --subst [name] [string1] [string2] replace all occurrences of [string1]
+ with [string2] in the name string's value
+
+"[name]" can be any of the following: (see the Name ID table on
+http://www.microsoft.com/typography/otspec/name.htm for full explanations)
+
+ copyright, family, subfamily, unique-identifier, full-name, version,
+ postscript, trademark, manufacturer, designer, description, vendor-url,
+ designer-url, license, license-url, preferred-family, preferred-subfamily,
+ compatible-full, sample-text, postscript-cid, wws-family, wws-subfamily
+
+EOF
+
+ exit 1;
+}
+
+sub modify_name {
+ my ($font, $id, $sub) = @_;
+ my $str = $font->{name}{strings}[$id];
+ my $exists = 0;
+ for my $plat (0..$#$str) {
+ next unless $str->[$plat];
+ for my $enc (0..$#{$str->[$plat]}) {
+ next unless $str->[$plat][$enc];
+ for my $lang (keys %{$str->[$plat][$enc]}) {
+ next unless exists $str->[$plat][$enc]{$lang};
+ my $val = $sub->($str->[$plat][$enc]{$lang}, $plat, $enc, $lang);
+ $str->[$plat][$enc]{$lang} = $val;
+ $exists = 1
+ }
+ }
+ }
+ if (not $exists) {
+ warn "Can't find existing name string '$name_strings[$id]' ($id)\n";
+ }
+}
+
+
+sub json_string {
+ my ($str) = @_;
+ $str =~ s/([\\"])/\\$1/g;
+ $str =~ s/\r/\\r/g;
+ $str =~ s/\n/\\n/g;
+ $str =~ s/\t/\\t/g;
+ $str =~ s/([\x00-\x1f])/sprintf '\u%04X', ord $1/eg;
+ return qq{"$str"};
+}
+
+sub print_names {
+ my ($font) = @_;
+ my @lines;
+ for my $nid (0..$#name_strings) {
+ my $name = $font->{name}->find_name($nid);
+ if (length $name) {
+ push @lines, json_string($name_strings[$nid]).': '.json_string($name);
+ }
+ }
+
+ print "{\n";
+ print join ",\n\n", @lines;
+ print "\n}\n";
+}
+
+sub parse_id {
+ my ($name) = @_;
+ if ($name =~ /^\d+$/ and $name < @name_strings) {
+ return int $name;
+ }
+ my $id = $name_strings{lc $name};
+ return $id if defined $id;
+ warn "Invalid name string identifier '$name'\n\n";
+ help();
+}
+
+sub main {
+ my $verbose = 0;
+ my $print = 0;
+ my @commands;
+
+ my @args = @ARGV;
+ my @rest;
+ while (@args) {
+ $_ = shift @args;
+ if ($_ eq '-v' or $_ eq '--verbose') {
+ $verbose = 1;
+ } elsif ($_ eq '-p' or $_ eq '--print') {
+ $print = 1;
+ push @commands, [ 'print' ];
+ } elsif ($_ eq '--set') {
+ @args >= 2 or help();
+ my $id = parse_id(shift @args);
+ my $val = shift @args;
+ push @commands, [ 'set', $id, $val ];
+ } elsif ($_ eq '--append') {
+ @args >= 2 or help();
+ my $id = parse_id(shift @args);
+ my $val = shift @args;
+ push @commands, [ 'append', $id, $val ];
+ } elsif ($_ eq '--subst') {
+ @args >= 3 or help();
+ my $id = parse_id(shift @args);
+ my $val1 = shift @args;
+ my $val2 = shift @args;
+ push @commands, [ 'subst', $id, $val1, $val2 ];
+ } else {
+ push @rest, $_;
+ }
+ }
+
+ ($print and (@rest == 1 or @rest == 2)) or @rest == 2 or help();
+
+ my ($input_file, $output_file) = @rest;
+
+ my $font = Font::TTF::Font->open($input_file) or die "Error opening $input_file: $!";
+
+ $font->{name}->read;
+
+ for my $cmd (@commands) {
+ if ($cmd->[0] eq 'print') {
+ print_names($font);
+ } elsif ($cmd->[0] eq 'set') {
+ my $id = $cmd->[1];
+ modify_name($font, $id, sub {
+ my ($val, $plat, $enc, $lang) = @_;
+ print "Setting string $id (platform=$plat encoding=$enc lang=$lang)\n" if $verbose;
+ return $cmd->[2];
+ });
+ } elsif ($cmd->[0] eq 'append') {
+ my $id = $cmd->[1];
+ modify_name($font, $id, sub {
+ my ($val, $plat, $enc, $lang) = @_;
+ print "Appending to string $id (platform=$plat encoding=$enc lang=$lang)\n" if $verbose;
+ return $val . $cmd->[2];
+ });
+ } elsif ($cmd->[0] eq 'subst') {
+ my $id = $cmd->[1];
+ modify_name($font, $id, sub {
+ my ($val, $plat, $enc, $lang) = @_;
+ my $pat = quotemeta($cmd->[2]);
+ my $n = ($val =~ s/$pat/$cmd->[3]/g) || 0;
+ print "Substituting string $id (platform=$plat encoding=$enc lang=$lang) - $n match(es)\n" if $verbose;
+ warn "No match found for substitution on string '$name_strings[$id]'\n" if not $n;
+ return $val;
+ });
+ } else {
+ die;
+ }
+ }
+
+ $font->out($output_file) if $output_file;
+
+ $font->release;
+}
fnp / librarian.git / blobdiff