avoid dead code in i_tt_glyph_names()
[imager.git] / t / 350-font / 020-tt.t
CommitLineData
44191929 1#!perl -w
4f68b48f 2use strict;
ea3099db 3use Test::More;
4f68b48f 4
19dac3de
TC
5$|=1;
6
44191929 7BEGIN { use_ok(Imager => ':all') }
d8d215e3 8use Imager::Test qw(diff_text_with_nul is_color3 is_image);
02d1d628 9
40e78f96
TC
10-d "testout" or mkdir "testout";
11
27e79497 12init_log("testout/t35ttfont.log",2);
02d1d628 13
44191929
TC
14SKIP:
15{
d8d215e3 16 skip("freetype 1.x unavailable or disabled", 96)
2368cfec 17 unless $Imager::formats{"tt"};
44191929
TC
18 print "# has tt\n";
19
20 my $deffont = './fontfiles/dodge.ttf';
21 my $fontname=$ENV{'TTFONTTEST'} || $deffont;
22
23 if (!ok(-f $fontname, "check test font file exists")) {
24 print "# cannot find fontfile for truetype test $fontname\n";
fa16b6c6 25 skip('Cannot load test font', 89);
44191929
TC
26 }
27
d1555273 28 #i_init_fonts();
44191929
TC
29 # i_tt_set_aa(1);
30
31 my $bgcolor = i_color_new(255,0,0,0);
95b2bff4
TC
32 my $overlay = Imager::ImgRaw::new(320,140,3);
33 i_box_filled($overlay, 0, 0, 319, 139, i_color_new(128, 128, 128));
44191929
TC
34
35 my $ttraw = Imager::i_tt_new($fontname);
36 ok($ttraw, "create font");
37
7e3298ec 38 my @bbox = i_tt_bbox($ttraw,50.0,'XMCLH',0);
7fdbfba8 39 is(@bbox, 8, "bounding box");
44191929
TC
40 print "#bbox: ($bbox[0], $bbox[1]) - ($bbox[2], $bbox[3])\n";
41
83bb9f77 42 ok(i_tt_cp($ttraw,$overlay,5,50,1,50.0,'XM CLH',6,1,0), "cp output");
95b2bff4 43 ok(i_tt_cp($ttraw,$overlay,5,120,1,50.0,'XM CLH',6,0,0), "cp output (non AA)");
44191929
TC
44 i_line($overlay,0,50,100,50,$bgcolor,1);
45
46 open(FH,">testout/t35ttfont.ppm") || die "cannot open testout/t35ttfont.ppm\n";
47 binmode(FH);
48 my $IO = Imager::io_new_fd( fileno(FH) );
49 ok(i_writeppm_wiol($overlay, $IO), "save t35ttfont.ppm");
50 close(FH);
51
52 $bgcolor=i_color_set($bgcolor,200,200,200,0);
53 my $backgr=Imager::ImgRaw::new(500,300,3);
54
55 # i_tt_set_aa(2);
56
83bb9f77 57 ok(i_tt_text($ttraw,$backgr,100,120,$bgcolor,50.0,'te st',5,1,0),
44191929 58 "normal output");
95b2bff4
TC
59 ok(i_tt_text($ttraw,$backgr,100,200,$bgcolor,50.0,'te st',5,0,0),
60 "normal output (non AA)");
44191929
TC
61
62 my $ugly = Imager::i_tt_new("./fontfiles/ImUgly.ttf");
63 ok($ugly, "create ugly font");
64 # older versions were dropping the bottom of g and the right of a
65 ok(i_tt_text($ugly, $backgr,100, 80, $bgcolor, 14, 'g%g', 3, 1, 0),
66 "draw g%g");
83bb9f77 67 ok(i_tt_text($ugly, $backgr,150, 80, $bgcolor, 14, 'delta', 6, 1, 0),
44191929
TC
68 "draw delta");
69 i_line($backgr,0,20,499,20,i_color_new(0,127,0,0),1);
70 ok(i_tt_text($ttraw, $backgr, 20, 20, $bgcolor, 14, 'abcdefghijklmnopqrstuvwxyz{|}', 29, 1, 0), "alphabet");
71 ok(i_tt_text($ttraw, $backgr, 20, 50, $bgcolor, 14, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 26, 1, 0), "ALPHABET");
72
73 # UTF8 tests
74 # for perl < 5.6 we can hand-encode text
75 # the following is "A\x{2010}A"
76 #
77 my $text = pack("C*", 0x41, 0xE2, 0x80, 0x90, 0x41);
78 my $alttext = "A-A";
79
7e3298ec 80 my @utf8box = i_tt_bbox($ttraw, 50.0, $text, 1);
7fdbfba8 81 is(@utf8box, 8, "utf8 bbox element count");
7e3298ec 82 my @base = i_tt_bbox($ttraw, 50.0, $alttext, 0);
7fdbfba8 83 is(@base, 8, "alt bbox element count");
44191929
TC
84 my $maxdiff = $fontname eq $deffont ? 0 : $base[2] / 3;
85 print "# (@utf8box vs @base)\n";
86 ok(abs($utf8box[2] - $base[2]) <= $maxdiff,
87 "compare box sizes $utf8box[2] vs $base[2] (maxerror $maxdiff)");
88
89 # hand-encoded UTF8 drawing
90 ok(i_tt_text($ttraw, $backgr, 200, 80, $bgcolor, 14, $text, length($text), 1, 1), "draw hand-encoded UTF8");
91
92 ok(i_tt_cp($ttraw, $backgr, 250, 80, 1, 14, $text, length($text), 1, 1),
93 "cp hand-encoded UTF8");
94
95 # ok, try native perl UTF8 if available
96 SKIP:
97 {
98 skip("perl too old to test native UTF8 support", 5) unless $] >= 5.006;
99
100 my $text;
101 # we need to do this in eval to prevent compile time errors in older
102 # versions
103 eval q{$text = "A\x{2010}A"}; # A, HYPHEN, A in our test font
104 #$text = "A".chr(0x2010)."A"; # this one works too
105 ok(i_tt_text($ttraw, $backgr, 300, 80, $bgcolor, 14, $text, 0, 1, 0),
106 "draw UTF8");
107 ok(i_tt_cp($ttraw, $backgr, 350, 80, 0, 14, $text, 0, 1, 0),
108 "cp UTF8");
7e3298ec 109 @utf8box = i_tt_bbox($ttraw, 50.0, $text, 0);
7fdbfba8 110 is(@utf8box, 8, "native utf8 bbox element count");
44191929
TC
111 ok(abs($utf8box[2] - $base[2]) <= $maxdiff,
112 "compare box sizes native $utf8box[2] vs $base[2] (maxerror $maxdiff)");
113 eval q{$text = "A\x{0905}\x{0906}\x{0103}A"}; # Devanagari
114 ok(i_tt_text($ugly, $backgr, 100, 160, $bgcolor, 36, $text, 0, 1, 0),
115 "more complex output");
116 }
117
118 open(FH,">testout/t35ttfont2.ppm") || die "cannot open testout/t35ttfont.ppm\n";
119 binmode(FH);
120 $IO = Imager::io_new_fd( fileno(FH) );
121 ok(i_writeppm_wiol($backgr, $IO), "save t35ttfont2.ppm");
122 close(FH);
123
124 my $exists_font = "fontfiles/ExistenceTest.ttf";
125 my $hcfont = Imager::Font->new(file=>$exists_font, type=>'tt');
126 SKIP:
127 {
128 ok($hcfont, "loading existence test font")
7fdbfba8 129 or skip("could not load test font", 20);
44191929
TC
130
131 # list interface
132 my @exists = $hcfont->has_chars(string=>'!A');
133 ok(@exists == 2, "check return count");
134 ok($exists[0], "we have an exclamation mark");
135 ok(!$exists[1], "we have no exclamation mark");
136
137 # scalar interface
138 my $exists = $hcfont->has_chars(string=>'!A');
139 ok(length($exists) == 2, "check return length");
140 ok(ord(substr($exists, 0, 1)), "we have an exclamation mark");
141 ok(!ord(substr($exists, 1, 1)), "we have no upper-case A");
142
143 my $face_name = Imager::i_tt_face_name($hcfont->{id});
144 print "# face $face_name\n";
5386861e 145 is($face_name, 'ExistenceTest', "face name (function)");
44191929 146 $face_name = $hcfont->face_name;
5386861e 147 is($face_name, 'ExistenceTest', "face name (OO)");
44191929
TC
148
149 # FT 1.x cheats and gives names even if the font doesn't have them
150 my @glyph_names = $hcfont->glyph_names(string=>"!J/");
5386861e 151 is($glyph_names[0], 'exclam', "check exclam name OO");
44191929 152 ok(!defined($glyph_names[1]), "check for no J name OO");
5386861e 153 is($glyph_names[2], 'slash', "check slash name OO");
ea3099db
TC
154
155 # check invalid utf8
156 my @bad = $hcfont->glyph_names(string => "!/\xC0", utf8 => 1);
157 is(@bad, 0, "should return nothing for invalid UTF-8");
44191929
TC
158
159 print "# ** name table of the test font **\n";
160 Imager::i_tt_dump_names($hcfont->{id});
8a35bed5
TC
161
162 # the test font is known to have a shorter advance width for that char
163 my @bbox = $hcfont->bounding_box(string=>"/", size=>100);
7fdbfba8 164 is(@bbox, 8, "should be 8 entries");
8a35bed5
TC
165 isnt($bbox[6], $bbox[2], "different advance width from pos width");
166 print "# @bbox\n";
167 my $bbox = $hcfont->bounding_box(string=>"/", size=>100);
168 isnt($bbox->pos_width, $bbox->advance_width, "OO check");
7fdbfba8
TC
169
170 cmp_ok($bbox->right_bearing, '<', 0, "check right bearing");
171
172 cmp_ok($bbox->display_width, '>', $bbox->advance_width,
173 "check display width (roughly)");
174
175 # check with a char that fits inside the box
176 $bbox = $hcfont->bounding_box(string=>"!", size=>100);
177 print "# @$bbox\n";
178 print "# pos width ", $bbox->pos_width, "\n";
179 is($bbox->pos_width, $bbox->advance_width,
180 "check backwards compatibility");
181 cmp_ok($bbox->left_bearing, '>', 0, "left bearing positive");
182 cmp_ok($bbox->right_bearing, '>', 0, "right bearing positive");
183 cmp_ok($bbox->display_width, '<', $bbox->advance_width,
184 "display smaller than advance");
44191929
TC
185 }
186 undef $hcfont;
187
188 my $name_font = "fontfiles/NameTest.ttf";
6a00d627 189 $hcfont = Imager::Font->new(file=>$name_font, type=>'tt');
44191929
TC
190 SKIP:
191 {
192 ok($hcfont, "loading name font")
193 or skip("could not load name font $name_font", 3);
194 # make sure a missing string parameter is handled correctly
195 eval {
196 $hcfont->glyph_names();
197 };
198 is($@, "", "correct error handling");
199 cmp_ok(Imager->errstr, '=~', qr/no string parameter/, "error message");
200
201 my $text = pack("C*", 0xE2, 0x80, 0x90); # "\x{2010}" as utf-8
202 my @names = $hcfont->glyph_names(string=>$text, utf8=>1);
203 is($names[0], "hyphentwo", "check utf8 glyph name");
204 }
205
206 undef $hcfont;
207
490aa9ae
TC
208 SKIP:
209 { print "# alignment tests\n";
210 my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt');
211 ok($font, "loaded deffont OO")
212 or skip("could not load font:".Imager->errstr, 4);
9ab6338b
TC
213 my $im = Imager->new(xsize=>140, ysize=>150);
214 my %common =
490aa9ae
TC
215 (
216 font=>$font,
490aa9ae 217 size=>40,
490aa9ae
TC
218 aa=>1,
219 );
9ab6338b
TC
220 $im->line(x1=>0, y1=>40, x2=>139, y2=>40, color=>'blue');
221 $im->line(x1=>0, y1=>90, x2=>139, y2=>90, color=>'blue');
222 $im->line(x1=>0, y1=>110, x2=>139, y2=>110, color=>'blue');
223 for my $args ([ x=>5, text=>"A", color=>"white" ],
224 [ x=>40, text=>"y", color=>"white" ],
a6d9b737
TC
225 [ x=>75, text=>"A", channel=>1 ],
226 [ x=>110, text=>"y", channel=>1 ]) {
9ab6338b
TC
227 ok($im->string(%common, @$args, 'y'=>40), "A no alignment");
228 ok($im->string(%common, @$args, 'y'=>90, align=>1), "A align=1");
229 ok($im->string(%common, @$args, 'y'=>110, align=>0), "A align=0");
230 }
490aa9ae
TC
231 ok($im->write(file=>'testout/t35align.ppm'), "save align image");
232 }
233
d93d5c10
TC
234 { # Ticket #14804 Imager::Font->new() doesn't report error details
235 # when using freetype 1
e32e7bb5
TC
236 # make sure we're using C locale for messages
237 use POSIX qw(setlocale LC_ALL);
238 setlocale(LC_ALL, "C");
239
5664d5c8 240 my $font = Imager::Font->new(file=>'t/350-font/020-tt.t', type=>'tt');
d93d5c10
TC
241 ok(!$font, "font creation should have failed for invalid file");
242 cmp_ok(Imager->errstr, 'eq', 'Invalid file format.',
243 "test error message");
e32e7bb5
TC
244
245 setlocale(LC_ALL, "");
d93d5c10
TC
246 }
247
aa68d6e9
TC
248 { # check errstr set correctly
249 my $font = Imager::Font->new(file=>$fontname, type=>'tt',
250 size => undef);
251 ok($font, "made size error test font");
252 my $im = Imager->new(xsize=>100, ysize=>100);
253 ok($im, "made size error test image");
254 ok(!$im->string(font=>$font, x=>10, 'y'=>50, string=>"Hello"),
255 "drawing should fail with no size");
256 is($im->errstr, "No font size provided", "check error message");
257
258 # try no string
259 ok(!$im->string(font=>$font, x=>10, 'y'=>50, size=>15),
260 "drawing should fail with no string");
261 is($im->errstr, "missing required parameter 'string'",
262 "check error message");
263 }
264
83bb9f77
TC
265 { # introduced in 0.46 - outputting just space crashes
266 my $im = Imager->new(xsize=>100, ysize=>100);
267 my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', size=>14);
fa16b6c6 268 ok($im->string(font=>$font, x=> 5, 'y' => 50, string=>' '),
83bb9f77
TC
269 "outputting just a space was crashing");
270 }
271
9a6ab99c
TC
272 { # string output cut off at NUL ('\0')
273 # https://rt.cpan.org/Ticket/Display.html?id=21770 cont'd
274 my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt');
275 ok($font, "loaded imugly");
276
277 diff_text_with_nul("a\\0b vs a", "a\0b", "a",
278 font => $font, color => '#FFFFFF');
279 diff_text_with_nul("a\\0b vs a", "a\0b", "a",
280 font => $font, channel => 1);
281
282 # UTF8 encoded \x{2010}
283 my $dash = pack("C*", 0xE2, 0x80, 0x90);
8927ff88 284 diff_text_with_nul("utf8 dash\\0dash vs dash", "$dash\0$dash", $dash,
9a6ab99c 285 font => $font, color => '#FFFFFF', utf8 => 1);
8927ff88 286 diff_text_with_nul("utf8 dash\\0dash vs dash", "$dash\0$dash", $dash,
9a6ab99c
TC
287 font => $font, channel => 1, utf8 => 1);
288 }
289
8927ff88 290 SKIP:
fa16b6c6
TC
291 { # RT 11972
292 # when rendering to a transparent image the coverage should be
293 # expressed in terms of the alpha channel rather than the color
294 my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt');
8927ff88
TC
295 ok($font, "loaded fontfiles/ImUgly.ttf")
296 or skip("Could not load test font: ".Imager->errstr, 4);
fa16b6c6
TC
297 my $im = Imager->new(xsize => 40, ysize => 20, channels => 4);
298 ok($im->string(string => "AB", size => 20, aa => 1, color => '#F00',
299 x => 0, y => 15, font => $font),
300 "draw to transparent image");
301 #$im->write(file => "foo.png");
302 my $im_noalpha = $im->convert(preset => 'noalpha');
303 my $im_pal = $im->to_paletted(make_colors => 'mediancut');
304 my @colors = $im_pal->getcolors;
305 is(@colors, 2, "should be only 2 colors");
306 @colors = sort { ($a->rgba)[0] <=> ($b->rgba)[0] } @colors;
307 is_color3($colors[0], 0, 0, 0, "check we got black");
308 is_color3($colors[1], 255, 0, 0, "and red");
309 }
310
d8d215e3
TC
311 SKIP:
312 { # RT 71564
313 my $noalpha = Imager::Color->new(255, 255, 255, 0);
314 my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt',
315 color => $noalpha);
316 ok($font, "loaded fontfiles/ImUgly.ttf")
317 or skip("Could not load test font: ".Imager->errstr, 4);
318 {
319 my $im = Imager->new(xsize => 40, ysize => 20);
320 my $copy = $im->copy;
321 ok($im->string(string => "AB", size => 20, aa => 1,
322 x => 0, y => 15, font => $font),
323 "draw with transparent color, aa");
324 is_image($im, $copy, "should draw nothing");
325 }
326 {
327 my $im = Imager->new(xsize => 40, ysize => 20);
328 my $copy = $im->copy;
329 ok($im->string(string => "AB", size => 20, aa => 0,
330 x => 0, y => 15, font => $font),
331 "draw with transparent color, non-aa");
d8d215e3
TC
332 is_image($im, $copy, "should draw nothing");
333 }
334 }
335
44191929 336 ok(1, "end of code");
4f68b48f 337}
ea3099db
TC
338
339done_testing();