t/t07iolayer.t

   1 #!perl -w
   2 use strict;
   3 use lib 't';
   4 use Test::More tests => 68;
   5 # for SEEK_SET etc, Fcntl doesn't provide these in 5.005_03
   6 use IO::Seekable;
   7
   8 BEGIN { use_ok(Imager => ':all') };
   9
  10 init_log("testout/t07iolayer.log", 1);
  11
  12 undef($/);
  13 # start by testing io buffer
  14
  15 my $data="P2\n2 2\n255\n 255 0\n0 255\n";
  16 my $IO = Imager::io_new_buffer($data);
  17 my $im = Imager::i_readpnm_wiol($IO, -1);
  18
  19 ok($im, "read from data io");
  20
  21 open(FH, ">testout/t07.ppm") or die $!;
  22 binmode(FH);
  23 my $fd = fileno(FH);
  24 my $IO2 = Imager::io_new_fd( $fd );
  25 Imager::i_writeppm_wiol($im, $IO2);
  26 close(FH);
  27 undef($im);
  28
  29 open(FH, "<testimg/penguin-base.ppm");
  30 binmode(FH);
  31 $data = <FH>;
  32 close(FH);
  33 my $IO3 = Imager::io_new_buffer($data);
  34 #undef($data);
  35 $im = Imager::i_readpnm_wiol($IO3, -1);
  36
  37 ok($im, "read from buffer, for compare");
  38 undef $IO3;
  39
  40 open(FH, "<testimg/penguin-base.ppm") or die $!;
  41 binmode(FH);
  42 $fd = fileno(FH);
  43 my $IO4 = Imager::io_new_fd( $fd );
  44 my $im2 = Imager::i_readpnm_wiol($IO4, -1);
  45 close(FH);
  46 undef($IO4);
  47
  48 ok($im2, "read from file, for compare");
  49
  50 is(i_img_diff($im, $im2), 0, "compare images");
  51 undef($im2);
  52
  53 my $IO5 = Imager::io_new_bufchain();
  54 Imager::i_writeppm_wiol($im, $IO5);
  55 my $data2 = Imager::io_slurp($IO5);
  56 undef($IO5);
  57
  58 ok($data2, "check we got data from bufchain");
  59
  60 my $IO6 = Imager::io_new_buffer($data2);
  61 my $im3 = Imager::i_readpnm_wiol($IO6, -1);
  62
  63 is(Imager::i_img_diff($im, $im3), 0, "read from buffer");
  64
  65 my $work = $data;
  66 my $pos = 0;
  67 sub io_reader {
  68   my ($size, $maxread) = @_;
  69   my $out = substr($work, $pos, $maxread);
  70   $pos += length $out;
  71   $out;
  72 }
  73 sub io_reader2 {
  74   my ($size, $maxread) = @_;
  75   my $out = substr($work, $pos, $maxread);
  76   $pos += length $out;
  77   $out;
  78 }
  79 my $IO7 = Imager::io_new_cb(undef, \&io_reader, undef, undef);
  80 ok($IO7, "making readcb object");
  81 my $im4 = Imager::i_readpnm_wiol($IO7, -1);
  82 ok($im4, "read from cb");
  83 ok(Imager::i_img_diff($im, $im4) == 0, "read from cb image match");
  84
  85 $pos = 0;
  86 $IO7 = Imager::io_new_cb(undef, \&io_reader2, undef, undef);
  87 ok($IO7, "making short readcb object");
  88 my $im5 = Imager::i_readpnm_wiol($IO7, -1);
  89 ok($im4, "read from cb2");
  90 is(Imager::i_img_diff($im, $im5), 0, "read from cb2 image match");
  91
  92 sub io_writer {
  93   my ($what) = @_;
  94   substr($work, $pos, $pos+length $what) = $what;
  95   $pos += length $what;
  96
  97   1;
  98 }
  99
 100 my $did_close;
 101 sub io_close {
 102   ++$did_close;
 103 }
 104
 105 my $IO8 = Imager::io_new_cb(\&io_writer, undef, undef, \&io_close);
 106 ok($IO8, "making writecb object");
 107 $pos = 0;
 108 $work = '';
 109 ok(Imager::i_writeppm_wiol($im, $IO8), "write to cb");
 110 # I originally compared this to $data, but that doesn't include the
 111 # Imager header
 112 ok($work eq $data2, "write image match");
 113 ok($did_close, "did close");
 114
 115 # with a short buffer, no closer
 116 my $IO9 = Imager::io_new_cb(\&io_writer, undef, undef, undef, 1);
 117 ok($IO9, "making short writecb object");
 118 $pos = 0;
 119 $work = '';
 120 ok(Imager::i_writeppm_wiol($im, $IO9), "write to short cb");
 121 ok($work eq $data2, "short write image match");
 122
 123 {
 124   my $buf_data = "Test data";
 125   my $io9 = Imager::io_new_buffer($buf_data);
 126   is(ref $io9, "Imager::IO", "check class");
 127   my $work;
 128   is($io9->read($work, 4), 4, "read 4 from buffer object");
 129   is($work, "Test", "check data read");
 130   is($io9->read($work, 5), 5, "read the rest");
 131   is($work, " data", "check data read");
 132   is($io9->seek(5, SEEK_SET), 5, "seek");
 133   is($io9->read($work, 5), 4, "short read");
 134   is($work, "data", "check data read");
 135   is($io9->seek(-1, SEEK_CUR), 8, "seek relative");
 136   is($io9->seek(-5, SEEK_END), 4, "seek relative to end");
 137   is($io9->seek(-10, SEEK_CUR), -1, "seek failure");
 138   undef $io9;
 139 }
 140 {
 141   my $io = Imager::io_new_bufchain();
 142   is(ref $io, "Imager::IO", "check class");
 143   is($io->write("testdata"), 8, "check write");
 144   is($io->seek(-8, SEEK_CUR), 0, "seek relative");
 145   my $work;
 146   is($io->read($work, 8), 8, "check read");
 147   is($work, "testdata", "check data read");
 148   is($io->seek(-3, SEEK_END), 5, "seek end relative");
 149   is($io->read($work, 5), 3, "short read");
 150   is($work, "ata", "check read data");
 151   is($io->seek(4, SEEK_SET), 4, "absolute seek to write some");
 152   is($io->write("testdata"), 8, "write");
 153   is($io->seek(0, SEEK_CUR), 12, "check size");
 154   $io->close();
 155
 156   # grab the data
 157   my $data = Imager::io_slurp($io);
 158   is($data, "testtestdata", "check we have the right data");
 159 }
 160
 161 { # callback failure checks
 162   my $fail_io = Imager::io_new_cb(\&fail_write, \&fail_read, \&fail_seek, undef, 1);
 163   # scalar context
 164   my $buffer;
 165   my $read_result = $fail_io->read($buffer, 10);
 166   is($read_result, undef, "read failure undef in scalar context");
 167   my @read_result = $fail_io->read($buffer, 10);
 168   is(@read_result, 0, "empty list in list context");
 169   $read_result = $fail_io->read2(10);
 170   is($read_result, undef, "read2 failure (scalar)");
 171   @read_result = $fail_io->read2(10);
 172   is(@read_result, 0, "read2 failure (list)");
 173
 174   my $write_result = $fail_io->write("test");
 175   is($write_result, -1, "failed write");
 176
 177   my $seek_result = $fail_io->seek(-1, SEEK_SET);
 178   is($seek_result, -1, "failed seek");
 179 }
 180
 181 { # callback success checks
 182   my $good_io = Imager::io_new_cb(\&good_write, \&good_read, \&good_seek, undef, 1);
 183   # scalar context
 184   my $buffer;
 185   my $read_result = $good_io->read($buffer, 10);
 186   is($read_result, 10, "read success (scalar)");
 187   is($buffer, "testdatate", "check data");
 188   my @read_result = $good_io->read($buffer, 10);
 189   is_deeply(\@read_result, [ 10 ], "read success (list)");
 190   is($buffer, "testdatate", "check data");
 191   $read_result = $good_io->read2(10);
 192   is($read_result, "testdatate", "read2 success (scalar)");
 193   @read_result = $good_io->read2(10);
 194   is_deeply(\@read_result, [ "testdatate" ], "read2 success (list)");
 195 }
 196
 197 { # end of file
 198   my $eof_io = Imager::io_new_cb(undef, \&eof_read, undef, undef, 1);
 199   my $buffer;
 200   my $read_result = $eof_io->read($buffer, 10);
 201   is($read_result, 0, "read eof (scalar)");
 202   is($buffer, '', "check data");
 203   my @read_result = $eof_io->read($buffer, 10);
 204   is_deeply(\@read_result, [ 0 ], "read eof (list)");
 205   is($buffer, '', "check data");
 206 }
 207
 208 { # no callbacks
 209   my $none_io = Imager::io_new_cb(undef, undef, undef, undef, 0);
 210   is($none_io->write("test"), -1, "write with no writecb should fail");
 211   my $buffer;
 212   is($none_io->read($buffer, 10), undef, "read with no readcb should fail");
 213   is($none_io->seek(0, SEEK_SET), -1, "seek with no seekcb should fail");
 214 }
 215
 216 SKIP:
 217 { # make sure we croak when trying to write a string with characters over 0xff
 218   # the write callback shouldn't get called
 219   skip("no native UTF8 support in this version of perl", 2)
 220     unless $] >= 5.006;
 221   my $io = Imager::io_new_cb(\&good_write, undef, undef, 1);
 222   my $data = chr(0x100);
 223   is(ord $data, 0x100, "make sure we got what we expected");
 224   my $result =
 225     eval {
 226       $io->write($data);
 227     };
 228   ok($@, "should have croaked")
 229     and print "# $@\n";
 230 }
 231
 232 { # 0.52 left some debug code in a path that wasn't tested, make sure
 233   # that path is tested
 234   # http://rt.cpan.org/Ticket/Display.html?id=20705
 235   my $io = Imager::io_new_cb
 236     (
 237      sub {
 238        print "# write $_[0]\n";
 239        1
 240      },
 241      sub {
 242        print "# read $_[0], $_[1]\n";
 243        "x" x $_[1]
 244      },
 245      sub { print "# seek\n"; 0 },
 246      sub { print "# close\n"; 1 });
 247   my $buffer;
 248   is($io->read($buffer, 10), 10, "read 10");
 249   is($buffer, "xxxxxxxxxx", "read value");
 250   ok($io->write("foo"), "write");
 251   is($io->close, 0, "close");
 252 }
 253
 254 sub eof_read {
 255   my ($max_len) = @_;
 256
 257   return '';
 258 }
 259
 260 sub good_read {
 261   my ($max_len) = @_;
 262
 263   my $data = "testdata";
 264   length $data <= $max_len or substr($data, $max_len) = '';
 265
 266   print "# good_read ($max_len) => $data\n";
 267
 268   return $data;
 269 }
 270
 271 sub fail_write {
 272   return;
 273 }
 274
 275 sub fail_read {
 276   return;
 277 }
 278
 279 sub fail_seek {
 280   return -1;
 281 }