t/t104ppm.t

   1 #!perl -w
   2 use Imager ':all';
   3 use lib 't';
   4 use Test::More tests => 60;
   5 use strict;
   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    = Imager::ImgRaw::new(150,150,3);
  14
  15 i_box_filled($img,70,25,130,125,$green);
  16 i_box_filled($img,20,25,80,125,$blue);
  17 i_arc($img,75,75,30,0,361,$red);
  18 i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
  19
  20 my $fh = openimage(">testout/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 open FH, "> testout/t104_gray.pgm" or die "Cannot create testout/t104_gray.pgm: $!\n";
  53 binmode FH;
  54 $IO = Imager::io_new_fd(fileno(FH));
  55 ok(i_writeppm_wiol($gimg, $IO), "write grayscale");
  56 close FH;
  57
  58 open FH, "< testout/t104_gray.pgm" or die "Cannot open testout/t104_gray.pgm: $!\n";
  59 binmode FH;
  60 $IO = Imager::io_new_fd(fileno(FH));
  61 my $gcmpimg = i_readpnm_wiol($IO, -1);
  62 ok($gcmpimg, "read grayscale");
  63 is(i_img_diff($gimg, $gcmpimg), 0,
  64    "compare written and read greyscale images");
  65
  66 my $ooim = Imager->new;
  67 ok($ooim->read(file=>"testimg/simple.pbm"), "read simple pbm, via OO");
  68
  69 check_gray(Imager::i_get_pixel($ooim->{IMG}, 0, 0), 255);
  70 check_gray(Imager::i_get_pixel($ooim->{IMG}, 0, 1), 0);
  71 check_gray(Imager::i_get_pixel($ooim->{IMG}, 1, 0), 0);
  72 check_gray(Imager::i_get_pixel($ooim->{IMG}, 1, 1), 255);
  73
  74 {
  75   # https://rt.cpan.org/Ticket/Display.html?id=7465
  76   # the pnm reader ignores the maxval that it reads from the pnm file
  77   my $maxval = Imager->new;
  78   ok($maxval->read(file=>"testimg/maxval.ppm"),
  79      "read testimg/maxval.ppm");
  80
  81   # this image contains three pixels, with each sample from 0 to 63
  82   # the pixels are (63, 63, 63), (32, 32, 32) and (31, 31, 0)
  83
  84   # check basic parameters
  85   is($maxval->getchannels, 3, "channel count");
  86   is($maxval->getwidth, 3, "width");
  87   is($maxval->getheight, 1, "height");
  88
  89   # check the pixels
  90   ok(my ($white, $grey, $green) = $maxval->getpixel('x'=>[0,1,2], 'y'=>[0,0,0]), "fetch pixels");
  91   check_color($white, 255, 255, 255, "white pixel");
  92   check_color($grey,  130, 130, 130, "grey  pixel");
  93   check_color($green, 125, 125, 0,   "green pixel");
  94
  95   # and do the same for ASCII images
  96   my $maxval_asc = Imager->new;
  97   ok($maxval_asc->read(file=>"testimg/maxval_asc.ppm"),
  98      "read testimg/maxval_asc.ppm");
  99
 100   # this image contains three pixels, with each sample from 0 to 63
 101   # the pixels are (63, 63, 63), (32, 32, 32) and (31, 31, 0)
 102
 103   # check basic parameters
 104   is($maxval_asc->getchannels, 3, "channel count");
 105   is($maxval_asc->getwidth, 3, "width");
 106   is($maxval_asc->getheight, 1, "height");
 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   check_color($white_asc, 255, 255, 255, "white asc pixel");
 111   check_color($grey_asc,  130, 130, 130, "grey  asc pixel");
 112   check_color($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, but Imager can't handle it yet in binary files
 132   my $maxval256 = Imager->new;
 133   ok(!$maxval256->read(file=>'testimg/maxval_256.ppm'),
 134      "should fail reading maxval 256 image");
 135   print "# ",$maxval256->errstr,"\n";
 136   like($maxval256->errstr, qr/maxval of 256 is over 255 - not currently supported by Imager/,
 137        "error expected from reading maxval_256.ppm");
 138
 139   # make sure we handle maxval > 255 for ascii
 140   my $maxval4095asc = Imager->new;
 141   ok($maxval4095asc->read(file=>'testimg/maxval_4095_asc.ppm'),
 142      "read maxval_4095_asc.ppm");
 143   is($maxval4095asc->getchannels, 3, "channels");
 144   is($maxval4095asc->getwidth, 3, "width");
 145   is($maxval4095asc->getheight, 1, "height");
 146
 147   ok(my ($white, $grey, $green) = $maxval4095asc->getpixel('x'=>[0,1,2], 'y'=>[0,0,0]), "fetch pixels");
 148   check_color($white, 255, 255, 255, "white 4095 pixel");
 149   check_color($grey,  128, 128, 128, "grey  4095 pixel");
 150   check_color($green, 127, 127, 0,   "green 4095 pixel");
 151 }
 152
 153 { # check i_format is set when reading a pnm file
 154   # doesn't really matter which file.
 155   my $maxval = Imager->new;
 156   ok($maxval->read(file=>"testimg/maxval.ppm"),
 157       "read test file");
 158   my ($type) = $maxval->tags(name=>'i_format');
 159   is($type, 'pnm', "check i_format");
 160 }
 161
 162 { # check file limits are checked
 163   my $limit_file = "testout/t104.ppm";
 164   ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
 165   my $im = Imager->new;
 166   ok(!$im->read(file=>$limit_file),
 167      "should fail read due to size limits");
 168   print "# ",$im->errstr,"\n";
 169   like($im->errstr, qr/image width/, "check message");
 170
 171   ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
 172   ok(!$im->read(file=>$limit_file),
 173      "should fail read due to size limits");
 174   print "# ",$im->errstr,"\n";
 175   like($im->errstr, qr/image height/, "check message");
 176
 177   ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
 178   ok($im->read(file=>$limit_file),
 179      "should succeed - just inside width limit");
 180   ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
 181   ok($im->read(file=>$limit_file),
 182      "should succeed - just inside height limit");
 183
 184   # 150 x 150 x 3 channel image uses 67500 bytes
 185   ok(Imager->set_file_limits(reset=>1, bytes=>67499),
 186      "set bytes limit 67499");
 187   ok(!$im->read(file=>$limit_file),
 188      "should fail - too many bytes");
 189   print "# ",$im->errstr,"\n";
 190   like($im->errstr, qr/storage size/, "check error message");
 191   ok(Imager->set_file_limits(reset=>1, bytes=>67500),
 192      "set bytes limit 67500");
 193   ok($im->read(file=>$limit_file),
 194      "should succeed - just inside bytes limit");
 195   Imager->set_file_limits(reset=>1);
 196 }
 197
 198 sub openimage {
 199   my $fname = shift;
 200   local(*FH);
 201   open(FH, $fname) or die "Cannot open $fname: $!\n";
 202   binmode(FH);
 203   return *FH;
 204 }
 205
 206 sub slurp {
 207   my $fh = openimage(shift);
 208   local $/;
 209   my $data = <$fh>;
 210   close($fh);
 211   return $data;
 212 }
 213
 214 sub check_gray {
 215   my ($c, $gray) = @_;
 216
 217   my ($g) = $c->rgba;
 218   is($g, $gray, "compare gray");
 219 }
 220
 221 sub check_color {
 222   my ($c, $red, $green, $blue, $note) = @_;
 223
 224   my ($r, $g, $b) = $c->rgba;
 225   is_deeply([ $r, $g, $b], [ $red, $green, $blue ],
 226             "$note ($r, $g, $b) compared to ($red, $green, $blue)");
 227 }