t/t07iolayer.t

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