]>
Commit | Line | Data |
---|---|---|
8b695554 | 1 | #!perl -w |
0baa1a31 | 2 | use Imager ':all'; |
6d5c85a2 | 3 | use Test::More tests => 205; |
8b695554 | 4 | use strict; |
6d5c85a2 TC |
5 | use Imager::Test qw(test_image_raw test_image_16 is_color3 is_color1 is_image test_image_named); |
6 | ||
7 | $| = 1; | |
0baa1a31 | 8 | |
40e78f96 TC |
9 | -d "testout" or mkdir "testout"; |
10 | ||
cc59eadc | 11 | Imager->open_log(log => "testout/t104ppm.log"); |
0baa1a31 | 12 | |
067d6bdc AMH |
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); | |
0baa1a31 | 16 | |
cc59eadc TC |
17 | my @files; |
18 | ||
9c106321 | 19 | my $img = test_image_raw(); |
0baa1a31 | 20 | |
790923a4 | 21 | my $fh = openimage(">testout/t104.ppm"); |
cc59eadc | 22 | push @files, "t104.ppm"; |
8b695554 | 23 | my $IO = Imager::io_new_fd(fileno($fh)); |
3a927a6b | 24 | ok(i_writeppm_wiol($img, $IO), "write pnm low") |
067d6bdc AMH |
25 | or die "Cannot write testout/t104.ppm\n"; |
26 | close($fh); | |
0baa1a31 | 27 | |
067d6bdc | 28 | $IO = Imager::io_new_bufchain(); |
3a927a6b TC |
29 | ok(i_writeppm_wiol($img, $IO), "write to bufchain") |
30 | or die "Cannot write to bufchain"; | |
8b695554 | 31 | my $data = Imager::io_slurp($IO); |
0baa1a31 | 32 | |
067d6bdc AMH |
33 | $fh = openimage("testout/t104.ppm"); |
34 | $IO = Imager::io_new_fd( fileno($fh) ); | |
3a927a6b TC |
35 | my $cmpimg = i_readpnm_wiol($IO,-1); |
36 | ok($cmpimg, "read image we wrote") | |
37 | or die "Cannot read testout/t104.ppm\n"; | |
067d6bdc | 38 | close($fh); |
0baa1a31 | 39 | |
3a927a6b | 40 | is(i_img_diff($img, $cmpimg), 0, "compare written and read images"); |
067d6bdc AMH |
41 | |
42 | my $rdata = slurp("testout/t104.ppm"); | |
3a927a6b | 43 | is($data, $rdata, "check data read from file and bufchain data"); |
0baa1a31 | 44 | |
9f56d386 TC |
45 | # build a grayscale image |
46 | my $gimg = Imager::ImgRaw::new(150, 150, 1); | |
cd62a5a7 TC |
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); | |
9f56d386 TC |
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); | |
067d6bdc | 53 | |
cc59eadc | 54 | push @files, "t104_gray.pgm"; |
067d6bdc | 55 | open FH, "> testout/t104_gray.pgm" or die "Cannot create testout/t104_gray.pgm: $!\n"; |
9f56d386 | 56 | binmode FH; |
8b695554 | 57 | $IO = Imager::io_new_fd(fileno(FH)); |
3a927a6b | 58 | ok(i_writeppm_wiol($gimg, $IO), "write grayscale"); |
9f56d386 | 59 | close FH; |
067d6bdc AMH |
60 | |
61 | open FH, "< testout/t104_gray.pgm" or die "Cannot open testout/t104_gray.pgm: $!\n"; | |
9f56d386 TC |
62 | binmode FH; |
63 | $IO = Imager::io_new_fd(fileno(FH)); | |
3a927a6b TC |
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"); | |
067d6bdc | 68 | |
91492c5e | 69 | my $ooim = Imager->new; |
6d5c85a2 TC |
70 | ok($ooim->read(file=>"testimg/simple.pbm"), "read simple pbm, via OO") |
71 | or print "# ", $ooim->errstr, "\n"; | |
91492c5e | 72 | |
9c106321 TC |
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"); | |
91492c5e | 79 | |
8b695554 TC |
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; | |
3a927a6b TC |
84 | ok($maxval->read(file=>"testimg/maxval.ppm"), |
85 | "read testimg/maxval.ppm"); | |
8b695554 TC |
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 | |
3a927a6b TC |
91 | is($maxval->getchannels, 3, "channel count"); |
92 | is($maxval->getwidth, 3, "width"); | |
93 | is($maxval->getheight, 1, "height"); | |
8b695554 TC |
94 | |
95 | # check the pixels | |
3a927a6b | 96 | ok(my ($white, $grey, $green) = $maxval->getpixel('x'=>[0,1,2], 'y'=>[0,0,0]), "fetch pixels"); |
9c106321 TC |
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"); | |
8b695554 TC |
101 | |
102 | # and do the same for ASCII images | |
103 | my $maxval_asc = Imager->new; | |
3a927a6b TC |
104 | ok($maxval_asc->read(file=>"testimg/maxval_asc.ppm"), |
105 | "read testimg/maxval_asc.ppm"); | |
8b695554 TC |
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 | |
3a927a6b TC |
111 | is($maxval_asc->getchannels, 3, "channel count"); |
112 | is($maxval_asc->getwidth, 3, "width"); | |
113 | is($maxval_asc->getheight, 1, "height"); | |
9c106321 TC |
114 | |
115 | is($maxval->tags(name=>'pnm_type'), 6, "check pnm_type tag on maxval"); | |
8b695554 TC |
116 | |
117 | # check the pixels | |
3a927a6b | 118 | ok(my ($white_asc, $grey_asc, $green_asc) = $maxval_asc->getpixel('x'=>[0,1,2], 'y'=>[0,0,0]), "fetch pixels"); |
9c106321 TC |
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"); | |
8b695554 TC |
122 | } |
123 | ||
124 | { # previously we didn't validate maxval at all, make sure it's | |
125 | # validated now | |
126 | my $maxval0 = Imager->new; | |
3a927a6b TC |
127 | ok(!$maxval0->read(file=>'testimg/maxval_0.ppm'), |
128 | "should fail to read maxval 0 image"); | |
8b695554 | 129 | print "# ", $maxval0->errstr, "\n"; |
3a927a6b TC |
130 | like($maxval0->errstr, qr/maxval is zero - invalid pnm file/, |
131 | "error expected from reading maxval_0.ppm"); | |
8b695554 TC |
132 | |
133 | my $maxval65536 = Imager->new; | |
3a927a6b TC |
134 | ok(!$maxval65536->read(file=>'testimg/maxval_65536.ppm'), |
135 | "should fail reading maxval 65536 image"); | |
8b695554 | 136 | print "# ",$maxval65536->errstr, "\n"; |
3a927a6b TC |
137 | like($maxval65536->errstr, qr/maxval of 65536 is over 65535 - invalid pnm file/, |
138 | "error expected from reading maxval_65536.ppm"); | |
8b695554 | 139 | |
9c106321 | 140 | # maxval of 256 is valid, and handled as of 0.56 |
8b695554 | 141 | my $maxval256 = Imager->new; |
9c106321 TC |
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"); | |
8b695554 TC |
149 | |
150 | # make sure we handle maxval > 255 for ascii | |
151 | my $maxval4095asc = Imager->new; | |
3a927a6b | 152 | ok($maxval4095asc->read(file=>'testimg/maxval_4095_asc.ppm'), |
8b695554 | 153 | "read maxval_4095_asc.ppm"); |
3a927a6b TC |
154 | is($maxval4095asc->getchannels, 3, "channels"); |
155 | is($maxval4095asc->getwidth, 3, "width"); | |
156 | is($maxval4095asc->getheight, 1, "height"); | |
9c106321 | 157 | is($maxval4095asc->bits, 16, "check bits/sample on maxval 4095"); |
3a927a6b TC |
158 | |
159 | ok(my ($white, $grey, $green) = $maxval4095asc->getpixel('x'=>[0,1,2], 'y'=>[0,0,0]), "fetch pixels"); | |
9c106321 TC |
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"); | |
8b695554 TC |
163 | } |
164 | ||
642a675b TC |
165 | { # check i_format is set when reading a pnm file |
166 | # doesn't really matter which file. | |
167 | my $maxval = Imager->new; | |
3a927a6b | 168 | ok($maxval->read(file=>"testimg/maxval.ppm"), |
642a675b TC |
169 | "read test file"); |
170 | my ($type) = $maxval->tags(name=>'i_format'); | |
3a927a6b | 171 | is($type, 'pnm', "check i_format"); |
642a675b TC |
172 | } |
173 | ||
77157728 TC |
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 | ||
9c106321 TC |
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'), | |
73497ab9 TC |
214 | "read pgm.pgm") |
215 | or print "# cannot read pgm.pgm: ", $im->errstr, "\n"; | |
9c106321 TC |
216 | print "# ", $im->getsamples('y' => 0), "\n"; |
217 | is_color1($im->getpixel(x=>0, 'y' => 0), 254, "check top left"); | |
218 | } | |
219 | ||
2691d220 | 220 | { # check error messages set correctly |
fa90de94 | 221 | my $im = Imager->new; |
2691d220 TC |
222 | ok(!$im->read(file=>'t/t104ppm.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 | ||
fa90de94 TC |
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); | |
cc59eadc | 235 | push @files, "t104_alpha.ppm"; |
fa90de94 TC |
236 | ok($im->write(file=>"testout/t104_alpha.ppm", type=>'pnm'), |
237 | "should succeed writing 4 channel image"); | |
238 | my $imread = Imager->new; | |
6d5c85a2 TC |
239 | ok($imread->read(file => 'testout/t104_alpha.ppm'), "read it back") |
240 | or print "# ", $imread->errstr, "\n"; | |
fa90de94 TC |
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); | |
cc59eadc | 266 | push @files, "t104_alp16.ppm"; |
fa90de94 TC |
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 | ||
9c106321 TC |
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', | |
dfe73b78 | 387 | allow_incomplete => 1), |
9c106321 TC |
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', | |
dfe73b78 | 396 | allow_incomplete => 1), |
9c106321 TC |
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', | |
dfe73b78 | 406 | allow_incomplete => 1), |
9c106321 TC |
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', | |
dfe73b78 | 415 | allow_incomplete => 1), |
9c106321 TC |
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', | |
dfe73b78 | 424 | allow_incomplete => 1), |
9c106321 TC |
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', | |
dfe73b78 | 433 | allow_incomplete => 1), |
9c106321 TC |
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', | |
dfe73b78 | 442 | allow_incomplete => 1), |
9c106321 TC |
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', | |
dfe73b78 | 451 | allow_incomplete => 1), |
9c106321 TC |
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 | ||
2086be61 TC |
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 | ||
9c106321 TC |
471 | { |
472 | my $im = Imager->new; | |
473 | ok($im->read(file => 'testimg/bad_asc.ppm', type => 'pnm', | |
dfe73b78 | 474 | allow_incomplete => 1), |
9c106321 TC |
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', | |
dfe73b78 | 483 | allow_incomplete => 1), |
9c106321 TC |
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', | |
dfe73b78 | 492 | allow_incomplete => 1), |
9c106321 TC |
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"; | |
57c9ce6a | 500 | my $im = Imager->new(xsize => 10, ysize => 10, channels => 1, type => 'paletted'); |
9c106321 TC |
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'); | |
cc59eadc | 506 | push @files, "t104_mono.pbm"; |
9c106321 TC |
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"); | |
57c9ce6a TC |
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'); | |
cc59eadc | 528 | push @files, "t104_mono2.pbm"; |
57c9ce6a TC |
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"); | |
9c106321 TC |
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"); | |
cc59eadc | 560 | push @files, "t104_16.ppm"; |
9c106321 TC |
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"); | |
cc59eadc | 565 | push @files, "t104_16b.ppm"; |
9c106321 TC |
566 | $im16->write(file=>'testout/t104_16b.ppm'); |
567 | is_image($im, $im16, "check image matches"); | |
568 | } | |
569 | ||
f245645a TC |
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 | ||
3c252111 TC |
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"); | |
75812841 TC |
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); | |
1d7e3124 | 591 | binmode FH; |
75812841 TC |
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 | } | |
3c252111 TC |
599 | } |
600 | ||
8d14daab TC |
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 | ||
6d5c85a2 TC |
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 | ||
cc59eadc TC |
634 | unless ($ENV{IMAGER_KEEP_FILES}) { |
635 | unlink "testout/t104ppm.log"; | |
636 | unlink map "testout/$_", @files; | |
637 | } | |
638 | ||
067d6bdc AMH |
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 | } | |
0baa1a31 | 646 | |
067d6bdc AMH |
647 | sub slurp { |
648 | my $fh = openimage(shift); | |
649 | local $/; | |
650 | my $data = <$fh>; | |
651 | close($fh); | |
652 | return $data; | |
653 | } | |
91492c5e TC |
654 | |
655 | sub check_gray { | |
3a927a6b | 656 | my ($c, $gray) = @_; |
91492c5e TC |
657 | |
658 | my ($g) = $c->rgba; | |
3a927a6b | 659 | is($g, $gray, "compare gray"); |
91492c5e | 660 | } |
8b695554 | 661 |