#!perl -w
use strict;
use Test::More tests => 252;
# for SEEK_SET etc, Fcntl doesn't provide these in 5.005_03
use IO::Seekable;
BEGIN { use_ok(Imager => ':all') };
-d "testout" or mkdir "testout";
$| = 1;
Imager->open_log(log => "testout/t07iolayer.log");
undef($/);
# start by testing io buffer
my $data="P2\n2 2\n255\n 255 0\n0 255\n";
my $IO = Imager::io_new_buffer($data);
my $im = Imager::i_readpnm_wiol($IO, -1);
ok($im, "read from data io");
open(FH, ">testout/t07.ppm") or die $!;
binmode(FH);
my $fd = fileno(FH);
my $IO2 = Imager::io_new_fd( $fd );
Imager::i_writeppm_wiol($im, $IO2);
close(FH);
undef($im);
open(FH, "<testimg/penguin-base.ppm");
binmode(FH);
$data = <FH>;
close(FH);
my $IO3 = Imager::IO->new_buffer($data);
#undef($data);
$im = Imager::i_readpnm_wiol($IO3, -1);
ok($im, "read from buffer, for compare");
undef $IO3;
open(FH, "<testimg/penguin-base.ppm") or die $!;
binmode(FH);
$fd = fileno(FH);
my $IO4 = Imager::IO->new_fd( $fd );
my $im2 = Imager::i_readpnm_wiol($IO4, -1);
close(FH);
undef($IO4);
ok($im2, "read from file, for compare");
is(i_img_diff($im, $im2), 0, "compare images");
undef($im2);
my $IO5 = Imager::io_new_bufchain();
Imager::i_writeppm_wiol($im, $IO5);
my $data2 = Imager::io_slurp($IO5);
undef($IO5);
ok($data2, "check we got data from bufchain");
my $IO6 = Imager::io_new_buffer($data2);
my $im3 = Imager::i_readpnm_wiol($IO6, -1);
is(Imager::i_img_diff($im, $im3), 0, "read from buffer");
my $work = $data;
my $pos = 0;
sub io_reader {
my ($size, $maxread) = @_;
my $out = substr($work, $pos, $maxread);
$pos += length $out;
$out;
}
sub io_reader2 {
my ($size, $maxread) = @_;
my $out = substr($work, $pos, $maxread);
$pos += length $out;
$out;
}
my $IO7 = Imager::IO->new_cb(undef, \&io_reader, undef, undef);
ok($IO7, "making readcb object");
my $im4 = Imager::i_readpnm_wiol($IO7, -1);
ok($im4, "read from cb");
ok(Imager::i_img_diff($im, $im4) == 0, "read from cb image match");
$pos = 0;
$IO7 = Imager::io_new_cb(undef, \&io_reader2, undef, undef);
ok($IO7, "making short readcb object");
my $im5 = Imager::i_readpnm_wiol($IO7, -1);
ok($im4, "read from cb2");
is(Imager::i_img_diff($im, $im5), 0, "read from cb2 image match");
sub io_writer {
my ($what) = @_;
substr($work, $pos, $pos+length $what) = $what;
$pos += length $what;
1;
}
my $did_close;
sub io_close {
++$did_close;
}
my $IO8 = Imager::io_new_cb(\&io_writer, undef, undef, \&io_close);
ok($IO8, "making writecb object");
$pos = 0;
$work = '';
ok(Imager::i_writeppm_wiol($im, $IO8), "write to cb");
# I originally compared this to $data, but that doesn't include the
# Imager header
is($work, $data2, "write image match");
ok($did_close, "did close");
# with a short buffer, no closer
my $IO9 = Imager::io_new_cb(\&io_writer, undef, undef, undef, 1);
ok($IO9, "making short writecb object");
$pos = 0;
$work = '';
ok(Imager::i_writeppm_wiol($im, $IO9), "write to short cb");
is($work, $data2, "short write image match");
{
my $buf_data = "Test data";
my $io9 = Imager::io_new_buffer($buf_data);
is(ref $io9, "Imager::IO", "check class");
my $work;
is($io9->raw_read($work, 4), 4, "read 4 from buffer object");
is($work, "Test", "check data read");
is($io9->raw_read($work, 5), 5, "read the rest");
is($work, " data", "check data read");
is($io9->raw_seek(5, SEEK_SET), 5, "seek");
is($io9->raw_read($work, 5), 4, "short read");
is($work, "data", "check data read");
is($io9->raw_seek(-1, SEEK_CUR), 8, "seek relative");
is($io9->raw_seek(-5, SEEK_END), 4, "seek relative to end");
is($io9->raw_seek(-10, SEEK_CUR), -1, "seek failure");
undef $io9;
}
{
my $io = Imager::IO->new_bufchain();
is(ref $io, "Imager::IO", "check class");
is($io->raw_write("testdata"), 8, "check write");
is($io->raw_seek(-8, SEEK_CUR), 0, "seek relative");
my $work;
is($io->raw_read($work, 8), 8, "check read");
is($work, "testdata", "check data read");
is($io->raw_seek(-3, SEEK_END), 5, "seek end relative");
is($io->raw_read($work, 5), 3, "short read");
is($work, "ata", "check read data");
is($io->raw_seek(4, SEEK_SET), 4, "absolute seek to write some");
is($io->raw_write("testdata"), 8, "write");
is($io->raw_seek(0, SEEK_CUR), 12, "check size");
$io->raw_close();
# grab the data
my $data = Imager::io_slurp($io);
is($data, "testtestdata", "check we have the right data");
}
{ # callback failure checks
my $fail_io = Imager::io_new_cb(\&fail_write, \&fail_read, \&fail_seek, undef, 1);
# scalar context
my $buffer;
my $read_result = $fail_io->raw_read($buffer, 10);
is($read_result, undef, "read failure undef in scalar context");
my @read_result = $fail_io->raw_read($buffer, 10);
is(@read_result, 0, "empty list in list context");
$read_result = $fail_io->raw_read2(10);
is($read_result, undef, "raw_read2 failure (scalar)");
@read_result = $fail_io->raw_read2(10);
is(@read_result, 0, "raw_read2 failure (list)");
my $write_result = $fail_io->raw_write("test");
is($write_result, -1, "failed write");
my $seek_result = $fail_io->raw_seek(-1, SEEK_SET);
is($seek_result, -1, "failed seek");
}
{ # callback success checks
my $good_io = Imager::io_new_cb(\&good_write, \&good_read, \&good_seek, undef, 1);
# scalar context
my $buffer;
my $read_result = $good_io->raw_read($buffer, 10);
is($read_result, 8, "read success (scalar)");
is($buffer, "testdata", "check data");
my @read_result = $good_io->raw_read($buffer, 10);
is_deeply(\@read_result, [ 8 ], "read success (list)");
is($buffer, "testdata", "check data");
$read_result = $good_io->raw_read2(10);
is($read_result, "testdata", "read2 success (scalar)");
@read_result = $good_io->raw_read2(10);
is_deeply(\@read_result, [ "testdata" ], "read2 success (list)");
}
{ # end of file
my $eof_io = Imager::io_new_cb(undef, \&eof_read, undef, undef, 1);
my $buffer;
my $read_result = $eof_io->raw_read($buffer, 10);
is($read_result, 0, "read eof (scalar)");
is($buffer, '', "check data");
my @read_result = $eof_io->raw_read($buffer, 10);
is_deeply(\@read_result, [ 0 ], "read eof (list)");
is($buffer, '', "check data");
}
{ # no callbacks
my $none_io = Imager::io_new_cb(undef, undef, undef, undef, 0);
is($none_io->raw_write("test"), -1, "write with no writecb should fail");
my $buffer;
is($none_io->raw_read($buffer, 10), undef, "read with no readcb should fail");
is($none_io->raw_seek(0, SEEK_SET), -1, "seek with no seekcb should fail");
}
SKIP:
{ # make sure we croak when trying to write a string with characters over 0xff
# the write callback shouldn't get called
skip("no native UTF8 support in this version of perl", 2)
unless $] >= 5.006;
my $io = Imager::io_new_cb(\&good_write, undef, undef, 1);
my $data = chr(0x100);
is(ord $data, 0x100, "make sure we got what we expected");
my $result =
eval {
$io->raw_write($data);
};
ok($@, "should have croaked")
and print "# $@\n";
}
{ # 0.52 left some debug code in a path that wasn't tested, make sure
# that path is tested
# http://rt.cpan.org/Ticket/Display.html?id=20705
my $io = Imager::io_new_cb
(
sub {
print "# write $_[0]\n";
1
},
sub {
print "# read $_[0], $_[1]\n";
"x" x $_[1]
},
sub { print "# seek\n"; 0 },
sub { print "# close\n"; 1 });
my $buffer;
is($io->raw_read($buffer, 10), 10, "read 10");
is($buffer, "xxxxxxxxxx", "read value");
ok($io->raw_write("foo"), "write");
is($io->raw_close, 0, "close");
}
SKIP:
{ # fd_seek write failure
-c "/dev/full"
or skip("No /dev/full", 3);
open my $fh, "> /dev/full"
or skip("Can't open /dev/full: $!", 3);
my $io = Imager::io_new_fd(fileno($fh));
ok($io, "make fd io for /dev/full");
Imager::i_clear_error();
is($io->raw_write("test"), -1, "fail to write");
my $msg = Imager->_error_as_msg;
like($msg, qr/^write\(\) failure: /, "check error message");
print "# $msg\n";
# /dev/full succeeds on seek on Linux
undef $io;
}
SKIP:
{ # fd_seek seek failure
my $seekfail = "testout/t07seekfail.dat";
open my $fh, "> $seekfail"
or skip("Can't open $seekfail: $!", 3);
my $io = Imager::io_new_fd(fileno($fh));
ok($io, "make fd io for $seekfail");
Imager::i_clear_error();
is($io->raw_seek(-1, SEEK_SET), -1, "shouldn't be able to seek to -1");
my $msg = Imager->_error_as_msg;
like($msg, qr/^lseek\(\) failure: /, "check error message");
print "# $msg\n";
undef $io;
close $fh;
unlink $seekfail;
}
SKIP:
{ # fd_seek read failure
open my $fh, "> testout/t07writeonly.txt"
or skip("Can't open testout/t07writeonly.txt: $!", 3);
my $io = Imager::io_new_fd(fileno($fh));
ok($io, "make fd io for write-only");
Imager::i_clear_error();
my $buf;
is($io->raw_read($buf, 10), undef,
"file open for write shouldn't be readable");
my $msg = Imager->_error_as_msg;
like($msg, qr/^read\(\) failure: /, "check error message");
print "# $msg\n";
undef $io;
}
SKIP:
{ # fd_seek eof
open my $fh, "> testout/t07readeof.txt"
or skip("Can't open testout/t07readeof.txt: $!", 5);
binmode $fh;
print $fh "test";
close $fh;
open my $fhr, "< testout/t07readeof.txt",
or skip("Can't open testout/t07readeof.txt: $!", 5);
my $io = Imager::io_new_fd(fileno($fhr));
ok($io, "make fd io for read eof");
Imager::i_clear_error();
my $buf;
is($io->raw_read($buf, 10), 4,
"10 byte read on 4 byte file should return 4");
my $msg = Imager->_error_as_msg;
is($msg, "", "should be no error message")
or print STDERR "# read(4) message is: $msg\n";
Imager::i_clear_error();
$buf = '';
is($io->raw_read($buf, 10), 0,
"10 byte read at end of 4 byte file should return 0 (eof)");
$msg = Imager->_error_as_msg;
is($msg, "", "should be no error message")
or print STDERR "# read(4), eof message is: $msg\n";
undef $io;
}
{ # buffered I/O
my $data="P2\n2 2\n255\n 255 0\n0 255\n";
my $io = Imager::io_new_buffer($data);
my $c = $io->getc();
is($c, ord "P", "getc");
my $peekc = $io->peekc();
is($peekc, ord "2", "peekc");
my $peekn = $io->peekn(2);
is($peekn, "2\n", "peekn");
$c = $io->getc();
is($c, ord "2", "getc after peekc/peekn");
is($io->seek(0, SEEK_SET), "0", "seek");
is($io->getc, ord "P", "check we got back to the start");
}
{ # test closecb result is propagated
my $success_cb = sub { 1 };
my $failure_cb = sub { 0 };
{
my $io = Imager::io_new_cb(undef, $success_cb, undef, $success_cb);
is($io->close(), 0, "test successful close");
}
{
my $io = Imager::io_new_cb(undef, $success_cb, undef, $failure_cb);
is($io->close(), -1, "test failed close");
}
}
{ # buffered coverage/function tests
# some data to play with
my $base = pack "C*", map rand(26) + ord("a"), 0 .. 20_001;
{ # buffered accessors
my $io = Imager::io_new_buffer($base);
ok($io->set_buffered(0), "set unbuffered");
ok(!$io->is_buffered, "verify unbuffered");
ok($io->set_buffered(1), "set buffered");
ok($io->is_buffered, "verify buffered");
}
{ # initial i_io_read(), buffered
my $pos = 0;
my $ops = "";
my $work = $base;
my $read = sub {
my ($size) = @_;
my $req_size = $size;
if ($pos + $size > length $work) {
$size = length($work) - $pos;
}
my $result = substr($work, $pos, $size);
$pos += $size;
$ops .= "R$req_size>$size;";
print "# read $req_size>$size\n";
return $result;
};
my $write = sub {
my ($data) = @_;
substr($work, $pos, length($data), $data);
return 1;
};
{
my $io = Imager::io_new_cb(undef, $read, undef, undef);
my $buf;
is($io->read($buf, 1000), 1000, "read initial 1000");
is($buf, substr($base, 0, 1000), "check data read");
is($ops, "R8192>8192;", "check read op happened to buffer size");
undef $buf;
is($io->read($buf, 1001), 1001, "read another 1001");
is($buf, substr($base, 1000, 1001), "check data read");
is($ops, "R8192>8192;", "should be no further reads");
undef $buf;
is($io->read($buf, 40_000), length($base) - 2001,
"read the rest in one chunk");
is($buf, substr($base, 2001), "check the data read");
my $buffer_left = 8192 - 2001;
my $after_buffer = length($base) - 8192;
is($ops, "R8192>8192;R".(40_000 - $buffer_left).">$after_buffer;R21999>0;",
"check we tried to read the remainder");
}
{
# read after write errors
my $io = Imager::io_new_cb($write, $read, undef, undef);
is($io->write("test"), 4, "write 4 bytes, io in write mode");
is($io->read2(10), undef, "read should fail");
is($io->peekn(10), undef, "peekn should fail");
is($io->getc(), -1, "getc should fail");
is($io->peekc(), -1, "peekc should fail");
}
}
{
my $io = Imager::io_new_buffer($base);
print "# buffer fill check\n";
ok($io, "make memory io");
my $buf;
is($io->read($buf, 4096), 4096, "read 4k");
is($buf, substr($base, 0, 4096), "check data is correct");
# peek a bit
undef $buf;
is($io->peekn(5120), substr($base, 4096, 5120),
"peekn() 5120, which should exceed the buffer, and only read the left overs");
}
{ # initial peekn
my $io = Imager::io_new_buffer($base);
is($io->peekn(10), substr($base, 0, 10),
"make sure initial peekn() is sane");
is($io->read2(10), substr($base, 0, 10),
"and that reading 10 gets the expected data");
}
{ # oversize peekn
my $io = Imager::io_new_buffer($base);
is($io->peekn(10_000), substr($base, 0, 8192),
"peekn() larger than buffer should return buffer-size bytes");
}
{ # small peekn then large peekn with a small I/O back end
# this might happen when reading from a socket
my $work = $base;
my $pos = 0;
my $ops = '';
my $reader = sub {
my ($size) = @_;
my $req_size = $size;
# do small reads, to trigger a possible bug
if ($size > 10) {
$size = 10;
}
if ($pos + $size > length $work) {
$size = length($work) - $pos;
}
my $result = substr($work, $pos, $size);
$pos += $size;
$ops .= "R$req_size>$size;";
print "# read $req_size>$size\n";
return $result;
};
my $io = Imager::io_new_cb(undef, $reader, undef, undef);
ok($io, "small reader io");
is($io->peekn(25), substr($base, 0, 25), "peek 25");
is($ops, "R8192>10;R8182>10;R8172>10;",
"check we got the raw calls expected");
is($io->peekn(65), substr($base, 0, 65), "peek 65");
is($ops, "R8192>10;R8182>10;R8172>10;R8162>10;R8152>10;R8142>10;R8132>10;",
"check we got the raw calls expected");
}
for my $buffered (1, 0) { # peekn followed by errors
my $buffered_desc = $buffered ? "buffered" : "unbuffered";
my $read = 0;
my $base = "abcdef";
my $pos = 0;
my $reader = sub {
my $size = shift;
my $req_size = $size;
if ($pos + $size > length $base) {
$size = length($base) - $pos;
}
# error instead of eof
if ($size == 0) {
print "# read $req_size>error\n";
return;
}
my $result = substr($base, $pos, $size);
$pos += $size;
print "# read $req_size>$size\n";
return $result;
};
my $io = Imager::io_new_cb(undef, $reader, undef, undef);
ok($io, "make $buffered_desc cb with error after 6 bytes");
is($io->peekn(5), "abcde",
"peekn until just before error ($buffered_desc)");
is($io->peekn(6), "abcdef", "peekn until error ($buffered_desc)");
is($io->peekn(7), "abcdef", "peekn past error ($buffered_desc)");
ok(!$io->error,
"should be no error indicator, since data buffered ($buffered_desc)");
ok(!$io->eof,
"should be no eof indicator, since data buffered ($buffered_desc)");
# consume it
is($io->read2(6), "abcdef", "consume the buffer ($buffered_desc)");
is($io->peekn(10), undef,
"peekn should get an error indicator ($buffered_desc)");
ok($io->error, "should be an error state ($buffered_desc)");
ok(!$io->eof, "but not eof ($buffered_desc)");
}
{ # peekn on an empty file
my $io = Imager::io_new_buffer("");
is($io->peekn(10), "", "peekn on empty source");
ok($io->eof, "should be in eof state");
ok(!$io->error, "but not error");
}
{ # peekn on error source
my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
is($io->peekn(10), undef, "peekn on empty source");
ok($io->error, "should be in error state");
ok(!$io->eof, "but not eof");
}
{ # peekn on short source
my $io = Imager::io_new_buffer("abcdef");
is($io->peekn(4), "abcd", "peekn 4 on 6 byte source");
is($io->peekn(10), "abcdef", "followed by peekn 10 on 6 byte source");
is($io->peekn(10), "abcdef", "and again, now eof is set");
}
{ # peekn(0)
Imager::i_clear_error();
my $io = Imager::io_new_buffer("abcdef");
is($io->peekn(0), undef, "peekn 0 on 6 byte source");
my $msg = Imager->_error_as_msg;
is($msg, "peekn size must be positive");
}
{ # getc through a whole file (buffered)
my $io = Imager::io_new_buffer($base);
my $out = '';
while ((my $c = $io->getc()) != -1) {
$out .= chr($c);
}
is($out, $base, "getc should return the file byte by byte (buffered)");
is($io->getc, -1, "another getc after eof should fail too");
ok($io->eof, "should be marked eof");
ok(!$io->error, "shouldn't be marked in error");
}
{ # getc through a whole file (unbuffered)
my $io = Imager::io_new_buffer($base);
$io->set_buffered(0);
my $out = '';
while ((my $c = $io->getc()) != -1) {
$out .= chr($c);
}
is($out, $base, "getc should return the file byte by byte (unbuffered)");
is($io->getc, -1, "another getc after eof should fail too");
ok($io->eof, "should be marked eof");
ok(!$io->error, "shouldn't be marked in error");
}
{ # buffered getc with an error
my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
is($io->getc, -1, "buffered getc error");
ok($io->error, "io marked in error");
ok(!$io->eof, "but not eof");
}
{ # unbuffered getc with an error
my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
$io->set_buffered(0);
is($io->getc, -1, "unbuffered getc error");
ok($io->error, "io marked in error");
ok(!$io->eof, "but not eof");
}
{ # initial peekc - buffered
my $io = Imager::io_new_buffer($base);
my $c = $io->peekc;
is($c, ord($base), "buffered peekc matches");
is($io->peekc, $c, "duplicate peekc matchess");
}
{ # initial peekc - unbuffered
my $io = Imager::io_new_buffer($base);
$io->set_buffered(0);
my $c = $io->peekc;
is($c, ord($base), "unbuffered peekc matches");
is($io->peekc, $c, "duplicate peekc matchess");
}
{ # initial peekc eof - buffered
my $io = Imager::io_new_cb(undef, sub { "" }, undef, undef);
my $c = $io->peekc;
is($c, -1, "buffered eof peekc is -1");
is($io->peekc, $c, "duplicate matches");
ok($io->eof, "io marked eof");
ok(!$io->error, "but not error");
}
{ # initial peekc eof - unbuffered
my $io = Imager::io_new_cb(undef, sub { "" }, undef, undef);
$io->set_buffered(0);
my $c = $io->peekc;
is($c, -1, "buffered eof peekc is -1");
is($io->peekc, $c, "duplicate matches");
ok($io->eof, "io marked eof");
ok(!$io->error, "but not error");
}
{ # initial peekc error - buffered
my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
my $c = $io->peekc;
is($c, -1, "buffered error peekc is -1");
is($io->peekc, $c, "duplicate matches");
ok($io->error, "io marked error");
ok(!$io->eof, "but not eof");
}
{ # initial peekc error - unbuffered
my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
$io->set_buffered(0);
my $c = $io->peekc;
is($c, -1, "unbuffered error peekc is -1");
is($io->peekc, $c, "duplicate matches");
ok($io->error, "io marked error");
ok(!$io->eof, "but not eof");
}
{ # initial putc
my $io = Imager::io_new_bufchain();
is($io->putc(ord "A"), ord "A", "initial putc buffered");
is($io->close, 0, "close it");
is(Imager::io_slurp($io), "A", "check it was written");
}
{ # initial putc - unbuffered
my $io = Imager::io_new_bufchain();
$io->set_buffered(0);
is($io->putc(ord "A"), ord "A", "initial putc unbuffered");
is($io->close, 0, "close it");
is(Imager::io_slurp($io), "A", "check it was written");
}
{ # putc unbuffered with error
my $io = Imager::io_new_cb(undef, undef, undef, undef);
$io->set_buffered(0);
is($io->putc(ord "A"), -1, "initial putc unbuffered error");
ok($io->error, "io in error");
is($io->putc(ord "B"), -1, "still in error");
}
{ # writes while in read state
my $io = Imager::io_new_cb(sub { 1 }, sub { return "AA" }, undef, undef);
is($io->getc, ord "A", "read to setup read buffer");
is($io->putc(ord "B"), -1, "putc should fail");
is($io->write("test"), -1, "write should fail");
}
{ # buffered putc error handling
# tests the check for error state in the buffered putc code
my $io = Imager::io_new_cb(undef, undef, undef, undef);
$io->putc(ord "A");
ok(!$io->flush, "flush should fail");
ok($io->error, "should be in error state");
is($io->putc(ord "B"), -1, "check for error");
}
{ # buffered putc flush error handling
# test handling of flush failure and of the error state resulting
# from that
my $io = Imager::io_new_cb(undef, undef, undef, undef);
my $i = 0;
while (++$i < 100_000 && $io->putc(ord "A") == ord "A") {
# until we have to flush and fail doing do
}
is($i, 8193, "should have failed on 8193rd byte");
ok($io->error, "should be in error state");
is($io->putc(ord "B"), -1, "next putc should fail");
}
{ # buffered write flush error handling
# test handling of flush failure and of the error state resulting
# from that
my $io = Imager::io_new_cb(undef, undef, undef, undef);
my $i = 0;
while (++$i < 100_000 && $io->write("A") == 1) {
# until we have to flush and fail doing do
}
is($i, 8193, "should have failed on 8193rd byte");
ok($io->error, "should be in error state");
is($io->write("B"), -1, "next write should fail");
}
{ # buffered read error
my $io = Imager::io_new_cb(undef, undef, undef, undef);
is($io->read2(10), undef, "initial read returning error");
ok($io->error, "should be in error state");
}
{ # unbuffered read error
my $io = Imager::io_new_cb(undef, undef, undef, undef);
$io->set_buffered(0);
is($io->read2(10), undef, "initial read returning error");
ok($io->error, "should be in error state");
}
{ # unbuffered write error
my $count = 0;
my $io = Imager::io_new_cb(sub { return $count++; }, undef, undef, undef);
$io->set_buffered(0);
is($io->write("A"), -1, "unbuffered write failure");
ok($io->error, "should be in error state");
is($io->write("BC"), -1, "should still fail");
}
{ # buffered write + large write
my $io = Imager::io_new_bufchain();
is($io->write(substr($base, 0, 4096)), 4096,
"should be buffered");
is($io->write(substr($base, 4096)), length($base) - 4096,
"large write, should fill buffer and fall back to direct write");
is($io->close, 0, "close it");
is(Imager::io_slurp($io), $base, "make sure the data is correct");
}
{ # initial large write with failure
# tests error handling for the case where we bypass the buffer
# when the write is too large to fit
my $io = Imager::io_new_cb(undef, undef, undef, undef);
ok($io->flush, "flush with nothing buffered should succeed");
is($io->write($base), -1, "large write failure");
ok($io->error, "should be in error state");
is($io->close, -1, "should fail to close");
}
{ # write that causes a flush then fills the buffer a bit
my $io = Imager::io_new_bufchain();
is($io->write(substr($base, 0, 6000)), 6000, "fill the buffer a bit");
is($io->write(substr($base, 6000, 4000)), 4000,
"cause it to flush and then fill some more");
is($io->write(substr($base, 10000)), length($base)-10000,
"write out the rest of our test data");
is($io->close, 0, "close the stream");
is(Imager::io_slurp($io), $base, "make sure the data is right");
}
{ # failure on flush on close
my $io = Imager::io_new_cb(undef, undef, undef, undef);
is($io->putc(ord "A"), ord "A", "something in the buffer");
ok(!$io->error, "should be no error yet");
is($io->close, -1, "close should failure due to flush error");
}
{ # seek failure
my $io = Imager::io_new_cb(undef, undef, undef, undef);
is($io->seek(0, SEEK_SET), -1, "seek failure");
}
{ # read a little and seek
my $io = Imager::io_new_buffer($base);
is($io->getc, ord $base, "read one");
is($io->getc, ord substr($base, 1, 1), "read another");
is($io->seek(-1, SEEK_CUR), 1, "seek relative back to origin+1");
is($io->getc, ord substr($base, 1, 1), "read another again");
}
{ # seek with failing flush
my $io = Imager::io_new_cb(undef, undef, undef, undef);
is($io->putc(ord "A"), ord "A", "write one");
ok(!$io->error, "not in error mode (yet)");
is($io->seek(0, SEEK_SET), -1, "seek failure due to flush");
ok($io->error, "in error mode");
}
{ # gets()
my $data = "test1\ntest2\ntest3";
my $io = Imager::io_new_buffer($data);
is($io->gets(6), "test1\n", "gets(6)");
is($io->gets(5), "test2", "gets(5) (short for the line)");
is($io->gets(10), "\n", "gets(10) the rest of the line (the newline)");
is($io->gets(), "test3", "gets(default) unterminated line");
}
{ # more gets()
my $data = "test1\ntest2\ntest3";
my $io = Imager::io_new_buffer($data);
is($io->gets(6, ord("1")), "test1", "gets(6) (line terminator 1)");
is($io->gets(6, ord("2")), "\ntest2", "gets(6) (line terminator 2)");
is($io->gets(6, ord("3")), "\ntest3", "gets(6) (line terminator 3)");
is($io->getc, -1, "should be eof");
}
}
{ # based on discussion on IRC, user was attempting to write a TIFF
# image file with only a write callback, but TIFF requires seek and
# read callbacks when writing.
# https://rt.cpan.org/Ticket/Display.html?id=76782
my $cb = Imager::io_new_cb(undef, undef, undef, undef);
{
Imager::i_clear_error();
my $data;
is($cb->read($data, 10), undef, "default read callback should fail");
is(Imager->_error_as_msg(), "read callback called but no readcb supplied",
"check error message");
}
{
Imager::i_clear_error();
is($cb->raw_write("abc"), -1, "default write callback should fail");
is(Imager->_error_as_msg(), "write callback called but no writecb supplied",
"check error message");
}
{
Imager::i_clear_error();
is($cb->seek(0, 0), -1, "default seek callback should fail");
is(Imager->_error_as_msg(), "seek callback called but no seekcb supplied",
"check error message");
}
}
Imager->close_log;
unless ($ENV{IMAGER_KEEP_FILES}) {
unlink "testout/t07.ppm", "testout/t07iolayer.log";
}
sub eof_read {
my ($max_len) = @_;
return '';
}
sub good_read {
my ($max_len) = @_;
my $data = "testdata";
length $data <= $max_len or substr($data, $max_len) = '';
print "# good_read ($max_len) => $data\n";
return $data;
}
sub fail_write {
return;
}
sub fail_read {
return;
}
sub fail_seek {
return -1;
}