t/t37w32font.t

   1 #!perl -w
   2 use strict;
   3 use lib 't';
   4 use Test::More tests => 32;
   5 BEGIN { use_ok(Imager => ':all') }
   6 ++$|;
   7
   8 init_log("testout/t37w32font.log",1);
   9
  10 SKIP:
  11 {
  12   i_has_format('w32') or skip("no MS Windows", 31);
  13   print "# has w32\n";
  14
  15   my $fontname=$ENV{'TTFONTTEST'} || 'Times New Roman Bold';
  16
  17   # i_init_fonts(); # unnecessary for Win32 font support
  18
  19   my $bgcolor=i_color_new(255,0,0,0);
  20   my $overlay=Imager::ImgRaw::new(200,70,3);
  21
  22   my @bbox=Imager::i_wf_bbox($fontname, 50.0,'XMCLH');
  23   print "#bbox: ($bbox[0], $bbox[1]) - ($bbox[2], $bbox[3])\n";
  24
  25   ok(Imager::i_wf_cp($fontname,$overlay,5,50,1,50.0,'XMCLH',1,1),
  26      "i_wf_cp smoke test");
  27   i_line($overlay,0,50,100,50,$bgcolor, 1);
  28
  29   open(FH,">testout/t37w32font.ppm") || die "cannot open testout/t37w32font.ppm\n";
  30   binmode(FH);
  31   my $io = Imager::io_new_fd(fileno(FH));
  32   i_writeppm_wiol($overlay,$io);
  33   close(FH);
  34
  35   $bgcolor=i_color_set($bgcolor,200,200,200,0);
  36   my $backgr=Imager::ImgRaw::new(500,300,3);
  37
  38   ok(Imager::i_wf_text($fontname,$backgr,100,100,$bgcolor,100,'MAW.',1, 1),
  39      "i_wf_text smoke test");
  40   i_line($backgr,0, 100, 499, 100, NC(0, 0, 255), 1);
  41
  42   open(FH,">testout/t37w32font2.ppm") || die "cannot open testout/t37w32font2.ppm\n";
  43   binmode(FH);
  44   $io = Imager::io_new_fd(fileno(FH));
  45   i_writeppm_wiol($backgr,$io);
  46   close(FH);
  47
  48   my $img = Imager->new(xsize=>200, ysize=>200);
  49   my $font = Imager::Font->new(face=>$fontname, size=>20);
  50   ok($img->string('x'=>30, 'y'=>30, string=>"Imager", color=>NC(255, 0, 0),
  51                font=>$font),
  52      "string with win32 smoke test")
  53     or print "# ",$img->errstr,"\n";
  54   $img->write(file=>'testout/t37_oo.ppm') or print "not ";
  55   my @bbox2 = $font->bounding_box(string=>'Imager');
  56   is(@bbox2, 8, "got 8 values from bounding_box");
  57
  58   # this only applies while the Win32 driver returns 6 values
  59   # at this point we don't return the advance width from the low level
  60   # bounding box function, so the Imager::Font::BBox advance method should
  61   # return end_offset, check it does
  62   my $bbox = $font->bounding_box(string=>"some text");
  63   ok($bbox, "got the bounding box object");
  64   is($bbox->advance_width, $bbox->end_offset,
  65      "check advance_width fallback correct");
  66
  67  SKIP:
  68   {
  69     $^O eq 'cygwin' and skip("Too hard to get correct directory for test font on cygwin", 11);
  70     ok(Imager::i_wf_addfont("fontfiles/ExistenceTest.ttf"), "add test font")
  71       or print "# ",Imager::_error_as_msg(),"\n";
  72
  73     my $namefont = Imager::Font->new(face=>"ExistenceTest");
  74     ok($namefont, "create font based on added font");
  75
  76     # the test font is known to have a shorter advance width for that char
  77     @bbox = $namefont->bounding_box(string=>"/", size=>100);
  78     print "# / box: @bbox\n";
  79     is(@bbox, 8, "should be 8 entries");
  80     isnt($bbox[6], $bbox[2], "different advance width");
  81     $bbox = $namefont->bounding_box(string=>"/", size=>100);
  82     ok($bbox->pos_width != $bbox->advance_width, "OO check");
  83
  84     cmp_ok($bbox->right_bearing, '<', 0, "check right bearing");
  85
  86     cmp_ok($bbox->display_width, '>', $bbox->advance_width,
  87            "check display width (roughly)");
  88
  89     my $im = Imager->new(xsize=>200, ysize=>200);
  90     $im->string(font=>$namefont, text=>"/", x=>20, y=>100, color=>'white', size=>100);
  91     $im->line(color=>'blue', x1=>20, y1=>0, x2=>20, y2=>199);
  92     my $right = 20 + $bbox->advance_width;
  93     $im->line(color=>'blue', x1=>$right, y1=>0, x2=>$right, y2=>199);
  94     $im->write(file=>'testout/t37w32_slash.ppm');
  95
  96     # check with a char that fits inside the box
  97     $bbox = $namefont->bounding_box(string=>"!", size=>100);
  98     print "# pos width ", $bbox->pos_width, "\n";
  99     print "# ! box: @$bbox\n";
 100     is($bbox->pos_width, $bbox->advance_width,
 101      "check backwards compatibility");
 102     cmp_ok($bbox->left_bearing, '>', 0, "left bearing positive");
 103     cmp_ok($bbox->right_bearing, '>', 0, "right bearing positive");
 104     cmp_ok($bbox->display_width, '<', $bbox->advance_width,
 105            "display smaller than advance");
 106   }
 107
 108  SKIP:
 109   { print "# alignment tests\n";
 110     my $font = Imager::Font->new(face=>"Arial");
 111     ok($font, "loaded Arial OO")
 112       or skip("could not load font:".Imager->errstr, 4);
 113     my $im = Imager->new(xsize=>140, ysize=>150);
 114     my %common =
 115       (
 116        font=>$font,
 117        size=>40,
 118        aa=>1,
 119       );
 120     $im->line(x1=>0, y1=>40, x2=>139, y2=>40, color=>'blue');
 121     $im->line(x1=>0, y1=>90, x2=>139, y2=>90, color=>'blue');
 122     $im->line(x1=>0, y1=>110, x2=>139, y2=>110, color=>'blue');
 123     for my $args ([ x=>5,   text=>"A", color=>"white" ],
 124                   [ x=>40,  text=>"y", color=>"white" ],
 125                   [ x=>75,  text=>"A", channel=>1 ],
 126                   [ x=>110, text=>"y", channel=>1 ]) {
 127       ok($im->string(%common, @$args, 'y'=>40), "A no alignment");
 128       ok($im->string(%common, @$args, 'y'=>90, align=>1), "A align=1");
 129       ok($im->string(%common, @$args, 'y'=>110, align=>0), "A align=0");
 130     }
 131     ok($im->write(file=>'testout/t37align.ppm'), "save align image");
 132   }
 133
 134 }