t/t50basicoo.t

   1 #!perl -w
   2 ######################### We start with some black magic to print on failure.
   3
   4 # this used to do the check for the load of Imager, but I want to be able
   5 # to count tests, which means I need to load Imager first
   6 # since many of the early tests already do this, we don't really need to
   7
   8 use strict;
   9 use Imager;
  10 use IO::Seekable;
  11
  12 my $buggy_giflib_file = "buggy_giflib.txt";
  13
  14 -d "testout" or mkdir "testout";
  15
  16 Imager::init("log"=>"testout/t50basicoo.log");
  17
  18 # single image/file types
  19 my @types = qw( jpeg png raw pnm gif tiff bmp tga );
  20
  21 # multiple image/file formats
  22 my @mtypes = qw(tiff gif);
  23
  24 my %hsh=%Imager::formats;
  25
  26 my $test_num = 0;
  27 my $count;
  28 for my $type (@types) {
  29   $count += 31 if $hsh{$type};
  30 }
  31 for my $type (@mtypes) {
  32   $count += 7 if $hsh{$type};
  33 }
  34
  35 print "1..$count\n";
  36
  37 print "# avaliable formats:\n";
  38 for(keys %hsh) { print "# $_\n"; }
  39
  40 #print Dumper(\%hsh);
  41
  42 my $img = Imager->new();
  43
  44 my %files;
  45 @files{@types} = ({ file => "JPEG/testimg/209_yonge.jpg"  },
  46                   { file => "testimg/test.png"  },
  47                   { file => "testimg/test.raw", xsize=>150, ysize=>150, type=>'raw', interleave => 0},
  48                   { file => "testimg/penguin-base.ppm"  },
  49                   { file => "GIF/testimg/expected.gif"  },
  50                   { file => "TIFF/testimg/comp8.tif" },
  51                   { file => "testimg/winrgb24.bmp" },
  52                   { file => "testimg/test.tga" }, );
  53 my %writeopts =
  54   (
  55    gif=> { make_colors=>'webmap', translate=>'closest', gifquant=>'gen',
  56          gif_delay=>20 },
  57   );
  58
  59 for my $type (@types) {
  60   next unless $hsh{$type};
  61   print "# type $type\n";
  62   my %opts = %{$files{$type}};
  63   my @a = map { "$_=>${opts{$_}}" } keys %opts;
  64   print "#opening Format: $type, options: @a\n";
  65   ok($img->read( %opts ), "reading from file", $img);
  66   #or die "failed: ",$img->errstr,"\n";
  67
  68   my %mopts = %opts;
  69   delete $mopts{file};
  70
  71   # read from a file handle
  72   my $fh = IO::File->new($opts{file}, "r");
  73   if (ok($fh, "opening $opts{file}")) {
  74     binmode $fh;
  75     my $fhimg = Imager->new;
  76     if (ok($fhimg->read(fh=>$fh, %mopts), "read from fh")) {
  77       ok($fh->seek(0, SEEK_SET), "seek after read");
  78       if (ok($fhimg->read(fh=>$fh, %mopts, type=>$type), "read from fh")) {
  79         ok(Imager::i_img_diff($img->{IMG}, $fhimg->{IMG}) == 0,
  80            "image comparison after fh read");
  81       }
  82       else {
  83         skip("no image to compare");
  84       }
  85       ok($fh->seek(0, SEEK_SET), "seek after read");
  86     }
  87
  88     # read from a fd
  89     my $fdimg = Imager->new;
  90     if (ok($fdimg->read(fd=>fileno($fh), %mopts, type=>$type), "read from fd")) {
  91       ok(Imager::i_img_diff($img->{IMG}, $fdimg->{IMG}) == 0,
  92          "image comparistion after fd read");
  93     }
  94     else {
  95       skip("no image to compare");
  96     }
  97     ok($fh->seek(0, SEEK_SET), "seek after fd read");
  98     ok($fh->close, "close fh after reads");
  99   }
 100   else {
 101     skip("couldn't open the damn file: $!", 7);
 102   }
 103
 104   # read from a memory buffer
 105   open DATA, "< $opts{file}"
 106     or die "Cannot open $opts{file}: $!";
 107   binmode DATA;
 108   my $data = do { local $/; <DATA> };
 109   close DATA;
 110   my $bimg = Imager->new;
 111
 112   if (ok($bimg->read(data=>$data, %mopts, type=>$type), "read from buffer",
 113          $img)) {
 114     ok(Imager::i_img_diff($img->{IMG}, $bimg->{IMG}) == 0,
 115        "comparing buffer read image");
 116   }
 117   else {
 118     skip("nothing to compare");
 119   }
 120
 121   # read from callbacks, both with minimum and maximum reads
 122   my $buf = $data;
 123   my $seekpos = 0;
 124   my $reader_min =
 125     sub {
 126       my ($size, $maxread) = @_;
 127       my $out = substr($buf, $seekpos, $size);
 128       $seekpos += length $out;
 129       $out;
 130     };
 131   my $reader_max =
 132     sub {
 133       my ($size, $maxread) = @_;
 134       my $out = substr($buf, $seekpos, $maxread);
 135       $seekpos += length $out;
 136       $out;
 137     };
 138   my $seeker =
 139     sub {
 140       my ($offset, $whence) = @_;
 141       #print "io_seeker($offset, $whence)\n";
 142       if ($whence == SEEK_SET) {
 143         $seekpos = $offset;
 144       }
 145       elsif ($whence == SEEK_CUR) {
 146         $seekpos += $offset;
 147       }
 148       else { # SEEK_END
 149         $seekpos = length($buf) + $offset;
 150       }
 151       #print "-> $seekpos\n";
 152       $seekpos;
 153     };
 154   my $cbimg = Imager->new;
 155   ok($cbimg->read(callback=>$reader_min, seekcb=>$seeker, type=>$type, %mopts),
 156      "read from callback min", $cbimg);
 157   ok(Imager::i_img_diff($cbimg->{IMG}, $img->{IMG}) == 0,
 158      "comparing mincb image");
 159   $seekpos = 0;
 160   ok($cbimg->read(callback=>$reader_max, seekcb=>$seeker, type=>$type, %mopts),
 161      "read from callback max", $cbimg);
 162   ok(Imager::i_img_diff($cbimg->{IMG}, $img->{IMG}) == 0,
 163      "comparing maxcb image");
 164 }
 165
 166 for my $type (@types) {
 167   next unless $hsh{$type};
 168
 169   print "# write tests for $type\n";
 170   # test writes
 171   next unless $hsh{$type};
 172   my $file = "testout/t50out.$type";
 173   my $wimg = Imager->new;
 174   # if this doesn't work, we're so screwed up anyway
 175
 176   ok($wimg->read(file=>"testimg/penguin-base.ppm"),
 177      "cannot read base file", $wimg);
 178
 179   # first to a file
 180   print "# writing $type to a file\n";
 181   my %extraopts;
 182   %extraopts = %{$writeopts{$type}} if $writeopts{$type};
 183   ok($wimg->write(file=>$file, %extraopts),
 184      "writing $type to a file $file", $wimg);
 185
 186   print "# writing $type to a FH\n";
 187   # to a FH
 188   my $fh = IO::File->new($file, "w+")
 189     or die "Could not create $file: $!";
 190   binmode $fh;
 191   ok($wimg->write(fh=>$fh, %extraopts, type=>$type),
 192      "writing $type to a FH", $wimg);
 193   ok($fh->seek(0, SEEK_END) > 0,
 194      "seek after writing $type to a FH");
 195   ok(print($fh "SUFFIX\n"),
 196      "write to FH after writing $type");
 197   ok($fh->close, "closing FH after writing $type");
 198
 199   if (ok(open(DATA, "< $file"), "opening data source")) {
 200     binmode DATA;
 201     my $data = do { local $/; <DATA> };
 202     close DATA;
 203
 204     # writing to a buffer
 205     print "# writing $type to a buffer\n";
 206     my $buf = '';
 207     ok($wimg->write(data=>\$buf, %extraopts, type=>$type),
 208        "writing $type to a buffer", $wimg);
 209     $buf .= "SUFFIX\n";
 210     open DATA, "> testout/t50_buf.$type"
 211       or die "Cannot create $type buffer file: $!";
 212     binmode DATA;
 213     print DATA $buf;
 214     close DATA;
 215     ok($data eq $buf, "comparing file data to buffer");
 216
 217     $buf = '';
 218     my $seekpos = 0;
 219     my $did_close;
 220     my $writer =
 221       sub {
 222         my ($what) = @_;
 223         if ($seekpos > length $buf) {
 224           $buf .= "\0" x ($seekpos - length $buf);
 225         }
 226         substr($buf, $seekpos, length $what) = $what;
 227         $seekpos += length $what;
 228         $did_close = 0; # the close must be last
 229         1;
 230       };
 231     my $reader_min =
 232       sub {
 233         my ($size, $maxread) = @_;
 234         my $out = substr($buf, $seekpos, $size);
 235         $seekpos += length $out;
 236         $out;
 237       };
 238     my $reader_max =
 239       sub {
 240         my ($size, $maxread) = @_;
 241         my $out = substr($buf, $seekpos, $maxread);
 242         $seekpos += length $out;
 243         $out;
 244       };
 245     use IO::Seekable;
 246     my $seeker =
 247       sub {
 248         my ($offset, $whence) = @_;
 249         #print "io_seeker($offset, $whence)\n";
 250         if ($whence == SEEK_SET) {
 251           $seekpos = $offset;
 252         }
 253         elsif ($whence == SEEK_CUR) {
 254           $seekpos += $offset;
 255         }
 256         else { # SEEK_END
 257           $seekpos = length($buf) + $offset;
 258         }
 259         #print "-> $seekpos\n";
 260         $seekpos;
 261       };
 262
 263     my $closer = sub { ++$did_close; };
 264
 265     print "# writing $type via callbacks (mb=1)\n";
 266     ok($wimg->write(writecb=>$writer, seekcb=>$seeker, closecb=>$closer,
 267                     readcb=>$reader_min,
 268                     %extraopts, type=>$type, maxbuffer=>1),
 269        "writing $type to callback (mb=1)", $wimg);
 270
 271     ok($did_close, "checking closecb called");
 272     $buf .= "SUFFIX\n";
 273     ok($data eq $buf, "comparing callback output to file data");
 274     print "# writing $type via callbacks (no mb)\n";
 275     $buf = '';
 276     $did_close = 0;
 277     $seekpos = 0;
 278     # we don't use the closecb here - used to make sure we don't get
 279     # a warning/error on an attempt to call an undef close sub
 280     ok($wimg->write(writecb=>$writer, seekcb=>$seeker, readcb=>$reader_min,
 281                     %extraopts, type=>$type),
 282        "writing $type to callback (no mb)", $wimg);
 283     $buf .= "SUFFIX\n";
 284     ok($data eq $buf, "comparing callback output to file data");
 285   }
 286   else {
 287     skip("couldn't open data source", 7);
 288   }
 289 }
 290
 291 my $img2 =  $img->crop(width=>50, height=>50);
 292 $img2 -> write(file=> 'testout/t50.ppm', type=>'pnm');
 293
 294 undef($img);
 295
 296 # multi image/file tests
 297 print "# multi-image write tests\n";
 298 for my $type (@mtypes) {
 299   next unless $hsh{$type};
 300   print "# $type\n";
 301
 302   my $file = "testout/t50out.$type";
 303   my $wimg = Imager->new;
 304
 305   # if this doesn't work, we're so screwed up anyway
 306   ok($wimg->read(file=>"testout/t50out.$type"),
 307      "reading base file", $wimg);
 308
 309   ok(my $wimg2 = $wimg->copy, "copying base image", $wimg);
 310   ok($wimg2->flip(dir=>'h'), "flipping base image", $wimg2);
 311
 312   my @out = ($wimg, $wimg2);
 313   my %extraopts;
 314   %extraopts = %{$writeopts{$type}} if $writeopts{$type};
 315   ok(Imager->write_multi({ file=>"testout/t50_multi.$type", %extraopts },
 316                          @out),
 317      "writing multiple to a file", "Imager");
 318
 319   # make sure we get the same back
 320   my @images = Imager->read_multi(file=>"testout/t50_multi.$type");
 321   if (ok(@images == @out, "checking read image count")) {
 322     for my $i (0 .. $#out) {
 323       my $diff = Imager::i_img_diff($out[$i]{IMG}, $images[$i]{IMG});
 324       print "# diff $diff\n";
 325       ok($diff == 0, "comparing image $i");
 326     }
 327   }
 328   else {
 329     skip("wrong number of images read", 2);
 330   }
 331 }
 332
 333
 334 Imager::malloc_state();
 335
 336 #print "ok 2\n";
 337
 338 sub ok {
 339   my ($ok, $msg, $img, $why, $skipcount) = @_;
 340
 341   ++$test_num;
 342   if ($ok) {
 343     print "ok $test_num # $msg\n";
 344     Imager::i_log_entry("ok $test_num # $msg\n", 0);
 345   }
 346   else {
 347     my $err;
 348     $err = $img->errstr if $img;
 349     # VMS (if we ever support it) wants the whole line in one print
 350     my $line = "not ok $test_num # line ".(caller)[2].": $msg";
 351     $line .= ": $err" if $err;
 352     print $line, "\n";
 353     Imager::i_log_entry($line."\n", 0);
 354   }
 355   skip($why, $skipcount) if defined $why;
 356   $ok;
 357 }
 358
 359 sub skip {
 360   my ($why, $skipcount) = @_;
 361
 362   $skipcount ||= 1;
 363   for (1.. $skipcount) {
 364     ++$test_num;
 365     print "ok $test_num # skipped $why\n";
 366   }
 367 }