t/t07iolayer.t

   1 #!perl -w
   2 use strict;
   3 use Test::More tests => 252;
   4 # for SEEK_SET etc, Fcntl doesn't provide these in 5.005_03
   5 use IO::Seekable;
   6
   7 BEGIN { use_ok(Imager => ':all') };
   8
   9 -d "testout" or mkdir "testout";
  10
  11 $| = 1;
  12
  13 Imager->open_log(log => "testout/t07iolayer.log");
  14
  15 undef($/);
  16 # start by testing io buffer
  17
  18 my $data="P2\n2 2\n255\n 255 0\n0 255\n";
  19 my $IO = Imager::io_new_buffer($data);
  20 my $im = Imager::i_readpnm_wiol($IO, -1);
  21
  22 ok($im, "read from data io");
  23
  24 open(FH, ">testout/t07.ppm") or die $!;
  25 binmode(FH);
  26 my $fd = fileno(FH);
  27 my $IO2 = Imager::io_new_fd( $fd );
  28 Imager::i_writeppm_wiol($im, $IO2);
  29 close(FH);
  30 undef($im);
  31
  32 open(FH, "<testimg/penguin-base.ppm");
  33 binmode(FH);
  34 $data = <FH>;
  35 close(FH);
  36 my $IO3 = Imager::IO->new_buffer($data);
  37 #undef($data);
  38 $im = Imager::i_readpnm_wiol($IO3, -1);
  39
  40 ok($im, "read from buffer, for compare");
  41 undef $IO3;
  42
  43 open(FH, "<testimg/penguin-base.ppm") or die $!;
  44 binmode(FH);
  45 $fd = fileno(FH);
  46 my $IO4 = Imager::IO->new_fd( $fd );
  47 my $im2 = Imager::i_readpnm_wiol($IO4, -1);
  48 close(FH);
  49 undef($IO4);
  50
  51 ok($im2, "read from file, for compare");
  52
  53 is(i_img_diff($im, $im2), 0, "compare images");
  54 undef($im2);
  55
  56 my $IO5 = Imager::io_new_bufchain();
  57 Imager::i_writeppm_wiol($im, $IO5);
  58 my $data2 = Imager::io_slurp($IO5);
  59 undef($IO5);
  60
  61 ok($data2, "check we got data from bufchain");
  62
  63 my $IO6 = Imager::io_new_buffer($data2);
  64 my $im3 = Imager::i_readpnm_wiol($IO6, -1);
  65
  66 is(Imager::i_img_diff($im, $im3), 0, "read from buffer");
  67
  68 my $work = $data;
  69 my $pos = 0;
  70 sub io_reader {
  71   my ($size, $maxread) = @_;
  72   my $out = substr($work, $pos, $maxread);
  73   $pos += length $out;
  74   $out;
  75 }
  76 sub io_reader2 {
  77   my ($size, $maxread) = @_;
  78   my $out = substr($work, $pos, $maxread);
  79   $pos += length $out;
  80   $out;
  81 }
  82 my $IO7 = Imager::IO->new_cb(undef, \&io_reader, undef, undef);
  83 ok($IO7, "making readcb object");
  84 my $im4 = Imager::i_readpnm_wiol($IO7, -1);
  85 ok($im4, "read from cb");
  86 ok(Imager::i_img_diff($im, $im4) == 0, "read from cb image match");
  87
  88 $pos = 0;
  89 $IO7 = Imager::io_new_cb(undef, \&io_reader2, undef, undef);
  90 ok($IO7, "making short readcb object");
  91 my $im5 = Imager::i_readpnm_wiol($IO7, -1);
  92 ok($im4, "read from cb2");
  93 is(Imager::i_img_diff($im, $im5), 0, "read from cb2 image match");
  94
  95 sub io_writer {
  96   my ($what) = @_;
  97   substr($work, $pos, $pos+length $what) = $what;
  98   $pos += length $what;
  99
 100   1;
 101 }
 102
 103 my $did_close;
 104 sub io_close {
 105   ++$did_close;
 106 }
 107
 108 my $IO8 = Imager::io_new_cb(\&io_writer, undef, undef, \&io_close);
 109 ok($IO8, "making writecb object");
 110 $pos = 0;
 111 $work = '';
 112 ok(Imager::i_writeppm_wiol($im, $IO8), "write to cb");
 113 # I originally compared this to $data, but that doesn't include the
 114 # Imager header
 115 is($work, $data2, "write image match");
 116 ok($did_close, "did close");
 117
 118 # with a short buffer, no closer
 119 my $IO9 = Imager::io_new_cb(\&io_writer, undef, undef, undef, 1);
 120 ok($IO9, "making short writecb object");
 121 $pos = 0;
 122 $work = '';
 123 ok(Imager::i_writeppm_wiol($im, $IO9), "write to short cb");
 124 is($work, $data2, "short write image match");
 125
 126 {
 127   my $buf_data = "Test data";
 128   my $io9 = Imager::io_new_buffer($buf_data);
 129   is(ref $io9, "Imager::IO", "check class");
 130   my $work;
 131   is($io9->raw_read($work, 4), 4, "read 4 from buffer object");
 132   is($work, "Test", "check data read");
 133   is($io9->raw_read($work, 5), 5, "read the rest");
 134   is($work, " data", "check data read");
 135   is($io9->raw_seek(5, SEEK_SET), 5, "seek");
 136   is($io9->raw_read($work, 5), 4, "short read");
 137   is($work, "data", "check data read");
 138   is($io9->raw_seek(-1, SEEK_CUR), 8, "seek relative");
 139   is($io9->raw_seek(-5, SEEK_END), 4, "seek relative to end");
 140   is($io9->raw_seek(-10, SEEK_CUR), -1, "seek failure");
 141   undef $io9;
 142 }
 143 {
 144   my $io = Imager::IO->new_bufchain();
 145   is(ref $io, "Imager::IO", "check class");
 146   is($io->raw_write("testdata"), 8, "check write");
 147   is($io->raw_seek(-8, SEEK_CUR), 0, "seek relative");
 148   my $work;
 149   is($io->raw_read($work, 8), 8, "check read");
 150   is($work, "testdata", "check data read");
 151   is($io->raw_seek(-3, SEEK_END), 5, "seek end relative");
 152   is($io->raw_read($work, 5), 3, "short read");
 153   is($work, "ata", "check read data");
 154   is($io->raw_seek(4, SEEK_SET), 4, "absolute seek to write some");
 155   is($io->raw_write("testdata"), 8, "write");
 156   is($io->raw_seek(0, SEEK_CUR), 12, "check size");
 157   $io->raw_close();
 158
 159   # grab the data
 160   my $data = Imager::io_slurp($io);
 161   is($data, "testtestdata", "check we have the right data");
 162 }
 163
 164 { # callback failure checks
 165   my $fail_io = Imager::io_new_cb(\&fail_write, \&fail_read, \&fail_seek, undef, 1);
 166   # scalar context
 167   my $buffer;
 168   my $read_result = $fail_io->raw_read($buffer, 10);
 169   is($read_result, undef, "read failure undef in scalar context");
 170   my @read_result = $fail_io->raw_read($buffer, 10);
 171   is(@read_result, 0, "empty list in list context");
 172   $read_result = $fail_io->raw_read2(10);
 173   is($read_result, undef, "raw_read2 failure (scalar)");
 174   @read_result = $fail_io->raw_read2(10);
 175   is(@read_result, 0, "raw_read2 failure (list)");
 176
 177   my $write_result = $fail_io->raw_write("test");
 178   is($write_result, -1, "failed write");
 179
 180   my $seek_result = $fail_io->raw_seek(-1, SEEK_SET);
 181   is($seek_result, -1, "failed seek");
 182 }
 183
 184 { # callback success checks
 185   my $good_io = Imager::io_new_cb(\&good_write, \&good_read, \&good_seek, undef, 1);
 186   # scalar context
 187   my $buffer;
 188   my $read_result = $good_io->raw_read($buffer, 10);
 189   is($read_result, 8, "read success (scalar)");
 190   is($buffer, "testdata", "check data");
 191   my @read_result = $good_io->raw_read($buffer, 10);
 192   is_deeply(\@read_result, [ 8 ], "read success (list)");
 193   is($buffer, "testdata", "check data");
 194   $read_result = $good_io->raw_read2(10);
 195   is($read_result, "testdata", "read2 success (scalar)");
 196   @read_result = $good_io->raw_read2(10);
 197   is_deeply(\@read_result, [ "testdata" ], "read2 success (list)");
 198 }
 199
 200 { # end of file
 201   my $eof_io = Imager::io_new_cb(undef, \&eof_read, undef, undef, 1);
 202   my $buffer;
 203   my $read_result = $eof_io->raw_read($buffer, 10);
 204   is($read_result, 0, "read eof (scalar)");
 205   is($buffer, '', "check data");
 206   my @read_result = $eof_io->raw_read($buffer, 10);
 207   is_deeply(\@read_result, [ 0 ], "read eof (list)");
 208   is($buffer, '', "check data");
 209 }
 210
 211 { # no callbacks
 212   my $none_io = Imager::io_new_cb(undef, undef, undef, undef, 0);
 213   is($none_io->raw_write("test"), -1, "write with no writecb should fail");
 214   my $buffer;
 215   is($none_io->raw_read($buffer, 10), undef, "read with no readcb should fail");
 216   is($none_io->raw_seek(0, SEEK_SET), -1, "seek with no seekcb should fail");
 217 }
 218
 219 SKIP:
 220 { # make sure we croak when trying to write a string with characters over 0xff
 221   # the write callback shouldn't get called
 222   skip("no native UTF8 support in this version of perl", 2)
 223     unless $] >= 5.006;
 224   my $io = Imager::io_new_cb(\&good_write, undef, undef, 1);
 225   my $data = chr(0x100);
 226   is(ord $data, 0x100, "make sure we got what we expected");
 227   my $result =
 228     eval {
 229       $io->raw_write($data);
 230     };
 231   ok($@, "should have croaked")
 232     and print "# $@\n";
 233 }
 234
 235 { # 0.52 left some debug code in a path that wasn't tested, make sure
 236   # that path is tested
 237   # http://rt.cpan.org/Ticket/Display.html?id=20705
 238   my $io = Imager::io_new_cb
 239     (
 240      sub {
 241        print "# write $_[0]\n";
 242        1
 243      },
 244      sub {
 245        print "# read $_[0], $_[1]\n";
 246        "x" x $_[1]
 247      },
 248      sub { print "# seek\n"; 0 },
 249      sub { print "# close\n"; 1 });
 250   my $buffer;
 251   is($io->raw_read($buffer, 10), 10, "read 10");
 252   is($buffer, "xxxxxxxxxx", "read value");
 253   ok($io->raw_write("foo"), "write");
 254   is($io->raw_close, 0, "close");
 255 }
 256
 257 SKIP:
 258 { # fd_seek write failure
 259   -c "/dev/full"
 260     or skip("No /dev/full", 3);
 261   open my $fh, "> /dev/full"
 262     or skip("Can't open /dev/full: $!", 3);
 263   my $io = Imager::io_new_fd(fileno($fh));
 264   ok($io, "make fd io for /dev/full");
 265   Imager::i_clear_error();
 266   is($io->raw_write("test"), -1, "fail to write");
 267   my $msg = Imager->_error_as_msg;
 268   like($msg, qr/^write\(\) failure: /, "check error message");
 269   print "# $msg\n";
 270
 271   # /dev/full succeeds on seek on Linux
 272
 273   undef $io;
 274 }
 275
 276 SKIP:
 277 { # fd_seek seek failure
 278   my $seekfail = "testout/t07seekfail.dat";
 279   open my $fh, "> $seekfail"
 280     or skip("Can't open $seekfail: $!", 3);
 281   my $io = Imager::io_new_fd(fileno($fh));
 282   ok($io, "make fd io for $seekfail");
 283
 284   Imager::i_clear_error();
 285   is($io->raw_seek(-1, SEEK_SET), -1, "shouldn't be able to seek to -1");
 286   my $msg = Imager->_error_as_msg;
 287   like($msg, qr/^lseek\(\) failure: /, "check error message");
 288   print "# $msg\n";
 289
 290   undef $io;
 291   close $fh;
 292   unlink $seekfail;
 293 }
 294
 295 SKIP:
 296 { # fd_seek read failure
 297   open my $fh, "> testout/t07writeonly.txt"
 298     or skip("Can't open testout/t07writeonly.txt: $!", 3);
 299   my $io = Imager::io_new_fd(fileno($fh));
 300   ok($io, "make fd io for write-only");
 301
 302   Imager::i_clear_error();
 303   my $buf;
 304   is($io->raw_read($buf, 10), undef,
 305      "file open for write shouldn't be readable");
 306   my $msg = Imager->_error_as_msg;
 307   like($msg, qr/^read\(\) failure: /, "check error message");
 308   print "# $msg\n";
 309
 310   undef $io;
 311 }
 312
 313 SKIP:
 314 { # fd_seek eof
 315   open my $fh, "> testout/t07readeof.txt"
 316     or skip("Can't open testout/t07readeof.txt: $!", 5);
 317   binmode $fh;
 318   print $fh "test";
 319   close $fh;
 320   open my $fhr, "< testout/t07readeof.txt",
 321     or skip("Can't open testout/t07readeof.txt: $!", 5);
 322   my $io = Imager::io_new_fd(fileno($fhr));
 323   ok($io, "make fd io for read eof");
 324
 325   Imager::i_clear_error();
 326   my $buf;
 327   is($io->raw_read($buf, 10), 4,
 328      "10 byte read on 4 byte file should return 4");
 329   my $msg = Imager->_error_as_msg;
 330   is($msg, "", "should be no error message")
 331     or print STDERR "# read(4) message is: $msg\n";
 332
 333   Imager::i_clear_error();
 334   $buf = '';
 335   is($io->raw_read($buf, 10), 0,
 336      "10 byte read at end of 4 byte file should return 0 (eof)");
 337
 338   $msg = Imager->_error_as_msg;
 339   is($msg, "", "should be no error message")
 340     or print STDERR "# read(4), eof message is: $msg\n";
 341
 342   undef $io;
 343 }
 344
 345 { # buffered I/O
 346   my $data="P2\n2 2\n255\n 255 0\n0 255\n";
 347   my $io = Imager::io_new_buffer($data);
 348
 349   my $c = $io->getc();
 350
 351   is($c, ord "P", "getc");
 352   my $peekc = $io->peekc();
 353
 354   is($peekc, ord "2", "peekc");
 355
 356   my $peekn = $io->peekn(2);
 357   is($peekn, "2\n", "peekn");
 358
 359   $c = $io->getc();
 360   is($c, ord "2", "getc after peekc/peekn");
 361
 362   is($io->seek(0, SEEK_SET), "0", "seek");
 363   is($io->getc, ord "P", "check we got back to the start");
 364 }
 365
 366 { # test closecb result is propagated
 367   my $success_cb = sub { 1 };
 368   my $failure_cb = sub { 0 };
 369
 370   {
 371     my $io = Imager::io_new_cb(undef, $success_cb, undef, $success_cb);
 372     is($io->close(), 0, "test successful close");
 373   }
 374   {
 375     my $io = Imager::io_new_cb(undef, $success_cb, undef, $failure_cb);
 376     is($io->close(), -1, "test failed close");
 377   }
 378 }
 379
 380 { # buffered coverage/function tests
 381   # some data to play with
 382   my $base = pack "C*", map rand(26) + ord("a"), 0 .. 20_001;
 383
 384   { # buffered accessors
 385     my $io = Imager::io_new_buffer($base);
 386     ok($io->set_buffered(0), "set unbuffered");
 387     ok(!$io->is_buffered, "verify unbuffered");
 388     ok($io->set_buffered(1), "set buffered");
 389     ok($io->is_buffered, "verify buffered");
 390   }
 391
 392   { # initial i_io_read(), buffered
 393     my $pos = 0;
 394     my $ops = "";
 395     my $work = $base;
 396     my $read = sub {
 397       my ($size) = @_;
 398
 399       my $req_size = $size;
 400
 401       if ($pos + $size > length $work) {
 402         $size = length($work) - $pos;
 403       }
 404
 405       my $result = substr($work, $pos, $size);
 406       $pos += $size;
 407       $ops .= "R$req_size>$size;";
 408
 409       print "# read $req_size>$size\n";
 410
 411       return $result;
 412     };
 413     my $write = sub {
 414       my ($data) = @_;
 415
 416       substr($work, $pos, length($data), $data);
 417
 418       return 1;
 419     };
 420     {
 421       my $io = Imager::io_new_cb(undef, $read, undef, undef);
 422       my $buf;
 423       is($io->read($buf, 1000), 1000, "read initial 1000");
 424       is($buf, substr($base, 0, 1000), "check data read");
 425       is($ops, "R8192>8192;", "check read op happened to buffer size");
 426
 427       undef $buf;
 428       is($io->read($buf, 1001), 1001, "read another 1001");
 429       is($buf, substr($base, 1000, 1001), "check data read");
 430       is($ops, "R8192>8192;", "should be no further reads");
 431
 432       undef $buf;
 433       is($io->read($buf, 40_000), length($base) - 2001,
 434          "read the rest in one chunk");
 435       is($buf, substr($base, 2001), "check the data read");
 436       my $buffer_left = 8192 - 2001;
 437       my $after_buffer = length($base) - 8192;
 438       is($ops, "R8192>8192;R".(40_000 - $buffer_left).">$after_buffer;R21999>0;",
 439          "check we tried to read the remainder");
 440     }
 441     {
 442       # read after write errors
 443       my $io = Imager::io_new_cb($write, $read, undef, undef);
 444       is($io->write("test"), 4, "write 4 bytes, io in write mode");
 445       is($io->read2(10), undef, "read should fail");
 446       is($io->peekn(10), undef, "peekn should fail");
 447       is($io->getc(), -1, "getc should fail");
 448       is($io->peekc(), -1, "peekc should fail");
 449     }
 450   }
 451
 452   {
 453     my $io = Imager::io_new_buffer($base);
 454     print "# buffer fill check\n";
 455     ok($io, "make memory io");
 456     my $buf;
 457     is($io->read($buf, 4096), 4096, "read 4k");
 458     is($buf, substr($base, 0, 4096), "check data is correct");
 459
 460     # peek a bit
 461     undef $buf;
 462     is($io->peekn(5120), substr($base, 4096, 5120),
 463        "peekn() 5120, which should exceed the buffer, and only read the left overs");
 464   }
 465
 466   { # initial peekn
 467     my $io = Imager::io_new_buffer($base);
 468     is($io->peekn(10), substr($base, 0, 10),
 469        "make sure initial peekn() is sane");
 470     is($io->read2(10), substr($base, 0, 10),
 471        "and that reading 10 gets the expected data");
 472   }
 473
 474   { # oversize peekn
 475     my $io = Imager::io_new_buffer($base);
 476     is($io->peekn(10_000), substr($base, 0, 8192),
 477        "peekn() larger than buffer should return buffer-size bytes");
 478   }
 479
 480   { # small peekn then large peekn with a small I/O back end
 481     # this might happen when reading from a socket
 482     my $work = $base;
 483     my $pos = 0;
 484     my $ops = '';
 485     my $reader = sub {
 486       my ($size) = @_;
 487
 488       my $req_size = $size;
 489       # do small reads, to trigger a possible bug
 490       if ($size > 10) {
 491         $size = 10;
 492       }
 493
 494       if ($pos + $size > length $work) {
 495         $size = length($work) - $pos;
 496       }
 497
 498       my $result = substr($work, $pos, $size);
 499       $pos += $size;
 500       $ops .= "R$req_size>$size;";
 501
 502       print "# read $req_size>$size\n";
 503
 504       return $result;
 505     };
 506     my $io = Imager::io_new_cb(undef, $reader, undef, undef);
 507     ok($io, "small reader io");
 508     is($io->peekn(25), substr($base, 0, 25), "peek 25");
 509     is($ops, "R8192>10;R8182>10;R8172>10;",
 510        "check we got the raw calls expected");
 511     is($io->peekn(65), substr($base, 0, 65), "peek 65");
 512     is($ops, "R8192>10;R8182>10;R8172>10;R8162>10;R8152>10;R8142>10;R8132>10;",
 513        "check we got the raw calls expected");
 514   }
 515   for my $buffered (1, 0) { # peekn followed by errors
 516     my $buffered_desc = $buffered ? "buffered" : "unbuffered";
 517     my $read = 0;
 518     my $base = "abcdef";
 519     my $pos = 0;
 520     my $reader = sub {
 521       my $size = shift;
 522       my $req_size = $size;
 523       if ($pos + $size > length $base) {
 524         $size = length($base) - $pos;
 525       }
 526       # error instead of eof
 527       if ($size == 0) {
 528         print "# read $req_size>error\n";
 529         return;
 530       }
 531       my $result = substr($base, $pos, $size);
 532       $pos += $size;
 533
 534       print "# read $req_size>$size\n";
 535
 536       return $result;
 537     };
 538     my $io = Imager::io_new_cb(undef, $reader, undef, undef);
 539     ok($io, "make $buffered_desc cb with error after 6 bytes");
 540     is($io->peekn(5), "abcde",
 541        "peekn until just before error ($buffered_desc)");
 542     is($io->peekn(6), "abcdef", "peekn until error ($buffered_desc)");
 543     is($io->peekn(7), "abcdef", "peekn past error ($buffered_desc)");
 544     ok(!$io->error,
 545        "should be no error indicator, since data buffered ($buffered_desc)");
 546     ok(!$io->eof,
 547        "should be no eof indicator, since data buffered ($buffered_desc)");
 548
 549     # consume it
 550     is($io->read2(6), "abcdef", "consume the buffer ($buffered_desc)");
 551     is($io->peekn(10), undef,
 552        "peekn should get an error indicator ($buffered_desc)");
 553     ok($io->error, "should be an error state ($buffered_desc)");
 554     ok(!$io->eof, "but not eof ($buffered_desc)");
 555   }
 556   { # peekn on an empty file
 557     my $io = Imager::io_new_buffer("");
 558     is($io->peekn(10), "", "peekn on empty source");
 559     ok($io->eof, "should be in eof state");
 560     ok(!$io->error, "but not error");
 561   }
 562   { # peekn on error source
 563     my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
 564     is($io->peekn(10), undef, "peekn on empty source");
 565     ok($io->error, "should be in error state");
 566     ok(!$io->eof, "but not eof");
 567   }
 568   { # peekn on short source
 569     my $io = Imager::io_new_buffer("abcdef");
 570     is($io->peekn(4), "abcd", "peekn 4 on 6 byte source");
 571     is($io->peekn(10), "abcdef", "followed by peekn 10 on 6 byte source");
 572     is($io->peekn(10), "abcdef", "and again, now eof is set");
 573   }
 574   { # peekn(0)
 575     Imager::i_clear_error();
 576     my $io = Imager::io_new_buffer("abcdef");
 577     is($io->peekn(0), undef, "peekn 0 on 6 byte source");
 578     my $msg = Imager->_error_as_msg;
 579     is($msg, "peekn size must be positive");
 580   }
 581   { # getc through a whole file (buffered)
 582     my $io = Imager::io_new_buffer($base);
 583     my $out = '';
 584     while ((my $c = $io->getc()) != -1) {
 585       $out .= chr($c);
 586     }
 587     is($out, $base, "getc should return the file byte by byte (buffered)");
 588     is($io->getc, -1, "another getc after eof should fail too");
 589     ok($io->eof, "should be marked eof");
 590     ok(!$io->error, "shouldn't be marked in error");
 591   }
 592   { # getc through a whole file (unbuffered)
 593     my $io = Imager::io_new_buffer($base);
 594     $io->set_buffered(0);
 595     my $out = '';
 596     while ((my $c = $io->getc()) != -1) {
 597       $out .= chr($c);
 598     }
 599     is($out, $base, "getc should return the file byte by byte (unbuffered)");
 600     is($io->getc, -1, "another getc after eof should fail too");
 601     ok($io->eof, "should be marked eof");
 602     ok(!$io->error, "shouldn't be marked in error");
 603   }
 604   { # buffered getc with an error
 605     my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
 606     is($io->getc, -1, "buffered getc error");
 607     ok($io->error, "io marked in error");
 608     ok(!$io->eof, "but not eof");
 609   }
 610   { # unbuffered getc with an error
 611     my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
 612     $io->set_buffered(0);
 613     is($io->getc, -1, "unbuffered getc error");
 614     ok($io->error, "io marked in error");
 615     ok(!$io->eof, "but not eof");
 616   }
 617   { # initial peekc - buffered
 618     my $io = Imager::io_new_buffer($base);
 619     my $c = $io->peekc;
 620     is($c, ord($base), "buffered peekc matches");
 621     is($io->peekc, $c, "duplicate peekc matchess");
 622   }
 623   { # initial peekc - unbuffered
 624     my $io = Imager::io_new_buffer($base);
 625     $io->set_buffered(0);
 626     my $c = $io->peekc;
 627     is($c, ord($base), "unbuffered peekc matches");
 628     is($io->peekc, $c, "duplicate peekc matchess");
 629   }
 630   { # initial peekc eof - buffered
 631     my $io = Imager::io_new_cb(undef, sub { "" }, undef, undef);
 632     my $c = $io->peekc;
 633     is($c, -1, "buffered eof peekc is -1");
 634     is($io->peekc, $c, "duplicate matches");
 635     ok($io->eof, "io marked eof");
 636     ok(!$io->error, "but not error");
 637   }
 638   { # initial peekc eof - unbuffered
 639     my $io = Imager::io_new_cb(undef, sub { "" }, undef, undef);
 640     $io->set_buffered(0);
 641     my $c = $io->peekc;
 642     is($c, -1, "buffered eof peekc is -1");
 643     is($io->peekc, $c, "duplicate matches");
 644     ok($io->eof, "io marked eof");
 645     ok(!$io->error, "but not error");
 646   }
 647   { # initial peekc error - buffered
 648     my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
 649     my $c = $io->peekc;
 650     is($c, -1, "buffered error peekc is -1");
 651     is($io->peekc, $c, "duplicate matches");
 652     ok($io->error, "io marked error");
 653     ok(!$io->eof, "but not eof");
 654   }
 655   { # initial peekc error - unbuffered
 656     my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
 657     $io->set_buffered(0);
 658     my $c = $io->peekc;
 659     is($c, -1, "unbuffered error peekc is -1");
 660     is($io->peekc, $c, "duplicate matches");
 661     ok($io->error, "io marked error");
 662     ok(!$io->eof, "but not eof");
 663   }
 664   { # initial putc
 665     my $io = Imager::io_new_bufchain();
 666     is($io->putc(ord "A"), ord "A", "initial putc buffered");
 667     is($io->close, 0, "close it");
 668     is(Imager::io_slurp($io), "A", "check it was written");
 669   }
 670   { # initial putc - unbuffered
 671     my $io = Imager::io_new_bufchain();
 672     $io->set_buffered(0);
 673     is($io->putc(ord "A"), ord "A", "initial putc unbuffered");
 674     is($io->close, 0, "close it");
 675     is(Imager::io_slurp($io), "A", "check it was written");
 676   }
 677   { # putc unbuffered with error
 678     my $io = Imager::io_new_cb(undef, undef, undef, undef);
 679     $io->set_buffered(0);
 680     is($io->putc(ord "A"), -1, "initial putc unbuffered error");
 681     ok($io->error, "io in error");
 682     is($io->putc(ord "B"), -1, "still in error");
 683   }
 684   { # writes while in read state
 685     my $io = Imager::io_new_cb(sub { 1 }, sub { return "AA" }, undef, undef);
 686     is($io->getc, ord "A", "read to setup read buffer");
 687     is($io->putc(ord "B"), -1, "putc should fail");
 688     is($io->write("test"), -1, "write should fail");
 689   }
 690   { # buffered putc error handling
 691     # tests the check for error state in the buffered putc code
 692     my $io = Imager::io_new_cb(undef, undef, undef, undef);
 693     $io->putc(ord "A");
 694     ok(!$io->flush, "flush should fail");
 695     ok($io->error, "should be in error state");
 696     is($io->putc(ord "B"), -1, "check for error");
 697   }
 698   { # buffered putc flush error handling
 699     # test handling of flush failure and of the error state resulting
 700     # from that
 701     my $io = Imager::io_new_cb(undef, undef, undef, undef);
 702     my $i = 0;
 703     while (++$i < 100_000 && $io->putc(ord "A") == ord "A") {
 704       # until we have to flush and fail doing do
 705     }
 706     is($i, 8193, "should have failed on 8193rd byte");
 707     ok($io->error, "should be in error state");
 708     is($io->putc(ord "B"), -1, "next putc should fail");
 709   }
 710   { # buffered write flush error handling
 711     # test handling of flush failure and of the error state resulting
 712     # from that
 713     my $io = Imager::io_new_cb(undef, undef, undef, undef);
 714     my $i = 0;
 715     while (++$i < 100_000 && $io->write("A") == 1) {
 716       # until we have to flush and fail doing do
 717     }
 718     is($i, 8193, "should have failed on 8193rd byte");
 719     ok($io->error, "should be in error state");
 720     is($io->write("B"), -1, "next write should fail");
 721   }
 722   { # buffered read error
 723     my $io = Imager::io_new_cb(undef, undef, undef, undef);
 724     is($io->read2(10), undef, "initial read returning error");
 725     ok($io->error, "should be in error state");
 726   }
 727   { # unbuffered read error
 728     my $io = Imager::io_new_cb(undef, undef, undef, undef);
 729     $io->set_buffered(0);
 730     is($io->read2(10), undef, "initial read returning error");
 731     ok($io->error, "should be in error state");
 732   }
 733   { # unbuffered write error
 734     my $count = 0;
 735     my $io = Imager::io_new_cb(sub { return $count++; }, undef, undef, undef);
 736     $io->set_buffered(0);
 737     is($io->write("A"), -1, "unbuffered write failure");
 738     ok($io->error, "should be in error state");
 739     is($io->write("BC"), -1, "should still fail");
 740   }
 741   { # buffered write + large write
 742     my $io = Imager::io_new_bufchain();
 743     is($io->write(substr($base, 0, 4096)), 4096,
 744        "should be buffered");
 745     is($io->write(substr($base, 4096)), length($base) - 4096,
 746        "large write, should fill buffer and fall back to direct write");
 747     is($io->close, 0, "close it");
 748     is(Imager::io_slurp($io), $base, "make sure the data is correct");
 749   }
 750   { # initial large write with failure
 751     # tests error handling for the case where we bypass the buffer
 752     # when the write is too large to fit
 753     my $io = Imager::io_new_cb(undef, undef, undef, undef);
 754     ok($io->flush, "flush with nothing buffered should succeed");
 755     is($io->write($base), -1, "large write failure");
 756     ok($io->error, "should be in error state");
 757     is($io->close, -1, "should fail to close");
 758   }
 759   { # write that causes a flush then fills the buffer a bit
 760     my $io = Imager::io_new_bufchain();
 761     is($io->write(substr($base, 0, 6000)), 6000, "fill the buffer a bit");
 762     is($io->write(substr($base, 6000, 4000)), 4000,
 763        "cause it to flush and then fill some more");
 764     is($io->write(substr($base, 10000)), length($base)-10000,
 765        "write out the rest of our test data");
 766     is($io->close, 0, "close the stream");
 767     is(Imager::io_slurp($io), $base, "make sure the data is right");
 768   }
 769   { # failure on flush on close
 770     my $io = Imager::io_new_cb(undef, undef, undef, undef);
 771     is($io->putc(ord "A"), ord "A", "something in the buffer");
 772     ok(!$io->error, "should be no error yet");
 773     is($io->close, -1, "close should failure due to flush error");
 774   }
 775   { # seek failure
 776     my $io = Imager::io_new_cb(undef, undef, undef, undef);
 777     is($io->seek(0, SEEK_SET), -1, "seek failure");
 778   }
 779   { # read a little and seek
 780     my $io = Imager::io_new_buffer($base);
 781     is($io->getc, ord $base, "read one");
 782     is($io->getc, ord substr($base, 1, 1), "read another");
 783     is($io->seek(-1, SEEK_CUR), 1, "seek relative back to origin+1");
 784     is($io->getc, ord substr($base, 1, 1), "read another again");
 785   }
 786   { # seek with failing flush
 787     my $io = Imager::io_new_cb(undef, undef, undef, undef);
 788     is($io->putc(ord "A"), ord "A", "write one");
 789     ok(!$io->error, "not in error mode (yet)");
 790     is($io->seek(0, SEEK_SET), -1, "seek failure due to flush");
 791     ok($io->error, "in error mode");
 792   }
 793   { # gets()
 794     my $data = "test1\ntest2\ntest3";
 795     my $io = Imager::io_new_buffer($data);
 796     is($io->gets(6), "test1\n", "gets(6)");
 797     is($io->gets(5), "test2", "gets(5) (short for the line)");
 798     is($io->gets(10), "\n", "gets(10) the rest of the line (the newline)");
 799     is($io->gets(), "test3", "gets(default) unterminated line");
 800   }
 801   { # more gets()
 802     my $data = "test1\ntest2\ntest3";
 803     my $io = Imager::io_new_buffer($data);
 804     is($io->gets(6, ord("1")), "test1", "gets(6) (line terminator 1)");
 805     is($io->gets(6, ord("2")), "\ntest2", "gets(6) (line terminator 2)");
 806     is($io->gets(6, ord("3")), "\ntest3", "gets(6) (line terminator 3)");
 807     is($io->getc, -1, "should be eof");
 808   }
 809 }
 810
 811 { # based on discussion on IRC, user was attempting to write a TIFF
 812   # image file with only a write callback, but TIFF requires seek and
 813   # read callbacks when writing.
 814   # https://rt.cpan.org/Ticket/Display.html?id=76782
 815   my $cb = Imager::io_new_cb(undef, undef, undef, undef);
 816   {
 817     Imager::i_clear_error();
 818     my $data;
 819     is($cb->read($data, 10), undef, "default read callback should fail");
 820     is(Imager->_error_as_msg(), "read callback called but no readcb supplied",
 821        "check error message");
 822   }
 823   {
 824     Imager::i_clear_error();
 825     is($cb->raw_write("abc"), -1, "default write callback should fail");
 826     is(Imager->_error_as_msg(), "write callback called but no writecb supplied",
 827        "check error message");
 828   }
 829   {
 830     Imager::i_clear_error();
 831     is($cb->seek(0, 0), -1, "default seek callback should fail");
 832     is(Imager->_error_as_msg(), "seek callback called but no seekcb supplied",
 833        "check error message");
 834   }
 835 }
 836
 837 Imager->close_log;
 838
 839 unless ($ENV{IMAGER_KEEP_FILES}) {
 840   unlink "testout/t07.ppm", "testout/t07iolayer.log";
 841 }
 842
 843 sub eof_read {
 844   my ($max_len) = @_;
 845
 846   return '';
 847 }
 848
 849 sub good_read {
 850   my ($max_len) = @_;
 851
 852   my $data = "testdata";
 853   length $data <= $max_len or substr($data, $max_len) = '';
 854
 855   print "# good_read ($max_len) => $data\n";
 856
 857   return $data;
 858 }
 859
 860 sub fail_write {
 861   return;
 862 }
 863
 864 sub fail_read {
 865   return;
 866 }
 867
 868 sub fail_seek {
 869   return -1;
 870 }