t/t104ppm.t

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