t/t38ft2font.t

   1 #!perl -w
   2 # Before `make install' is performed this script should be runnable with
   3 # `make test'. After `make install' it should work as `perl test.pl'
   4
   5 ######################### We start with some black magic to print on failure.
   6
   7 # Change 1..1 below to 1..last_test_to_print .
   8 # (It may become useful if the test is moved to ./t subdirectory.)
   9
  10 BEGIN { $| = 1; print "1..10\n"; }
  11 END {print "not ok 1\n" unless $loaded;}
  12 use Imager qw(:all);
  13 $loaded = 1;
  14 print "ok 1\n";
  15
  16 init_log("testout/t38ft2font.log",1);
  17
  18 sub skip {
  19   for (2..10) {
  20     print "ok $_ # skip no Freetype2 library\n";
  21   }
  22   malloc_state();
  23   exit(0);
  24 }
  25
  26 if (!(i_has_format("ft2")) ) { skip(); }
  27 print "# has ft2\n";
  28
  29 $fontname=$ENV{'TTFONTTEST'}||'./fontfiles/dodge.ttf';
  30
  31 if (! -f $fontname) {
  32   print "# cannot find fontfile for truetype test $fontname\n";
  33   skip();
  34 }
  35
  36 i_init_fonts();
  37 #     i_tt_set_aa(1);
  38
  39 $bgcolor=i_color_new(255,0,0,0);
  40 $overlay=Imager::ImgRaw::new(200,70,3);
  41
  42 $ttraw=Imager::Font::FreeType2::i_ft2_new($fontname, 0);
  43
  44 $ttraw or print Imager::_error_as_msg(),"\n";
  45 #use Data::Dumper;
  46 #warn Dumper($ttraw);
  47
  48 @bbox=Imager::Font::FreeType2::i_ft2_bbox($ttraw, 50.0, 0, 'XMCLH');
  49 print "#bbox: ($bbox[0], $bbox[1]) - ($bbox[2], $bbox[3])\n";
  50
  51 Imager::Font::FreeType2::i_ft2_cp($ttraw,$overlay,5,50,1,50.0,50, 'XMCLH',1,1, 0, 0);
  52 i_draw($overlay,0,50,100,50,$bgcolor);
  53
  54 open(FH,">testout/t38ft2font.ppm") || die "cannot open testout/t38ft2font.ppm\n";
  55 binmode(FH);
  56 my $IO = Imager::io_new_fd(fileno(FH));
  57 i_writeppm_wiol($overlay, $IO);
  58 close(FH);
  59
  60 print "ok 2\n";
  61
  62 dotest:
  63
  64 $bgcolor=i_color_set($bgcolor,200,200,200,0);
  65 $backgr=Imager::ImgRaw::new(500,300,3);
  66
  67 #     i_tt_set_aa(2);
  68 Imager::Font::FreeType2::i_ft2_text($ttraw,$backgr,100,150,NC(255, 64, 64),200.0,50, 'MAW',1,1,0, 0);
  69 Imager::Font::FreeType2::i_ft2_settransform($ttraw, [0.9659, 0.2588, 0, -0.2588, 0.9659, 0 ]);
  70 Imager::Font::FreeType2::i_ft2_text($ttraw,$backgr,100,150,NC(0, 128, 0),200.0,50, 'MAW',0,1, 0, 0);
  71 i_draw($backgr, 0,150, 499, 150, NC(0, 0, 255));
  72
  73 open(FH,">testout/t38ft2font2.ppm") || die "cannot open testout/t38ft2font.ppm\n";
  74 binmode(FH);
  75 $IO = Imager::io_new_fd(fileno(FH));
  76 i_writeppm_wiol($backgr,$IO);
  77 close(FH);
  78
  79 print "ok 3\n";
  80
  81 #$fontname = 'fontfiles/arial.ttf';
  82 my $oof = Imager::Font->new(file=>$fontname, type=>'ft2', 'index'=>0)
  83   or print "not ";
  84 print "ok 4\n";
  85
  86 my $im = Imager->new(xsize=>400, ysize=>250);
  87
  88 $im->string(font=>$oof,
  89             text=>"Via OO",
  90             'x'=>20,
  91             'y'=>20,
  92             size=>60,
  93             color=>NC(255, 128, 255),
  94             aa => 1,
  95             align=>0) or print "not ";
  96 print "ok 5\n";
  97 $oof->transform(matrix=>[1, 0.1, 0, 0, 1, 0])
  98   or print "not ";
  99 print "ok 6\n";
 100 $im->string(font=>$oof,
 101             text=>"Shear",
 102             'x'=>20,
 103             'y'=>40,
 104             size=>60,
 105             sizew=>50,
 106             channel=>1,
 107             aa=>1,
 108             align=>1) or print "not ";
 109 print "ok 7\n";
 110 use Imager::Matrix2d ':handy';
 111 $oof->transform(matrix=>m2d_rotate(degrees=>-30));
 112 #$oof->transform(matrix=>m2d_identity());
 113 $im->string(font=>$oof,
 114             text=>"SPIN",
 115             'x'=>20,
 116             'y'=>50,
 117             size=>50,
 118             sizew=>40,
 119             color=>NC(255,255,0),
 120             aa => 1,
 121             align=>0, vlayout=>0)
 122 and
 123 $im->string(font=>$oof,
 124             text=>"SPIN",
 125             'x'=>20,
 126             'y'=>50,
 127             size=>50,
 128             sizew=>40,
 129             channel=>2,
 130             aa => 1,
 131             align=>0, vlayout=>0) or print "not ";
 132 print "ok 8\n";
 133
 134 $oof->transform(matrix=>m2d_identity());
 135 $oof->hinting(hinting=>1);
 136
 137 # UTF8 testing
 138 # the test font (dodge.ttf) only supports one character above 0xFF that
 139 # I can see, 0x2010 HYPHEN (which renders the same as 0x002D HYPHEN MINUS)
 140 # an attempt at utf8 support
 141 # first attempt to use native perl UTF8
 142 if ($] >= 5.006) {
 143   my $text;
 144   # we need to do this in eval to prevent compile time errors in older
 145   # versions
 146   eval q{$text = "A\x{2010}A"}; # A, HYPHEN, A in our test font
 147   #$text = "A".chr(0x2010)."A"; # this one works too
 148   if ($im->string(font=>$oof,
 149               text=>$text,
 150               'x'=>20,
 151               'y'=>200,
 152               size=>50,
 153               color=>NC(0,255,0),
 154               aa=>1)) {
 155     print "ok 9\n";
 156   }
 157   else {
 158     print "not ok 9 # ",$im->errstr,"\n";
 159   }
 160 }
 161 else {
 162   print "ok 9 # skip no native UTF8 support in this version of perl\n";
 163 }
 164
 165 # an attempt using emulation of UTF8
 166 my $text = pack("C*", 0x41, 0xE2, 0x80, 0x90, 0x41);
 167 #my $text = "A\xE2\x80\x90\x41\x{2010}";
 168 #substr($text, -1, 0) = '';
 169 if ($im->string(font=>$oof,
 170                 text=>$text,
 171                 'x'=>20,
 172                 'y'=>230,
 173                 size=>50,
 174                 color=>NC(255,128,0),
 175                 aa=>1,
 176                 utf8=>1)) {
 177   print "ok 10\n";
 178 }
 179 else {
 180   print "not ok 10 # ",$im->errstr,"\n";
 181 }
 182
 183 # just a bit of fun
 184 # well it was - it demostrates what happens when you combine
 185 # transformations and font hinting
 186 for my $steps (0..39) {
 187   $oof->transform(matrix=>m2d_rotate(degrees=>-$steps+5));
 188   # demonstrates why we disable hinting on a doing a transform
 189   # if the following line is enabled then the 0 degrees output sticks
 190   # out a bit
 191   # $oof->hinting(hinting=>1);
 192   $im->string(font=>$oof,
 193               text=>"SPIN",
 194               'x'=>160,
 195               'y'=>70,
 196               size=>65,
 197               color=>NC(255, $steps * 5, 200-$steps * 5),
 198               aa => 1,
 199               align=>0, ) or print "not ";
 200 }
 201
 202 $im->write(file=>'testout/t38_oo.ppm')
 203   or print "# could not save OO output: ",$im->errstr,"\n";