FT2/t/t10ft2.t

   1 #!perl -w
   2 use strict;
   3 use Test::More tests => 204;
   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 is_image);
   9
  10 -d "testout" or mkdir "testout";
  11
  12 my @test_output;
  13
  14 push @test_output, "t38ft2font.log";
  15
  16 Imager->open_log(log => "testout/t38ft2font.log");
  17
  18 my $deffont = "fontfiles/dodge.ttf";
  19
  20 my @base_color = (64, 255, 64);
  21
  22 SKIP:
  23 {
  24   ok($Imager::formats{ft2}, "ft2 should be in %formats");
  25
  26   my $fontname=$ENV{'TTFONTTEST'} || $deffont;
  27
  28   -f $fontname or skip("cannot find fontfile $fontname", 189);
  29
  30   print STDERR "FreeType2 runtime ", Imager::Font::FT2::i_ft2_version(1),
  31     " compile-time ", Imager::Font::FT2::i_ft2_version(0), "\n";
  32
  33   my $bgcolor=i_color_new(255,0,0,0);
  34   my $overlay=Imager::ImgRaw::new(200,70,3);
  35
  36   my $ttraw=Imager::Font::FT2::i_ft2_new($fontname, 0);
  37
  38   $ttraw or print Imager::_error_as_msg(),"\n";
  39   ok($ttraw, "loaded raw font");
  40
  41   my @bbox=Imager::Font::FT2::i_ft2_bbox($ttraw, 50.0, 0, 'XMCLH', 0);
  42   print "#bbox @bbox\n";
  43
  44   is(@bbox, 8, "i_ft2_bbox() returns 8 values");
  45
  46   ok(Imager::Font::FT2::i_ft2_cp($ttraw,$overlay,5,50,1,50.0,50, 'XMCLH',1,1, 0, 0), "drawn to channel");
  47   i_line($overlay,0,50,100,50,$bgcolor,1);
  48
  49   push @test_output, "t38ft2font.ppm";
  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);
  55
  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);
  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");
  63   i_line($backgr, 0,150, 499, 150, NC(0, 0, 255),1);
  64
  65   push @test_output, "t38ft2font2.ppm";
  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);
  71
  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     }
 146
 147   }
 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";
 162   }
 163
 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, );
 181   }
 182
 183   push @test_output, "t38_oo.ppm";
 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'");
 191   is($oof->has_chars(string=>"H\x01"), "\x01\x00",
 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
 198   is(@bbox, 8, "list bbox returned 8 items");
 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
 226   push @test_output, "t38aligned.ppm";
 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   {
 234     ok($exfont, "loaded existence font")
 235       or diag(Imager->errstr);
 236     $exfont
 237       or skip("couldn't load test font", 11);
 238
 239     # the test font is known to have a shorter advance width for that char
 240     my @bbox = $exfont->bounding_box(string=>"/", size=>100);
 241     is(@bbox, 8, "should be 8 entries");
 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
 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
 252     $bbox = $exfont->bounding_box(string=>"!", size=>100);
 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
 261     # name tests
 262     # make sure the number of tests on each branch match
 263     if (Imager::Font::FT2::i_ft2_can_face_name()) {
 264       my $facename = Imager::Font::FT2::i_ft2_face_name($exfont->{id});
 265       print "# face name '$facename'\n";
 266       is($facename, 'ExistenceTest', "test face name");
 267       $facename = $exfont->face_name;
 268       is($facename, 'ExistenceTest', "test face name OO");
 269     }
 270     else {
 271       # make sure we get the error we expect
 272       my $facename = Imager::Font::FT2::i_ft2_face_name($exfont->{id});
 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     }
 278   }
 279
 280   SKIP:
 281   {
 282     Imager::Font::FT2->can_glyph_names
 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',
 288                                type=>'ft2');
 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 =
 294         Imager::Font::FT2::i_ft2_glyph_name($exfont->{id}, "!J/");
 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");
 335     }
 336   }
 337
 338   # check that error codes are translated correctly
 339   my $errfont = Imager::Font->new(file=>"t/t10ft2.t", type=>"ft2");
 340   is($errfont, undef, "new font vs non font");
 341   cmp_ok(Imager->errstr, '=~', qr/unknown file format/, "check error message");
 342
 343   # Multiple Master tests
 344   # we check a non-MM font errors correctly
 345   print "# check that the methods act correctly for a non-MM font\n";
 346   ok(!$exfont->is_mm, "exfont not MM");
 347   ok((() = $exfont->mm_axes) == 0, "exfont has no MM axes");
 348   cmp_ok(Imager->errstr, '=~', qr/no multiple masters/,
 349          "and returns correct error when we ask");
 350   ok(!$exfont->set_mm_coords(coords=>[0, 0]), "fail setting axis on exfont");
 351   cmp_ok(Imager->errstr, '=~', qr/no multiple masters/,
 352          "and returns correct error when we ask");
 353
 354   # try a MM font now - test font only has A defined
 355   print "# Try a multiple master font\n";
 356   my $mmfont = Imager::Font->new(file=>"fontfiles/MMOne.pfb", type=>"ft2",
 357                                  color=>"white", aa=>1, size=>60);
 358   ok($mmfont, "loaded MM font")
 359     or print "# ", Imager->errstr, "\n";
 360   ok($mmfont->is_mm, "font is multiple master");
 361   my @axes = $mmfont->mm_axes;
 362   is(@axes, 2, "check we got both axes");
 363   is($axes[0][0], "Weight", "name of first axis");
 364   is($axes[0][1],  50, "min for first axis");
 365   is($axes[0][2], 999, "max for first axis");
 366   is($axes[1][0], "Slant", "name of second axis");
 367   is($axes[1][1],   0, "min for second axis");
 368   is($axes[1][2], 999, "max for second axis");
 369   my $mmim = Imager->new(xsize=>200, ysize=>200);
 370   $mmim->string(font=>$mmfont, x=>0, 'y'=>50, text=>"A");
 371   ok($mmfont->set_mm_coords(coords=>[ 700, 0 ]), "set to bold, unsloped");
 372   $mmim->string(font=>$mmfont, x=>0, 'y'=>100, text=>"A", color=>'blue');
 373   my @weights = qw(50 260 525 760 999);
 374   my @slants = qw(0 333 666 999);
 375   for my $windex (0 .. $#weights) {
 376     my $weight = $weights[$windex];
 377     for my $sindex (0 .. $#slants) {
 378       my $slant = $slants[$sindex];
 379       $mmfont->set_mm_coords(coords=>[ $weight, $slant ]);
 380       $mmim->string(font=>$mmfont, x=>30+32*$windex, 'y'=>50+45*$sindex,
 381                     text=>"A");
 382     }
 383   }
 384
 385   push @test_output, "t38mm.ppm";
 386   ok($mmim->write(file=>"testout/t38mm.ppm"), "save MM output");
 387
 388  SKIP:
 389   { print "# alignment tests\n";
 390     my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'ft2');
 391     ok($font, "loaded deffont OO")
 392       or skip("could not load font:".Imager->errstr, 4);
 393     my $im = Imager->new(xsize=>140, ysize=>150);
 394     my %common =
 395       (
 396        font=>$font,
 397        size=>40,
 398        aa=>1,
 399       );
 400     $im->line(x1=>0, y1=>40, x2=>139, y2=>40, color=>'blue');
 401     $im->line(x1=>0, y1=>90, x2=>139, y2=>90, color=>'blue');
 402     $im->line(x1=>0, y1=>110, x2=>139, y2=>110, color=>'blue');
 403     for my $args ([ x=>5,   text=>"A", color=>"white" ],
 404                   [ x=>40,  text=>"y", color=>"white" ],
 405                   [ x=>75,  text=>"A", channel=>1 ],
 406                   [ x=>110, text=>"y", channel=>1 ]) {
 407       ok($im->string(%common, @$args, 'y'=>40), "A no alignment");
 408       ok($im->string(%common, @$args, 'y'=>90, align=>1), "A align=1");
 409       ok($im->string(%common, @$args, 'y'=>110, align=>0), "A align=0");
 410     }
 411     push @test_output, "t38align.ppm";
 412     ok($im->write(file=>'testout/t38align.ppm'), "save align image");
 413   }
 414
 415
 416   { # outputting a space in non-AA could either crash
 417     # or fail (ft 2.2+)
 418     my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'ft2');
 419     my $im = Imager->new(xsize => 100, ysize => 100);
 420     ok($im->string(x => 10, y => 10, string => "test space", aa => 0,
 421                    color => '#FFF', size => 8, font => $font),
 422        "draw space non-antialiased (color)");
 423     ok($im->string(x => 10, y => 50, string => "test space", aa => 0,
 424                    channel => 0, size => 8, font => $font),
 425        "draw space non-antialiased (channel)");
 426   }
 427
 428   { # cannot output "0"
 429     # https://rt.cpan.org/Ticket/Display.html?id=21770
 430     my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'ft2');
 431     ok($font, "loaded imugly");
 432     my $imbase = Imager->new(xsize => 100, ysize => 100);
 433     my $im = $imbase->copy;
 434     ok($im->string(x => 10, y => 50, string => "0", aa => 0,
 435                    color => '#FFF', size => 20, font => $font),
 436        "draw '0'");
 437     ok(Imager::i_img_diff($im->{IMG}, $imbase->{IMG}),
 438        "make sure we actually drew it");
 439     $im = $imbase->copy;
 440     ok($im->string(x => 10, y => 50, string => 0.0, aa => 0,
 441                    color => '#FFF', size => 20, font => $font),
 442        "draw 0.0");
 443     ok(Imager::i_img_diff($im->{IMG}, $imbase->{IMG}),
 444        "make sure we actually drew it");
 445   }
 446   { # string output cut off at NUL ('\0')
 447     # https://rt.cpan.org/Ticket/Display.html?id=21770 cont'd
 448     my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'ft2');
 449     ok($font, "loaded imugly");
 450
 451     diff_text_with_nul("a\\0b vs a", "a\0b", "a",
 452                        font => $font, color => '#FFFFFF');
 453     diff_text_with_nul("a\\0b vs a", "a\0b", "a",
 454                        font => $font, channel => 1);
 455
 456     # UTF8 encoded \x{2010}
 457     my $dash = pack("C*", 0xE2, 0x80, 0x90);
 458     diff_text_with_nul("utf8 dash\0dash vs dash", "$dash\0$dash", $dash,
 459                        font => $font, color => '#FFFFFF', utf8 => 1);
 460     diff_text_with_nul("utf8 dash\0dash vs dash", "$dash\0$dash", $dash,
 461                        font => $font, channel => 1, utf8 => 1);
 462   }
 463
 464   { # RT 11972
 465     # when rendering to a transparent image the coverage should be
 466     # expressed in terms of the alpha channel rather than the color
 467     my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'ft2');
 468     my $im = Imager->new(xsize => 40, ysize => 20, channels => 4);
 469     ok($im->string(string => "AB", size => 20, aa => 1, color => '#F00',
 470                    x => 0, y => 15, font => $font),
 471        "draw to transparent image");
 472     my $im_noalpha = $im->convert(preset => 'noalpha');
 473     my $im_pal = $im->to_paletted(make_colors => 'mediancut');
 474     my @colors = $im_pal->getcolors;
 475     is(@colors, 2, "should be only 2 colors");
 476     @colors = sort { ($a->rgba)[0] <=> ($b->rgba)[0] } @colors;
 477     is_color3($colors[0], 0, 0, 0, "check we got black");
 478     is_color3($colors[1], 255, 0, 0, "and red");
 479   }
 480
 481   { # RT 27546
 482     my $im = Imager->new(xsize => 100, ysize => 100, channels => 4);
 483     $im->box(filled => 1, color => '#ff0000FF');
 484     my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'ft2');
 485     ok($im->string(x => 0, 'y' => 40, text => 'test',
 486                    size => 11, sizew => 11, font => $font, aa => 1),
 487        'draw on translucent image')
 488   }
 489
 490   { # RT 60199
 491     # not ft2 specific, but Imager
 492     my $im = Imager->new(xsize => 100, ysize => 100);
 493     my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'ft2');
 494     my $imcopy = $im->copy;
 495     ok($im, "make test image");
 496     ok($font, "make test font");
 497     ok($im->align_string(valign => "center", halign => "center",
 498                          x => 50, y => 50, string => "0", color => "#FFF",
 499                          font => $font),
 500        "draw 0 aligned");
 501     ok(Imager::i_img_diff($im->{IMG}, $imcopy->{IMG}),
 502        "make sure we drew the '0'");
 503   }
 504
 505  SKIP:
 506   { # RT 60509
 507     # checks that a c:foo or c:\foo path is handled correctly on win32
 508     my $type = "ft2";
 509     $^O eq "MSWin32" || $^O eq "cygwin"
 510       or skip("only for win32", 2);
 511     my $dir = getcwd
 512       or skip("Cannot get cwd", 2);
 513     if ($^O eq "cygwin") {
 514       $dir = Cygwin::posix_to_win_path($dir);
 515     }
 516     my $abs_path = abs_path($deffont);
 517     my $font = Imager::Font->new(file => $abs_path, type => $type);
 518     ok($font, "found font by absolute path")
 519       or print "# path $abs_path\n";
 520     undef $font;
 521
 522     $^O eq "cygwin"
 523       and skip("cygwin doesn't support drive relative DOSsish paths", 1);
 524     my ($drive) = $dir =~ /^([a-z]:)/i
 525       or skip("cwd has no drive letter", 2);
 526     my $drive_path = $drive . $deffont;
 527     $font = Imager::Font->new(file => $drive_path, type => $type);
 528     ok($font, "found font by drive relative path")
 529       or print "# path $drive_path\n";
 530   }
 531   { # RT 71469
 532     my $font1 = Imager::Font->new(file => $deffont, type => "ft2", index => 0);
 533     my $font2 = Imager::Font::FT2->new(file => $deffont, index => 0);
 534
 535     for my $font ($font1, $font2) {
 536       print "# ", join(",", $font->{color}->rgba), "\n";
 537
 538       my $im = Imager->new(xsize => 20, ysize => 20, channels => 4);
 539
 540       ok($im->string(text => "T", font => $font, y => 15),
 541          "draw with default color")
 542         or print "# ", $im->errstr, "\n";
 543       my $work = Imager->new(xsize => 20, ysize => 20);
 544       my $cmp = $work->copy;
 545       $work->rubthrough(src => $im);
 546       isnt_image($work, $cmp, "make sure something was drawn");
 547     }
 548   }
 549
 550   { # RT 73359
 551     # non-AA font drawing isn't normal mode
 552
 553     Imager->log("testing no-aa normal output\n");
 554
 555     my $font = Imager::Font->new(file => "fontfiles/ImUgly.ttf", type => "ft2");
 556
 557     ok($font, "make a work font");
 558
 559     my %common =
 560       (
 561        x => 10,
 562        font => $font,
 563        size => 25,
 564        aa => 0,
 565        align => 0,
 566       );
 567
 568     # build our comparison image
 569     my $cmp = Imager->new(xsize => 120, ysize => 100);
 570     my $layer = Imager->new(xsize => 120, ysize => 100, channels => 4);
 571     ok($layer->string(%common, y => 10, text => "full", color => "#8080FF"),
 572        "draw non-aa text at full coverage to layer image");
 573     ok($layer->string(%common, y => 40, text => "half", color => "#FF808080"),
 574        "draw non-aa text at half coverage to layer image");
 575     ok($layer->string(%common, y => 70, text => "quarter", color => "#80FF8040"),
 576        "draw non-aa text at zero coverage to layer image");
 577     ok($cmp->rubthrough(src => $layer), "rub layer onto comparison image");
 578
 579     my $im = Imager->new(xsize => 120, ysize => 100);
 580     ok($im->string(%common, y => 10, text => "full", color => "#8080FF"),
 581        "draw non-aa text at full coverage");
 582     ok($im->string(%common, y => 40, text => "half", color => "#FF808080"),
 583        "draw non-aa text at half coverage");
 584     ok($im->string(%common, y => 70, text => "quarter", color => "#80FF8040"),
 585        "draw non-aa text at zero coverage");
 586     is_image($im, $cmp, "check the result");
 587
 588     push @test_output, "noaanorm.ppm", "noaacmp.ppm";
 589     ok($cmp->write(file => "testout/noaacmp.ppm"), "save cmp image")
 590       or diag "Saving cmp image: ", $cmp->errstr;
 591     ok($im->write(file => "testout/noaanorm.ppm"), "save test image")
 592       or diag "Saving result image: ", $im->errstr;
 593   }
 594 }
 595
 596 Imager->close_log();
 597
 598 END {
 599   unless ($ENV{IMAGER_KEEP_FILES}) {
 600     unlink map "testout/$_", @test_output;
 601   }
 602 }
 603
 604 sub align_test {
 605   my ($h, $v, $x, $y, $f, $img) = @_;
 606
 607   my @pos = $f->align(halign=>$h, valign=>$v, 'x'=>$x, 'y'=>$y,
 608                       image=>$img, size=>15, color=>'FFFFFF',
 609                       string=>"x$h ${v}y", channel=>1, aa=>1);
 610   @pos = $img->align_string(halign=>$h, valign=>$v, 'x'=>$x, 'y'=>$y,
 611                       font=>$f, size=>15, color=>'FF99FF',
 612                       string=>"x$h ${v}y", aa=>1);
 613   if (ok(@pos == 4, "$h $v aligned output")) {
 614     # checking corners
 615     my $cx = int(($pos[0] + $pos[2]) / 2);
 616     my $cy = int(($pos[1] + $pos[3]) / 2);
 617
 618     print "# @pos cx $cx cy $cy\n";
 619     okmatchcolor($img, $cx, $pos[1]-1, @base_color, "outer top edge");
 620     okmatchcolor($img, $cx, $pos[3], @base_color, "outer bottom edge");
 621     okmatchcolor($img, $pos[0]-1, $cy, @base_color, "outer left edge");
 622     okmatchcolor($img, $pos[2], $cy, @base_color, "outer right edge");
 623
 624     okmismatchcolor($img, $cx, $pos[1], @base_color, "inner top edge");
 625     okmismatchcolor($img, $cx, $pos[3]-1, @base_color, "inner bottom edge");
 626     okmismatchcolor($img, $pos[0], $cy, @base_color, "inner left edge");
 627 #    okmismatchcolor($img, $pos[2]-1, $cy, @base_color, "inner right edge");
 628 # XXX: This gets triggered by a freetype2 bug I think
 629 #    $ rpm -qa | grep freetype
 630 #    freetype-2.1.3-6
 631 #
 632 # (addi: 4/1/2004).
 633
 634     cross($img, $x, $y, 'FF0000');
 635     cross($img, $cx, $pos[1]-1, '0000FF');
 636     cross($img, $cx, $pos[3], '0000FF');
 637     cross($img, $pos[0]-1, $cy, '0000FF');
 638     cross($img, $pos[2], $cy, '0000FF');
 639   }
 640   else {
 641     SKIP: { skip("couldn't draw text", 7) };
 642   }
 643 }
 644
 645 sub okmatchcolor {
 646   my ($img, $x, $y, $r, $g, $b, $about) = @_;
 647
 648   my $c = $img->getpixel('x'=>$x, 'y'=>$y);
 649   my ($fr, $fg, $fb) = $c->rgba;
 650   ok($fr == $r && $fg == $g && $fb == $b,
 651       "want ($r,$g,$b) found ($fr,$fg,$fb)\@($x,$y) $about");
 652 }
 653
 654 sub okmismatchcolor {
 655   my ($img, $x, $y, $r, $g, $b, $about) = @_;
 656
 657   my $c = $img->getpixel('x'=>$x, 'y'=>$y);
 658   my ($fr, $fg, $fb) = $c->rgba;
 659   ok($fr != $r || $fg != $g || $fb != $b,
 660       "don't want ($r,$g,$b) found ($fr,$fg,$fb)\@($x,$y) $about");
 661 }
 662
 663 sub cross {
 664   my ($img, $x, $y, $color) = @_;
 665
 666   $img->setpixel('x'=>[$x, $x, $x, $x, $x, $x-2, $x-1, $x+1, $x+2],
 667                  'y'=>[$y-2, $y-1, $y, $y+1, $y+2, $y, $y, $y, $y],
 668                  color => $color);
 669
 670 }
 671
 672