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