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