t/t38ft2font.t

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