updates

[imager.git] / t / t07iolayer.t

diff --git a/t/t07iolayer.t b/t/t07iolayer.t
index 654c6e697a640cab02c9943762623e02c4056709..4f747f53baf16b33d6cf3219cc072d7c420e2779 100644 (file)
--- a/t/t07iolayer.t
+++ b/t/t07iolayer.t
@@ -1,7 +1,8 @@
 #!perl -w
 use strict;
-use Test::More tests => 43;
-use Fcntl ':seek';
+use Test::More tests => 68;
+# for SEEK_SET etc, Fcntl doesn't provide these in 5.005_03
+use IO::Seekable;
 
 BEGIN { use_ok(Imager => ':all') };
 
@@ -107,7 +108,7 @@ $work = '';
 ok(Imager::i_writeppm_wiol($im, $IO8), "write to cb");
 # I originally compared this to $data, but that doesn't include the
 # Imager header
-ok($work eq $data2, "write image match");
+is($work, $data2, "write image match");
 ok($did_close, "did close");
 
 # with a short buffer, no closer
@@ -116,7 +117,7 @@ ok($IO9, "making short writecb object");
 $pos = 0;
 $work = '';
 ok(Imager::i_writeppm_wiol($im, $IO9), "write to short cb");
-ok($work eq $data2, "short write image match");
+is($work, $data2, "short write image match");
 
 {
   my $buf_data = "Test data";
@@ -155,3 +156,125 @@ ok($work eq $data2, "short write image match");
   my $data = Imager::io_slurp($io);
   is($data, "testtestdata", "check we have the right data");
 }
+
+{ # callback failure checks
+  my $fail_io = Imager::io_new_cb(\&fail_write, \&fail_read, \&fail_seek, undef, 1);
+  # scalar context
+  my $buffer;
+  my $read_result = $fail_io->read($buffer, 10);
+  is($read_result, undef, "read failure undef in scalar context");
+  my @read_result = $fail_io->read($buffer, 10);
+  is(@read_result, 0, "empty list in list context");
+  $read_result = $fail_io->read2(10);
+  is($read_result, undef, "read2 failure (scalar)");
+  @read_result = $fail_io->read2(10);
+  is(@read_result, 0, "read2 failure (list)");
+
+  my $write_result = $fail_io->write("test");
+  is($write_result, -1, "failed write");
+
+  my $seek_result = $fail_io->seek(-1, SEEK_SET);
+  is($seek_result, -1, "failed seek");
+}
+
+{ # callback success checks
+  my $good_io = Imager::io_new_cb(\&good_write, \&good_read, \&good_seek, undef, 1);
+  # scalar context
+  my $buffer;
+  my $read_result = $good_io->read($buffer, 10);
+  is($read_result, 10, "read success (scalar)");
+  is($buffer, "testdatate", "check data");
+  my @read_result = $good_io->read($buffer, 10);
+  is_deeply(\@read_result, [ 10 ], "read success (list)");
+  is($buffer, "testdatate", "check data");
+  $read_result = $good_io->read2(10);
+  is($read_result, "testdatate", "read2 success (scalar)");
+  @read_result = $good_io->read2(10);
+  is_deeply(\@read_result, [ "testdatate" ], "read2 success (list)");
+}
+
+{ # end of file
+  my $eof_io = Imager::io_new_cb(undef, \&eof_read, undef, undef, 1);
+  my $buffer;
+  my $read_result = $eof_io->read($buffer, 10);
+  is($read_result, 0, "read eof (scalar)");
+  is($buffer, '', "check data");
+  my @read_result = $eof_io->read($buffer, 10);
+  is_deeply(\@read_result, [ 0 ], "read eof (list)");
+  is($buffer, '', "check data");
+}
+
+{ # no callbacks
+  my $none_io = Imager::io_new_cb(undef, undef, undef, undef, 0);
+  is($none_io->write("test"), -1, "write with no writecb should fail");
+  my $buffer;
+  is($none_io->read($buffer, 10), undef, "read with no readcb should fail");
+  is($none_io->seek(0, SEEK_SET), -1, "seek with no seekcb should fail");
+}
+
+SKIP:
+{ # make sure we croak when trying to write a string with characters over 0xff
+  # the write callback shouldn't get called
+  skip("no native UTF8 support in this version of perl", 2)
+    unless $] >= 5.006;
+  my $io = Imager::io_new_cb(\&good_write, undef, undef, 1);
+  my $data = chr(0x100);
+  is(ord $data, 0x100, "make sure we got what we expected");
+  my $result = 
+    eval {
+      $io->write($data);
+    };
+  ok($@, "should have croaked")
+    and print "# $@\n";
+}
+
+{ # 0.52 left some debug code in a path that wasn't tested, make sure
+  # that path is tested
+  # http://rt.cpan.org/Ticket/Display.html?id=20705
+  my $io = Imager::io_new_cb
+    (
+     sub { 
+       print "# write $_[0]\n";
+       1 
+     }, 
+     sub { 
+       print "# read $_[0], $_[1]\n";
+       "x" x $_[1]
+     }, 
+     sub { print "# seek\n"; 0 }, 
+     sub { print "# close\n"; 1 });
+  my $buffer;
+  is($io->read($buffer, 10), 10, "read 10");
+  is($buffer, "xxxxxxxxxx", "read value");
+  ok($io->write("foo"), "write");
+  is($io->close, 0, "close");
+}
+
+sub eof_read {
+  my ($max_len) = @_;
+
+  return '';
+}
+
+sub good_read {
+  my ($max_len) = @_;
+
+  my $data = "testdata";
+  length $data <= $max_len or substr($data, $max_len) = '';
+
+  print "# good_read ($max_len) => $data\n";
+
+  return $data;
+}
+
+sub fail_write {
+  return;
+}
+
+sub fail_read {
+  return;
+}
+
+sub fail_seek {
+  return -1;
+}