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 my $loaded;
  11 BEGIN { $| = 1; print "1..38\n"; }
  12 END {print "not ok 1\n" unless $loaded;}
  13 use Imager qw(:all);
  14 use Imager::Color;
  15 require "t/testtools.pl";
  16
  17 $loaded = 1;
  18 okx(1, "loaded");
  19
  20 #$Imager::DEBUG=1;
  21
  22 init_log("testout/t30t1font.log",1);
  23
  24 my $deffont = './fontfiles/dcr10.pfb';
  25
  26 my $fontname_pfb=$ENV{'T1FONTTESTPFB'}||$deffont;
  27 my $fontname_afm=$ENV{'T1FONTTESTAFM'}||'./fontfiles/dcr10.afm';
  28
  29
  30 if (!(i_has_format("t1")) ) {
  31   skipx(37, "t1lib unavailable or disabled");
  32 }
  33 elsif (! -f $fontname_pfb) {
  34   skipx(37, "cannot find fontfile for type 1 test $fontname_pfb");
  35 }
  36 elsif (! -f $fontname_afm) {
  37   skipx(37, "cannot find fontfile for type 1 test $fontname_afm");
  38 } else {
  39
  40   print "# has t1\n";
  41
  42   i_t1_set_aa(1);
  43
  44   my $fnum=Imager::i_t1_new($fontname_pfb,$fontname_afm); # this will load the pfb font
  45   unless (okx($fnum >= 0, "load font $fontname_pfb")) {
  46     skipx(31, "without the font I can't do a thing");
  47     exit;
  48   }
  49
  50   my $bgcolor=Imager::Color->new(255,0,0,0);
  51   my $overlay=Imager::ImgRaw::new(200,70,3);
  52
  53   okx(i_t1_cp($overlay,5,50,1,$fnum,50.0,'XMCLH',5,1), "i_t1_cp");
  54
  55   i_line($overlay,0,50,100,50,$bgcolor,1);
  56
  57   my @bbox=i_t1_bbox(0,50.0,'XMCLH',5);
  58   okx(@bbox == 7, "i_t1_bbox");
  59   print "# bbox: ($bbox[0], $bbox[1]) - ($bbox[2], $bbox[3])\n";
  60
  61   open(FH,">testout/t30t1font.ppm") || die "cannot open testout/t35t1font.ppm\n";
  62   binmode(FH); # for os2
  63   my $IO = Imager::io_new_fd( fileno(FH) );
  64   i_writeppm_wiol($overlay,$IO);
  65   close(FH);
  66
  67   $bgcolor=Imager::Color::set($bgcolor,200,200,200,0);
  68   my $backgr=Imager::ImgRaw::new(280,300,3);
  69
  70   i_t1_set_aa(2);
  71   okx(i_t1_text($backgr,10,100,$bgcolor,$fnum,150.0,'test',4,1), "i_t1_text");
  72
  73   # "UTF8" tests
  74   # for perl < 5.6 we can hand-encode text
  75   # since T1 doesn't support over 256 chars in an encoding we just drop
  76   # chars over \xFF
  77   # the following is "A\xA1\x{2010}A"
  78   #
  79   my $text = pack("C*", 0x41, 0xC2, 0xA1, 0xE2, 0x80, 0x90, 0x41);
  80   my $alttext = "A\xA1A";
  81
  82   my @utf8box = i_t1_bbox($fnum, 50.0, $text, length($text), 1);
  83   okx(@utf8box == 7, "utf8 bbox element count");
  84   my @base = i_t1_bbox($fnum, 50.0, $alttext, length($alttext), 0);
  85   okx(@base == 7, "alt bbox element count");
  86   my $maxdiff = $fontname_pfb eq $deffont ? 0 : $base[2] / 3;
  87   print "# (@utf8box vs @base)\n";
  88   okx(abs($utf8box[2] - $base[2]) <= $maxdiff,
  89       "compare box sizes $utf8box[2] vs $base[2] (maxerror $maxdiff)");
  90
  91   # hand-encoded UTF8 drawing
  92   okx(i_t1_text($backgr, 10, 140, $bgcolor, $fnum, 32, $text, length($text), 1,1), "draw hand-encoded UTF8");
  93
  94   okx(i_t1_cp($backgr, 80, 140, 1, $fnum, 32, $text, length($text), 1, 1),
  95       "cp hand-encoded UTF8");
  96
  97   # ok, try native perl UTF8 if available
  98   if ($] >= 5.006) {
  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     okx(i_t1_text($backgr, 10, 180, $bgcolor, $fnum, 32, $text, length($text), 1),
 105         "draw UTF8");
 106     okx(i_t1_cp($backgr, 80, 180, 1, $fnum, 32, $text, length($text), 1),
 107         "cp UTF8");
 108     @utf8box = i_t1_bbox($fnum, 50.0, $text, length($text), 0);
 109     okx(@utf8box == 7, "native utf8 bbox element count");
 110     okx(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     okx(i_t1_text($backgr, 10, 220, $bgcolor, $fnum, 32, $text, 0, 1, 0, "uso"),
 114         "more complex output");
 115   }
 116   else {
 117     skipx(5, "perl too old to test native UTF8 support");
 118   }
 119
 120   open(FH,">testout/t30t1font2.ppm") || die "cannot open testout/t35t1font.ppm\n";
 121   binmode(FH);
 122   $IO = Imager::io_new_fd( fileno(FH) );
 123   i_writeppm_wiol($backgr, $IO);
 124   close(FH);
 125
 126   my $rc=i_t1_destroy($fnum);
 127   unless (okx($rc >= 0, "i_t1_destroy")) {
 128     print "# i_t1_destroy failed: rc=$rc\n";
 129   }
 130
 131   print "# debug: ",join(" x ",i_t1_bbox(0,50,"eses",4) ),"\n";
 132   print "# debug: ",join(" x ",i_t1_bbox(0,50,"llll",4) ),"\n";
 133
 134   unlink "t1lib.log"; # lose it if it exists
 135   init(t1log=>0);
 136   okx(!-e("t1lib.log"), "disable t1log");
 137   init(t1log=>1);
 138   okx(-e("t1lib.log"), "enable t1log");
 139   init(t1log=>0);
 140   unlink "t1lib.log";
 141
 142   # character existance tests - uses the special ExistenceTest font
 143   my $exists_font = 'fontfiles/ExistenceTest.pfb';
 144   my $exists_afm = 'fontfiles/ExistenceText.afm';
 145
 146   -e $exists_font or die;
 147
 148   my $font_num = Imager::i_t1_new($exists_font, $exists_afm);
 149   if (okx($font_num >= 0, 'loading test font')) {
 150     # first the list interface
 151     my @exists = Imager::i_t1_has_chars($font_num, "!A");
 152     okx(@exists == 2, "return count from has_chars");
 153     okx($exists[0], "we have an exclamation mark");
 154     okx(!$exists[1], "we have no uppercase A");
 155
 156     # then the scalar interface
 157     my $exists = Imager::i_t1_has_chars($font_num, "!A");
 158     okx(length($exists) == 2, "return scalar length");
 159     okx(ord(substr($exists, 0, 1)), "we have an exclamation mark");
 160     okx(!ord(substr($exists, 1, 1)), "we have no upper-case A");
 161   }
 162   else {
 163     skipx(6, 'Could not load test font');
 164   }
 165
 166   my $font = Imager::Font->new(file=>$exists_font, type=>'t1');
 167   if (okx($font, "loaded OO font")) {
 168     my @exists = $font->has_chars(string=>"!A");
 169     okx(@exists == 2, "return count from has_chars");
 170     okx($exists[0], "we have an exclamation mark");
 171     okx(!$exists[1], "we have no uppercase A");
 172
 173     # then the scalar interface
 174     my $exists = $font->has_chars(string=>"!A");
 175     okx(length($exists) == 2, "return scalar length");
 176     okx(ord(substr($exists, 0, 1)), "we have an exclamation mark");
 177     okx(!ord(substr($exists, 1, 1)), "we have no upper-case A");
 178
 179     # check the advance width
 180     my @bbox = $font->bounding_box(string=>'/', size=>100);
 181     print "# @bbox\n";
 182     okx($bbox[2] != $bbox[5], "different advance to pos_width");
 183
 184     # names
 185     my $face_name = Imager::i_t1_face_name($font->{id});
 186     print "# face $face_name\n";
 187     okx($face_name eq 'ExistenceTest', "face name");
 188     $face_name = $font->face_name;
 189     okx($face_name eq 'ExistenceTest', "face name");
 190
 191     my @glyph_names = $font->glyph_names(string=>"!J/");
 192     okx($glyph_names[0] eq 'exclam', "check exclam name OO");
 193     okx(!defined($glyph_names[1]), "check for no J name OO");
 194     okx($glyph_names[2] eq 'slash', "check slash name OO");
 195   }
 196   else {
 197     skipx(12, "Could not load test font");
 198   }
 199 }
 200
 201 #malloc_state();