- set i_format to pnm when reading pnm files and test for it
[imager.git] / t / t104ppm.t
1 #!perl -w
2 use Imager ':all';
3 BEGIN { require "t/testtools.pl"; }
4 use strict;
5
6 print "1..45\n";
7
8 init_log("testout/t104ppm.log",1);
9
10 my $green = i_color_new(0,255,0,255);
11 my $blue  = i_color_new(0,0,255,255);
12 my $red   = i_color_new(255,0,0,255);
13
14 my $img    = Imager::ImgRaw::new(150,150,3);
15
16 i_box_filled($img,70,25,130,125,$green);
17 i_box_filled($img,20,25,80,125,$blue);
18 i_arc($img,75,75,30,0,361,$red);
19 i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
20
21 my $fh = openimage(">testout/t104.ppm");
22 my $IO = Imager::io_new_fd(fileno($fh));
23 i_writeppm_wiol($img, $IO) 
24   or die "Cannot write testout/t104.ppm\n";
25 close($fh);
26
27 print "ok 1\n";
28
29 $IO = Imager::io_new_bufchain();
30 i_writeppm_wiol($img, $IO) or die "Cannot write to bufchain";
31 my $data = Imager::io_slurp($IO);
32 print "ok 2\n";
33
34 $fh = openimage("testout/t104.ppm");
35 $IO = Imager::io_new_fd( fileno($fh) );
36 my $cmpimg = i_readpnm_wiol($IO,-1) || die "Cannot read testout/t104.ppm\n";
37 close($fh);
38 print "ok 3\n";
39
40 print i_img_diff($img, $cmpimg) ? "not ok 4 # saved image different\n" : "ok 4\n";
41
42 my $rdata = slurp("testout/t104.ppm");
43 print "not " if $rdata ne $data;
44 print "ok 5\n";
45
46
47 # build a grayscale image
48 my $gimg = Imager::ImgRaw::new(150, 150, 1);
49 my $gray = i_color_new(128, 0, 0, 255);
50 my $dgray = i_color_new(64, 0, 0, 255);
51 my $white = i_color_new(255, 0, 0, 255);
52 i_box_filled($gimg, 20, 20, 130, 130, $gray);
53 i_box_filled($gimg, 40, 40, 110, 110, $dgray);
54 i_arc($gimg, 75, 75, 30, 0, 361, $white);
55
56 open FH, "> testout/t104_gray.pgm" or die "Cannot create testout/t104_gray.pgm: $!\n";
57 binmode FH;
58 $IO = Imager::io_new_fd(fileno(FH));
59 i_writeppm_wiol($gimg, $IO) or print "not ";
60 print "ok 6\n";
61 close FH;
62
63 open FH, "< testout/t104_gray.pgm" or die "Cannot open testout/t104_gray.pgm: $!\n";
64 binmode FH;
65 $IO = Imager::io_new_fd(fileno(FH));
66 my $gcmpimg = i_readpnm_wiol($IO, -1) or print "not ";
67 print "ok 7\n";
68 i_img_diff($gimg, $gcmpimg) == 0 or print "not ";
69 print "ok 8\n";
70
71 my $ooim = Imager->new;
72 $ooim->read(file=>"testimg/simple.pbm") or print "not ";
73 print "ok 9\n";
74
75 check_gray(10, Imager::i_get_pixel($ooim->{IMG}, 0, 0), 255);
76 check_gray(11, Imager::i_get_pixel($ooim->{IMG}, 0, 1), 0);
77 check_gray(12, Imager::i_get_pixel($ooim->{IMG}, 1, 0), 0);
78 check_gray(13, Imager::i_get_pixel($ooim->{IMG}, 1, 1), 255);
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   $maxval->read(file=>"testimg/maxval.ppm") or print "not ";
85   print "ok 14 # read testimg/maxval.ppm\n";
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   $maxval->getchannels == 3 or print "not ";
92   print "ok 15 # channel count\n";
93   $maxval->getwidth == 3 or print "not ";
94   print "ok 16 # width\n";
95   $maxval->getheight == 1 or print "not ";
96   print "ok 17 # height\n";
97   
98   # check the pixels
99   my ($white, $grey, $green) = $maxval->getpixel('x'=>[0,1,2], 'y'=>[0,0,0])
100     or print "not ";
101   print "ok 18 # fetch pixels\n";
102   check_color(19, $white, 255, 255, 255, "white pixel");
103   check_color(20, $grey,  130, 130, 130, "grey  pixel");
104   check_color(21, $green, 125, 125, 0,   "green pixel");
105
106   # and do the same for ASCII images
107   my $maxval_asc = Imager->new;
108   $maxval_asc->read(file=>"testimg/maxval_asc.ppm") or print "not ";
109   print "ok 22 # read testimg/maxval_asc.ppm\n";
110   
111   # this image contains three pixels, with each sample from 0 to 63
112   # the pixels are (63, 63, 63), (32, 32, 32) and (31, 31, 0)
113   
114   # check basic parameters
115   $maxval_asc->getchannels == 3 or print "not ";
116   print "ok 23 # channel count\n";
117   $maxval_asc->getwidth == 3 or print "not ";
118   print "ok 24 # width\n";
119   $maxval_asc->getheight == 1 or print "not ";
120   print "ok 25 # height\n";
121   
122   # check the pixels
123   my ($white_asc, $grey_asc, $green_asc) = $maxval_asc->getpixel('x'=>[0,1,2], 'y'=>[0,0,0])
124     or print "not ";
125   print "ok 26 # fetch pixels\n";
126   check_color(27, $white_asc, 255, 255, 255, "white asc pixel");
127   check_color(28, $grey_asc,  130, 130, 130, "grey  asc pixel");
128   check_color(29, $green_asc, 125, 125, 0,   "green asc pixel");
129 }
130
131 { # previously we didn't validate maxval at all, make sure it's
132   # validated now
133   my $maxval0 = Imager->new;
134   $maxval0->read(file=>'testimg/maxval_0.ppm') and print "not ";
135   print "ok 30 # reading maxval 0 image\n";
136   print "# ", $maxval0->errstr, "\n";
137   $maxval0->errstr =~ /maxval is zero - invalid pnm file/
138     or print "not ";
139   print "ok 31 # error expected from reading maxval_0.ppm\n";
140
141   my $maxval65536 = Imager->new;
142   $maxval65536->read(file=>'testimg/maxval_65536.ppm') and print "not ";
143   print "ok 32 # reading maxval 65536 image\n";
144   print "# ",$maxval65536->errstr, "\n";
145   $maxval65536->errstr =~ /maxval of 65536 is over 65535 - invalid pnm file/
146     or print "not ";
147   print "ok 33 # error expected from reading maxval_65536.ppm\n";
148
149   # maxval of 256 is valid, but Imager can't handle it yet in binary files
150   my $maxval256 = Imager->new;
151   $maxval256->read(file=>'testimg/maxval_256.ppm') and print "not ";
152   print "ok 34 # reading maxval 256 image\n";
153   print "# ",$maxval256->errstr,"\n";
154   $maxval256->errstr =~ /maxval of 256 is over 255 - not currently supported by Imager/
155     or print "not ";
156   print "ok 35 # error expected from reading maxval_256.ppm\n";
157
158   # make sure we handle maxval > 255 for ascii
159   my $maxval4095asc = Imager->new;
160   okn(36, $maxval4095asc->read(file=>'testimg/maxval_4095_asc.ppm'),
161      "read maxval_4095_asc.ppm");
162   okn(37, $maxval4095asc->getchannels == 3, "channels");
163   okn(38, $maxval4095asc->getwidth == 3, "width");
164   okn(39, $maxval4095asc->getheight == 1, "height");
165
166   my ($white, $grey, $green) = $maxval4095asc->getpixel('x'=>[0,1,2], 'y'=>[0,0,0])
167     or print "not ";
168   print "ok 40 # fetch pixels\n";
169   check_color(41, $white, 255, 255, 255, "white 4095 pixel");
170   check_color(42, $grey,  128, 128, 128, "grey  4095 pixel");
171   check_color(43, $green, 127, 127, 0,   "green 4095 pixel");
172 }
173
174 my $num = 44;
175 { # check i_format is set when reading a pnm file
176   # doesn't really matter which file.
177   my $maxval = Imager->new;
178   okn($num++, $maxval->read(file=>"testimg/maxval.ppm"),
179       "read test file");
180   my ($type) = $maxval->tags(name=>'i_format');
181   isn($num++, $type, 'pnm', "check i_format");
182 }
183
184 sub openimage {
185   my $fname = shift;
186   local(*FH);
187   open(FH, $fname) or die "Cannot open $fname: $!\n";
188   binmode(FH);
189   return *FH;
190 }
191
192 sub slurp {
193   my $fh = openimage(shift);
194   local $/;
195   my $data = <$fh>;
196   close($fh);
197   return $data;
198 }
199
200 sub check_gray {
201   my ($num, $c, $gray) = @_;
202
203   my ($g) = $c->rgba;
204   if ($g == $gray) {
205     print "ok $num\n";
206   }
207   else {
208     print "not ok $num # $g doesn't match $gray\n";
209   }
210 }
211
212 sub check_color {
213   my ($num, $c, $red, $green, $blue, $note) = @_;
214
215   my ($r, $g, $b) = $c->rgba;
216   if ($r == $red && $g == $green && $b == $blue) {
217     print "ok $num # $note\n";
218   }
219   else {
220     print "not ok $num # ($r, $g, $b) doesn't match ($red, $green, $blue)\n";
221   }
222 }