t/200-file/310-pnm.t

   1 #!perl -w
   2 use Imager ':all';
   3 use Test::More tests => 205;
   4 use strict;
   5 use Imager::Test qw(test_image_raw test_image_16 is_color3 is_color1 is_image test_image_named);
   6
   7 $| = 1;
   8
   9 -d "testout" or mkdir "testout";
  10
  11 Imager->open_log(log => "testout/t104ppm.log");
  12
  13 my $green = i_color_new(0,255,0,255);
  14 my $blue  = i_color_new(0,0,255,255);
  15 my $red   = i_color_new(255,0,0,255);
  16
  17 my @files;
  18
  19 my $img    = test_image_raw();
  20
  21 my $fh = openimage(">testout/t104.ppm");
  22 push @files, "t104.ppm";
  23 my $IO = Imager::io_new_fd(fileno($fh));
  24 ok(i_writeppm_wiol($img, $IO), "write pnm low")
  25   or die "Cannot write testout/t104.ppm\n";
  26 close($fh);
  27
  28 $IO = Imager::io_new_bufchain();
  29 ok(i_writeppm_wiol($img, $IO), "write to bufchain")
  30   or die "Cannot write to bufchain";
  31 my $data = Imager::io_slurp($IO);
  32
  33 $fh = openimage("testout/t104.ppm");
  34 $IO = Imager::io_new_fd( fileno($fh) );
  35 my $cmpimg = i_readpnm_wiol($IO,-1);
  36 ok($cmpimg, "read image we wrote")
  37   or die "Cannot read testout/t104.ppm\n";
  38 close($fh);
  39
  40 is(i_img_diff($img, $cmpimg), 0, "compare written and read images");
  41
  42 my $rdata = slurp("testout/t104.ppm");
  43 is($data, $rdata, "check data read from file and bufchain data");
  44
  45 # build a grayscale image
  46 my $gimg = Imager::ImgRaw::new(150, 150, 1);
  47 my $gray = i_color_new(128, 0, 0, 255);
  48 my $dgray = i_color_new(64, 0, 0, 255);
  49 my $white = i_color_new(255, 0, 0, 255);
  50 i_box_filled($gimg, 20, 20, 130, 130, $gray);
  51 i_box_filled($gimg, 40, 40, 110, 110, $dgray);
  52 i_arc($gimg, 75, 75, 30, 0, 361, $white);
  53
  54 push @files, "t104_gray.pgm";
  55 open FH, "> testout/t104_gray.pgm" or die "Cannot create testout/t104_gray.pgm: $!\n";
  56 binmode FH;
  57 $IO = Imager::io_new_fd(fileno(FH));
  58 ok(i_writeppm_wiol($gimg, $IO), "write grayscale");
  59 close FH;
  60
  61 open FH, "< testout/t104_gray.pgm" or die "Cannot open testout/t104_gray.pgm: $!\n";
  62 binmode FH;
  63 $IO = Imager::io_new_fd(fileno(FH));
  64 my $gcmpimg = i_readpnm_wiol($IO, -1);
  65 ok($gcmpimg, "read grayscale");
  66 is(i_img_diff($gimg, $gcmpimg), 0,
  67    "compare written and read greyscale images");
  68
  69 my $ooim = Imager->new;
  70 ok($ooim->read(file=>"testimg/simple.pbm"), "read simple pbm, via OO")
  71   or print "# ", $ooim->errstr, "\n";
  72
  73 check_gray(Imager::i_get_pixel($ooim->{IMG}, 0, 0), 0);
  74 check_gray(Imager::i_get_pixel($ooim->{IMG}, 0, 1), 255);
  75 check_gray(Imager::i_get_pixel($ooim->{IMG}, 1, 0), 255);
  76 check_gray(Imager::i_get_pixel($ooim->{IMG}, 1, 1), 0);
  77 is($ooim->type, 'paletted', "check pbm read as paletted");
  78 is($ooim->tags(name=>'pnm_type'), 1, "check pnm_type tag");
  79
  80 {
  81   # https://rt.cpan.org/Ticket/Display.html?id=7465
  82   # the pnm reader ignores the maxval that it reads from the pnm file
  83   my $maxval = Imager->new;
  84   ok($maxval->read(file=>"testimg/maxval.ppm"),
  85      "read testimg/maxval.ppm");
  86
  87   # this image contains three pixels, with each sample from 0 to 63
  88   # the pixels are (63, 63, 63), (32, 32, 32) and (31, 31, 0)
  89
  90   # check basic parameters
  91   is($maxval->getchannels, 3, "channel count");
  92   is($maxval->getwidth, 3, "width");
  93   is($maxval->getheight, 1, "height");
  94
  95   # check the pixels
  96   ok(my ($white, $grey, $green) = $maxval->getpixel('x'=>[0,1,2], 'y'=>[0,0,0]), "fetch pixels");
  97   is_color3($white, 255, 255, 255, "white pixel");
  98   is_color3($grey,  130, 130, 130, "grey  pixel");
  99   is_color3($green, 125, 125, 0,   "green pixel");
 100   is($maxval->tags(name=>'pnm_type'), 6, "check pnm_type tag on maxval");
 101
 102   # and do the same for ASCII images
 103   my $maxval_asc = Imager->new;
 104   ok($maxval_asc->read(file=>"testimg/maxval_asc.ppm"),
 105      "read testimg/maxval_asc.ppm");
 106
 107   # this image contains three pixels, with each sample from 0 to 63
 108   # the pixels are (63, 63, 63), (32, 32, 32) and (31, 31, 0)
 109
 110   # check basic parameters
 111   is($maxval_asc->getchannels, 3, "channel count");
 112   is($maxval_asc->getwidth, 3, "width");
 113   is($maxval_asc->getheight, 1, "height");
 114
 115   is($maxval->tags(name=>'pnm_type'), 6, "check pnm_type tag on maxval");
 116
 117   # check the pixels
 118   ok(my ($white_asc, $grey_asc, $green_asc) = $maxval_asc->getpixel('x'=>[0,1,2], 'y'=>[0,0,0]), "fetch pixels");
 119   is_color3($white_asc, 255, 255, 255, "white asc pixel");
 120   is_color3($grey_asc,  130, 130, 130, "grey  asc pixel");
 121   is_color3($green_asc, 125, 125, 0,   "green asc pixel");
 122 }
 123
 124 { # previously we didn't validate maxval at all, make sure it's
 125   # validated now
 126   my $maxval0 = Imager->new;
 127   ok(!$maxval0->read(file=>'testimg/maxval_0.ppm'),
 128      "should fail to read maxval 0 image");
 129   print "# ", $maxval0->errstr, "\n";
 130   like($maxval0->errstr, qr/maxval is zero - invalid pnm file/,
 131        "error expected from reading maxval_0.ppm");
 132
 133   my $maxval65536 = Imager->new;
 134   ok(!$maxval65536->read(file=>'testimg/maxval_65536.ppm'),
 135      "should fail reading maxval 65536 image");
 136   print "# ",$maxval65536->errstr, "\n";
 137   like($maxval65536->errstr, qr/maxval of 65536 is over 65535 - invalid pnm file/,
 138        "error expected from reading maxval_65536.ppm");
 139
 140   # maxval of 256 is valid, and handled as of 0.56
 141   my $maxval256 = Imager->new;
 142   ok($maxval256->read(file=>'testimg/maxval_256.ppm'),
 143      "should succeed reading maxval 256 image");
 144   is_color3($maxval256->getpixel(x => 0, 'y' => 0),
 145             0, 0, 0, "check black in maxval_256");
 146   is_color3($maxval256->getpixel(x => 0, 'y' => 1),
 147             255, 255, 255, "check white in maxval_256");
 148   is($maxval256->bits, 16, "check bits/sample on maxval 256");
 149
 150   # make sure we handle maxval > 255 for ascii
 151   my $maxval4095asc = Imager->new;
 152   ok($maxval4095asc->read(file=>'testimg/maxval_4095_asc.ppm'),
 153      "read maxval_4095_asc.ppm");
 154   is($maxval4095asc->getchannels, 3, "channels");
 155   is($maxval4095asc->getwidth, 3, "width");
 156   is($maxval4095asc->getheight, 1, "height");
 157   is($maxval4095asc->bits, 16, "check bits/sample on maxval 4095");
 158
 159   ok(my ($white, $grey, $green) = $maxval4095asc->getpixel('x'=>[0,1,2], 'y'=>[0,0,0]), "fetch pixels");
 160   is_color3($white, 255, 255, 255, "white 4095 pixel");
 161   is_color3($grey,  128, 128, 128, "grey  4095 pixel");
 162   is_color3($green, 127, 127, 0,   "green 4095 pixel");
 163 }
 164
 165 { # check i_format is set when reading a pnm file
 166   # doesn't really matter which file.
 167   my $maxval = Imager->new;
 168   ok($maxval->read(file=>"testimg/maxval.ppm"),
 169       "read test file");
 170   my ($type) = $maxval->tags(name=>'i_format');
 171   is($type, 'pnm', "check i_format");
 172 }
 173
 174 { # check file limits are checked
 175   my $limit_file = "testout/t104.ppm";
 176   ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
 177   my $im = Imager->new;
 178   ok(!$im->read(file=>$limit_file),
 179      "should fail read due to size limits");
 180   print "# ",$im->errstr,"\n";
 181   like($im->errstr, qr/image width/, "check message");
 182
 183   ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
 184   ok(!$im->read(file=>$limit_file),
 185      "should fail read due to size limits");
 186   print "# ",$im->errstr,"\n";
 187   like($im->errstr, qr/image height/, "check message");
 188
 189   ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
 190   ok($im->read(file=>$limit_file),
 191      "should succeed - just inside width limit");
 192   ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
 193   ok($im->read(file=>$limit_file),
 194      "should succeed - just inside height limit");
 195
 196   # 150 x 150 x 3 channel image uses 67500 bytes
 197   ok(Imager->set_file_limits(reset=>1, bytes=>67499),
 198      "set bytes limit 67499");
 199   ok(!$im->read(file=>$limit_file),
 200      "should fail - too many bytes");
 201   print "# ",$im->errstr,"\n";
 202   like($im->errstr, qr/storage size/, "check error message");
 203   ok(Imager->set_file_limits(reset=>1, bytes=>67500),
 204      "set bytes limit 67500");
 205   ok($im->read(file=>$limit_file),
 206      "should succeed - just inside bytes limit");
 207   Imager->set_file_limits(reset=>1);
 208 }
 209
 210 {
 211   # check we correctly sync with the data stream
 212   my $im = Imager->new;
 213   ok($im->read(file => 'testimg/pgm.pgm', type => 'pnm'),
 214      "read pgm.pgm")
 215     or print "# cannot read pgm.pgm: ", $im->errstr, "\n";
 216   print "# ", $im->getsamples('y' => 0), "\n";
 217   is_color1($im->getpixel(x=>0, 'y' => 0), 254, "check top left");
 218 }
 219
 220 { # check error messages set correctly
 221   my $im = Imager->new;
 222   ok(!$im->read(file=>'t/200-file/310-pnm.t', type=>'pnm'),
 223      'should fail to read script as an image file');
 224   is($im->errstr, 'unable to read pnm image: bad header magic, not a PNM file',
 225      "check error message");
 226 }
 227
 228 {
 229   # RT #30074
 230   # give 4/2 channel images a background color when saving to pnm
 231   my $im = Imager->new(xsize=>16, ysize=>16, channels=>4);
 232   $im->box(filled => 1, xmin => 8, color => '#FFE0C0');
 233   $im->box(filled => 1, color => NC(0, 192, 192, 128),
 234            ymin => 8, xmax => 7);
 235   push @files, "t104_alpha.ppm";
 236   ok($im->write(file=>"testout/t104_alpha.ppm", type=>'pnm'),
 237      "should succeed writing 4 channel image");
 238   my $imread = Imager->new;
 239   ok($imread->read(file => 'testout/t104_alpha.ppm'), "read it back")
 240     or print "# ", $imread->errstr, "\n";
 241   is_color3($imread->getpixel('x' => 0, 'y' => 0), 0, 0, 0,
 242             "check transparent became black");
 243   is_color3($imread->getpixel('x' => 8, 'y' => 0), 255, 224, 192,
 244             "check color came through");
 245   is_color3($imread->getpixel('x' => 0, 'y' => 15), 0, 96, 96,
 246             "check translucent came through");
 247   my $data;
 248   ok($im->write(data => \$data, type => 'pnm', i_background => '#FF0000'),
 249      "write with red background");
 250   ok($imread->read(data => $data, type => 'pnm'),
 251      "read it back");
 252   is_color3($imread->getpixel('x' => 0, 'y' => 0), 255, 0, 0,
 253             "check transparent became red");
 254   is_color3($imread->getpixel('x' => 8, 'y' => 0), 255, 224, 192,
 255             "check color came through");
 256   is_color3($imread->getpixel('x' => 0, 'y' => 15), 127, 96, 96,
 257             "check translucent came through");
 258 }
 259
 260 {
 261   # more RT #30074 - 16 bit images
 262   my $im = Imager->new(xsize=>16, ysize=>16, channels=>4, bits => 16);
 263   $im->box(filled => 1, xmin => 8, color => '#FFE0C0');
 264   $im->box(filled => 1, color => NC(0, 192, 192, 128),
 265            ymin => 8, xmax => 7);
 266   push @files, "t104_alp16.ppm";
 267   ok($im->write(file=>"testout/t104_alp16.ppm", type=>'pnm',
 268                 pnm_write_wide_data => 1),
 269      "should succeed writing 4 channel image");
 270   my $imread = Imager->new;
 271   ok($imread->read(file => 'testout/t104_alp16.ppm'), "read it back");
 272   is($imread->bits, 16, "check we did produce a 16 bit image");
 273   is_color3($imread->getpixel('x' => 0, 'y' => 0), 0, 0, 0,
 274             "check transparent became black");
 275   is_color3($imread->getpixel('x' => 8, 'y' => 0), 255, 224, 192,
 276             "check color came through");
 277   is_color3($imread->getpixel('x' => 0, 'y' => 15), 0, 96, 96,
 278             "check translucent came through");
 279   my $data;
 280   ok($im->write(data => \$data, type => 'pnm', i_background => '#FF0000',
 281                 pnm_write_wide_data => 1),
 282      "write with red background");
 283   ok($imread->read(data => $data, type => 'pnm'),
 284      "read it back");
 285   is($imread->bits, 16, "check it's 16-bit");
 286   is_color3($imread->getpixel('x' => 0, 'y' => 0), 255, 0, 0,
 287             "check transparent became red");
 288   is_color3($imread->getpixel('x' => 8, 'y' => 0), 255, 224, 192,
 289             "check color came through");
 290   is_color3($imread->getpixel('x' => 0, 'y' => 15), 127, 96, 96,
 291             "check translucent came through");
 292 }
 293
 294 # various bad input files
 295 print "# check error handling\n";
 296 {
 297   my $im = Imager->new;
 298   ok(!$im->read(file => 'testimg/short_bin.ppm', type=>'pnm'),
 299      "fail to read short bin ppm");
 300   cmp_ok($im->errstr, '=~', 'short read - file truncated',
 301          "check error message");
 302 }
 303
 304 {
 305   my $im = Imager->new;
 306   ok(!$im->read(file => 'testimg/short_bin16.ppm', type=>'pnm'),
 307      "fail to read short bin ppm (maxval 65535)");
 308   cmp_ok($im->errstr, '=~', 'short read - file truncated',
 309          "check error message");
 310 }
 311
 312 {
 313   my $im = Imager->new;
 314   ok(!$im->read(file => 'testimg/short_bin.pgm', type=>'pnm'),
 315      "fail to read short bin pgm");
 316   cmp_ok($im->errstr, '=~', 'short read - file truncated',
 317          "check error message");
 318 }
 319
 320 {
 321   my $im = Imager->new;
 322   ok(!$im->read(file => 'testimg/short_bin16.pgm', type=>'pnm'),
 323      "fail to read short bin pgm (maxval 65535)");
 324   cmp_ok($im->errstr, '=~', 'short read - file truncated',
 325          "check error message");
 326 }
 327
 328 {
 329   my $im = Imager->new;
 330   ok(!$im->read(file => 'testimg/short_bin.pbm', type => 'pnm'),
 331      "fail to read a short bin pbm");
 332   cmp_ok($im->errstr, '=~', 'short read - file truncated',
 333          "check error message");
 334 }
 335
 336 {
 337   my $im = Imager->new;
 338   ok(!$im->read(file => 'testimg/short_asc.ppm', type => 'pnm'),
 339      "fail to read a short asc ppm");
 340   cmp_ok($im->errstr, '=~', 'short read - file truncated',
 341          "check error message");
 342 }
 343
 344 {
 345   my $im = Imager->new;
 346   ok(!$im->read(file => 'testimg/short_asc.pgm', type => 'pnm'),
 347      "fail to read a short asc pgm");
 348   cmp_ok($im->errstr, '=~', 'short read - file truncated',
 349          "check error message");
 350 }
 351
 352 {
 353   my $im = Imager->new;
 354   ok(!$im->read(file => 'testimg/short_asc.pbm', type => 'pnm'),
 355      "fail to read a short asc pbm");
 356   cmp_ok($im->errstr, '=~', 'short read - file truncated',
 357          "check error message");
 358 }
 359
 360 {
 361   my $im = Imager->new;
 362   ok(!$im->read(file => 'testimg/bad_asc.ppm', type => 'pnm'),
 363      "fail to read a bad asc ppm");
 364   cmp_ok($im->errstr, '=~', 'invalid data for ascii pnm',
 365          "check error message");
 366 }
 367
 368 {
 369   my $im = Imager->new;
 370   ok(!$im->read(file => 'testimg/bad_asc.pgm', type => 'pnm'),
 371      "fail to read a bad asc pgm");
 372   cmp_ok($im->errstr, '=~', 'invalid data for ascii pnm',
 373          "check error message");
 374 }
 375
 376 {
 377   my $im = Imager->new;
 378   ok(!$im->read(file => 'testimg/bad_asc.pbm', type => 'pnm'),
 379      "fail to read a bad asc pbm");
 380   cmp_ok($im->errstr, '=~', 'invalid data for ascii pnm',
 381          "check error message");
 382 }
 383
 384 {
 385   my $im = Imager->new;
 386   ok($im->read(file => 'testimg/short_bin.ppm', type => 'pnm',
 387                 allow_incomplete => 1),
 388      "partial read bin ppm");
 389   is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
 390   is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
 391 }
 392
 393 {
 394   my $im = Imager->new;
 395   ok($im->read(file => 'testimg/short_bin16.ppm', type => 'pnm',
 396                 allow_incomplete => 1),
 397      "partial read bin16 ppm");
 398   is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
 399   is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
 400   is($im->bits, 16, "check correct bits");
 401 }
 402
 403 {
 404   my $im = Imager->new;
 405   ok($im->read(file => 'testimg/short_bin.pgm', type => 'pnm',
 406                 allow_incomplete => 1),
 407      "partial read bin pgm");
 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   my $im = Imager->new;
 414   ok($im->read(file => 'testimg/short_bin16.pgm', type => 'pnm',
 415                 allow_incomplete => 1),
 416      "partial read bin16 pgm");
 417   is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
 418   is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
 419 }
 420
 421 {
 422   my $im = Imager->new;
 423   ok($im->read(file => 'testimg/short_bin.pbm', type => 'pnm',
 424                 allow_incomplete => 1),
 425      "partial read bin pbm");
 426   is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
 427   is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
 428 }
 429
 430 {
 431   my $im = Imager->new;
 432   ok($im->read(file => 'testimg/short_asc.ppm', type => 'pnm',
 433                 allow_incomplete => 1),
 434      "partial read asc ppm");
 435   is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
 436   is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
 437 }
 438
 439 {
 440   my $im = Imager->new;
 441   ok($im->read(file => 'testimg/short_asc.pgm', type => 'pnm',
 442                 allow_incomplete => 1),
 443      "partial read asc pgm");
 444   is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
 445   is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
 446 }
 447
 448 {
 449   my $im = Imager->new;
 450   ok($im->read(file => 'testimg/short_asc.pbm', type => 'pnm',
 451                 allow_incomplete => 1),
 452      "partial read asc pbm");
 453   is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
 454   is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
 455 }
 456
 457 {
 458   my @imgs = Imager->read_multi(file => 'testimg/multiple.ppm');
 459   is( 0+@imgs, 3, "Read 3 images");
 460   is( $imgs[0]->tags( name => 'pnm_type' ), 1, "Image 1 is type 1" );
 461   is( $imgs[0]->getwidth, 2, " ... width=2" );
 462   is( $imgs[0]->getheight, 2, " ... width=2" );
 463   is( $imgs[1]->tags( name => 'pnm_type' ), 6, "Image 2 is type 6" );
 464   is( $imgs[1]->getwidth, 164, " ... width=164" );
 465   is( $imgs[1]->getheight, 180, " ... width=180" );
 466   is( $imgs[2]->tags( name => 'pnm_type' ), 5, "Image 3 is type 5" );
 467   is( $imgs[2]->getwidth, 2, " ... width=2" );
 468   is( $imgs[2]->getheight, 2, " ... width=2" );
 469 }
 470
 471 {
 472   my $im = Imager->new;
 473   ok($im->read(file => 'testimg/bad_asc.ppm', type => 'pnm',
 474                 allow_incomplete => 1),
 475      "partial read bad asc ppm");
 476   is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
 477   is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
 478 }
 479
 480 {
 481   my $im = Imager->new;
 482   ok($im->read(file => 'testimg/bad_asc.pgm', type => 'pnm',
 483                 allow_incomplete => 1),
 484      "partial read bad asc pgm");
 485   is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
 486   is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
 487 }
 488
 489 {
 490   my $im = Imager->new;
 491   ok($im->read(file => 'testimg/bad_asc.pbm', type => 'pnm',
 492                 allow_incomplete => 1),
 493      "partial read bad asc pbm");
 494   is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
 495   is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
 496 }
 497
 498 {
 499   print "# monochrome output\n";
 500   my $im = Imager->new(xsize => 10, ysize => 10, channels => 1, type => 'paletted');
 501   ok($im->addcolors(colors => [ '#000000', '#FFFFFF' ]),
 502      "add black and white");
 503   $im->box(filled => 1, xmax => 4, color => '#000000');
 504   $im->box(filled => 1, xmin => 5, color => '#FFFFFF');
 505   is($im->type, 'paletted', 'mono still paletted');
 506   push @files, "t104_mono.pbm";
 507   ok($im->write(file => 'testout/t104_mono.pbm', type => 'pnm'),
 508      "save as pbm");
 509
 510   # check it
 511   my $imread = Imager->new;
 512   ok($imread->read(file => 'testout/t104_mono.pbm', type=>'pnm'),
 513      "read it back in")
 514     or print "# ", $imread->errstr, "\n";
 515   is($imread->type, 'paletted', "check result is paletted");
 516   is($imread->tags(name => 'pnm_type'), 4, "check type");
 517   is_image($im, $imread, "check image matches");
 518 }
 519
 520 {
 521   print "# monochrome output - reversed palette\n";
 522   my $im = Imager->new(xsize => 10, ysize => 10, channels => 1, type => 'paletted');
 523   ok($im->addcolors(colors => [ '#FFFFFF', '#000000' ]),
 524      "add white and black");
 525   $im->box(filled => 1, xmax => 4, color => '#000000');
 526   $im->box(filled => 1, xmin => 5, color => '#FFFFFF');
 527   is($im->type, 'paletted', 'mono still paletted');
 528   push @files, "t104_mono2.pbm";
 529   ok($im->write(file => 'testout/t104_mono2.pbm', type => 'pnm'),
 530      "save as pbm");
 531
 532   # check it
 533   my $imread = Imager->new;
 534   ok($imread->read(file => 'testout/t104_mono2.pbm', type=>'pnm'),
 535      "read it back in")
 536     or print "# ", $imread->errstr, "\n";
 537   is($imread->type, 'paletted', "check result is paletted");
 538   is($imread->tags(name => 'pnm_type'), 4, "check type");
 539   is_image($im, $imread, "check image matches");
 540 }
 541
 542 {
 543   print "# 16-bit output\n";
 544   my $data;
 545   my $im = test_image_16();
 546
 547   # without tag, it should do 8-bit output
 548   ok($im->write(data => \$data, type => 'pnm'),
 549      "write 16-bit image as 8-bit/sample ppm");
 550   my $im8 = Imager->new;
 551   ok($im8->read(data => $data), "read it back");
 552   is($im8->tags(name => 'pnm_maxval'), 255, "check maxval");
 553   is_image($im, $im8, "check image matches");
 554
 555   # try 16-bit output
 556   $im->settag(name => 'pnm_write_wide_data', value => 1);
 557   $data = '';
 558   ok($im->write(data => \$data, type => 'pnm'),
 559      "write 16-bit image as 16-bit/sample ppm");
 560   push @files, "t104_16.ppm";
 561   $im->write(file=>'testout/t104_16.ppm');
 562   my $im16 = Imager->new;
 563   ok($im16->read(data => $data), "read it back");
 564   is($im16->tags(name => 'pnm_maxval'), 65535, "check maxval");
 565   push @files, "t104_16b.ppm";
 566   $im16->write(file=>'testout/t104_16b.ppm');
 567   is_image($im, $im16, "check image matches");
 568 }
 569
 570 {
 571   ok(grep($_ eq 'pnm', Imager->read_types), "check pnm in read types");
 572   ok(grep($_ eq 'pnm', Imager->write_types), "check pnm in write types");
 573 }
 574
 575 { # test new() loading an image
 576   my $im = Imager->new(file => "testimg/penguin-base.ppm");
 577   ok($im, "received an image");
 578   is($im->getwidth, 164, "check width matches image");
 579
 580   # fail to load an image
 581   my $im2 = Imager->new(file => "Imager.pm", filetype => "pnm");
 582   ok(!$im2, "no image when file failed to load");
 583   cmp_ok(Imager->errstr, '=~', "bad header magic, not a PNM file",
 584          "check error message transferred");
 585
 586   # load from data
 587  SKIP:
 588   {
 589     ok(open(FH, "< testimg/penguin-base.ppm"), "open test file")
 590       or skip("couldn't open data source", 4);
 591     binmode FH;
 592     my $imdata = do { local $/; <FH> };
 593     close FH;
 594     ok(length $imdata, "we got the data");
 595     my $im3 = Imager->new(data => $imdata);
 596     ok($im3, "read the file data");
 597     is($im3->getwidth, 164, "check width matches image");
 598   }
 599 }
 600
 601 { # image too large handling
 602   {
 603     ok(!Imager->new(file => "testimg/toowide.ppm", filetype => "pnm"),
 604        "fail to read a too wide image");
 605     is(Imager->errstr, "unable to read pnm image: could not read image width: integer overflow",
 606        "check error message");
 607   }
 608   {
 609     ok(!Imager->new(file => "testimg/tootall.ppm", filetype => "pnm"),
 610        "fail to read a too wide image");
 611     is(Imager->errstr, "unable to read pnm image: could not read image height: integer overflow",
 612        "check error message");
 613   }
 614 }
 615
 616 { # make sure close is checked for each image type
 617   my $fail_close = sub {
 618     Imager::i_push_error(0, "synthetic close failure");
 619     return 0;
 620   };
 621
 622   for my $type (qw(basic basic16 gray gray16 mono)) {
 623     my $im = test_image_named($type);
 624     my $io = Imager::io_new_cb(sub { 1 }, undef, undef, $fail_close);
 625     ok(!$im->write(io => $io, type => "pnm"),
 626        "write $type image with a failing close handler");
 627     like($im->errstr, qr/synthetic close failure/,
 628          "check error message");
 629   }
 630 }
 631
 632 Imager->close_log;
 633
 634 unless ($ENV{IMAGER_KEEP_FILES}) {
 635   unlink "testout/t104ppm.log";
 636   unlink map "testout/$_", @files;
 637 }
 638
 639 sub openimage {
 640   my $fname = shift;
 641   local(*FH);
 642   open(FH, $fname) or die "Cannot open $fname: $!\n";
 643   binmode(FH);
 644   return *FH;
 645 }
 646
 647 sub slurp {
 648   my $fh = openimage(shift);
 649   local $/;
 650   my $data = <$fh>;
 651   close($fh);
 652   return $data;
 653 }
 654
 655 sub check_gray {
 656   my ($c, $gray) = @_;
 657
 658   my ($g) = $c->rgba;
 659   is($g, $gray, "compare gray");
 660 }
 661