t/t35ttfont.t

   1 #!perl -w
   2 use strict;
   3 use lib 't';
   4 use Test::More tests => 49;
   5
   6 BEGIN { use_ok(Imager => ':all') }
   7 require "t/testtools.pl";
   8
   9 init_log("testout/t35ttfont.log",2);
  10
  11 SKIP:
  12 {
  13   skip("freetype 1.x unavailable or disabled", 48)
  14     unless i_has_format("tt");
  15   print "# has tt\n";
  16
  17   my $deffont = './fontfiles/dodge.ttf';
  18   my $fontname=$ENV{'TTFONTTEST'} || $deffont;
  19
  20   if (!ok(-f $fontname, "check test font file exists")) {
  21     print "# cannot find fontfile for truetype test $fontname\n";
  22     skip('Cannot load test font', 47);
  23   }
  24
  25   i_init_fonts();
  26   #     i_tt_set_aa(1);
  27
  28   my $bgcolor = i_color_new(255,0,0,0);
  29   my $overlay = Imager::ImgRaw::new(200,70,3);
  30
  31   my $ttraw = Imager::i_tt_new($fontname);
  32   ok($ttraw, "create font");
  33
  34   my @bbox = i_tt_bbox($ttraw,50.0,'XMCLH',5,0);
  35   is(@bbox, 8, "bounding box");
  36   print "#bbox: ($bbox[0], $bbox[1]) - ($bbox[2], $bbox[3])\n";
  37
  38   ok(i_tt_cp($ttraw,$overlay,5,50,1,50.0,'XMCLH',5,1,0), "cp output");
  39   i_line($overlay,0,50,100,50,$bgcolor,1);
  40
  41   open(FH,">testout/t35ttfont.ppm") || die "cannot open testout/t35ttfont.ppm\n";
  42   binmode(FH);
  43   my $IO = Imager::io_new_fd( fileno(FH) );
  44   ok(i_writeppm_wiol($overlay, $IO), "save t35ttfont.ppm");
  45   close(FH);
  46
  47   $bgcolor=i_color_set($bgcolor,200,200,200,0);
  48   my $backgr=Imager::ImgRaw::new(500,300,3);
  49
  50   #     i_tt_set_aa(2);
  51
  52   ok(i_tt_text($ttraw,$backgr,100,120,$bgcolor,50.0,'test',4,1,0),
  53       "normal output");
  54
  55   my $ugly = Imager::i_tt_new("./fontfiles/ImUgly.ttf");
  56   ok($ugly, "create ugly font");
  57   # older versions were dropping the bottom of g and the right of a
  58   ok(i_tt_text($ugly, $backgr,100, 80, $bgcolor, 14, 'g%g', 3, 1, 0),
  59      "draw g%g");
  60   ok(i_tt_text($ugly, $backgr,150, 80, $bgcolor, 14, 'delta', 5, 1, 0),
  61       "draw delta");
  62   i_line($backgr,0,20,499,20,i_color_new(0,127,0,0),1);
  63   ok(i_tt_text($ttraw, $backgr, 20, 20, $bgcolor, 14, 'abcdefghijklmnopqrstuvwxyz{|}', 29, 1, 0), "alphabet");
  64   ok(i_tt_text($ttraw, $backgr, 20, 50, $bgcolor, 14, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 26, 1, 0), "ALPHABET");
  65
  66   # UTF8 tests
  67   # for perl < 5.6 we can hand-encode text
  68   # the following is "A\x{2010}A"
  69   #
  70   my $text = pack("C*", 0x41, 0xE2, 0x80, 0x90, 0x41);
  71   my $alttext = "A-A";
  72
  73   my @utf8box = i_tt_bbox($ttraw, 50.0, $text, length($text), 1);
  74   is(@utf8box, 8, "utf8 bbox element count");
  75   my @base = i_tt_bbox($ttraw, 50.0, $alttext, length($alttext), 0);
  76   is(@base, 8, "alt bbox element count");
  77   my $maxdiff = $fontname eq $deffont ? 0 : $base[2] / 3;
  78   print "# (@utf8box vs @base)\n";
  79   ok(abs($utf8box[2] - $base[2]) <= $maxdiff,
  80      "compare box sizes $utf8box[2] vs $base[2] (maxerror $maxdiff)");
  81
  82   # hand-encoded UTF8 drawing
  83   ok(i_tt_text($ttraw, $backgr, 200, 80, $bgcolor, 14, $text, length($text), 1, 1), "draw hand-encoded UTF8");
  84
  85   ok(i_tt_cp($ttraw, $backgr, 250, 80, 1, 14, $text, length($text), 1, 1),
  86       "cp hand-encoded UTF8");
  87
  88   # ok, try native perl UTF8 if available
  89  SKIP:
  90   {
  91     skip("perl too old to test native UTF8 support", 5) unless $] >= 5.006;
  92
  93     my $text;
  94     # we need to do this in eval to prevent compile time errors in older
  95     # versions
  96     eval q{$text = "A\x{2010}A"}; # A, HYPHEN, A in our test font
  97     #$text = "A".chr(0x2010)."A"; # this one works too
  98     ok(i_tt_text($ttraw, $backgr, 300, 80, $bgcolor, 14, $text, 0, 1, 0),
  99        "draw UTF8");
 100     ok(i_tt_cp($ttraw, $backgr, 350, 80, 0, 14, $text, 0, 1, 0),
 101        "cp UTF8");
 102     @utf8box = i_tt_bbox($ttraw, 50.0, $text, length($text), 0);
 103     is(@utf8box, 8, "native utf8 bbox element count");
 104     ok(abs($utf8box[2] - $base[2]) <= $maxdiff,
 105        "compare box sizes native $utf8box[2] vs $base[2] (maxerror $maxdiff)");
 106     eval q{$text = "A\x{0905}\x{0906}\x{0103}A"}; # Devanagari
 107     ok(i_tt_text($ugly, $backgr, 100, 160, $bgcolor, 36, $text, 0, 1, 0),
 108        "more complex output");
 109   }
 110
 111   open(FH,">testout/t35ttfont2.ppm") || die "cannot open testout/t35ttfont.ppm\n";
 112   binmode(FH);
 113   $IO = Imager::io_new_fd( fileno(FH) );
 114   ok(i_writeppm_wiol($backgr, $IO), "save t35ttfont2.ppm");
 115   close(FH);
 116
 117   my $exists_font = "fontfiles/ExistenceTest.ttf";
 118   my $hcfont = Imager::Font->new(file=>$exists_font, type=>'tt');
 119  SKIP:
 120   {
 121     ok($hcfont, "loading existence test font")
 122       or skip("could not load test font", 20);
 123
 124     # list interface
 125     my @exists = $hcfont->has_chars(string=>'!A');
 126     ok(@exists == 2, "check return count");
 127     ok($exists[0], "we have an exclamation mark");
 128     ok(!$exists[1], "we have no exclamation mark");
 129
 130     # scalar interface
 131     my $exists = $hcfont->has_chars(string=>'!A');
 132     ok(length($exists) == 2, "check return length");
 133     ok(ord(substr($exists, 0, 1)), "we have an exclamation mark");
 134     ok(!ord(substr($exists, 1, 1)), "we have no upper-case A");
 135
 136     my $face_name = Imager::i_tt_face_name($hcfont->{id});
 137     print "# face $face_name\n";
 138     ok($face_name eq 'ExistenceTest', "face name");
 139     $face_name = $hcfont->face_name;
 140     ok($face_name eq 'ExistenceTest', "face name");
 141
 142     # FT 1.x cheats and gives names even if the font doesn't have them
 143     my @glyph_names = $hcfont->glyph_names(string=>"!J/");
 144     ok($glyph_names[0] eq 'exclam', "check exclam name OO");
 145     ok(!defined($glyph_names[1]), "check for no J name OO");
 146     ok($glyph_names[2] eq 'slash', "check slash name OO");
 147
 148     print "# ** name table of the test font **\n";
 149     Imager::i_tt_dump_names($hcfont->{id});
 150
 151     # the test font is known to have a shorter advance width for that char
 152     my @bbox = $hcfont->bounding_box(string=>"/", size=>100);
 153     is(@bbox, 8, "should be 8 entries");
 154     isnt($bbox[6], $bbox[2], "different advance width from pos width");
 155     print "# @bbox\n";
 156     my $bbox = $hcfont->bounding_box(string=>"/", size=>100);
 157     isnt($bbox->pos_width, $bbox->advance_width, "OO check");
 158
 159     cmp_ok($bbox->right_bearing, '<', 0, "check right bearing");
 160
 161     cmp_ok($bbox->display_width, '>', $bbox->advance_width,
 162            "check display width (roughly)");
 163
 164     # check with a char that fits inside the box
 165     $bbox = $hcfont->bounding_box(string=>"!", size=>100);
 166     print "# @$bbox\n";
 167     print "# pos width ", $bbox->pos_width, "\n";
 168     is($bbox->pos_width, $bbox->advance_width,
 169        "check backwards compatibility");
 170     cmp_ok($bbox->left_bearing, '>', 0, "left bearing positive");
 171     cmp_ok($bbox->right_bearing, '>', 0, "right bearing positive");
 172     cmp_ok($bbox->display_width, '<', $bbox->advance_width,
 173            "display smaller than advance");
 174   }
 175   undef $hcfont;
 176
 177   my $name_font = "fontfiles/NameTest.ttf";
 178   $hcfont = Imager::Font->new(file=>$name_font);
 179  SKIP:
 180   {
 181     ok($hcfont, "loading name font")
 182       or skip("could not load name font $name_font", 3);
 183     # make sure a missing string parameter is handled correctly
 184     eval {
 185       $hcfont->glyph_names();
 186     };
 187     is($@, "", "correct error handling");
 188     cmp_ok(Imager->errstr, '=~', qr/no string parameter/, "error message");
 189
 190     my $text = pack("C*", 0xE2, 0x80, 0x90); # "\x{2010}" as utf-8
 191     my @names = $hcfont->glyph_names(string=>$text, utf8=>1);
 192     is($names[0], "hyphentwo", "check utf8 glyph name");
 193   }
 194
 195   undef $hcfont;
 196
 197   ok(1, "end of code");
 198 }