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