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