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