t/t07iolayer.t

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