| 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__ |