t/t35ttfont.t

   1 #!perl -w
   2 use strict;
   3 use Test::More tests => 92;
   4
   5 $|=1;
   6
   7 BEGIN { use_ok(Imager => ':all') }
   8 use Imager::Test qw(diff_text_with_nul is_color3);
   9
  10 -d "testout" or mkdir "testout";
  11
  12 init_log("testout/t35ttfont.log",2);
  13
  14 SKIP:
  15 {
  16   skip("freetype 1.x unavailable or disabled", 91)
  17     unless $Imager::formats{"tt"};
  18   print "# has tt\n";
  19
  20   my $deffont = './fontfiles/dodge.ttf';
  21   my $fontname=$ENV{'TTFONTTEST'} || $deffont;
  22
  23   if (!ok(-f $fontname, "check test font file exists")) {
  24     print "# cannot find fontfile for truetype test $fontname\n";
  25     skip('Cannot load test font', 89);
  26   }
  27
  28   #i_init_fonts();
  29   #     i_tt_set_aa(1);
  30
  31   my $bgcolor = i_color_new(255,0,0,0);
  32   my $overlay = Imager::ImgRaw::new(320,140,3);
  33   i_box_filled($overlay, 0, 0, 319, 139, i_color_new(128, 128, 128));
  34
  35   my $ttraw = Imager::i_tt_new($fontname);
  36   ok($ttraw, "create font");
  37
  38   my @bbox = i_tt_bbox($ttraw,50.0,'XMCLH',6,0);
  39   is(@bbox, 8, "bounding box");
  40   print "#bbox: ($bbox[0], $bbox[1]) - ($bbox[2], $bbox[3])\n";
  41
  42   ok(i_tt_cp($ttraw,$overlay,5,50,1,50.0,'XM CLH',6,1,0), "cp output");
  43   ok(i_tt_cp($ttraw,$overlay,5,120,1,50.0,'XM CLH',6,0,0), "cp output (non AA)");
  44   i_line($overlay,0,50,100,50,$bgcolor,1);
  45
  46   open(FH,">testout/t35ttfont.ppm") || die "cannot open testout/t35ttfont.ppm\n";
  47   binmode(FH);
  48   my $IO = Imager::io_new_fd( fileno(FH) );
  49   ok(i_writeppm_wiol($overlay, $IO), "save t35ttfont.ppm");
  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
  57   ok(i_tt_text($ttraw,$backgr,100,120,$bgcolor,50.0,'te st',5,1,0),
  58       "normal output");
  59   ok(i_tt_text($ttraw,$backgr,100,200,$bgcolor,50.0,'te st',5,0,0),
  60       "normal output (non AA)");
  61
  62   my $ugly = Imager::i_tt_new("./fontfiles/ImUgly.ttf");
  63   ok($ugly, "create ugly font");
  64   # older versions were dropping the bottom of g and the right of a
  65   ok(i_tt_text($ugly, $backgr,100, 80, $bgcolor, 14, 'g%g', 3, 1, 0),
  66      "draw g%g");
  67   ok(i_tt_text($ugly, $backgr,150, 80, $bgcolor, 14, 'delta', 6, 1, 0),
  68       "draw delta");
  69   i_line($backgr,0,20,499,20,i_color_new(0,127,0,0),1);
  70   ok(i_tt_text($ttraw, $backgr, 20, 20, $bgcolor, 14, 'abcdefghijklmnopqrstuvwxyz{|}', 29, 1, 0), "alphabet");
  71   ok(i_tt_text($ttraw, $backgr, 20, 50, $bgcolor, 14, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 26, 1, 0), "ALPHABET");
  72
  73   # UTF8 tests
  74   # for perl < 5.6 we can hand-encode text
  75   # the following is "A\x{2010}A"
  76   #
  77   my $text = pack("C*", 0x41, 0xE2, 0x80, 0x90, 0x41);
  78   my $alttext = "A-A";
  79
  80   my @utf8box = i_tt_bbox($ttraw, 50.0, $text, length($text), 1);
  81   is(@utf8box, 8, "utf8 bbox element count");
  82   my @base = i_tt_bbox($ttraw, 50.0, $alttext, length($alttext), 0);
  83   is(@base, 8, "alt bbox element count");
  84   my $maxdiff = $fontname eq $deffont ? 0 : $base[2] / 3;
  85   print "# (@utf8box vs @base)\n";
  86   ok(abs($utf8box[2] - $base[2]) <= $maxdiff,
  87      "compare box sizes $utf8box[2] vs $base[2] (maxerror $maxdiff)");
  88
  89   # hand-encoded UTF8 drawing
  90   ok(i_tt_text($ttraw, $backgr, 200, 80, $bgcolor, 14, $text, length($text), 1, 1), "draw hand-encoded UTF8");
  91
  92   ok(i_tt_cp($ttraw, $backgr, 250, 80, 1, 14, $text, length($text), 1, 1),
  93       "cp hand-encoded UTF8");
  94
  95   # ok, try native perl UTF8 if available
  96  SKIP:
  97   {
  98     skip("perl too old to test native UTF8 support", 5) unless $] >= 5.006;
  99
 100     my $text;
 101     # we need to do this in eval to prevent compile time errors in older
 102     # versions
 103     eval q{$text = "A\x{2010}A"}; # A, HYPHEN, A in our test font
 104     #$text = "A".chr(0x2010)."A"; # this one works too
 105     ok(i_tt_text($ttraw, $backgr, 300, 80, $bgcolor, 14, $text, 0, 1, 0),
 106        "draw UTF8");
 107     ok(i_tt_cp($ttraw, $backgr, 350, 80, 0, 14, $text, 0, 1, 0),
 108        "cp UTF8");
 109     @utf8box = i_tt_bbox($ttraw, 50.0, $text, length($text), 0);
 110     is(@utf8box, 8, "native utf8 bbox element count");
 111     ok(abs($utf8box[2] - $base[2]) <= $maxdiff,
 112        "compare box sizes native $utf8box[2] vs $base[2] (maxerror $maxdiff)");
 113     eval q{$text = "A\x{0905}\x{0906}\x{0103}A"}; # Devanagari
 114     ok(i_tt_text($ugly, $backgr, 100, 160, $bgcolor, 36, $text, 0, 1, 0),
 115        "more complex output");
 116   }
 117
 118   open(FH,">testout/t35ttfont2.ppm") || die "cannot open testout/t35ttfont.ppm\n";
 119   binmode(FH);
 120   $IO = Imager::io_new_fd( fileno(FH) );
 121   ok(i_writeppm_wiol($backgr, $IO), "save t35ttfont2.ppm");
 122   close(FH);
 123
 124   my $exists_font = "fontfiles/ExistenceTest.ttf";
 125   my $hcfont = Imager::Font->new(file=>$exists_font, type=>'tt');
 126  SKIP:
 127   {
 128     ok($hcfont, "loading existence test font")
 129       or skip("could not load test font", 20);
 130
 131     # list interface
 132     my @exists = $hcfont->has_chars(string=>'!A');
 133     ok(@exists == 2, "check return count");
 134     ok($exists[0], "we have an exclamation mark");
 135     ok(!$exists[1], "we have no exclamation mark");
 136
 137     # scalar interface
 138     my $exists = $hcfont->has_chars(string=>'!A');
 139     ok(length($exists) == 2, "check return length");
 140     ok(ord(substr($exists, 0, 1)), "we have an exclamation mark");
 141     ok(!ord(substr($exists, 1, 1)), "we have no upper-case A");
 142
 143     my $face_name = Imager::i_tt_face_name($hcfont->{id});
 144     print "# face $face_name\n";
 145     is($face_name, 'ExistenceTest', "face name (function)");
 146     $face_name = $hcfont->face_name;
 147     is($face_name, 'ExistenceTest', "face name (OO)");
 148
 149     # FT 1.x cheats and gives names even if the font doesn't have them
 150     my @glyph_names = $hcfont->glyph_names(string=>"!J/");
 151     is($glyph_names[0], 'exclam', "check exclam name OO");
 152     ok(!defined($glyph_names[1]), "check for no J name OO");
 153     is($glyph_names[2], 'slash', "check slash name OO");
 154
 155     print "# ** name table of the test font **\n";
 156     Imager::i_tt_dump_names($hcfont->{id});
 157
 158     # the test font is known to have a shorter advance width for that char
 159     my @bbox = $hcfont->bounding_box(string=>"/", size=>100);
 160     is(@bbox, 8, "should be 8 entries");
 161     isnt($bbox[6], $bbox[2], "different advance width from pos width");
 162     print "# @bbox\n";
 163     my $bbox = $hcfont->bounding_box(string=>"/", size=>100);
 164     isnt($bbox->pos_width, $bbox->advance_width, "OO check");
 165
 166     cmp_ok($bbox->right_bearing, '<', 0, "check right bearing");
 167
 168     cmp_ok($bbox->display_width, '>', $bbox->advance_width,
 169            "check display width (roughly)");
 170
 171     # check with a char that fits inside the box
 172     $bbox = $hcfont->bounding_box(string=>"!", size=>100);
 173     print "# @$bbox\n";
 174     print "# pos width ", $bbox->pos_width, "\n";
 175     is($bbox->pos_width, $bbox->advance_width,
 176        "check backwards compatibility");
 177     cmp_ok($bbox->left_bearing, '>', 0, "left bearing positive");
 178     cmp_ok($bbox->right_bearing, '>', 0, "right bearing positive");
 179     cmp_ok($bbox->display_width, '<', $bbox->advance_width,
 180            "display smaller than advance");
 181   }
 182   undef $hcfont;
 183
 184   my $name_font = "fontfiles/NameTest.ttf";
 185   $hcfont = Imager::Font->new(file=>$name_font, type=>'tt');
 186  SKIP:
 187   {
 188     ok($hcfont, "loading name font")
 189       or skip("could not load name font $name_font", 3);
 190     # make sure a missing string parameter is handled correctly
 191     eval {
 192       $hcfont->glyph_names();
 193     };
 194     is($@, "", "correct error handling");
 195     cmp_ok(Imager->errstr, '=~', qr/no string parameter/, "error message");
 196
 197     my $text = pack("C*", 0xE2, 0x80, 0x90); # "\x{2010}" as utf-8
 198     my @names = $hcfont->glyph_names(string=>$text, utf8=>1);
 199     is($names[0], "hyphentwo", "check utf8 glyph name");
 200   }
 201
 202   undef $hcfont;
 203
 204  SKIP:
 205   { print "# alignment tests\n";
 206     my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt');
 207     ok($font, "loaded deffont OO")
 208       or skip("could not load font:".Imager->errstr, 4);
 209     my $im = Imager->new(xsize=>140, ysize=>150);
 210     my %common =
 211       (
 212        font=>$font,
 213        size=>40,
 214        aa=>1,
 215       );
 216     $im->line(x1=>0, y1=>40, x2=>139, y2=>40, color=>'blue');
 217     $im->line(x1=>0, y1=>90, x2=>139, y2=>90, color=>'blue');
 218     $im->line(x1=>0, y1=>110, x2=>139, y2=>110, color=>'blue');
 219     for my $args ([ x=>5,   text=>"A", color=>"white" ],
 220                   [ x=>40,  text=>"y", color=>"white" ],
 221                   [ x=>75,  text=>"A", channel=>1 ],
 222                   [ x=>110, text=>"y", channel=>1 ]) {
 223       ok($im->string(%common, @$args, 'y'=>40), "A no alignment");
 224       ok($im->string(%common, @$args, 'y'=>90, align=>1), "A align=1");
 225       ok($im->string(%common, @$args, 'y'=>110, align=>0), "A align=0");
 226     }
 227     ok($im->write(file=>'testout/t35align.ppm'), "save align image");
 228   }
 229
 230   { # Ticket #14804 Imager::Font->new() doesn't report error details
 231     # when using freetype 1
 232     # make sure we're using C locale for messages
 233     use POSIX qw(setlocale LC_ALL);
 234     setlocale(LC_ALL, "C");
 235
 236     my $font = Imager::Font->new(file=>'t/t35ttfont.t', type=>'tt');
 237     ok(!$font, "font creation should have failed for invalid file");
 238     cmp_ok(Imager->errstr, 'eq', 'Invalid file format.',
 239           "test error message");
 240
 241     setlocale(LC_ALL, "");
 242   }
 243
 244   { # check errstr set correctly
 245     my $font = Imager::Font->new(file=>$fontname, type=>'tt',
 246                                 size => undef);
 247     ok($font, "made size error test font");
 248     my $im = Imager->new(xsize=>100, ysize=>100);
 249     ok($im, "made size error test image");
 250     ok(!$im->string(font=>$font, x=>10, 'y'=>50, string=>"Hello"),
 251        "drawing should fail with no size");
 252     is($im->errstr, "No font size provided", "check error message");
 253
 254     # try no string
 255     ok(!$im->string(font=>$font, x=>10, 'y'=>50, size=>15),
 256        "drawing should fail with no string");
 257     is($im->errstr, "missing required parameter 'string'",
 258        "check error message");
 259   }
 260
 261   { # introduced in 0.46 - outputting just space crashes
 262     my $im = Imager->new(xsize=>100, ysize=>100);
 263     my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', size=>14);
 264     ok($im->string(font=>$font, x=> 5, 'y' => 50, string=>' '),
 265       "outputting just a space was crashing");
 266   }
 267
 268   { # string output cut off at NUL ('\0')
 269     # https://rt.cpan.org/Ticket/Display.html?id=21770 cont'd
 270     my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt');
 271     ok($font, "loaded imugly");
 272
 273     diff_text_with_nul("a\\0b vs a", "a\0b", "a",
 274                        font => $font, color => '#FFFFFF');
 275     diff_text_with_nul("a\\0b vs a", "a\0b", "a",
 276                        font => $font, channel => 1);
 277
 278     # UTF8 encoded \x{2010}
 279     my $dash = pack("C*", 0xE2, 0x80, 0x90);
 280     diff_text_with_nul("utf8 dash\\0dash vs dash", "$dash\0$dash", $dash,
 281                        font => $font, color => '#FFFFFF', utf8 => 1);
 282     diff_text_with_nul("utf8 dash\\0dash vs dash", "$dash\0$dash", $dash,
 283                        font => $font, channel => 1, utf8 => 1);
 284   }
 285
 286  SKIP:
 287   { # RT 11972
 288     # when rendering to a transparent image the coverage should be
 289     # expressed in terms of the alpha channel rather than the color
 290     my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt');
 291     ok($font, "loaded fontfiles/ImUgly.ttf")
 292       or skip("Could not load test font: ".Imager->errstr, 4);
 293     my $im = Imager->new(xsize => 40, ysize => 20, channels => 4);
 294     ok($im->string(string => "AB", size => 20, aa => 1, color => '#F00',
 295                    x => 0, y => 15, font => $font),
 296        "draw to transparent image");
 297     #$im->write(file => "foo.png");
 298     my $im_noalpha = $im->convert(preset => 'noalpha');
 299     my $im_pal = $im->to_paletted(make_colors => 'mediancut');
 300     my @colors = $im_pal->getcolors;
 301     is(@colors, 2, "should be only 2 colors");
 302     @colors = sort { ($a->rgba)[0] <=> ($b->rgba)[0] } @colors;
 303     is_color3($colors[0], 0, 0, 0, "check we got black");
 304     is_color3($colors[1], 255, 0, 0, "and red");
 305   }
 306
 307   ok(1, "end of code");
 308 }