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