t/200-file/400-basic.t

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