librarian/font-optimizer/gen-tests.pl

   1 # This script generates various 'interesting' fonts, and outputs an HTML file
   2 # containing the subsetted fonts and the original fonts.
   3 # View the output in browsers (preferably multiple, on multiple platforms) to
   4 # make sure the output looks the same as the original.
   5
   6 use strict;
   7 use warnings;
   8
   9 use lib 'ext/Font-TTF/lib';
  10 use Font::Subsetter;
  11 use Font::EOTWrapper;
  12 use Encode;
  13 use Clone;
  14
  15 use utf8;
  16
  17 # The following fonts need to exist in a directory called 'testfonts':
  18 my @all = qw(
  19     GenBasR.ttf
  20     GenR102.TTF
  21     LinLibertine_Re-4.1.8.ttf
  22     DoulosSILR.ttf
  23     DejaVuSans.ttf
  24     DejaVuSerif.ttf
  25     calibri.ttf
  26     FedraSansPro-Demi.ttf
  27 );
  28
  29 my $index = $ARGV[0];
  30 die "Run '$0', or '$0 n' where n is the number of the test to rebuild\n"
  31     if defined $index and $index !~ /^\d+$/;
  32
  33 my @tests = (
  34     # These aren't proper tests (they drop features that affect the rendering)
  35     # TODO: fix them so they are proper, and test that they're really dropping the
  36     # unneeded glyphs etc
  37 #     [ [qw(DejaVuSans.ttf FedraSansPro-Demi.ttf)], ["fluffily لا f"], [20], [qw(aalt ccmp dlig fina hlig init liga locl medi rlig salt kern mark mkmk)] ],
  38 #     [ [qw(DejaVuSans.ttf FedraSansPro-Demi.ttf)], ["fluffily لا f"], [20], [qw(liga)] ],
  39 #     [ [qw(DejaVuSans.ttf FedraSansPro-Demi.ttf)], ["fluffily لا f"], [20], [qw(fina init rlig)] ],
  40 #     [ [qw(DejaVuSans.ttf FedraSansPro-Demi.ttf)], ["fluffily لا f"], [20], [] ],
  41
  42     # Basic rendering
  43     [ [@all], ["Hello world ABC abc 123"], [20] ],
  44
  45     # Substitution and NFC issues
  46     [ [qw(GenBasR.ttf DejaVuSans.ttf FedraSansPro-Demi.ttf)], [
  47         "i",
  48         "\xec",
  49         "i\x{0300}",
  50         "i \x{0300}",
  51         "ixixi",
  52         "i<span class='h'>\x{0300}</span>",
  53     ], [20, 8] ],
  54     [ [qw(DejaVuSans.ttf FedraSansPro-Demi.ttf)], [
  55         "s\x{0323}\x{0307}", # s, combining dot below, combining dot above
  56         "s\x{0307}\x{0323}", # s, combining dot above, combining dot below
  57         "\x{1e61}\x{0323}", # s with dot above, combining dot below
  58         "\x{1e63}\x{0307}", # s with dot below, combining dot above
  59         "\x{212b}", # angstrom
  60     ], [20, 8] ],
  61
  62     # Ligature rendering
  63     [ [qw(LinLibertine_Re-4.1.8.ttf DejaVuSans.ttf FedraSansPro-Demi.ttf)], [
  64         "fluffily",
  65         "f<span>l</span>uf<span>f</span>ily",
  66         "f<span class='h'>l</span>uf<span class='h'>f</span>ily",
  67     ], [20, 8] ],
  68
  69     # GPOS issues
  70     [ [qw(DejaVuSans.ttf FedraSansPro-Demi.ttf calibri.ttf)],
  71         ["|VAVAV|", "ToToT", "x//x"], [20], ['kern'] ],
  72
  73     # Lots of stuff
  74     [ [@all], ["VABC(123) fTo fluffiest f<span class='h'>f</span>i!\@#,. \x{00e2}\x{00eb}I\x{0303}o\x{0300}u\x{030a}\x{0305}\x{0303} i\x{0331}\x{0301} \x{0d23}\x{0d4d}\x{200d} παρακαλώ хэлло  你好 表示问候 やあ التل<span class='h'>ف</span>ون הלו"], [20, 8] ],
  75
  76 );
  77
  78 my $common_css = <<EOF;
  79 body {
  80     font-family: Courier, monospace;
  81     font-size: 10pt;
  82 }
  83 p {
  84     margin: 0;
  85 }
  86 .h {
  87     color: red;
  88     text-decoration: underline;
  89 }
  90 small {
  91     font-size: 35%;
  92 }
  93 .box {
  94     display:inline-block;
  95     border: 1px #aaa solid;
  96     padding-left: 4px;
  97     padding-right: 4px;
  98 }
  99 EOF
 100
 101 my %font_cache;
 102 sub new_font {
 103     my ($fn) = @_;
 104     if (not $font_cache{$fn}) {
 105         my $s = new Font::Subsetter();
 106         $s->preload($fn);
 107         $font_cache{$fn} = $s;
 108     }
 109     return Clone::clone($font_cache{$fn});
 110 }
 111
 112 my %std_fonts;
 113 # if (0) { my $j = 0;
 114 for my $j (0..$#all) {
 115     my $fn = $all[$j];
 116     (my $eot_fn = $fn) =~ s/\.[ot]tf$/.eot/i;
 117     if (not -e "testfonts/$eot_fn") {
 118         Font::EOTWrapper::convert("testfonts/$fn", "testfonts/$eot_fn");
 119     }
 120     $common_css .= <<EOF;
 121 \@font-face {
 122     font-family: original-$j;
 123     src: url(../testfonts/$eot_fn);
 124 }
 125 \@font-face {
 126     font-family: original-$j;
 127     src: url(../testfonts/$fn) format("truetype");
 128 }
 129 EOF
 130     $std_fonts{$all[$j]} = "original-$j";
 131 }
 132
 133 mkdir 'testoutput';
 134
 135 my $out;
 136 if (not defined $index) {
 137     open $out, '>', 'testoutput/tests.html' or die $!;
 138     binmode $out, ':utf8';
 139
 140     print $out <<EOF;
 141 <!DOCTYPE html>
 142 <meta charset="utf-8">
 143 <title>Font tests</title>
 144 <style>
 145 $common_css
 146 </style>
 147 EOF
 148 }
 149
 150 my $i = -1;
 151 for my $test (@tests) {
 152     for my $fn (@{$test->[0]}) {
 153         for my $text (@{$test->[1]}) {
 154             ++$i;
 155             next if defined $index and $index != $i;
 156
 157             print encode('utf-8', "$fn -- $text\n");
 158
 159             (my $text_plain = $text) =~ s/<.*?>//g;
 160
 161             my $features;
 162             if ($test->[3]) {
 163                 $features = { DEFAULT => 0 };
 164                 $features->{$_} = 1 for @{$test->[3]};
 165             }
 166
 167             my $s = new_font("testfonts/$fn");
 168             $s->subset("testfonts/$fn", $text_plain, { features => $features });
 169             my $path = sprintf '%03d', $i;
 170             $s->write("testoutput/$path.ttf");
 171             my $old_glyphs = $s->num_glyphs_old;
 172             my $new_glyphs = $s->num_glyphs_new;
 173             my @glyph_names = $s->glyph_names;
 174             $s->release;
 175
 176             Font::EOTWrapper::convert("testoutput/$path.ttf", "testoutput/$path.eot");
 177
 178             my $fragment = <<EOF;
 179 <style>
 180 \@font-face { /* for IE */
 181     font-family: subsetted-$i;
 182     src: url($path.eot);
 183 }
 184 \@font-face {
 185     font-family: subsetted-$i;
 186     src: url($path.ttf) format("truetype");
 187 }
 188 </style>
 189 EOF
 190
 191             for my $size (@{$test->[2]}) {
 192                 $fragment .= <<EOF;
 193 <p title="$fn -- $path -- $old_glyphs vs $new_glyphs" class="box"><span style="font-family: $std_fonts{$fn}; font-size: ${size}pt">$text</span>
 194 <br>
 195 <span style="font-family: subsetted-$i; font-size: ${size}pt">$text</span></p>
 196 EOF
 197             }
 198
 199             print $out qq{\n\n$fragment<a href="$path.html">#</a>} if not defined $index;
 200
 201             open my $html, '>', "testoutput/$path.html";
 202             binmode $html, ':utf8';
 203             print $html <<EOF;
 204 <!DOCTYPE html>
 205 <meta charset="utf-8">
 206 <title>Font test $path</title>
 207 <style>
 208 $common_css
 209 .glyphs { font-family: serif; font-size: 10pt; }
 210 .sizes { font-size: 8pt; }
 211 </style>
 212 $fragment
 213 EOF
 214             print $html qq{<p class="glyphs">}, (join ' &nbsp; ', map "$_", sort @glyph_names), qq{</p>};
 215             print $html qq{<pre class="sizes">}, dump_sizes("testoutput/$path.ttf"), qq{</pre>};
 216         }
 217         print $out "<hr>\n" if not defined $index;
 218     }
 219 }
 220
 221 sub dump_sizes {
 222     my ($fn) = @_;
 223     my $font = Font::TTF::Font->open($fn) or die "Failed to open $fn: $!";
 224
 225     my $s = 0;
 226     my $out = '';
 227     for (sort keys %$font) {
 228         next if /^ /;
 229         my $l = $font->{$_}{' LENGTH'};
 230         $s += $l;
 231         $out .= "$_: $l\n";
 232     }
 233     $out .= "Total: $s\n";
 234     return $out;
 235 }