+++ /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