The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl -w
use strict;
use Imager;
use Imager::Test qw(isnt_image);
use Test::More tests => 14;

# extracted from t/t36oofont.t

my $fontname_pfb = "fontfiles/dcr10.pfb";

my $green=Imager::Color->new(92,205,92,128);
die $Imager::ERRSTR unless $green;
my $red=Imager::Color->new(205, 92, 92, 255);
die $Imager::ERRSTR unless $red;

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

Imager::init_log("testout/t20oo.log", 1);

my $img=Imager->new(xsize=>300, ysize=>100) or die "$Imager::ERRSTR\n";

my $font=Imager::Font->new(file=>$fontname_pfb,size=>25, type => "t1")
  or die $img->{ERRSTR};

ok(1, "created font");

ok($img->string(font=>$font, text=>"XMCLH", 'x'=>100, 'y'=>100),
   "draw text");
$img->line(x1=>0, x2=>300, y1=>50, y2=>50, color=>$green);

my $text="LLySja";
my @bbox=$font->bounding_box(string=>$text, 'x'=>0, 'y'=>50);

is(@bbox, 8, "bounding box list length");

$img->box(box=>\@bbox, color=>$green);

# "utf8" support
$text = pack("C*", 0x41, 0xE2, 0x80, 0x90, 0x41);
ok($img->string(font=>$font, text=>$text, 'x'=>100, 'y'=>50, utf8=>1,
		overline=>1),
   "draw 'utf8' hand-encoded text");

ok($img->string(font=>$font, text=>$text, 'x'=>140, 'y'=>50, utf8=>1, 
		underline=>1, channel=>2),
   "channel 'utf8' hand-encoded text");

SKIP:
{
  $] >= 5.006
    or skip("perl too old for native utf8", 2);
    eval q{$text = "A\x{2010}A"};
  ok($img->string(font=>$font, text=>$text, 'x'=>180, 'y'=>50,
		  strikethrough=>1),
     "draw native UTF8 text");
  ok($img->string(font=>$font, text=>$text, 'x'=>220, 'y'=>50, channel=>1),
     "channel native UTF8 text");
}

ok($img->write(file=>"testout/t36oofont1.ppm", type=>'pnm'),
   "write t36oofont1.ppm")
  or print "# ",$img->errstr,"\n";

{ # RT 71469
  my $font1 = Imager::Font->new(file => $fontname_pfb, type => "t1");
  my $font2 = Imager::Font::T1->new(file => $fontname_pfb);

  for my $font ($font1, $font2) {
    print "# ", join(",", $font->{color}->rgba), "\n";

    my $im = Imager->new(xsize => 20, ysize => 20, channels => 4);

    ok($im->string(text => "T", font => $font, y => 15),
       "draw with default color")
      or print "# ", $im->errstr, "\n";
    my $work = Imager->new(xsize => 20, ysize => 20);
    my $cmp = $work->copy;
    $work->rubthrough(src => $im);
    isnt_image($work, $cmp, "make sure something was drawn");
  }
}

{ # open a non-font as a font (test open failure)
  local $ENV{LANG} = "C";
  local $ENV{LC_ALL} = "C";
  my $font = Imager::Font->new(file => "t/t20oo.t", type => "t1");
  ok(!$font, "should fail to open test script as a font");
  print "# ", Imager->errstr, "\n";
}

unless ($ENV{IMAGER_KEEP_FILES}) {
  unlink "testout/t36oofont1.ppm";
}