Various changes:
[imager.git] / t / t104ppm.t
1 #!perl -w
2 use Imager ':all';
3 use Test::More tests => 143;
4 use strict;
5 use Imager::Test qw(test_image_raw test_image_16 is_color3 is_color1 is_image);
6
7 init_log("testout/t104ppm.log",1);
8
9 my $green = i_color_new(0,255,0,255);
10 my $blue  = i_color_new(0,0,255,255);
11 my $red   = i_color_new(255,0,0,255);
12
13 my $img    = test_image_raw();
14
15 my $fh = openimage(">testout/t104.ppm");
16 my $IO = Imager::io_new_fd(fileno($fh));
17 ok(i_writeppm_wiol($img, $IO), "write pnm low")
18   or die "Cannot write testout/t104.ppm\n";
19 close($fh);
20
21 $IO = Imager::io_new_bufchain();
22 ok(i_writeppm_wiol($img, $IO), "write to bufchain")
23   or die "Cannot write to bufchain";
24 my $data = Imager::io_slurp($IO);
25
26 $fh = openimage("testout/t104.ppm");
27 $IO = Imager::io_new_fd( fileno($fh) );
28 my $cmpimg = i_readpnm_wiol($IO,-1);
29 ok($cmpimg, "read image we wrote")
30   or die "Cannot read testout/t104.ppm\n";
31 close($fh);
32
33 is(i_img_diff($img, $cmpimg), 0, "compare written and read images");
34
35 my $rdata = slurp("testout/t104.ppm");
36 is($data, $rdata, "check data read from file and bufchain data");
37
38 # build a grayscale image
39 my $gimg = Imager::ImgRaw::new(150, 150, 1);
40 my $gray = i_color_new(128, 0, 0, 255);
41 my $dgray = i_color_new(64, 0, 0, 255);
42 my $white = i_color_new(255, 0, 0, 255);
43 i_box_filled($gimg, 20, 20, 130, 130, $gray);
44 i_box_filled($gimg, 40, 40, 110, 110, $dgray);
45 i_arc($gimg, 75, 75, 30, 0, 361, $white);
46
47 open FH, "> testout/t104_gray.pgm" or die "Cannot create testout/t104_gray.pgm: $!\n";
48 binmode FH;
49 $IO = Imager::io_new_fd(fileno(FH));
50 ok(i_writeppm_wiol($gimg, $IO), "write grayscale");
51 close FH;
52
53 open FH, "< testout/t104_gray.pgm" or die "Cannot open testout/t104_gray.pgm: $!\n";
54 binmode FH;
55 $IO = Imager::io_new_fd(fileno(FH));
56 my $gcmpimg = i_readpnm_wiol($IO, -1);
57 ok($gcmpimg, "read grayscale");
58 is(i_img_diff($gimg, $gcmpimg), 0, 
59    "compare written and read greyscale images");
60
61 my $ooim = Imager->new;
62 ok($ooim->read(file=>"testimg/simple.pbm"), "read simple pbm, via OO");
63
64 check_gray(Imager::i_get_pixel($ooim->{IMG}, 0, 0), 0);
65 check_gray(Imager::i_get_pixel($ooim->{IMG}, 0, 1), 255);
66 check_gray(Imager::i_get_pixel($ooim->{IMG}, 1, 0), 255);
67 check_gray(Imager::i_get_pixel($ooim->{IMG}, 1, 1), 0);
68 is($ooim->type, 'paletted', "check pbm read as paletted");
69 is($ooim->tags(name=>'pnm_type'), 1, "check pnm_type tag");
70
71 {
72   # https://rt.cpan.org/Ticket/Display.html?id=7465
73   # the pnm reader ignores the maxval that it reads from the pnm file
74   my $maxval = Imager->new;
75   ok($maxval->read(file=>"testimg/maxval.ppm"),
76      "read testimg/maxval.ppm");
77   
78   # this image contains three pixels, with each sample from 0 to 63
79   # the pixels are (63, 63, 63), (32, 32, 32) and (31, 31, 0)
80   
81   # check basic parameters
82   is($maxval->getchannels, 3, "channel count");
83   is($maxval->getwidth, 3, "width");
84   is($maxval->getheight, 1, "height");
85   
86   # check the pixels
87   ok(my ($white, $grey, $green) = $maxval->getpixel('x'=>[0,1,2], 'y'=>[0,0,0]), "fetch pixels");
88   is_color3($white, 255, 255, 255, "white pixel");
89   is_color3($grey,  130, 130, 130, "grey  pixel");
90   is_color3($green, 125, 125, 0,   "green pixel");
91   is($maxval->tags(name=>'pnm_type'), 6, "check pnm_type tag on maxval");
92
93   # and do the same for ASCII images
94   my $maxval_asc = Imager->new;
95   ok($maxval_asc->read(file=>"testimg/maxval_asc.ppm"),
96      "read testimg/maxval_asc.ppm");
97   
98   # this image contains three pixels, with each sample from 0 to 63
99   # the pixels are (63, 63, 63), (32, 32, 32) and (31, 31, 0)
100   
101   # check basic parameters
102   is($maxval_asc->getchannels, 3, "channel count");
103   is($maxval_asc->getwidth, 3, "width");
104   is($maxval_asc->getheight, 1, "height");
105
106   is($maxval->tags(name=>'pnm_type'), 6, "check pnm_type tag on maxval");
107   
108   # check the pixels
109   ok(my ($white_asc, $grey_asc, $green_asc) = $maxval_asc->getpixel('x'=>[0,1,2], 'y'=>[0,0,0]), "fetch pixels");
110   is_color3($white_asc, 255, 255, 255, "white asc pixel");
111   is_color3($grey_asc,  130, 130, 130, "grey  asc pixel");
112   is_color3($green_asc, 125, 125, 0,   "green asc pixel");
113 }
114
115 { # previously we didn't validate maxval at all, make sure it's
116   # validated now
117   my $maxval0 = Imager->new;
118   ok(!$maxval0->read(file=>'testimg/maxval_0.ppm'),
119      "should fail to read maxval 0 image");
120   print "# ", $maxval0->errstr, "\n";
121   like($maxval0->errstr, qr/maxval is zero - invalid pnm file/,
122        "error expected from reading maxval_0.ppm");
123
124   my $maxval65536 = Imager->new;
125   ok(!$maxval65536->read(file=>'testimg/maxval_65536.ppm'),
126      "should fail reading maxval 65536 image");
127   print "# ",$maxval65536->errstr, "\n";
128   like($maxval65536->errstr, qr/maxval of 65536 is over 65535 - invalid pnm file/,
129        "error expected from reading maxval_65536.ppm");
130
131   # maxval of 256 is valid, and handled as of 0.56
132   my $maxval256 = Imager->new;
133   ok($maxval256->read(file=>'testimg/maxval_256.ppm'),
134      "should succeed reading maxval 256 image");
135   is_color3($maxval256->getpixel(x => 0, 'y' => 0),
136             0, 0, 0, "check black in maxval_256");
137   is_color3($maxval256->getpixel(x => 0, 'y' => 1),
138             255, 255, 255, "check white in maxval_256");
139   is($maxval256->bits, 16, "check bits/sample on maxval 256");
140
141   # make sure we handle maxval > 255 for ascii
142   my $maxval4095asc = Imager->new;
143   ok($maxval4095asc->read(file=>'testimg/maxval_4095_asc.ppm'),
144      "read maxval_4095_asc.ppm");
145   is($maxval4095asc->getchannels, 3, "channels");
146   is($maxval4095asc->getwidth, 3, "width");
147   is($maxval4095asc->getheight, 1, "height");
148   is($maxval4095asc->bits, 16, "check bits/sample on maxval 4095");
149
150   ok(my ($white, $grey, $green) = $maxval4095asc->getpixel('x'=>[0,1,2], 'y'=>[0,0,0]), "fetch pixels");
151   is_color3($white, 255, 255, 255, "white 4095 pixel");
152   is_color3($grey,  128, 128, 128, "grey  4095 pixel");
153   is_color3($green, 127, 127, 0,   "green 4095 pixel");
154 }
155
156 { # check i_format is set when reading a pnm file
157   # doesn't really matter which file.
158   my $maxval = Imager->new;
159   ok($maxval->read(file=>"testimg/maxval.ppm"),
160       "read test file");
161   my ($type) = $maxval->tags(name=>'i_format');
162   is($type, 'pnm', "check i_format");
163 }
164
165 { # check file limits are checked
166   my $limit_file = "testout/t104.ppm";
167   ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
168   my $im = Imager->new;
169   ok(!$im->read(file=>$limit_file),
170      "should fail read due to size limits");
171   print "# ",$im->errstr,"\n";
172   like($im->errstr, qr/image width/, "check message");
173
174   ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
175   ok(!$im->read(file=>$limit_file),
176      "should fail read due to size limits");
177   print "# ",$im->errstr,"\n";
178   like($im->errstr, qr/image height/, "check message");
179
180   ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
181   ok($im->read(file=>$limit_file),
182      "should succeed - just inside width limit");
183   ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
184   ok($im->read(file=>$limit_file),
185      "should succeed - just inside height limit");
186   
187   # 150 x 150 x 3 channel image uses 67500 bytes
188   ok(Imager->set_file_limits(reset=>1, bytes=>67499),
189      "set bytes limit 67499");
190   ok(!$im->read(file=>$limit_file),
191      "should fail - too many bytes");
192   print "# ",$im->errstr,"\n";
193   like($im->errstr, qr/storage size/, "check error message");
194   ok(Imager->set_file_limits(reset=>1, bytes=>67500),
195      "set bytes limit 67500");
196   ok($im->read(file=>$limit_file),
197      "should succeed - just inside bytes limit");
198   Imager->set_file_limits(reset=>1);
199 }
200
201 {
202   # check we correctly sync with the data stream
203   my $im = Imager->new;
204   ok($im->read(file => 'testimg/pgm.pgm', type => 'pnm'),
205      "read pgm.pgm");
206   print "# ", $im->getsamples('y' => 0), "\n";
207   is_color1($im->getpixel(x=>0, 'y' => 0), 254, "check top left");
208 }
209
210 { # check error messages set correctly
211   my $im = Imager->new(xsize=>100, ysize=>100, channels=>4);
212   ok(!$im->write(file=>"testout/t104_fail.ppm", type=>'pnm'),
213      "should fail to write 4 channel image");
214   is($im->errstr, 'can only save 1 or 3 channel images to pnm',
215      "check error message");
216   ok(!$im->read(file=>'t/t104ppm.t', type=>'pnm'),
217      'should fail to read script as an image file');
218   is($im->errstr, 'unable to read pnm image: bad header magic, not a PNM file',
219      "check error message");
220 }
221
222 # various bad input files
223 print "# check error handling\n";
224 {
225   my $im = Imager->new;
226   ok(!$im->read(file => 'testimg/short_bin.ppm', type=>'pnm'),
227      "fail to read short bin ppm");
228   cmp_ok($im->errstr, '=~', 'short read - file truncated', 
229          "check error message");
230 }
231
232 {
233   my $im = Imager->new;
234   ok(!$im->read(file => 'testimg/short_bin16.ppm', type=>'pnm'),
235      "fail to read short bin ppm (maxval 65535)");
236   cmp_ok($im->errstr, '=~', 'short read - file truncated', 
237          "check error message");
238 }
239
240 {
241   my $im = Imager->new;
242   ok(!$im->read(file => 'testimg/short_bin.pgm', type=>'pnm'),
243      "fail to read short bin pgm");
244   cmp_ok($im->errstr, '=~', 'short read - file truncated', 
245          "check error message");
246 }
247
248 {
249   my $im = Imager->new;
250   ok(!$im->read(file => 'testimg/short_bin16.pgm', type=>'pnm'),
251      "fail to read short bin pgm (maxval 65535)");
252   cmp_ok($im->errstr, '=~', 'short read - file truncated', 
253          "check error message");
254 }
255
256 {
257   my $im = Imager->new;
258   ok(!$im->read(file => 'testimg/short_bin.pbm', type => 'pnm'),
259      "fail to read a short bin pbm");
260   cmp_ok($im->errstr, '=~', 'short read - file truncated', 
261          "check error message");
262 }
263
264 {
265   my $im = Imager->new;
266   ok(!$im->read(file => 'testimg/short_asc.ppm', type => 'pnm'),
267      "fail to read a short asc ppm");
268   cmp_ok($im->errstr, '=~', 'short read - file truncated', 
269          "check error message");
270 }
271
272 {
273   my $im = Imager->new;
274   ok(!$im->read(file => 'testimg/short_asc.pgm', type => 'pnm'),
275      "fail to read a short asc pgm");
276   cmp_ok($im->errstr, '=~', 'short read - file truncated', 
277          "check error message");
278 }
279
280 {
281   my $im = Imager->new;
282   ok(!$im->read(file => 'testimg/short_asc.pbm', type => 'pnm'),
283      "fail to read a short asc pbm");
284   cmp_ok($im->errstr, '=~', 'short read - file truncated', 
285          "check error message");
286 }
287
288 {
289   my $im = Imager->new;
290   ok(!$im->read(file => 'testimg/bad_asc.ppm', type => 'pnm'),
291      "fail to read a bad asc ppm");
292   cmp_ok($im->errstr, '=~', 'invalid data for ascii pnm', 
293          "check error message");
294 }
295
296 {
297   my $im = Imager->new;
298   ok(!$im->read(file => 'testimg/bad_asc.pgm', type => 'pnm'),
299      "fail to read a bad asc pgm");
300   cmp_ok($im->errstr, '=~', 'invalid data for ascii pnm', 
301          "check error message");
302 }
303
304 {
305   my $im = Imager->new;
306   ok(!$im->read(file => 'testimg/bad_asc.pbm', type => 'pnm'),
307      "fail to read a bad asc pbm");
308   cmp_ok($im->errstr, '=~', 'invalid data for ascii pnm', 
309          "check error message");
310 }
311
312 {
313   my $im = Imager->new;
314   ok($im->read(file => 'testimg/short_bin.ppm', type => 'pnm',
315                 allow_partial => 1),
316      "partial read bin ppm");
317   is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
318   is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
319 }
320
321 {
322   my $im = Imager->new;
323   ok($im->read(file => 'testimg/short_bin16.ppm', type => 'pnm',
324                 allow_partial => 1),
325      "partial read bin16 ppm");
326   is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
327   is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
328   is($im->bits, 16, "check correct bits");
329 }
330
331 {
332   my $im = Imager->new;
333   ok($im->read(file => 'testimg/short_bin.pgm', type => 'pnm',
334                 allow_partial => 1),
335      "partial read bin pgm");
336   is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
337   is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
338 }
339
340 {
341   my $im = Imager->new;
342   ok($im->read(file => 'testimg/short_bin16.pgm', type => 'pnm',
343                 allow_partial => 1),
344      "partial read bin16 pgm");
345   is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
346   is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
347 }
348
349 {
350   my $im = Imager->new;
351   ok($im->read(file => 'testimg/short_bin.pbm', type => 'pnm',
352                 allow_partial => 1),
353      "partial read bin pbm");
354   is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
355   is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
356 }
357
358 {
359   my $im = Imager->new;
360   ok($im->read(file => 'testimg/short_asc.ppm', type => 'pnm',
361                 allow_partial => 1),
362      "partial read asc ppm");
363   is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
364   is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
365 }
366
367 {
368   my $im = Imager->new;
369   ok($im->read(file => 'testimg/short_asc.pgm', type => 'pnm',
370                 allow_partial => 1),
371      "partial read asc pgm");
372   is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
373   is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
374 }
375
376 {
377   my $im = Imager->new;
378   ok($im->read(file => 'testimg/short_asc.pbm', type => 'pnm',
379                 allow_partial => 1),
380      "partial read asc pbm");
381   is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
382   is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
383 }
384
385 {
386   my $im = Imager->new;
387   ok($im->read(file => 'testimg/bad_asc.ppm', type => 'pnm',
388                 allow_partial => 1),
389      "partial read bad asc ppm");
390   is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
391   is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
392 }
393
394 {
395   my $im = Imager->new;
396   ok($im->read(file => 'testimg/bad_asc.pgm', type => 'pnm',
397                 allow_partial => 1),
398      "partial read bad asc pgm");
399   is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
400   is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
401 }
402
403 {
404   my $im = Imager->new;
405   ok($im->read(file => 'testimg/bad_asc.pbm', type => 'pnm',
406                 allow_partial => 1),
407      "partial read bad asc pbm");
408   is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
409   is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
410 }
411
412 {
413   print "# monochrome output\n";
414   my $im = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
415   ok($im->addcolors(colors => [ '#000000', '#FFFFFF' ]),
416      "add black and white");
417   $im->box(filled => 1, xmax => 4, color => '#000000');
418   $im->box(filled => 1, xmin => 5, color => '#FFFFFF');
419   is($im->type, 'paletted', 'mono still paletted');
420   ok($im->write(file => 'testout/t104_mono.pbm', type => 'pnm'),
421      "save as pbm");
422
423   # check it
424   my $imread = Imager->new;
425   ok($imread->read(file => 'testout/t104_mono.pbm', type=>'pnm'),
426      "read it back in")
427     or print "# ", $imread->errstr, "\n";
428   is($imread->type, 'paletted', "check result is paletted");
429   is($imread->tags(name => 'pnm_type'), 4, "check type");
430 }
431
432 {
433   print "# 16-bit output\n";
434   my $data;
435   my $im = test_image_16();
436   
437   # without tag, it should do 8-bit output
438   ok($im->write(data => \$data, type => 'pnm'),
439      "write 16-bit image as 8-bit/sample ppm");
440   my $im8 = Imager->new;
441   ok($im8->read(data => $data), "read it back");
442   is($im8->tags(name => 'pnm_maxval'), 255, "check maxval");
443   is_image($im, $im8, "check image matches");
444
445   # try 16-bit output
446   $im->settag(name => 'pnm_write_wide_data', value => 1);
447   $data = '';
448   ok($im->write(data => \$data, type => 'pnm'),
449      "write 16-bit image as 16-bit/sample ppm");
450   $im->write(file=>'testout/t104_16.ppm');
451   my $im16 = Imager->new;
452   ok($im16->read(data => $data), "read it back");
453   is($im16->tags(name => 'pnm_maxval'), 65535, "check maxval");
454   $im16->write(file=>'testout/t104_16b.ppm');
455   is_image($im, $im16, "check image matches");
456 }
457
458 sub openimage {
459   my $fname = shift;
460   local(*FH);
461   open(FH, $fname) or die "Cannot open $fname: $!\n";
462   binmode(FH);
463   return *FH;
464 }
465
466 sub slurp {
467   my $fh = openimage(shift);
468   local $/;
469   my $data = <$fh>;
470   close($fh);
471   return $data;
472 }
473
474 sub check_gray {
475   my ($c, $gray) = @_;
476
477   my ($g) = $c->rgba;
478   is($g, $gray, "compare gray");
479 }
480