The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use Imager ':all';

print "1..13\n";

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

my $green = i_color_new(0,255,0,255);
my $blue  = i_color_new(0,0,255,255);
my $red   = i_color_new(255,0,0,255);

my $img    = Imager::ImgRaw::new(150,150,3);

i_box_filled($img,70,25,130,125,$green);
i_box_filled($img,20,25,80,125,$blue);
i_arc($img,75,75,30,0,361,$red);
i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);

my $fh = openimage(">testout/t104.ppm");
$IO = Imager::io_new_fd(fileno($fh));
i_writeppm_wiol($img, $IO) 
  or die "Cannot write testout/t104.ppm\n";
close($fh);

print "ok 1\n";

$IO = Imager::io_new_bufchain();
i_writeppm_wiol($img, $IO) or die "Cannot write to bufchain";
$data = Imager::io_slurp($IO);
print "ok 2\n";

$fh = openimage("testout/t104.ppm");
$IO = Imager::io_new_fd( fileno($fh) );
$cmpimg = i_readpnm_wiol($IO,-1) || die "Cannot read testout/t104.ppm\n";
close($fh);
print "ok 3\n";

print i_img_diff($img, $cmpimg) ? "not ok 4 # saved image different\n" : "ok 4\n";

my $rdata = slurp("testout/t104.ppm");
print "not " if $rdata ne $data;
print "ok 5\n";


# build a grayscale image
my $gimg = Imager::ImgRaw::new(150, 150, 1);
my $gray = i_color_new(128, 0, 0, 255);
my $dgray = i_color_new(64, 0, 0, 255);
my $white = i_color_new(255, 0, 0, 255);
i_box_filled($gimg, 20, 20, 130, 130, $gray);
i_box_filled($gimg, 40, 40, 110, 110, $dgray);
i_arc($gimg, 75, 75, 30, 0, 361, $white);

open FH, "> testout/t104_gray.pgm" or die "Cannot create testout/t104_gray.pgm: $!\n";
binmode FH;
my $IO = Imager::io_new_fd(fileno(FH));
i_writeppm_wiol($gimg, $IO) or print "not ";
print "ok 6\n";
close FH;

open FH, "< testout/t104_gray.pgm" or die "Cannot open testout/t104_gray.pgm: $!\n";
binmode FH;
$IO = Imager::io_new_fd(fileno(FH));
my $gcmpimg = i_readpnm_wiol($IO, -1) or print "not ";
print "ok 7\n";
i_img_diff($gimg, $gcmpimg) == 0 or print "not ";
print "ok 8\n";

my $ooim = Imager->new;
$ooim->read(file=>"testimg/simple.pbm") or print "not ";
print "ok 9\n";

check_gray(10, Imager::i_get_pixel($ooim->{IMG}, 0, 0), 255);
check_gray(11, Imager::i_get_pixel($ooim->{IMG}, 0, 1), 0);
check_gray(12, Imager::i_get_pixel($ooim->{IMG}, 1, 0), 0);
check_gray(13, Imager::i_get_pixel($ooim->{IMG}, 1, 1), 255);

sub openimage {
  my $fname = shift;
  local(*FH);
  open(FH, $fname) or die "Cannot open $fname: $!\n";
  binmode(FH);
  return *FH;
}

sub slurp {
  my $fh = openimage(shift);
  local $/;
  my $data = <$fh>;
  close($fh);
  return $data;
}

sub check_gray {
  my ($num, $c, $gray) = @_;

  my ($g) = $c->rgba;
  if ($g == $gray) {
    print "ok $num\n";
  }
  else {
    print "not ok $num # $g doesn't match $gray\n";
  }
}