t50basicoo.t

#!perl -w
######################### We start with some black magic to print on failure.

# this used to do the check for the load of Imager, but I want to be able 
# to count tests, which means I need to load Imager first
# since many of the early tests already do this, we don't really need to

use strict;
use Imager;
use IO::Seekable;

my $buggy_giflib_file = "buggy_giflib.txt";

Imager::init("log"=>"testout/t50basicoo.log");

# single image/file types
my @types = qw( jpeg png raw ppm gif tiff bmp tga );

# multiple image/file formats
my @mtypes = qw(tiff gif);

my %hsh=%Imager::formats;

my $test_num = 0;
my $count;
for my $type (@types) {
  $count += 31 if $hsh{$type};
}
for my $type (@mtypes) {
  $count += 7 if $hsh{$type};
}

print "1..$count\n";

print "# avaliable formats:\n";
for(keys %hsh) { print "# $_\n"; }

#print Dumper(\%hsh);

my $img = Imager->new();

my %files;
@files{@types} = ({ file => "testout/t101.jpg"  },
		  { file => "testout/t102.png"  },
		  { file => "testout/t103.raw", xsize=>150, ysize=>150, type=>'raw', interleave => 0},
		  { file => "testout/t104.ppm"  },
		  { file => "testout/t105.gif"  },
		  { file => "testout/t106.tiff" },
                  { file => "testout/t107_24bit.bmp" },
                  { file => "testout/t108_24bit.tga" }, );
my %writeopts =
  (
   gif=> { make_colors=>'webmap', translate=>'closest', gifquant=>'gen',
         gif_delay=>20 },
  );

for my $type (@types) {
  next unless $hsh{$type};
  print "# type $type\n";
  my %opts = %{$files{$type}};
  my @a = map { "$_=>${opts{$_}}" } keys %opts;
  print "#opening Format: $type, options: @a\n";
  ok($img->read( %opts ), "reading from file", $img);
  #or die "failed: ",$img->errstr,"\n";

  my %mopts = %opts;
  delete $mopts{file};

  # read from a file handle
  my $fh = IO::File->new($opts{file}, "r");
  if (ok($fh, "opening $opts{file}")) {
    binmode $fh;
    my $fhimg = Imager->new;
    if (ok($fhimg->read(fh=>$fh, %mopts), "read from fh")) {
      ok($fh->seek(0, SEEK_SET), "seek after read");
      if (ok($fhimg->read(fh=>$fh, %mopts, type=>$type), "read from fh")) {
	ok(Imager::i_img_diff($img->{IMG}, $fhimg->{IMG}) == 0,
	   "image comparison after fh read");
      }
      else {
	skip("no image to compare");
      }
      ok($fh->seek(0, SEEK_SET), "seek after read");
    }

    # read from a fd
    my $fdimg = Imager->new;
    if (ok($fdimg->read(fd=>fileno($fh), %mopts, type=>$type), "read from fd")) {
      ok(Imager::i_img_diff($img->{IMG}, $fdimg->{IMG}) == 0,
         "image comparistion after fd read");
    }
    else {
      skip("no image to compare");
    }
    ok($fh->seek(0, SEEK_SET), "seek after fd read");
    ok($fh->close, "close fh after reads");
  }
  else {
    skip("couldn't open the damn file: $!", 7);
  }

  if ($type ne 'gif' || Imager::i_giflib_version() >= 4) {
    # read from a memory buffer
    open DATA, "< $opts{file}"
      or die "Cannot open $opts{file}: $!";
    binmode DATA;
    my $data = do { local $/; <DATA> };
    close DATA;
    my $bimg = Imager->new;
    
    if (ok($bimg->read(data=>$data, %mopts, type=>$type), "read from buffer", 
           $img)) {
      ok(Imager::i_img_diff($img->{IMG}, $bimg->{IMG}) == 0,
         "comparing buffer read image");
    }
    else {
      skip("nothing to compare");
    }
    
    # read from callbacks, both with minimum and maximum reads
    my $buf = $data;
    my $seekpos = 0;
    my $reader_min = 
      sub { 
        my ($size, $maxread) = @_;
        my $out = substr($buf, $seekpos, $size);
        $seekpos += length $out;
        $out;
      };
    my $reader_max = 
      sub { 
        my ($size, $maxread) = @_;
        my $out = substr($buf, $seekpos, $maxread);
        $seekpos += length $out;
        $out;
      };
    my $seeker =
      sub {
        my ($offset, $whence) = @_;
        #print "io_seeker($offset, $whence)\n";
        if ($whence == SEEK_SET) {
          $seekpos = $offset;
        }
        elsif ($whence == SEEK_CUR) {
          $seekpos += $offset;
        }
        else { # SEEK_END
          $seekpos = length($buf) + $offset;
        }
        #print "-> $seekpos\n";
        $seekpos;
      };
    my $cbimg = Imager->new;
    ok($cbimg->read(callback=>$reader_min, seekcb=>$seeker, type=>$type, %mopts),
       "read from callback min", $cbimg);
    ok(Imager::i_img_diff($cbimg->{IMG}, $img->{IMG}) == 0,
       "comparing mincb image");
    $seekpos = 0;
    ok($cbimg->read(callback=>$reader_max, seekcb=>$seeker, type=>$type, %mopts),
       "read from callback max", $cbimg);
    ok(Imager::i_img_diff($cbimg->{IMG}, $img->{IMG}) == 0,
       "comparing maxcb image");
  }
  else {
    skip("giflib < 4 doesn't support callbacks", 6);
  }
}

