63bb1533d874ef498ea0b0dd914ad3a6b571242e
[librarian.git] / 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 }