test code now reports the (compile-time) library version
[imager.git] / 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 => 103;
15
16 print STDERR "libjpeg version: ", Imager::File::JPEG::i_libjpeg_version(), "\n";
17
18 my $green=i_color_new(0,255,0,255);
19 my $blue=i_color_new(0,0,255,255);
20 my $red=i_color_new(255,0,0,255);
21
22 my $img=test_image_raw();
23 my $cmpimg=Imager::ImgRaw::new(150,150,3);
24
25 open(FH,">testout/t101.jpg")
26   || die "cannot open testout/t101.jpg for writing\n";
27 binmode(FH);
28 my $IO = Imager::io_new_fd(fileno(FH));
29 ok(Imager::File::JPEG::i_writejpeg_wiol($img,$IO,30), "write jpeg low level");
30 close(FH);
31
32 open(FH, "testout/t101.jpg") || die "cannot open testout/t101.jpg\n";
33 binmode(FH);
34 $IO = Imager::io_new_fd(fileno(FH));
35 ($cmpimg,undef) = Imager::File::JPEG::i_readjpeg_wiol($IO);
36 close(FH);
37
38 my $diff = sqrt(i_img_diff($img,$cmpimg))/150*150;
39 print "# jpeg average mean square pixel difference: ",$diff,"\n";
40 ok($cmpimg, "read jpeg low level");
41
42 ok($diff < 10000, "difference between original and jpeg within bounds");
43
44 Imager::i_log_entry("Starting 4\n", 1);
45 my $imoo = Imager->new;
46 ok($imoo->read(file=>'testout/t101.jpg'), "read jpeg OO");
47
48 ok($imoo->write(file=>'testout/t101_oo.jpg'), "write jpeg OO");
49 Imager::i_log_entry("Starting 5\n", 1);
50 my $oocmp = Imager->new;
51 ok($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;
54 print "# OO image difference $diff\n";
55 ok($diff < 10000, "difference between original and jpeg within bounds");
56
57 # write failure test
58 open FH, "< testout/t101.jpg" or die "Cannot open testout/t101.jpg: $!";
59 binmode FH;
60 my $io = Imager::io_new_fd(fileno(FH));
61 $io->set_buffered(0);
62 ok(!$imoo->write(io => $io, type=>'jpeg'), 'failure handling');
63 close FH;
64 print "# ",$imoo->errstr,"\n";
65
66 # check that the i_format tag is set
67 my @fmt = $imoo->tags(name=>'i_format');
68 is($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 }
105
106 SKIP:
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   
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");
130   }
131 }
132
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;
203     
204     my $work = $base_im->copy;
205     for my $key (keys %$out_tags) {
206       $work->addtag(name => $key, value => $out_tags->{$key});
207     }
208     
209     ok($work->write(file=>"testout/$filename", type=>'jpeg'),
210        "save $filename");
211     
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);
219     }
220     is_deeply($expect_tags, \%tags, "check tags for $filename");
221   }
222 }
223
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 }
235
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 }
250
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");
268   
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 }
279 SKIP:
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.
286   my $im = Imager->new;
287   ok($im->read(file=>'testimg/zerotype.jpg'), "shouldn't crash");
288 }
289
290 SKIP:
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 }
309
310 SKIP:
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 }
322
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));
328   }
329   my $data;
330   ok($im->write(data => \$data, type=>'jpeg', jpegquality => 100), 
331      "write big file to ensure wiol_empty_output_buffer is called")
332     or print "# ", $im->errstr, "\n";
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 }
340
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 }
354
355 SKIP:
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 }
381
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 }
410
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");
414 }
415
416 { # progressive JPEG
417   # https://rt.cpan.org/Ticket/Display.html?id=68691
418   my $im = test_image();
419   my $progim = $im->copy;
420
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 }
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 }