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