t/t101jpeg.t

   1 #!perl -w
   2 use strict;
   3 use Imager qw(:all);
   4 use Test::More;
   5 use Imager::Test qw(is_color_close3 test_image_raw);
   6
   7 init_log("testout/t101jpeg.log",1);
   8
   9 i_has_format("jpeg")
  10   or plan skip_all => "no jpeg support";
  11
  12 plan tests => 94;
  13
  14 my $green=i_color_new(0,255,0,255);
  15 my $blue=i_color_new(0,0,255,255);
  16 my $red=i_color_new(255,0,0,255);
  17
  18 my $img=test_image_raw();
  19 my $cmpimg=Imager::ImgRaw::new(150,150,3);
  20
  21 open(FH,">testout/t101.jpg")
  22   || die "cannot open testout/t101.jpg for writing\n";
  23 binmode(FH);
  24 my $IO = Imager::io_new_fd(fileno(FH));
  25 ok(i_writejpeg_wiol($img,$IO,30), "write jpeg low level");
  26 close(FH);
  27
  28 open(FH, "testout/t101.jpg") || die "cannot open testout/t101.jpg\n";
  29 binmode(FH);
  30 $IO = Imager::io_new_fd(fileno(FH));
  31 ($cmpimg,undef) = i_readjpeg_wiol($IO);
  32 close(FH);
  33
  34 my $diff = sqrt(i_img_diff($img,$cmpimg))/150*150;
  35 print "# jpeg average mean square pixel difference: ",$diff,"\n";
  36 ok($cmpimg, "read jpeg low level");
  37
  38 ok($diff < 10000, "difference between original and jpeg within bounds");
  39
  40 Imager::i_log_entry("Starting 4\n", 1);
  41 my $imoo = Imager->new;
  42 ok($imoo->read(file=>'testout/t101.jpg'), "read jpeg OO");
  43
  44 ok($imoo->write(file=>'testout/t101_oo.jpg'), "write jpeg OO");
  45 Imager::i_log_entry("Starting 5\n", 1);
  46 my $oocmp = Imager->new;
  47 ok($oocmp->read(file=>'testout/t101_oo.jpg'), "read jpeg OO for comparison");
  48
  49 $diff = sqrt(i_img_diff($imoo->{IMG},$oocmp->{IMG}))/150*150;
  50 print "# OO image difference $diff\n";
  51 ok($diff < 10000, "difference between original and jpeg within bounds");
  52
  53 # write failure test
  54 open FH, "< testout/t101.jpg" or die "Cannot open testout/t101.jpg: $!";
  55 binmode FH;
  56 ok(!$imoo->write(fd=>fileno(FH), type=>'jpeg'), 'failure handling');
  57 close FH;
  58 print "# ",$imoo->errstr,"\n";
  59
  60 # check that the i_format tag is set
  61 my @fmt = $imoo->tags(name=>'i_format');
  62 is($fmt[0], 'jpeg', 'i_format tag');
  63
  64 { # check file limits are checked
  65   my $limit_file = "testout/t101.jpg";
  66   ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
  67   my $im = Imager->new;
  68   ok(!$im->read(file=>$limit_file),
  69      "should fail read due to size limits");
  70   print "# ",$im->errstr,"\n";
  71   like($im->errstr, qr/image width/, "check message");
  72
  73   ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
  74   ok(!$im->read(file=>$limit_file),
  75      "should fail read due to size limits");
  76   print "# ",$im->errstr,"\n";
  77   like($im->errstr, qr/image height/, "check message");
  78
  79   ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
  80   ok($im->read(file=>$limit_file),
  81      "should succeed - just inside width limit");
  82   ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
  83   ok($im->read(file=>$limit_file),
  84      "should succeed - just inside height limit");
  85
  86   # 150 x 150 x 3 channel image uses 67500 bytes
  87   ok(Imager->set_file_limits(reset=>1, bytes=>67499),
  88      "set bytes limit 67499");
  89   ok(!$im->read(file=>$limit_file),
  90        "should fail - too many bytes");
  91   print "# ",$im->errstr,"\n";
  92   like($im->errstr, qr/storage size/, "check error message");
  93   ok(Imager->set_file_limits(reset=>1, bytes=>67500),
  94      "set bytes limit 67500");
  95   ok($im->read(file=>$limit_file),
  96      "should succeed - just inside bytes limit");
  97   Imager->set_file_limits(reset=>1);
  98 }
  99
 100 SKIP:
 101 {
 102   # we don't test them all
 103   my %expected_tags =
 104     (
 105      exif_date_time_original => "2005:11:25 00:00:00",
 106      exif_flash => 0,
 107      exif_image_description => "Imager Development Notes",
 108      exif_make => "Canon",
 109      exif_model => "CanoScan LiDE 35",
 110      exif_resolution_unit => 2,
 111      exif_resolution_unit_name => "inches",
 112      exif_user_comment => "        Part of notes from reworking i_arc() and friends.",
 113      exif_white_balance => 0,
 114      exif_white_balance_name => "Auto white balance",
 115     );
 116
 117   # exif tests
 118   Imager::i_exif_enabled()
 119       or skip("no exif support", scalar keys %expected_tags);
 120
 121   my $im = Imager->new;
 122   $im->read(file=>"testimg/exiftest.jpg")
 123     or skip("Could not read test image:".$im->errstr, scalar keys %expected_tags);
 124
 125   for my $key (keys %expected_tags) {
 126     is($expected_tags{$key}, $im->tags(name => $key),
 127        "test value of exif tag $key");
 128   }
 129 }
 130
 131 {
 132   # tests that the density values are set and read correctly
 133   # tests jpeg_comment too
 134   my @density_tests =
 135     (
 136      [ 't101cm100.jpg',
 137        {
 138         jpeg_density_unit => 2,
 139         i_xres => 254,
 140         i_yres => 254
 141        },
 142        {
 143         jpeg_density_unit => 2,
 144         i_xres => 254,
 145         i_yres => 254,
 146         i_aspect_only => undef,
 147        },
 148      ],
 149      [
 150       't101xonly.jpg',
 151       {
 152        i_xres => 100,
 153       },
 154       {
 155        i_xres => 100,
 156        i_yres => 100,
 157        jpeg_density_unit => 1,
 158        i_aspect_only => undef,
 159       },
 160      ],
 161      [
 162       't101yonly.jpg',
 163       {
 164        i_yres => 100,
 165       },
 166       {
 167        i_xres => 100,
 168        i_yres => 100,
 169        jpeg_density_unit => 1,
 170        i_aspect_only => undef,
 171       },
 172      ],
 173      [
 174       't101asponly.jpg',
 175       {
 176        i_xres => 50,
 177        i_yres => 100,
 178        i_aspect_only => 1,
 179       },
 180       {
 181        i_xres => 50,
 182        i_yres => 100,
 183        i_aspect_only => 1,
 184        jpeg_density_unit => 0,
 185       },
 186      ],
 187      [
 188       't101com.jpg',
 189       {
 190        jpeg_comment => 'test comment'
 191       },
 192      ],
 193     );
 194
 195   print "# test density tags\n";
 196   # I don't care about the content
 197   my $base_im = Imager->new(xsize => 10, ysize => 10);
 198   for my $test (@density_tests) {
 199     my ($filename, $out_tags, $expect_tags) = @$test;
 200     $expect_tags ||= $out_tags;
 201
 202     my $work = $base_im->copy;
 203     for my $key (keys %$out_tags) {
 204       $work->addtag(name => $key, value => $out_tags->{$key});
 205     }
 206
 207     ok($work->write(file=>"testout/$filename", type=>'jpeg'),
 208        "save $filename");
 209
 210     my $check = Imager->new;
 211     ok($check->read(file=> "testout/$filename"),
 212        "read $filename");
 213
 214     my %tags;
 215     for my $key (keys %$expect_tags) {
 216       $tags{$key} = $check->tags(name=>$key);
 217     }
 218     is_deeply($expect_tags, \%tags, "check tags for $filename");
 219   }
 220 }
 221
 222 { # Issue # 17981
 223   # the test image has a zero-length user_comment field
 224   # the code would originally attempt to convert '\0' to ' '
 225   # for the first 8 bytes, even if the string was less than
 226   # 8 bytes long
 227   my $im = Imager->new;
 228   ok($im->read(file => 'testimg/209_yonge.jpg', type=>'jpeg'),
 229      "test read of image with invalid exif_user_comment");
 230   is($im->tags(name=>'exif_user_comment'), '',
 231      "check exif_user_comment set correctly");
 232 }
 233
 234 { # test parseiptc handling no IPTC data correctly
 235   my $saw_warn;
 236   local $SIG{__WARN__} =
 237     sub {
 238       ++$saw_warn;
 239       print "# @_\n";
 240     };
 241   my $im = Imager->new;
 242   ok($im->read(file => 'testout/t101.jpg', type=>'jpeg'),
 243      "read jpeg with no IPTC data");
 244   ok(!defined $im->{IPTCRAW}, "no iptc data");
 245   my %iptc = $im->parseiptc;
 246   ok(!$saw_warn, "should be no warnings");
 247 }
 248
 249 { # Issue # 18397
 250   # attempting to write a 4 channel image to a bufchain would
 251   # cause a seg fault.
 252   # it should fail still
 253   # overridden by # 29876
 254   # give 4/2 channel images a background color when saving to JPEG
 255   my $im = Imager->new(xsize => 16, ysize => 16, channels => 4);
 256   $im->box(filled => 1, xmin => 8, color => '#FFE0C0');
 257   my $data;
 258   ok($im->write(data => \$data, type => 'jpeg'),
 259      "should write with a black background");
 260   my $imread = Imager->new;
 261   ok($imread->read(data => $data, type => 'jpeg'), 'read it back');
 262   is_color_close3($imread->getpixel('x' => 0, 'y' => 0), 0, 0, 0, 4,
 263                   "check it's black");
 264   is_color_close3($imread->getpixel('x' => 15, 'y' => 9), 255, 224, 192, 4,
 265                   "check filled area filled");
 266
 267   # write with a red background
 268   $data = '';
 269   ok($im->write(data => \$data, type => 'jpeg', i_background => '#FF0000'),
 270      "write with red background");
 271   ok($imread->read(data => $data, type => 'jpeg'), "read it back");
 272   is_color_close3($imread->getpixel('x' => 0, 'y' => 0), 255, 0, 0, 4,
 273                   "check it's red");
 274   is_color_close3($imread->getpixel('x' => 15, 'y' => 9), 255, 224, 192, 4,
 275                   "check filled area filled");
 276 }
 277 SKIP:
 278 { # Issue # 18496
 279   # If a jpeg with EXIF data containing an (invalid) IFD entry with a
 280   # type of zero is read then Imager crashes with a Floating point
 281   # exception
 282   # testimg/zerojpeg.jpg was manually modified from exiftest.jpg to
 283   # reproduce the problem.
 284   Imager::i_exif_enabled()
 285       or skip("no exif support", 1);
 286   my $im = Imager->new;
 287   ok($im->read(file=>'testimg/zerotype.jpg'), "shouldn't crash");
 288 }
 289
 290 SKIP:
 291 { # code coverage - make sure wiol_skip_input_data is called
 292   open BASEDATA, "< testimg/exiftest.jpg"
 293     or skip "can't open base data", 1;
 294   binmode BASEDATA;
 295   my $data = do { local $/; <BASEDATA> };
 296   close BASEDATA;
 297
 298   substr($data, 3, 1) eq "\xE1"
 299     or skip "base data isn't as expected", 1;
 300   # inserting a lot of marker data here means we take the branch in
 301   # wiol_skip_input_data that refills the buffer
 302   my $marker = "\xFF\xE9"; # APP9 marker
 303   $marker .= pack("n", 8192) . "x" x 8190;
 304   $marker x= 10; # make it take up a lot of space
 305   substr($data, 2, 0) = $marker;
 306   my $im = Imager->new;
 307   ok($im->read(data => $data), "read with a skip of data");
 308 }
 309
 310 SKIP:
 311 { # code coverage - take the branch that provides a fake EOI
 312   open BASEDATA, "< testimg/exiftest.jpg"
 313     or skip "can't open base data", 1;
 314   binmode BASEDATA;
 315   my $data = do { local $/; <BASEDATA> };
 316   close BASEDATA;
 317   substr($data, -1000) = '';
 318
 319   my $im = Imager->new;
 320   ok($im->read(data => $data), "read with image data truncated");
 321 }
 322
 323 { # code coverage - make sure wiol_empty_output_buffer is called
 324   my $im = Imager->new(xsize => 1000, ysize => 1000);
 325   for my $x (0 .. 999) {
 326     $im->line(x1 => $x, y1 => 0, x2 => $x, y2 => 999,
 327               color => Imager::Color->new(rand 256, rand 256, rand 256));
 328   }
 329   my $data;
 330   ok($im->write(data => \$data, type=>'jpeg', jpegquality => 100),
 331      "write big file to ensure wiol_empty_output_buffer is called");
 332
 333   # code coverage - write failure path in wiol_empty_output_buffer
 334   ok(!$im->write(callback => sub { return },
 335                  type => 'jpeg', jpegquality => 100),
 336      "fail to write")
 337     and print "# ", $im->errstr, "\n";
 338 }
 339
 340 { # code coverage - virtual image branch in i_writejpeg_wiol()
 341   my $im = $imoo->copy;
 342   my $immask = $im->masked;
 343   ok($immask, "made a virtual image (via masked)");
 344   ok($immask->virtual, "check it's virtual");
 345   my $mask_data;
 346   ok($immask->write(data => \$mask_data, type => 'jpeg'),
 347      "write masked version");
 348   my $base_data;
 349   ok($im->write(data => \$base_data, type=>'jpeg'),
 350      "write normal version");
 351   is($base_data, $mask_data, "check the data written matches");
 352 }
 353
 354 SKIP:
 355 { # code coverage - IPTC data
 356   # this is dummy data
 357   my $iptc = "\x04\x04" .
 358     "\034\002x   My Caption"
 359       . "\034\002P   Tony Cook"
 360         . "\034\002i   Dummy Headline!"
 361           . "\034\002n   No Credit Given";
 362
 363   my $app13 = "\xFF\xED" . pack("n", 2 + length $iptc) . $iptc;
 364
 365   open BASEDATA, "< testimg/exiftest.jpg"
 366     or skip "can't open base data", 1;
 367   binmode BASEDATA;
 368   my $data = do { local $/; <BASEDATA> };
 369   close BASEDATA;
 370   substr($data, 2, 0) = $app13;
 371
 372   my $im = Imager->new;
 373   ok($im->read(data => $data), "read with app13 data");
 374   my %iptc = $im->parseiptc;
 375   is($iptc{caption}, 'My Caption', 'check iptc caption');
 376   is($iptc{photogr}, 'Tony Cook', 'check iptc photogr');
 377   is($iptc{headln}, 'Dummy Headline!', 'check iptc headln');
 378   is($iptc{credit}, 'No Credit Given', 'check iptc credit');
 379 }
 380
 381 { # handling of CMYK jpeg
 382   # http://rt.cpan.org/Ticket/Display.html?id=20416
 383   my $im = Imager->new;
 384   ok($im->read(file => 'testimg/scmyk.jpg'), 'read a CMYK jpeg');
 385   is($im->getchannels, 3, "check channel count");
 386   my $col = $im->getpixel(x => 0, 'y' => 0);
 387   ok($col, "got the 'black' pixel");
 388   # this is jpeg, so we can't compare colors exactly
 389   # older versions returned this pixel at a light color, but
 390   # it's black in the image
 391   my ($r, $g, $b) = $col->rgba;
 392   cmp_ok($r, '<', 10, 'black - red low');
 393   cmp_ok($g, '<', 10, 'black - green low');
 394   cmp_ok($b, '<', 10, 'black - blue low');
 395   $col = $im->getpixel(x => 15, 'y' => 0);
 396   ok($col, "got the dark blue");
 397   ($r, $g, $b) = $col->rgba;
 398   cmp_ok($r, '<', 10, 'dark blue - red low');
 399   cmp_ok($g, '<', 10, 'dark blue - green low');
 400   cmp_ok($b, '>', 110, 'dark blue - blue middle (bottom)');
 401   cmp_ok($b, '<', 130, 'dark blue - blue middle (top)');
 402   $col = $im->getpixel(x => 0, 'y' => 15);
 403   ok($col, "got the red");
 404   ($r, $g, $b) = $col->rgba;
 405   cmp_ok($r, '>', 245, 'red - red high');
 406   cmp_ok($g, '<', 10, 'red - green low');
 407   cmp_ok($b, '<', 10, 'red - blue low');
 408 }
 409
 410 {
 411   ok(grep($_ eq 'jpeg', Imager->read_types), "check jpeg in read types");
 412   ok(grep($_ eq 'jpeg', Imager->write_types), "check jpeg in write types");
 413 }
 414
 415