t/t07iolayer.t

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