#!perl -w
-######################### We start with some black magic to print on failure.
-# this used to do the check for the load of Imager, but I want to be able
-# to count tests, which means I need to load Imager first
-# since many of the early tests already do this, we don't really need to
use strict;
use Imager;
use IO::Seekable;
+use Test::More;
+use File::Spec;
+use Imager::Test qw(is_image);
+
+sub diag_skip_image($$);
+sub diag_skip_errno($);
my $buggy_giflib_file = "buggy_giflib.txt";
+my @cleanup = "t50basicoo.log";
+
-d "testout" or mkdir "testout";
-Imager::init("log"=>"testout/t50basicoo.log");
+Imager->open_log(log => "testout/t50basicoo.log");
# single image/file types
my @types = qw( jpeg png raw pnm gif tiff bmp tga );
my %hsh=%Imager::formats;
-my $test_num = 0;
-my $count;
-for my $type (@types) {
- $count += 31 if $hsh{$type};
-}
-for my $type (@mtypes) {
- $count += 7 if $hsh{$type};
-}
-
-print "1..$count\n";
-
print "# avaliable formats:\n";
for(keys %hsh) { print "# $_\n"; }
print "# type $type\n";
my %opts = %{$files{$type}};
my @a = map { "$_=>${opts{$_}}" } keys %opts;
- print "#opening Format: $type, options: @a\n";
- ok($img->read( %opts ), "reading from file", $img);
- #or die "failed: ",$img->errstr,"\n";
-
- my %mopts = %opts;
- delete $mopts{file};
-
- # read from a file handle
- my $fh = IO::File->new($opts{file}, "r");
- if (ok($fh, "opening $opts{file}")) {
- binmode $fh;
- my $fhimg = Imager->new;
- if (ok($fhimg->read(fh=>$fh, %mopts), "read from fh")) {
- ok($fh->seek(0, SEEK_SET), "seek after read");
- if (ok($fhimg->read(fh=>$fh, %mopts, type=>$type), "read from fh")) {
- ok(Imager::i_img_diff($img->{IMG}, $fhimg->{IMG}) == 0,
- "image comparison after fh read");
+
+ SKIP:
+ {
+ print "#opening Format: $type, options: @a\n";
+ ok($img->read( %opts ), "$type: reading from file")
+ or diag_skip_image($img, "$type: reading base file failed");
+
+ my %mopts = %opts;
+ delete $mopts{file};
+
+ SKIP:
+ {
+ my $fh;
+ ok(open($fh, "<", $opts{file}), "$type: open $opts{file}")
+ or diag_skip_errno("$type: Cannot open $opts{file}");
+
+ binmode $fh;
+ my $fhimg = Imager->new;
+ ok($fhimg->read(fh=>$fh, %mopts), "$type: read from fh")
+ or diag_skip_image($fhimg, "$type: couldn't read from fh");
+ ok($fh->seek(0, SEEK_SET), "$type: seek after read")
+ or diag_skip_errno("$type: couldn't seek back to start");
+ SKIP:
+ {
+ ok($fhimg->read(fh=>$fh, %mopts, type=>$type), "$type: read from fh after seek")
+ or diag_skip_image($fhimg, "$type: failed to read after seek");
+ is_image($img, $fhimg,
+ "$type: image comparison after fh read after seek");
}
- else {
- skip("no image to compare");
+ ok($fh->seek(0, SEEK_SET), "$type: seek after read prep to read from fd")
+ or diag_skip_errno("$type: couldn't seek");
+
+ SKIP:
+ {
+ # read from a fd
+ my $fdimg = Imager->new;
+ ok($fdimg->read(fd=>fileno($fh), %mopts, type=>$type), "read from fd")
+ or diag_skip_image($fdimg, "$type: couldn't read from fd");
+ is_image($img, $fdimg, "image comparistion after fd read");
}
- ok($fh->seek(0, SEEK_SET), "seek after read");
+ ok($fh->close, "close fh after reads")
+ or diag_skip_errno("$type: close after read failed");
}
- # read from a fd
- my $fdimg = Imager->new;
- if (ok($fdimg->read(fd=>fileno($fh), %mopts, type=>$type), "read from fd")) {
- ok(Imager::i_img_diff($img->{IMG}, $fdimg->{IMG}) == 0,
- "image comparistion after fd read");
- }
- else {
- skip("no image to compare");
+ # read from a memory buffer
+ open my $dfh, "<", $opts{file}
+ or die "Cannot open $opts{file}: $!";
+ binmode $dfh;
+ my $data = do { local $/; <$dfh> };
+ close $dfh;
+ my $bimg = Imager->new;
+
+ SKIP:
+ {
+ ok($bimg->read(data=>$data, %mopts, type=>$type), "$type: read from buffer")
+ or diag_skip_image($bimg, "$type: read from buffer failed");
+ is_image($img, $bimg, "comparing buffer read image");
}
- ok($fh->seek(0, SEEK_SET), "seek after fd read");
- ok($fh->close, "close fh after reads");
- }
- else {
- skip("couldn't open the damn file: $!", 7);
- }
-
- # read from a memory buffer
- open DATA, "< $opts{file}"
- or die "Cannot open $opts{file}: $!";
- binmode DATA;
- my $data = do { local $/; <DATA> };
- close DATA;
- my $bimg = Imager->new;
-
- if (ok($bimg->read(data=>$data, %mopts, type=>$type), "read from buffer",
- $img)) {
- ok(Imager::i_img_diff($img->{IMG}, $bimg->{IMG}) == 0,
- "comparing buffer read image");
- }
- else {
- skip("nothing to compare");
- }
-
- # read from callbacks, both with minimum and maximum reads
- my $buf = $data;
- my $seekpos = 0;
- my $reader_min =
- sub {
- my ($size, $maxread) = @_;
- my $out = substr($buf, $seekpos, $size);
- $seekpos += length $out;
- $out;
- };
- my $reader_max =
- sub {
- my ($size, $maxread) = @_;
- my $out = substr($buf, $seekpos, $maxread);
- $seekpos += length $out;
- $out;
- };
- my $seeker =
- sub {
- my ($offset, $whence) = @_;
- #print "io_seeker($offset, $whence)\n";
- if ($whence == SEEK_SET) {
- $seekpos = $offset;
- }
- elsif ($whence == SEEK_CUR) {
- $seekpos += $offset;
- }
- else { # SEEK_END
- $seekpos = length($buf) + $offset;
- }
- #print "-> $seekpos\n";
- $seekpos;
- };
- my $cbimg = Imager->new;
- ok($cbimg->read(callback=>$reader_min, seekcb=>$seeker, type=>$type, %mopts),
- "read from callback min", $cbimg);
- ok(Imager::i_img_diff($cbimg->{IMG}, $img->{IMG}) == 0,
- "comparing mincb image");
- $seekpos = 0;
- ok($cbimg->read(callback=>$reader_max, seekcb=>$seeker, type=>$type, %mopts),
- "read from callback max", $cbimg);
- ok(Imager::i_img_diff($cbimg->{IMG}, $img->{IMG}) == 0,
- "comparing maxcb image");
-}
-for my $type (@types) {
- next unless $hsh{$type};
-
- print "# write tests for $type\n";
- # test writes
- next unless $hsh{$type};
- my $file = "testout/t50out.$type";
- my $wimg = Imager->new;
- # if this doesn't work, we're so screwed up anyway
-
- ok($wimg->read(file=>"testimg/penguin-base.ppm"),
- "cannot read base file", $wimg);
-
- # first to a file
- print "# writing $type to a file\n";
- my %extraopts;
- %extraopts = %{$writeopts{$type}} if $writeopts{$type};
- ok($wimg->write(file=>$file, %extraopts),
- "writing $type to a file $file", $wimg);
-
- print "# writing $type to a FH\n";
- # to a FH
- my $fh = IO::File->new($file, "w+")
- or die "Could not create $file: $!";
- binmode $fh;
- ok($wimg->write(fh=>$fh, %extraopts, type=>$type),
- "writing $type to a FH", $wimg);
- ok($fh->seek(0, SEEK_END) > 0,
- "seek after writing $type to a FH");
- ok(print($fh "SUFFIX\n"),
- "write to FH after writing $type");
- ok($fh->close, "closing FH after writing $type");
-
- if (ok(open(DATA, "< $file"), "opening data source")) {
- binmode DATA;
- my $data = do { local $/; <DATA> };
- close DATA;
-
- # writing to a buffer
- print "# writing $type to a buffer\n";
- my $buf = '';
- ok($wimg->write(data=>\$buf, %extraopts, type=>$type),
- "writing $type to a buffer", $wimg);
- $buf .= "SUFFIX\n";
- open DATA, "> testout/t50_buf.$type"
- or die "Cannot create $type buffer file: $!";
- binmode DATA;
- print DATA $buf;
- close DATA;
- ok($data eq $buf, "comparing file data to buffer");
-
- $buf = '';
+ # read from callbacks, both with minimum and maximum reads
+ my $buf = $data;
my $seekpos = 0;
- my $did_close;
- my $writer =
+ my $reader_min =
sub {
- my ($what) = @_;
- if ($seekpos > length $buf) {
- $buf .= "\0" x ($seekpos - length $buf);
- }
- substr($buf, $seekpos, length $what) = $what;
- $seekpos += length $what;
- $did_close = 0; # the close must be last
- 1;
- };
- my $reader_min =
- sub {
my ($size, $maxread) = @_;
my $out = substr($buf, $seekpos, $size);
$seekpos += length $out;
$seekpos += length $out;
$out;
};
- use IO::Seekable;
my $seeker =
sub {
my ($offset, $whence) = @_;
#print "-> $seekpos\n";
$seekpos;
};
-
- my $closer = sub { ++$did_close; };
-
- print "# writing $type via callbacks (mb=1)\n";
- ok($wimg->write(writecb=>$writer, seekcb=>$seeker, closecb=>$closer,
- readcb=>$reader_min,
- %extraopts, type=>$type, maxbuffer=>1),
- "writing $type to callback (mb=1)", $wimg);
-
- ok($did_close, "checking closecb called");
- $buf .= "SUFFIX\n";
- ok($data eq $buf, "comparing callback output to file data");
- print "# writing $type via callbacks (no mb)\n";
- $buf = '';
- $did_close = 0;
- $seekpos = 0;
- # we don't use the closecb here - used to make sure we don't get
- # a warning/error on an attempt to call an undef close sub
- ok($wimg->write(writecb=>$writer, seekcb=>$seeker, readcb=>$reader_min,
- %extraopts, type=>$type),
- "writing $type to callback (no mb)", $wimg);
- $buf .= "SUFFIX\n";
- ok($data eq $buf, "comparing callback output to file data");
- }
- else {
- skip("couldn't open data source", 7);
+ my $cbimg = Imager->new;
+ SKIP:
+ {
+ ok($cbimg->read(callback=>$reader_min, seekcb=>$seeker, type=>$type, %mopts),
+ "$type: read from callback min")
+ or diag_skip_image("$type: read from callback min", $cbimg);
+ is_image($cbimg, $img, "$type: comparing mincb image");
+ }
+ SKIP:
+ {
+ $seekpos = 0;
+ ok($cbimg->read(callback=>$reader_max, seekcb=>$seeker, type=>$type, %mopts),
+ "$type: read from callback max")
+ or diag_skip_image("$type: read from callback max", $cbimg);
+ is_image($cbimg, $img, "$type: comparing maxcb image");
+ }
}
}
-my $img2 = $img->crop(width=>50, height=>50);
-$img2 -> write(file=> 'testout/t50.ppm', type=>'pnm');
+for my $type (@types) {
+ next unless $hsh{$type};
+
+ print "# write tests for $type\n";
+ # test writes
+ next unless $hsh{$type};
+ my $file = "testout/t50out.$type";
+ push @cleanup, "t50out.$type";
+ my $wimg = Imager->new;
+
+ SKIP:
+ {
+ ok($wimg->read(file=>"testimg/penguin-base.ppm"),
+ "$type: cannot read base file")
+ or diag_skip_image($wimg, "$type: reading base file");
+
+ # first to a file
+ print "# writing $type to a file\n";
+ my %extraopts;
+ %extraopts = %{$writeopts{$type}} if $writeopts{$type};
+ ok($wimg->write(file=>$file, %extraopts),
+ "writing $type to a file $file");
+
+ my $fh_data;
+ SKIP:
+ {
+ print "# writing $type to a FH\n";
+ # to a FH
+ ok(open(my $fh, "+>", $file), "$type: create FH test file")
+ or diag_skip_errno("$type: Could not create $file");
+ binmode $fh;
+ ok($wimg->write(fh=>$fh, %extraopts, type=>$type),
+ "$type: writing to a FH")
+ or diag_skip_image($wimg, "$type: write to fh");
+ ok($fh->seek(0, SEEK_END),
+ "$type: seek after writing to a FH")
+ or diag_skip_errno("$type: seek to end failed");
+ ok(print($fh "SUFFIX\n"), "write to FH after writing $type");
+ ok($fh->close, "closing FH after writing $type");
+
+ my $ifh;
+ ok(open($ifh, "< $file"), "opening data source")
+ or diag_skip_errno("$type: couldn't re-open file");
+ binmode $ifh;
+ $fh_data = do { local $/; <$ifh> };
+ close $ifh;
+
+ # writing to a buffer
+ print "# writing $type to a buffer\n";
+ my $buf = '';
+ ok($wimg->write(data=>\$buf, %extraopts, type=>$type),
+ "$type: writing to a buffer")
+ or diag_skip_image($wimg, "$type: writing to buffer failed");
+ $buf .= "SUFFIX\n";
+ if (open my $wfh, ">", "testout/t50_buf.$type") {
+ binmode $wfh;
+ print $wfh $buf;
+ close $wfh;
+ }
+ push @cleanup, "t50_buf.$type";
+ is($fh_data, $buf, "comparing file data to buffer");
+ }
+
+ SKIP:
+ {
+ my $buf = '';
+ my $seekpos = 0;
+ my $did_close;
+ my $writer =
+ sub {
+ my ($what) = @_;
+ if ($seekpos > length $buf) {
+ $buf .= "\0" x ($seekpos - length $buf);
+ }
+ substr($buf, $seekpos, length $what) = $what;
+ $seekpos += length $what;
+ $did_close = 0; # the close must be last
+ 1;
+ };
+ my $reader_min =
+ sub {
+ my ($size, $maxread) = @_;
+ my $out = substr($buf, $seekpos, $size);
+ $seekpos += length $out;
+ $out;
+ };
+ my $reader_max =
+ sub {
+ my ($size, $maxread) = @_;
+ my $out = substr($buf, $seekpos, $maxread);
+ $seekpos += length $out;
+ $out;
+ };
+ use IO::Seekable;
+ my $seeker =
+ sub {
+ my ($offset, $whence) = @_;
+ #print "io_seeker($offset, $whence)\n";
+ if ($whence == SEEK_SET) {
+ $seekpos = $offset;
+ }
+ elsif ($whence == SEEK_CUR) {
+ $seekpos += $offset;
+ }
+ else { # SEEK_END
+ $seekpos = length($buf) + $offset;
+ }
+ #print "-> $seekpos\n";
+ $seekpos;
+ };
+
+ my $closer = sub { ++$did_close; };
+
+ print "# writing $type via callbacks (mb=1)\n";
+ ok($wimg->write(writecb=>$writer, seekcb=>$seeker, closecb=>$closer,
+ readcb=>$reader_min,
+ %extraopts, type=>$type, maxbuffer=>1),
+ "$type: writing to callback (mb=1)")
+ or diag_skip_image($wimg, "$type: writing to callback failed");
+
+ ok($did_close, "checking closecb called");
+ $buf .= "SUFFIX\n";
+ SKIP:
+ {
+ defined $fh_data
+ or skip "Couldn't read original file", 1;
+ is($fh_data, $buf, "comparing callback output to file data");
+ }
+ print "# writing $type via callbacks (no mb)\n";
+ $buf = '';
+ $did_close = 0;
+ $seekpos = 0;
+ # we don't use the closecb here - used to make sure we don't get
+ # a warning/error on an attempt to call an undef close sub
+ ok($wimg->write(writecb=>$writer, seekcb=>$seeker, readcb=>$reader_min,
+ %extraopts, type=>$type),
+ "writing $type to callback (no mb)")
+ or diag_skip_image($wimg, "$type: failed writing to callback (no mb)");
+ $buf .= "SUFFIX\n";
+ SKIP:
+ {
+ defined $fh_data
+ or skip "Couldn't read original file", 1;
+ is($fh_data, $buf, "comparing callback output to file data");
+ }
+ }
+ }
+}
undef($img);
my $wimg = Imager->new;
# if this doesn't work, we're so screwed up anyway
- ok($wimg->read(file=>"testout/t50out.$type"),
- "reading base file", $wimg);
-
- ok(my $wimg2 = $wimg->copy, "copying base image", $wimg);
- ok($wimg2->flip(dir=>'h'), "flipping base image", $wimg2);
-
- my @out = ($wimg, $wimg2);
- my %extraopts;
- %extraopts = %{$writeopts{$type}} if $writeopts{$type};
- ok(Imager->write_multi({ file=>"testout/t50_multi.$type", %extraopts },
- @out),
- "writing multiple to a file", "Imager");
-
- # make sure we get the same back
- my @images = Imager->read_multi(file=>"testout/t50_multi.$type");
- if (ok(@images == @out, "checking read image count")) {
- for my $i (0 .. $#out) {
- my $diff = Imager::i_img_diff($out[$i]{IMG}, $images[$i]{IMG});
- print "# diff $diff\n";
- ok($diff == 0, "comparing image $i");
+ SKIP:
+ {
+ ok($wimg->read(file=>"testout/t50out.$type"),
+ "reading base file")
+ or diag_skip_image($wimg, "$type-multi: reading base file failed");
+
+ ok(my $wimg2 = $wimg->copy, "copying base image")
+ or diag_skip_image($wimg, "$type-multi: cannot copy");
+ ok($wimg2->flip(dir=>'h'), "flipping base image")
+ or diag_skip_image($wimg, "$type-multi: cannot flip");
+
+ my @out = ($wimg, $wimg2);
+ my %extraopts;
+ %extraopts = %{$writeopts{$type}} if $writeopts{$type};
+ push @cleanup, "t50_multi.$type";
+ ok(Imager->write_multi({ file=>"testout/t50_multi.$type", %extraopts },
+ @out),
+ "$type-multi: writing multiple to a file")
+ or diag_skip_image(Imager => "$type-multi: failed writing multiple to a file");
+
+ # make sure we get the same back
+ my @images = Imager->read_multi(file=>"testout/t50_multi.$type");
+ if (ok(@images == @out, "$type-multi: checking read image count")) {
+ for my $i (0 .. $#out) {
+ is_image($out[$i], $images[$i],
+ "$type-multi: comparing image $i");
+ }
}
}
- else {
- skip("wrong number of images read", 2);
- }
}
+done_testing();
Imager::malloc_state();
-#print "ok 2\n";
-
-sub ok {
- my ($ok, $msg, $img, $why, $skipcount) = @_;
+Imager->close_log;
- ++$test_num;
- if ($ok) {
- print "ok $test_num # $msg\n";
- Imager::i_log_entry("ok $test_num # $msg\n", 0);
+END {
+ unless ($ENV{IMAGER_KEEP_FILES}) {
+ unlink map "testout/$_", @cleanup;
+ rmdir "testout";
}
- else {
- my $err;
- $err = $img->errstr if $img;
- # VMS (if we ever support it) wants the whole line in one print
- my $line = "not ok $test_num # line ".(caller)[2].": $msg";
- $line .= ": $err" if $err;
- print $line, "\n";
- Imager::i_log_entry($line."\n", 0);
- }
- skip($why, $skipcount) if defined $why;
- $ok;
}
-sub skip {
- my ($why, $skipcount) = @_;
+sub diag_skip_image($$) {
+ my ($img, $msg) = @_;
- $skipcount ||= 1;
- for (1.. $skipcount) {
- ++$test_num;
- print "ok $test_num # skipped $why\n";
- }
+ diag "$msg: " . $img->errstr;
+ skip $msg, 1;
+}
+
+sub diag_skip_errno($) {
+ my ($msg) = @_;
+
+ diag "$msg: $!";
+ skip $msg, 1;
}
projects / imager.git / commitdiff