W32/t/t10win32.t

   1 #!perl -w
   2 use strict;
   3 use Test::More tests => 59;
   4 use Imager qw(:all);
   5 use Imager::Test qw(diff_text_with_nul isnt_image);
   6 ++$|;
   7
   8 ok(-d "testout" or mkdir("testout"), "testout directory");
   9
  10 ok($Imager::formats{w32}, "\$formats{w32} populated");
  11
  12 init_log("testout/t10w32font.log",1);
  13
  14 SKIP:
  15 {
  16   print "# has w32\n";
  17
  18   my $fontname=$ENV{'TTFONTTEST'} || 'Times New Roman Bold';
  19
  20   # i_init_fonts(); # unnecessary for Win32 font support
  21
  22   my $bgcolor=i_color_new(255,0,0,0);
  23   my $overlay=Imager::ImgRaw::new(200,70,3);
  24
  25   my @bbox=Imager::Font::W32::i_wf_bbox($fontname, 50.0,'XMCLH');
  26   print "#bbox: ($bbox[0], $bbox[1]) - ($bbox[2], $bbox[3])\n";
  27
  28   ok(Imager::Font::W32::i_wf_cp($fontname,$overlay,5,50,1,50.0,'XMCLH',1,1),
  29      "i_wf_cp smoke test");
  30   i_line($overlay,0,50,100,50,$bgcolor, 1);
  31
  32   if (open(FH,">testout/t10font.ppm")) {
  33     binmode(FH);
  34     my $io = Imager::io_new_fd(fileno(FH));
  35     i_writeppm_wiol($overlay,$io);
  36     close(FH);
  37   }
  38   else {
  39     diag "cannot open testout/t10font.ppm: $!";
  40   }
  41
  42   $bgcolor=i_color_set($bgcolor,200,200,200,255);
  43   my $backgr=Imager::ImgRaw::new(500,300,3);
  44
  45   ok(Imager::Font::W32::i_wf_text($fontname,$backgr,100,100,$bgcolor,100,'MAW.',1, 1),
  46      "i_wf_text smoke test");
  47   i_line($backgr,0, 100, 499, 100, NC(0, 0, 255), 1);
  48
  49   if (open(FH,">testout/t10font2.ppm")) {
  50     binmode(FH);
  51     my $io = Imager::io_new_fd(fileno(FH));
  52     i_writeppm_wiol($backgr,$io);
  53     close(FH);
  54   }
  55   else {
  56     diag "cannot open testout/t10font2.ppm: $!";
  57   }
  58
  59   my $img = Imager->new(xsize=>200, ysize=>200);
  60   my $font = Imager::Font->new(face=>$fontname, size=>20);
  61   ok($img->string('x'=>30, 'y'=>30, string=>"Imager", color=>NC(255, 0, 0),
  62                font=>$font),
  63      "string with win32 smoke test")
  64     or diag "simple string output: ",$img->errstr;
  65   $img->write(file=>'testout/t10_oo.ppm')
  66     or diag "Cannot save t10_oo.ppm: ", $img->errstr;
  67   my @bbox2 = $font->bounding_box(string=>'Imager');
  68   is(@bbox2, 8, "got 8 values from bounding_box");
  69
  70   # this only applies while the Win32 driver returns 6 values
  71   # at this point we don't return the advance width from the low level
  72   # bounding box function, so the Imager::Font::BBox advance method should
  73   # return end_offset, check it does
  74   my $bbox = $font->bounding_box(string=>"some text");
  75   ok($bbox, "got the bounding box object");
  76   is($bbox->advance_width, $bbox->end_offset,
  77      "check advance_width fallback correct");
  78
  79  SKIP:
  80   {
  81     $^O eq 'cygwin' and skip("Too hard to get correct directory for test font on cygwin", 13);
  82     my $extra_font = "fontfiles/ExistenceTest.ttf";
  83     unless (ok(Imager::Font::W32::i_wf_addfont($extra_font), "add test font")) {
  84       diag "adding font resource: ",Imager::_error_as_msg();
  85       skip("Could not add font resource", 12);
  86     }
  87
  88     my $namefont = Imager::Font->new(face=>"ExistenceTest");
  89     ok($namefont, "create font based on added font");
  90
  91     # the test font is known to have a shorter advance width for that char
  92     @bbox = $namefont->bounding_box(string=>"/", size=>100);
  93     print "# / box: @bbox\n";
  94     is(@bbox, 8, "should be 8 entries");
  95     isnt($bbox[6], $bbox[2], "different advance width");
  96     $bbox = $namefont->bounding_box(string=>"/", size=>100);
  97     isnt($bbox->pos_width, $bbox->advance_width, "OO check");
  98
  99     cmp_ok($bbox->right_bearing, '<', 0, "check right bearing");
 100
 101     cmp_ok($bbox->display_width, '>', $bbox->advance_width,
 102            "check display width (roughly)");
 103
 104     my $im = Imager->new(xsize=>200, ysize=>200);
 105     $im->box(filled => 1, color => '#202020');
 106     $im->box(box => [ 20 + $bbox->neg_width, 100-$bbox->ascent,
 107                       20+$bbox->advance_width-$bbox->right_bearing, 100-$bbox->descent ],
 108              color => '#101010', filled => 1);
 109     $im->line(color=>'blue', x1=>20, y1=>0, x2=>20, y2=>199);
 110     my $right = 20 + $bbox->advance_width;
 111     $im->line(color=>'blue', x1=>$right, y1=>0, x2=>$right, y2=>199);
 112     $im->line(color=>'blue', x1=>0, y1 => 100, x2=>199, y2 => 100);
 113     ok($im->string(font=>$namefont, text=>"/", x=>20, y=>100, color=>'white', size=>100),
 114        "draw / from ExistenceText")
 115         or diag "draw / from ExistenceTest:", $im->errstr;
 116     $im->setpixel(x => 20+$bbox->neg_width, y => 100-$bbox->ascent, color => 'red');
 117     $im->setpixel(x => 20+$bbox->advance_width - $bbox->right_bearing, y => 100-$bbox->descent, color => 'red');
 118     $im->write(file=>'testout/t10_slash.ppm');
 119
 120     # check with a char that fits inside the box
 121     $bbox = $namefont->bounding_box(string=>"!", size=>100);
 122     print "# pos width ", $bbox->pos_width, "\n";
 123     print "# ! box: @$bbox\n";
 124     is($bbox->pos_width, $bbox->advance_width,
 125      "check backwards compatibility");
 126     cmp_ok($bbox->left_bearing, '>', 0, "left bearing positive");
 127     cmp_ok($bbox->right_bearing, '>', 0, "right bearing positive");
 128     cmp_ok($bbox->display_width, '<', $bbox->advance_width,
 129            "display smaller than advance");
 130
 131     $im = Imager->new(xsize=>200, ysize=>200);
 132     $im->box(filled => 1, color => '#202020');
 133     $im->box(box => [ 20 + $bbox->neg_width, 100-$bbox->ascent,
 134                       20+$bbox->advance_width-$bbox->right_bearing, 100-$bbox->descent ],
 135              color => '#101010', filled => 1);
 136     $im->line(color=>'blue', x1=>20, y1=>0, x2=>20, y2=>199);
 137     $right = 20 + $bbox->advance_width;
 138     $im->line(color=>'blue', x1=>$right, y1=>0, x2=>$right, y2=>199);
 139     $im->line(color=>'blue', x1=>0, y1 => 100, x2=>199, y2 => 100);
 140     ok($im->string(font=>$namefont, text=>"!", x=>20, y=>100, color=>'white', size=>100),
 141        "draw / from ExistenceText")
 142         or diag "draw / from ExistenceTest: ", $im->errstr;
 143     $im->setpixel(x => 20+$bbox->neg_width, y => 100-$bbox->ascent, color => 'red');
 144     $im->setpixel(x => 20+$bbox->advance_width - $bbox->right_bearing, y => 100-$bbox->descent, color => 'red');
 145     $im->write(file=>'testout/t10_bang.ppm');
 146
 147     Imager::Font::W32::i_wf_delfont("fontfiles/ExistenceTest.ttf");
 148   }
 149
 150  SKIP:
 151   { print "# alignment tests\n";
 152     my $font = Imager::Font->new(face=>"Arial");
 153     ok($font, "loaded Arial OO")
 154       or skip("could not load font:".Imager->errstr, 4);
 155     my $im = Imager->new(xsize=>140, ysize=>150);
 156     my %common =
 157       (
 158        font=>$font,
 159        size=>40,
 160        aa=>1,
 161       );
 162     $im->line(x1=>0, y1=>40, x2=>139, y2=>40, color=>'blue');
 163     $im->line(x1=>0, y1=>90, x2=>139, y2=>90, color=>'blue');
 164     $im->line(x1=>0, y1=>110, x2=>139, y2=>110, color=>'blue');
 165     for my $args ([ x=>5,   text=>"A", color=>"white" ],
 166                   [ x=>40,  text=>"y", color=>"white" ],
 167                   [ x=>75,  text=>"A", channel=>1 ],
 168                   [ x=>110, text=>"y", channel=>1 ]) {
 169       print "# ", join(",", @$args), "\n";
 170       ok($im->string(%common, @$args, 'y'=>40), "A no alignment");
 171       ok($im->string(%common, @$args, 'y'=>90, align=>1), "A align=1");
 172       ok($im->string(%common, @$args, 'y'=>110, align=>0), "A align=0");
 173     }
 174     ok($im->write(file=>'testout/t10align.ppm'), "save align image");
 175   }
 176   { print "# utf 8 support\n";
 177     my $font = Imager::Font->new(face => "Arial");
 178     ok($font, "created font");
 179     my $im = Imager->new(xsize => 100, ysize => 100);
 180     ok($im->string(string => "\xE2\x98\xBA", size => 80, aa => 1, utf8 => 1,
 181                    color => "white", font => $font, x => 5, y => 80),
 182        "draw in utf8 (hand encoded)")
 183         or diag "draw utf8 hand-encoded ", $im->errstr;
 184     ok($im->write(file=>'testout/t10utf8.ppm'), "save utf8 image")
 185       or diag "save t10utf8.ppm: ", $im->errstr;
 186
 187     # native perl utf8
 188     # Win32 only supported on 5.6+
 189     # since this gets compiled even on older perls we need to be careful
 190     # creating the string
 191     my $text;
 192     eval q{$text = "\x{263A}"}; # A, HYPHEN, A in our test font
 193     my $im2 = Imager->new(xsize => 100, ysize => 100);
 194     ok($im2->string(string => $text, size => 80, aa => 1,
 195                     color => 'white', font => $font, x => 5, y => 80),
 196        "draw in utf8 (perl utf8)")
 197         or diag "draw in utf8: ", $im->errstr;
 198     ok($im2->write(file=>'testout/t10utf8b.ppm'), "save utf8 image");
 199     is(Imager::i_img_diff($im->{IMG}, $im2->{IMG}), 0,
 200        "check result is the same");
 201
 202     # bounding box
 203     cmp_ok($font->bounding_box(string=>$text, size => 80)->advance_width, '<', 100,
 204            "check we only get width of single char rather than 3");
 205   }
 206
 207   { # string output cut off at NUL ('\0')
 208     # https://rt.cpan.org/Ticket/Display.html?id=21770 cont'd
 209     my $font = Imager::Font->new(face=>'Arial', type=>'w32');
 210     ok($font, "loaded Arial");
 211
 212     diff_text_with_nul("a\\0b vs a", "a\0b - color", "a",
 213                        font => $font, color => '#FFFFFF');
 214     diff_text_with_nul("a\\0b vs a", "a\0b - channel", "a",
 215                        font => $font, channel => 1);
 216
 217     # UTF8 encoded \x{2010}
 218     my $dash = pack("C*", 0xE2, 0x80, 0x90);
 219     diff_text_with_nul("utf8 dash\0dash vs dash - color", "$dash\0$dash", $dash,
 220                        font => $font, color => '#FFFFFF', utf8 => 1);
 221     diff_text_with_nul("utf8 dash\0dash vs dash - channel", "$dash\0$dash", $dash,
 222                        font => $font, channel => 1, utf8 => 1);
 223   }
 224
 225   { # RT 71469
 226     my $font1 = Imager::Font->new(face => $fontname, type => "w32");
 227     my $font2 = Imager::Font::W32->new(face => $fontname );
 228
 229     for my $font ($font1, $font2) {
 230       print "# ", join(",", $font->{color}->rgba), "\n";
 231
 232       my $im = Imager->new(xsize => 20, ysize => 20, channels => 4);
 233
 234       ok($im->string(text => "T", font => $font, y => 15),
 235          "draw with default color")
 236         or diag "draw with default color: ", $im->errstr;
 237       my $work = Imager->new(xsize => 20, ysize => 20);
 238       my $cmp = $work->copy;
 239       $work->rubthrough(src => $im);
 240       isnt_image($work, $cmp, "make sure something was drawn");
 241     }
 242   }
 243 }