fix SV type probing to not break pre perl 5.12
[imager.git] / t / 200-file / 010-iolayer.t
1 #!perl -w
2 use strict;
3 use Test::More tests => 287;
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 { # pass buffer by reference
894   my $data = "This is a test";
895   my $data2 = $data;
896   my $io = Imager::IO->new_buffer(\$data2)
897     or diag "Can't create from SV REF:", Imager->_error_as_msg;
898   undef $data2;
899   my $tmp = $io->read2(1000);
900   is($tmp, $data, "buffer io created by reference");
901 }
902
903 {
904   my @buffer_tests =
905     (
906      [ 1000, "IV" ],
907      [ 1000.1, "NV" ],
908      [ qr/abcd/, "regexp",
909        $> >= 5.012 && "Can't use regexps as a buffer before 5.14" ],
910     );
911   for my $test (@buffer_tests) {
912     my ($val, $note, $skip) = @$test;
913   SKIP:
914     {
915       $skip and skip $skip, 4;
916     SKIP:
917       {
918         my $temp = $val;
919         my $io = Imager::IO->new_buffer(\$temp);
920         ok($io, "$note/ref: open_buffer")
921           or skip "couldn't open", 1;
922         my $read = $io->read2(1000);
923         is($read, "$val", "$note/ref: read result");
924       }
925
926     SKIP:
927       {
928         my $temp = $val;
929         my $io = Imager::IO->new_buffer($temp);
930         ok($io, "$note: open_buffer")
931           or skip "couldn't open", 1;
932         my $read = $io->read2(1000);
933         is($read, "$val", "$note: read result");
934       }
935     }
936   }
937 }
938
939 Imager->close_log;
940
941 unless ($ENV{IMAGER_KEEP_FILES}) {
942   unlink "testout/t07.ppm", "testout/t07iolayer.log";
943 }
944
945 sub eof_read {
946   my ($max_len) = @_;
947
948   return '';
949 }
950
951 sub good_read {
952   my ($max_len) = @_;
953
954   my $data = "testdata";
955   length $data <= $max_len or substr($data, $max_len) = '';
956
957   print "# good_read ($max_len) => $data\n";
958
959   return $data;
960 }
961
962 sub fail_write {
963   return;
964 }
965
966 sub fail_read {
967   return;
968 }
969
970 sub fail_seek {
971   return -1;
972 }
973
974 package IO::Tied;
975 use base 'Tie::Handle';
976 use IO::Seekable;
977
978 sub TIEHANDLE {
979   return bless [ "", 0 ];
980 }
981
982 sub PRINT {
983   for my $entry (@_[1 .. $#_]) {
984     substr($_[0][0], $_[0][1], length $entry, $entry);
985     $_[0][1] += length $entry;
986   }
987
988   return 1;
989 }
990
991 sub SEEK {
992   my ($self, $offset, $whence) = @_;
993
994   my $newpos;
995   if ($whence == SEEK_SET) {
996     $newpos = $offset;
997   }
998   elsif ($whence == SEEK_CUR) {
999     $newpos = $self->[1] + $offset;
1000   }
1001   elsif ($whence == SEEK_END) {
1002     $newpos = length($self->[0]) + $newpos;
1003   }
1004   else {
1005     return -1;
1006   }
1007
1008   if ($newpos < 0) {
1009     return 0;
1010   }
1011
1012   $self->[1] = $newpos;
1013
1014   return 1;
1015 }
1016
1017 sub TELL {
1018   return $_[0][1];
1019 }
1020
1021 sub READ {
1022   my $self = shift;
1023   my $outlen = $_[1];
1024   my $offset = @_ > 2 ? $_[2] : 0;
1025   if ($self->[1] + $outlen > length $self->[0]) {
1026     $outlen = length($self->[0]) - $self->[1];
1027     $outlen <= 0
1028       and return "";
1029   }
1030   defined $_[0] or $_[0] = "";
1031   substr($_[0], $offset, $outlen) = substr($self->[0], $self->[1], $outlen);
1032   $self->[1] += $outlen;
1033
1034   return $outlen;
1035 }