--- /dev/null
+# This script generates various 'interesting' fonts, and outputs an HTML file
+# containing the subsetted fonts and the original fonts.
+# View the output in browsers (preferably multiple, on multiple platforms) to
+# make sure the output looks the same as the original.
+
+use strict;
+use warnings;
+
+use lib 'ext/Font-TTF/lib';
+use Font::Subsetter;
+use Font::EOTWrapper;
+use Encode;
+use Clone;
+
+use utf8;
+
+# The following fonts need to exist in a directory called 'testfonts':
+my @all = qw(
+ GenBasR.ttf
+ GenR102.TTF
+ LinLibertine_Re-4.1.8.ttf
+ DoulosSILR.ttf
+ DejaVuSans.ttf
+ DejaVuSerif.ttf
+ calibri.ttf
+ FedraSansPro-Demi.ttf
+);
+
+my $index = $ARGV[0];
+die "Run '$0', or '$0 n' where n is the number of the test to rebuild\n"
+ if defined $index and $index !~ /^\d+$/;
+
+my @tests = (
+ # These aren't proper tests (they drop features that affect the rendering)
+ # TODO: fix them so they are proper, and test that they're really dropping the
+ # unneeded glyphs etc
+# [ [qw(DejaVuSans.ttf FedraSansPro-Demi.ttf)], ["fluffily لا f"], [20], [qw(aalt ccmp dlig fina hlig init liga locl medi rlig salt kern mark mkmk)] ],
+# [ [qw(DejaVuSans.ttf FedraSansPro-Demi.ttf)], ["fluffily لا f"], [20], [qw(liga)] ],
+# [ [qw(DejaVuSans.ttf FedraSansPro-Demi.ttf)], ["fluffily لا f"], [20], [qw(fina init rlig)] ],
+# [ [qw(DejaVuSans.ttf FedraSansPro-Demi.ttf)], ["fluffily لا f"], [20], [] ],
+
+ # Basic rendering
+ [ [@all], ["Hello world ABC abc 123"], [20] ],
+
+ # Substitution and NFC issues
+ [ [qw(GenBasR.ttf DejaVuSans.ttf FedraSansPro-Demi.ttf)], [
+ "i",
+ "\xec",
+ "i\x{0300}",
+ "i \x{0300}",
+ "ixixi",
+ "i<span class='h'>\x{0300}</span>",
+ ], [20, 8] ],
+ [ [qw(DejaVuSans.ttf FedraSansPro-Demi.ttf)], [
+ "s\x{0323}\x{0307}", # s, combining dot below, combining dot above
+ "s\x{0307}\x{0323}", # s, combining dot above, combining dot below
+ "\x{1e61}\x{0323}", # s with dot above, combining dot below
+ "\x{1e63}\x{0307}", # s with dot below, combining dot above
+ "\x{212b}", # angstrom
+ ], [20, 8] ],
+
+ # Ligature rendering
+ [ [qw(LinLibertine_Re-4.1.8.ttf DejaVuSans.ttf FedraSansPro-Demi.ttf)], [
+ "fluffily",
+ "f<span>l</span>uf<span>f</span>ily",
+ "f<span class='h'>l</span>uf<span class='h'>f</span>ily",
+ ], [20, 8] ],
+
+ # GPOS issues
+ [ [qw(DejaVuSans.ttf FedraSansPro-Demi.ttf calibri.ttf)],
+ ["|VAVAV|", "ToToT", "x//x"], [20], ['kern'] ],
+
+ # Lots of stuff
+ [ [@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] ],
+
+);
+
+my $common_css = <<EOF;
+body {
+ font-family: Courier, monospace;
+ font-size: 10pt;
+}
+p {
+ margin: 0;
+}
+.h {
+ color: red;
+ text-decoration: underline;
+}
+small {
+ font-size: 35%;
+}
+.box {
+ display:inline-block;
+ border: 1px #aaa solid;
+ padding-left: 4px;
+ padding-right: 4px;
+}
+EOF
+
+my %font_cache;
+sub new_font {
+ my ($fn) = @_;
+ if (not $font_cache{$fn}) {
+ my $s = new Font::Subsetter();
+ $s->preload($fn);
+ $font_cache{$fn} = $s;
+ }
+ return Clone::clone($font_cache{$fn});
+}
+
+my %std_fonts;
+# if (0) { my $j = 0;
+for my $j (0..$#all) {
+ my $fn = $all[$j];
+ (my $eot_fn = $fn) =~ s/\.[ot]tf$/.eot/i;
+ if (not -e "testfonts/$eot_fn") {
+ Font::EOTWrapper::convert("testfonts/$fn", "testfonts/$eot_fn");
+ }
+ $common_css .= <<EOF;
+\@font-face {
+ font-family: original-$j;
+ src: url(../testfonts/$eot_fn);
+}
+\@font-face {
+ font-family: original-$j;
+ src: url(../testfonts/$fn) format("truetype");
+}
+EOF
+ $std_fonts{$all[$j]} = "original-$j";
+}
+
+mkdir 'testoutput';
+
+my $out;
+if (not defined $index) {
+ open $out, '>', 'testoutput/tests.html' or die $!;
+ binmode $out, ':utf8';
+
+ print $out <<EOF;
+<!DOCTYPE html>
+<meta charset="utf-8">
+<title>Font tests</title>
+<style>
+$common_css
+</style>
+EOF
+}
+
+my $i = -1;
+for my $test (@tests) {
+ for my $fn (@{$test->[0]}) {
+ for my $text (@{$test->[1]}) {
+ ++$i;
+ next if defined $index and $index != $i;
+
+ print encode('utf-8', "$fn -- $text\n");
+
+ (my $text_plain = $text) =~ s/<.*?>//g;
+
+ my $features;
+ if ($test->[3]) {
+ $features = { DEFAULT => 0 };
+ $features->{$_} = 1 for @{$test->[3]};
+ }
+
+ my $s = new_font("testfonts/$fn");
+ $s->subset("testfonts/$fn", $text_plain, { features => $features });
+ my $path = sprintf '%03d', $i;
+ $s->write("testoutput/$path.ttf");
+ my $old_glyphs = $s->num_glyphs_old;
+ my $new_glyphs = $s->num_glyphs_new;
+ my @glyph_names = $s->glyph_names;
+ $s->release;
+
+ Font::EOTWrapper::convert("testoutput/$path.ttf", "testoutput/$path.eot");
+
+ my $fragment = <<EOF;
+<style>
+\@font-face { /* for IE */
+ font-family: subsetted-$i;
+ src: url($path.eot);
+}
+\@font-face {
+ font-family: subsetted-$i;
+ src: url($path.ttf) format("truetype");
+}
+</style>
+EOF
+
+ for my $size (@{$test->[2]}) {
+ $fragment .= <<EOF;
+<p title="$fn -- $path -- $old_glyphs vs $new_glyphs" class="box"><span style="font-family: $std_fonts{$fn}; font-size: ${size}pt">$text</span>
+<br>
+<span style="font-family: subsetted-$i; font-size: ${size}pt">$text</span></p>
+EOF
+ }
+
+ print $out qq{\n\n$fragment<a href="$path.html">#</a>} if not defined $index;
+
+ open my $html, '>', "testoutput/$path.html";
+ binmode $html, ':utf8';
+ print $html <<EOF;
+<!DOCTYPE html>
+<meta charset="utf-8">
+<title>Font test $path</title>
+<style>
+$common_css
+.glyphs { font-family: serif; font-size: 10pt; }
+.sizes { font-size: 8pt; }
+</style>
+$fragment
+EOF
+ print $html qq{<p class="glyphs">}, (join ' ', map "$_", sort @glyph_names), qq{</p>};
+ print $html qq{<pre class="sizes">}, dump_sizes("testoutput/$path.ttf"), qq{</pre>};
+ }
+ print $out "<hr>\n" if not defined $index;
+ }
+}
+
+sub dump_sizes {
+ my ($fn) = @_;
+ my $font = Font::TTF::Font->open($fn) or die "Failed to open $fn: $!";
+
+ my $s = 0;
+ my $out = '';
+ for (sort keys %$font) {
+ next if /^ /;
+ my $l = $font->{$_}{' LENGTH'};
+ $s += $l;
+ $out .= "$_: $l\n";
+ }
+ $out .= "Total: $s\n";
+ return $out;
+}