for my $type (@types) {
  next unless $hsh{$type};

  print "# write tests for $type\n";
  # test writes
  next unless $hsh{$type};
  my $file = "testout/t50out.$type";
  my $wimg = Imager->new;
  # if this doesn't work, we're so screwed up anyway
  
  ok($wimg->read(file=>"testout/t104.ppm"),
     "cannot read base file", $wimg);

  # first to a file
  print "# writing $type to a file\n";
  my %extraopts;
  %extraopts = %{$writeopts{$type}} if $writeopts{$type};
  ok($wimg->write(file=>$file, %extraopts),
     "writing $type to a file $file", $wimg);

  print "# writing $type to a FH\n";
  # to a FH
  my $fh = IO::File->new($file, "w+")
    or die "Could not create $file: $!";
  binmode $fh;
  ok($wimg->write(fh=>$fh, %extraopts, type=>$type),
     "writing $type to a FH", $wimg);
  ok($fh->seek(0, SEEK_END) > 0,
     "seek after writing $type to a FH");
  ok(print($fh "SUFFIX\n"),
     "write to FH after writing $type");
  ok($fh->close, "closing FH after writing $type");

  if ($type ne 'gif' || 
      (Imager::i_giflib_version() >= 4 && !-e $buggy_giflib_file)) {
    if (ok(open(DATA, "< $file"), "opening data source")) {
      binmode DATA;
      my $data = do { local $/; <DATA> };
      close DATA;

      # writing to a buffer
      print "# writing $type to a buffer\n";
      my $buf = '';
      ok($wimg->write(data=>\$buf, %extraopts, type=>$type),
         "writing $type to a buffer", $wimg);
      $buf .= "SUFFIX\n";
      open DATA, "> testout/t50_buf.$type"
        or die "Cannot create $type buffer file: $!";
      binmode DATA;
      print DATA $buf;
      close DATA;
      ok($data eq $buf, "comparing file data to buffer");

      $buf = '';
      my $seekpos = 0;
      my $did_close;
      my $writer = 
        sub {
          my ($what) = @_;
          if ($seekpos > length $buf) {
            $buf .= "\0" x ($seekpos - length $buf);
          }
          substr($buf, $seekpos, length $what) = $what;
          $seekpos += length $what;
          $did_close = 0; # the close must be last
          1;
        };
      my $reader_min = 
        sub { 
          my ($size, $maxread) = @_;
          my $out = substr($buf, $seekpos, $size);
          $seekpos += length $out;
          $out;
        };
      my $reader_max = 
        sub { 
          my ($size, $maxread) = @_;
          my $out = substr($buf, $seekpos, $maxread);
          $seekpos += length $out;
          $out;
        };
      use IO::Seekable;
      my $seeker =
        sub {
          my ($offset, $whence) = @_;
          #print "io_seeker($offset, $whence)\n";
          if ($whence == SEEK_SET) {
            $seekpos = $offset;
          }
          elsif ($whence == SEEK_CUR) {
            $seekpos += $offset;
          }
          else { # SEEK_END
            $seekpos = length($buf) + $offset;
          }
          #print "-> $seekpos\n";
          $seekpos;
        };
      
      my $closer = sub { ++$did_close; };
      
      print "# writing $type via callbacks (mb=1)\n";
      ok($wimg->write(writecb=>$writer, seekcb=>$seeker, closecb=>$closer,
                   readcb=>$reader_min,
                   %extraopts, type=>$type, maxbuffer=>1),
         "writing $type to callback (mb=1)", $wimg);

      ok($did_close, "checking closecb called");
      $buf .= "SUFFIX\n";
      ok($data eq $buf, "comparing callback output to file data");
      print "# writing $type via callbacks (no mb)\n";
      $buf = '';
      $did_close = 0;
      $seekpos = 0;
      # we don't use the closecb here - used to make sure we don't get 
      # a warning/error on an attempt to call an undef close sub
      ok($wimg->write(writecb=>$writer, seekcb=>$seeker, readcb=>$reader_min,
                   %extraopts, type=>$type),
         "writing $type to callback (no mb)", $wimg);
      $buf .= "SUFFIX\n";
      ok($data eq $buf, "comparing callback output to file data");
    }
    else {
      skip("couldn't open data source", 7);
    }
  }
  else {
    if (-e $buggy_giflib_file) {
      skip("see $buggy_giflib_file", 8);
    }
    else {
      skip("giflib < 4 doesn't support callbacks", 8);
    }
  }
}

