t/t07iolayer.t

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