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 lib 't';
  11 use Test::More tests => 64;
  12 BEGIN { use_ok(Imager => ':all') }
  13
  14 #$Imager::DEBUG=1;
  15
  16 init_log("testout/t30t1font.log",1);
  17
  18 my $deffont = './fontfiles/dcr10.pfb';
  19
  20 my $fontname_pfb=$ENV{'T1FONTTESTPFB'}||$deffont;
  21 my $fontname_afm=$ENV{'T1FONTTESTAFM'}||'./fontfiles/dcr10.afm';
  22
  23 SKIP:
  24 {
  25   if (!(i_has_format("t1")) ) {
  26     skip("t1lib unavailable or disabled", 63);
  27   }
  28   elsif (! -f $fontname_pfb) {
  29     skip("cannot find fontfile for type 1 test $fontname_pfb", 63);
  30   }
  31   elsif (! -f $fontname_afm) {
  32     skip("cannot find fontfile for type 1 test $fontname_afm", 63);
  33   }
  34
  35   print "# has t1\n";
  36
  37   i_t1_set_aa(1);
  38
  39   my $fnum=Imager::i_t1_new($fontname_pfb,$fontname_afm); # this will load the pfb font
  40   unless (ok($fnum >= 0, "load font $fontname_pfb")) {
  41     skip("without the font I can't do a thing", 48);
  42   }
  43
  44   my $bgcolor=Imager::Color->new(255,0,0,0);
  45   my $overlay=Imager::ImgRaw::new(200,70,3);
  46
  47   ok(i_t1_cp($overlay,5,50,1,$fnum,50.0,'XMCLH',5,1), "i_t1_cp");
  48
  49   i_line($overlay,0,50,100,50,$bgcolor,1);
  50
  51   my @bbox=i_t1_bbox(0,50.0,'XMCLH',5);
  52   is(@bbox, 8, "i_t1_bbox");
  53   print "# bbox: ($bbox[0], $bbox[1]) - ($bbox[2], $bbox[3])\n";
  54
  55   open(FH,">testout/t30t1font.ppm") || die "cannot open testout/t35t1font.ppm\n";
  56   binmode(FH); # for os2
  57   my $IO = Imager::io_new_fd( fileno(FH) );
  58   i_writeppm_wiol($overlay,$IO);
  59   close(FH);
  60
  61   $bgcolor=Imager::Color::set($bgcolor,200,200,200,0);
  62   my $backgr=Imager::ImgRaw::new(280,300,3);
  63
  64   i_t1_set_aa(2);
  65   ok(i_t1_text($backgr,10,100,$bgcolor,$fnum,150.0,'test',4,1), "i_t1_text");
  66
  67   # "UTF8" tests
  68   # for perl < 5.6 we can hand-encode text
  69   # since T1 doesn't support over 256 chars in an encoding we just drop
  70   # chars over \xFF
  71   # the following is "A\xA1\x{2010}A"
  72   #
  73   my $text = pack("C*", 0x41, 0xC2, 0xA1, 0xE2, 0x80, 0x90, 0x41);
  74   my $alttext = "A\xA1A";
  75
  76   my @utf8box = i_t1_bbox($fnum, 50.0, $text, length($text), 1);
  77   is(@utf8box, 8, "utf8 bbox element count");
  78   my @base = i_t1_bbox($fnum, 50.0, $alttext, length($alttext), 0);
  79   is(@base, 8, "alt bbox element count");
  80   my $maxdiff = $fontname_pfb eq $deffont ? 0 : $base[2] / 3;
  81   print "# (@utf8box vs @base)\n";
  82   ok(abs($utf8box[2] - $base[2]) <= $maxdiff,
  83       "compare box sizes $utf8box[2] vs $base[2] (maxerror $maxdiff)");
  84
  85   # hand-encoded UTF8 drawing
  86   ok(i_t1_text($backgr, 10, 140, $bgcolor, $fnum, 32, $text, length($text), 1,1), "draw hand-encoded UTF8");
  87
  88   ok(i_t1_cp($backgr, 80, 140, 1, $fnum, 32, $text, length($text), 1, 1),
  89       "cp hand-encoded UTF8");
  90
  91   # ok, try native perl UTF8 if available
  92  SKIP:
  93   {
  94     $] >= 5.006 or skip("perl too old to test native UTF8 support", 5);
  95     my $text;
  96     # we need to do this in eval to prevent compile time errors in older
  97     # versions
  98     eval q{$text = "A\xA1\x{2010}A"}; # A, a with ogonek, HYPHEN, A in our test font
  99     #$text = "A".chr(0xA1).chr(0x2010)."A"; # this one works too
 100     ok(i_t1_text($backgr, 10, 180, $bgcolor, $fnum, 32, $text, length($text), 1),
 101         "draw UTF8");
 102     ok(i_t1_cp($backgr, 80, 180, 1, $fnum, 32, $text, length($text), 1),
 103         "cp UTF8");
 104     @utf8box = i_t1_bbox($fnum, 50.0, $text, length($text), 0);
 105     is(@utf8box, 8, "native utf8 bbox element count");
 106     ok(abs($utf8box[2] - $base[2]) <= $maxdiff,
 107       "compare box sizes native $utf8box[2] vs $base[2] (maxerror $maxdiff)");
 108     eval q{$text = "A\xA1\xA2\x01\x1F\x{0100}A"};
 109     ok(i_t1_text($backgr, 10, 220, $bgcolor, $fnum, 32, $text, 0, 1, 0, "uso"),
 110        "more complex output");
 111   }
 112
 113   open(FH,">testout/t30t1font2.ppm") || die "cannot open testout/t35t1font.ppm\n";
 114   binmode(FH);
 115   $IO = Imager::io_new_fd( fileno(FH) );
 116   i_writeppm_wiol($backgr, $IO);
 117   close(FH);
 118
 119   my $rc=i_t1_destroy($fnum);
 120   unless (ok($rc >= 0, "i_t1_destroy")) {
 121     print "# i_t1_destroy failed: rc=$rc\n";
 122   }
 123
 124   print "# debug: ",join(" x ",i_t1_bbox(0,50,"eses",4) ),"\n";
 125   print "# debug: ",join(" x ",i_t1_bbox(0,50,"llll",4) ),"\n";
 126
 127   unlink "t1lib.log"; # lose it if it exists
 128   init(t1log=>0);
 129   ok(!-e("t1lib.log"), "disable t1log");
 130   init(t1log=>1);
 131   ok(-e("t1lib.log"), "enable t1log");
 132   init(t1log=>0);
 133   unlink "t1lib.log";
 134
 135   # character existance tests - uses the special ExistenceTest font
 136   my $exists_font = 'fontfiles/ExistenceTest.pfb';
 137   my $exists_afm = 'fontfiles/ExistenceText.afm';
 138
 139   -e $exists_font or die;
 140
 141   my $font_num = Imager::i_t1_new($exists_font, $exists_afm);
 142   SKIP: {
 143     ok($font_num >= 0, 'loading test font')
 144       or skip('Could not load test font', 6);
 145     # first the list interface
 146     my @exists = Imager::i_t1_has_chars($font_num, "!A");
 147     is(@exists, 2, "return count from has_chars");
 148     ok($exists[0], "we have an exclamation mark");
 149     ok(!$exists[1], "we have no uppercase A");
 150
 151     # then the scalar interface
 152     my $exists = Imager::i_t1_has_chars($font_num, "!A");
 153     is(length($exists), 2, "return scalar length");
 154     ok(ord(substr($exists, 0, 1)), "we have an exclamation mark");
 155     ok(!ord(substr($exists, 1, 1)), "we have no upper-case A");
 156   }
 157
 158   my $font = Imager::Font->new(file=>$exists_font, type=>'t1');
 159   SKIP:
 160   {
 161     ok($font, "loaded OO font")
 162       or skip("Could not load test font", 24);
 163     my @exists = $font->has_chars(string=>"!A");
 164     is(@exists, 2, "return count from has_chars");
 165     ok($exists[0], "we have an exclamation mark");
 166     ok(!$exists[1], "we have no uppercase A");
 167
 168     # then the scalar interface
 169     my $exists = $font->has_chars(string=>"!A");
 170     is(length($exists), 2, "return scalar length");
 171     ok(ord(substr($exists, 0, 1)), "we have an exclamation mark");
 172     ok(!ord(substr($exists, 1, 1)), "we have no upper-case A");
 173
 174     # check the advance width
 175     my @bbox = $font->bounding_box(string=>'/', size=>100);
 176     print "# @bbox\n";
 177     isnt($bbox[2], $bbox[5], "different advance to pos_width");
 178
 179     # names
 180     my $face_name = Imager::i_t1_face_name($font->{id});
 181     print "# face $face_name\n";
 182     ok($face_name eq 'ExistenceTest', "face name");
 183     $face_name = $font->face_name;
 184     ok($face_name eq 'ExistenceTest', "face name");
 185
 186     my @glyph_names = $font->glyph_names(string=>"!J/");
 187     is($glyph_names[0], 'exclam', "check exclam name OO");
 188     ok(!defined($glyph_names[1]), "check for no J name OO");
 189     is($glyph_names[2], 'slash', "check slash name OO");
 190
 191     # this character chosen since when it's truncated to one byte it
 192     # becomes 0x21 or '!' which the font does define
 193     my $text = pack("C*", 0xE2, 0x80, 0xA1); # "\x{2021}" as utf-8
 194     @glyph_names = $font->glyph_names(string=>$text, utf8=>1);
 195     is($glyph_names[0], undef, "expect no glyph_name for \\x{20A1}");
 196
 197     # make sure a missing string parameter is handled correctly
 198     eval {
 199       $font->glyph_names();
 200     };
 201     is($@, "", "correct error handling");
 202     cmp_ok(Imager->errstr, '=~', qr/no string parameter/, "error message");
 203
 204     # test extended bounding box results
 205     # the test font is known to have a shorter advance width for that char
 206     @bbox = $font->bounding_box(string=>"/", size=>100);
 207     is(@bbox, 8, "should be 8 entries");
 208     isnt($bbox[6], $bbox[2], "different advance width");
 209     my $bbox = $font->bounding_box(string=>"/", size=>100);
 210     cmp_ok($bbox->pos_width, '>', $bbox->advance_width, "OO check");
 211
 212     cmp_ok($bbox->right_bearing, '<', 0, "check right bearing");
 213
 214     cmp_ok($bbox->display_width, '>', $bbox->advance_width,
 215            "check display width (roughly)");
 216
 217     # check with a char that fits inside the box
 218     $bbox = $font->bounding_box(string=>"!", size=>100);
 219     print "# pos width ", $bbox->pos_width, "\n";
 220
 221     # they aren't the same historically for the type 1 driver
 222     isnt($bbox->pos_width, $bbox->advance_width,
 223        "check backwards compatibility");
 224     cmp_ok($bbox->left_bearing, '>', 0, "left bearing positive");
 225     cmp_ok($bbox->right_bearing, '>', 0, "right bearing positive");
 226     cmp_ok($bbox->display_width, '<', $bbox->advance_width,
 227            "display smaller than advance");
 228   }
 229
 230  SKIP:
 231   { print "# alignment tests\n";
 232     my $font = Imager::Font->new(file=>$deffont, type=>'t1');
 233     ok($font, "loaded deffont OO")
 234       or skip("could not load font:".Imager->errstr, 4);
 235     my $im = Imager->new(xsize=>140, ysize=>150);
 236     my %common =
 237       (
 238        font=>$font,
 239        size=>40,
 240        aa=>1,
 241       );
 242     $im->line(x1=>0, y1=>40, x2=>139, y2=>40, color=>'blue');
 243     $im->line(x1=>0, y1=>90, x2=>139, y2=>90, color=>'blue');
 244     $im->line(x1=>0, y1=>110, x2=>139, y2=>110, color=>'blue');
 245     for my $args ([ x=>5,   text=>"A", color=>"white" ],
 246                   [ x=>40,  text=>"y", color=>"white" ],
 247                   [ x=>75,  text=>"A", channel=>1 ],
 248                   [ x=>110, text=>"y", channel=>1 ]) {
 249       ok($im->string(%common, @$args, 'y'=>40), "A no alignment");
 250       ok($im->string(%common, @$args, 'y'=>90, align=>1), "A align=1");
 251       ok($im->string(%common, @$args, 'y'=>110, align=>0), "A align=0");
 252     }
 253     ok($im->write(file=>'testout/t30align.ppm'), "save align image");
 254   }
 255 }
 256
 257 #malloc_state();