my $img2 =  $img->crop(width=>50, height=>50);
$img2 -> write(file=> 'testout/t50.ppm', type=>'pnm');

undef($img);

# multi image/file tests
print "# multi-image write tests\n";
for my $type (@mtypes) {
  next unless $hsh{$type};
  print "# $type\n";

  my $file = "testout/t50out.$type";
  my $wimg = Imager->new;

  # if this doesn't work, we're so screwed up anyway
  ok($wimg->read(file=>"testout/t50out.$type"),
     "reading base file", $wimg);

  ok(my $wimg2 = $wimg->copy, "copying base image", $wimg);
  ok($wimg2->flip(dir=>'h'), "flipping base image", $wimg2);

  my @out = ($wimg, $wimg2);
  my %extraopts;
  %extraopts = %{$writeopts{$type}} if $writeopts{$type};
  ok(Imager->write_multi({ file=>"testout/t50_multi.$type", %extraopts },
                         @out),
     "writing multiple to a file", "Imager");

  # make sure we get the same back
  my @images = Imager->read_multi(file=>"testout/t50_multi.$type");
  if (ok(@images == @out, "checking read image count")) {
    for my $i (0 .. $#out) {
      my $diff = Imager::i_img_diff($out[$i]{IMG}, $images[$i]{IMG});
      print "# diff $diff\n";
      ok($diff == 0, "comparing image $i");
    }
  }
  else {
    skip("wrong number of images read", 2);
  }
}


Imager::malloc_state();

#print "ok 2\n";

sub ok {
  my ($ok, $msg, $img, $why, $skipcount) = @_;

  ++$test_num;
  if ($ok) {
    print "ok $test_num # $msg\n";
    Imager::i_log_entry("ok $test_num # $msg\n", 0);
  }
  else {
    my $err;
    $err = $img->errstr if $img;
    # VMS (if we ever support it) wants the whole line in one print
    my $line = "not ok $test_num # line ".(caller)[2].": $msg";
    $line .= ": $err" if $err;
    print $line, "\n";
    Imager::i_log_entry($line."\n", 0);
  }
  skip($why, $skipcount) if defined $why;
  $ok;
}

sub skip {
  my ($why, $skipcount) = @_;

  $skipcount ||= 1;
  for (1.. $skipcount) {
    ++$test_num;
    print "ok $test_num # skipped $why\n";
  }
}