t/t101jpeg.t

   1 #!perl -w
   2 use strict;
   3 use Imager qw(:all);
   4 use Test::More tests => 86;
   5
   6 init_log("testout/t101jpeg.log",1);
   7
   8 my $green=i_color_new(0,255,0,255);
   9 my $blue=i_color_new(0,0,255,255);
  10 my $red=i_color_new(255,0,0,255);
  11
  12 my $img=Imager::ImgRaw::new(150,150,3);
  13 my $cmpimg=Imager::ImgRaw::new(150,150,3);
  14
  15 i_box_filled($img,70,25,130,125,$green);
  16 i_box_filled($img,20,25,80,125,$blue);
  17 i_arc($img,75,75,30,0,361,$red);
  18 i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
  19
  20 i_has_format("jpeg") && print "# has jpeg\n";
  21 if (!i_has_format("jpeg")) {
  22   # previously we'd crash if we tried to save/read an image via the OO
  23   # interface when there was no jpeg support
  24  SKIP:
  25   {
  26     my $im = Imager->new;
  27     ok(!$im->read(file=>"testimg/base.jpg"), "should fail to read jpeg");
  28     cmp_ok($im->errstr, '=~', qr/format 'jpeg' not supported/, "check no jpeg message");
  29     $im = Imager->new(xsize=>2, ysize=>2);
  30     ok(!$im->write(file=>"testout/nojpeg.jpg"), "should fail to write jpeg");
  31     cmp_ok($im->errstr, '=~', qr/format not supported/, "check no jpeg message");
  32     skip("no jpeg support", 82);
  33   }
  34 } else {
  35   open(FH,">testout/t101.jpg") || die "cannot open testout/t101.jpg for writing\n";
  36   binmode(FH);
  37   my $IO = Imager::io_new_fd(fileno(FH));
  38   ok(i_writejpeg_wiol($img,$IO,30), "write jpeg low level");
  39   close(FH);
  40
  41   open(FH, "testout/t101.jpg") || die "cannot open testout/t101.jpg\n";
  42   binmode(FH);
  43   $IO = Imager::io_new_fd(fileno(FH));
  44   ($cmpimg,undef) = i_readjpeg_wiol($IO);
  45   close(FH);
  46
  47   my $diff = sqrt(i_img_diff($img,$cmpimg))/150*150;
  48   print "# jpeg average mean square pixel difference: ",$diff,"\n";
  49   ok($cmpimg, "read jpeg low level");
  50
  51   ok($diff < 10000, "difference between original and jpeg within bounds");
  52
  53         Imager::i_log_entry("Starting 4\n", 1);
  54   my $imoo = Imager->new;
  55   ok($imoo->read(file=>'testout/t101.jpg'), "read jpeg OO");
  56
  57   ok($imoo->write(file=>'testout/t101_oo.jpg'), "write jpeg OO");
  58         Imager::i_log_entry("Starting 5\n", 1);
  59   my $oocmp = Imager->new;
  60   ok($oocmp->read(file=>'testout/t101_oo.jpg'), "read jpeg OO for comparison");
  61
  62   $diff = sqrt(i_img_diff($imoo->{IMG},$oocmp->{IMG}))/150*150;
  63   print "# OO image difference $diff\n";
  64   ok($diff < 10000, "difference between original and jpeg within bounds");
  65
  66   # write failure test
  67   open FH, "< testout/t101.jpg" or die "Cannot open testout/t101.jpg: $!";
  68   binmode FH;
  69   ok(!$imoo->write(fd=>fileno(FH), type=>'jpeg'), 'failure handling');
  70   close FH;
  71   print "# ",$imoo->errstr,"\n";
  72
  73   # check that the i_format tag is set
  74   my @fmt = $imoo->tags(name=>'i_format');
  75   is($fmt[0], 'jpeg', 'i_format tag');
  76
  77   { # check file limits are checked
  78     my $limit_file = "testout/t101.jpg";
  79     ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
  80     my $im = Imager->new;
  81     ok(!$im->read(file=>$limit_file),
  82        "should fail read due to size limits");
  83     print "# ",$im->errstr,"\n";
  84     like($im->errstr, qr/image width/, "check message");
  85
  86     ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
  87     ok(!$im->read(file=>$limit_file),
  88        "should fail read due to size limits");
  89     print "# ",$im->errstr,"\n";
  90     like($im->errstr, qr/image height/, "check message");
  91
  92     ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
  93     ok($im->read(file=>$limit_file),
  94        "should succeed - just inside width limit");
  95     ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
  96     ok($im->read(file=>$limit_file),
  97        "should succeed - just inside height limit");
  98
  99     # 150 x 150 x 3 channel image uses 67500 bytes
 100     ok(Imager->set_file_limits(reset=>1, bytes=>67499),
 101        "set bytes limit 67499");
 102     ok(!$im->read(file=>$limit_file),
 103        "should fail - too many bytes");
 104     print "# ",$im->errstr,"\n";
 105     like($im->errstr, qr/storage size/, "check error message");
 106     ok(Imager->set_file_limits(reset=>1, bytes=>67500),
 107        "set bytes limit 67500");
 108     ok($im->read(file=>$limit_file),
 109        "should succeed - just inside bytes limit");
 110     Imager->set_file_limits(reset=>1);
 111   }
 112
 113  SKIP:
 114   {
 115     # we don't test them all
 116     my %expected_tags =
 117       (
 118        exif_date_time_original => "2005:11:25 00:00:00",
 119        exif_flash => 0,
 120        exif_image_description => "Imager Development Notes",
 121        exif_make => "Canon",
 122        exif_model => "CanoScan LiDE 35",
 123        exif_resolution_unit => 2,
 124        exif_resolution_unit_name => "inches",
 125        exif_user_comment => "        Part of notes from reworking i_arc() and friends.",
 126        exif_white_balance => 0,
 127        exif_white_balance_name => "Auto white balance",
 128       );
 129
 130     # exif tests
 131     Imager::i_exif_enabled()
 132         or skip("no exif support", scalar keys %expected_tags);
 133
 134     my $im = Imager->new;
 135     $im->read(file=>"testimg/exiftest.jpg")
 136       or skip("Could not read test image:".$im->errstr, scalar keys %expected_tags);
 137
 138     for my $key (keys %expected_tags) {
 139       is($expected_tags{$key}, $im->tags(name => $key),
 140          "test value of exif tag $key");
 141     }
 142   }
 143
 144   {
 145     # tests that the density values are set and read correctly
 146     # tests jpeg_comment too
 147     my @density_tests =
 148       (
 149        [ 't101cm100.jpg',
 150          {
 151           jpeg_density_unit => 2,
 152           i_xres => 254,
 153           i_yres => 254
 154          },
 155          {
 156           jpeg_density_unit => 2,
 157           i_xres => 254,
 158           i_yres => 254,
 159           i_aspect_only => undef,
 160          },
 161        ],
 162        [
 163         't101xonly.jpg',
 164         {
 165          i_xres => 100,
 166         },
 167         {
 168          i_xres => 100,
 169          i_yres => 100,
 170          jpeg_density_unit => 1,
 171          i_aspect_only => undef,
 172         },
 173        ],
 174        [
 175         't101yonly.jpg',
 176         {
 177          i_yres => 100,
 178         },
 179         {
 180          i_xres => 100,
 181          i_yres => 100,
 182          jpeg_density_unit => 1,
 183          i_aspect_only => undef,
 184         },
 185        ],
 186        [
 187         't101asponly.jpg',
 188         {
 189          i_xres => 50,
 190          i_yres => 100,
 191          i_aspect_only => 1,
 192         },
 193         {
 194          i_xres => 50,
 195          i_yres => 100,
 196          i_aspect_only => 1,
 197          jpeg_density_unit => 0,
 198         },
 199        ],
 200        [
 201         't101com.jpg',
 202         {
 203          jpeg_comment => 'test comment'
 204         },
 205        ],
 206       );
 207
 208     print "# test density tags\n";
 209     # I don't care about the content
 210     my $base_im = Imager->new(xsize => 10, ysize => 10);
 211     for my $test (@density_tests) {
 212       my ($filename, $out_tags, $expect_tags) = @$test;
 213       $expect_tags ||= $out_tags;
 214
 215       my $work = $base_im->copy;
 216       for my $key (keys %$out_tags) {
 217         $work->addtag(name => $key, value => $out_tags->{$key});
 218       }
 219
 220       ok($work->write(file=>"testout/$filename", type=>'jpeg'),
 221          "save $filename");
 222
 223       my $check = Imager->new;
 224       ok($check->read(file=> "testout/$filename"),
 225          "read $filename");
 226
 227       my %tags;
 228       for my $key (keys %$expect_tags) {
 229         $tags{$key} = $check->tags(name=>$key);
 230       }
 231       is_deeply($expect_tags, \%tags, "check tags for $filename");
 232     }
 233   }
 234
 235   { # Issue # 17981
 236     # the test image has a zero-length user_comment field
 237     # the code would originally attempt to convert '\0' to ' '
 238     # for the first 8 bytes, even if the string was less than
 239     # 8 bytes long
 240     my $im = Imager->new;
 241     ok($im->read(file => 'testimg/209_yonge.jpg', type=>'jpeg'),
 242        "test read of image with invalid exif_user_comment");
 243     is($im->tags(name=>'exif_user_comment'), '',
 244        "check exif_user_comment set correctly");
 245   }
 246
 247   { # test parseiptc handling no IPTC data correctly
 248     my $saw_warn;
 249     local $SIG{__WARN__} =
 250       sub {
 251         ++$saw_warn;
 252         print "# @_\n";
 253       };
 254     my $im = Imager->new;
 255     ok($im->read(file => 'testout/t101.jpg', type=>'jpeg'),
 256        "read jpeg with no IPTC data");
 257     ok(!defined $im->{IPTCRAW}, "no iptc data");
 258     my %iptc = $im->parseiptc;
 259     ok(!$saw_warn, "should be no warnings");
 260   }
 261
 262   { # Issue # 18397
 263     # attempting to write a 4 channel image to a bufchain would
 264     # cause a seg fault.
 265     # it should fail still
 266     my $im = Imager->new(xsize => 10, ysize => 10, channels => 4);
 267     my $data;
 268     ok(!$im->write(data => \$data, type => 'jpeg'),
 269        "should fail to write but shouldn't crash");
 270     is($im->errstr, "only 1 or 3 channels images can be saved as JPEG",
 271        "check the error message");
 272   }
 273  SKIP:
 274   { # Issue # 18496
 275     # If a jpeg with EXIF data containing an (invalid) IFD entry with a
 276     # type of zero is read then Imager crashes with a Floating point
 277     # exception
 278     # testimg/zerojpeg.jpg was manually modified from exiftest.jpg to
 279     # reproduce the problem.
 280     Imager::i_exif_enabled()
 281         or skip("no exif support", 1);
 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