t/200-file/300-raw.t

   1 #!perl -w
   2 use strict;
   3 use Test::More tests => 56;
   4 use Imager qw(:all);
   5 use Imager::Test qw/is_color3 is_color4 test_image test_image_mono is_image/;
   6
   7 -d "testout" or mkdir "testout";
   8
   9 Imager->open_log(log => "testout/t103raw.log");
  10
  11 $| = 1;
  12
  13 my $green=i_color_new(0,255,0,255);
  14 my $blue=i_color_new(0,0,255,255);
  15 my $red=i_color_new(255,0,0,255);
  16
  17 my $img=Imager::ImgRaw::new(150,150,3);
  18 my $cmpimg=Imager::ImgRaw::new(150,150,3);
  19
  20 i_box_filled($img,70,25,130,125,$green);
  21 i_box_filled($img,20,25,80,125,$blue);
  22 i_arc($img,75,75,30,0,361,$red);
  23 i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
  24
  25 my $timg = Imager::ImgRaw::new(20, 20, 4);
  26 my $trans = i_color_new(255, 0, 0, 127);
  27 i_box_filled($timg, 0, 0, 20, 20, $green);
  28 i_box_filled($timg, 2, 2, 18, 18, $trans);
  29
  30 open(FH,">testout/t103.raw") || die "Cannot open testout/t103.raw for writing\n";
  31 binmode(FH);
  32 my $IO = Imager::io_new_fd( fileno(FH) );
  33 ok(i_writeraw_wiol($img, $IO), "write raw low") or
  34   print "# Cannot write testout/t103.raw\n";
  35 close(FH);
  36
  37 open(FH,"testout/t103.raw") || die "Cannot open testout/t103.raw\n";
  38 binmode(FH);
  39 $IO = Imager::io_new_fd( fileno(FH) );
  40 $cmpimg = i_readraw_wiol($IO, 150, 150, 3, 3, 0);
  41 ok($cmpimg, "read raw low")
  42   or print "# Cannot read testout/t103.raw\n";
  43 close(FH);
  44
  45 print "# raw average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
  46
  47 # I could have kept the raw images for these tests in binary files in
  48 # testimg/, but I think keeping them as hex encoded data in here makes
  49 # it simpler to add more if necessary
  50 # Later we may change this to read from a scalar instead
  51 save_data('testout/t103_base.raw');
  52 save_data('testout/t103_3to4.raw');
  53 save_data('testout/t103_line_int.raw');
  54 save_data('testout/t103_img_int.raw');
  55
  56 # load the base image
  57 open FH, "testout/t103_base.raw"
  58   or die "Cannot open testout/t103_base.raw: $!";
  59 binmode FH;
  60 $IO = Imager::io_new_fd( fileno(FH) );
  61
  62 my $baseimg = i_readraw_wiol( $IO, 4, 4, 3, 3, 0);
  63 ok($baseimg, "read base raw image")
  64   or die "Cannot read base raw image";
  65 close FH;
  66
  67 # the actual read tests
  68 # each read_test() call does 2 tests:
  69 #  - check if the read succeeds
  70 #  - check if it matches $baseimg
  71 read_test('testout/t103_3to4.raw', 4, 4, 4, 3, 0, $baseimg);
  72 read_test('testout/t103_line_int.raw', 4, 4, 3, 3, 1, $baseimg);
  73 # intrl==2 is documented in raw.c but doesn't seem to be implemented
  74 #read_test('testout/t103_img_int.raw', 4, 4, 3, 3, 2, $baseimg, 7);
  75
  76 # paletted images
  77 SKIP:
  78 {
  79   my $palim = Imager::i_img_pal_new(20, 20, 3, 256);
  80   ok($palim, "make paletted image")
  81     or skip("couldn't make paletted image", 2);
  82   my $redindex = Imager::i_addcolors($palim, $red);
  83   my $blueindex = Imager::i_addcolors($palim, $blue);
  84   for my $y (0..9) {
  85     Imager::i_ppal($palim, 0, $y, ($redindex) x 20);
  86   }
  87   for my $y (10..19) {
  88     Imager::i_ppal($palim, 0, $y, ($blueindex) x 20);
  89   }
  90   open FH, "> testout/t103_pal.raw"
  91     or die "Cannot create testout/t103_pal.raw: $!";
  92   binmode FH;
  93   $IO = Imager::io_new_fd(fileno(FH));
  94   ok(i_writeraw_wiol($palim, $IO), "write low paletted");
  95   close FH;
  96
  97   open FH, "testout/t103_pal.raw"
  98     or die "Cannot open testout/t103_pal.raw: $!";
  99   binmode FH;
 100   my $data = do { local $/; <FH> };
 101   is($data, "\x0" x 200 . "\x1" x 200, "compare paletted data written");
 102   close FH;
 103 }
 104
 105 # 16-bit image
 106 # we don't have 16-bit reads yet
 107 SKIP:
 108 {
 109   my $img16 = Imager::i_img_16_new(150, 150, 3);
 110   ok($img16, "make 16-bit/sample image")
 111     or skip("couldn't make 16 bit/sample image", 1);
 112   i_box_filled($img16,70,25,130,125,$green);
 113   i_box_filled($img16,20,25,80,125,$blue);
 114   i_arc($img16,75,75,30,0,361,$red);
 115   i_conv($img16,[0.1, 0.2, 0.4, 0.2, 0.1]);
 116
 117   open FH, "> testout/t103_16.raw"
 118     or die "Cannot create testout/t103_16.raw: $!";
 119   binmode FH;
 120   $IO = Imager::io_new_fd(fileno(FH));
 121   ok(i_writeraw_wiol($img16, $IO), "write low 16 bit image");
 122   close FH;
 123 }
 124
 125 # try a simple virtual image
 126 SKIP:
 127 {
 128   my $maskimg = Imager::i_img_masked_new($img, undef, 0, 0, 150, 150);
 129   ok($maskimg, "make masked image")
 130     or skip("couldn't make masked image", 3);
 131
 132   open FH, "> testout/t103_virt.raw"
 133     or die "Cannot create testout/t103_virt.raw: $!";
 134   binmode FH;
 135   $IO = Imager::io_new_fd(fileno(FH));
 136   ok(i_writeraw_wiol($maskimg, $IO), "write virtual raw");
 137   close FH;
 138
 139   open FH, "testout/t103_virt.raw"
 140     or die "Cannot open testout/t103_virt.raw: $!";
 141   binmode FH;
 142   $IO = Imager::io_new_fd(fileno(FH));
 143   my $cmpimgmask = i_readraw_wiol($IO, 150, 150, 3, 3, 0);
 144   ok($cmpimgmask, "read result of masked write");
 145   my $diff = i_img_diff($maskimg, $cmpimgmask);
 146   print "# difference for virtual image $diff\n";
 147   is($diff, 0, "compare masked to read");
 148
 149   # check that i_format is set correctly
 150   my $index = Imager::i_tags_find($cmpimgmask, 'i_format', 0);
 151   if ($index) {
 152     my $value = Imager::i_tags_get($cmpimgmask, $index);
 153     is($value, 'raw', "check i_format value");
 154   }
 155   else {
 156     fail("couldn't find i_format tag");
 157   }
 158 }
 159
 160 { # error handling checks
 161   # should get an error writing to a open for read file
 162   # make a empty file
 163   open RAW, "> testout/t103_empty.raw"
 164     or die "Cannot create testout/t103_empty.raw: $!";
 165   close RAW;
 166   open RAW, "< testout/t103_empty.raw"
 167     or die "Cannot open testout/t103_empty.raw: $!";
 168   my $im = Imager->new(xsize => 50, ysize=>50);
 169   ok(!$im->write(fh => \*RAW, type => 'raw', buffered => 0),
 170      "write to open for read handle");
 171   cmp_ok($im->errstr, '=~', '^Could not write to file: write\(\) failure',
 172          "check error message");
 173   close RAW;
 174
 175   # should get an error reading an empty file
 176   ok(!$im->read(file => 'testout/t103_empty.raw', xsize => 50, ysize=>50, type=>'raw', interleave => 1),
 177      'read an empty file');
 178   is($im->errstr, 'premature end of file', "check message");
 179  SKIP:
 180   {
 181     # see 862083f7e40bc2a9e3b94aedce56c1336e7bdb25 in perl5 git
 182     $] >= 5.010
 183       or skip "5.8.x and earlier don't treat a read on a WRONLY file as an error", 2;
 184     open RAW, "> testout/t103_empty.raw"
 185       or die "Cannot create testout/t103_empty.raw: $!";
 186     ok(!$im->read(fh => \*RAW, , xsize => 50, ysize=>50, type=>'raw', interleave => 1),
 187        'read a file open for write');
 188     cmp_ok($im->errstr, '=~', '^error reading file: read\(\) failure', "check message");
 189     close RAW; # avoid a message on 5.22+
 190   }
 191 }
 192
 193
 194 {
 195   ok(grep($_ eq 'raw', Imager->read_types), "check raw in read types");
 196   ok(grep($_ eq 'raw', Imager->write_types), "check raw in write types");
 197 }
 198
 199
 200 { # OO no interleave warning
 201   my $im = Imager->new;
 202   my $msg;
 203   local $SIG{__WARN__} = sub { $msg = "@_" };
 204   ok($im->read(file => "testout/t103_line_int.raw", xsize => 4, ysize => 4,
 205                type => "raw"),
 206      "read without interleave parameter")
 207     or print "# ", $im->errstr, "\n";
 208   ok($msg, "should have warned");
 209   like($msg, qr/interleave/, "check warning is ok");
 210   # check we got the right value
 211   is_color3($im->getpixel(x => 0, y => 0), 0x00, 0x11, 0x22,
 212             "check the image was read correctly");
 213
 214   # check no warning if either is supplied
 215   $im = Imager->new;
 216   undef $msg;
 217   ok($im->read(file => "testout/t103_base.raw", xsize => 4, ysize => 4, type => "raw", interleave => 0),
 218      "read with interleave 0");
 219   is($msg, undef, "no warning");
 220   is_color3($im->getpixel(x => 0, y => 0), 0x00, 0x11, 0x22,
 221             "check read non-interleave");
 222
 223   $im = Imager->new;
 224   undef $msg;
 225   ok($im->read(file => "testout/t103_base.raw", xsize => 4, ysize => 4, type => "raw", raw_interleave => 0),
 226      "read with raw_interleave 0");
 227   is($msg, undef, "no warning");
 228   is_color3($im->getpixel(x => 1, y => 0), 0x01, 0x12, 0x23,
 229             "check read non-interleave");
 230
 231   # make sure set to 1 is sane
 232   $im = Imager->new;
 233   undef $msg;
 234   ok($im->read(file => "testout/t103_line_int.raw", xsize => 4, ysize => 4, type => "raw", raw_interleave => 1),
 235      "read with raw_interleave 1");
 236   is($msg, undef, "no warning");
 237   is_color3($im->getpixel(x => 2, y => 0), 0x02, 0x13, 0x24,
 238             "check read interleave = 1");
 239 }
 240
 241 { # invalid interleave error handling
 242   my $im = Imager->new;
 243   ok(!$im->read(file => "testout/t103_base.raw", raw_interleave => 2, type => "raw", xsize => 4, ysize => 4),
 244      "invalid interleave");
 245   is($im->errstr, "raw_interleave must be 0 or 1", "check message");
 246 }
 247
 248 { # store/data channel behaviour
 249   my $im = Imager->new;
 250   ok($im->read(file => "testout/t103_3to4.raw", xsize => 4, ysize => 4,
 251                raw_datachannels => 4, raw_interleave => 0, type => "raw"),
 252      "read 4 channel file as 3 channels")
 253     or print "# ", $im->errstr, "\n";
 254   is_color3($im->getpixel(x => 2, y => 1), 0x12, 0x23, 0x34,
 255             "check read correctly");
 256 }
 257
 258 { # should fail to read with storechannels > 4
 259   my $im = Imager->new;
 260   ok(!$im->read(file => "testout/t103_line_int.raw", type => "raw",
 261                 raw_interleave => 1, xsize => 4, ysize => 4,
 262                 raw_storechannels => 5),
 263      "read with large storechannels");
 264   is($im->errstr, "raw_storechannels must be between 1 and 4",
 265      "check error message");
 266 }
 267
 268 { # should zero spare channels if storechannels > datachannels
 269   my $im = Imager->new;
 270   ok($im->read(file => "testout/t103_base.raw", type => "raw",
 271                 raw_interleave => 0, xsize => 4, ysize => 4,
 272                 raw_storechannels => 4),
 273      "read with storechannels > datachannels");
 274   is($im->getchannels, 4, "should have 4 channels");
 275   is_color4($im->getpixel(x => 2, y => 1), 0x12, 0x23, 0x34, 0x00,
 276             "check last channel zeroed");
 277 }
 278
 279 {
 280   my @ims = ( basic => test_image(), mono => test_image_mono() );
 281   push @ims, masked => test_image()->masked();
 282
 283   my $fail_close = sub {
 284     Imager::i_push_error(0, "synthetic close failure");
 285     return 0;
 286   };
 287
 288   while (my ($type, $im) = splice(@ims, 0, 2)) {
 289     my $io = Imager::io_new_cb(sub { 1 }, undef, undef, $fail_close);
 290     ok(!$im->write(io => $io, type => "raw"),
 291        "write $type image with a failing close handler");
 292     like($im->errstr, qr/synthetic close failure/,
 293          "check error message");
 294   }
 295 }
 296
 297 { # https://rt.cpan.org/Ticket/Display.html?id=106836
 298   my $im = test_image;
 299   my $data;
 300   ok($im->write(data => \$data, type => "raw", raw_interleave => 0), "save some raw image")
 301     or diag $im->errstr;
 302   my $im2 = Imager->new
 303     (
 304      data => \$data,
 305      filetype => "raw",
 306      xsize => $im->getwidth,
 307      ysize => $im->getheight,
 308      raw_datachannels => $im->getchannels,
 309      raw_storechannels => $im->getchannels,
 310      raw_interleave => 0,
 311     );
 312   ok($im2, "read raw image using new() method");
 313   is_image($im, $im2, "check they match");
 314 }
 315
 316 Imager->close_log;
 317
 318 unless ($ENV{IMAGER_KEEP_FILES}) {
 319   unlink "testout/t103raw.log";
 320   unlink(qw(testout/t103_base.raw testout/t103_3to4.raw
 321             testout/t103_line_int.raw testout/t103_img_int.raw))
 322 }
 323
 324 sub read_test {
 325   my ($in, $xsize, $ysize, $data, $store, $intrl, $base) = @_;
 326   open FH, $in or die "Cannot open $in: $!";
 327   binmode FH;
 328   my $IO = Imager::io_new_fd( fileno(FH) );
 329
 330   my $img = i_readraw_wiol($IO, $xsize, $ysize, $data, $store, $intrl);
 331  SKIP:
 332   {
 333     ok($img, "read_test $in read")
 334       or skip("couldn't read $in", 1);
 335     is(i_img_diff($img, $baseimg), 0, "read_test $in compare");
 336   }
 337 }
 338
 339 sub save_data {
 340   my $outname = shift;
 341   my $data = load_data();
 342   open FH, "> $outname" or die "Cannot create $outname: $!";
 343   binmode FH;
 344   print FH $data;
 345   close FH;
 346 }
 347
 348 sub load_data {
 349   my $hex = '';
 350   while (<DATA>) {
 351     next if /^#/;
 352     last if /^EOF/;
 353     chomp;
 354     $hex .= $_;
 355   }
 356   $hex =~ tr/ //d;
 357   my $result = pack("H*", $hex);
 358   #print unpack("H*", $result),"\n";
 359   return $result;
 360 }
 361
 362 # FIXME: may need tests for 1,2,4 channel images
 363
 364 __DATA__
 365 # we keep some packed raw images here
 366 # we decode this in the code, ignoring lines starting with #, a subfile
 367 # ends with EOF, data is HEX encoded (spaces ignored)
 368
 369 # basic 3 channel version of the image
 370 001122 011223 021324 031425
 371 102132 112233 122334 132435
 372 203142 213243 223344 233445
 373 304152 314253 324354 334455
 374 EOF
 375
 376 # test image for reading a 4 channel image into a 3 channel image
 377 # 4 x 4 pixels
 378 00112233 01122334 02132435 03142536
 379 10213243 11223344 12233445 13243546
 380 20314253 21324354 22334455 23344556
 381 30415263 31425364 32435465 33445566
 382 EOF
 383
 384 # test image for line based interlacing
 385 # 4 x 4 pixels
 386 # first line
 387 00 01 02 03
 388 11 12 13 14
 389 22 23 24 25
 390
 391 # second line
 392 10 11 12 13
 393 21 22 23 24
 394 32 33 34 35
 395
 396 # third line
 397 20 21 22 23
 398 31 32 33 34
 399 42 43 44 45
 400
 401 # fourth line
 402 30 31 32 33
 403 41 42 43 44
 404 52 53 54 55
 405
 406 EOF
 407
 408 # test image for image based interlacing
 409 # first channel
 410 00 01 02 03
 411 10 11 12 13
 412 20 21 22 23
 413 30 31 32 33
 414
 415 # second channel
 416 11 12 13 14
 417 21 22 23 24
 418 31 32 33 34
 419 41 42 43 44
 420
 421 # third channel
 422 22 23 24 25
 423 32 33 34 35
 424 42 43 44 45
 425 52 53 54 55
 426
 427 EOF