view release on metacpan or  search on metacpan

T1/t/t10type1.t  view on Meta::CPAN

#!perl -w
use strict;
use Test::More;
use Imager ':all';
use Imager::Test qw(diff_text_with_nul is_color3 is_image isnt_image);
use Imager::Font::T1;
use Cwd qw(getcwd abs_path);

#$Imager::DEBUG=1;

ok($Imager::formats{t1}, "must have t1");

-d "testout" or mkdir "testout";
ok(-d "testout", "make output directory");

init_log("testout/t10type1.log",1);

my $deffont = 'fontfiles/dcr10.pfb';

my $fontname_pfb=$ENV{'T1FONTTESTPFB'}||$deffont;
my $fontname_afm=$ENV{'T1FONTTESTAFM'}||'./fontfiles/dcr10.afm';

-f $fontname_pfb
  or skip_all("cannot find fontfile for type 1 test $fontname_pfb");
-f $fontname_afm
  or skip_all("cannot find fontfile for type 1 test $fontname_afm");

SKIP:
{
  print "# has t1\n";

  #i_t1_set_aa(1);

  unlink "t1lib.log"; # lose it if it exists
  init(t1log=>0);
  ok(!-e("t1lib.log"), "disable t1log");
  init(t1log=>1);
  ok(-e("t1lib.log"), "enable t1log");
  init(t1log=>0);
  unlink "t1lib.log";

  my $fnum=Imager::Font::T1xs->new($fontname_pfb,$fontname_afm); # this will load the pfb font
  unless (ok($fnum >= 0, "load font $fontname_pfb")) {
    skip("without the font I can't do a thing", 90);
  }

  my $bgcolor=Imager::Color->new(255,0,0,255);
  my $overlay=Imager::ImgRaw::new(200,70,3);
  
  ok($fnum->cp($overlay,5,50,1,50.0,'XMCLH',1), "i_t1_cp");

  i_line($overlay,0,50,100,50,$bgcolor,1);

  my @bbox=$fnum->bbox(50.0,'XMCLH');
  is(@bbox, 8, "i_t1_bbox");
  print "# bbox: ($bbox[0], $bbox[1]) - ($bbox[2], $bbox[3])\n";

  open(FH,">testout/t30t1font.ppm") || die "cannot open testout/t35t1font.ppm\n";
  binmode(FH); # for os2
  my $IO = Imager::io_new_fd( fileno(FH) );
  i_writeppm_wiol($overlay,$IO);
  close(FH);

  $bgcolor=Imager::Color::set($bgcolor,200,200,200,255);
  my $backgr=Imager::ImgRaw::new(280,300,3);

  ok($fnum->text($backgr,10,100,$bgcolor,150.0,'test',1,2), "i_t1_text");

  # "UTF8" tests
  # for perl < 5.6 we can hand-encode text
  # since T1 doesn't support over 256 chars in an encoding we just drop
  # chars over \xFF
  # the following is "A\xA1\x{2010}A"
  # 
  my $text = pack("C*", 0x41, 0xC2, 0xA1, 0xE2, 0x80, 0x90, 0x41);
  my $alttext = "A\xA1A";
  
  my @utf8box = $fnum->bbox(50.0, $text, 1);
  is(@utf8box, 8, "utf8 bbox element count");
  my @base = $fnum->bbox(50.0, $alttext, 0);
  is(@base, 8, "alt bbox element count");
  my $maxdiff = $fontname_pfb eq $deffont ? 0 : $base[2] / 3;
  print "# (@utf8box vs @base)\n";
  ok(abs($utf8box[2] - $base[2]) <= $maxdiff, 
      "compare box sizes $utf8box[2] vs $base[2] (maxerror $maxdiff)");

  # hand-encoded UTF8 drawing
  ok($fnum->text($backgr, 10, 140, $bgcolor, 32, $text, 1,1), "draw hand-encoded UTF8");

  ok($fnum->cp($backgr, 80, 140, 1, 32, $text, 1, 1), 
      "cp hand-encoded UTF8");

  { # invalid utf8
    my $text = pack("C", 0xC0);
    ok(!$fnum->text($backgr, 10, 140, $bgcolor, 32, $text, 1, 1),
       "attempt to draw invalid utf8");
    is(Imager->_error_as_msg, "invalid UTF8 character",
       "check message");
  }

  # ok, try native perl UTF8 if available
 SKIP:
  {
    $] >= 5.006 or skip("perl too old to test native UTF8 support", 5);
    my $text;
    # we need to do this in eval to prevent compile time errors in older
    # versions
    eval q{$text = "A\xA1\x{2010}A"}; # A, a with ogonek, HYPHEN, A in our test font
    #$text = "A".chr(0xA1).chr(0x2010)."A"; # this one works too
    Imager->log("draw UTF8\n");
    ok($fnum->text($backgr, 10, 180, $bgcolor, 32, $text, 1),
        "draw UTF8");
    ok($fnum->cp($backgr, 80, 180, 1, 32, $text, 1),
        "cp UTF8");
    @utf8box = $fnum->bbox(50.0, $text, 0);
    is(@utf8box, 8, "native utf8 bbox element count");
    ok(abs($utf8box[2] - $base[2]) <= $maxdiff, 
      "compare box sizes native $utf8box[2] vs $base[2] (maxerror $maxdiff)");
    eval q{$text = "A\xA1\xA2\x01\x1F\x{0100}A"};
    ok($fnum->text($backgr, 10, 220, $bgcolor, 32, $text, 0, 1, "uso"),
       "more complex output");