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