t/350-font/030-ttoo.t

   1 #!/usr/bin/perl -w
   2 use strict;
   3
   4 #use lib qw(blib/lib blib/arch);
   5
   6 # Before `make install' is performed this script should be runnable with
   7 # `make test'. After `make install' it should work as `perl test.pl'
   8
   9 ######################### We start with some black magic to print on failure.
  10
  11 # Change 1..1 below to 1..last_test_to_print .
  12 # (It may become useful if the test is moved to ./t subdirectory.)
  13 use Test::More tests => 25;
  14
  15 use Imager;
  16
  17 use Imager::Test qw(isnt_image is_image);
  18
  19 -d "testout" or mkdir "testout";
  20
  21 Imager->open_log(log => "testout/t36oofont.log");
  22
  23 my @test_output;
  24
  25 my $fontname_tt=$ENV{'TTFONTTEST'}||'./fontfiles/dodge.ttf';
  26
  27 my $green=Imager::Color->new(92,205,92,128);
  28 die $Imager::ERRSTR unless $green;
  29 my $red=Imager::Color->new(205, 92, 92, 255);
  30 die $Imager::ERRSTR unless $red;
  31
  32 SKIP:
  33 {
  34   $Imager::formats{"tt"} && -f $fontname_tt
  35     or skip("FT1.x missing or disabled", 25);
  36
  37   my $img=Imager->new(xsize=>300, ysize=>100) or die "$Imager::ERRSTR\n";
  38
  39   my $font=Imager::Font->new(file=>$fontname_tt,size=>25)
  40     or die $img->{ERRSTR};
  41
  42   ok(1, "create TT font object");
  43
  44   ok($img->string(font=>$font, text=>"XMCLH", 'x'=>100, 'y'=>100),
  45       "draw text");
  46
  47   $img->line(x1=>0, x2=>300, y1=>50, y2=>50, color=>$green);
  48
  49   my $text="LLySja";
  50   my @bbox=$font->bounding_box(string=>$text, 'x'=>0, 'y'=>50);
  51
  52   is(@bbox, 8, "bbox list size");
  53
  54   $img->box(box=>\@bbox, color=>$green);
  55
  56   $text = pack("C*", 0x41, 0xE2, 0x80, 0x90, 0x41);
  57   ok($img->string(font=>$font, text=>$text, 'x'=>100, 'y'=>50, utf8=>1),
  58       "draw hand-encoded UTF8 text");
  59
  60  SKIP:
  61   {
  62     $] >= 5.006
  63       or skip("perl too old for native utf8", 1);
  64     eval q{$text = "A\x{2010}A"};
  65     ok($img->string(font=>$font, text=>$text, 'x'=>200, 'y'=>50),
  66        "draw native UTF8 text");
  67   }
  68
  69   ok($img->write(file=>"testout/t36oofont2.ppm", type=>'pnm'),
  70       "write t36oofont2.ppm")
  71     or print "# ", $img->errstr,"\n";
  72
  73   ok($font->utf8, "make sure utf8 method returns true");
  74
  75   my $has_chars = $font->has_chars(string=>"\x01A");
  76   is($has_chars, "\x00\x01", "has_chars scalar");
  77   my @has_chars = $font->has_chars(string=>"\x01A");
  78   ok(!$has_chars[0], "has_chars list 0");
  79   ok($has_chars[1], "has_chars list 1");
  80
  81   { # RT 71469
  82     my $font1 = Imager::Font->new(file => $fontname_tt, type => "tt");
  83     my $font2 = Imager::Font::Truetype->new(file => $fontname_tt);
  84
  85     for my $font ($font1, $font2) {
  86       print "# ", join(",", $font->{color}->rgba), "\n";
  87
  88       my $im = Imager->new(xsize => 20, ysize => 20, channels => 4);
  89
  90       ok($im->string(text => "T", font => $font, y => 15),
  91          "draw with default color")
  92         or print "# ", $im->errstr, "\n";
  93       my $work = Imager->new(xsize => 20, ysize => 20);
  94       my $cmp = $work->copy;
  95       $work->rubthrough(src => $im);
  96       isnt_image($work, $cmp, "make sure something was drawn");
  97     }
  98   }
  99
 100   { # RT 73359
 101     # non-AA font drawing isn't normal mode
 102
 103     Imager->log("testing no-aa normal output\n");
 104
 105     my $font = Imager::Font->new(file => "fontfiles/ImUgly.ttf", type => "tt");
 106
 107     ok($font, "make a work font");
 108
 109     my %common =
 110       (
 111        x => 10,
 112        font => $font,
 113        size => 25,
 114        aa => 0,
 115        align => 0,
 116       );
 117
 118     # build our comparison image
 119     my $cmp = Imager->new(xsize => 120, ysize => 100);
 120     my $layer = Imager->new(xsize => 120, ysize => 100, channels => 4);
 121     ok($layer->string(%common, y => 10, text => "full", color => "#8080FF"),
 122        "draw non-aa text at full coverage to layer image");
 123     ok($layer->string(%common, y => 40, text => "half", color => "#FF808080"),
 124        "draw non-aa text at half coverage to layer image");
 125     ok($layer->string(%common, y => 70, text => "quarter", color => "#80FF8040"),
 126        "draw non-aa text at zero coverage to layer image");
 127     ok($cmp->rubthrough(src => $layer), "rub layer onto comparison image");
 128
 129     my $im = Imager->new(xsize => 120, ysize => 100);
 130     ok($im->string(%common, y => 10, text => "full", color => "#8080FF"),
 131        "draw non-aa text at full coverage");
 132     ok($im->string(%common, y => 40, text => "half", color => "#FF808080"),
 133        "draw non-aa text at half coverage");
 134     ok($im->string(%common, y => 70, text => "quarter", color => "#80FF8040"),
 135        "draw non-aa text at zero coverage");
 136     is_image($im, $cmp, "check the result");
 137
 138     push @test_output, "ttaanorm.ppm", "ttaacmp.ppm";
 139     ok($cmp->write(file => "testout/ttaacmp.ppm"), "save cmp image")
 140       or diag "Saving cmp image: ", $cmp->errstr;
 141     ok($im->write(file => "testout/ttaanorm.ppm"), "save test image")
 142       or diag "Saving result image: ", $im->errstr;
 143   }
 144 }
 145
 146 Imager->close_log;
 147
 148 END {
 149   unless ($ENV{IMAGER_KEEP_FILES}) {
 150     unlink map "testout/$_", @test_output;
 151   }
 152 }