view release on metacpan or  search on metacpan

t/350-font/020-tt.t  view on Meta::CPAN

#!perl -w
use strict;
use Test::More;

$|=1;

BEGIN { use_ok(Imager => ':all') }
use Imager::Test qw(diff_text_with_nul is_color3 is_image);

-d "testout" or mkdir "testout";

init_log("testout/t35ttfont.log",2);

SKIP:
{
  skip("freetype 1.x unavailable or disabled", 96) 
    unless $Imager::formats{"tt"};
  print "# has tt\n";
  
  my $deffont = './fontfiles/dodge.ttf';
  my $fontname=$ENV{'TTFONTTEST'} || $deffont;

  if (!ok(-f $fontname, "check test font file exists")) {
    print "# cannot find fontfile for truetype test $fontname\n";
    skip('Cannot load test font', 89);
  }

  #i_init_fonts();
  #     i_tt_set_aa(1);
  
  my $bgcolor = i_color_new(255,0,0,0);
  my $overlay = Imager::ImgRaw::new(320,140,3);
  i_box_filled($overlay, 0, 0, 319, 139, i_color_new(128, 128, 128));
  
  my $ttraw = Imager::i_tt_new($fontname);
  ok($ttraw, "create font");

  my @bbox = i_tt_bbox($ttraw,50.0,'XMCLH',0);
  is(@bbox, 8, "bounding box");
  print "#bbox: ($bbox[0], $bbox[1]) - ($bbox[2], $bbox[3])\n";

  ok(i_tt_cp($ttraw,$overlay,5,50,1,50.0,'XM CLH',6,1,0), "cp output");
  ok(i_tt_cp($ttraw,$overlay,5,120,1,50.0,'XM CLH',6,0,0), "cp output (non AA)");
  i_line($overlay,0,50,100,50,$bgcolor,1);

  open(FH,">testout/t35ttfont.ppm") || die "cannot open testout/t35ttfont.ppm\n";
  binmode(FH);
  my $IO = Imager::io_new_fd( fileno(FH) );
  ok(i_writeppm_wiol($overlay, $IO), "save t35ttfont.ppm");
  close(FH);

  $bgcolor=i_color_set($bgcolor,200,200,200,0);
  my $backgr=Imager::ImgRaw::new(500,300,3);
  
  #     i_tt_set_aa(2);
  
  ok(i_tt_text($ttraw,$backgr,100,120,$bgcolor,50.0,'te st',5,1,0),
      "normal output");
  ok(i_tt_text($ttraw,$backgr,100,200,$bgcolor,50.0,'te st',5,0,0),
      "normal output (non AA)");

  my $ugly = Imager::i_tt_new("./fontfiles/ImUgly.ttf");
  ok($ugly, "create ugly font");
  # older versions were dropping the bottom of g and the right of a
  ok(i_tt_text($ugly, $backgr,100, 80, $bgcolor, 14, 'g%g', 3, 1, 0), 
     "draw g%g");
  ok(i_tt_text($ugly, $backgr,150, 80, $bgcolor, 14, 'delta', 6, 1, 0),
      "draw delta");
  i_line($backgr,0,20,499,20,i_color_new(0,127,0,0),1);
  ok(i_tt_text($ttraw, $backgr, 20, 20, $bgcolor, 14, 'abcdefghijklmnopqrstuvwxyz{|}', 29, 1, 0), "alphabet");
  ok(i_tt_text($ttraw, $backgr, 20, 50, $bgcolor, 14, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 26, 1, 0), "ALPHABET");
  
  # UTF8 tests
  # for perl < 5.6 we can hand-encode text
  # the following is "A\x{2010}A"
  # 
  my $text = pack("C*", 0x41, 0xE2, 0x80, 0x90, 0x41);
  my $alttext = "A-A";
  
  my @utf8box = i_tt_bbox($ttraw, 50.0, $text, 1);
  is(@utf8box, 8, "utf8 bbox element count");
  my @base = i_tt_bbox($ttraw, 50.0, $alttext, 0);
  is(@base, 8, "alt bbox element count");
  my $maxdiff = $fontname eq $deffont ? 0 : $base[2] / 3;
  print "# (@utf8box vs @base)\n";
  ok(abs($utf8box[2] - $base[2]) <= $maxdiff, 
     "compare box sizes $utf8box[2] vs $base[2] (maxerror $maxdiff)");
  
  # hand-encoded UTF8 drawing
  ok(i_tt_text($ttraw, $backgr, 200, 80, $bgcolor, 14, $text, length($text), 1, 1), "draw hand-encoded UTF8");

  ok(i_tt_cp($ttraw, $backgr, 250, 80, 1, 14, $text, length($text), 1, 1), 
      "cp hand-encoded UTF8");

  # ok, try native perl UTF8 if available
 SKIP:
  {
    skip("perl too old to test native UTF8 support", 5) unless $] >= 5.006;

    my $text;
    # we need to do this in eval to prevent compile time errors in older
    # versions
    eval q{$text = "A\x{2010}A"}; # A, HYPHEN, A in our test font
    #$text = "A".chr(0x2010)."A"; # this one works too
    ok(i_tt_text($ttraw, $backgr, 300, 80, $bgcolor, 14, $text, 0, 1, 0),
       "draw UTF8");
    ok(i_tt_cp($ttraw, $backgr, 350, 80, 0, 14, $text, 0, 1, 0),
       "cp UTF8");
    @utf8box = i_tt_bbox($ttraw, 50.0, $text, 0);