add support for giflib 5.1.0
[imager.git] / t / 200-file / 010-iolayer.t
CommitLineData
c35f2f76
TC
1#!perl -w
2use strict;
a87997b2 3use Test::More tests => 275;
d5b8dad2 4use Imager::Test qw(is_image);
13eb8ccd
TC
5# for SEEK_SET etc, Fcntl doesn't provide these in 5.005_03
6use IO::Seekable;
52d990d6 7use Config;
c35f2f76
TC
8
9BEGIN { use_ok(Imager => ':all') };
4dfa5522 10
40e78f96
TC
11-d "testout" or mkdir "testout";
12
6d5c85a2
TC
13$| = 1;
14
cc59eadc 15Imager->open_log(log => "testout/t07iolayer.log");
4dfa5522
AMH
16
17undef($/);
18# start by testing io buffer
19
c35f2f76
TC
20my $data="P2\n2 2\n255\n 255 0\n0 255\n";
21my $IO = Imager::io_new_buffer($data);
22my $im = Imager::i_readpnm_wiol($IO, -1);
4dfa5522 23
c35f2f76 24ok($im, "read from data io");
4dfa5522
AMH
25
26open(FH, ">testout/t07.ppm") or die $!;
27binmode(FH);
c35f2f76
TC
28my $fd = fileno(FH);
29my $IO2 = Imager::io_new_fd( $fd );
4dfa5522
AMH
30Imager::i_writeppm_wiol($im, $IO2);
31close(FH);
32undef($im);
33
4dfa5522 34open(FH, "<testimg/penguin-base.ppm");
866278a5 35binmode(FH);
4dfa5522
AMH
36$data = <FH>;
37close(FH);
6d5c85a2 38my $IO3 = Imager::IO->new_buffer($data);
4dfa5522
AMH
39#undef($data);
40$im = Imager::i_readpnm_wiol($IO3, -1);
41
c35f2f76 42ok($im, "read from buffer, for compare");
10461f9a 43undef $IO3;
4dfa5522
AMH
44
45open(FH, "<testimg/penguin-base.ppm") or die $!;
46binmode(FH);
47$fd = fileno(FH);
6d5c85a2 48my $IO4 = Imager::IO->new_fd( $fd );
c35f2f76 49my $im2 = Imager::i_readpnm_wiol($IO4, -1);
4dfa5522
AMH
50close(FH);
51undef($IO4);
52
c35f2f76 53ok($im2, "read from file, for compare");
4dfa5522 54
c35f2f76 55is(i_img_diff($im, $im2), 0, "compare images");
4dfa5522
AMH
56undef($im2);
57
c35f2f76 58my $IO5 = Imager::io_new_bufchain();
73b25e89
TC
59Imager::i_writeppm_wiol($im, $IO5)
60 or diag("failed to write to bufchain: " . Imager->_error_as_msg);
c35f2f76 61my $data2 = Imager::io_slurp($IO5);
4dfa5522
AMH
62undef($IO5);
63
c35f2f76 64ok($data2, "check we got data from bufchain");
4dfa5522 65
c35f2f76 66my $IO6 = Imager::io_new_buffer($data2);
73b25e89
TC
67my $im3 = Imager::i_readpnm_wiol($IO6, -1)
68 or diag("failed to read from buffer: " . Imager->_error_as_msg);
4dfa5522 69
c35f2f76 70is(Imager::i_img_diff($im, $im3), 0, "read from buffer");
10461f9a
TC
71
72my $work = $data;
73my $pos = 0;
74sub io_reader {
75 my ($size, $maxread) = @_;
76 my $out = substr($work, $pos, $maxread);
77 $pos += length $out;
78 $out;
79}
80sub io_reader2 {
81 my ($size, $maxread) = @_;
82 my $out = substr($work, $pos, $maxread);
83 $pos += length $out;
84 $out;
85}
6d5c85a2 86my $IO7 = Imager::IO->new_cb(undef, \&io_reader, undef, undef);
c35f2f76 87ok($IO7, "making readcb object");
10461f9a 88my $im4 = Imager::i_readpnm_wiol($IO7, -1);
c35f2f76
TC
89ok($im4, "read from cb");
90ok(Imager::i_img_diff($im, $im4) == 0, "read from cb image match");
10461f9a
TC
91
92$pos = 0;
93$IO7 = Imager::io_new_cb(undef, \&io_reader2, undef, undef);
c35f2f76 94ok($IO7, "making short readcb object");
10461f9a 95my $im5 = Imager::i_readpnm_wiol($IO7, -1);
c35f2f76
TC
96ok($im4, "read from cb2");
97is(Imager::i_img_diff($im, $im5), 0, "read from cb2 image match");
10461f9a
TC
98
99sub io_writer {
100 my ($what) = @_;
101 substr($work, $pos, $pos+length $what) = $what;
102 $pos += length $what;
103
104 1;
105}
106
107my $did_close;
108sub io_close {
109 ++$did_close;
110}
111
112my $IO8 = Imager::io_new_cb(\&io_writer, undef, undef, \&io_close);
c35f2f76 113ok($IO8, "making writecb object");
10461f9a
TC
114$pos = 0;
115$work = '';
c35f2f76 116ok(Imager::i_writeppm_wiol($im, $IO8), "write to cb");
10461f9a
TC
117# I originally compared this to $data, but that doesn't include the
118# Imager header
5386861e 119is($work, $data2, "write image match");
c35f2f76 120ok($did_close, "did close");
10461f9a
TC
121
122# with a short buffer, no closer
123my $IO9 = Imager::io_new_cb(\&io_writer, undef, undef, undef, 1);
c35f2f76 124ok($IO9, "making short writecb object");
10461f9a
TC
125$pos = 0;
126$work = '';
c35f2f76 127ok(Imager::i_writeppm_wiol($im, $IO9), "write to short cb");
5386861e 128is($work, $data2, "short write image match");
c35f2f76 129
eda1622c
TC
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;
6d5c85a2 135 is($io9->raw_read($work, 4), 4, "read 4 from buffer object");
eda1622c 136 is($work, "Test", "check data read");
6d5c85a2 137 is($io9->raw_read($work, 5), 5, "read the rest");
eda1622c 138 is($work, " data", "check data read");
6d5c85a2
TC
139 is($io9->raw_seek(5, SEEK_SET), 5, "seek");
140 is($io9->raw_read($work, 5), 4, "short read");
eda1622c 141 is($work, "data", "check data read");
6d5c85a2
TC
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");
eda1622c
TC
145 undef $io9;
146}
147{
6d5c85a2 148 my $io = Imager::IO->new_bufchain();
eda1622c 149 is(ref $io, "Imager::IO", "check class");
6d5c85a2
TC
150 is($io->raw_write("testdata"), 8, "check write");
151 is($io->raw_seek(-8, SEEK_CUR), 0, "seek relative");
eda1622c 152 my $work;
6d5c85a2 153 is($io->raw_read($work, 8), 8, "check read");
eda1622c 154 is($work, "testdata", "check data read");
6d5c85a2
TC
155 is($io->raw_seek(-3, SEEK_END), 5, "seek end relative");
156 is($io->raw_read($work, 5), 3, "short read");
eda1622c 157 is($work, "ata", "check read data");
6d5c85a2
TC
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();
eda1622c
TC
162
163 # grab the data
164 my $data = Imager::io_slurp($io);
165 is($data, "testtestdata", "check we have the right data");
166}
1f6c1c10
TC
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;
6d5c85a2 172 my $read_result = $fail_io->raw_read($buffer, 10);
1f6c1c10 173 is($read_result, undef, "read failure undef in scalar context");
6d5c85a2 174 my @read_result = $fail_io->raw_read($buffer, 10);
1f6c1c10 175 is(@read_result, 0, "empty list in list context");
6d5c85a2
TC
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)");
1f6c1c10 180
6d5c85a2 181 my $write_result = $fail_io->raw_write("test");
1f6c1c10
TC
182 is($write_result, -1, "failed write");
183
6d5c85a2 184 my $seek_result = $fail_io->raw_seek(-1, SEEK_SET);
1f6c1c10
TC
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;
6d5c85a2
TC
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)");
1f6c1c10
TC
202}
203
204{ # end of file
205 my $eof_io = Imager::io_new_cb(undef, \&eof_read, undef, undef, 1);
206 my $buffer;
6d5c85a2 207 my $read_result = $eof_io->raw_read($buffer, 10);
1f6c1c10
TC
208 is($read_result, 0, "read eof (scalar)");
209 is($buffer, '', "check data");
6d5c85a2 210 my @read_result = $eof_io->raw_read($buffer, 10);
1f6c1c10
TC
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);
6d5c85a2 217 is($none_io->raw_write("test"), -1, "write with no writecb should fail");
1f6c1c10 218 my $buffer;
6d5c85a2
TC
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");
1f6c1c10
TC
221}
222
223SKIP:
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 {
6d5c85a2 233 $io->raw_write($data);
40a88898 234 1;
1f6c1c10 235 };
40a88898 236 ok(!$result, "should have croaked")
1f6c1c10
TC
237 and print "# $@\n";
238}
239
3d6d61d8
TC
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;
6d5c85a2 256 is($io->raw_read($buffer, 10), 10, "read 10");
3d6d61d8 257 is($buffer, "xxxxxxxxxx", "read value");
6d5c85a2
TC
258 ok($io->raw_write("foo"), "write");
259 is($io->raw_close, 0, "close");
260}
261
262SKIP:
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
281SKIP:
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
300SKIP:
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
318SKIP:
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 }
3d6d61d8
TC
814}
815
9d5ff8a6
TC
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
52d990d6
TC
842SKIP:
843{
844 $Config{useperlio}
d5b8dad2 845 or skip "PerlIO::scalar requires perlio", 13;
52d990d6
TC
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");
d5b8dad2
TC
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");
52d990d6
TC
876}
877
f388cd37
TC
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
a87997b2
TC
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 undef $data2;
898 my $tmp = $io->read2(1000);
899 is($tmp, $data, "buffer io created by reference");
900}
901
cc59eadc
TC
902Imager->close_log;
903
904unless ($ENV{IMAGER_KEEP_FILES}) {
905 unlink "testout/t07.ppm", "testout/t07iolayer.log";
906}
907
1f6c1c10
TC
908sub eof_read {
909 my ($max_len) = @_;
910
911 return '';
912}
913
914sub good_read {
915 my ($max_len) = @_;
916
917 my $data = "testdata";
918 length $data <= $max_len or substr($data, $max_len) = '';
919
920 print "# good_read ($max_len) => $data\n";
921
922 return $data;
923}
924
925sub fail_write {
926 return;
927}
928
929sub fail_read {
930 return;
931}
932
933sub fail_seek {
934 return -1;
935}
f388cd37
TC
936
937package IO::Tied;
938use base 'Tie::Handle';
939use IO::Seekable;
940
941sub TIEHANDLE {
942 return bless [ "", 0 ];
943}
944
945sub PRINT {
946 for my $entry (@_[1 .. $#_]) {
947 substr($_[0][0], $_[0][1], length $entry, $entry);
948 $_[0][1] += length $entry;
949 }
950
951 return 1;
952}
953
954sub SEEK {
955 my ($self, $offset, $whence) = @_;
956
957 my $newpos;
958 if ($whence == SEEK_SET) {
959 $newpos = $offset;
960 }
961 elsif ($whence == SEEK_CUR) {
962 $newpos = $self->[1] + $offset;
963 }
964 elsif ($whence == SEEK_END) {
965 $newpos = length($self->[0]) + $newpos;
966 }
967 else {
968 return -1;
969 }
970
971 if ($newpos < 0) {
972 return 0;
973 }
974
975 $self->[1] = $newpos;
976
977 return 1;
978}
979
980sub TELL {
981 return $_[0][1];
982}
983
984sub READ {
985 my $self = shift;
986 my $outlen = $_[1];
987 my $offset = @_ > 2 ? $_[2] : 0;
988 if ($self->[1] + $outlen > length $self->[0]) {
989 $outlen = length($self->[0]) - $self->[1];
990 $outlen <= 0
991 and return "";
992 }
993 defined $_[0] or $_[0] = "";
994 substr($_[0], $offset, $outlen) = substr($self->[0], $self->[1], $outlen);
995 $self->[1] += $outlen;
996
997 return $outlen;
998}