t/t30t1font.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 use strict;
  10 use Test::More;
  11 use Imager ':all';
  12 use Imager::Test qw(diff_text_with_nul is_color3);
  13 use Cwd qw(getcwd abs_path);
  14
  15 #$Imager::DEBUG=1;
  16
  17 i_has_format("t1")
  18   or plan skip_all => "t1lib unavailble or disabled";
  19
  20 plan tests => 95;
  21
  22 -d "testout" or mkdir "testout";
  23
  24 init_log("testout/t30t1font.log",1);
  25
  26 my $deffont = 'fontfiles/dcr10.pfb';
  27
  28 my $fontname_pfb=$ENV{'T1FONTTESTPFB'}||$deffont;
  29 my $fontname_afm=$ENV{'T1FONTTESTAFM'}||'./fontfiles/dcr10.afm';
  30
  31 -f $fontname_pfb
  32   or skip_all("cannot find fontfile for type 1 test $fontname_pfb");
  33 -f $fontname_afm
  34   or skip_all("cannot find fontfile for type 1 test $fontname_afm");
  35
  36 SKIP:
  37 {
  38   print "# has t1\n";
  39
  40   #i_t1_set_aa(1);
  41
  42   unlink "t1lib.log"; # lose it if it exists
  43   init(t1log=>0);
  44   ok(!-e("t1lib.log"), "disable t1log");
  45   init(t1log=>1);
  46   ok(-e("t1lib.log"), "enable t1log");
  47   init(t1log=>0);
  48   unlink "t1lib.log";
  49
  50   my $fnum=Imager::i_t1_new($fontname_pfb,$fontname_afm); # this will load the pfb font
  51   unless (ok($fnum >= 0, "load font $fontname_pfb")) {
  52     skip("without the font I can't do a thing", 90);
  53   }
  54
  55   my $bgcolor=Imager::Color->new(255,0,0,0);
  56   my $overlay=Imager::ImgRaw::new(200,70,3);
  57
  58   ok(i_t1_cp($overlay,5,50,1,$fnum,50.0,'XMCLH',5,1), "i_t1_cp");
  59
  60   i_line($overlay,0,50,100,50,$bgcolor,1);
  61
  62   my @bbox=i_t1_bbox(0,50.0,'XMCLH',5);
  63   is(@bbox, 8, "i_t1_bbox");
  64   print "# bbox: ($bbox[0], $bbox[1]) - ($bbox[2], $bbox[3])\n";
  65
  66   open(FH,">testout/t30t1font.ppm") || die "cannot open testout/t35t1font.ppm\n";
  67   binmode(FH); # for os2
  68   my $IO = Imager::io_new_fd( fileno(FH) );
  69   i_writeppm_wiol($overlay,$IO);
  70   close(FH);
  71
  72   $bgcolor=Imager::Color::set($bgcolor,200,200,200,0);
  73   my $backgr=Imager::ImgRaw::new(280,300,3);
  74
  75   i_t1_set_aa(2);
  76   ok(i_t1_text($backgr,10,100,$bgcolor,$fnum,150.0,'test',4,1), "i_t1_text");
  77
  78   # "UTF8" tests
  79   # for perl < 5.6 we can hand-encode text
  80   # since T1 doesn't support over 256 chars in an encoding we just drop
  81   # chars over \xFF
  82   # the following is "A\xA1\x{2010}A"
  83   #
  84   my $text = pack("C*", 0x41, 0xC2, 0xA1, 0xE2, 0x80, 0x90, 0x41);
  85   my $alttext = "A\xA1A";
  86
  87   my @utf8box = i_t1_bbox($fnum, 50.0, $text, length($text), 1);
  88   is(@utf8box, 8, "utf8 bbox element count");
  89   my @base = i_t1_bbox($fnum, 50.0, $alttext, length($alttext), 0);
  90   is(@base, 8, "alt bbox element count");
  91   my $maxdiff = $fontname_pfb eq $deffont ? 0 : $base[2] / 3;
  92   print "# (@utf8box vs @base)\n";
  93   ok(abs($utf8box[2] - $base[2]) <= $maxdiff,
  94       "compare box sizes $utf8box[2] vs $base[2] (maxerror $maxdiff)");
  95
  96   # hand-encoded UTF8 drawing
  97   ok(i_t1_text($backgr, 10, 140, $bgcolor, $fnum, 32, $text, length($text), 1,1), "draw hand-encoded UTF8");
  98
  99   ok(i_t1_cp($backgr, 80, 140, 1, $fnum, 32, $text, length($text), 1, 1),
 100       "cp hand-encoded UTF8");
 101
 102   # ok, try native perl UTF8 if available
 103  SKIP:
 104   {
 105     $] >= 5.006 or skip("perl too old to test native UTF8 support", 5);
 106     my $text;
 107     # we need to do this in eval to prevent compile time errors in older
 108     # versions
 109     eval q{$text = "A\xA1\x{2010}A"}; # A, a with ogonek, HYPHEN, A in our test font
 110     #$text = "A".chr(0xA1).chr(0x2010)."A"; # this one works too
 111     ok(i_t1_text($backgr, 10, 180, $bgcolor, $fnum, 32, $text, length($text), 1),
 112         "draw UTF8");
 113     ok(i_t1_cp($backgr, 80, 180, 1, $fnum, 32, $text, length($text), 1),
 114         "cp UTF8");
 115     @utf8box = i_t1_bbox($fnum, 50.0, $text, length($text), 0);
 116     is(@utf8box, 8, "native utf8 bbox element count");
 117     ok(abs($utf8box[2] - $base[2]) <= $maxdiff,
 118       "compare box sizes native $utf8box[2] vs $base[2] (maxerror $maxdiff)");
 119     eval q{$text = "A\xA1\xA2\x01\x1F\x{0100}A"};
 120     ok(i_t1_text($backgr, 10, 220, $bgcolor, $fnum, 32, $text, 0, 1, 0, "uso"),
 121        "more complex output");
 122   }
 123
 124   open(FH,">testout/t30t1font2.ppm") || die "cannot open testout/t35t1font.ppm\n";
 125   binmode(FH);
 126   $IO = Imager::io_new_fd( fileno(FH) );
 127   i_writeppm_wiol($backgr, $IO);
 128   close(FH);
 129
 130   my $rc=i_t1_destroy($fnum);
 131   unless (ok($rc >= 0, "i_t1_destroy")) {
 132     print "# i_t1_destroy failed: rc=$rc\n";
 133   }
 134
 135   print "# debug: ",join(" x ",i_t1_bbox(0,50,"eses",4) ),"\n";
 136   print "# debug: ",join(" x ",i_t1_bbox(0,50,"llll",4) ),"\n";
 137
 138   # character existance tests - uses the special ExistenceTest font
 139   my $exists_font = 'fontfiles/ExistenceTest.pfb';
 140   my $exists_afm = 'fontfiles/ExistenceText.afm';
 141
 142   -e $exists_font or die;
 143
 144   my $font_num = Imager::i_t1_new($exists_font, $exists_afm);
 145   SKIP: {
 146     ok($font_num >= 0, 'loading test font')
 147       or skip('Could not load test font', 6);
 148     # first the list interface
 149     my @exists = Imager::i_t1_has_chars($font_num, "!A");
 150     is(@exists, 2, "return count from has_chars");
 151     ok($exists[0], "we have an exclamation mark");
 152     ok(!$exists[1], "we have no uppercase A");
 153
 154     # then the scalar interface
 155     my $exists = Imager::i_t1_has_chars($font_num, "!A");
 156     is(length($exists), 2, "return scalar length");
 157     ok(ord(substr($exists, 0, 1)), "we have an exclamation mark");
 158     ok(!ord(substr($exists, 1, 1)), "we have no upper-case A");
 159     i_t1_destroy($font_num);
 160   }
 161
 162   my $font = Imager::Font->new(file=>$exists_font, type=>'t1');
 163   SKIP:
 164   {
 165     ok($font, "loaded OO font")
 166       or skip("Could not load test font", 24);
 167     my @exists = $font->has_chars(string=>"!A");
 168     is(@exists, 2, "return count from has_chars");
 169     ok($exists[0], "we have an exclamation mark");
 170     ok(!$exists[1], "we have no uppercase A");
 171
 172     # then the scalar interface
 173     my $exists = $font->has_chars(string=>"!A");
 174     is(length($exists), 2, "return scalar length");
 175     ok(ord(substr($exists, 0, 1)), "we have an exclamation mark");
 176     ok(!ord(substr($exists, 1, 1)), "we have no upper-case A");
 177
 178     # check the advance width
 179     my @bbox = $font->bounding_box(string=>'/', size=>100);
 180     print "# @bbox\n";
 181     isnt($bbox[2], $bbox[5], "different advance to pos_width");
 182
 183     # names
 184     my $face_name = Imager::i_t1_face_name($font->{id});
 185     print "# face $face_name\n";
 186     is($face_name, 'ExistenceTest', "face name");
 187     $face_name = $font->face_name;
 188     is($face_name, 'ExistenceTest', "face name");
 189
 190     my @glyph_names = $font->glyph_names(string=>"!J/");
 191     is($glyph_names[0], 'exclam', "check exclam name OO");
 192     ok(!defined($glyph_names[1]), "check for no J name OO");
 193     is($glyph_names[2], 'slash', "check slash name OO");
 194
 195     # this character chosen since when it's truncated to one byte it
 196     # becomes 0x21 or '!' which the font does define
 197     my $text = pack("C*", 0xE2, 0x80, 0xA1); # "\x{2021}" as utf-8
 198     @glyph_names = $font->glyph_names(string=>$text, utf8=>1);
 199     is($glyph_names[0], undef, "expect no glyph_name for \\x{20A1}");
 200
 201     # make sure a missing string parameter is handled correctly
 202     eval {
 203       $font->glyph_names();
 204     };
 205     is($@, "", "correct error handling");
 206     cmp_ok(Imager->errstr, '=~', qr/no string parameter/, "error message");
 207
 208     # test extended bounding box results
 209     # the test font is known to have a shorter advance width for that char
 210     @bbox = $font->bounding_box(string=>"/", size=>100);
 211     is(@bbox, 8, "should be 8 entries");
 212     isnt($bbox[6], $bbox[2], "different advance width");
 213     my $bbox = $font->bounding_box(string=>"/", size=>100);
 214     cmp_ok($bbox->pos_width, '>', $bbox->advance_width, "OO check");
 215
 216     cmp_ok($bbox->right_bearing, '<', 0, "check right bearing");
 217
 218     cmp_ok($bbox->display_width, '>', $bbox->advance_width,
 219            "check display width (roughly)");
 220
 221     # check with a char that fits inside the box
 222     $bbox = $font->bounding_box(string=>"!", size=>100);
 223     print "# pos width ", $bbox->pos_width, "\n";
 224
 225     # they aren't the same historically for the type 1 driver
 226     isnt($bbox->pos_width, $bbox->advance_width,
 227        "check backwards compatibility");
 228     cmp_ok($bbox->left_bearing, '>', 0, "left bearing positive");
 229     cmp_ok($bbox->right_bearing, '>', 0, "right bearing positive");
 230     cmp_ok($bbox->display_width, '<', $bbox->advance_width,
 231            "display smaller than advance");
 232   }
 233
 234  SKIP:
 235   { print "# alignment tests\n";
 236     my $font = Imager::Font->new(file=>$deffont, type=>'t1');
 237     ok($font, "loaded deffont OO")
 238       or skip("could not load font:".Imager->errstr, 4);
 239     my $im = Imager->new(xsize=>140, ysize=>150);
 240     my %common =
 241       (
 242        font=>$font,
 243        size=>40,
 244        aa=>1,
 245       );
 246     $im->line(x1=>0, y1=>40, x2=>139, y2=>40, color=>'blue');
 247     $im->line(x1=>0, y1=>90, x2=>139, y2=>90, color=>'blue');
 248     $im->line(x1=>0, y1=>110, x2=>139, y2=>110, color=>'blue');
 249     for my $args ([ x=>5,   text=>"A", color=>"white" ],
 250                   [ x=>40,  text=>"y", color=>"white" ],
 251                   [ x=>75,  text=>"A", channel=>1 ],
 252                   [ x=>110, text=>"y", channel=>1 ]) {
 253       ok($im->string(%common, @$args, 'y'=>40), "A no alignment");
 254       ok($im->string(%common, @$args, 'y'=>90, align=>1), "A align=1");
 255       ok($im->string(%common, @$args, 'y'=>110, align=>0), "A align=0");
 256     }
 257     ok($im->write(file=>'testout/t30align.ppm'), "save align image");
 258   }
 259
 260  SKIP:
 261   {
 262     # see http://rt.cpan.org/Ticket/Display.html?id=20555
 263     print "# bounding box around spaces\n";
 264     # SpaceTest contains 3 characters, space, ! and .undef
 265     # only characters that define character zero seem to illustrate
 266     # the problem we had with spaces
 267     my $space_fontfile = "fontfiles/SpaceTest.pfb";
 268     my $font = Imager::Font->new(file => $space_fontfile, type => 't1');
 269     ok($font, "loaded $deffont")
 270       or skip("failed to load $deffont" . Imager->errstr, 13);
 271     my $bbox = $font->bounding_box(string => "", size => 36);
 272     print "# empty string bbox: @$bbox\n";
 273     is($bbox->start_offset, 0, "empty string start_offset");
 274     is($bbox->end_offset, 0, "empty string end_offset");
 275     is($bbox->advance_width, 0, "empty string advance_width");
 276     is($bbox->ascent, 0, "empty string ascent");
 277     is($bbox->descent, 0, "empty string descent");
 278
 279     # a single space
 280     my $bbox_space = $font->bounding_box(string => " ", size => 36);
 281     print "# space bbox: @$bbox_space\n";
 282     is($bbox_space->start_offset, 0, "single space start_offset");
 283     is($bbox_space->end_offset, $bbox_space->advance_width,
 284        "single space end_offset");
 285     cmp_ok($bbox_space->ascent, '>=', $bbox_space->descent,
 286            "single space ascent/descent");
 287
 288     my $bbox_bang = $font->bounding_box(string => "!", size => 36);
 289     print "# '!' bbox: @$bbox_bang\n";
 290
 291     # space ! space
 292     my $bbox_spbangsp = $font->bounding_box(string => " ! ", size => 36);
 293     print "# ' ! ' bbox: @$bbox_spbangsp\n";
 294     my $exp_advance = $bbox_bang->advance_width + 2 * $bbox_space->advance_width;
 295     is($bbox_spbangsp->advance_width, $exp_advance, "sp ! sp advance_width");
 296     is($bbox_spbangsp->start_offset, 0, "sp ! sp start_offset");
 297     is($bbox_spbangsp->end_offset, $exp_advance, "sp ! sp end_offset");
 298   }
 299
 300  SKIP:
 301   { # http://rt.cpan.org/Ticket/Display.html?id=20554
 302     # this is "A\xA1\x{2010}A"
 303     # the t1 driver is meant to ignore any UTF8 characters over 0xff
 304     print "# issue 20554\n";
 305     my $text = pack("C*", 0x41, 0xC2, 0xA1, 0xE2, 0x80, 0x90, 0x41);
 306     my $tran_text = "A\xA1A";
 307     my $font = Imager::Font->new(file => 'fontfiles/dcr10.pfb', type => 't1');
 308     $font
 309       or skip("cannot load font fontfiles/fcr10.pfb:".Imager->errstr, 1);
 310     my $bbox_utf8 = $font->bounding_box(string => $text, utf8 => 1, size => 36);
 311     my $bbox_tran = $font->bounding_box(string => $tran_text, size => 36);
 312     is($bbox_utf8->advance_width, $bbox_tran->advance_width,
 313        "advance widths should match");
 314   }
 315   { # string output cut off at NUL ('\0')
 316     # https://rt.cpan.org/Ticket/Display.html?id=21770 cont'd
 317     my $font = Imager::Font->new(file => 'fontfiles/dcr10.pfb', type => 't1');
 318     ok($font, "loaded dcr10.pfb");
 319
 320     diff_text_with_nul("a\\0b vs a", "a\0b", "a",
 321                        font => $font, color => '#FFFFFF');
 322     diff_text_with_nul("a\\0b vs a", "a\0b", "a",
 323                        font => $font, channel => 1);
 324
 325     # UTF8 encoded \xBF
 326     my $pound = pack("C*", 0xC2, 0xBF);
 327     diff_text_with_nul("utf8 pound\0pound vs pound", "$pound\0$pound", $pound,
 328                        font => $font, color => '#FFFFFF', utf8 => 1);
 329     diff_text_with_nul("utf8 dash\0dash vs dash", "$pound\0$pound", $pound,
 330                        font => $font, channel => 1, utf8 => 1);
 331
 332   }
 333
 334   { # RT 11972
 335     # when rendering to a transparent image the coverage should be
 336     # expressed in terms of the alpha channel rather than the color
 337     my $font = Imager::Font->new(file=>'fontfiles/dcr10.pfb', type=>'t1');
 338     my $im = Imager->new(xsize => 40, ysize => 20, channels => 4);
 339     ok($im->string(string => "AB", size => 20, aa => 2, color => '#F00',
 340                    x => 0, y => 15, font => $font),
 341        "draw to transparent image");
 342     my $im_noalpha = $im->convert(preset => 'noalpha');
 343     my $im_pal = $im->to_paletted(make_colors => 'mediancut');
 344     my @colors = $im_pal->getcolors;
 345     is(@colors, 2, "should be only 2 colors");
 346     @colors = sort { ($a->rgba)[0] <=> ($b->rgba)[0] } @colors;
 347     is_color3($colors[0], 0, 0, 0, "check we got black");
 348     is_color3($colors[1], 255, 0, 0, "and red");
 349   }
 350
 351  SKIP:
 352   { # RT 60509
 353     # checks that a c:foo or c:\foo path is handled correctly on win32
 354     my $type = "t1";
 355     $^O eq "MSWin32" || $^O eq "cygwin"
 356       or skip("only for win32", 2);
 357     my $dir = getcwd
 358       or skip("Cannot get cwd", 2);
 359     if ($^O eq "cygwin") {
 360       $dir = Cygwin::posix_to_win_path($dir);
 361     }
 362     my $abs_path = abs_path($deffont);
 363     my $font = Imager::Font->new(file => $abs_path, type => $type);
 364     ok($font, "found font by absolute path")
 365       or print "# path $abs_path\n";
 366     undef $font;
 367
 368     $^O eq "cygwin"
 369       and skip("cygwin doesn't support drive relative DOSsish paths", 1);
 370     my ($drive) = $dir =~ /^([a-z]:)/i
 371       or skip("cwd has no drive letter", 2);
 372     my $drive_path = $drive . $deffont;
 373     $font = Imager::Font->new(file => $drive_path, type => $type);
 374     ok($font, "found font by drive relative path")
 375       or print "# path $drive_path\n";
 376   }
 377 }
 378
 379 #malloc_state();