File Coverage

blib/lib/Image/PBMlib.pm
Criterion Covered Total %
statement 929 1183 78.5
branch 395 550 71.8
condition 69 156 44.2
subroutine 45 51 88.2
pod 23 46 50.0
total 1461 1986 73.5


line stmt bran cond sub pod time code
1             #! perl -w
2             # A PBM/PGM/PPM library.
3             # Benjamin Elijah Griffin 28 Feb 2012
4             # elijah@cpan.org
5              
6             package Image::PBMlib;
7 14     14   431457 use 5.010000;
  14         55  
  14         627  
8 14     14   93 use strict;
  14         26  
  14         707  
9 14     14   77 use warnings;
  14         30  
  14         587  
10              
11 14     14   80 use vars qw( @ISA @EXPORT );
  14         26  
  14         2452  
12             require Exporter;
13             @ISA = qw(Exporter);
14              
15             @EXPORT = qw( readpnmfile checkpnminfo readpnmheader readpnmpixels
16             makepnmheader encodepixels writepnmfile inspectpixels
17             explodetriple rescaleval rescaletriple
18             hextripletofloat dectripletofloat
19             hexvaltofloat decvaltofloat
20             floattripletodec floattripletohex
21             floatvaltodec floatvaltohex
22             comparefloatval comparefloattriple
23             comparepixelval comparepixeltriple
24             );
25              
26             $Image::PBMlib::VERSION = '2.00';
27              
28             =head1 NAME
29              
30             Image::PBMlib - Helper functions for PBM/PGM/PPM image file formats
31              
32             =head1 SYNOPSIS
33              
34             use Image::PBMlib;
35              
36             ... open(PNM, '<:raw', "image.ppm")...
37              
38             my (%info, @pixels);
39             # fourth is encoding of float, dec, or hex
40             readpnmfile( \*PNM, \%info, \@pixels, 'float' );
41             # sets $info{error} if an error
42              
43             readpnmheader( \*PNM, \%info );
44             # sets $info{error} if an error
45              
46             checkpnminfo( \%info );
47             # sets $info{error} if an error
48              
49             # float, dec, or hex
50             readpnmpixels( \*PNM, \%info, \@pixels, 'float')
51             # sets $info{error} if an error
52              
53             # R/G/B to RRRR/GGGG/BBBB, max 1 to 65535
54             my $rgb = hextripletofloat( "F00/B/A4", $maxvalue );
55              
56             # R:G:B, max 1 to 65535
57             my $rgb = dectripletofloat( "3840:11:164", $maxvalue );
58              
59             # returns the number of bytes written, as a positive
60             # number if no error, and zero or -1*bytes if error
61             my $return = writepnmfile(\*PNM, \%info, \@pixels);
62              
63             # this header can contain comments
64             my $header = makepnmheader(\%info);
65              
66             # this header will not contain comments
67             # 1 for ascii PBM, 2 for ascii PGM, 3 for ascii PPM,
68             # 4 for raw PBM, 5 for raw PGM, 6 for raw PPM
69             my $header = makepnmheader('5', $width, $height, $maxvalue);
70              
71             # raw, dec, or hex format pixels, in 'raw' or 'ascii'
72             # for writing to a file
73             my $block = encodepixels('raw', $maxvalue, \@pixels);
74              
75             =head1 DESCRIPTION
76              
77             This is primarily a library for reading and writing portable bitmap (PBM),
78             portable graymap (PGM), and portable pixmap (PPM) files. As a
79             set they are portable anymap (PNM). There is a separate PAM
80             format that is not yet supported. Within each format there are
81             two representations on disk, ASCII and RAW. ASCII is suitable
82             for raw email transmission, short lines, all 7-bit characters.
83             RAW is much more compact and generally preferred. A single RAW
84             formatted file can contain multiple concatenated images.
85              
86             These image formats are only the barest step up from raw raster
87             data, and have a very simple format which is the key to be "portable".
88             Writing out images in these formats is very easy. Reading only
89             slightly more complicated.
90              
91             =head2 Maxvalue
92              
93             Version 1.x of this library had serious bugs except for the most
94             basic versions of PGM and PPM files, by not properly observing
95             the maxvalue. Version 2.x fixes that at a compatiblity cost. Raw
96             gray and color channel information is now stored as a floating
97             point number from 0.0 as full black to 1.0 as full white, and
98             it is scaled to the approprate maxvalue, which is a decimal integer
99             from 1 to 65535 inclusive.
100              
101             =head2 Pixels
102              
103             When this version of the library returns a pixel it will be:
104             "0" or "1" for PBM files; "0.0," to "1.0," for PGM in float
105             format, "0:" to "65535:" for PGM in decimal, "0/" to "FFFF/"
106             for PGM in hexadecimal; "0.0,0.0,0.0" to "1.0,1.0,1.0" for
107             PPM in float, "0:0:0" to "65535:65535:65535" for PPM in decimal,
108             and "FFFF/FFFF/FFFF" for PPM in hexadecimal.
109              
110             That is to say PBM files always return just zeros and ones,
111             regardless of float, dec, or hex settings.
112              
113             PGM files return a floating point number, an unrescaled dec or
114             hex value, but always followed by a comma if float, a colon if
115             decimal, and a slash if hex. Unrescaled means that if the
116             maxvalue is 1000 (decimal integer), then white is "1.0," in
117             float, "1000:" in dec, and "3E8/" in hex.
118              
119             PPM files return a RGB set of floating point numbers, an
120             unrescaled set of dec or hex values, which are always separated
121             by commas if float, colons if decimal, and slashes if hex. Be sure
122             to read what unscaled means in the previous paragraph.
123              
124             Image::PBMlib likes pixels in a two dimensional array, but can
125             use a single dimensional array.
126              
127             =cut
128              
129 14     14   237500 BEGIN {
130             } # end BEGIN
131              
132              
133             # Internal read header function. Does not do argument checks.
134             sub int_readpnmheader {
135 13     13 0 23 my $gr = shift; # input file glob ref
136 13         18 my $ir = shift; # image info hash ref
137 13         25 my $in = '';
138 13         17 my $pre = '';
139 13         16 my $no_comments;
140             my $rc;
141              
142 13         296 $rc = read($gr, $in, 3);
143              
144 13 50 33     87 if (!defined($rc) or $rc != 3) {
145 0         0 $$ir{error} = 'Read error or EOF on magic number';
146 0         0 $$ir{fullheader} = $in;
147 0         0 return;
148             }
149              
150 13 100       42 if ($in =~ /\nP[123456]/) {
151             # hmmm. bad concatenated file?
152 2         5 my $peek;
153 2         4 $rc = read($gr, $peek, 1);
154 2 50 33     15 if($rc and $peek eq "\n") {
155 2         7 $in =~ s/^\n//;
156 2         6 $in .= "\n";
157             }
158             }
159              
160 13 50       51 if ($in =~ /^P([123456])\s/) {
161 13         36 $$ir{type} = $1;
162 13 100       42 if ($$ir{type} > 3) {
163 8         17 $$ir{raw} = 1;
164 8         20 $$ir{format} = 'raw';
165             } else {
166 5         11 $$ir{raw} = 0;
167 5         16 $$ir{format} = 'ascii';
168             }
169              
170 13 100 100     100 if ($$ir{type} == 1 or $$ir{type} == 4) {
    100 100        
171 5         11 $$ir{max} = 1;
172 5         7 $$ir{bgp} = 'b';
173             } elsif ($$ir{type} == 2 or $$ir{type} == 5) {
174 4         11 $$ir{bgp} = 'g';
175             } else {
176 4         9 $$ir{bgp} = 'p';
177             }
178              
179 13         21 while(1) {
180 88         190 $rc = read($gr, $in, 1, length($in));
181 88 50 33     336 if (!defined($rc) or $rc != 1) {
182 0         0 $$ir{error} = 'Read error or EOF during header';
183 0         0 $$ir{fullheader} = $in;
184 0         0 return;
185             }
186              
187             # yes, really reset ir{comments} every time through loop
188 88         103 $no_comments = $in;
189 88         120 $$ir{comments} = '';
190 88         260 while ($no_comments =~ /#.*\n/) {
191 0         0 $no_comments =~ s/#(.*\n)/ /;
192 0         0 $$ir{comments} .= $1;
193             }
194              
195 88 100       155 if ($$ir{bgp} eq 'b') {
196 20 100       54 if ($no_comments =~ /^P\d\s+(\d+)\s+(\d+)\s/) {
197 5         18 $$ir{width} = $1;
198 5         14 $$ir{height} = $2;
199 5         15 $$ir{pixels} = $1*$2;
200 5         6 last;
201             }
202             } else {
203             # graymap and pixmap
204 68 100       197 if ($no_comments =~ /^P\d\s+(\d+)\s+(\d+)\s+(\d+)\s/) {
205 8         24 $$ir{width} = $1;
206 8         26 $$ir{height} = $2;
207 8         23 $$ir{max} = $3;
208 8         21 $$ir{pixels} = $1*$2;
209 8         11 last;
210             }
211             }
212             } # while reading header
213              
214 13         26 $$ir{error} = '';
215             } else {
216 0         0 $$ir{error} = 'Wrong magic number';
217             }
218              
219 13         29 $$ir{fullheader} = $in;
220 13         37 return;
221             } # end &int_readpnmheader
222              
223             # internal single value to float function
224             sub int_decvaltofloat {
225 16     16 0 25 my $v = shift;
226 16         20 my $m = shift;
227 16         17 my $p;
228              
229             # eat our own dog food for indicating a decimal value
230 16         32 $v =~ s/:$//;
231              
232 16 100       47 if($v >= $m) {
    50          
233 4         7 $p = '1.0,';
234             } elsif ($v == 0) {
235 0         0 $p = '0.0,';
236             } else {
237 12         115 $p = sprintf('%0.8f,', ($v/$m));
238             }
239              
240 16         51 return $p;
241             } # end &int_decvaltofloat
242              
243             # internal RGB to float function
244             sub int_dectripletofloat {
245 44     44 0 101 my $r = shift;
246 44         49 my $g = shift;
247 44         60 my $b = shift;
248 44         49 my $m = shift;
249 44         76 my $p;
250              
251             # eat our own dog food for indicating a decimal value
252 44         65 $r =~ s/:$//;
253 44         57 $g =~ s/:$//;
254 44         49 $b =~ s/:$//;
255              
256 44 100       81 if($r > $m) { $r = $m; }
  2         3  
257 44 50       73 if($g > $m) { $g = $m; }
  0         0  
258 44 100       75 if($b > $m) { $b = $m; }
  2         3  
259              
260 44         295 $p = sprintf('%0.8f,%0.8f,%0.8f', ($r/$m), ($g/$m), ($b/$m));
261              
262             # paranoia: I don't trust floating point to get 1.0 exactly
263 44         184 $p =~ s/1[.]\d+/1.0/g;
264              
265             # more compact
266 44         103 $p =~ s/0[.]0+\b/0.0/g;
267              
268 44         89 return $p;
269             } # end &int_dectripletofloat
270              
271             # internal single float to dec function
272             sub int_floatvaltodec {
273 93     93 0 120 my $v = shift;
274 93         89 my $m = shift;
275 93         76 my $p;
276              
277             # eat our own dog food for indicating a float value
278 93         222 $v =~ s/,$//;
279              
280             # 1/65535 is about .0000152590
281 93 100       204 if($v >= 0.999999) {
    100          
282 17         24 $p = "$m:";
283             } elsif ($v <= 0.000001) {
284 65         74 $p = '0:';
285             } else {
286             # counter-intuitive way to round to an interger, but int() is
287             # rather broken.
288 11         78 $p = sprintf('%1.0f:', ($v*$m));
289             }
290              
291 93         144 return $p;
292             } # end &int_floatvaltodec
293              
294             # internal RGB float to dec function
295             sub int_floattripletodec {
296 0     0 0 0 my $r = shift;
297 0         0 my $g = shift;
298 0         0 my $b = shift;
299 0         0 my $m = shift;
300 0         0 my $p;
301              
302 0         0 $r = int_floatvaltodec($r, $m);
303 0         0 $g = int_floatvaltodec($g, $m);
304 0         0 $b = int_floatvaltodec($b, $m);
305              
306 0         0 $p = "$r$g$b";
307             # remove final (extra) comma
308 0         0 $p =~ s/,$//;
309              
310 0         0 return $p;
311             } # end &int_floattripletodec
312              
313             # internal single float to hex function
314             sub int_floatvaltohex {
315 8     8 0 14 my $v = shift;
316 8         11 my $m = shift;
317 8         9 my $p;
318              
319             # eat our own dog food for indicating a float value
320 8         60 $v =~ s/,$//;
321              
322             # 1/65535 is about .0000152590
323 8 100       31 if($v >= 0.999999) {
    50          
324 1         3 $p = sprintf("%X/", $m);
325             } elsif ($v <= 0.000001) {
326 0         0 $p = '0/';
327             } else {
328             # counter-intuitive way to round to an interger, but int() is
329             # rather broken.
330 7         69 $p = sprintf("%X/", sprintf('%1.0f', ($v*$m)));
331             }
332              
333 8         22 return $p;
334             } # end &int_floatvaltohex
335              
336             # internal RGB float to hex function
337             sub int_floattripletodhex{
338 0     0 0 0 my $r = shift;
339 0         0 my $g = shift;
340 0         0 my $b = shift;
341 0         0 my $m = shift;
342 0         0 my $p;
343              
344 0         0 $r = int_floatvaltohex($r, $m);
345 0         0 $g = int_floatvaltohex($g, $m);
346 0         0 $b = int_floatvaltohex($b, $m);
347              
348 0         0 $p = "$r$g$b";
349             # remove final (extra) slash
350 0         0 $p =~ s:/$::;
351              
352 0         0 return $p;
353             } # end &int_floattripletohex
354              
355             # hands off to correct int_encodepixels_N type
356             sub int_encodepixels {
357 39     39 0 43 my $type = shift;
358 39         47 my $p_r = shift;
359 39         42 my $deep = shift;
360 39         41 my $encode = shift;
361 39         40 my $max = shift;
362              
363             # most common to least common
364             # type 7 is PAM, not supported here (yet)
365             # types 1 and 4 are PBM and don't need a max
366              
367 39 100       78 if($type == 6) {
368 12         28 return int_encodepixels_6($p_r, $deep, $encode, $max);
369             }
370 27 100       45 if($type == 5) {
371 9         23 return int_encodepixels_5($p_r, $deep, $encode, $max);
372             }
373 18 100       28 if($type == 4) {
374 3         8 return int_encodepixels_4($p_r, $deep, $encode );
375             }
376 15 100       45 if($type == 3) {
377 5         10 return int_encodepixels_3($p_r, $deep, $encode, $max);
378             }
379 10 100       29 if($type == 2) {
380 7         15 return int_encodepixels_2($p_r, $deep, $encode, $max);
381             }
382 3 50       5 if($type == 1) {
383 3         8 return int_encodepixels_1($p_r, $deep, $encode );
384             }
385              
386             # should never reach here
387 0         0 return undef;
388              
389             } # end &int_encodepixels
390              
391             # Internal read pixels for P1: ascii bitmap. Does not do argument checks.
392             sub int_readpixels_1 {
393 1     1 0 1 my $gr = shift; # input file glob ref
394 1         2 my $ir = shift; # image info hash ref
395 1         2 my $pr = shift; # pixel array ref
396 1         2 my $enc = shift; # target pixel encoding
397              
398 1         1 my $used = 0;
399 1         2 my $read;
400             my $bit;
401 1         2 my $w = 0;
402 1         1 my $h = 0;
403              
404 1         6 while(defined($read = <$gr>)) {
405 5         17 while($read =~ /\b(\d+)\b/g) {
406 20 100       35 $bit = ($1)? 1 : 0;
407 20         28 $$pr[$h][$w] = $bit;
408 20         18 $used ++;
409 20 100       40 if($used >= $$ir{pixels}) { last; }
  1         8  
410 19         18 $w ++;
411 19 100       69 if($w >= $$ir{width}) {
412 4         10 $w = 0;
413 4         21 $h ++;
414             }
415             }
416             } # while read from file
417              
418 1 50       4 if($used < $$ir{pixels}) {
419 0         0 $$ir{error} = 'type 1 read: not enough pixels';
420             } else {
421 1         5 $$ir{error} = '';
422             }
423             } # end &int_readpixels_1
424              
425             # Internal write pixels for P1: ascii bitmap. Does not do argument checks.
426             sub int_encodepixels_1 {
427 3     3 0 2 my $pr = shift; # pixel array ref
428 3         4 my $deep = shift; # how deep is our array
429 3         4 my $enc = shift; # source pixel encoding
430              
431 3         3 my $w = 0;
432 3         4 my $h = 0;
433 3         3 my $out = '';
434 3         3 my $wide = 0;
435 3         3 my $pix;
436             my $cur;
437              
438 3 100       7 if($deep eq '1d') {
439             # $#{array} returns counts starting at -1 for empty array
440 1         2 $pix = 1+ $#{$pr};
  1         1  
441 1         2 $cur = $$pr[$w];
442             } else {
443             # deep = 3d only allowed for P3/P6
444 2         2 $pix = (1+ $#{$pr}) * (1+ $#{$$pr[0]});
  2         3  
  2         3  
445 2         3 $cur = $$pr[$h][$w];
446             }
447              
448 3         6 while($pix > 0) {
449 60         85 $cur =~ s![,:/]$!!;
450 60 50       81 if($enc eq 'float') {
451 0 0       0 if($cur > 0.5) {
452 0         0 $out .= '1 ';
453             } else {
454 0         0 $out .= '0 ';
455             }
456             } else {
457             # for PBM, we assume $max is 1
458 60 100       72 if($cur) {
459 12         12 $out .= '1 ';
460             } else {
461 48         53 $out .= '0 ';
462             }
463             }
464              
465 60         53 $wide += 2;
466 60 50       127 if($wide > 70) {
467 0         0 $out .= "\n";
468 0         0 $wide = 0;
469             }
470              
471 60         52 $pix --;
472 60         47 $w ++;
473 60 100       86 if($deep eq '1d') {
474 20 100 66     62 if(exists($$pr[$w]) and defined($$pr[$w])) {
475 19         36 $cur = $$pr[$w];
476             } else {
477 1         3 $cur = 0;
478             }
479             } else {
480 40 100       68 if(!exists($$pr[$h][$w])) {
481 11         10 $w = 0;
482 11         11 $h ++;
483             }
484 40 100 66     128 if(exists($$pr[$h][$w]) and defined($$pr[$h][$w])) {
485 37         175 $cur = $$pr[$h][$w];
486             } else {
487 3         4 $cur = 0;
488             }
489             }
490             } # while pix
491              
492 3 50       8 if($wide) {
493 3         3 $out .= "\n";
494             }
495 3         18 return($out);
496             } # end &int_encodepixels_1
497              
498             # Internal read pixels for P2: ascii graymap. Does not do argument checks.
499             sub int_readpixels_2 {
500 2     2 0 3 my $gr = shift; # input file glob ref
501 2         5 my $ir = shift; # image info hash ref
502 2         3 my $pr = shift; # pixel array ref
503 2         3 my $enc = shift; # target pixel encoding
504              
505 2         3 my $used = 0;
506 2         4 my $read;
507             my $val;
508 0         0 my $pix;
509 2         3 my $w = 0;
510 2         3 my $h = 0;
511            
512 2         12 while(defined($read = <$gr>)) {
513 10         40 while($read =~ /\b(\d+)\b/g) {
514 40         63 $val = $1;
515              
516 40 50       84 if($enc eq 'dec') {
    50          
517 0         0 $pix = "$val:";
518             } elsif ($enc eq 'hex') {
519 0         0 $pix = sprintf('%X:', $val);
520             } else {
521 40 100       102 if($val >= $$ir{max}) {
    50          
522 32         41 $pix = '1.0,';
523             } elsif ($val == 0) {
524 8         14 $pix = '0.0,';
525             } else {
526 0         0 $pix = sprintf('%0.8f,', $val/$$ir{max});
527             }
528             }
529              
530 40         64 $$pr[$h][$w] = $pix;
531 40         49 $used ++;
532 40 100       87 if($used >= $$ir{pixels}) { last; }
  2         21  
533 38         40 $w ++;
534 38 100       157 if($w >= $$ir{width}) {
535 8         9 $w = 0;
536 8         41 $h ++;
537             }
538             }
539             } # while read from file
540              
541 2 50       10 if($used < $$ir{pixels}) {
542 0         0 $$ir{error} = 'type 2 read: not enough pixels';
543             } else {
544 2         10 $$ir{error} = '';
545             }
546             } # end &int_readpixels_2
547              
548             # Internal write pixels for P2: ascii graymap. Does not do argument checks.
549             sub int_encodepixels_2 {
550 7     7 0 8 my $pr = shift; # pixel array ref
551 7         9 my $deep = shift; # how deep is our array
552 7         13 my $enc = shift; # source pixel encoding
553 7         6 my $max = shift; # max value
554              
555 7         10 my $w = 0;
556 7         5 my $h = 0;
557 7         8 my $out = '';
558 7         10 my $val;
559 7         5 my $wide = 0;
560 7         7 my $pix;
561             my $cur;
562              
563 7 100       16 if($deep eq '1d') {
564             # $#{array} returns counts starting at -1 for empty array
565 3         4 $pix = 1+ $#{$pr};
  3         5  
566 3         7 $cur = $$pr[$w];
567             } else {
568             # deep = 3d only allowed for P3/P6
569 4         4 $pix = (1+ $#{$pr}) * (1+ $#{$$pr[0]});
  4         5  
  4         5  
570 4         8 $cur = $$pr[$h][$w];
571             }
572              
573 7         12 while($pix > 0) {
574              
575 129 100       290 if($enc eq 'float') {
    100          
576 20         27 $val = int_floatvaltodec($cur, $max);
577 20         23 chop($val); # eat last ':'
578             } elsif($enc eq 'hex') {
579 29         55 $cur =~ s!/$!!;
580 29         35 $val = hex($cur);
581             } else {
582 80         98 $cur =~ s!:$!!;
583 80         88 $val = 0+$cur; # normalize numbers
584             }
585              
586 129 100       191 if($val > $max) {
587 2         2 $val = $max;
588             }
589              
590 129 50       241 if(70 < ($wide + 1 + length($val))) {
591 0         0 $wide = 0;
592 0         0 $out .= "\n";
593             }
594 129         154 $out .= $val . ' ';
595 129         152 $wide += 1 + length($val);
596              
597 129         107 $pix --;
598 129         106 $w ++;
599 129 100       182 if($deep eq '1d') {
600 49 100 66     168 if(exists($$pr[$w]) and defined($$pr[$w])) {
601 46         93 $cur = $$pr[$w];
602             } else {
603 3         9 $cur = 0;
604             }
605             } else {
606 80 100       136 if(!exists($$pr[$h][$w])) {
607 23         19 $w = 0;
608 23         21 $h ++;
609             }
610 80 100 66     237 if(exists($$pr[$h][$w]) and defined($$pr[$h][$w])) {
611 73         140 $cur = $$pr[$h][$w];
612             } else {
613 7         14 $cur = 0;
614             }
615             }
616             } # while pix
617              
618 7 50       17 if($wide) {
619 7         7 $out .= "\n";
620             }
621              
622 7         37 return($out);
623             } # end &int_encodepixels_2
624              
625             # Internal read pixels for P3: ascii pixmap. Does not do argument checks.
626             sub int_readpixels_3 {
627 2     2 0 3 my $gr = shift; # input file glob ref
628 2         3 my $ir = shift; # image info hash ref
629 2         3 my $pr = shift; # pixel array ref
630 2         4 my $enc = shift; # target pixel encoding
631              
632 2         2 my $used = 0;
633 2         5 my $read;
634             my $val;
635 0         0 my $pix;
636 2         3 my $w = 0;
637 2         3 my $h = 0;
638 2         3 my $r;
639             my $g;
640 2         3 my $state = 'r';
641              
642 2         21 while(defined($read = <$gr>)) {
643 10         32 while($read =~ /\b(\d+)\b/g) {
644 120         161 $val = $1;
645              
646 120 50       243 if($enc eq 'dec') {
    50          
647 0         0 $pix = "$val:";
648             } elsif ($enc eq 'hex') {
649 0         0 $pix = sprintf('%X:', $val);
650             } else {
651 120 100       232 if($val >= $$ir{max}) {
    50          
652 96         112 $pix = '1.0,';
653             } elsif ($val == 0) {
654 24         29 $pix = '0.0,';
655             } else {
656 0         0 $pix = sprintf('%0.8f,', $val/$$ir{max});
657             }
658             }
659              
660 120 100       208 if($state eq 'r') {
    100          
661 40         45 $r = $pix;
662 40         135 $state = 'g';
663             } elsif($state eq 'g') {
664 40         41 $g = $pix;
665 40         126 $state = 'b';
666             } else {
667              
668 40         66 chop($pix);
669 40         80 $$pr[$h][$w] = "$r$g$pix";
670 40         42 $used ++;
671 40 100       77 if($used >= $$ir{pixels}) { last; }
  2         23  
672 38         36 $w ++;
673 38 100       68 if($w >= $$ir{width}) {
674 8         8 $w = 0;
675 8         9 $h ++;
676             }
677              
678 38         143 $state = 'r';
679             }
680             }
681             } # while read from file
682              
683 2 50       14 if($used < $$ir{pixels}) {
684 0         0 $$ir{error} = 'type 3 read: not enough pixels';
685             } else {
686 2         10 $$ir{error} = '';
687             }
688             } # end &int_readpixels_3
689              
690             # Internal write pixels for P3: ascii pixmap. Does not do argument checks.
691             sub int_encodepixels_3 {
692 5     5 0 7 my $pr = shift; # pixel array ref
693 5         7 my $deep = shift; # how deep is our array
694 5         4 my $enc = shift; # source pixel encoding
695 5         5 my $max = shift; # max value
696              
697 5         5 my $w = 0;
698 5         5 my $h = 0;
699 5         6 my $out = '';
700 5         10 my $val;
701 5         4 my $wide = 0;
702 5         6 my $pix;
703             my @cur;
704 0         0 my $rgb;
705              
706 5 50       10 if($deep eq '1d') {
707             # $#{array} returns counts starting at -1 for empty array
708 0         0 $pix = 1+ $#{$pr};
  0         0  
709 0         0 @cur = explodetriple($$pr[$w]);
710             } else {
711             # explodetriple makes deep = 2d work like deep = 3d
712 5         35 $pix = (1+ $#{$pr}) * (1+ $#{$$pr[0]});
  5         9  
  5         8  
713 5         12 @cur = explodetriple($$pr[$h][$w]);
714             }
715              
716 5         13 while($pix > 0) {
717              
718 100         124 for $rgb (0,1,2) {
719 300 100       502 if($enc eq 'float') {
    100          
720 60         103 $val = int_floatvaltodec($cur[$rgb], $max);
721 60         64 chop($val); # eat last ':'
722             } elsif($enc eq 'hex') {
723 60         129 $cur[$rgb] =~ s!/$!!;
724 60         149 $val = hex($cur[$rgb]);
725             } else {
726 180         359 $cur[$rgb] =~ s!:$!!;
727 180         231 $val = 0+$cur[$rgb]; # normalize numbers
728             }
729              
730 300 50       485 if($val > $max) {
731 0         0 $val = $max;
732             }
733              
734 300 100       503 if(70 < ($wide + 1 + length($val))) {
735 6         6 $wide = 0;
736 6         8 $out .= "\n";
737             }
738 300         338 $out .= $val . ' ';
739 300         388 $wide += 1 + length($val);
740             } # for rgb
741              
742 100         110 $pix --;
743 100         87 $w ++;
744 100 50       139 if($deep eq '1d') {
745 0 0 0     0 if(exists($$pr[$w]) and defined($$pr[$w])) {
746 0         0 @cur = explodetriple($$pr[$w]);
747             } else {
748 0         0 @cur = (0,0,0);
749             }
750             } else {
751 100 100       193 if(!exists($$pr[$h][$w])) {
752 25         20 $w = 0;
753 25         23 $h ++;
754             }
755 100 100 66     395 if(exists($$pr[$h][$w]) and defined($$pr[$h][$w])) {
756 95         154 @cur = explodetriple($$pr[$h][$w]);
757             } else {
758 5         13 @cur = (0,0,0);
759             }
760             }
761             } # while pix
762              
763 5 50       10 if($wide) {
764 5         4 $out .= "\n";
765             }
766 5         31 return($out);
767             } # end &int_encodepixels_3
768              
769             # Internal read pixels for P4: raw bitmap. Does not do argument checks.
770             sub int_readpixels_4 {
771 4     4 0 7 my $gr = shift; # input file glob ref
772 4         5 my $ir = shift; # image info hash ref
773 4         5 my $pr = shift; # pixel array ref
774 4         6 my $enc = shift; # target pixel encoding
775              
776 4         8 my $used = 0;
777 4         6 my $read;
778             my $bits;
779 0         0 my $bit;
780 4         4 my $w = 0;
781 4         6 my $h = 0;
782              
783             READ:
784 4         15 while(read($gr,$read,1)) {
785             # $bits will be '01000001' if $read is 'A'
786 20         49 $bits = unpack('B*', $read);
787              
788 20         119 for $bit ($bits =~ /([01])/g) {
789 80         135 $$pr[$h][$w] = $bit;
790 80         72 $used ++;
791 80 100       141 if($used >= $$ir{pixels}) { last READ; }
  4         7  
792 76         69 $w ++;
793 76 100       148 if($w >= $$ir{width}) {
794 16         17 $w = 0;
795 16         14 $h ++;
796             # pbm pads each row with unused bits, if (width % 8) != 0
797 16         59 next READ;
798             }
799             }
800             } # while read from file
801              
802 4 50       16 if($used < $$ir{pixels}) {
803 0         0 $$ir{error} = 'type 4 read: not enough pixels';
804             } else {
805 4         13 $$ir{error} = '';
806             }
807             } # end &int_readpixels_4
808              
809             # Internal write pixels for P4: raw bitmap. Does not do argument checks.
810             sub int_encodepixels_4 {
811 3     3 0 3 my $pr = shift; # pixel array ref
812 3         4 my $deep = shift; # how deep is our array
813 3         4 my $enc = shift; # source pixel encoding
814              
815 3         2 my $w = 0;
816 3         4 my $h = 0;
817 3         3 my $out = '';
818 3         4 my $used = 0;
819 3         3 my $pix;
820             my $cur;
821 3         2 my $val = '';
822              
823 3 50       7 if($deep eq '1d') {
824             # $#{array} returns counts starting at -1 for empty array
825 0         0 $pix = 1+ $#{$pr};
  0         0  
826 0         0 $cur = $$pr[$w];
827             } else {
828             # deep = 3d only allowed for P3/P6
829 3         3 $pix = (1+ $#{$pr}) * (1+ $#{$$pr[0]});
  3         4  
  3         5  
830 3         5 $cur = $$pr[$h][$w];
831             }
832              
833 3         6 while($pix > 0) {
834 57         75 $cur =~ s![,:/]$!!;
835 57 50       77 if($enc eq 'float') {
836 0 0       0 if($cur > 0.5) {
837 0         0 $val .= '1';
838             } else {
839 0         0 $val .= '0';
840             }
841             } else {
842             # for PBM, we assume $max is 1
843 57 100       61 if($cur) {
844 32         29 $val .= '1';
845             } else {
846 25         28 $val .= '0';
847             }
848             }
849              
850 57         43 $used ++;
851 57 100       83 if($used == 8) {
852 3         9 $out .= pack("B*", $val);
853 3         4 $used = 0;
854 3         2 $val = '';
855             }
856              
857 57         43 $pix --;
858 57         42 $w ++;
859 57 50       80 if($deep eq '1d') {
860 0 0 0     0 if(exists($$pr[$w]) and defined($$pr[$w])) {
861 0         0 $cur = $$pr[$w];
862             } else {
863 0         0 $cur = 0;
864             }
865             } else {
866 57 100       91 if(!exists($$pr[$h][$w])) {
867 11         9 $w = 0;
868 11         9 $h ++;
869              
870             # PBM raw is padded to full byte at end of each row
871 11 100       23 if($used) {
872 8         14 $out .= pack("B*", substr($val.'0000000',0,8) );
873 8         7 $used = 0;
874 8         11 $val = '';
875             }
876             }
877 57 100 66     177 if(exists($$pr[$h][$w]) and defined($$pr[$h][$w])) {
878 52         96 $cur = $$pr[$h][$w];
879             } else {
880 5         11 $cur = 0;
881             }
882             }
883             } # while pix
884              
885 3 50       4 if($used) {
886 0         0 $out .= pack("B*", substr($val.'0000000',0,8) );
887             }
888 3         17 return($out);
889             } # end &int_encodepixels_4
890              
891             # Internal read pixels for P5: raw graymap. Does not do argument checks.
892             sub int_readpixels_5 {
893 2     2 0 3 my $gr = shift; # input file glob ref
894 2         2 my $ir = shift; # image info hash ref
895 2         4 my $pr = shift; # pixel array ref
896 2         2 my $enc = shift; # target pixel encoding
897              
898 2         48 my $used = 0;
899 2         6 my $read;
900             my $val;
901 0         0 my $pix;
902 0         0 my $rc;
903 2         3 my $w = 0;
904 2         3 my $h = 0;
905 2         3 my $expect = 1;
906              
907 2 100       8 if ($$ir{max} > 255) {
908 1         2 $expect = 2;
909             }
910            
911 2         8 while($rc = read($gr,$read,$expect)) {
912 40 50       82 if($rc == $expect) {
913 40 100       71 if($expect == 1) {
914             # $val will be 65 if $read is 'A'
915 20         39 $val = unpack('C', $read);
916             } else {
917             # $val will be 16706 if $read is 'AB'
918 20         32 $val = unpack('n', $read);
919             }
920              
921 40 50       92 if($enc eq 'dec') {
    50          
922 0         0 $pix = "$val:";
923             } elsif ($enc eq 'hex') {
924 0         0 $pix = sprintf('%X:', $val);
925             } else {
926 40 100       79 if($val >= $$ir{max}) {
    50          
927 32         42 $pix = '1.0,';
928             } elsif ($val == 0) {
929 8         9 $pix = '0.0,';
930             } else {
931 0         0 $pix = sprintf('%0.8f,', $val/$$ir{max});
932             }
933             }
934              
935 40         69 $$pr[$h][$w] = $pix;
936 40         40 $used ++;
937 40 100       78 if($used >= $$ir{pixels}) { last; }
  2         5  
938 38         39 $w ++;
939 38 100       113 if($w >= $$ir{width}) {
940 8         9 $w = 0;
941 8         19 $h ++;
942             }
943             }
944             } # while read from file
945              
946 2 50       6 if($used < $$ir{pixels}) {
947 0         0 $$ir{error} = 'type 5 read: not enough pixels';
948             } else {
949 2         7 $$ir{error} = '';
950             }
951             } # end &int_readpixels_5
952              
953              
954             # Internal write pixels for P5: raw graymap. Does not do argument checks.
955             sub int_encodepixels_5 {
956 9     9 0 12 my $pr = shift; # pixel array ref
957 9         10 my $deep = shift; # how deep is our array
958 9         12 my $enc = shift; # source pixel encoding
959 9         11 my $max = shift; # max value
960              
961 9         10 my $w = 0;
962 9         11 my $h = 0;
963 9         13 my $out = '';
964 9         17 my $val;
965             my $pix;
966 0         0 my $cur;
967 0         0 my $packer;
968              
969 9 100       19 if($max > 255) {
970 2         6 $packer = 'n';
971             } else {
972 7         11 $packer = 'C';
973             }
974 9 100       25 if($deep eq '1d') {
975             # $#{array} returns counts starting at -1 for empty array
976 2         4 $pix = 1+ $#{$pr};
  2         4  
977 2         4 $cur = $$pr[$w];
978             } else {
979             # deep = 3d only allowed for P3/P6
980 7         7 $pix = (1+ $#{$pr}) * (1+ $#{$$pr[0]});
  7         11  
  7         15  
981 7         15 $cur = $$pr[$h][$w];
982             }
983              
984 9         21 while($pix > 0) {
985              
986 72 100       177 if($enc eq 'float') {
    50          
987 3         6 $val = int_floatvaltodec($cur, $max);
988 3         3 chop($val); # eat last ':'
989             } elsif($enc eq 'hex') {
990 69         275 $cur =~ s!/$!!;
991 69         109 $val = hex($cur);
992             } else {
993 0         0 $cur =~ s!:$!!;
994 0         0 $val = 0+$cur; # normalize numbers
995             }
996              
997 72 50       142 if($val > $max) {
998 0         0 $val = $max;
999             }
1000              
1001 72         115 $out .= pack($packer, $val);
1002              
1003 72         68 $pix --;
1004 72         72 $w ++;
1005 72 100       129 if($deep eq '1d') {
1006 18 100 66     70 if(exists($$pr[$w]) and defined($$pr[$w])) {
1007 16         41 $cur = $$pr[$w];
1008             } else {
1009 2         6 $cur = 0;
1010             }
1011             } else {
1012 54 100       111 if(!exists($$pr[$h][$w])) {
1013 11         12 $w = 0;
1014 11         14 $h ++;
1015             }
1016 54 100 66     255 if(exists($$pr[$h][$w]) and defined($$pr[$h][$w])) {
1017 47         113 $cur = $$pr[$h][$w];
1018             } else {
1019 7         51 $cur = 0;
1020             }
1021             }
1022             } # while pix
1023              
1024 9         37 return($out);
1025              
1026             } # end &int_encodepixels_5
1027              
1028              
1029             # Internal read pixels for P6: raw pixmap. Does not do argument checks.
1030             sub int_readpixels_6 {
1031 2     2 0 5 my $gr = shift; # input file glob ref
1032 2         4 my $ir = shift; # image info hash ref
1033 2         2 my $pr = shift; # pixel array ref
1034 2         3 my $enc = shift; # target pixel encoding
1035              
1036 2         4 my $used = 0;
1037 2         2 my $read;
1038             my $val;
1039 0         0 my $pix;
1040 0         0 my $rc;
1041 2         3 my $w = 0;
1042 2         5 my $h = 0;
1043 2         3 my $r;
1044             my $g;
1045 0         0 my $b;
1046 2         3 my $expect = 3;
1047              
1048 2 100       6 if ($$ir{max} > 255) {
1049 1         3 $expect = 6;
1050             }
1051              
1052 2         8 while($rc = read($gr,$read,$expect)) {
1053 40 50       81 if($rc == $expect) {
1054 40 100       64 if($expect == 3) {
1055             # ($r,$g,$b) will be (65,66,0) if $read is 'AB'
1056 20         41 ($r,$g,$b) = unpack('CCC', $read);
1057             } else {
1058             # ($r,$g,$b) will be (16706,49,12544) if $read is 'AB11'
1059 20         43 ($r,$g,$b) = unpack('nnn', $read);
1060             }
1061            
1062              
1063 40 50       82 if($enc eq 'dec') {
    50          
1064 0         0 $pix = "$r:$g:$b";
1065             } elsif ($enc eq 'hex') {
1066 0         0 $pix = sprintf('%X:%X:%X', $r, $g, $b);
1067             } else {
1068 40         83 $pix = int_dectripletofloat($r,$g,$b,$$ir{max});
1069             }
1070              
1071 40         73 $$pr[$h][$w] = $pix;
1072 40         36 $used ++;
1073 40 100       92 if($used >= $$ir{pixels}) { last; }
  2         6  
1074 38         36 $w ++;
1075 38 100       120 if($w >= $$ir{width}) {
1076 8         9 $w = 0;
1077 8         27 $h ++;
1078             }
1079              
1080             }
1081             } # while read from file
1082              
1083 2 50       20 if($used < $$ir{pixels}) {
1084 0         0 $$ir{error} = 'type 6 read: not enough pixels';
1085             } else {
1086 2         8 $$ir{error} = '';
1087             }
1088             } # end &int_readpixels_6
1089              
1090             # Internal write pixels for P6: raw pixmap. Does not do argument checks.
1091             sub int_encodepixels_6 {
1092 12     12 0 22 my $pr = shift; # pixel array ref
1093 12         19 my $deep = shift; # how deep is our array
1094 12         13 my $enc = shift; # source pixel encoding
1095 12         18 my $max = shift; # max value
1096              
1097 12         15 my $w = 0;
1098 12         15 my $h = 0;
1099 12         13 my $out = '';
1100 12         15 my $val;
1101             my $pix;
1102 0         0 my @cur;
1103 0         0 my $rgb;
1104 0         0 my $packer;
1105              
1106 12 100       29 if($max > 255) {
1107 1         2 $packer = 'n';
1108             } else {
1109 11         20 $packer = 'C';
1110             }
1111              
1112 12 50       24 if($deep eq '1d') {
1113             # $#{array} returns counts starting at -1 for empty array
1114 0         0 $pix = 1+ $#{$pr};
  0         0  
1115 0         0 @cur = explodetriple($$pr[$w]);
1116             } else {
1117             # explodetriple makes deep = 2d work like deep = 3d
1118 12         16 $pix = (1+ $#{$pr}) * (1+ $#{$$pr[0]});
  12         22  
  12         28  
1119 12         33 @cur = explodetriple($$pr[$h][$w]);
1120             }
1121              
1122 12         34 while($pix > 0) {
1123              
1124 25         37 for $rgb (0,1,2) {
1125 75 50       164 if($enc eq 'float') {
    50          
1126 0         0 $val = int_floatvaltodec($cur[$rgb], $max);
1127 0         0 chop($val); # eat last ':'
1128             } elsif($enc eq 'hex') {
1129 0         0 $cur[$rgb] =~ s!/$!!;
1130 0         0 $val = hex($cur[$rgb]);
1131             } else {
1132 75         220 $cur[$rgb] =~ s!:$!!;
1133 75         138 $val = 0+$cur[$rgb]; # normalize numbers
1134             }
1135              
1136 75 50       153 if($val > $max) {
1137 0         0 $val = $max;
1138             }
1139              
1140 75         156 $out .= pack($packer, $val);
1141             } # for rgb
1142              
1143 25         35 $pix --;
1144 25         27 $w ++;
1145 25 50       47 if($deep eq '1d') {
1146 0 0 0     0 if(exists($$pr[$w]) and defined($$pr[$w])) {
1147 0         0 @cur = explodetriple($$pr[$w]);
1148             } else {
1149 0         0 @cur = (0,0,0);
1150             }
1151             } else {
1152 25 100       83 if(!exists($$pr[$h][$w])) {
1153 14         18 $w = 0;
1154 14         19 $h ++;
1155             }
1156 25 100 66     102 if(exists($$pr[$h][$w]) and defined($$pr[$h][$w])) {
1157 13         31 @cur = explodetriple($$pr[$h][$w]);
1158             } else {
1159 12         44 @cur = (0,0,0);
1160             }
1161             }
1162             } # while pix
1163              
1164 12         49 return($out);
1165              
1166             } # end &int_encodepixels_6
1167              
1168             # Internal read pixels function. Does not do argument checks.
1169             sub int_readpixels {
1170 13     13 0 22 my $gr = shift; # input file glob ref
1171 13         18 my $ir = shift; # image info hash ref
1172 13         17 my $pr = shift; # pixel array ref
1173 13         22 my $enc = shift; # target pixel encoding
1174              
1175             # most common to least common
1176             # type 7 is PAM, not supported here (yet)
1177 13 100       35 if($$ir{type} == 6) { return int_readpixels_6($gr, $ir, $pr, $enc); }
  2         8  
1178 11 100       44 if($$ir{type} == 5) { return int_readpixels_5($gr, $ir, $pr, $enc); }
  2         8  
1179 9 100       24 if($$ir{type} == 4) { return int_readpixels_4($gr, $ir, $pr, $enc); }
  4         15  
1180 5 100       20 if($$ir{type} == 3) { return int_readpixels_3($gr, $ir, $pr, $enc); }
  2         8  
1181 3 100       9 if($$ir{type} == 2) { return int_readpixels_2($gr, $ir, $pr, $enc); }
  2         8  
1182 1 50       5 if($$ir{type} == 1) { return int_readpixels_1($gr, $ir, $pr, $enc); }
  1         4  
1183            
1184 0         0 $$ir{error} = 'image type not recognized';
1185             } # end &int_readpixels
1186              
1187             # Internal argument check for encodepixels() and inspectpixels()
1188             sub int_prelim_inspect {
1189 36     36 0 61 my $fmt = shift;
1190 36         44 my $max = shift;
1191 36         44 my $p_r = shift;
1192 36         42 my %inspect;
1193              
1194 36         89 $inspect{error} = '';
1195            
1196 36 100       160 if($fmt =~ /^raw$/i) {
    100          
1197 18         34 $inspect{type} = 3; # will be modified later
1198             } elsif($fmt =~ /^ascii$/i) {
1199 17         33 $inspect{type} = 0; # will be modified later
1200             } else {
1201 1         2 $inspect{error} = 'invalid format';
1202 1         7 return \%inspect;
1203             }
1204              
1205 35 50 33     324 if(($max !~ /^\d+$/) or ($max < 1) or ($max > 65535)) {
      33        
1206 0         0 $inspect{error} = 'invalid max';
1207 0         0 return \%inspect;
1208             }
1209 35 100       72 if($max > 255) {
1210 11         20 $inspect{bytes} = 2;
1211             } else {
1212 24         51 $inspect{bytes} = 1;
1213             }
1214              
1215 35 50       94 if( ref($p_r) ne 'ARRAY') {
1216 0         0 $inspect{error} = 'pixels not an array';
1217 0         0 return \%inspect;
1218             }
1219              
1220 35 100 66     229 if( ref($$p_r[0]) eq '') {
    100 33        
    50          
1221 8         15 $inspect{deep} = '1d';
1222 8         18 $inspect{first} = $$p_r[0];
1223 8         10 $inspect{pixels} = 1+ $#{$p_r};
  8         37  
1224              
1225             } elsif(ref($$p_r[0]) eq 'ARRAY' and ref($$p_r[0][0]) eq '') {
1226 21         35 $inspect{deep} = '2d';
1227 21         42 $inspect{first} = $$p_r[0][0];
1228 21         24 $inspect{height} = 1+ $#{$p_r};
  21         46  
1229 21         29 $inspect{width} = 1+ $#{$$p_r[0]};
  21         35  
1230 21         68 $inspect{pixels} = $inspect{width} * $inspect{height};
1231              
1232             } elsif(ref($$p_r[0][0]) eq 'ARRAY' and ref($$p_r[0][0][0]) eq '') {
1233 6         22 $inspect{deep} = '3d';
1234 6         18 $inspect{first} = $$p_r[0][0][0];
1235 6         11 $inspect{height} = 1+ $#{$p_r};
  6         18  
1236 6         12 $inspect{width} = 1+ $#{$$p_r[0]};
  6         17  
1237 6         24 $inspect{pixels} = $inspect{width} * $inspect{height};
1238              
1239             } else {
1240             # too many levels?
1241 0         0 $inspect{error} = 'pixels not expected structure';
1242 0         0 return \%inspect;
1243             }
1244              
1245 35 100       86 if(!defined($inspect{first})) {
1246 1         3 $inspect{error} = 'first pixel undef';
1247 1         14 return \%inspect;
1248             }
1249 34 100       195 if($inspect{first} =~ m!^[.0-9]+,!) {
    100          
    100          
    50          
1250 4         8 $inspect{encode} = 'float';
1251              
1252             } elsif($inspect{first} =~ m!^[0-9]+:!) {
1253 14         36 $inspect{encode} = 'dec';
1254              
1255             } elsif($inspect{first} =~ m!^[0-9a-fA-F]+/!) {
1256 8         19 $inspect{encode} = 'hex';
1257              
1258             } elsif($inspect{first} =~ m!^[01]+$!) {
1259             # for PBM
1260 8         12 $inspect{encode} = 'dec';
1261              
1262             } else {
1263 0         0 $inspect{error} = 'first pixel unrecognized';
1264 0         0 return \%inspect;
1265             }
1266              
1267 34 100       102 if($max == 1) {
    100          
1268 6         7 $inspect{type} += 1; # now either 1 or 4
1269              
1270             } elsif($inspect{deep} eq '3d') {
1271 6         10 $inspect{type} += 3; # now either 3 or 6
1272              
1273             } else {
1274             # still could be 2, 3, 5, 6
1275 22 100       54 if($inspect{first} =~ m!^[.0-9a-fA-F]+[,:/][.0-9a-fA-F]+[,:/][.0-9a-fA-F]+!) {
1276 7         11 $inspect{type} += 3; # now either 3 or 6
1277             } else {
1278 15         44 $inspect{type} += 2; # now either 2 or 5
1279             }
1280             }
1281              
1282 34         166 return \%inspect;
1283             } # end &int_prelim_inspect
1284              
1285              
1286             =head1 FUNCTIONS
1287              
1288             =head2 readpnmfile( \*PNM, \%info, \@pixels, $encoding );
1289              
1290             Reads from a file handle and sets hash %info with properties,
1291             puts pixels into @pixels, formated as "float", "dec", or "hex".
1292             The @pixels structure is an array of rows, each row being an
1293             array of pixel strings.
1294              
1295             The %info hash has numerous properties about the source file.
1296             The function itself returns 'error' for usage errors, and the
1297             empty string normally.
1298              
1299             This function essentially chains readpnmheader(),
1300             checkpnminfo(), and readpnmpixels().
1301              
1302             A single file, if in the RAW format, can contain multiple
1303             concatenated images. This function will only read one at a
1304             time, but can be called multiple times on the same file handle.
1305              
1306             =over
1307              
1308             =item *
1309              
1310             $info{bgp}
1311              
1312             Will contain one of "b", "g", or "p" for pbm (bitmap), pgm (graymap),
1313             or ppm (pixmap). This is an informational value not used by this library.
1314              
1315             =item *
1316              
1317             $info{type}
1318              
1319             Will contain one of "1" for ASCII PBM, "2" for ASCII PGM, "3" for
1320             ASCII PPM, "4" for raw PBM, "5" for raw PGM, or "6" for raw PPM.
1321             This numerical value is right out of the header of the PBM family
1322             of files and is essential to understanding the pixel format.
1323              
1324             =item *
1325              
1326             $info{max}
1327              
1328             Will contain the max value of the image as a decimal integer. This
1329             is needed to properly understand what a decimal or hexadecimal
1330             pixel value means. It is used to convert raw pixel data into
1331             floating point values (and back to integers).
1332              
1333             =item *
1334              
1335             $info{format}
1336              
1337             Will contain 'raw' or 'ascii'.
1338              
1339             =item *
1340              
1341             $info{raw}
1342              
1343             Will contain a true value if the file is raw encoded, and false
1344             for ASCII. This is an informational value not used by this library.
1345              
1346             =item *
1347              
1348             $info{height}
1349              
1350             Will contain the height of the image in pixels.
1351              
1352             =item *
1353              
1354             $info{width}
1355              
1356             Will contain the width of the image in pixels.
1357              
1358             =item *
1359              
1360             $info{pixels}
1361              
1362             Will contain the number of pixels (height * width).
1363              
1364             =item *
1365              
1366             $info{comments}
1367              
1368             Will contain any comments found in the header, concatenated.
1369              
1370             =item *
1371              
1372             $info{fullheader}
1373              
1374             Will contain the complete, unparsed, header.
1375              
1376             =item *
1377              
1378             $info{error}
1379              
1380             Will contain an empty string if no errors occured, or an error
1381             message, including usage errors.
1382              
1383             =back
1384              
1385             =cut
1386              
1387             # readpnmfile(\*PNM, \%imageinfo, \@pixels, 'float' );
1388             sub readpnmfile {
1389 13     13 1 44803 my $f_r = shift; # file
1390 13         27 my $i_r = shift; # image info
1391 13         22 my $p_r = shift; # 2d array of pixels
1392 13         21 my $enc = shift; # encoding string
1393              
1394 13 50       51 if('HASH' ne ref($i_r)) {
1395             # not a hash, can't return errors the normal way
1396 0         0 return 'error';
1397             }
1398              
1399 13 50       48 if('GLOB' ne ref($f_r)) {
1400 0         0 $$i_r{error} = 'readpnmfile: first arg not a file handle ref';
1401 0         0 return 'error';
1402             }
1403              
1404 13 50       43 if('ARRAY' ne ref($p_r)) {
1405 0         0 $$i_r{error} = 'readpnmfile: third arg not an array ref';
1406 0         0 return 'error';
1407             }
1408              
1409 13 50       84 if($enc =~ /^(float|dec|raw)/i) {
1410 13         45 $enc = lc($1);
1411             } else {
1412 0         0 $$i_r{error} = 'readpnmfile: fourth arg not recognized pixel encoding';
1413 0         0 return 'error';
1414             }
1415              
1416 13         41 int_readpnmheader($f_r, $i_r);
1417              
1418 13 50       38 if(length($$i_r{error})) {
1419 0         0 $$i_r{error} = 'readpnmfile: ' . $$i_r{error};
1420 0         0 return '';
1421             }
1422              
1423 13         40 checkpnminfo($i_r);
1424 13 50 33     67 if(exists($$i_r{error}) and length($$i_r{error})) {
1425 0         0 $$i_r{error} = 'readpnmfile: ' . $$i_r{error};
1426 0         0 return 'error';
1427             }
1428              
1429 13         39 int_readpixels($f_r, $i_r, $p_r, $enc);
1430 13 50       37 if(length($$i_r{error})) {
1431 0         0 $$i_r{error} = 'readpnmfile: ' . $$i_r{error};
1432             }
1433              
1434 13         49 return '';
1435             } # end &readpnmfile
1436              
1437              
1438             ##################################################################
1439              
1440              
1441             =head2 checkpnminfo( \%info )
1442              
1443             Checks the values in the image info hash for completeness. Used
1444             internally between reading the header and reading the pixels of
1445             an image, but might be useful generally. Expects to find numerical
1446             values for type, pixels, max, width, and height.
1447              
1448             =cut
1449              
1450             sub checkpnminfo {
1451 13     13 1 23 my $i_r = shift; # image info
1452              
1453 13 50 33     329 if((!exists($$i_r{type}) or ($$i_r{type} !~ /^\d/)) or
1454             (!exists($$i_r{pixels}) or ($$i_r{pixels} !~ /^\d/)) or
1455             (!exists($$i_r{max}) or ($$i_r{max} !~ /^\d/)) or
1456             (!exists($$i_r{width}) or ($$i_r{width} !~ /^\d/)) or
1457             (!exists($$i_r{height}) or ($$i_r{height} !~ /^\d/)) ) {
1458 0         0 $$i_r{error} = 'image info incomplete';
1459 0         0 return 'error';
1460             }
1461             } # end &checkheader
1462              
1463              
1464              
1465             ##################################################################
1466              
1467              
1468              
1469             =head2 readpnminfo( \*PNM, \%info )
1470              
1471             Reads just the header of a PBM/PGM/PPM file from the file handle
1472             and populates the image info hash. See C for a
1473             description of the image info hash. Returns the string 'error'
1474             if there is an problem, and the empty string otherwise. Sets
1475             the $info{error} value with an error string.
1476              
1477             =cut
1478              
1479             sub readpnmheader {
1480 0     0 0 0 my $f_r = shift; # file
1481 0         0 my $i_r = shift; # image info
1482              
1483 0 0       0 if('HASH' ne ref($i_r)) {
1484             # not a hash, can't return errors the normal way
1485 0         0 return 'error';
1486             }
1487              
1488 0 0       0 if('GLOB' ne ref($f_r)) {
1489 0         0 $$i_r{error} = 'readpnmfile: first arg not a file handle ref';
1490 0         0 return 'error';
1491             }
1492              
1493 0         0 int_readpnmheader($f_r, $i_r);
1494              
1495 0 0       0 if(length($$i_r{error})) {
1496 0         0 $$i_r{error} = 'readpnmheader: ' . $$i_r{error};
1497 0         0 return '';
1498             }
1499              
1500 0         0 checkpnminfo($i_r);
1501 0 0 0     0 if(exists($$i_r{error}) and length($$i_r{error})) {
1502 0         0 $$i_r{error} = 'readpnmheader: ' . $$i_r{error};
1503 0         0 return 'error';
1504             }
1505              
1506 0         0 return '';
1507             } # end &readpnmheader
1508              
1509              
1510              
1511             ##################################################################
1512              
1513              
1514             =head2 readpnmpixels( \*PNM, \%info, \@pixels, $encoding )
1515              
1516             Reads just the pixels of a PBM/PGM/PPM file from the file handle
1517             and populates the pixels array. See C for a
1518             description of the image info hash, pixel array output format,
1519             and encoding details. Returns 'error' if there is an problem, and
1520             the empty string otherwise. Sets the $info{error} value with an
1521             error string.
1522              
1523             =cut
1524              
1525             sub readpnmpixels {
1526 0     0 1 0 my $g_r = shift; # input file glob ref
1527 0         0 my $i_r = shift; # image info hash ref
1528 0         0 my $p_r = shift; # pixel array ref
1529 0         0 my $enc = shift; # target pixel encoding
1530              
1531 0 0       0 if('HASH' ne ref($i_r)) {
1532             # not a hash, can't return errors the normal way
1533 0         0 return 'error';
1534             }
1535              
1536 0 0       0 if('GLOB' ne ref($g_r)) {
1537 0         0 $$i_r{error} = 'readpnmpixels: first arg not a file handle ref';
1538 0         0 return 'error';
1539             }
1540              
1541 0 0       0 if('ARRAY' ne ref($p_r)) {
1542 0         0 $$i_r{error} = 'readpnmpixels: third arg not an array ref';
1543 0         0 return 'error';
1544             }
1545              
1546 0 0       0 if($enc =~ /^(float|dec|raw)/i) {
1547 0         0 $enc = lc($1);
1548             } else {
1549 0         0 $$i_r{error} = 'readpnmpixels: fourth arg not recognized pixel encoding';
1550 0         0 return 'error';
1551             }
1552              
1553 0         0 checkpnminfo($i_r);
1554 0 0 0     0 if(exists($$i_r{error}) and length($$i_r{error})) {
1555 0         0 $$i_r{error} = 'readpnmpixels: ' . $$i_r{error};
1556 0         0 return 'error';
1557             }
1558              
1559 0         0 int_readpixels($g_r,$i_r,$p_r,$enc);
1560 0 0 0     0 if(exists($$i_r{error}) and length($$i_r{error})) {
1561 0         0 $$i_r{error} = 'readpnmpixels: ' . $$i_r{error};
1562 0         0 return 'error';
1563             }
1564              
1565 0         0 return '';
1566             } # end &readpnmpixels
1567              
1568              
1569              
1570             ##################################################################
1571              
1572              
1573             =head2 $float_pixel = hextripletofloat( $hex_pixel, $max )
1574              
1575             =head2 $float_pixel = hextripletofloat( \@hex_pixel, $max )
1576              
1577             For a pixel string with hex red green and blue values separated by
1578             slashes (R/G/B to RRRR/GGGG/BBBB) or an array of hex values, and a
1579             of max 1 to 65535, convert to the comma separated floating point
1580             pixel format.
1581              
1582             No error is returned if $max is outside of the allowed range, but 0
1583             will kill the program. Any value larger than max is clipped.
1584              
1585             C<$hex_pixel> can be a scalar or an array ref (eg C<\@triple>) and
1586             C<$float_pixel> can be a scalar or an array (eg C<@triple>).
1587              
1588             Returns undef if $hex_pixel is malformed.
1589              
1590             =cut
1591              
1592             sub hextripletofloat {
1593 4     4 1 6140 my $trip = shift;
1594 4         6 my $max = shift;
1595 4         4 my $rgb = undef;
1596 4         5 my @val;
1597              
1598 4 100       12 if(wantarray()) {
1599 2         3 my @set;
1600              
1601 2 100       12 if(ref($trip) eq 'ARRAY') {
    50          
1602 1         4 @val = ( $$trip[0], $$trip[1], $$trip[2]);
1603 1         2 map { s:/$:: } @val;
  3         8  
1604              
1605             } elsif($trip =~ m:^([0-9a-fA-F]+)/([0-9a-fA-F]+)/([0-9a-fA-F]+)/?$:) {
1606 1         6 @val = ( $1, $2, $3 );
1607             }
1608              
1609 2         9 @set = ( int_decvaltofloat(hex($val[0]), $max),
1610             int_decvaltofloat(hex($val[1]), $max),
1611             int_decvaltofloat(hex($val[2]), $max) );
1612 2         11 return @set;
1613             }
1614              
1615 2 100       14 if(ref($trip) eq 'ARRAY') {
    50          
1616 1         30 @val = ( $$trip[0], $$trip[1], $$trip[2]);
1617 1         4 map { s:/$:: } @val;
  3         8  
1618 1         5 $rgb = int_dectripletofloat(hex($val[0]),
1619             hex($val[1]),
1620             hex($val[2]), $max)
1621             } elsif($trip =~ m:^([0-9a-fA-F]+)/([0-9a-fA-F]+)/([0-9a-fA-F]+)/?$:) {
1622 1         6 $rgb = int_dectripletofloat(hex($1), hex($2), hex($3), $max);
1623             }
1624 2         7 return $rgb;
1625             } # end hextripletofloat
1626              
1627              
1628              
1629             ##################################################################
1630              
1631              
1632             =head2 $float_pixel = dectripletofloat( $dec_pixel, $max )
1633              
1634             =head2 $float_pixel = dectripletofloat( \@dec_pixel, $max )
1635              
1636             For a pixel string with decimal red green and blue values separated by
1637             colons (eg R:G:B), or an array of decimal values, and a max of 1 to 65535,
1638             convert to the comma separated floating point pixel format.
1639              
1640             No error is returned if $max is outside of the allowed range, but 0 will
1641             kill the program. Any value larger than max is clipped.
1642              
1643             C<$dec_pixel> can be a scalar or an array ref (eg C<\@triple>) and
1644             C<$float_pixel> can be a scalar or an array (eg C<@triple>).
1645              
1646             Returns undef if $dec_pixel is malformed.
1647              
1648             =cut
1649              
1650             # R:G:B, max 1 to 65535
1651             sub dectripletofloat {
1652 4     4 1 8297 my $trip = shift;
1653 4         10 my $max = shift;
1654 4         8 my $rgb = undef;
1655              
1656 4 100       17 if(wantarray()) {
1657 2         5 my @set;
1658              
1659 2 100       46 if(ref($trip) eq 'ARRAY') {
    50          
1660 1         5 @set = ( int_decvaltofloat($$trip[0], $max),
1661             int_decvaltofloat($$trip[1], $max),
1662             int_decvaltofloat($$trip[2], $max) );
1663              
1664             } elsif($trip =~ m/^(\d+):(\d+):(\d+):?$/) {
1665 1         6 @set = ( int_decvaltofloat($1, $max),
1666             int_decvaltofloat($2, $max),
1667             int_decvaltofloat($3, $max) );
1668             }
1669 2         12 return @set;
1670             }
1671              
1672 2 100       28 if(ref($trip) eq 'ARRAY') {
    50          
1673 1         7 $rgb = int_dectripletofloat($$trip[0],
1674             $$trip[1],
1675             $$trip[2], $max);
1676             } elsif($trip =~ m/^(\d+):(\d+):(\d+):?$/) {
1677 1         6 $rgb = int_dectripletofloat($1, $2, $3, $max);
1678             }
1679 2         8 return $rgb;
1680             }
1681              
1682              
1683              
1684             ##################################################################
1685              
1686              
1687             =head2 $float_pixel = hexvaltofloat( $hex_val, $max )
1688              
1689             For a pixel value in hexadecimal and a max of 1 to 65535,
1690             convert to the comma separated floating point pixel value format.
1691              
1692             No error is returned if $max is outside of the allowed range, but 0 will
1693             kill the program. Any value larger than max is clipped.
1694              
1695             Returns undef if $hex_pixel is malformed.
1696              
1697             =cut
1698              
1699             sub hexvaltofloat {
1700 2     2 1 965 my $val = shift;
1701 2         6 my $max = shift;
1702 2         3 my $fl = undef;
1703              
1704             # allow trailing slash, since we use them
1705 2 50       13 if($val =~ m:^([a-fA-F0-9]+)/?$:) {
1706 2         10 $fl = int_decvaltofloat(hex($1), $max);
1707             }
1708              
1709 2         6 return $fl;
1710             } # end &hexvaltofloat
1711              
1712              
1713              
1714             ##################################################################
1715              
1716              
1717             =head2 $float_pixel = decvaltofloat( $dec_val, $max )
1718              
1719             For a pixel value in decimal and a max of 1 to 65535,
1720             convert to the comma separated floating point pixel value format.
1721              
1722             No error is returned if $max is outside of the allowed range, but 0 will
1723             kill the program. Any value larger than max is clipped.
1724              
1725             Returns undef if $dec_pixel is malformed.
1726              
1727             =cut
1728              
1729             sub decvaltofloat {
1730 2     2 1 1446 my $val = shift;
1731 2         3 my $max = shift;
1732 2         3 my $fl = undef;
1733              
1734             # allow trailing colon, since we use them
1735 2 50       8 if($val =~ /^(\d+):?$/) {
1736 2         5 $fl = int_decvaltofloat($1, $max);
1737             }
1738              
1739 2         5 return $fl;
1740             } # end &decvaltofloat
1741              
1742              
1743              
1744             ##################################################################
1745              
1746              
1747             =head2 $dec_pixel = floattripletodec( \@float_pixel, $max )
1748              
1749             =head2 $dec_pixel = floattripletodec( $float_pixel, $max )
1750              
1751             For a pixel string with floating red green and blue values separated by
1752             commas (eg R:G:B), and max 1 to 65535, convert to the colon separated
1753             decimal pixel format. No error is returned
1754             if $max is outside of the allowed range, but 0 will kill the program.
1755             Any value larger than max is clipped.
1756              
1757             C<$float_pixel> can be a scalar or an array ref (eg C<\@triple>) and
1758             C<$dec_pixel> can be a scalar or an array (eg C<@triple>).
1759              
1760             Returns undef if $float_pixel is malformed.
1761              
1762             =cut
1763              
1764             sub floattripletodec {
1765 0     0 1 0 my $trip = shift;
1766 0         0 my $max = shift;
1767 0         0 my $rgb = undef;
1768              
1769 0 0       0 if(wantarray()) {
1770 0         0 my @set;
1771              
1772 0 0       0 if(ref($trip) eq 'ARRAY') {
    0          
1773 0         0 @set = ( int_floatvaltodec($$trip[0], $max),
1774             int_floatvaltodec($$trip[1], $max),
1775             int_floatvaltodec($$trip[2], $max) );
1776              
1777             } elsif($trip =~ m/^([.\d+]),([.\d+]),([.\d+]),?$/) {
1778 0         0 @set = ( int_floatvaltodec($1, $max),
1779             int_floatvaltodec($2, $max),
1780             int_floatvaltodec($3, $max) );
1781             }
1782 0         0 return @set;
1783             }
1784              
1785 0 0       0 if(ref($trip) eq 'ARRAY') {
    0          
1786 0         0 $rgb = int_floattripletodec($$trip[0],
1787             $$trip[1],
1788             $$trip[2], $max);
1789             } elsif($trip =~ m/^([.\d+]),([.\d+]),([.\d+]),?$/) {
1790 0         0 $rgb = int_floattripletodec($1, $2, $3, $max);
1791             }
1792 0         0 return $rgb;
1793              
1794             } # end &floattripletodec
1795              
1796              
1797              
1798             ##################################################################
1799              
1800              
1801             =head2 $hex_pixel = floattripletohex( \@float_pixel, $max )
1802              
1803             =head2 $hex_pixel = floattripletohex( $float_pixel, $max )
1804              
1805             For a pixel string with floating red green and blue values separated by
1806             commas (eg R:G:B), and max 1 to 65535, convert to the slash separated
1807             hex pixel format. No error is returned
1808             if $max is outside of the allowed range, but 0 will kill the program.
1809             Any value larger than max is clipped.
1810              
1811             C<$float_pixel> can be a scalar or an array ref (eg C<\@triple>) and
1812             C<$hex_pixel> can be a scalar or an array (eg C<@triple>).
1813              
1814             Returns undef if $float_pixel is malformed.
1815              
1816             =cut
1817              
1818             sub floattripletohex {
1819 0     0 1 0 my $trip = shift;
1820 0         0 my $max = shift;
1821 0         0 my $rgb = undef;
1822              
1823 0 0       0 if(wantarray()) {
1824 0         0 my @set;
1825              
1826 0 0       0 if(ref($trip) eq 'ARRAY') {
    0          
1827 0         0 @set = ( int_floatvaltohex($$trip[0], $max),
1828             int_floatvaltohex($$trip[1], $max),
1829             int_floatvaltohex($$trip[2], $max) );
1830              
1831             } elsif($trip =~ m/^([.\d+]),([.\d+]),([.\d+]),?$/) {
1832 0         0 @set = ( int_floatvaltohex($1, $max),
1833             int_floatvaltohex($2, $max),
1834             int_floatvaltohex($3, $max) );
1835             }
1836 0         0 return @set;
1837             }
1838              
1839 0 0       0 if(ref($trip) eq 'ARRAY') {
    0          
1840 0         0 $rgb = int_floattripletohex($$trip[0],
1841             $$trip[1],
1842             $$trip[2], $max);
1843             } elsif($trip =~ m/^([.\d+]),([.\d+]),([.\d+]),?$/) {
1844 0         0 $rgb = int_floattripletohex($1, $2, $3, $max);
1845             }
1846 0         0 return $rgb;
1847              
1848             } # end &floattripletodec
1849              
1850              
1851              
1852             ##################################################################
1853              
1854              
1855             =head2 $dec_pixel = floatvaltodec( $float_pixel, $max )
1856              
1857             For a floating point pixel value and max 1 to 65535, convert to the decimal
1858             pixel format. No error is returned
1859             if $max is outside of the allowed range, but 0 will kill the program.
1860             Any value larger than max is clipped.
1861              
1862             Returns undef if $float_pixel is malformed.
1863              
1864             =cut
1865              
1866             sub floatvaltodec {
1867 3     3 1 1251 my $trip = shift;
1868 3         6 my $max = shift;
1869 3         7 my $p = undef;
1870              
1871 3         10 $p = int_floatvaltodec($trip, $max);
1872            
1873 3         11 return $p;
1874              
1875             } # end &floatvaltodec
1876              
1877              
1878              
1879             ##################################################################
1880              
1881              
1882             =head2 $hex_pixel = floatvaltohex( $float_pixel, $max )
1883              
1884             For a floating point pixel value and max 1 to 65535, convert to the hexadecimal
1885             pixel format. No error is returned
1886             if $max is outside of the allowed range, but 0 will kill the program.
1887             Any value larger than max is clipped.
1888              
1889             Returns undef if $float_pixel is malformed.
1890              
1891             =cut
1892              
1893             sub floatvaltohex {
1894 3     3 1 1449 my $trip = shift;
1895 3         14 my $max = shift;
1896 3         5 my $p = undef;
1897              
1898 3         8 $p = int_floatvaltohex($trip, $max);
1899            
1900 3         10 return $p;
1901              
1902             } # end &floatvaltohex
1903              
1904              
1905              
1906             ##################################################################
1907              
1908              
1909             =head2 $status = comparefloattriple(\@a, \@b)
1910              
1911             =head2 $status = comparefloattriple($a, $b)
1912              
1913             Returns -1, 0, or 1 much like <=>, but allows a variance of up
1914             to half 1/65535. Checks only a single pair at a time (red value
1915             of $a to red value of $b, etc) and stops at the first obvious
1916             non-equal value. Does not check if any value is outside of 0.0
1917             to 1.0. Returns undef if either triple can't be understood.
1918              
1919             =cut
1920              
1921             sub comparefloattriple {
1922 4     4 1 1806 my $a = shift;
1923 4         8 my $b = shift;
1924 4         5 my $v;
1925              
1926 0         0 my $a_r; my $a_g; my $a_b;
  0         0  
1927 0         0 my $b_r; my $b_g; my $b_b;
  0         0  
  0         0  
1928              
1929 4         10 ($a_r, $a_g, $a_b) = explodetriple($a);
1930 4         9 ($b_r, $b_g, $b_b) = explodetriple($b);
1931              
1932 4 50 33     21 if(!defined($a_r) or !defined($b_r)) { return undef; }
  0         0  
1933              
1934 4         22 $v = comparefloatval($a_r, $b_r);
1935 4 50       8 if($v) { return $v; }
  0         0  
1936              
1937 4         8 $v = comparefloatval($a_g, $b_g);
1938 4 100       9 if($v) { return $v; }
  1         4  
1939              
1940 3         6 $v = comparefloatval($a_b, $b_b);
1941 3         12 return $v;
1942             } # end &comparefloattriple
1943              
1944              
1945              
1946             ##################################################################
1947              
1948              
1949             =head2 $status = comparefloatval($a, $b)
1950              
1951             Returns -1, 0, or 1 much like <=>, but allows a variance of up
1952             to half 1/65535. Checks only a single pair (not an RGB triple),
1953             does not check if either value is outside of 0.0 to 1.0.
1954              
1955             =cut
1956              
1957             sub comparefloatval {
1958 15     15 1 1600 my $a = shift;
1959 15         16 my $b = shift;
1960             # 1/65535 ~ .0000152590; .0000152590 / 2 = .0000076295
1961 15         15 my $alpha = 0.0000076295;
1962              
1963             # eat our own dog food for indicating a float value
1964 15         76 $a =~ s/,$//;
1965 15         45 $b =~ s/,$//;
1966              
1967 15         26 my $low_a = $a - $alpha;
1968 15         19 my $hi_a = $a + $alpha;
1969              
1970 15 100       36 if($low_a > $b) { return 1; }
  2         6  
1971 13 100       25 if($hi_a < $b) { return -1; }
  2         5  
1972              
1973 11         22 return 0;
1974             } # end &comparefloatval
1975              
1976              
1977             ##################################################################
1978              
1979             =head2 $status = comparepixelval($a, $max_a, $b, $max_b)
1980              
1981             Returns -1, 0, or 1 much like <=>, taking into account that
1982             each is really a fraction: C<$v / $max_v>. Decimal values should
1983             have a colon (eg "123:"), while hex values should have a slash
1984             (eg "7B/"). Uses integer comparisions and should not be used with
1985             floating point values. Max should always be a regular decimal integer.
1986             Checks only a single pair (not an RGB triple),
1987             does not enforce checks on the max values.
1988              
1989             This is a less forgiving comparison than C.
1990              
1991             =cut
1992              
1993             sub comparepixelval {
1994 4     4 1 1394 my $a = shift;
1995 4         5 my $a_m = shift;
1996 4         5 my $b = shift;
1997 4         5 my $b_m = shift;
1998              
1999             # eat our own dog food for indicating a dec / hex value
2000 4 100       16 if($a =~ s:/$::) {
2001 2         5 $a = hex($a);
2002             } else {
2003 2         7 $a =~ s/:$//;
2004             }
2005 4 100       11 if($b =~ s:/$::) {
2006 2         3 $b = hex($b);
2007             } else {
2008 2         6 $b =~ s/:$//;
2009             }
2010              
2011 4 100       8 if($a_m == $b_m) {
2012 2         6 return ($a <=> $b);
2013             }
2014              
2015             # simple way to get to common denominator
2016 2         3 $a = $a * $b_m;
2017 2         3 $b = $b * $a_m;
2018              
2019 2         5 return ($a <=> $b);
2020             } # end &comparepixelval
2021              
2022              
2023             ##################################################################
2024              
2025             =head2 $status = comparepixeltriple(\@a, $max_a, \@b, $max_b)
2026              
2027             =head2 $status = comparepixeltriple($a, $max_a, $b, $max_b)
2028              
2029             Returns -1, 0, or 1 much like <=>, taking into account that
2030             RGB each is really a fraction: C<$v / $max_v>. Decimal values should
2031             be colon separated (eg "123:1:1024" or terminated ["123:", "1:", "1024:"]),
2032             while hex values should have slashes
2033             (eg "7B/1/400" or ["7B/", "1/", "400/"]). Uses integer comparisions and
2034             should not be used with floating point values. Max should always be a
2035             regular decimal integer. Checks only a single pair at a time (red value
2036             of $a to red value of $b, etc) and stops at the first obvious
2037             non-equal value. Does not enforce checks on the max values.
2038             Returns undef if either triple can't be understood.
2039              
2040             This is a less forgiving comparison than C.
2041              
2042             =cut
2043              
2044             sub comparepixeltriple {
2045 4     4 1 1324 my $a = shift;
2046 4         6 my $a_m = shift;
2047 4         6 my $b = shift;
2048 4         4 my $b_m = shift;
2049 4         4 my $v;
2050              
2051 0         0 my $a_r; my $a_g; my $a_b;
  0         0  
2052 0         0 my $b_r; my $b_g; my $b_b;
  0         0  
  0         0  
2053              
2054 4         9 ($a_r, $a_g, $a_b) = explodetriple($a);
2055 4         8 ($b_r, $b_g, $b_b) = explodetriple($b);
2056              
2057 4 50 33     23 if(!defined($a_r) or !defined($b_r)) { return undef; }
  0         0  
2058              
2059             # eat our own dog food for indicating a dec / hex value
2060 4 100       12 if($a_r =~ s:/$::) { $a_r = hex($a_r); } else { $a_r =~ s/:$//; }
  2         4  
  2         6  
2061 4 100       9 if($a_g =~ s:/$::) { $a_g = hex($a_g); } else { $a_g =~ s/:$//; }
  2         2  
  2         6  
2062 4 100       11 if($a_b =~ s:/$::) { $a_b = hex($a_b); } else { $a_b =~ s/:$//; }
  2         2  
  2         5  
2063 4 100       27 if($b_r =~ s:/$::) { $b_r = hex($b_r); } else { $b_r =~ s/:$//; }
  2         4  
  2         5  
2064 4 100       9 if($b_g =~ s:/$::) { $b_g = hex($b_g); } else { $b_g =~ s/:$//; }
  2         2  
  2         5  
2065 4 100       10 if($b_b =~ s:/$::) { $b_b = hex($b_b); } else { $b_b =~ s/:$//; }
  2         1  
  2         5  
2066              
2067 4 100       9 if($a_m == $b_m) {
2068 2   66     23 return (($a_r <=> $b_r) or ($a_g <=> $b_g) or ($a_b <=> $b_b));
2069             }
2070              
2071             # simple way to get to common denominator
2072 2         3 $a_r = $a_r * $b_m;
2073 2         3 $b_r = $b_r * $a_m;
2074              
2075 2         2 $v = ($a_r <=> $b_r);
2076 2 50       4 if($v) { return $v; }
  0         0  
2077              
2078 2         2 $a_g = $a_g * $b_m;
2079 2         3 $b_g = $b_g * $a_m;
2080              
2081 2         2 $v = ($a_g <=> $b_g);
2082 2 50       8 if($v) { return $v; }
  0         0  
2083              
2084 2         3 $a_b = $a_b * $b_m;
2085 2         2 $b_b = $b_b * $a_m;
2086              
2087 2         5 return ($a_g <=> $b_g);
2088              
2089             } # end &comparepixeltriple
2090              
2091              
2092             ##################################################################
2093              
2094             =head2 ($r, $g, $b) = explodetriple( \@pixel );
2095              
2096             =head2 ($r, $g, $b) = explodetriple( $pixel );
2097              
2098             Helper function to separate the values of an RGB pixel, either in
2099             array or string format. Float pixels have comma separated triples,
2100             and comma suffixed single values. Decimal pixels use colons, and
2101             hex pixels use slashes. Does not enforce values to be within the
2102             allowed range.
2103              
2104             Returns undef if the pixel could not be understood.
2105              
2106             =cut
2107              
2108             sub explodetriple {
2109 158     158 1 1533 my $a = shift;
2110 158         158 my $a_r;
2111             my $a_g;
2112 0         0 my $a_b;
2113              
2114 158 100       272 if(ref($a) eq 'ARRAY') {
2115 49         66 $a_r = $$a[0];
2116 49         65 $a_g = $$a[1];
2117 49         70 $a_b = $$a[2];
2118             } else {
2119 109 100       478 if($a =~ m/^(\d+):(\d+):(\d+):?$/) {
    100          
    50          
2120 58         96 $a_r = $1 .':';
2121 58         78 $a_g = $2 .':';
2122 58         82 $a_b = $3 .':';
2123             } elsif ($a =~ m:^([0-9a-fA-F]+)/([0-9a-fA-F]+)/([0-9a-fA-F]+)/?$:) {
2124 27         43 $a_r = $1 .'/';
2125 27         35 $a_g = $2 .'/';
2126 27         35 $a_b = $3 .'/';
2127             } elsif ($a =~ m/^([.0-9]+),([.0-9]+),([.0-9]+),?$/) {
2128 24         42 $a_r = $1 .',';
2129 24         45 $a_g = $2 .',';
2130 24         40 $a_b = $3 .',';
2131             } else {
2132 0         0 return undef;
2133             }
2134             }
2135              
2136 158         660 return ($a_r, $a_g, $a_b);
2137              
2138             } # end &explodetriple
2139              
2140              
2141             ##################################################################
2142              
2143             =head2 @pixel = rescaletriple( \@pixel, $old_max, $new_max );
2144              
2145             =head2 $pixel = rescaletriple( $pixel, $old_max, $new_max );
2146              
2147             Helper function to rescale the values of an RGB pixel to a new max
2148             value, either in array or string format. Float pixels do not need
2149             rescaling. Decimal pixels use colons as separator / suffix, and
2150             hex pixels use slashes. Does not enforce values to be within the
2151             allowed range.
2152              
2153             Returns undef if the pixel could not be understood.
2154              
2155             =cut
2156              
2157             sub rescaletriple {
2158 6     6 1 2446 my $p = shift;
2159 6         7 my $o_m = shift;
2160 6         7 my $n_m = shift;
2161 6         8 my $p_r;
2162             my $p_g;
2163 0         0 my $p_b;
2164 0         0 my $enc;
2165 0         0 my $r;
2166              
2167 6         22 ($p_r, $p_g, $p_b) = explodetriple($p);
2168              
2169 6 50       39 if(!defined($p_r)) { return undef; }
  0         0  
2170              
2171 6 100       22 if($p_r =~ /:/) {
    100          
2172 3         4 $enc = 'dec';
2173             } elsif ($p_r =~ m:/:) {
2174 2         3 $enc = 'hex';
2175             }
2176              
2177             # undef if it was a float triple
2178 6 100       13 if(defined($enc)) {
2179 5         10 $p_r = rescaleval($p_r, $o_m, $n_m);
2180 5         11 $p_g = rescaleval($p_g, $o_m, $n_m);
2181 5         11 $p_b = rescaleval($p_b, $o_m, $n_m);
2182             }
2183              
2184 6 100       11 if(wantarray()) {
2185 2         9 return ($p_r, $p_g, $p_b);
2186             } else {
2187 4         11 $r = "$p_r$p_g$p_b";
2188 4         5 chop $r;
2189 4         10 return $r;
2190             }
2191              
2192             } # end &rescaletriple
2193              
2194              
2195             ##################################################################
2196              
2197              
2198             =head2 $value = rescaleval( $value, $old_max, $new_max );
2199              
2200             Helper function to rescale a single value to a new max
2201             value, either in array or string format. Float values do not need
2202             rescaling. Decimal values use colons as suffix, and
2203             hex values use slashes. Does not enforce values to be within the
2204             allowed range.
2205              
2206             Returns undef if the value could not be understood.
2207              
2208             =cut
2209              
2210             sub rescaleval {
2211 19     19 1 1590 my $v = shift;
2212 19         19 my $o_m = shift;
2213 19         16 my $n_m = shift;
2214 19         23 my $r;
2215              
2216 19 100       36 if($o_m == $n_m) {
2217             # no change
2218 6         11 return $v;
2219             }
2220              
2221 13 100       54 if($v =~ /:$/) {
    100          
    50          
2222 7         18 $v =~ s/:$//;
2223              
2224 7         20 $r = int_floatvaltodec( ($v / $o_m), $n_m);
2225             } elsif ($v =~ m:/$:) {
2226 5         16 $v =~ s:/$::; $v = hex($v);
  5         9  
2227              
2228 5         16 $r = int_floatvaltohex( ($v / $o_m), $n_m);
2229             } elsif ($v =~ m/,$/) {
2230             # no change
2231 1         4 return $v;
2232             } else {
2233 0         0 return undef;
2234             }
2235              
2236 12         27 return $r;
2237             } # end &rescaleval
2238              
2239              
2240              
2241             ##################################################################
2242              
2243              
2244             =head2 $header = makepnmheader( \%info );
2245              
2246             =head2 $header = makepnmheader($type, $width, $height, $max);
2247              
2248             Takes a hash reference similar to C or
2249             C would return and makes a PBM, PGM, or PPM header string
2250             from it. C first looks for a B in the hash and
2251             uses that, otherwise it expects B and B to be set in the hash
2252             (and it will set B for you then). If there is a non-empty
2253             B in the hash, that will be put in as one or more lines
2254             of comments. There must be sizes for B and B, and if
2255             the image is not a bitmap, there should be one for B. A missing
2256             B will result in C guessing 255 and setting
2257             B accordingly.
2258              
2259             The numerical types are 1 for ASCII PBM, 2 for ASCII PGM, 3 for
2260             ASCII PPM, 4 for raw PBM, 5 for raw PGM, and 6 for raw PPM. The
2261             maxvalue is ignored for PBM files.
2262              
2263             Returns the header string if successful.
2264             Returns undef if there is an error.
2265              
2266             =cut
2267              
2268             sub makepnmheader {
2269 16     16 1 4866 my $type;
2270             my $w;
2271 0         0 my $h;
2272 0         0 my $max;
2273              
2274 16         22 my $hr = shift; # header hash ref
2275 16         25 my $head = '';
2276 16         22 my $com = '';
2277 16         18 my $setmax;
2278              
2279 16 100       46 if(ref($hr) ne 'HASH') {
2280 2         3 $type = $hr;
2281 2         2 $w = shift;
2282 2         2 $h = shift;
2283 2         3 $max = shift;
2284              
2285 2 50 33     11 if(!defined($type) or !defined($w) or !defined($h)) {
      33        
2286 0         0 return undef;
2287             }
2288              
2289 2 50       10 if($type !~ /^[123456]$/) {
2290 0         0 return undef;
2291             }
2292 2 50       9 if($w !~ /^\d+$/) {
2293 0         0 return undef;
2294             }
2295 2 50       7 if($h !~ /^\d+$/) {
2296 0         0 return undef;
2297             }
2298              
2299             } else {
2300              
2301 14 50 33     120 if (defined($$hr{width}) and $$hr{width} =~ /^\d+$/) {
2302 14         29 $w = $$hr{width};
2303             } else {
2304 0         0 return undef;
2305             }
2306              
2307 14 50 33     103 if (defined($$hr{height}) and $$hr{height} =~ /^\d+$/) {
2308 14         22 $h = $$hr{height};
2309             } else {
2310 0         0 return undef;
2311             }
2312              
2313 14 100 66     83 if (defined($$hr{max}) and $$hr{max} =~ /^\d+$/) {
2314 12         20 $max = $$hr{max};
2315             } else {
2316 2         3 $max = 255;
2317 2         2 $setmax = 1;
2318             }
2319              
2320 14 100 66     89 if (defined($$hr{type}) and $$hr{type} =~ /^[123456]$/) {
    50 33        
      33        
2321 12         22 $type = $$hr{type};
2322              
2323             } elsif(defined($$hr{bgp}) and defined($$hr{format}) and
2324             $$hr{bgp} =~ /^([bgp])$/i) {
2325            
2326 2         5 my $bgp = lc($1);
2327 2 50       23 if ($bgp eq 'b') {
    50          
2328 0         0 $type = 1;
2329             } elsif ($bgp eq 'g') {
2330 2         3 $type = 2;
2331             } else {
2332 0         0 $type = 3;
2333             }
2334              
2335 2 100       30 if ($$hr{format} =~ /raw/i) {
    50          
2336 1         3 $type += 3;
2337             } elsif ($$hr{format} !~ /ascii/i) {
2338 0         0 return undef;
2339             }
2340              
2341 2         4 $$hr{type} = $type;
2342             } else {
2343 0         0 return undef;
2344             }
2345              
2346 14 100 66     72 if(defined($$hr{comments}) and length($$hr{comments})) {
2347 11         17 $com = $$hr{comments};
2348 11         62 $com =~ s/^/#/gm;
2349 11 50       39 if(substr($com, -1, 1) ne "\n") {
2350 11         17 $com .= "\n";
2351             };
2352             }
2353              
2354             }
2355              
2356 16 50 33     77 if($w < 1 or $h < 1) {
2357 0         0 return undef;
2358             }
2359              
2360 16         74 $head = "P$type\n$com";
2361 16         29 $head .= "$w $h\n";
2362              
2363 16 100 66     82 if($type != 1 and $type != 4) {
2364 14 50 33     110 if(!defined($max) or $max < 1 or $max > 65535) {
      33        
2365 0         0 return undef;
2366             }
2367 14         23 $head .= "$max\n";
2368 14 100       32 if($setmax) {
2369 1         3 $$hr{max} = $max;
2370             }
2371             }
2372              
2373 16         59 return $head;
2374             } # end &makepnmheader
2375              
2376             ##################################################################
2377              
2378              
2379             =head2 $block = encodepixels($format, $max, \@pixels);
2380              
2381             Encodes pixels into 'raw' or 'ascii' PBM/PGM/PPM format. The
2382             supplied pixels can be decimal, hex, or floating point values.
2383             Decimal and hex values greater than $max will be clipped to $max.
2384             A $max of 1 will encode a PBM file, otherwise the first pixel
2385             will be examined to determine if it is PGM or PPM data.
2386              
2387             The array of pixels can be one, two, or three dimensional. A
2388             two dimensional array is prefered and will be considered to
2389             be same format C and C uses.
2390             There, the @pixels structure is an array of rows, each row
2391             being an array of pixel strings. This function will expect
2392             every row to have the same number of pixels as the first. If
2393             subsequent rows have different amounts, the results can be
2394             unpredictable. Missing values will be assumed to be 0 if it
2395             it tries to read past the end of the array.
2396              
2397             A three dimensional @pixels structure is considered to be an
2398             array of rows, each row being an array of PPM pixel values.
2399              
2400             A one dimensional @pixels structure is an array of pixel strings
2401             with no hint of row and column structure.
2402             With a one dimensional array, raw PBM files will be
2403             misencoded if number of columns is not a multiple of 8 and the data
2404             represents more than one row: each row is supposed to be padded to
2405             a multiple of 8 bits.
2406              
2407             Returns undef if $encoding is not recognized, $max is out of bounds
2408             (1 to 65535, inclusive), or @pixels cannot be understood.
2409              
2410             =cut
2411              
2412             # $block = encodepixels($encoding, $max, \@pixels);
2413             sub encodepixels {
2414 21     21 1 8005 my $fmt = shift;
2415 21         24 my $max = shift;
2416 21         24 my $p_r = shift;
2417 21         25 my $i;
2418              
2419 21         37 $i = int_prelim_inspect($fmt, $max, $p_r);
2420              
2421 21 50 33     99 if(exists($$i{error}) and length($$i{error})) {
2422             # we don't return a meaningful error
2423 0         0 return undef;
2424             }
2425              
2426 21         48 return int_encodepixels($$i{type}, $p_r, $$i{deep}, $$i{encode}, $max);
2427             } # end &encodepixels
2428              
2429              
2430             ##################################################################
2431              
2432              
2433             =head2 $return = writepnmfile(\*PNM, \%info, \@pixels);
2434              
2435             Writes an entire PNM image to a given filehandle. Sometimes more
2436             memory efficient than a C C pair
2437             (by encoding row by row when possible). Does not do an C.
2438              
2439             Writes are done using C so see that the documentation for
2440             that function for warnings about mixing with other file operations.
2441              
2442             Returns undef if $encoding is not recognized, $max is out of bounds
2443             (1 to 65535, inclusive), or @pixels cannot be understood. Returns
2444             number of bytes written with positive values for complete success,
2445             0 for no bytes successfully written, and -1 * bytes written for
2446             a partial success (eg, ran out of disk space).
2447              
2448             =cut
2449              
2450             # $return = writepnmfile(\*PNM, \%info, \@pixels);
2451             sub writepnmfile {
2452 5     5 1 510 my $f_r = shift; # file
2453 5         7 my $i_r = shift; # image info
2454 5         7 my $p_r = shift; # array of pixels
2455 5         8 my $header;
2456             my $inspect;
2457 0         0 my $fmt;
2458 0         0 my $max;
2459 0         0 my $encode;
2460 0         0 my $deep;
2461 0         0 my $type;
2462 0         0 my $bytes;
2463 0         0 my $rc;
2464 0         0 my $row;
2465 0         0 my $pixels;
2466              
2467 5 50 33     44 if((ref($f_r) ne 'GLOB') or (ref($i_r) ne 'HASH') or (ref($p_r) ne 'ARRAY')) {
      33        
2468 0         0 return undef;
2469             }
2470              
2471 5         9 $header = makepnmheader($i_r);
2472 5 50       18 if(!defined($header)) {
2473 0         0 return undef;
2474             }
2475              
2476 5         7 $fmt = $$i_r{format};
2477 5         10 $max = $$i_r{max};
2478              
2479 5 50       13 if(!defined($fmt)) {
2480 5 100       12 if($$i_r{type} > 3) {
2481 4         8 $fmt = 'raw';
2482             } else {
2483 1         3 $fmt = 'ascii';
2484             }
2485             }
2486 5         12 $inspect = int_prelim_inspect($fmt, $max, $p_r);
2487              
2488 5 50 33     30 if(exists($$inspect{error}) and length($$inspect{error})) {
2489             # last undef case
2490 0         0 return undef;
2491             }
2492              
2493 5         7 $encode = $$inspect{encode};
2494 5         10 $deep = $$inspect{deep};
2495 5         7 $type = $$inspect{type};
2496              
2497 5         178 $rc = syswrite($f_r, $header);
2498 5 50       15 if($rc != length($header)) {
2499 0         0 return ($rc * -1);
2500             }
2501 5         7 $bytes = $rc;
2502              
2503 5 100       11 if($deep eq '1d') {
2504             # oh well, have to encode it all
2505 3         9 $pixels = int_encodepixels($type, $p_r, $deep, $encode, $max);
2506 3         41 $rc = syswrite($f_r, $pixels);
2507 3         4 $bytes += $rc;
2508 3 50       9 if($rc != length($pixels)) {
2509 0         0 return ($bytes * -1);
2510             }
2511 3         17 return $bytes;
2512             }
2513              
2514 2         5 for $row (@$p_r) {
2515 15         42 $pixels = int_encodepixels($type, [ $row ], $deep, $encode, $max);
2516 15         193 $rc = syswrite($f_r, $pixels);
2517 15         19 $bytes += $rc;
2518 15 50       49 if($rc != length($pixels)) {
2519 0         0 return ($bytes * -1);
2520             }
2521             }
2522              
2523 2         13 return $bytes;
2524             } # end &writepnmfile
2525              
2526             ##################################################################
2527              
2528              
2529             =head2 inspectpixels($format, $max, \@pixels, \%report );
2530              
2531             Performs all of the argument checks of C, and
2532             if no errors are found it does a thorough inspection all pixels
2533             looking for inconsitencies.
2534              
2535             Returns undef if there was an error, and the number of pixels
2536             if it succeeded. (An image with no pixels is considered an error.)
2537             The report hash will contain information gleaned from the inspection.
2538              
2539             =over
2540              
2541             =item *
2542              
2543             $report{error}
2544              
2545             Set if there is an error with a description of the problem.
2546              
2547             =item *
2548              
2549             $report{where}
2550              
2551             Set if there is an error with the array coordinates of the problem.
2552              
2553             =item *
2554              
2555             $report{deep}
2556              
2557             Set to '1d', '2d', or '3d' to describe the pixel array.
2558              
2559             =item *
2560              
2561             $report{width}
2562              
2563             Width of the pixel array (if not '1d' deep).
2564              
2565             =item *
2566              
2567             $report{height}
2568              
2569             Height of the pixel array (if not '1d' deep).
2570              
2571             =item *
2572              
2573             $report{pixels}
2574              
2575             Expected number pixels.
2576              
2577             =item *
2578              
2579             $report{bytes}
2580              
2581             Number of bytes needed to encode each pixel, if in raw. Will be 1
2582             for PBM files.
2583              
2584             =item *
2585              
2586             $report{encode}
2587              
2588             The 'float', 'dec', or 'hex' encoding of the first pixel. All others
2589             are expected to match this.
2590              
2591             =item *
2592              
2593             $report{first}
2594              
2595             First pixel found.
2596              
2597             =item *
2598              
2599             $report{type}
2600              
2601             The numerical type of the format. Might be wrong if B<$report{first}>
2602             is unset. Will contain one of "1" for ASCII PBM, "2" for ASCII PGM, "3" for
2603             ASCII PPM, "4" for raw PBM, "5" for raw PGM, or "6" for raw PPM.
2604              
2605             =item *
2606              
2607             $report{checked}
2608              
2609             Number of pixels checked.
2610              
2611             =back
2612              
2613             =cut
2614              
2615             sub inspectpixels {
2616 10     10 1 15769 my $fmt = shift;
2617 10         18 my $max = shift;
2618 10         15 my $p_r = shift;
2619 10         16 my $i_r = shift;
2620              
2621             # int_prelim_inspect returns a hash ref
2622 10         15 %$i_r = %{int_prelim_inspect($fmt, $max, $p_r)};
  10         27  
2623              
2624 10 100 66     88 if(exists($$i_r{error}) and length($$i_r{error})) {
2625             # the inspection report error explains the problem
2626 2         8 return undef;
2627             }
2628              
2629 8         11 my $w = 0;
2630 8         10 my $h = 0;
2631 8         9 my $checked = 0;
2632 8         8 my $cur;
2633             my @rgb;
2634              
2635 8 100       23 if($$i_r{deep} eq '1d') { $cur = $$p_r[$w]; }
  2         4  
2636 6         12 else { $cur = $$p_r[$h][$w]; }
2637              
2638             CHECK_ALL:
2639 8         19 while(defined($cur)) {
2640              
2641 32 100 66     159 if($$i_r{deep} eq '3d') {
    50 66        
    100          
    50          
2642 11 100 66     21 if(ref($cur) ne 'ARRAY') {
  10 50       41  
    100          
2643 1         4 $$i_r{error} = 'rgb pixel not array';
2644              
2645             } elsif ($#{$cur} != 2) {
2646 0         0 $$i_r{error} = 'rgb pixel array wrong size';
2647              
2648             } elsif (!checkval($$cur[0], $$i_r{encode}) or
2649             !checkval($$cur[1], $$i_r{encode}) or
2650             !checkval($$cur[2], $$i_r{encode})) {
2651 1         3 $$i_r{error} = 'rgb pixel array encoded wrong';
2652              
2653             }
2654             } # 3d
2655              
2656             elsif(ref($cur) ne '') {
2657 0         0 $$i_r{error} = 'pixel not scalar';
2658             }
2659              
2660             elsif(($$i_r{type} == 6) or ($$i_r{type} == 3)) { # pixmap
2661 8         18 @rgb = explodetriple($cur);
2662              
2663 8 50 33     29 if ($#rgb != 2) {
    100          
2664 0         0 $$i_r{error} = 'rgb pixel not a triple';
2665              
2666             } elsif (!checkval($rgb[0], $$i_r{encode}) or
2667             !checkval($rgb[1], $$i_r{encode}) or
2668             !checkval($rgb[2], $$i_r{encode})) {
2669 1         2 $$i_r{error} = 'rgb pixel encoded wrong';
2670             }
2671             } # pixmap
2672              
2673             elsif(($$i_r{type} == 5) or ($$i_r{type} == 2)) { # graymap
2674 13 100       31 if (!checkval($cur, $$i_r{encode})) {
2675 1         3 $$i_r{error} = 'gray pixel encoded wrong';
2676             }
2677             } # graymap
2678              
2679 32 100       92 if(length($$i_r{error})) {
2680 4         7 $$i_r{checked} = $checked;
2681 4         13 $$i_r{where} = "$h,$w";
2682 4         16 return undef;
2683             }
2684              
2685             # that pixel works out okay
2686 28         26 $checked ++;
2687              
2688 28 100       61 if($checked == $$i_r{pixels}) {
2689 3         8 last CHECK_ALL;
2690             }
2691              
2692 25 100       49 if($$i_r{deep} eq '1d') {
2693 8         8 $w ++;
2694 8         20 $cur = $$p_r[$w];
2695             } else {
2696 17         13 $w ++;
2697 17 100       39 if($w > ($$i_r{width} - 1)) {
2698 5 50       11 if(exists($$p_r[$h][$w])) {
2699 0         0 $$i_r{error} = 'row too wide';
2700 0         0 last CHECK_ALL;
2701             } else {
2702 5         5 $w = 0;
2703 5         8 $h ++;
2704             }
2705             }
2706 17 50       42 if (!exists($$p_r[$h][$w])) {
2707 0         0 $$i_r{error} = 'row not wide enough';
2708 0         0 last CHECK_ALL;
2709             }
2710 17         40 $cur = $$p_r[$h][$w];
2711             }
2712             } # while CHECK_ALL
2713              
2714 4         9 $$i_r{checked} = $checked;
2715              
2716 4 100       13 if($checked != $$i_r{pixels}) {
2717 1         3 $$i_r{error} = 'pixel undef';
2718 1         5 $$i_r{where} = "$h,$w";
2719 1         3 return undef;
2720             }
2721              
2722 3         16 return $$i_r{pixels};
2723             } # end &inspectpixels
2724              
2725              
2726             ##################################################################
2727              
2728              
2729             =head2 checkval($value, $encode);
2730              
2731             Checks that a value (not an RGB triple) conforms to an encoding of
2732             'float', 'dec', or 'hex'. Returns undef if there was an error, and a
2733             positive value otherwise.
2734              
2735             =cut
2736              
2737             sub checkval {
2738 65     65 1 77 my $v = shift;
2739 65         63 my $enc = shift;
2740              
2741 65 50 33     186 if(!defined($v) or !defined($enc)) {
2742 0         0 return undef;
2743             }
2744              
2745 65 100       151 if($enc eq 'float') {
    100          
    50          
2746 7 50       25 if($v =~ /^[.\d]+,$/) {
2747 7         20 return 1;
2748             }
2749             } elsif($enc eq 'dec') {
2750 34 100       149 if($v =~ /^[\d]+:$/) {
2751 31         137 return 1;
2752             }
2753             } elsif($enc eq 'hex') {
2754 24 50       61 if($v =~ m:^[\da-fA-F]+/$:) {
2755 24         83 return 1;
2756             }
2757             }
2758              
2759 3         18 return undef;
2760             } # sub &checkval
2761              
2762             ##################################################################
2763              
2764              
2765              
2766              
2767             =head1 PORTABILITY
2768              
2769             This code is pure perl for maximum portability, as befitting the
2770             PBM/PGM/PPM philosophy.
2771              
2772             =head1 CHANGES
2773              
2774             2.0 is a nearly complete rewrite fixing the bugs that arose from
2775             not taking the max value into account. Only the code to read an
2776             image header is taken from 1.x. None of the function names are the
2777             same and most of the interface has changed.
2778              
2779             1.05 fixes two comment related bugs (thanks Ladislav Sladecek!) and
2780             some error reporting bugs with bad filehandles.
2781              
2782             =head1 BUGS
2783              
2784             No attempt is made to deal with comments after the header in ASCII
2785             formatted files.
2786              
2787             No attempt is made to handle the PAM format.
2788              
2789             Pure perl code makes this slower than it could be.
2790              
2791             Not all PBM/PGM/PPM tools are safe for images from untrusted sources
2792             but this one should be. Be careful what you use this with. This
2793             software can create raw files with multibyte (max over 255) values, but
2794             some older PBM/PGM/PPM tools can only handle ASCII files for large
2795             max values (or cannot handle it at all).
2796              
2797             =head1 SEE ALSO
2798              
2799             The manual pages for B(5), B(5), and B(5) define the
2800             various file formats. The netpbm and pbmplus packages include a host
2801             of interesting PNM tools.
2802              
2803             =head1 COPYRIGHT
2804              
2805             Copyright 2012, 2003 Benjamin Elijah Griffin / Eli the Bearded
2806             Eelijah@cpan.orgE
2807              
2808             This library is free software; you can redistribute it and/or modify it
2809             under the same terms as Perl itself.
2810              
2811             =cut
2812              
2813             1;
2814              
2815             __END__