FT2/t/t10ft2.t

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