move JPEG into it's own module
[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);
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 => 94;
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 ok(!$imoo->write(fd=>fileno(FH), type=>'jpeg'), 'failure handling');
59 close FH;
60 print "# ",$imoo->errstr,"\n";
61
62 # check that the i_format tag is set
63 my @fmt = $imoo->tags(name=>'i_format');
64 is($fmt[0], 'jpeg', 'i_format tag');
65
66 { # check file limits are checked
67   my $limit_file = "testout/t101.jpg";
68   ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
69   my $im = Imager->new;
70   ok(!$im->read(file=>$limit_file),
71      "should fail read due to size limits");
72   print "# ",$im->errstr,"\n";
73   like($im->errstr, qr/image width/, "check message");
74   
75   ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
76   ok(!$im->read(file=>$limit_file),
77      "should fail read due to size limits");
78   print "# ",$im->errstr,"\n";
79   like($im->errstr, qr/image height/, "check message");
80   
81   ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
82   ok($im->read(file=>$limit_file),
83      "should succeed - just inside width limit");
84   ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
85   ok($im->read(file=>$limit_file),
86      "should succeed - just inside height limit");
87   
88   # 150 x 150 x 3 channel image uses 67500 bytes
89   ok(Imager->set_file_limits(reset=>1, bytes=>67499),
90      "set bytes limit 67499");
91   ok(!$im->read(file=>$limit_file),
92        "should fail - too many bytes");
93   print "# ",$im->errstr,"\n";
94   like($im->errstr, qr/storage size/, "check error message");
95   ok(Imager->set_file_limits(reset=>1, bytes=>67500),
96      "set bytes limit 67500");
97   ok($im->read(file=>$limit_file),
98      "should succeed - just inside bytes limit");
99   Imager->set_file_limits(reset=>1);
100 }
101
102 SKIP:
103 {
104   # we don't test them all
105   my %expected_tags =
106     (
107      exif_date_time_original => "2005:11:25 00:00:00",
108      exif_flash => 0,
109      exif_image_description => "Imager Development Notes",
110      exif_make => "Canon",
111      exif_model => "CanoScan LiDE 35",
112      exif_resolution_unit => 2,
113      exif_resolution_unit_name => "inches",
114      exif_user_comment => "        Part of notes from reworking i_arc() and friends.",
115      exif_white_balance => 0,
116      exif_white_balance_name => "Auto white balance",
117     );
118   
119   my $im = Imager->new;
120   $im->read(file=>"testimg/exiftest.jpg")
121     or skip("Could not read test image:".$im->errstr, scalar keys %expected_tags);
122   
123   for my $key (keys %expected_tags) {
124     is($expected_tags{$key}, $im->tags(name => $key),
125        "test value of exif tag $key");
126   }
127 }
128
129 {
130   # tests that the density values are set and read correctly
131   # tests jpeg_comment too
132   my @density_tests =
133     (
134      [ 't101cm100.jpg', 
135        { 
136         jpeg_density_unit => 2, 
137         i_xres => 254, 
138         i_yres => 254
139        },
140        { 
141         jpeg_density_unit => 2, 
142         i_xres => 254, 
143         i_yres => 254,
144         i_aspect_only => undef,
145        },
146      ],
147      [
148       't101xonly.jpg',
149       {
150        i_xres => 100,
151       },
152       {
153        i_xres => 100,
154        i_yres => 100,
155        jpeg_density_unit => 1,
156        i_aspect_only => undef,
157       },
158      ],
159      [
160       't101yonly.jpg',
161       {
162        i_yres => 100,
163       },
164       {
165        i_xres => 100,
166        i_yres => 100,
167        jpeg_density_unit => 1,
168        i_aspect_only => undef,
169       },
170      ],
171      [
172       't101asponly.jpg',
173       {
174        i_xres => 50,
175        i_yres => 100,
176        i_aspect_only => 1,
177       },
178       {
179        i_xres => 50,
180        i_yres => 100,
181        i_aspect_only => 1,
182        jpeg_density_unit => 0,
183       },
184      ],
185      [
186       't101com.jpg',
187       {
188        jpeg_comment => 'test comment'
189       },
190      ],
191     );
192   
193   print "# test density tags\n";
194   # I don't care about the content
195   my $base_im = Imager->new(xsize => 10, ysize => 10);
196   for my $test (@density_tests) {
197     my ($filename, $out_tags, $expect_tags) = @$test;
198     $expect_tags ||= $out_tags;
199     
200     my $work = $base_im->copy;
201     for my $key (keys %$out_tags) {
202       $work->addtag(name => $key, value => $out_tags->{$key});
203     }
204     
205     ok($work->write(file=>"testout/$filename", type=>'jpeg'),
206        "save $filename");
207     
208     my $check = Imager->new;
209     ok($check->read(file=> "testout/$filename"),
210        "read $filename");
211     
212     my %tags;
213     for my $key (keys %$expect_tags) {
214       $tags{$key} = $check->tags(name=>$key);
215     }
216     is_deeply($expect_tags, \%tags, "check tags for $filename");
217   }
218 }
219
220 { # Issue # 17981
221   # the test image has a zero-length user_comment field
222   # the code would originally attempt to convert '\0' to ' '
223   # for the first 8 bytes, even if the string was less than 
224   # 8 bytes long
225   my $im = Imager->new;
226   ok($im->read(file => 'testimg/209_yonge.jpg', type=>'jpeg'),
227      "test read of image with invalid exif_user_comment");
228   is($im->tags(name=>'exif_user_comment'), '',
229      "check exif_user_comment set correctly");
230 }
231
232 { # test parseiptc handling no IPTC data correctly
233   my $saw_warn;
234   local $SIG{__WARN__} = 
235     sub {
236       ++$saw_warn;
237       print "# @_\n";
238     };
239   my $im = Imager->new;
240   ok($im->read(file => 'testout/t101.jpg', type=>'jpeg'),
241      "read jpeg with no IPTC data");
242   ok(!defined $im->{IPTCRAW}, "no iptc data");
243   my %iptc = $im->parseiptc;
244   ok(!$saw_warn, "should be no warnings");
245 }
246
247 { # Issue # 18397
248   # attempting to write a 4 channel image to a bufchain would
249   # cause a seg fault.
250   # it should fail still
251   # overridden by # 29876
252   # give 4/2 channel images a background color when saving to JPEG
253   my $im = Imager->new(xsize => 16, ysize => 16, channels => 4);
254   $im->box(filled => 1, xmin => 8, color => '#FFE0C0');
255   my $data;
256   ok($im->write(data => \$data, type => 'jpeg'),
257      "should write with a black background");
258   my $imread = Imager->new;
259   ok($imread->read(data => $data, type => 'jpeg'), 'read it back');
260   is_color_close3($imread->getpixel('x' => 0, 'y' => 0), 0, 0, 0, 4,
261                   "check it's black");
262   is_color_close3($imread->getpixel('x' => 15, 'y' => 9), 255, 224, 192, 4,
263                   "check filled area filled");
264   
265   # write with a red background
266   $data = '';
267   ok($im->write(data => \$data, type => 'jpeg', i_background => '#FF0000'),
268      "write with red background");
269   ok($imread->read(data => $data, type => 'jpeg'), "read it back");
270   is_color_close3($imread->getpixel('x' => 0, 'y' => 0), 255, 0, 0, 4,
271                   "check it's red");
272   is_color_close3($imread->getpixel('x' => 15, 'y' => 9), 255, 224, 192, 4,
273                   "check filled area filled");
274 }
275 SKIP:
276 { # Issue # 18496
277   # If a jpeg with EXIF data containing an (invalid) IFD entry with a 
278   # type of zero is read then Imager crashes with a Floating point 
279   # exception
280   # testimg/zerojpeg.jpg was manually modified from exiftest.jpg to
281   # reproduce the problem.
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 {
407   ok(grep($_ eq 'jpeg', Imager->read_types), "check jpeg in read types");
408   ok(grep($_ eq 'jpeg', Imager->write_types), "check jpeg in write types");
409 }
410
411