avoid dead code in i_ft2_glyph_name()
[imager.git] / FT2 / t / t10ft2.t
CommitLineData
faa9b3e7 1#!perl -w
f5dae600 2use strict;
4eb9a521 3use Test::More;
b851aeeb 4use Cwd qw(getcwd abs_path);
faa9b3e7 5
50c75381 6use Imager qw(:all);
faa9b3e7 7
36f8c315 8use Imager::Test qw(diff_text_with_nul is_color3 is_color4 isnt_image is_image);
9a6ab99c 9
50c75381
TC
10-d "testout" or mkdir "testout";
11
b9459ada
TC
12my @test_output;
13
14push @test_output, "t38ft2font.log";
15
16Imager->open_log(log => "testout/t38ft2font.log");
faa9b3e7 17
b851aeeb
TC
18my $deffont = "fontfiles/dodge.ttf";
19
185531af 20my @base_color = (64, 255, 64);
faa9b3e7 21
185531af
TC
22SKIP:
23{
50c75381 24 ok($Imager::formats{ft2}, "ft2 should be in %formats");
faa9b3e7 25
b851aeeb 26 my $fontname=$ENV{'TTFONTTEST'} || $deffont;
faa9b3e7 27
61e5a61a 28 -f $fontname or skip("cannot find fontfile $fontname", 189);
faa9b3e7 29
17dd918e
TC
30 print STDERR "FreeType2 runtime ", Imager::Font::FT2::i_ft2_version(1),
31 " compile-time ", Imager::Font::FT2::i_ft2_version(0), "\n";
faa9b3e7 32
185531af
TC
33 my $bgcolor=i_color_new(255,0,0,0);
34 my $overlay=Imager::ImgRaw::new(200,70,3);
35
50c75381 36 my $ttraw=Imager::Font::FT2::i_ft2_new($fontname, 0);
185531af
TC
37
38 $ttraw or print Imager::_error_as_msg(),"\n";
39 ok($ttraw, "loaded raw font");
faa9b3e7 40
50c75381 41 my @bbox=Imager::Font::FT2::i_ft2_bbox($ttraw, 50.0, 0, 'XMCLH', 0);
185531af
TC
42 print "#bbox @bbox\n";
43
dc35bde9 44 is(@bbox, 8, "i_ft2_bbox() returns 8 values");
3799c4d1 45
50c75381 46 ok(Imager::Font::FT2::i_ft2_cp($ttraw,$overlay,5,50,1,50.0,50, 'XMCLH',1,1, 0, 0), "drawn to channel");
185531af 47 i_line($overlay,0,50,100,50,$bgcolor,1);
3799c4d1 48
b9459ada 49 push @test_output, "t38ft2font.ppm";
185531af
TC
50 open(FH,">testout/t38ft2font.ppm") || die "cannot open testout/t38ft2font.ppm\n";
51 binmode(FH);
52 my $IO = Imager::io_new_fd(fileno(FH));
53 ok(i_writeppm_wiol($overlay, $IO), "saved image");
54 close(FH);
3799c4d1 55
185531af
TC
56 $bgcolor=i_color_set($bgcolor,200,200,200,0);
57 my $backgr=Imager::ImgRaw::new(500,300,3);
58
59 # i_tt_set_aa(2);
50c75381
TC
60 ok(Imager::Font::FT2::i_ft2_text($ttraw,$backgr,100,150,NC(255, 64, 64),200.0,50, 'MAW',1,1,0, 0), "drew MAW");
61 Imager::Font::FT2::i_ft2_settransform($ttraw, [0.9659, 0.2588, 0, -0.2588, 0.9659, 0 ]);
62 ok(Imager::Font::FT2::i_ft2_text($ttraw,$backgr,100,150,NC(0, 128, 0),200.0,50, 'MAW',0,1, 0, 0), "drew rotated MAW");
185531af 63 i_line($backgr, 0,150, 499, 150, NC(0, 0, 255),1);
3799c4d1 64
b9459ada 65 push @test_output, "t38ft2font2.ppm";
185531af
TC
66 open(FH,">testout/t38ft2font2.ppm") || die "cannot open testout/t38ft2font.ppm\n";
67 binmode(FH);
68 $IO = Imager::io_new_fd(fileno(FH));
69 ok(i_writeppm_wiol($backgr,$IO), "saved second image");
70 close(FH);
3799c4d1 71
185531af
TC
72 my $oof = Imager::Font->new(file=>$fontname, type=>'ft2', 'index'=>0);
73
74 ok($oof, "loaded OO font");
75
76 my $im = Imager->new(xsize=>400, ysize=>250);
77
78 ok($im->string(font=>$oof,
79 text=>"Via OO",
80 'x'=>20,
81 'y'=>20,
82 size=>60,
83 color=>NC(255, 128, 255),
84 aa => 1,
85 align=>0), "drawn through OO interface");
86 ok($oof->transform(matrix=>[1, 0.1, 0, 0, 1, 0]),
87 "set matrix via OO interface");
88 ok($im->string(font=>$oof,
89 text=>"Shear",
90 'x'=>20,
91 'y'=>40,
92 size=>60,
93 sizew=>50,
94 channel=>1,
95 aa=>1,
96 align=>1), "drawn transformed through OO");
97 use Imager::Matrix2d ':handy';
98 ok($oof->transform(matrix=>m2d_rotate(degrees=>-30)),
99 "set transform from m2d module");
100 ok($im->string(font=>$oof,
101 text=>"SPIN",
102 'x'=>20,
103 'y'=>50,
104 size=>50,
105 sizew=>40,
106 color=>NC(255,255,0),
107 aa => 1,
108 align=>0, vlayout=>0), "drawn first rotated");
109
110 ok($im->string(font=>$oof,
111 text=>"SPIN",
112 'x'=>20,
113 'y'=>50,
114 size=>50,
115 sizew=>40,
116 channel=>2,
117 aa => 1,
118 align=>0, vlayout=>0), "drawn second rotated");
119
120 $oof->transform(matrix=>m2d_identity());
121 $oof->hinting(hinting=>1);
122
123 # UTF8 testing
124 # the test font (dodge.ttf) only supports one character above 0xFF that
125 # I can see, 0x2010 HYPHEN (which renders the same as 0x002D HYPHEN MINUS)
126 # an attempt at utf8 support
127 # first attempt to use native perl UTF8
128 SKIP:
129 {
130 skip("no native UTF8 support in this version of perl", 1)
131 unless $] >= 5.006;
132 my $text;
133 # we need to do this in eval to prevent compile time errors in older
134 # versions
135 eval q{$text = "A\x{2010}A"}; # A, HYPHEN, A in our test font
136 #$text = "A".chr(0x2010)."A"; # this one works too
137 unless (ok($im->string(font=>$oof,
138 text=>$text,
139 'x'=>20,
140 'y'=>200,
141 size=>50,
142 color=>NC(0,255,0),
143 aa=>1), "drawn UTF natively")) {
144 print "# ",$im->errstr,"\n";
145 }
36f8c315 146
042cdaea 147 }
185531af
TC
148
149 # an attempt using emulation of UTF8
150 my $text = pack("C*", 0x41, 0xE2, 0x80, 0x90, 0x41);
151 #my $text = "A\xE2\x80\x90\x41\x{2010}";
152 #substr($text, -1, 0) = '';
153 unless (ok($im->string(font=>$oof,
154 text=>$text,
155 'x'=>20,
156 'y'=>230,
157 size=>50,
158 color=>NC(255,128,0),
159 aa=>1,
160 utf8=>1), "drawn UTF emulated")) {
161 print "# ",$im->errstr,"\n";
042cdaea 162 }
3799c4d1 163
185531af
TC
164 # just a bit of fun
165 # well it was - it demostrates what happens when you combine
166 # transformations and font hinting
167 for my $steps (0..39) {
168 $oof->transform(matrix=>m2d_rotate(degrees=>-$steps+5));
169 # demonstrates why we disable hinting on a doing a transform
170 # if the following line is enabled then the 0 degrees output sticks
171 # out a bit
172 # $oof->hinting(hinting=>1);
173 $im->string(font=>$oof,
174 text=>"SPIN",
175 'x'=>160,
176 'y'=>70,
177 size=>65,
178 color=>NC(255, $steps * 5, 200-$steps * 5),
179 aa => 1,
180 align=>0, );
3799c4d1 181 }
185531af 182
b9459ada 183 push @test_output, "t38_oo.ppm";
185531af
TC
184 $im->write(file=>'testout/t38_oo.ppm')
185 or print "# could not save OO output: ",$im->errstr,"\n";
186
187 my (@got) = $oof->has_chars(string=>"\x01H");
188 ok(@got == 2, "has_chars returned 2 items");
189 ok(!$got[0], "have no chr(1)");
190 ok($got[1], "have 'H'");
5386861e 191 is($oof->has_chars(string=>"H\x01"), "\x01\x00",
185531af
TC
192 "scalar has_chars()");
193
194 print "# OO bounding boxes\n";
195 @bbox = $oof->bounding_box(string=>"hello", size=>30);
196 my $bbox = $oof->bounding_box(string=>"hello", size=>30);
197
dc35bde9 198 is(@bbox, 8, "list bbox returned 8 items");
185531af
TC
199 ok($bbox->isa('Imager::Font::BBox'), "scalar bbox returned right class");
200 ok($bbox->start_offset == $bbox[0], "start_offset");
201 ok($bbox->end_offset == $bbox[2], "end_offset");
202 ok($bbox->global_ascent == $bbox[3], "global_ascent");
203 ok($bbox->global_descent == $bbox[1], "global_descent");
204 ok($bbox->ascent == $bbox[5], "ascent");
205 ok($bbox->descent == $bbox[4], "descent");
206 ok($bbox->advance_width == $bbox[6], "advance_width");
207
208 print "# aligned text output\n";
209 my $alimg = Imager->new(xsize=>300, ysize=>300);
210 $alimg->box(color=>'40FF40', filled=>1);
211
212 $oof->transform(matrix=>m2d_identity());
213 $oof->hinting(hinting=>1);
214
215 align_test('left', 'top', 10, 10, $oof, $alimg);
216 align_test('start', 'top', 10, 40, $oof, $alimg);
217 align_test('center', 'top', 150, 70, $oof, $alimg);
218 align_test('end', 'top', 290, 100, $oof, $alimg);
219 align_test('right', 'top', 290, 130, $oof, $alimg);
220
221 align_test('center', 'top', 150, 160, $oof, $alimg);
222 align_test('center', 'center', 150, 190, $oof, $alimg);
223 align_test('center', 'bottom', 150, 220, $oof, $alimg);
224 align_test('center', 'baseline', 150, 250, $oof, $alimg);
225
b9459ada 226 push @test_output, "t38aligned.ppm";
185531af
TC
227 ok($alimg->write(file=>'testout/t38aligned.ppm'),
228 "saving aligned output image");
229
230 my $exfont = Imager::Font->new(file=>'fontfiles/ExistenceTest.ttf',
231 type=>'ft2');
232 SKIP:
233 {
50c75381
TC
234 ok($exfont, "loaded existence font")
235 or diag(Imager->errstr);
236 $exfont
237 or skip("couldn't load test font", 11);
dc35bde9 238
185531af
TC
239 # the test font is known to have a shorter advance width for that char
240 my @bbox = $exfont->bounding_box(string=>"/", size=>100);
dc35bde9 241 is(@bbox, 8, "should be 8 entries");
185531af
TC
242 isnt($bbox[6], $bbox[2], "different advance width");
243 my $bbox = $exfont->bounding_box(string=>"/", size=>100);
244 ok($bbox->pos_width != $bbox->advance_width, "OO check");
245
dc35bde9
TC
246 cmp_ok($bbox->right_bearing, '<', 0, "check right bearing");
247
248 cmp_ok($bbox->display_width, '>', $bbox->advance_width,
249 "check display width (roughly)");
250
251 # check with a char that fits inside the box
319bf94b 252 $bbox = $exfont->bounding_box(string=>"!", size=>100);
dc35bde9
TC
253 print "# pos width ", $bbox->pos_width, "\n";
254 is($bbox->pos_width, $bbox->advance_width,
255 "check backwards compatibility");
256 cmp_ok($bbox->left_bearing, '>', 0, "left bearing positive");
257 cmp_ok($bbox->right_bearing, '>', 0, "right bearing positive");
258 cmp_ok($bbox->display_width, '<', $bbox->advance_width,
259 "display smaller than advance");
260
185531af
TC
261 # name tests
262 # make sure the number of tests on each branch match
50c75381
TC
263 if (Imager::Font::FT2::i_ft2_can_face_name()) {
264 my $facename = Imager::Font::FT2::i_ft2_face_name($exfont->{id});
185531af 265 print "# face name '$facename'\n";
5386861e 266 is($facename, 'ExistenceTest', "test face name");
185531af 267 $facename = $exfont->face_name;
5386861e 268 is($facename, 'ExistenceTest', "test face name OO");
185531af
TC
269 }
270 else {
271 # make sure we get the error we expect
50c75381 272 my $facename = Imager::Font::FT2::i_ft2_face_name($exfont->{id});
185531af
TC
273 my ($msg) = Imager::_error_as_msg();
274 ok(!defined($facename), "test face name not supported");
275 print "# $msg\n";
276 ok(scalar($msg =~ /or later required/), "test face name not supported");
277 }
a4168bea
TC
278 }
279
185531af
TC
280 SKIP:
281 {
50c75381 282 Imager::Font::FT2->can_glyph_names
185531af
TC
283 or skip("FT2 compiled without glyph names support", 9);
284
285 # FT2 considers POST tables in TTF fonts unreliable, so use
286 # a type 1 font, see below for TTF test
287 my $exfont = Imager::Font->new(file=>'fontfiles/ExistenceTest.pfb',
a4168bea 288 type=>'ft2');
185531af
TC
289 SKIP:
290 {
291 ok($exfont, "load Type 1 via FT2")
292 or skip("couldn't load type 1 with FT2", 8);
293 my @glyph_names =
50c75381 294 Imager::Font::FT2::i_ft2_glyph_name($exfont->{id}, "!J/");
185531af
TC
295 #use Data::Dumper;
296 #print Dumper \@glyph_names;
297 is($glyph_names[0], 'exclam', "check exclam name");
298 ok(!defined($glyph_names[1]), "check for no J name");
299 is($glyph_names[2], 'slash', "check slash name");
300
301 # oo interfaces
302 @glyph_names = $exfont->glyph_names(string=>"!J/");
303 is($glyph_names[0], 'exclam', "check exclam name OO");
304 ok(!defined($glyph_names[1]), "check for no J name OO");
305 is($glyph_names[2], 'slash', "check slash name OO");
306
307 # make sure a missing string parameter is handled correctly
308 eval {
309 $exfont->glyph_names();
310 };
311 is($@, "", "correct error handling");
312 cmp_ok(Imager->errstr, '=~', qr/no string parameter/, "error message");
313 }
314
315 # freetype 2 considers truetype glyph name tables unreliable
316 # due to some specific fonts, supplying reliable_only=>0 bypasses
317 # that check and lets us get the glyph names even for truetype fonts
318 # so we can test this stuff <sigh>
319 # we can't use ExistenceTest.ttf since that's generated with
320 # AppleStandardEncoding since the same .sfd needs to generate
321 # a .pfb file, NameTest.ttf uses a Unicode encoding
322
323 # we were using an unsigned char to store a unicode character
324 # https://rt.cpan.org/Ticket/Display.html?id=7949
325 $exfont = Imager::Font->new(file=>'fontfiles/NameTest.ttf',
326 type=>'ft2');
327 SKIP:
328 {
329 ok($exfont, "load TTF via FT2")
330 or skip("could not load TTF with FT2", 1);
331 my $text = pack("C*", 0xE2, 0x80, 0x90); # "\x{2010}" as utf-8
332 my @names = $exfont->glyph_names(string=>$text,
333 utf8=>1, reliable_only=>0);
334 is($names[0], "hyphentwo", "check utf8 glyph name");
4eb9a521
TC
335
336 # make sure we get an empty list with bad utf8
337 my @bad = $exfont->glyph_names(string => "ab\xC0", utf8 => 1);
338 is(@bad, 0, "properly got empty result with bad utf8");
185531af 339 }
3799c4d1 340 }
3799c4d1 341
185531af 342 # check that error codes are translated correctly
50c75381 343 my $errfont = Imager::Font->new(file=>"t/t10ft2.t", type=>"ft2");
185531af
TC
344 is($errfont, undef, "new font vs non font");
345 cmp_ok(Imager->errstr, '=~', qr/unknown file format/, "check error message");
346
347 # Multiple Master tests
348 # we check a non-MM font errors correctly
349 print "# check that the methods act correctly for a non-MM font\n";
350 ok(!$exfont->is_mm, "exfont not MM");
351 ok((() = $exfont->mm_axes) == 0, "exfont has no MM axes");
352 cmp_ok(Imager->errstr, '=~', qr/no multiple masters/,
353 "and returns correct error when we ask");
354 ok(!$exfont->set_mm_coords(coords=>[0, 0]), "fail setting axis on exfont");
355 cmp_ok(Imager->errstr, '=~', qr/no multiple masters/,
356 "and returns correct error when we ask");
357
358 # try a MM font now - test font only has A defined
359 print "# Try a multiple master font\n";
360 my $mmfont = Imager::Font->new(file=>"fontfiles/MMOne.pfb", type=>"ft2",
361 color=>"white", aa=>1, size=>60);
4bc9bad2
TC
362 ok($mmfont, "loaded MM font")
363 or print "# ", Imager->errstr, "\n";
185531af
TC
364 ok($mmfont->is_mm, "font is multiple master");
365 my @axes = $mmfont->mm_axes;
366 is(@axes, 2, "check we got both axes");
367 is($axes[0][0], "Weight", "name of first axis");
368 is($axes[0][1], 50, "min for first axis");
369 is($axes[0][2], 999, "max for first axis");
370 is($axes[1][0], "Slant", "name of second axis");
371 is($axes[1][1], 0, "min for second axis");
372 is($axes[1][2], 999, "max for second axis");
373 my $mmim = Imager->new(xsize=>200, ysize=>200);
374 $mmim->string(font=>$mmfont, x=>0, 'y'=>50, text=>"A");
375 ok($mmfont->set_mm_coords(coords=>[ 700, 0 ]), "set to bold, unsloped");
376 $mmim->string(font=>$mmfont, x=>0, 'y'=>100, text=>"A", color=>'blue');
377 my @weights = qw(50 260 525 760 999);
378 my @slants = qw(0 333 666 999);
379 for my $windex (0 .. $#weights) {
380 my $weight = $weights[$windex];
381 for my $sindex (0 .. $#slants) {
382 my $slant = $slants[$sindex];
383 $mmfont->set_mm_coords(coords=>[ $weight, $slant ]);
384 $mmim->string(font=>$mmfont, x=>30+32*$windex, 'y'=>50+45*$sindex,
385 text=>"A");
386 }
3e882362 387 }
3e882362 388
b9459ada 389 push @test_output, "t38mm.ppm";
185531af 390 ok($mmim->write(file=>"testout/t38mm.ppm"), "save MM output");
490aa9ae
TC
391
392 SKIP:
393 { print "# alignment tests\n";
6a00d627 394 my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'ft2');
490aa9ae
TC
395 ok($font, "loaded deffont OO")
396 or skip("could not load font:".Imager->errstr, 4);
9ab6338b
TC
397 my $im = Imager->new(xsize=>140, ysize=>150);
398 my %common =
490aa9ae
TC
399 (
400 font=>$font,
490aa9ae 401 size=>40,
490aa9ae
TC
402 aa=>1,
403 );
9ab6338b
TC
404 $im->line(x1=>0, y1=>40, x2=>139, y2=>40, color=>'blue');
405 $im->line(x1=>0, y1=>90, x2=>139, y2=>90, color=>'blue');
406 $im->line(x1=>0, y1=>110, x2=>139, y2=>110, color=>'blue');
407 for my $args ([ x=>5, text=>"A", color=>"white" ],
408 [ x=>40, text=>"y", color=>"white" ],
a6d9b737
TC
409 [ x=>75, text=>"A", channel=>1 ],
410 [ x=>110, text=>"y", channel=>1 ]) {
9ab6338b
TC
411 ok($im->string(%common, @$args, 'y'=>40), "A no alignment");
412 ok($im->string(%common, @$args, 'y'=>90, align=>1), "A align=1");
413 ok($im->string(%common, @$args, 'y'=>110, align=>0), "A align=0");
414 }
b9459ada 415 push @test_output, "t38align.ppm";
490aa9ae
TC
416 ok($im->write(file=>'testout/t38align.ppm'), "save align image");
417 }
e15cea68
TC
418
419
420 { # outputting a space in non-AA could either crash
421 # or fail (ft 2.2+)
422 my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'ft2');
423 my $im = Imager->new(xsize => 100, ysize => 100);
424 ok($im->string(x => 10, y => 10, string => "test space", aa => 0,
425 color => '#FFF', size => 8, font => $font),
426 "draw space non-antialiased (color)");
427 ok($im->string(x => 10, y => 50, string => "test space", aa => 0,
428 channel => 0, size => 8, font => $font),
429 "draw space non-antialiased (channel)");
430 }
4314a320
TC
431
432 { # cannot output "0"
9a6ab99c 433 # https://rt.cpan.org/Ticket/Display.html?id=21770
4314a320
TC
434 my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'ft2');
435 ok($font, "loaded imugly");
436 my $imbase = Imager->new(xsize => 100, ysize => 100);
437 my $im = $imbase->copy;
438 ok($im->string(x => 10, y => 50, string => "0", aa => 0,
439 color => '#FFF', size => 20, font => $font),
440 "draw '0'");
441 ok(Imager::i_img_diff($im->{IMG}, $imbase->{IMG}),
442 "make sure we actually drew it");
443 $im = $imbase->copy;
444 ok($im->string(x => 10, y => 50, string => 0.0, aa => 0,
445 color => '#FFF', size => 20, font => $font),
446 "draw 0.0");
447 ok(Imager::i_img_diff($im->{IMG}, $imbase->{IMG}),
448 "make sure we actually drew it");
449 }
9a6ab99c
TC
450 { # string output cut off at NUL ('\0')
451 # https://rt.cpan.org/Ticket/Display.html?id=21770 cont'd
452 my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'ft2');
453 ok($font, "loaded imugly");
454
455 diff_text_with_nul("a\\0b vs a", "a\0b", "a",
456 font => $font, color => '#FFFFFF');
457 diff_text_with_nul("a\\0b vs a", "a\0b", "a",
458 font => $font, channel => 1);
459
460 # UTF8 encoded \x{2010}
461 my $dash = pack("C*", 0xE2, 0x80, 0x90);
462 diff_text_with_nul("utf8 dash\0dash vs dash", "$dash\0$dash", $dash,
463 font => $font, color => '#FFFFFF', utf8 => 1);
464 diff_text_with_nul("utf8 dash\0dash vs dash", "$dash\0$dash", $dash,
465 font => $font, channel => 1, utf8 => 1);
466 }
a4947da7
TC
467
468 { # RT 11972
469 # when rendering to a transparent image the coverage should be
470 # expressed in terms of the alpha channel rather than the color
471 my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'ft2');
472 my $im = Imager->new(xsize => 40, ysize => 20, channels => 4);
473 ok($im->string(string => "AB", size => 20, aa => 1, color => '#F00',
474 x => 0, y => 15, font => $font),
475 "draw to transparent image");
a4947da7
TC
476 my $im_noalpha = $im->convert(preset => 'noalpha');
477 my $im_pal = $im->to_paletted(make_colors => 'mediancut');
478 my @colors = $im_pal->getcolors;
479 is(@colors, 2, "should be only 2 colors");
480 @colors = sort { ($a->rgba)[0] <=> ($b->rgba)[0] } @colors;
481 is_color3($colors[0], 0, 0, 0, "check we got black");
482 is_color3($colors[1], 255, 0, 0, "and red");
483 }
e6e94ab0
TC
484
485 { # RT 27546
486 my $im = Imager->new(xsize => 100, ysize => 100, channels => 4);
487 $im->box(filled => 1, color => '#ff0000FF');
488 my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'ft2');
489 ok($im->string(x => 0, 'y' => 40, text => 'test',
490 size => 11, sizew => 11, font => $font, aa => 1),
491 'draw on translucent image')
492 }
120f4287
TC
493
494 { # RT 60199
495 # not ft2 specific, but Imager
496 my $im = Imager->new(xsize => 100, ysize => 100);
497 my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'ft2');
498 my $imcopy = $im->copy;
499 ok($im, "make test image");
500 ok($font, "make test font");
501 ok($im->align_string(valign => "center", halign => "center",
502 x => 50, y => 50, string => "0", color => "#FFF",
503 font => $font),
504 "draw 0 aligned");
505 ok(Imager::i_img_diff($im->{IMG}, $imcopy->{IMG}),
506 "make sure we drew the '0'");
507 }
b851aeeb
TC
508
509 SKIP:
510 { # RT 60509
511 # checks that a c:foo or c:\foo path is handled correctly on win32
512 my $type = "ft2";
513 $^O eq "MSWin32" || $^O eq "cygwin"
514 or skip("only for win32", 2);
515 my $dir = getcwd
516 or skip("Cannot get cwd", 2);
517 if ($^O eq "cygwin") {
518 $dir = Cygwin::posix_to_win_path($dir);
519 }
520 my $abs_path = abs_path($deffont);
521 my $font = Imager::Font->new(file => $abs_path, type => $type);
522 ok($font, "found font by absolute path")
523 or print "# path $abs_path\n";
524 undef $font;
525
526 $^O eq "cygwin"
527 and skip("cygwin doesn't support drive relative DOSsish paths", 1);
528 my ($drive) = $dir =~ /^([a-z]:)/i
529 or skip("cwd has no drive letter", 2);
530 my $drive_path = $drive . $deffont;
531 $font = Imager::Font->new(file => $drive_path, type => $type);
532 ok($font, "found font by drive relative path")
533 or print "# path $drive_path\n";
534 }
61e5a61a
TC
535 { # RT 71469
536 my $font1 = Imager::Font->new(file => $deffont, type => "ft2", index => 0);
537 my $font2 = Imager::Font::FT2->new(file => $deffont, index => 0);
538
539 for my $font ($font1, $font2) {
540 print "# ", join(",", $font->{color}->rgba), "\n";
541
542 my $im = Imager->new(xsize => 20, ysize => 20, channels => 4);
543
544 ok($im->string(text => "T", font => $font, y => 15),
545 "draw with default color")
546 or print "# ", $im->errstr, "\n";
547 my $work = Imager->new(xsize => 20, ysize => 20);
548 my $cmp = $work->copy;
549 $work->rubthrough(src => $im);
550 isnt_image($work, $cmp, "make sure something was drawn");
551 }
552 }
b9459ada
TC
553
554 { # RT 73359
555 # non-AA font drawing isn't normal mode
556
557 Imager->log("testing no-aa normal output\n");
558
559 my $font = Imager::Font->new(file => "fontfiles/ImUgly.ttf", type => "ft2");
560
561 ok($font, "make a work font");
562
563 my %common =
564 (
565 x => 10,
566 font => $font,
567 size => 25,
568 aa => 0,
569 align => 0,
570 );
571
572 # build our comparison image
573 my $cmp = Imager->new(xsize => 120, ysize => 100);
574 my $layer = Imager->new(xsize => 120, ysize => 100, channels => 4);
575 ok($layer->string(%common, y => 10, text => "full", color => "#8080FF"),
576 "draw non-aa text at full coverage to layer image");
577 ok($layer->string(%common, y => 40, text => "half", color => "#FF808080"),
578 "draw non-aa text at half coverage to layer image");
579 ok($layer->string(%common, y => 70, text => "quarter", color => "#80FF8040"),
580 "draw non-aa text at zero coverage to layer image");
581 ok($cmp->rubthrough(src => $layer), "rub layer onto comparison image");
582
583 my $im = Imager->new(xsize => 120, ysize => 100);
584 ok($im->string(%common, y => 10, text => "full", color => "#8080FF"),
585 "draw non-aa text at full coverage");
586 ok($im->string(%common, y => 40, text => "half", color => "#FF808080"),
587 "draw non-aa text at half coverage");
588 ok($im->string(%common, y => 70, text => "quarter", color => "#80FF8040"),
589 "draw non-aa text at zero coverage");
590 is_image($im, $cmp, "check the result");
591
592 push @test_output, "noaanorm.ppm", "noaacmp.ppm";
593 ok($cmp->write(file => "testout/noaacmp.ppm"), "save cmp image")
594 or diag "Saving cmp image: ", $cmp->errstr;
595 ok($im->write(file => "testout/noaanorm.ppm"), "save test image")
596 or diag "Saving result image: ", $im->errstr;
597 }
598}
599
600Imager->close_log();
601
4eb9a521
TC
602done_testing();
603
b9459ada
TC
604END {
605 unless ($ENV{IMAGER_KEEP_FILES}) {
606 unlink map "testout/$_", @test_output;
607 }
185531af 608}
3e882362 609
3799c4d1
TC
610sub align_test {
611 my ($h, $v, $x, $y, $f, $img) = @_;
612
613 my @pos = $f->align(halign=>$h, valign=>$v, 'x'=>$x, 'y'=>$y,
614 image=>$img, size=>15, color=>'FFFFFF',
615 string=>"x$h ${v}y", channel=>1, aa=>1);
a7ccc5e2
TC
616 @pos = $img->align_string(halign=>$h, valign=>$v, 'x'=>$x, 'y'=>$y,
617 font=>$f, size=>15, color=>'FF99FF',
3a6bb91b 618 string=>"x$h ${v}y", aa=>1);
185531af 619 if (ok(@pos == 4, "$h $v aligned output")) {
3799c4d1
TC
620 # checking corners
621 my $cx = int(($pos[0] + $pos[2]) / 2);
622 my $cy = int(($pos[1] + $pos[3]) / 2);
623
624 print "# @pos cx $cx cy $cy\n";
625 okmatchcolor($img, $cx, $pos[1]-1, @base_color, "outer top edge");
626 okmatchcolor($img, $cx, $pos[3], @base_color, "outer bottom edge");
627 okmatchcolor($img, $pos[0]-1, $cy, @base_color, "outer left edge");
628 okmatchcolor($img, $pos[2], $cy, @base_color, "outer right edge");
629
630 okmismatchcolor($img, $cx, $pos[1], @base_color, "inner top edge");
631 okmismatchcolor($img, $cx, $pos[3]-1, @base_color, "inner bottom edge");
632 okmismatchcolor($img, $pos[0], $cy, @base_color, "inner left edge");
3a6bb91b
AMH
633# okmismatchcolor($img, $pos[2]-1, $cy, @base_color, "inner right edge");
634# XXX: This gets triggered by a freetype2 bug I think
635# $ rpm -qa | grep freetype
636# freetype-2.1.3-6
637#
638# (addi: 4/1/2004).
639
3799c4d1
TC
640 cross($img, $x, $y, 'FF0000');
641 cross($img, $cx, $pos[1]-1, '0000FF');
642 cross($img, $cx, $pos[3], '0000FF');
643 cross($img, $pos[0]-1, $cy, '0000FF');
644 cross($img, $pos[2], $cy, '0000FF');
645 }
646 else {
a7ccc5e2 647 SKIP: { skip("couldn't draw text", 7) };
3799c4d1
TC
648 }
649}
650
651sub okmatchcolor {
652 my ($img, $x, $y, $r, $g, $b, $about) = @_;
653
654 my $c = $img->getpixel('x'=>$x, 'y'=>$y);
655 my ($fr, $fg, $fb) = $c->rgba;
185531af 656 ok($fr == $r && $fg == $g && $fb == $b,
3799c4d1
TC
657 "want ($r,$g,$b) found ($fr,$fg,$fb)\@($x,$y) $about");
658}
659
660sub okmismatchcolor {
661 my ($img, $x, $y, $r, $g, $b, $about) = @_;
662
663 my $c = $img->getpixel('x'=>$x, 'y'=>$y);
664 my ($fr, $fg, $fb) = $c->rgba;
185531af 665 ok($fr != $r || $fg != $g || $fb != $b,
3799c4d1
TC
666 "don't want ($r,$g,$b) found ($fr,$fg,$fb)\@($x,$y) $about");
667}
668
669sub cross {
670 my ($img, $x, $y, $color) = @_;
671
672 $img->setpixel('x'=>[$x, $x, $x, $x, $x, $x-2, $x-1, $x+1, $x+2],
673 'y'=>[$y-2, $y-1, $y, $y+1, $y+2, $y, $y, $y, $y],
674 color => $color);
675
676}
36f8c315 677
36f8c315 678