Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 335 lines (284 sloc) 12.663 kb
4419192 converted to Test::More
Tony Cook authored
1 #!perl -w
4f68b48 support UTF with Freetype 1.x
Tony Cook authored
2 use strict;
d8d215e @tonycoz [rt #71564] fix i_render_color() to work in normal mode
authored
3 use Test::More tests => 97;
4f68b48 support UTF with Freetype 1.x
Tony Cook authored
4
19dac3d flush test output too, to be safe (RT 24859)
Tony Cook authored
5 $|=1;
6
4419192 converted to Test::More
Tony Cook authored
7 BEGIN { use_ok(Imager => ':all') }
d8d215e @tonycoz [rt #71564] fix i_render_color() to work in normal mode
authored
8 use Imager::Test qw(diff_text_with_nul is_color3 is_image);
02d1d62 Initial revision
Arnar Mar Hrafnkelsson authored
9
40e78f9 @tonycoz RT#65088 make sure each test script that needs testout/ creates it
authored
10 -d "testout" or mkdir "testout";
11
27e7949 use the font's first character map if we don't find a unicode map (FT1)
Tony Cook authored
12 init_log("testout/t35ttfont.log",2);
02d1d62 Initial revision
Arnar Mar Hrafnkelsson authored
13
4419192 converted to Test::More
Tony Cook authored
14 SKIP:
15 {
d8d215e @tonycoz [rt #71564] fix i_render_color() to work in normal mode
authored
16 skip("freetype 1.x unavailable or disabled", 96)
2368cfe @tonycoz [RT #65863] mostly eliminate i_has_format
authored
17 unless $Imager::formats{"tt"};
4419192 converted to Test::More
Tony Cook authored
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";
fa16b6c fix rendering on alpha channel images for the FreeType 1.x driver.
Tony Cook authored
25 skip('Cannot load test font', 89);
4419192 converted to Test::More
Tony Cook authored
26 }
27
d155527 - the font libraries are now only initialized when needed.
Tony Cook authored
28 #i_init_fonts();
4419192 converted to Test::More
Tony Cook authored
29 # i_tt_set_aa(1);
30
31 my $bgcolor = i_color_new(255,0,0,0);
95b2bff improve freetype 1.x text output efficiency
Tony Cook authored
32 my $overlay = Imager::ImgRaw::new(320,140,3);
33 i_box_filled($overlay, 0, 0, 319, 139, i_color_new(128, 128, 128));
4419192 converted to Test::More
Tony Cook authored
34
35 my $ttraw = Imager::i_tt_new($fontname);
36 ok($ttraw, "create font");
37
83bb9f7 - outputting a single space using the Freetype 1.x driver (type=>'tt')
Tony Cook authored
38 my @bbox = i_tt_bbox($ttraw,50.0,'XMCLH',6,0);
7fdbfba - Imager::Font::BBox objects now have right_bearing() and display_wid…
Tony Cook authored
39 is(@bbox, 8, "bounding box");
4419192 converted to Test::More
Tony Cook authored
40 print "#bbox: ($bbox[0], $bbox[1]) - ($bbox[2], $bbox[3])\n";
41
83bb9f7 - outputting a single space using the Freetype 1.x driver (type=>'tt')
Tony Cook authored
42 ok(i_tt_cp($ttraw,$overlay,5,50,1,50.0,'XM CLH',6,1,0), "cp output");
95b2bff improve freetype 1.x text output efficiency
Tony Cook authored
43 ok(i_tt_cp($ttraw,$overlay,5,120,1,50.0,'XM CLH',6,0,0), "cp output (non AA)");
4419192 converted to Test::More
Tony Cook authored
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
83bb9f7 - outputting a single space using the Freetype 1.x driver (type=>'tt')
Tony Cook authored
57 ok(i_tt_text($ttraw,$backgr,100,120,$bgcolor,50.0,'te st',5,1,0),
4419192 converted to Test::More
Tony Cook authored
58 "normal output");
95b2bff improve freetype 1.x text output efficiency
Tony Cook authored
59 ok(i_tt_text($ttraw,$backgr,100,200,$bgcolor,50.0,'te st',5,0,0),
60 "normal output (non AA)");
4419192 converted to Test::More
Tony Cook authored
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");
83bb9f7 - outputting a single space using the Freetype 1.x driver (type=>'tt')
Tony Cook authored
67 ok(i_tt_text($ugly, $backgr,150, 80, $bgcolor, 14, 'delta', 6, 1, 0),
4419192 converted to Test::More
Tony Cook authored
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
80 my @utf8box = i_tt_bbox($ttraw, 50.0, $text, length($text), 1);
7fdbfba - Imager::Font::BBox objects now have right_bearing() and display_wid…
Tony Cook authored
81 is(@utf8box, 8, "utf8 bbox element count");
4419192 converted to Test::More
Tony Cook authored
82 my @base = i_tt_bbox($ttraw, 50.0, $alttext, length($alttext), 0);
7fdbfba - Imager::Font::BBox objects now have right_bearing() and display_wid…
Tony Cook authored
83 is(@base, 8, "alt bbox element count");
4419192 converted to Test::More
Tony Cook authored
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");
109 @utf8box = i_tt_bbox($ttraw, 50.0, $text, length($text), 0);
7fdbfba - Imager::Font::BBox objects now have right_bearing() and display_wid…
Tony Cook authored
110 is(@utf8box, 8, "native utf8 bbox element count");
4419192 converted to Test::More
Tony Cook authored
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")
7fdbfba - Imager::Font::BBox objects now have right_bearing() and display_wid…
Tony Cook authored
129 or skip("could not load test font", 20);
4419192 converted to Test::More
Tony Cook authored
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";
5386861 convert ok(... eq ..., ... ) to is(..., ..., ...)
Tony Cook authored
145 is($face_name, 'ExistenceTest', "face name (function)");
4419192 converted to Test::More
Tony Cook authored
146 $face_name = $hcfont->face_name;
5386861 convert ok(... eq ..., ... ) to is(..., ..., ...)
Tony Cook authored
147 is($face_name, 'ExistenceTest', "face name (OO)");
4419192 converted to Test::More
Tony Cook authored
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/");
5386861 convert ok(... eq ..., ... ) to is(..., ..., ...)
Tony Cook authored
151 is($glyph_names[0], 'exclam', "check exclam name OO");
4419192 converted to Test::More
Tony Cook authored
152 ok(!defined($glyph_names[1]), "check for no J name OO");
5386861 convert ok(... eq ..., ... ) to is(..., ..., ...)
Tony Cook authored
153 is($glyph_names[2], 'slash', "check slash name OO");
4419192 converted to Test::More
Tony Cook authored
154
155 print "# ** name table of the test font **\n";
156 Imager::i_tt_dump_names($hcfont->{id});
8a35bed - the FT 1.x was comparing versus an uninitialized variable when
Tony Cook authored
157
158 # the test font is known to have a shorter advance width for that char
159 my @bbox = $hcfont->bounding_box(string=>"/", size=>100);
7fdbfba - Imager::Font::BBox objects now have right_bearing() and display_wid…
Tony Cook authored
160 is(@bbox, 8, "should be 8 entries");
8a35bed - the FT 1.x was comparing versus an uninitialized variable when
Tony Cook authored
161 isnt($bbox[6], $bbox[2], "different advance width from pos width");
162 print "# @bbox\n";
163 my $bbox = $hcfont->bounding_box(string=>"/", size=>100);
164 isnt($bbox->pos_width, $bbox->advance_width, "OO check");
7fdbfba - Imager::Font::BBox objects now have right_bearing() and display_wid…
Tony Cook authored
165
166 cmp_ok($bbox->right_bearing, '<', 0, "check right bearing");
167
168 cmp_ok($bbox->display_width, '>', $bbox->advance_width,
169 "check display width (roughly)");
170
171 # check with a char that fits inside the box
172 $bbox = $hcfont->bounding_box(string=>"!", size=>100);
173 print "# @$bbox\n";
174 print "# pos width ", $bbox->pos_width, "\n";
175 is($bbox->pos_width, $bbox->advance_width,
176 "check backwards compatibility");
177 cmp_ok($bbox->left_bearing, '>', 0, "left bearing positive");
178 cmp_ok($bbox->right_bearing, '>', 0, "right bearing positive");
179 cmp_ok($bbox->display_width, '<', $bbox->advance_width,
180 "display smaller than advance");
4419192 converted to Test::More
Tony Cook authored
181 }
182 undef $hcfont;
183
184 my $name_font = "fontfiles/NameTest.ttf";
6a00d62 changed alignment tests a bit
Tony Cook authored
185 $hcfont = Imager::Font->new(file=>$name_font, type=>'tt');
4419192 converted to Test::More
Tony Cook authored
186 SKIP:
187 {
188 ok($hcfont, "loading name font")
189 or skip("could not load name font $name_font", 3);
190 # make sure a missing string parameter is handled correctly
191 eval {
192 $hcfont->glyph_names();
193 };
194 is($@, "", "correct error handling");
195 cmp_ok(Imager->errstr, '=~', qr/no string parameter/, "error message");
196
197 my $text = pack("C*", 0xE2, 0x80, 0x90); # "\x{2010}" as utf-8
198 my @names = $hcfont->glyph_names(string=>$text, utf8=>1);
199 is($names[0], "hyphentwo", "check utf8 glyph name");
200 }
201
202 undef $hcfont;
203
490aa9a added alignment tests
Tony Cook authored
204 SKIP:
205 { print "# alignment tests\n";
206 my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt');
207 ok($font, "loaded deffont OO")
208 or skip("could not load font:".Imager->errstr, 4);
9ab6338 - the FT1.x driver now supports the align parameter correctly.
Tony Cook authored
209 my $im = Imager->new(xsize=>140, ysize=>150);
210 my %common =
490aa9a added alignment tests
Tony Cook authored
211 (
212 font=>$font,
213 size=>40,
214 aa=>1,
215 );
9ab6338 - the FT1.x driver now supports the align parameter correctly.
Tony Cook authored
216 $im->line(x1=>0, y1=>40, x2=>139, y2=>40, color=>'blue');
217 $im->line(x1=>0, y1=>90, x2=>139, y2=>90, color=>'blue');
218 $im->line(x1=>0, y1=>110, x2=>139, y2=>110, color=>'blue');
219 for my $args ([ x=>5, text=>"A", color=>"white" ],
220 [ x=>40, text=>"y", color=>"white" ],
a6d9b73 - the Win32 font driver bounding_box() method now puts accuarate values
Tony Cook authored
221 [ x=>75, text=>"A", channel=>1 ],
222 [ x=>110, text=>"y", channel=>1 ]) {
9ab6338 - the FT1.x driver now supports the align parameter correctly.
Tony Cook authored
223 ok($im->string(%common, @$args, 'y'=>40), "A no alignment");
224 ok($im->string(%common, @$args, 'y'=>90, align=>1), "A align=1");
225 ok($im->string(%common, @$args, 'y'=>110, align=>0), "A align=0");
226 }
490aa9a added alignment tests
Tony Cook authored
227 ok($im->write(file=>'testout/t35align.ppm'), "save align image");
228 }
229
d93d5c1 - Imager::Font->new() for the tt (Freetype 1.x) driver now correctly
Tony Cook authored
230 { # Ticket #14804 Imager::Font->new() doesn't report error details
231 # when using freetype 1
e32e7bb - set the locale to "C" properly when testing ft1.x error messages
Tony Cook authored
232 # make sure we're using C locale for messages
233 use POSIX qw(setlocale LC_ALL);
234 setlocale(LC_ALL, "C");
235
d93d5c1 - Imager::Font->new() for the tt (Freetype 1.x) driver now correctly
Tony Cook authored
236 my $font = Imager::Font->new(file=>'t/t35ttfont.t', type=>'tt');
237 ok(!$font, "font creation should have failed for invalid file");
238 cmp_ok(Imager->errstr, 'eq', 'Invalid file format.',
239 "test error message");
e32e7bb - set the locale to "C" properly when testing ft1.x error messages
Tony Cook authored
240
241 setlocale(LC_ALL, "");
d93d5c1 - Imager::Font->new() for the tt (Freetype 1.x) driver now correctly
Tony Cook authored
242 }
243
aa68d6e - improved missing argument handling a little for the string() method
Tony Cook authored
244 { # check errstr set correctly
245 my $font = Imager::Font->new(file=>$fontname, type=>'tt',
246 size => undef);
247 ok($font, "made size error test font");
248 my $im = Imager->new(xsize=>100, ysize=>100);
249 ok($im, "made size error test image");
250 ok(!$im->string(font=>$font, x=>10, 'y'=>50, string=>"Hello"),
251 "drawing should fail with no size");
252 is($im->errstr, "No font size provided", "check error message");
253
254 # try no string
255 ok(!$im->string(font=>$font, x=>10, 'y'=>50, size=>15),
256 "drawing should fail with no string");
257 is($im->errstr, "missing required parameter 'string'",
258 "check error message");
259 }
260
83bb9f7 - outputting a single space using the Freetype 1.x driver (type=>'tt')
Tony Cook authored
261 { # introduced in 0.46 - outputting just space crashes
262 my $im = Imager->new(xsize=>100, ysize=>100);
263 my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', size=>14);
fa16b6c fix rendering on alpha channel images for the FreeType 1.x driver.
Tony Cook authored
264 ok($im->string(font=>$font, x=> 5, 'y' => 50, string=>' '),
83bb9f7 - outputting a single space using the Freetype 1.x driver (type=>'tt')
Tony Cook authored
265 "outputting just a space was crashing");
266 }
267
9a6ab99 use SvPV to get the length of text to draw rather than strlen(), add
Tony Cook authored
268 { # string output cut off at NUL ('\0')
269 # https://rt.cpan.org/Ticket/Display.html?id=21770 cont'd
270 my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt');
271 ok($font, "loaded imugly");
272
273 diff_text_with_nul("a\\0b vs a", "a\0b", "a",
274 font => $font, color => '#FFFFFF');
275 diff_text_with_nul("a\\0b vs a", "a\0b", "a",
276 font => $font, channel => 1);
277
278 # UTF8 encoded \x{2010}
279 my $dash = pack("C*", 0xE2, 0x80, 0x90);
8927ff8 eliminate t/testtools.pl
Tony Cook authored
280 diff_text_with_nul("utf8 dash\\0dash vs dash", "$dash\0$dash", $dash,
9a6ab99 use SvPV to get the length of text to draw rather than strlen(), add
Tony Cook authored
281 font => $font, color => '#FFFFFF', utf8 => 1);
8927ff8 eliminate t/testtools.pl
Tony Cook authored
282 diff_text_with_nul("utf8 dash\\0dash vs dash", "$dash\0$dash", $dash,
9a6ab99 use SvPV to get the length of text to draw rather than strlen(), add
Tony Cook authored
283 font => $font, channel => 1, utf8 => 1);
284 }
285
8927ff8 eliminate t/testtools.pl
Tony Cook authored
286 SKIP:
fa16b6c fix rendering on alpha channel images for the FreeType 1.x driver.
Tony Cook authored
287 { # RT 11972
288 # when rendering to a transparent image the coverage should be
289 # expressed in terms of the alpha channel rather than the color
290 my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt');
8927ff8 eliminate t/testtools.pl
Tony Cook authored
291 ok($font, "loaded fontfiles/ImUgly.ttf")
292 or skip("Could not load test font: ".Imager->errstr, 4);
fa16b6c fix rendering on alpha channel images for the FreeType 1.x driver.
Tony Cook authored
293 my $im = Imager->new(xsize => 40, ysize => 20, channels => 4);
294 ok($im->string(string => "AB", size => 20, aa => 1, color => '#F00',
295 x => 0, y => 15, font => $font),
296 "draw to transparent image");
297 #$im->write(file => "foo.png");
298 my $im_noalpha = $im->convert(preset => 'noalpha');
299 my $im_pal = $im->to_paletted(make_colors => 'mediancut');
300 my @colors = $im_pal->getcolors;
301 is(@colors, 2, "should be only 2 colors");
302 @colors = sort { ($a->rgba)[0] <=> ($b->rgba)[0] } @colors;
303 is_color3($colors[0], 0, 0, 0, "check we got black");
304 is_color3($colors[1], 255, 0, 0, "and red");
305 }
306
d8d215e @tonycoz [rt #71564] fix i_render_color() to work in normal mode
authored
307 SKIP:
308 { # RT 71564
309 my $noalpha = Imager::Color->new(255, 255, 255, 0);
310 my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt',
311 color => $noalpha);
312 ok($font, "loaded fontfiles/ImUgly.ttf")
313 or skip("Could not load test font: ".Imager->errstr, 4);
314 {
315 my $im = Imager->new(xsize => 40, ysize => 20);
316 my $copy = $im->copy;
317 ok($im->string(string => "AB", size => 20, aa => 1,
318 x => 0, y => 15, font => $font),
319 "draw with transparent color, aa");
320 is_image($im, $copy, "should draw nothing");
321 }
322 {
323 my $im = Imager->new(xsize => 40, ysize => 20);
324 my $copy = $im->copy;
325 ok($im->string(string => "AB", size => 20, aa => 0,
326 x => 0, y => 15, font => $font),
327 "draw with transparent color, non-aa");
328 local $TODO = "RT 73359 - non-AA text isn't normal mode rendered";
329 is_image($im, $copy, "should draw nothing");
330 }
331 }
332
4419192 converted to Test::More
Tony Cook authored
333 ok(1, "end of code");
4f68b48 support UTF with Freetype 1.x
Tony Cook authored
334 }
Something went wrong with that request. Please try again.