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