t/t38ft2font.t

   1 #!perl -w
   2 use strict;
   3 use Test::More tests => 152;
   4 ++$|;
   5 # Before `make install' is performed this script should be runnable with
   6 # `make test'. After `make install' it should work as `perl test.pl'
   7
   8 ######################### We start with some black magic to print on failure.
   9
  10 # Change 1..1 below to 1..last_test_to_print .
  11 # (It may become useful if the test is moved to ./t subdirectory.)
  12
  13 BEGIN { use_ok(Imager => ':all') }
  14
  15 init_log("testout/t38ft2font.log",2);
  16
  17 my @base_color = (64, 255, 64);
  18
  19 SKIP:
  20 {
  21   i_has_format("ft2") or skip("no freetype2 library found", 151);
  22
  23   print "# has ft2\n";
  24
  25   my $fontname=$ENV{'TTFONTTEST'}||'./fontfiles/dodge.ttf';
  26
  27   -f $fontname or skip("cannot find fontfile $fontname", 151);
  28
  29
  30   my $bgcolor=i_color_new(255,0,0,0);
  31   my $overlay=Imager::ImgRaw::new(200,70,3);
  32
  33   my $ttraw=Imager::Font::FreeType2::i_ft2_new($fontname, 0);
  34
  35   $ttraw or print Imager::_error_as_msg(),"\n";
  36   ok($ttraw, "loaded raw font");
  37
  38   my @bbox=Imager::Font::FreeType2::i_ft2_bbox($ttraw, 50.0, 0, 'XMCLH', 0);
  39   print "#bbox @bbox\n";
  40
  41   is(@bbox, 8, "i_ft2_bbox() returns 8 values");
  42
  43   ok(Imager::Font::FreeType2::i_ft2_cp($ttraw,$overlay,5,50,1,50.0,50, 'XMCLH',1,1, 0, 0), "drawn to channel");
  44   i_line($overlay,0,50,100,50,$bgcolor,1);
  45
  46   open(FH,">testout/t38ft2font.ppm") || die "cannot open testout/t38ft2font.ppm\n";
  47   binmode(FH);
  48   my $IO = Imager::io_new_fd(fileno(FH));
  49   ok(i_writeppm_wiol($overlay, $IO), "saved image");
  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   ok(Imager::Font::FreeType2::i_ft2_text($ttraw,$backgr,100,150,NC(255, 64, 64),200.0,50, 'MAW',1,1,0, 0), "drew MAW");
  57   Imager::Font::FreeType2::i_ft2_settransform($ttraw, [0.9659, 0.2588, 0, -0.2588, 0.9659, 0 ]);
  58   ok(Imager::Font::FreeType2::i_ft2_text($ttraw,$backgr,100,150,NC(0, 128, 0),200.0,50, 'MAW',0,1, 0, 0), "drew rotated MAW");
  59   i_line($backgr, 0,150, 499, 150, NC(0, 0, 255),1);
  60
  61   open(FH,">testout/t38ft2font2.ppm") || die "cannot open testout/t38ft2font.ppm\n";
  62   binmode(FH);
  63   $IO = Imager::io_new_fd(fileno(FH));
  64   ok(i_writeppm_wiol($backgr,$IO), "saved second image");
  65   close(FH);
  66
  67   my $oof = Imager::Font->new(file=>$fontname, type=>'ft2', 'index'=>0);
  68
  69   ok($oof, "loaded OO font");
  70
  71   my $im = Imager->new(xsize=>400, ysize=>250);
  72
  73   ok($im->string(font=>$oof,
  74                  text=>"Via OO",
  75                  'x'=>20,
  76                  'y'=>20,
  77                  size=>60,
  78                  color=>NC(255, 128, 255),
  79                  aa => 1,
  80                  align=>0), "drawn through OO interface");
  81   ok($oof->transform(matrix=>[1, 0.1, 0, 0, 1, 0]),
  82      "set matrix via OO interface");
  83   ok($im->string(font=>$oof,
  84                  text=>"Shear",
  85                  'x'=>20,
  86                  'y'=>40,
  87                  size=>60,
  88                  sizew=>50,
  89                  channel=>1,
  90                  aa=>1,
  91                  align=>1), "drawn transformed through OO");
  92   use Imager::Matrix2d ':handy';
  93   ok($oof->transform(matrix=>m2d_rotate(degrees=>-30)),
  94      "set transform from m2d module");
  95   ok($im->string(font=>$oof,
  96                  text=>"SPIN",
  97                  'x'=>20,
  98                  'y'=>50,
  99                  size=>50,
 100                  sizew=>40,
 101                  color=>NC(255,255,0),
 102                  aa => 1,
 103                  align=>0, vlayout=>0), "drawn first rotated");
 104
 105   ok($im->string(font=>$oof,
 106                  text=>"SPIN",
 107                  'x'=>20,
 108                  'y'=>50,
 109                  size=>50,
 110                  sizew=>40,
 111             channel=>2,
 112                  aa => 1,
 113                  align=>0, vlayout=>0), "drawn second rotated");
 114
 115   $oof->transform(matrix=>m2d_identity());
 116   $oof->hinting(hinting=>1);
 117
 118   # UTF8 testing
 119   # the test font (dodge.ttf) only supports one character above 0xFF that
 120   # I can see, 0x2010 HYPHEN (which renders the same as 0x002D HYPHEN MINUS)
 121   # an attempt at utf8 support
 122   # first attempt to use native perl UTF8
 123  SKIP:
 124   {
 125     skip("no native UTF8 support in this version of perl", 1)
 126       unless $] >= 5.006;
 127     my $text;
 128     # we need to do this in eval to prevent compile time errors in older
 129     # versions
 130     eval q{$text = "A\x{2010}A"}; # A, HYPHEN, A in our test font
 131     #$text = "A".chr(0x2010)."A"; # this one works too
 132     unless (ok($im->string(font=>$oof,
 133                            text=>$text,
 134                            'x'=>20,
 135                            'y'=>200,
 136                            size=>50,
 137                            color=>NC(0,255,0),
 138                            aa=>1), "drawn UTF natively")) {
 139       print "# ",$im->errstr,"\n";
 140     }
 141   }
 142
 143   # an attempt using emulation of UTF8
 144   my $text = pack("C*", 0x41, 0xE2, 0x80, 0x90, 0x41);
 145   #my $text = "A\xE2\x80\x90\x41\x{2010}";
 146   #substr($text, -1, 0) = '';
 147   unless (ok($im->string(font=>$oof,
 148                          text=>$text,
 149                          'x'=>20,
 150                          'y'=>230,
 151                          size=>50,
 152                          color=>NC(255,128,0),
 153                          aa=>1,
 154                          utf8=>1), "drawn UTF emulated")) {
 155     print "# ",$im->errstr,"\n";
 156   }
 157
 158   # just a bit of fun
 159   # well it was - it demostrates what happens when you combine
 160   # transformations and font hinting
 161   for my $steps (0..39) {
 162     $oof->transform(matrix=>m2d_rotate(degrees=>-$steps+5));
 163     # demonstrates why we disable hinting on a doing a transform
 164     # if the following line is enabled then the 0 degrees output sticks
 165     # out a bit
 166     # $oof->hinting(hinting=>1);
 167     $im->string(font=>$oof,
 168                 text=>"SPIN",
 169                 'x'=>160,
 170                 'y'=>70,
 171                 size=>65,
 172                 color=>NC(255, $steps * 5, 200-$steps * 5),
 173                 aa => 1,
 174                 align=>0, );
 175   }
 176
 177   $im->write(file=>'testout/t38_oo.ppm')
 178     or print "# could not save OO output: ",$im->errstr,"\n";
 179
 180   my (@got) = $oof->has_chars(string=>"\x01H");
 181   ok(@got == 2, "has_chars returned 2 items");
 182   ok(!$got[0], "have no chr(1)");
 183   ok($got[1], "have 'H'");
 184   ok($oof->has_chars(string=>"H\x01") eq "\x01\x00",
 185      "scalar has_chars()");
 186
 187   print "# OO bounding boxes\n";
 188   @bbox = $oof->bounding_box(string=>"hello", size=>30);
 189   my $bbox = $oof->bounding_box(string=>"hello", size=>30);
 190
 191   is(@bbox, 8, "list bbox returned 8 items");
 192   ok($bbox->isa('Imager::Font::BBox'), "scalar bbox returned right class");
 193   ok($bbox->start_offset == $bbox[0], "start_offset");
 194   ok($bbox->end_offset == $bbox[2], "end_offset");
 195   ok($bbox->global_ascent == $bbox[3], "global_ascent");
 196   ok($bbox->global_descent == $bbox[1], "global_descent");
 197   ok($bbox->ascent == $bbox[5], "ascent");
 198   ok($bbox->descent == $bbox[4], "descent");
 199   ok($bbox->advance_width == $bbox[6], "advance_width");
 200
 201   print "# aligned text output\n";
 202   my $alimg = Imager->new(xsize=>300, ysize=>300);
 203   $alimg->box(color=>'40FF40', filled=>1);
 204
 205   $oof->transform(matrix=>m2d_identity());
 206   $oof->hinting(hinting=>1);
 207
 208   align_test('left', 'top', 10, 10, $oof, $alimg);
 209   align_test('start', 'top', 10, 40, $oof, $alimg);
 210   align_test('center', 'top', 150, 70, $oof, $alimg);
 211   align_test('end', 'top', 290, 100, $oof, $alimg);
 212   align_test('right', 'top', 290, 130, $oof, $alimg);
 213
 214   align_test('center', 'top', 150, 160, $oof, $alimg);
 215   align_test('center', 'center', 150, 190, $oof, $alimg);
 216   align_test('center', 'bottom', 150, 220, $oof, $alimg);
 217   align_test('center', 'baseline', 150, 250, $oof, $alimg);
 218
 219   ok($alimg->write(file=>'testout/t38aligned.ppm'),
 220      "saving aligned output image");
 221
 222   my $exfont = Imager::Font->new(file=>'fontfiles/ExistenceTest.ttf',
 223                                  type=>'ft2');
 224   SKIP:
 225   {
 226     ok($exfont, "loaded existence font") or
 227       skip("couldn't load test font", 11);
 228
 229     # the test font is known to have a shorter advance width for that char
 230     my @bbox = $exfont->bounding_box(string=>"/", size=>100);
 231     is(@bbox, 8, "should be 8 entries");
 232     isnt($bbox[6], $bbox[2], "different advance width");
 233     my $bbox = $exfont->bounding_box(string=>"/", size=>100);
 234     ok($bbox->pos_width != $bbox->advance_width, "OO check");
 235
 236     cmp_ok($bbox->right_bearing, '<', 0, "check right bearing");
 237
 238     cmp_ok($bbox->display_width, '>', $bbox->advance_width,
 239            "check display width (roughly)");
 240
 241     # check with a char that fits inside the box
 242     $bbox = $exfont->bounding_box(string=>"!", size=>100);
 243     print "# pos width ", $bbox->pos_width, "\n";
 244     is($bbox->pos_width, $bbox->advance_width,
 245        "check backwards compatibility");
 246     cmp_ok($bbox->left_bearing, '>', 0, "left bearing positive");
 247     cmp_ok($bbox->right_bearing, '>', 0, "right bearing positive");
 248     cmp_ok($bbox->display_width, '<', $bbox->advance_width,
 249            "display smaller than advance");
 250
 251     # name tests
 252     # make sure the number of tests on each branch match
 253     if (Imager::Font::FreeType2::i_ft2_can_face_name()) {
 254       my $facename = Imager::Font::FreeType2::i_ft2_face_name($exfont->{id});
 255       print "# face name '$facename'\n";
 256       ok($facename eq 'ExistenceTest', "test face name");
 257       $facename = $exfont->face_name;
 258       ok($facename eq 'ExistenceTest', "test face name OO");
 259     }
 260     else {
 261       # make sure we get the error we expect
 262       my $facename = Imager::Font::FreeType2::i_ft2_face_name($exfont->{id});
 263       my ($msg) = Imager::_error_as_msg();
 264       ok(!defined($facename), "test face name not supported");
 265       print "# $msg\n";
 266       ok(scalar($msg =~ /or later required/), "test face name not supported");
 267     }
 268   }
 269
 270   SKIP:
 271   {
 272     Imager::Font::FreeType2->can_glyph_names
 273         or skip("FT2 compiled without glyph names support", 9);
 274
 275     # FT2 considers POST tables in TTF fonts unreliable, so use
 276     # a type 1 font, see below for TTF test
 277     my $exfont = Imager::Font->new(file=>'fontfiles/ExistenceTest.pfb',
 278                                type=>'ft2');
 279   SKIP:
 280     {
 281       ok($exfont, "load Type 1 via FT2")
 282         or skip("couldn't load type 1 with FT2", 8);
 283       my @glyph_names =
 284         Imager::Font::FreeType2::i_ft2_glyph_name($exfont->{id}, "!J/");
 285       #use Data::Dumper;
 286       #print Dumper \@glyph_names;
 287       is($glyph_names[0], 'exclam', "check exclam name");
 288       ok(!defined($glyph_names[1]), "check for no J name");
 289       is($glyph_names[2], 'slash', "check slash name");
 290
 291       # oo interfaces
 292       @glyph_names = $exfont->glyph_names(string=>"!J/");
 293       is($glyph_names[0], 'exclam', "check exclam name OO");
 294       ok(!defined($glyph_names[1]), "check for no J name OO");
 295       is($glyph_names[2], 'slash', "check slash name OO");
 296
 297       # make sure a missing string parameter is handled correctly
 298       eval {
 299         $exfont->glyph_names();
 300       };
 301       is($@, "", "correct error handling");
 302       cmp_ok(Imager->errstr, '=~', qr/no string parameter/, "error message");
 303     }
 304
 305     # freetype 2 considers truetype glyph name tables unreliable
 306     # due to some specific fonts, supplying reliable_only=>0 bypasses
 307     # that check and lets us get the glyph names even for truetype fonts
 308     # so we can test this stuff <sigh>
 309     # we can't use ExistenceTest.ttf since that's generated with
 310     # AppleStandardEncoding since the same .sfd needs to generate
 311     # a .pfb file, NameTest.ttf uses a Unicode encoding
 312
 313     # we were using an unsigned char to store a unicode character
 314     # https://rt.cpan.org/Ticket/Display.html?id=7949
 315     $exfont = Imager::Font->new(file=>'fontfiles/NameTest.ttf',
 316                                 type=>'ft2');
 317   SKIP:
 318     {
 319       ok($exfont, "load TTF via FT2")
 320         or skip("could not load TTF with FT2", 1);
 321       my $text = pack("C*", 0xE2, 0x80, 0x90); # "\x{2010}" as utf-8
 322       my @names = $exfont->glyph_names(string=>$text,
 323                                        utf8=>1, reliable_only=>0);
 324       is($names[0], "hyphentwo", "check utf8 glyph name");
 325     }
 326   }
 327
 328   # check that error codes are translated correctly
 329   my $errfont = Imager::Font->new(file=>"t/t38ft2font.t", type=>"ft2");
 330   is($errfont, undef, "new font vs non font");
 331   cmp_ok(Imager->errstr, '=~', qr/unknown file format/, "check error message");
 332
 333   # Multiple Master tests
 334   # we check a non-MM font errors correctly
 335   print "# check that the methods act correctly for a non-MM font\n";
 336   ok(!$exfont->is_mm, "exfont not MM");
 337   ok((() = $exfont->mm_axes) == 0, "exfont has no MM axes");
 338   cmp_ok(Imager->errstr, '=~', qr/no multiple masters/,
 339          "and returns correct error when we ask");
 340   ok(!$exfont->set_mm_coords(coords=>[0, 0]), "fail setting axis on exfont");
 341   cmp_ok(Imager->errstr, '=~', qr/no multiple masters/,
 342          "and returns correct error when we ask");
 343
 344   # try a MM font now - test font only has A defined
 345   print "# Try a multiple master font\n";
 346   my $mmfont = Imager::Font->new(file=>"fontfiles/MMOne.pfb", type=>"ft2",
 347                                  color=>"white", aa=>1, size=>60);
 348   ok($mmfont, "loaded MM font");
 349   ok($mmfont->is_mm, "font is multiple master");
 350   my @axes = $mmfont->mm_axes;
 351   is(@axes, 2, "check we got both axes");
 352   is($axes[0][0], "Weight", "name of first axis");
 353   is($axes[0][1],  50, "min for first axis");
 354   is($axes[0][2], 999, "max for first axis");
 355   is($axes[1][0], "Slant", "name of second axis");
 356   is($axes[1][1],   0, "min for second axis");
 357   is($axes[1][2], 999, "max for second axis");
 358   my $mmim = Imager->new(xsize=>200, ysize=>200);
 359   $mmim->string(font=>$mmfont, x=>0, 'y'=>50, text=>"A");
 360   ok($mmfont->set_mm_coords(coords=>[ 700, 0 ]), "set to bold, unsloped");
 361   $mmim->string(font=>$mmfont, x=>0, 'y'=>100, text=>"A", color=>'blue');
 362   my @weights = qw(50 260 525 760 999);
 363   my @slants = qw(0 333 666 999);
 364   for my $windex (0 .. $#weights) {
 365     my $weight = $weights[$windex];
 366     for my $sindex (0 .. $#slants) {
 367       my $slant = $slants[$sindex];
 368       $mmfont->set_mm_coords(coords=>[ $weight, $slant ]);
 369       $mmim->string(font=>$mmfont, x=>30+32*$windex, 'y'=>50+45*$sindex,
 370                     text=>"A");
 371     }
 372   }
 373
 374   ok($mmim->write(file=>"testout/t38mm.ppm"), "save MM output");
 375
 376  SKIP:
 377   { print "# alignment tests\n";
 378     my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'ft2');
 379     ok($font, "loaded deffont OO")
 380       or skip("could not load font:".Imager->errstr, 4);
 381     my $im = Imager->new(xsize=>70, ysize=>150);
 382     my %common1 =
 383       (
 384        font=>$font,
 385        text=>'A',
 386        size=>40,
 387        color=>'white',
 388        x=>5,
 389        aa=>1,
 390       );
 391     my %common2 =
 392       (
 393        font=>$font,
 394        text=>'y',
 395        size=>40,
 396        color=>'white',
 397        x=>40,
 398        aa=>1,
 399       );
 400     $im->line(x1=>0, y1=>40, x2=>69, y2=>40, color=>'blue');
 401     $im->line(x1=>0, y1=>90, x2=>69, y2=>90, color=>'blue');
 402     $im->line(x1=>0, y1=>110, x2=>69, y2=>110, color=>'blue');
 403     ok($im->string(%common1, 'y'=>40), "A no alignment");
 404     ok($im->string(%common2, 'y'=>40), "y no alignment");
 405     ok($im->string(%common1, 'y'=>90, align=>1), "A align=1");
 406     ok($im->string(%common2, 'y'=>90, align=>1), "y align=1");
 407     ok($im->string(%common1, 'y'=>110, align=>0), "A align=0");
 408     ok($im->string(%common2, 'y'=>110, align=>0), "y align=0");
 409     ok($im->write(file=>'testout/t38align.ppm'), "save align image");
 410   }
 411 }
 412
 413 sub align_test {
 414   my ($h, $v, $x, $y, $f, $img) = @_;
 415
 416   my @pos = $f->align(halign=>$h, valign=>$v, 'x'=>$x, 'y'=>$y,
 417                       image=>$img, size=>15, color=>'FFFFFF',
 418                       string=>"x$h ${v}y", channel=>1, aa=>1);
 419   @pos = $f->align(halign=>$h, valign=>$v, 'x'=>$x, 'y'=>$y,
 420                       image=>$img, size=>15, color=>'FF99FF',
 421                       string=>"x$h ${v}y", aa=>1);
 422   if (ok(@pos == 4, "$h $v aligned output")) {
 423     # checking corners
 424     my $cx = int(($pos[0] + $pos[2]) / 2);
 425     my $cy = int(($pos[1] + $pos[3]) / 2);
 426
 427     print "# @pos cx $cx cy $cy\n";
 428     okmatchcolor($img, $cx, $pos[1]-1, @base_color, "outer top edge");
 429     okmatchcolor($img, $cx, $pos[3], @base_color, "outer bottom edge");
 430     okmatchcolor($img, $pos[0]-1, $cy, @base_color, "outer left edge");
 431     okmatchcolor($img, $pos[2], $cy, @base_color, "outer right edge");
 432
 433     okmismatchcolor($img, $cx, $pos[1], @base_color, "inner top edge");
 434     okmismatchcolor($img, $cx, $pos[3]-1, @base_color, "inner bottom edge");
 435     okmismatchcolor($img, $pos[0], $cy, @base_color, "inner left edge");
 436 #    okmismatchcolor($img, $pos[2]-1, $cy, @base_color, "inner right edge");
 437 # XXX: This gets triggered by a freetype2 bug I think
 438 #    $ rpm -qa | grep freetype
 439 #    freetype-2.1.3-6
 440 #
 441 # (addi: 4/1/2004).
 442
 443     cross($img, $x, $y, 'FF0000');
 444     cross($img, $cx, $pos[1]-1, '0000FF');
 445     cross($img, $cx, $pos[3], '0000FF');
 446     cross($img, $pos[0]-1, $cy, '0000FF');
 447     cross($img, $pos[2], $cy, '0000FF');
 448   }
 449   else {
 450     SKIP: { skip("couldn't draw text", 8) };
 451   }
 452
 453 }
 454
 455 sub okmatchcolor {
 456   my ($img, $x, $y, $r, $g, $b, $about) = @_;
 457
 458   my $c = $img->getpixel('x'=>$x, 'y'=>$y);
 459   my ($fr, $fg, $fb) = $c->rgba;
 460   ok($fr == $r && $fg == $g && $fb == $b,
 461       "want ($r,$g,$b) found ($fr,$fg,$fb)\@($x,$y) $about");
 462 }
 463
 464 sub okmismatchcolor {
 465   my ($img, $x, $y, $r, $g, $b, $about) = @_;
 466
 467   my $c = $img->getpixel('x'=>$x, 'y'=>$y);
 468   my ($fr, $fg, $fb) = $c->rgba;
 469   ok($fr != $r || $fg != $g || $fb != $b,
 470       "don't want ($r,$g,$b) found ($fr,$fg,$fb)\@($x,$y) $about");
 471 }
 472
 473 sub cross {
 474   my ($img, $x, $y, $color) = @_;
 475
 476   $img->setpixel('x'=>[$x, $x, $x, $x, $x, $x-2, $x-1, $x+1, $x+2],
 477                  'y'=>[$y-2, $y-1, $y, $y+1, $y+2, $y, $y, $y, $y],
 478                  color => $color);
 479
 480 }