#!perl -w
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 @cleanup = "t50basicoo.log";
-d "testout" or mkdir "testout";
Imager->open_log(log => "testout/t50basicoo.log");
# single image/file types
my @types = qw( jpeg png raw pnm gif tiff bmp tga );
# multiple image/file formats
my @mtypes = qw(tiff gif);
my %hsh=%Imager::formats;
print "# avaliable formats:\n";
for(keys %hsh) { print "# $_\n"; }
#print Dumper(\%hsh);
my $img = Imager->new();
my %files;
@files{@types} = ({ file => "JPEG/testimg/209_yonge.jpg" },
{ file => "testimg/test.png" },
{ file => "testimg/test.raw", xsize=>150, ysize=>150, type=>'raw', interleave => 0},
{ file => "testimg/penguin-base.ppm" },
{ file => "GIF/testimg/expected.gif" },
{ file => "TIFF/testimg/comp8.tif" },
{ file => "testimg/winrgb24.bmp" },
{ file => "testimg/test.tga" }, );
my %writeopts =
(
gif=> { make_colors=>'webmap', translate=>'closest', gifquant=>'gen',
gif_delay=>20 },
);
for my $type (@types) {
next unless $hsh{$type};
print "# type $type\n";
my %opts = %{$files{$type}};
my @a = map { "$_=>${opts{$_}}" } keys %opts;
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(seek($fh, 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");
}
ok(seek($fh, 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->close, "close fh after reads")
or diag_skip_errno("$type: close after read failed");
}
# 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");
}
# 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;
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");
}
}
}
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(seek($fh, 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);
# multi image/file tests
print "# multi-image write tests\n";
for my $type (@mtypes) {
next unless $hsh{$type};
print "# $type\n";
my $file = "testout/t50out.$type";
my $wimg = Imager->new;
# if this doesn't work, we're so screwed up anyway
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");
}
}
}
}
done_testing();
Imager::malloc_state();
Imager->close_log;
END {
unless ($ENV{IMAGER_KEEP_FILES}) {
unlink map "testout/$_", @cleanup;
rmdir "testout";
}
}
sub diag_skip_image($$) {
my ($img, $msg) = @_;
diag "$msg: " . $img->errstr;
skip $msg, 1;
}
sub diag_skip_errno($) {
my ($msg) = @_;
diag "$msg: $!";
skip $msg, 1;
}