#!perl -w
use strict;
use Imager qw(:all);
use Test::More;
use Imager::Test qw(is_color_close3 test_image_raw test_image is_image);
-d "testout" or mkdir "testout";
init_log("testout/t101jpeg.log",1);
$Imager::formats{"jpeg"}
or plan skip_all => "no jpeg support";
plan tests => 109;
print STDERR "libjpeg version: ", Imager::File::JPEG::i_libjpeg_version(), "\n";
my $green=i_color_new(0,255,0,255);
my $blue=i_color_new(0,0,255,255);
my $red=i_color_new(255,0,0,255);
my $img=test_image_raw();
my $cmpimg=Imager::ImgRaw::new(150,150,3);
open(FH,">testout/t101.jpg")
|| die "cannot open testout/t101.jpg for writing\n";
binmode(FH);
my $IO = Imager::io_new_fd(fileno(FH));
ok(Imager::File::JPEG::i_writejpeg_wiol($img,$IO,30), "write jpeg low level");
close(FH);
open(FH, "testout/t101.jpg") || die "cannot open testout/t101.jpg\n";
binmode(FH);
$IO = Imager::io_new_fd(fileno(FH));
($cmpimg,undef) = Imager::File::JPEG::i_readjpeg_wiol($IO);
close(FH);
my $diff = sqrt(i_img_diff($img,$cmpimg))/150*150;
print "# jpeg average mean square pixel difference: ",$diff,"\n";
ok($cmpimg, "read jpeg low level");
ok($diff < 10000, "difference between original and jpeg within bounds");
Imager::i_log_entry("Starting 4\n", 1);
my $imoo = Imager->new;
ok($imoo->read(file=>'testout/t101.jpg'), "read jpeg OO");
ok($imoo->write(file=>'testout/t101_oo.jpg'), "write jpeg OO");
Imager::i_log_entry("Starting 5\n", 1);
my $oocmp = Imager->new;
ok($oocmp->read(file=>'testout/t101_oo.jpg'), "read jpeg OO for comparison");
$diff = sqrt(i_img_diff($imoo->{IMG},$oocmp->{IMG}))/150*150;
print "# OO image difference $diff\n";
ok($diff < 10000, "difference between original and jpeg within bounds");
# write failure test
open FH, "< testout/t101.jpg" or die "Cannot open testout/t101.jpg: $!";
binmode FH;
my $io = Imager::io_new_fd(fileno(FH));
$io->set_buffered(0);
ok(!$imoo->write(io => $io, type=>'jpeg'), 'failure handling');
close FH;
print "# ",$imoo->errstr,"\n";
# check that the i_format tag is set
my @fmt = $imoo->tags(name=>'i_format');
is($fmt[0], 'jpeg', 'i_format tag');
{ # check file limits are checked
my $limit_file = "testout/t101.jpg";
ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
my $im = Imager->new;
ok(!$im->read(file=>$limit_file),
"should fail read due to size limits");
print "# ",$im->errstr,"\n";
like($im->errstr, qr/image width/, "check message");
ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
ok(!$im->read(file=>$limit_file),
"should fail read due to size limits");
print "# ",$im->errstr,"\n";
like($im->errstr, qr/image height/, "check message");
ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
ok($im->read(file=>$limit_file),
"should succeed - just inside width limit");
ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
ok($im->read(file=>$limit_file),
"should succeed - just inside height limit");
# 150 x 150 x 3 channel image uses 67500 bytes
ok(Imager->set_file_limits(reset=>1, bytes=>67499),
"set bytes limit 67499");
ok(!$im->read(file=>$limit_file),
"should fail - too many bytes");
print "# ",$im->errstr,"\n";
like($im->errstr, qr/storage size/, "check error message");
ok(Imager->set_file_limits(reset=>1, bytes=>67500),
"set bytes limit 67500");
ok($im->read(file=>$limit_file),
"should succeed - just inside bytes limit");
Imager->set_file_limits(reset=>1);
}
SKIP:
{
# we don't test them all
my %expected_tags =
(
exif_date_time_original => "2005:11:25 00:00:00",
exif_flash => 0,
exif_image_description => "Imager Development Notes",
exif_make => "Canon",
exif_model => "CanoScan LiDE 35",
exif_resolution_unit => 2,
exif_resolution_unit_name => "inches",
exif_user_comment => " Part of notes from reworking i_arc() and friends.",
exif_white_balance => 0,
exif_white_balance_name => "Auto white balance",
);
my $im = Imager->new;
$im->read(file=>"testimg/exiftest.jpg")
or skip("Could not read test image:".$im->errstr, scalar keys %expected_tags);
for my $key (keys %expected_tags) {
is($expected_tags{$key}, $im->tags(name => $key),
"test value of exif tag $key");
}
}
{
# tests that the density values are set and read correctly
# tests jpeg_comment too
my @density_tests =
(
[ 't101cm100.jpg',
{
jpeg_density_unit => 2,
i_xres => 254,
i_yres => 254
},
{
jpeg_density_unit => 2,
i_xres => 254,
i_yres => 254,
i_aspect_only => undef,
},
],
[
't101xonly.jpg',
{
i_xres => 100,
},
{
i_xres => 100,
i_yres => 100,
jpeg_density_unit => 1,
i_aspect_only => undef,
},
],
[
't101yonly.jpg',
{
i_yres => 100,
},
{
i_xres => 100,
i_yres => 100,
jpeg_density_unit => 1,
i_aspect_only => undef,
},
],
[
't101asponly.jpg',
{
i_xres => 50,
i_yres => 100,
i_aspect_only => 1,
},
{
i_xres => 50,
i_yres => 100,
i_aspect_only => 1,
jpeg_density_unit => 0,
},
],
[
't101com.jpg',
{
jpeg_comment => 'test comment'
},
],
);
print "# test density tags\n";
# I don't care about the content
my $base_im = Imager->new(xsize => 10, ysize => 10);
for my $test (@density_tests) {
my ($filename, $out_tags, $expect_tags) = @$test;
$expect_tags ||= $out_tags;
my $work = $base_im->copy;
for my $key (keys %$out_tags) {
$work->addtag(name => $key, value => $out_tags->{$key});
}
ok($work->write(file=>"testout/$filename", type=>'jpeg'),
"save $filename");
my $check = Imager->new;
ok($check->read(file=> "testout/$filename"),
"read $filename");
my %tags;
for my $key (keys %$expect_tags) {
$tags{$key} = $check->tags(name=>$key);
}
is_deeply($expect_tags, \%tags, "check tags for $filename");
}
}
{ # Issue # 17981
# the test image has a zero-length user_comment field
# the code would originally attempt to convert '\0' to ' '
# for the first 8 bytes, even if the string was less than
# 8 bytes long
my $im = Imager->new;
ok($im->read(file => 'testimg/209_yonge.jpg', type=>'jpeg'),
"test read of image with invalid exif_user_comment");
is($im->tags(name=>'exif_user_comment'), '',
"check exif_user_comment set correctly");
}
{ # test parseiptc handling no IPTC data correctly
my $saw_warn;
local $SIG{__WARN__} =
sub {
++$saw_warn;
print "# @_\n";
};
my $im = Imager->new;
ok($im->read(file => 'testout/t101.jpg', type=>'jpeg'),
"read jpeg with no IPTC data");
ok(!defined $im->{IPTCRAW}, "no iptc data");
my %iptc = $im->parseiptc;
ok(!$saw_warn, "should be no warnings");
}
{ # Issue # 18397
# attempting to write a 4 channel image to a bufchain would
# cause a seg fault.
# it should fail still
# overridden by # 29876
# give 4/2 channel images a background color when saving to JPEG
my $im = Imager->new(xsize => 16, ysize => 16, channels => 4);
$im->box(filled => 1, xmin => 8, color => '#FFE0C0');
my $data;
ok($im->write(data => \$data, type => 'jpeg'),
"should write with a black background");
my $imread = Imager->new;
ok($imread->read(data => $data, type => 'jpeg'), 'read it back');
is_color_close3($imread->getpixel('x' => 0, 'y' => 0), 0, 0, 0, 4,
"check it's black");
is_color_close3($imread->getpixel('x' => 15, 'y' => 9), 255, 224, 192, 4,
"check filled area filled");
# write with a red background
$data = '';
ok($im->write(data => \$data, type => 'jpeg', i_background => '#FF0000'),
"write with red background");
ok($imread->read(data => $data, type => 'jpeg'), "read it back");
is_color_close3($imread->getpixel('x' => 0, 'y' => 0), 255, 0, 0, 4,
"check it's red");
is_color_close3($imread->getpixel('x' => 15, 'y' => 9), 255, 224, 192, 4,
"check filled area filled");
}
SKIP:
{ # Issue # 18496
# If a jpeg with EXIF data containing an (invalid) IFD entry with a
# type of zero is read then Imager crashes with a Floating point
# exception
# testimg/zerojpeg.jpg was manually modified from exiftest.jpg to
# reproduce the problem.
my $im = Imager->new;
ok($im->read(file=>'testimg/zerotype.jpg'), "shouldn't crash");
}
SKIP:
{ # code coverage - make sure wiol_skip_input_data is called
open BASEDATA, "< testimg/exiftest.jpg"
or skip "can't open base data", 1;
binmode BASEDATA;
my $data = do { local $/; <BASEDATA> };
close BASEDATA;
substr($data, 3, 1) eq "\xE1"
or skip "base data isn't as expected", 1;
# inserting a lot of marker data here means we take the branch in
# wiol_skip_input_data that refills the buffer
my $marker = "\xFF\xE9"; # APP9 marker
$marker .= pack("n", 8192) . "x" x 8190;
$marker x= 10; # make it take up a lot of space
substr($data, 2, 0) = $marker;
my $im = Imager->new;
ok($im->read(data => $data), "read with a skip of data");
}
SKIP:
{ # code coverage - take the branch that provides a fake EOI
open BASEDATA, "< testimg/exiftest.jpg"
or skip "can't open base data", 1;
binmode BASEDATA;
my $data = do { local $/; <BASEDATA> };
close BASEDATA;
substr($data, -1000) = '';
my $im = Imager->new;
ok($im->read(data => $data), "read with image data truncated");
}
{ # code coverage - make sure wiol_empty_output_buffer is called
my $im = Imager->new(xsize => 1000, ysize => 1000);
for my $x (0 .. 999) {
$im->line(x1 => $x, y1 => 0, x2 => $x, y2 => 999,
color => Imager::Color->new(rand 256, rand 256, rand 256));
}
my $data;
ok($im->write(data => \$data, type=>'jpeg', jpegquality => 100),
"write big file to ensure wiol_empty_output_buffer is called")
or print "# ", $im->errstr, "\n";
# code coverage - write failure path in wiol_empty_output_buffer
ok(!$im->write(callback => sub { return },
type => 'jpeg', jpegquality => 100),
"fail to write")
and print "# ", $im->errstr, "\n";
}
{ # code coverage - virtual image branch in i_writejpeg_wiol()
my $im = $imoo->copy;
my $immask = $im->masked;
ok($immask, "made a virtual image (via masked)");
ok($immask->virtual, "check it's virtual");
my $mask_data;
ok($immask->write(data => \$mask_data, type => 'jpeg'),
"write masked version");
my $base_data;
ok($im->write(data => \$base_data, type=>'jpeg'),
"write normal version");
is($base_data, $mask_data, "check the data written matches");
}
SKIP:
{ # code coverage - IPTC data
# this is dummy data
my $iptc = "\x04\x04" .
"\034\002x My Caption"
. "\034\002P Tony Cook"
. "\034\002i Dummy Headline!"
. "\034\002n No Credit Given";
my $app13 = "\xFF\xED" . pack("n", 2 + length $iptc) . $iptc;
open BASEDATA, "< testimg/exiftest.jpg"
or skip "can't open base data", 1;
binmode BASEDATA;
my $data = do { local $/; <BASEDATA> };
close BASEDATA;
substr($data, 2, 0) = $app13;
my $im = Imager->new;
ok($im->read(data => $data), "read with app13 data");
my %iptc = $im->parseiptc;
is($iptc{caption}, 'My Caption', 'check iptc caption');
is($iptc{photogr}, 'Tony Cook', 'check iptc photogr');
is($iptc{headln}, 'Dummy Headline!', 'check iptc headln');
is($iptc{credit}, 'No Credit Given', 'check iptc credit');
}
{ # handling of CMYK jpeg
# http://rt.cpan.org/Ticket/Display.html?id=20416
my $im = Imager->new;
ok($im->read(file => 'testimg/scmyk.jpg'), 'read a CMYK jpeg');
is($im->getchannels, 3, "check channel count");
my $col = $im->getpixel(x => 0, 'y' => 0);
ok($col, "got the 'black' pixel");
# this is jpeg, so we can't compare colors exactly
# older versions returned this pixel at a light color, but
# it's black in the image
my ($r, $g, $b) = $col->rgba;
cmp_ok($r, '<', 10, 'black - red low');
cmp_ok($g, '<', 10, 'black - green low');
cmp_ok($b, '<', 10, 'black - blue low');
$col = $im->getpixel(x => 15, 'y' => 0);
ok($col, "got the dark blue");
($r, $g, $b) = $col->rgba;
cmp_ok($r, '<', 10, 'dark blue - red low');
cmp_ok($g, '<', 10, 'dark blue - green low');
cmp_ok($b, '>', 110, 'dark blue - blue middle (bottom)');
cmp_ok($b, '<', 130, 'dark blue - blue middle (top)');
$col = $im->getpixel(x => 0, 'y' => 15);
ok($col, "got the red");
($r, $g, $b) = $col->rgba;
cmp_ok($r, '>', 245, 'red - red high');
cmp_ok($g, '<', 10, 'red - green low');
cmp_ok($b, '<', 10, 'red - blue low');
}
{
ok(grep($_ eq 'jpeg', Imager->read_types), "check jpeg in read types");
ok(grep($_ eq 'jpeg', Imager->write_types), "check jpeg in write types");
}
{ # progressive JPEG
# https://rt.cpan.org/Ticket/Display.html?id=68691
my $im = test_image();
my $progim = $im->copy;
ok($progim->write(file => "testout/t10prog.jpg", type => "jpeg",
jpeg_progressive => 1),
"write progressive jpeg");
my $rdprog = Imager->new(file => "testout/t10prog.jpg");
ok($rdprog, "read progressive jpeg");
my @prog = $rdprog->tags(name => "jpeg_progressive");
is($prog[0], 1, "check progressive flag set on read");
my $data;
ok($im->write(data => \$data, type => "jpeg"),
"save as non-progressive to compare");
my $norm = Imager->new(data => $data);
ok($norm, "read non-progressive file");
my @nonprog = $norm->tags(name => "jpeg_progressive");
is($nonprog[0], 0, "check progressive flag 0 for non prog file");
is_image($rdprog, $norm, "prog vs norm should be the same image");
}
SKIP:
{ # optimize coding
my $im = test_image();
my $base;
ok($im->write(data => \$base, type => "jpeg"), "save without optimize");
my $opt;
ok($im->write(data => \$opt, type => "jpeg", jpeg_optimize => 1),
"save with optimize");
cmp_ok(length $opt, '<', length $base, "check optimized is smaller");
my $im_base = Imager->new(data => $base, filetype => "jpeg");
ok($im_base, "read unoptimized back");
my $im_opt = Imager->new(data => $opt, filetype => "jpeg");
ok($im_opt, "read optimized back");
$im_base && $im_opt
or skip "couldn't read one back", 1;
is_image($im_opt, $im_base,
"optimization should only change huffman compression, not quality");
}
{ # check close failures are handled correctly
my $im = test_image();
my $fail_close = sub {
Imager::i_push_error(0, "synthetic close failure");
return 0;
};
ok(!$im->write(type => "jpeg", callback => sub { 1 },
closecb => $fail_close),
"check failing close fails");
like($im->errstr, qr/synthetic close failure/,
"check error message");
}