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