t/t101jpeg.t

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