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