T1/t/t10type1.t

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