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